From aff7d92e1f6c7bcb8cabca6d9c564cf27154f5b1 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Thu, 8 Oct 2026 01:14:51 +0100 Subject: [PATCH 01/28] Add executable Lean WHIR model and checked algebraic properties --- verification/whir/.gitignore | 3 + verification/whir/Audit.lean | 22 ++ verification/whir/Main.lean | 101 +++++++ verification/whir/README.md | 96 ++++++ verification/whir/Whir.lean | 8 + verification/whir/Whir/Algebra.lean | 324 ++++++++++++++++++++ verification/whir/Whir/Completeness.lean | 144 +++++++++ verification/whir/Whir/Concrete.lean | 173 +++++++++++ verification/whir/Whir/Layout.lean | 331 +++++++++++++++++++++ verification/whir/Whir/Protocol.lean | 253 ++++++++++++++++ verification/whir/Whir/QuerySoundness.lean | 47 +++ verification/whir/Whir/RingSwitch.lean | 110 +++++++ verification/whir/Whir/Soundness.lean | 199 +++++++++++++ verification/whir/differential/Cargo.lock | 203 +++++++++++++ verification/whir/differential/Cargo.toml | 13 + verification/whir/differential/run.py | 61 ++++ verification/whir/differential/src/main.rs | 234 +++++++++++++++ verification/whir/lake-manifest.json | 96 ++++++ verification/whir/lakefile.toml | 15 + verification/whir/lean-toolchain | 1 + 20 files changed, 2434 insertions(+) create mode 100644 verification/whir/.gitignore create mode 100644 verification/whir/Audit.lean create mode 100644 verification/whir/Main.lean create mode 100644 verification/whir/README.md create mode 100644 verification/whir/Whir.lean create mode 100644 verification/whir/Whir/Algebra.lean create mode 100644 verification/whir/Whir/Completeness.lean create mode 100644 verification/whir/Whir/Concrete.lean create mode 100644 verification/whir/Whir/Layout.lean create mode 100644 verification/whir/Whir/Protocol.lean create mode 100644 verification/whir/Whir/QuerySoundness.lean create mode 100644 verification/whir/Whir/RingSwitch.lean create mode 100644 verification/whir/Whir/Soundness.lean create mode 100644 verification/whir/differential/Cargo.lock create mode 100644 verification/whir/differential/Cargo.toml create mode 100755 verification/whir/differential/run.py create mode 100644 verification/whir/differential/src/main.rs create mode 100644 verification/whir/lake-manifest.json create mode 100644 verification/whir/lakefile.toml create mode 100644 verification/whir/lean-toolchain diff --git a/verification/whir/.gitignore b/verification/whir/.gitignore new file mode 100644 index 000000000..8e30481c3 --- /dev/null +++ b/verification/whir/.gitignore @@ -0,0 +1,3 @@ +.lake/ +__pycache__/ +differential/target/ diff --git a/verification/whir/Audit.lean b/verification/whir/Audit.lean new file mode 100644 index 000000000..d2b33e9bf --- /dev/null +++ b/verification/whir/Audit.lean @@ -0,0 +1,22 @@ +import Whir +import Lean.Util.CollectAxioms + +open Lean in +run_cmd do + let environment ← getEnv + let mut count : Nat := 0 + for (name, info) in environment.constants.toList do + if (`Whir).isPrefixOf name then + match info with + | .thmInfo _ => + let axioms ← collectAxioms name + for axiomName in axioms do + unless #[``propext, ``Classical.choice, ``Quot.sound].contains axiomName do + throwError "unexpected axiom in {name}: {axiomName}" + logInfo m!"{name}: {axioms}" + count := count + 1 + | .axiomInfo _ => throwError "project declares an axiom: {name}" + | _ => pure () + unless count > 0 do + throwError "no project theorems audited" + logInfo m!"Audited {count} Whir theorems; only propext, Classical.choice and Quot.sound permitted." diff --git a/verification/whir/Main.lean b/verification/whir/Main.lean new file mode 100644 index 000000000..bcdd4daa8 --- /dev/null +++ b/verification/whir/Main.lean @@ -0,0 +1,101 @@ +import Whir.Protocol + +open Whir.Concrete Whir.Protocol + +def seed (i : Nat) : UInt64 := + let x := UInt64.ofNat (i+1) * 11400714819323198485 + (x ^^^ (x >>> 29)) * 13787848793156543929 + +def fixture (i : Nat) : E := ⟨seed (3*i), seed (3*i+1), seed (3*i+2)⟩ + +def emitN (key : String) (xs : Array Nat) : IO Unit := + IO.println (key ++ "=" ++ String.intercalate "," (xs.toList.map toString)) + +def emitE (key : String) (xs : Array E) : IO Unit := + emitN key (xs.flatMap fun x => #[x.c0.toNat, x.c1.toNat, x.c2.toNat]) + +def requireIO (ok : Bool) (message : String) : IO Unit := + unless ok do throw (IO.userError message) + +def smoke : IO Unit := do + let c : Config := ⟨7, #[2,2,1], #[1,2,2], #[5,3,3], #[0,1,1]⟩ + let ch : Challenges := ⟨#[ + ⟨#[fixture 1, fixture 2], #[tab 5 (fun i => fixture (10+i))], #[fixture 20], fixture 21⟩, + ⟨#[fixture 3, fixture 4], #[tab 3 (fun i => fixture (30+i))], #[fixture 40], fixture 41⟩, + ⟨#[fixture 5], #[], #[fixture 50], fixture 51⟩], #[fixture 6, fixture 7]⟩ + let witness := tab 96 seed + let b := tab 128 fun i => if i < 96 then fixture (100+i) else E.zero + let target := dot (witness.map E.ofK) b + let (root, p) ← match prove c ch witness b target with + | .ok result => pure result + | .error e => throw (IO.userError ("honest prover: " ++ e)) + let check := fun proof => (verify c ch 3 root b target proof).isOk + requireIO (check p) "honest multilevel opening rejected" + requireIO (!check {p with levels := p.levels.pop}) "short opening accepted" + requireIO (!check {p with residual := p.residual.pop}) "short final accepted" + requireIO (!check {p with residual := p.residual.set! 0 (p.residual[0]! + E.one)}) "bad final accepted" + requireIO (!(verify c ch 3 root b (target+E.one) p).isOk) "bad target accepted" + let l0 := p.levels[0]! + requireIO (!check {p with levels := p.levels.set! 0 {l0 with rows := l0.rows.pop}}) "missing query accepted" + let row := l0.rows[0]! + let rows := l0.rows.set! 0 (row.set! 0 (row[0]!+E.one)) + requireIO (!check {p with levels := p.levels.set! 0 {l0 with rows}}) "bad authenticated row accepted" + let ood := l0.oods[0]! + let oods := l0.oods.set! 0 {ood with value := ood.value+E.one} + requireIO (!check {p with levels := p.levels.set! 0 {l0 with oods}}) "bad OOD accepted" + requireIO (!check {p with levels := p.levels.set! 0 {l0 with oods := #[]}}) "missing OOD accepted" + let badCh := {ch with levels := ch.levels.set! 0 {ch.levels[0]! with querySqueezes := #[]}} + requireIO (!(verify c badCh 3 root b target p).isOk) "missing query challenge accepted" + requireIO (!(verify c ch 0 root b target p).isOk) "empty lane layout accepted" + IO.println "lean_smoke=honest,multilevel,truncated_lanes,bad_target,short_opening,short_final,bad_final,missing_query,bad_row,bad_ood,missing_ood,missing_challenge,bad_layout" + +def vectors : IO Unit := do + emitN "kmul" (tab 40 fun i => (kmul (seed i) (seed (i+41))).toNat) + emitN "kinv" (tab 12 fun i => (kinv (seed i)).toNat) + emitE "emul" (tab 32 fun i => fixture i * fixture (i+33)) + emitE "eq" (eqTable (tab 4 fixture)) + emitN "roots" ((subspaceRoots 8).map UInt64.toNat) + for lanes in #[1,3,4] do + let w := tab (lanes*8) seed + emitE s!"base_{lanes}" ((encodeBase w 5 2 1).flatten) + let f := tab 32 fixture + emitE "ext" ((encodeExt f 5 2 1).flatten) + let r := fixture 70 + emitE "lane_fold" (foldLane f 8 r) + emitE "low_fold" (foldLow f r) + let rs := tab 5 fixture + emitE "rotation" (rotatePoint 2 rs) + emitE "rotation_mle" #[mle f (rotatePoint 2 rs)] + let qs := #[0, 5, 5, 13] + let ws := powers (fixture 80) qs.size + let point := tab 3 fixture + let b := induced 3 qs ws + requireIO (mle b point == inducedAt 3 qs ws point) "dense/succinct induced disagreement" + emitE "induced" b + emitE "induced_at" #[inducedAt 3 qs ws point] + for rate in [1:5] do + for n in [15:29] do + let c := (productionConfig n rate).getD default + requireIO c.valid "invalid production configuration" + emitN s!"config_{n}_{rate}" (c.folds ++ c.rates ++ c.queries ++ c.oodCounts) + for (n, rate) in #[(14,1), (29,1), (15,0), (15,5)] do + requireIO (productionConfig n rate).isNone "unsupported production configuration accepted" + +def parseNat (s : String) : IO Nat := + match s.toNat? with + | some n => pure n + | none => throw (IO.userError ("invalid natural: " ++ s)) + +def main (args : List String) : IO Unit := do + match args with + | "query" :: d :: count :: limbs => + let depth ← parseNat d + let count ← parseNat count + let ns ← limbs.toArray.mapM parseNat + requireIO (ns.size % 3 == 0) "query requires triples of limbs" + let squeezes := tab (ns.size/3) fun i => E.mk (UInt64.ofNat ns[3*i]!) (UInt64.ofNat ns[3*i+1]!) (UInt64.ofNat ns[3*i+2]!) + match deriveQueries depth count squeezes with + | none => throw (IO.userError "malformed query challenge vector") + | some qs => emitN "queries" qs + | [] => vectors; smoke + | _ => throw (IO.userError "usage: whirModel [query DEPTH COUNT LIMB ...]") diff --git a/verification/whir/README.md b/verification/whir/README.md new file mode 100644 index 000000000..e4bfb0981 --- /dev/null +++ b/verification/whir/README.md @@ -0,0 +1,96 @@ +# Executable WHIR model and checked algebra + +This isolated Lean project models leanVM's binary-field, interleaved WHIR variant at production revision [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217). It contains an executable concrete model, generic checked algebra, exact layout/query arithmetic, finite soundness lemmas, and live Rust differential checks. It does **not** prove the Rust source correct, full PCS list binding, or security of the concrete Fiat-Shamir transcript. + +## Reproduce + +Dependencies are pinned by `lean-toolchain`, `lakefile.toml`, `lake-manifest.json`, and the external Rust harness's `Cargo.lock`. Lean is 4.34.0; Mathlib is `5ed2965256430c3649e86755f9576b54eca72435`. The Rust harness uses toolchain 1.97 and the production crates through relative path dependencies, without changing their APIs. Linux reproduction requires a working user systemd session; scopes cap each command at 16 GiB with no swap. + +```sh +cd verification/whir +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 lake update +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 lake build --wfail +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 lake env lean Audit.lean +python3 differential/run.py +``` + +The runner builds and executes `whirModel`, executes the production Rust harness in release mode, and compares newly computed records. Its query mode also feeds actual production challenge limbs to Lean. It uses `/tmp/whir-lean-target`, two Cargo jobs, and one leanVM worker. There are no accepted-output snapshots to regenerate. Lean proof checking is separate from executable differential evidence. + +## Protocol to code to theorem map + +Paths below are relative to `crates/pcs/src`, except the Python mirror, `python-verifier/verifier.py`. + +| Protocol step | Production implementation and mirror | Lean executable/specification | Checked guarantee and boundary | +| --- | --- | --- | --- | +| Shapes and rate ladder | `whir/config.rs`, Python `WhirConfig` | `Protocol.productionConfig`, `Layout.Shape` | Exact bounded index arithmetic; production tables are compared for every supported log-size/rate, not formally derived from a security target. | +| K/E arithmetic and embedding | `primitives::field::{F64,F192}` | `Concrete.kmul`, `Concrete.E`; `Algebra.novelEncode_lift` | Concrete arithmetic is executable and differentially checked. Generic embedding theorem requires an explicit ring homomorphism; there is no asserted concrete `Field` instance. | +| Interleaved commitment | `whir/commit.rs`, `ntt/additive_ntt_f64.rs` | `Concrete.encodeBase`, `Concrete.encodeExt`, `Layout.transposeIndex`, `Algebra.novelEncode` | Reversed-lane permutation/inverse and padding restoration are proved. Generic encoder is the tensor product of normalized novel-basis factors. NTT-to-spec universal refinement is not proved. | +| Equality weights and MLE | `primitives::multilinear`, Python `eq_kernel` | `Algebra.eqWeight`, `mle`, `foldFirst` | Partition of unity, Boolean interpolation, partial evaluation, constant evaluation, batching linearity. | +| Compact quadratic round | `whir/sumcheck.rs`, `verify.rs::Quad`, Python transcript round reader | `Algebra.compactRound`, `roundConstant`, `roundQuadratic` | Characteristic-two endpoint relation, reconstruction, honest round preservation, all-round sumcheck terminal equality. | +| Lane fold and later folds | `whir/prove.rs`, `sumcheck.rs`, `commit.rs` | `Concrete.foldLane`, `foldLow`, `Completeness.foldBlock` | Generic block folding is linear; encoding commutes with multilinear folds; all sizes, including empty algebraic blocks, are handled. Production-valid schedules are a subset. | +| OOD and query claims | `verify.rs::Ood`, `LevelCtx`, `induce.rs`; Python `_induced_weight` | `Protocol.prove/verify`, `Algebra.inducedWeight`, `Completeness.nextWeight` | Opened-column/induced inner-product identity and factorized MLE are proved for normalized factors. OOD enters only after subsequent commitments. | +| Query sampling | `whir.rs::strata/sample_queries_ordered`, public `OpeningVerifier`; Python `strata/sample_queries` | `Layout.strataBits`, `rawQuery`, `sampleQueries`; `Concrete.deriveQueries` | Exact counts, bounds, bit-chunk safety, fixed top bits, repeated full-domain groups, order and duplicate row behavior. Product/AM-GM miss bound is separate in `QuerySoundness`. | +| Pruned row authentication | `merkle.rs`, verifier `open_base` operations; Python `Transcript.merkle` | `Layout.prunedLeaf/restoreLeaf`, ideal oracle rows in `Protocol` | Leading-zero restoration and reversed live-lane ordering proved. Authentication in the executable model is exact ideal row lookup, not BLAKE2 or Merkle collision resistance. | +| Terminal point | `verify.rs::terminal`, Python `verify_whir` | `Layout.terminalPoint/levelPoint`, `Concrete.rotatePoint` | Caller weight receives the left-rotated point; per-level suffix stays in round order. Rotation length, permutation, inverse and slices are proved. | +| Last-level closure | `verify.rs::last_level/terminal` | `Protocol.verify`, `Completeness.finalWeight/finalClaim/replay` | Final consistency powers start at one, without OOD; honest residual plus query batching and all-level algebraic terminal equality are proved. | +| Ring switching and stack | `ring_switch.rs::RingFamily/RingShare`, `stack_open.rs`, Python `ring_switch` | `RingSwitch.composedMap`, `honest_family`, `stacked_claim` | Frobenius-map additivity, honest binary-slice reduction, arbitrary-point family batching with scale **inside** the map, overlapping-region addition, padding noninterference. Concrete optimized inverse-Frobenius/prefix-sharing refinement and map injectivity/soundness are not proved. | +| Interactive errors | Annex B `thm:rbr` | `Soundness` | Root counts, RS evaluation distance, false-claim quadratic round bound, adaptive-history product-space root count, list union bound, first escape and finite RBR error accumulation. This does not instantiate the whole WHIR invariant. | + +`Completeness.Schedule` is an ideal algebraic schedule with supplied challenges and honest mathematical column answers. Its `all_levels_complete` theorem proves preservation through arbitrary fold blocks, residual/OOD/query batching and closing sumcheck. It is not a theorem about `Protocol.verify`'s arrays or serialization. The executable model and the mathematical specification are deliberately separate where a refinement bridge is missing. + +## Intentional differences from original WHIR + +The implementation commits in K = GF(2^64), challenges in E = GF(2^192), and uses additive domains and the novel polynomial basis. The original multiplicative WHIR folding formulas cannot be copied into characteristic two. Quadratic messages contain only the constant and quadratic coefficient; the linear coefficient is reconstructed as `claim + quadratic`. + +There is no commitment-time OOD sample, following Flock. The appropriate security relation is **list binding**, not unique binding. Subsequent OOD claims occur after new commitments. The production protocol sends intro polynomials one message ahead; the interactive executable supplies challenges explicitly rather than claiming to reproduce that byte-level binding order or the concurrent transcript rewrite. + +L0 folds the top witness variables because each interleaved lane is a contiguous stack block. Codeword lane order is reversed, so missing zero-tail lanes become leading zeros in a leaf. Only the live suffix is transported. Caller-coordinate rotation must not be applied to per-level induced weights. + +Queries are sampled with replacement in binary-sized stratified groups. They are not iid uniform columns and are not deduplicated. Independent raw chunks give independent draws *within their assigned cosets*; `QuerySoundness` proves the product/AM-GM inequality and repeated-coset exponent accounting. The theorem does not prove independence of the concrete transcript's squeezes. `Soundness.conditioned_bound` retains the permitted-tape denominator for grinding rather than treating grinding-conditioned randomness as unconditioned uniform randomness. + +Ring switching combines all 64-slice claims by a gamma challenge before drawing the six-stage additive map. Each claim's scale remains inside that map. Claim points need not be prefixes of one another. The family reduction here proves this algebraic requirement, not the full DP24 compiler. + +## Why this formalization approach + +The inspected ArkLib revision is [`35ddcaa83f683011f944f58904be779495a5709a`](https://github.com/Verified-zkEVM/ArkLib/tree/35ddcaa83f683011f944f58904be779495a5709a/ArkLib). Its `ProofSystem/Sumcheck/Impl/Representation.lean` separates executable coefficient messages/Horner evaluation from polynomial interpretation and proves `evaluate_eq`. The modern `Interaction/ComputableSoundness.lean` proves an actual executor/adversarial-strategy bound, unlike several legacy admitted wrappers. `Data/CodingTheory/ProximityGenerator/Interleaving.lean` contains a source proof of exact MCA transfer under an explicit seed-cardinality bound, and `ReedSolomon/MutualCorrelatedAgreement/Johnson/Probability.lean` contains Johnson MCA endpoints with certificate hypotheses. These are useful precedents, not imported conclusions here. + +Source inspection also found admitted FRI input/output relations, admitted generic sequential security/RBR contracts, and admitted Fiat-Shamir interfaces. There is no inspected finished WHIR executor/security endpoint to reuse wholesale. Importing ArkLib's umbrella would not establish an admission-free WHIR proof. This project instead reuses Mathlib algebra/root/finite-sum/AM-GM results and directly audits its own dependency chains. ArkLib itself was inspected, not rebuilt or transitively audited by this project. + +The inspected Ironwood revision is [`86e3c7026db8c9af27ca731e6b5c7f2d8fc7f0fc`](https://github.com/zcash/ironwood/tree/86e3c7026db8c9af27ca731e6b5c7f2d8fc7f0fc/Zcash). `Arithmetic/NatKernelEquiv.lean` uses a representation map instead of an assumed implementation/spec isomorphism. `Arithmetic/FftSpec.lean` decomposes actual FFT refinement into bit reversal, twiddles and rounds. `Arithmetic/FastMsm.lean` uses a proved `csimp` equality rather than an unchecked implementation replacement. `Meta/AxiomCheck.lean`, `TrustBoundary.lean` and `CensusCheck.lean` motivate direct endpoint and elaborated-environment auditing. Ironwood's multiplicative FFT theorem is not an additive-NTT proof for leanVM. + +## Original papers and version limits + +- [WHIR, ePrint 2024/1586](https://eprint.iacr.org/2024/1586): substantive full-paper sections read from the November 21, 2024 PDF. Lemma 4.4 is the interleaved Johnson bound; Definition 4.9 defines MCA; Definition 4.14 and Claim 4.15 concern multiplicative folding; Construction 5.1/Theorem 5.2 give conditional RBR soundness. This numbering is not silently attributed to every later proceedings revision. +- [Ligerito, ePrint 2025/1187](https://eprint.iacr.org/2025/1187): full [author PDF](https://angeris.github.io/papers/ligerito.pdf), dated May 2025, read including the matrix-vector/partial-sumcheck construction and recursive protocol section 6. An immutable ePrint revision identifier was not obtained. +- [Ring switching, ePrint 2024/504](https://eprint.iacr.org/2024/504): packing/security sections read from a cached full PDF. Definition 2.2 is packing and Theorem 3.5 is the compiler security statement in that inspected copy. Its precise dated ePrint revision was not established; the inspected bytes are identified by SHA-256 below. +- [LCH14, arXiv 1404.3458v2](https://arxiv.org/abs/1404.3458v2): July 24, 2014 version. Section II-B equations (3)-(4) give additive subspace polynomials; II-C gives the normalized product basis and the subsequent sections the transform recurrence. +- [BCHKS25, ePrint 2025/2055](https://eprint.iacr.org/2025/2055): recovered and read from [ECCC TR25-169](https://eccc.weizmann.ac.il/report/2025/169/download/), title-page November 7, 2025. Corollary 1.4 is ordinary correlated agreement, so Annex B's stronger same-agreement-set adaptation needs its own argument. Theorem 4.6, pages 28-29, is the required list-correlated-agreement statement. Its rate is `(dimension - 1)/block length` and its multiplicity denominator is the Johnson slack, not twice the slack from Theorem 1.5. Section 3.2 explicitly charges content-factor exceptional roots omitted in an older proof. These security conclusions are not imported as Lean axioms here. +- [DT24, ePrint 2024/1038](https://eprint.iacr.org/2024/1038): complete author PDF read and [pinned to hosting commit `3c36f36aa545f514a967a4f157e8476ad2be335b`](https://github.com/quangvdao/quangvdao.github.io/blob/3c36f36aa545f514a967a4f157e8476ad2be335b/papers/authored/constraint-packing-binary-tower-fields.pdf), Git blob `58244673916d0f7c7b140c5c936cb1493b3eae5c`. Claim 1 and equations (11)-(13) use basis independence for deterministic coordinate packing; characteristic two alone does not suffice. Algorithm 3's Wiedemann-tower arithmetic is not leanVM's representation. +- [LFKN92, primary author manuscript](https://lance.fortnow.com/papers/files/ip.pdf): recovered through a real browser after the reader's HTTP 406; full protocol/security sections read. Rendered pages 3-4 confirm Theorem 1 (interactive proofs for P raised to a #P oracle), Lemma 3 (reduction to permanent checking), and Lemma 4 (degree-r polynomial agreement bounded by r/p). The manuscript proves the permanent expand/shrink protocol, not a named modern Boolean-cube sumcheck theorem. Its first-escape proof motivates `rbr_composition`; its footnote explicitly distinguishes ideal uniform field sampling from bit-based rejection sampling. +- [Jo26, ePrint 2026/891](https://eprint.iacr.org/2026/891) and [Gru24](https://eprint.iacr.org/2024/108): full originals remain unavailable after ePrint/publisher, author-site, archive and repository searches. The Jo26 PDF additionally remained behind a Cloudflare security-verification page in a real browser. Jo26 Theorem 4.4 is verified only as a local citation. No unverified original theorem numbering is asserted. + +The unavailable originals and incomplete revision pins above are explicit research limitations, not claimed completed source readings. + +SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8d95c310c8deb64e3beac30ce61`; ring switching `e0c9dd03a2e9b4a9c6b88dd3df077db6400668a6e8234b877d046bc60c9949d9`; LFKN `926388d68334bc8cdcd586c70f0b97b2b7e957fe0f360858f4574e91a36622ab`. The PDFs are research inputs, not vendored dependencies. + +## Trust boundary and unproved goals + +`Audit.lean` discovers every exported theorem in the elaborated `Whir` namespace and computes its transitive axioms. It rejects project axioms and every dependency axiom except `propext`, `Classical.choice` and `Quot.sound`. Selected principal algebra endpoints additionally retain `#print axioms` commands. No `sorry`, `admit`, `native_decide`, unsafe proof execution, or new correctness axiom is used in completed chains. Running the compiled model and Rust still trusts their compilers/runtime; differential testing is evidence for tested inputs, not a kernel proof of their correspondence. + +Outstanding proof boundaries are concrete K/E irreducibility and field-law refinement, the optimized additive NTT's universal refinement to the generic encoder, full array/length-checked executable verifier refinement, the concrete ring-map injectivity/error bound, Johnson list size/MCA and OOD-separation instantiation, the complete adaptive WHIR list-binding invariant, transcript-prefix binding, Merkle collision resistance, grinding/Fiat-Shamir compilation, and concrete BLAKE2 random-oracle security. `ListExplains` records a list-opening relation; it is not a theorem that commitments satisfy that relation. `rbr_composition` proves error accumulation from individual escape bounds, not those missing WHIR escape bounds. + +`ListBinding` makes the security quantifiers explicit: for every commitment there must be a bounded candidate list fixed before every adversarial strategy, with failure probability over the finite uniform randomness tape of a supplied verifier experiment. It is a game definition, not a proved WHIR instance. The abstract strategy and verifier interfaces keep challenge correlations and implementation-specific transcript semantics from being assumed away. + +Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte-decoding error taxonomy or underflow behavior as production `TranscriptError`. The Rust smoke separately uses the actual stack-opening prover/verifier and its malformed/tampered inputs. No byte-for-byte full transcript refinement is claimed. + +No production bug is established merely by disagreement with a hand port. Findings must first distinguish model errors, supported-input contracts and genuine Rust discrepancies. This verification addition does not modify production Rust, Python, recursion verifiers, protocol versions, or the LaTeX specification. + +## Exercised validation + +The delivered branch passed `lake build --wfail` and the elaborated axiom census: every discovered theorem declaration, including generated equations and auxiliary proofs, depended only on the three permitted standard axioms. The protocol properties are enumerated above rather than counting generated declarations as independently substantial results. + +The live differential runner matched 71 record groups: 15 arithmetic/encoding/folding/weight groups plus all 56 production configurations. Six additional production query batches covered `(depth,count)` = `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`, including cross-limb extraction, uneven groups and repeated queries. Lean's three-level opening accepted and rejected wrong targets, short openings/final residuals, changed final residuals, missing queries, changed rows, changed/missing OOD answers, missing challenges and invalid layouts. Rust's real minimum-size stacked opening exercised ring-switch and point claims, truncated lanes, Merkle authentication, Fiat-Shamir and grinding; it rejected short/trailing streams, changed round/OOD/final scalars, missing authentication and invalid layouts. + +The standalone Rust harness also passed release Clippy with warnings denied and rustdoc with warnings denied. Its Rust code was formatted; the Python runner passed Ruff and `ty`. No production Rust or Python verifier was changed, so full VM suites, Python verifier conformance suites, guest fixture rebuilds and LaTeX builds were intentionally not run. + +No Rust discrepancy was found in this explored scope. That statement is not a proof that untested inputs or the Rust protocol are correct, and no speculative bug-fix PR is warranted. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean new file mode 100644 index 000000000..7b2dd1d4a --- /dev/null +++ b/verification/whir/Whir.lean @@ -0,0 +1,8 @@ +import Whir.Algebra +import Whir.Layout +import Whir.RingSwitch +import Whir.Soundness +import Whir.QuerySoundness +import Whir.Completeness +import Whir.Concrete +import Whir.Protocol diff --git a/verification/whir/Whir/Algebra.lean b/verification/whir/Whir/Algebra.lean new file mode 100644 index 000000000..18485a238 --- /dev/null +++ b/verification/whir/Whir/Algebra.lean @@ -0,0 +1,324 @@ +import Mathlib.Algebra.BigOperators.Fin +import Mathlib.Algebra.BigOperators.Ring.Finset +import Mathlib.Algebra.CharP.Two +import Mathlib.Data.Fintype.Pi +import Mathlib.Tactic + +/-! Algebraic specification of Annex B's honest sumcheck and Annex D's column +weights. These results do not assert that the concrete machine fields satisfy +ring laws, or that an NTT implementation realizes the specified encoder. -/ +namespace Whir + +open scoped BigOperators + +abbrev Cube (n : ℕ) := Fin n → Bool + +def cubeConsEquiv (n : ℕ) : Bool × Cube n ≃ Cube (n + 1) where + toFun p := Fin.cons p.1 p.2 + invFun u := (u 0, fun i => u i.succ) + left_inv p := by cases p; rfl + right_inv u := by ext i; exact Fin.cases rfl (fun _ => rfl) i + +section Ring +variable {R : Type*} [CommRing R] + +lemma sum_cube_succ {n : ℕ} (f : Cube (n + 1) → R) : + ∑ u, f u = (∑ u, f (Fin.cons false u)) + ∑ u, f (Fin.cons true u) := by + rw [← Equiv.sum_comp (cubeConsEquiv n)] + simp [Fintype.sum_prod_type, cubeConsEquiv, add_comm] + +def eqWeight {n : ℕ} (r : Fin n → R) (u : Cube n) : R := + ∏ i, if u i then r i else 1 - r i + +def innerProduct {ι : Type*} [Fintype ι] (w f : ι → R) : R := ∑ i, w i * f i + +def mle {n : ℕ} (f : Cube n → R) (r : Fin n → R) : R := + innerProduct (eqWeight r) f + +def foldFirst {n : ℕ} (f : Cube (n + 1) → R) (r : R) : Cube n → R := + fun u => (1 - r) * f (Fin.cons false u) + r * f (Fin.cons true u) + +lemma eqWeight_cons {n : ℕ} (r : R) (rs : Fin n → R) (b : Bool) (u : Cube n) : + eqWeight (Fin.cons r rs) (Fin.cons b u) = + (if b then r else 1 - r) * eqWeight rs u := by + simp [eqWeight, Fin.prod_univ_succ] + +lemma mle_foldFirst {n : ℕ} (f : Cube (n + 1) → R) (r : R) (rs : Fin n → R) : + mle (foldFirst f r) rs = mle f (Fin.cons r rs) := by + unfold mle innerProduct + rw [sum_cube_succ] + simp only [eqWeight_cons, Bool.false_eq_true, ↓reduceIte, foldFirst] + rw [← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro u _ + ring + +lemma eqWeight_sum {n : ℕ} (r : Fin n → R) : ∑ u, eqWeight r u = 1 := by + induction n with + | zero => simp [eqWeight, Cube] + | succ n ih => + conv_lhs => rw [show r = Fin.cons (r 0) (fun i => r i.succ) by ext i; exact Fin.cases rfl (fun _ => rfl) i] + rw [sum_cube_succ] + simp only [eqWeight_cons, Bool.false_eq_true, ↓reduceIte, ← Finset.mul_sum, ih] + ring + +lemma mle_const {n : ℕ} (c : R) (r : Fin n → R) : mle (fun _ => c) r = c := by + simp [mle, innerProduct, ← Finset.sum_mul, eqWeight_sum] + +lemma mle_boolean {n : ℕ} (f : Cube n → R) (u : Cube n) : + mle f (fun i => if u i then 1 else 0) = f u := by + induction n with + | zero => + simp only [mle, innerProduct, eqWeight, Finset.univ_eq_empty, Finset.prod_empty, one_mul] + simp only [Fintype.sum_unique] + exact congrArg f (Subsingleton.elim _ _) + | succ n ih => + let tail : Cube n := fun i => u i.succ + have hu : u = Fin.cons (u 0) tail := by ext i; exact Fin.cases rfl (fun _ => rfl) i + rw [hu] + have hp : (fun i : Fin (n + 1) => if (Fin.cons (u 0) tail : Cube (n + 1)) i = true then (1 : R) else 0) = + Fin.cons (if u 0 then 1 else 0) (fun i => if tail i then 1 else 0) := by + ext i + exact Fin.cases rfl (fun _ => rfl) i + rw [hp] + rw [← mle_foldFirst, ih] + cases u 0 <;> simp [foldFirst] + +def batchWeights {ι τ : Type*} [Fintype τ] (a : τ → R) (w : τ → ι → R) : ι → R := + fun i => ∑ t, a t * w t i + +lemma innerProduct_batch {ι τ : Type*} [Fintype ι] [Fintype τ] + (a : τ → R) (w : τ → ι → R) (f : ι → R) : + innerProduct (batchWeights a w) f = ∑ t, a t * innerProduct (w t) f := by + simp only [innerProduct, batchWeights, Finset.sum_mul, Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro t _ + apply Finset.sum_congr rfl + intro i _ + ring + +lemma mle_batch {n : ℕ} {τ : Type*} [Fintype τ] + (a : τ → R) (w : τ → Cube n → R) (r : Fin n → R) : + mle (batchWeights a w) r = ∑ t, a t * mle (w t) r := by + simp only [mle, innerProduct, batchWeights, Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro t _ + apply Finset.sum_congr rfl + intro u _ + ring + +/-- Any matrix encoder, hence the novel-basis encoder, commutes with an +arbitrary multilinear fold of its rows. -/ +theorem fold_encode_commute {n : ℕ} {ι κ : Type*} [Fintype ι] + (matrix : κ → ι → R) (f : Cube n → ι → R) (r : Fin n → R) (x : κ) : + mle (fun u => innerProduct (matrix x) (f u)) r = + innerProduct (matrix x) (fun i => mle (fun u => f u i) r) := by + simp only [mle, innerProduct, Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro i _ + apply Finset.sum_congr rfl + intro u _ + ring + +/-- A column of the novel-basis encoder, parameterized by the normalized +subspace-polynomial values at that column. -/ +def tensorWeight {n : ℕ} (s : Fin n → R) (u : Cube n) : R := + ∏ i, if u i then s i else 1 + +def novelEncode {n : ℕ} (s : Fin n → R) (f : Cube n → R) : R := + ∑ u, f u * tensorWeight s u + +lemma novelEncode_eq_innerProduct {n : ℕ} (s : Fin n → R) (f : Cube n → R) : + novelEncode s f = innerProduct (tensorWeight s) f := by + simp [novelEncode, innerProduct, mul_comm] + +lemma tensorWeight_cons {n : ℕ} (s : R) (ss : Fin n → R) (b : Bool) (u : Cube n) : + tensorWeight (Fin.cons s ss) (Fin.cons b u) = + (if b then s else 1) * tensorWeight ss u := by + simp [tensorWeight, Fin.prod_univ_succ] + +/-- Annex D's column-weight factorization, without a characteristic assumption. -/ +theorem mle_tensorWeight {n : ℕ} (s r : Fin n → R) : + mle (tensorWeight s) r = ∏ i, ((1 - r i) + r i * s i) := by + induction n with + | zero => simp [mle, innerProduct, eqWeight, tensorWeight, Cube] + | succ n ih => + have hs : s = Fin.cons (s 0) (fun i => s i.succ) := by ext i; exact Fin.cases rfl (fun _ => rfl) i + have hr : r = Fin.cons (r 0) (fun i => r i.succ) := by ext i; exact Fin.cases rfl (fun _ => rfl) i + rw [hs, hr] + unfold mle innerProduct + rw [sum_cube_succ, Fin.prod_univ_succ] + simp only [eqWeight_cons, tensorWeight_cons, Bool.false_eq_true, ↓reduceIte, Fin.cons_zero, Fin.cons_succ, one_mul] + simp_rw [mul_assoc, ← Finset.mul_sum] + simp_rw [mul_left_comm (eqWeight _ _) (s 0), ← Finset.mul_sum] + have h := ih (fun i => s i.succ) (fun i => r i.succ) + unfold mle innerProduct at h + rw [h] + ring + +def inducedWeight {n q : ℕ} (a : Fin q → R) (s : Fin q → Fin n → R) : Cube n → R := + batchWeights a (fun t => tensorWeight (s t)) + +theorem inducedWeight_claim {n q : ℕ} (a : Fin q → R) (s : Fin q → Fin n → R) + (f : Cube n → R) : + innerProduct (inducedWeight a s) f = ∑ t, a t * novelEncode (s t) f := by + simp [inducedWeight, innerProduct_batch, novelEncode_eq_innerProduct] + +theorem inducedWeight_mle {n q : ℕ} (a : Fin q → R) (s : Fin q → Fin n → R) + (r : Fin n → R) : + mle (inducedWeight a s) r = ∑ t, a t * ∏ i, ((1 - r i) + r i * s t i) := by + simp [inducedWeight, mle_batch, mle_tensorWeight] + +/-- The batched claim computed from opened columns is exactly the induced +weight's claim on the folded message, provided those rows are encoded honestly. -/ +theorem inducedWeight_opened_columns {lanes n q : ℕ} + (a : Fin q → R) (s : Fin q → Fin n → R) + (f : Cube lanes → Cube n → R) (r : Fin lanes → R) : + (∑ t, a t * mle (fun u => novelEncode (s t) (f u)) r) = + innerProduct (inducedWeight a s) (fun v => mle (fun u => f u v) r) := by + rw [inducedWeight_claim] + apply Finset.sum_congr rfl + intro t _ + simp only [novelEncode_eq_innerProduct] + rw [fold_encode_commute] + +end Ring + +section CharacteristicTwo +variable {R : Type*} [CommRing R] [CharP R 2] + +/-- The two scalars sent by `sumcheck::pair_terms`. -/ +def roundConstant {n : ℕ} (w f : Cube (n + 1) → R) : R := + ∑ u, w (Fin.cons false u) * f (Fin.cons false u) + +def roundQuadratic {n : ℕ} (w f : Cube (n + 1) → R) : R := + ∑ u, (w (Fin.cons false u) + w (Fin.cons true u)) * + (f (Fin.cons false u) + f (Fin.cons true u)) + +/-- Rust's `(a * r + b) * r + c`, where `b = claim + a`. -/ +def compactRound (claim u₀ u₂ r : R) : R := (u₂ * r + (claim + u₂)) * r + u₀ + +lemma compactRound_endpoints (claim u₀ u₂ : R) : + compactRound claim u₀ u₂ 0 + compactRound claim u₀ u₂ 1 = claim := by + simp [compactRound, add_assoc] + ring_nf + simp [CharTwo.two_eq_zero] + +/-- Every degree-at-most-two polynomial satisfying the round sum has exactly +this reconstruction; characteristic two, rather than division by two, is used. -/ +theorem compactRound_reconstruct (c b a claim : R) + (h : c + (c + b + a) = claim) (r : R) : + compactRound claim c a r = c + b * r + a * r ^ 2 := by + have hb : claim = b + a := by + rw [← h] + rw [← add_assoc, ← add_assoc, CharTwo.add_self_eq_zero, zero_add] + rw [hb] + simp only [compactRound, CharTwo.add_cancel_right] + ring + +lemma foldFirst_charTwo {n : ℕ} (f : Cube (n + 1) → R) (r : R) (u : Cube n) : + foldFirst f r u = f (Fin.cons false u) + r * + (f (Fin.cons false u) + f (Fin.cons true u)) := by + rw [foldFirst, CharTwo.sub_eq_add] + ring + +private lemma honest_pair (w₀ w₁ f₀ f₁ r : R) : + ((w₀ + w₁) * (f₀ + f₁) * r + + (w₀ * f₀ + w₁ * f₁ + (w₀ + w₁) * (f₀ + f₁))) * r + w₀ * f₀ = + (w₀ + r * (w₀ + w₁)) * (f₀ + r * (f₀ + f₁)) := by + have h : w₀ * f₀ + w₁ * f₁ + (w₀ + w₁) * (f₀ + f₁) = w₀ * f₁ + w₁ * f₀ := by + linear_combination (f₀ * CharTwo.add_self_eq_zero w₀) + (f₁ * CharTwo.add_self_eq_zero w₁) + rw [h] + ring_nf + simp [CharTwo.two_eq_zero] + +/-- One honest round preserves the weighted-claim invariant for every challenge. -/ +theorem honest_round {n : ℕ} (w f : Cube (n + 1) → R) (r : R) : + compactRound (innerProduct w f) (roundConstant w f) (roundQuadratic w f) r = + innerProduct (foldFirst w r) (foldFirst f r) := by + unfold compactRound innerProduct roundConstant roundQuadratic + rw [sum_cube_succ] + simp only [← Finset.sum_add_distrib, Finset.sum_mul] + apply Finset.sum_congr rfl + intro u _ + rw [foldFirst_charTwo, foldFirst_charTwo] + exact honest_pair _ _ _ _ _ + +/-- Execute all compact verifier updates using honest prover messages. The +starting claim is an input, so completeness is not built into the evaluator. -/ +def honestSumcheck : (n : ℕ) → (Cube n → R) → (Cube n → R) → (Fin n → R) → R → R + | 0, _, _, _, claim => claim + | n + 1, w, f, r, claim => + honestSumcheck n (foldFirst w (r 0)) (foldFirst f (r 0)) (fun i => r i.succ) + (compactRound claim (roundConstant w f) (roundQuadratic w f) (r 0)) + +/-- All-round honest sumcheck completeness, including zero rounds. -/ +theorem honestSumcheck_complete (n : ℕ) (w f : Cube n → R) (r : Fin n → R) : + honestSumcheck n w f r (innerProduct w f) = mle w r * mle f r := by + induction n with + | zero => simp [honestSumcheck, innerProduct, mle, eqWeight, Cube] + | succ n ih => + rw [honestSumcheck, honest_round, ih, mle_foldFirst, mle_foldFirst] + have hr : Fin.cons (r 0) (fun i => r i.succ) = r := by ext i; exact Fin.cases rfl (fun _ => rfl) i + rw [hr] + +/-- Batching honest claims and then running every sumcheck round closes with +the verifier's terminal product, for arbitrary batch coefficients. Powers of +the transcript challenge are a special case. -/ +theorem honestSumcheck_batched_complete {n q : ℕ} (a : Fin q → R) + (w : Fin q → Cube n → R) (f : Cube n → R) (c : Fin q → R) + (honest : ∀ t, c t = innerProduct (w t) f) (r : Fin n → R) : + honestSumcheck n (batchWeights a w) f r (∑ t, a t * c t) = + (∑ t, a t * mle (w t) r) * mle f r := by + simp_rw [honest] + rw [← innerProduct_batch, honestSumcheck_complete, mle_batch] + +theorem inducedWeight_mle_charTwo {n q : ℕ} (a : Fin q → R) + (s : Fin q → Fin n → R) (r : Fin n → R) : + mle (inducedWeight a s) r = ∑ t, a t * ∏ i, (1 + r i * (1 + s t i)) := by + rw [inducedWeight_mle] + apply Finset.sum_congr rfl + intro t _ + congr 1 + apply Finset.prod_congr rfl + intro i _ + rw [CharTwo.sub_eq_add] + ring + +end CharacteristicTwo + +section Embedding +variable {K E : Type*} [CommRing K] [CommRing E] + +/-- The mixed K/E path needs a ring homomorphism. This is a typed hypothesis, +not an unproved assertion about the concrete bitfield implementation. -/ +theorem novelEncode_lift (embed : K →+* E) {n : ℕ} (s : Fin n → K) (f : Cube n → K) : + novelEncode (fun i => embed (s i)) (fun u => embed (f u)) = embed (novelEncode s f) := by + simp only [novelEncode, map_sum, map_mul, tensorWeight, map_prod] + apply Finset.sum_congr rfl + intro u _ + congr 1 + apply Finset.prod_congr rfl + intro i _ + cases u i <;> simp + +end Embedding + +end Whir + +#print axioms Whir.mle_boolean +#print axioms Whir.mle_foldFirst +#print axioms Whir.innerProduct_batch +#print axioms Whir.fold_encode_commute +#print axioms Whir.mle_tensorWeight +#print axioms Whir.inducedWeight_claim +#print axioms Whir.inducedWeight_mle_charTwo +#print axioms Whir.inducedWeight_opened_columns +#print axioms Whir.compactRound_reconstruct +#print axioms Whir.honest_round +#print axioms Whir.honestSumcheck_complete +#print axioms Whir.honestSumcheck_batched_complete +#print axioms Whir.novelEncode_lift diff --git a/verification/whir/Whir/Completeness.lean b/verification/whir/Whir/Completeness.lean new file mode 100644 index 000000000..7fdde576c --- /dev/null +++ b/verification/whir/Whir/Completeness.lean @@ -0,0 +1,144 @@ +import Whir.Algebra + +namespace Whir.Completeness + +open scoped BigOperators + +variable {R : Type*} [CommRing R] [CharP R 2] + +/-- A block of k consecutive sumcheck folds. The remaining m coordinates keep round order. -/ +def foldBlock : (k m : ℕ) → (Cube (m + k) → R) → (Fin k → R) → Cube m → R + | 0, _, f, _ => f + | k + 1, m, f, r => + foldBlock k m (foldFirst (n := m + k) f (r 0)) (fun i => r i.succ) + +def runBlock : (k m : ℕ) → (Cube (m + k) → R) → (Cube (m + k) → R) → + (Fin k → R) → R → R + | 0, _, _, _, _, claim => claim + | k + 1, m, w, f, r, claim => + runBlock k m (foldFirst (n := m + k) w (r 0)) (foldFirst f (r 0)) + (fun i => r i.succ) + (compactRound claim (roundConstant w f) (roundQuadratic w f) (r 0)) + +theorem block_complete (k m : ℕ) (w f : Cube (m + k) → R) (r : Fin k → R) : + runBlock k m w f r (innerProduct w f) = + innerProduct (foldBlock k m w r) (foldBlock k m f r) := by + induction k with + | zero => rfl + | succ k ih => + simp only [runBlock, foldBlock] + rw [honest_round] + exact ih _ _ _ + +omit [CharP R 2] in +/-- Fold/encode commutation for every block size, including uneven final blocks. -/ +theorem foldBlock_linear {I : Type*} [Fintype I] (k m : ℕ) + (a : I → R) (f : I → Cube (m + k) → R) (r : Fin k → R) (u : Cube m) : + foldBlock k m (fun x => ∑ i, a i * f i x) r u = + ∑ i, a i * foldBlock k m (f i) r u := by + induction k with + | zero => rfl + | succ k ih => + simp only [foldBlock] + have h : foldFirst (n := m + k) (fun x => ∑ i, a i * f i x) (r 0) = + fun x => ∑ i, a i * foldFirst (f i) (r 0) x := by + funext x + simp only [foldFirst, Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i _ + ring + exact (congrArg (fun g => foldBlock k m g (fun i => r i.succ) u) h).trans + (ih (fun i => foldFirst (f i) (r 0)) (fun i => r i.succ)) + +/-- Residual, OOD, then column claims in the production batching order. -/ +def nextWeight {m q : ℕ} (residual : Cube m → R) (z : Fin m → R) + (columns : Fin q → Fin m → R) (lambda : R) : Cube m → R := + fun u => residual u + lambda * eqWeight z u + + ∑ j, lambda ^ (j.val + 2) * tensorWeight (columns j) u + +def nextClaim {m q : ℕ} (residual : R) (folded : Cube m → R) (z : Fin m → R) + (columns : Fin q → Fin m → R) (lambda : R) : R := + residual + lambda * mle folded z + + ∑ j, lambda ^ (j.val + 2) * novelEncode (columns j) folded + +omit [CharP R 2] in +/-- Honest OOD and authenticated column answers preserve the residual invariant. -/ +theorem next_claim_complete {m q : ℕ} (residual folded : Cube m → R) + (z : Fin m → R) (columns : Fin q → Fin m → R) (lambda : R) : + nextClaim (innerProduct residual folded) folded z columns lambda = + innerProduct (nextWeight residual z columns lambda) folded := by + simp only [nextClaim, nextWeight, mle, innerProduct, novelEncode_eq_innerProduct, + innerProduct, add_mul, Finset.sum_add_distrib, Finset.sum_mul, Finset.mul_sum] + congr 1 + · simp only [mul_assoc] + · rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + apply Finset.sum_congr rfl + intro u _ + ring + +/-- Closing level: there is no OOD claim, so consistency powers start at one. -/ +def finalWeight {m q : ℕ} (residual : Cube m → R) + (columns : Fin q → Fin m → R) (lambda : R) : Cube m → R := + fun u => residual u + ∑ j, lambda ^ (j.val + 1) * tensorWeight (columns j) u + +def finalClaim {m q : ℕ} (residual : R) (folded : Cube m → R) + (columns : Fin q → Fin m → R) (lambda : R) : R := + residual + ∑ j, lambda ^ (j.val + 1) * novelEncode (columns j) folded + +omit [CharP R 2] in +theorem final_claim_complete {m q : ℕ} (residual folded : Cube m → R) + (columns : Fin q → Fin m → R) (lambda : R) : + finalClaim (innerProduct residual folded) folded columns lambda = + innerProduct (finalWeight residual columns lambda) folded := by + simp only [finalClaim, finalWeight, innerProduct, novelEncode_eq_innerProduct, + innerProduct, add_mul, Finset.sum_add_distrib, Finset.sum_mul, Finset.mul_sum] + congr 1 + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + apply Finset.sum_congr rfl + intro u _ + ring + +/-- An ideal interactive schedule. Column parameters are normalized subspace-polynomial +values. No field sampling, Merkle hashing or transcript serialization is implicit. -/ +inductive Schedule (R : Type u) : ℕ → Type u + | terminal {m : ℕ} (point : Fin m → R) : Schedule R m + | closing {m q : ℕ} (point : Fin m → R) + (columns : Fin q → Fin m → R) (lambda : R) : Schedule R m + | level {k m q : ℕ} (folds : Fin k → R) (ood : Fin m → R) + (columns : Fin q → Fin m → R) (lambda : R) + (next : Schedule R m) : Schedule R (m + k) + +/-- The residual claim is not recomputed from the witness: compact messages update it. -/ +def replay : {n : ℕ} → Schedule R n → (Cube n → R) → (Cube n → R) → R → R × R + | _, .terminal point, w, f, claim => + (honestSumcheck _ w f point claim, mle w point * mle f point) + | _, .closing point columns lambda, w, f, claim => + let weight := finalWeight w columns lambda + (honestSumcheck _ weight f point (finalClaim claim f columns lambda), + mle weight point * mle f point) + | _, .level (k := k) (m := m) folds ood columns lambda next, w, f, claim => + let folded := foldBlock k m f folds + let residual := runBlock k m w f folds claim + replay next (nextWeight (foldBlock k m w folds) ood columns lambda) folded + (nextClaim residual folded ood columns lambda) + +/-- Algebraic all-level completeness for any fold ladder and arbitrary challenges. +This theorem concerns honest algebraic messages, not Rust source-level refinement. -/ +theorem all_levels_complete {n : ℕ} (schedule : Schedule R n) + (w f : Cube n → R) : + (replay schedule w f (innerProduct w f)).1 = + (replay schedule w f (innerProduct w f)).2 := by + induction schedule with + | terminal point => exact honestSumcheck_complete _ w f point + | closing point columns lambda => + simp only [replay, final_claim_complete] + exact honestSumcheck_complete _ _ _ _ + | level folds ood columns lambda next ih => + simp only [replay, block_complete, next_claim_complete] + exact ih _ _ + +end Whir.Completeness diff --git a/verification/whir/Whir/Concrete.lean b/verification/whir/Whir/Concrete.lean new file mode 100644 index 000000000..8736277e7 --- /dev/null +++ b/verification/whir/Whir/Concrete.lean @@ -0,0 +1,173 @@ +import Std + +/-! Executable bit model. No `Field` instance is asserted for these operations. +The moduli are exactly the production K and E moduli. -/ +namespace Whir.Concrete + +abbrev K := UInt64 + +def kadd (a b : K) : K := a ^^^ b + +def kmul (a b : K) : K := Id.run do + let mut x := a + let mut y := b + let mut z : K := 0 + for _ in [:64] do + if y &&& 1 == 1 then z := z ^^^ x + let carry := x >>> 63 + x := x <<< 1 + if carry == 1 then x := x ^^^ 27 + y := y >>> 1 + return z + +def kpow (a : K) (n : Nat) : K := Id.run do + let mut x := a + let mut out : K := 1 + for i in [:64] do + if n.testBit i then out := kmul out x + x := kmul x x + return out + +def kinv (a : K) : K := kpow a (2^64 - 2) + +structure E where + c0 : K := 0 + c1 : K := 0 + c2 : K := 0 + deriving BEq, DecidableEq, Repr, Inhabited + +namespace E + +def zero : E := ⟨0, 0, 0⟩ +def one : E := ⟨1, 0, 0⟩ +def ofK (a : K) : E := ⟨a, 0, 0⟩ +def add (a b : E) : E := ⟨a.c0 ^^^ b.c0, a.c1 ^^^ b.c1, a.c2 ^^^ b.c2⟩ +def scale (a : E) (b : K) : E := ⟨kmul a.c0 b, kmul a.c1 b, kmul a.c2 b⟩ +def mul (a b : E) : E := + let d0 := kmul a.c0 b.c0 + let d1 := kmul a.c0 b.c1 ^^^ kmul a.c1 b.c0 + let d2 := kmul a.c0 b.c2 ^^^ kmul a.c1 b.c1 ^^^ kmul a.c2 b.c0 + let d3 := kmul a.c1 b.c2 ^^^ kmul a.c2 b.c1 + let d4 := kmul a.c2 b.c2 + ⟨d0 ^^^ d3, d1 ^^^ d3 ^^^ d4, d2 ^^^ d4⟩ +def toNat (a : E) : Nat := a.c0.toNat + 2^64 * a.c1.toNat + 2^128 * a.c2.toNat +end E + +instance : Add E := ⟨E.add⟩ +instance : Mul E := ⟨E.mul⟩ + +def tab (n : Nat) (f : Nat → α) : Array α := (List.range n).toArray.map f + +def dot (a b : Array E) : E := + (tab (min a.size b.size) fun i => a[i]! * b[i]!).foldl (· + ·) E.zero + +def powers (a : E) (n : Nat) : Array E := Id.run do + let mut out := #[] + let mut x := E.one + for _ in [:n] do + out := out.push x + x := x * a + return out + +/-- Coordinates and table indices are least-significant-bit first. -/ +def eqTable (point : Array E) : Array E := Id.run do + let mut out := #[E.one] + for r in point do + out := (out.map fun x => x * (E.one + r)) ++ (out.map fun x => x * r) + return out + +def foldPair (a b r : E) : E := a + r * (a + b) + +def foldLow (a : Array E) (r : E) : Array E := + tab (a.size / 2) fun i => foldPair a[2*i]! a[2*i+1]! r + +/-- One of the top-lane rounds: adjacent lane blocks, not adjacent words. -/ +def foldLane (a : Array E) (block : Nat) (r : E) : Array E := + tab (a.size / 2) fun i => + let offset := (i / block) * (2*block) + i % block + foldPair a[offset]! a[offset+block]! r + +def mle (a : Array E) (point : Array E) : E := dot a (eqTable point) + +def rotatePoint (initialK : Nat) (point : Array E) : Array E := + point.extract initialK point.size ++ point.extract 0 initialK + +/-- s_i(v_i), including i=n, using the standard polynomial basis v_i=x^i. -/ +def subspaceRoots (n : Nat) : Array K := Id.run do + let mut roots : Array K := #[1] + let mut layer := tab n fun i => (1 : K) <<< UInt64.ofNat (i+1) + for i in [:n] do + layer := layer.map fun x => kmul x (x ^^^ roots[i]!) + roots := roots.push layer[0]! + layer := layer.extract 1 layer.size + return roots + +def normalizedSubspaces (n : Nat) (x : K) : Array K := Id.run do + let roots := subspaceRoots n + let mut out := #[] + let mut s := x + for i in [:n] do + out := out.push (kmul s (kinv roots[i]!)) + s := kmul s (s ^^^ roots[i]!) + return out + +def column (n : Nat) (q : Nat) : Array E := Id.run do + let mut out := #[E.one] + for s in normalizedSubspaces n (UInt64.ofNat q) do + out := out ++ out.map (fun x => x.scale s) + return out + +def encode (n rate : Nat) (coeffs : Array E) : Array E := + tab (2^(n+rate)) fun q => dot coeffs (column n q) + +/-- L0 returns only the occupied tail of each leaf, in descending lane order. -/ +def encodeBase (message : Array K) (logN initialK rate : Nat) : Array (Array E) := + let n := logN - initialK + let block := 2^n + let lanes := message.size / block + let codes := tab lanes fun lane => encode n rate + (tab block fun j => E.ofK message[lane*block+j]!) + tab (2^(n+rate)) fun q => tab lanes fun t => codes[lanes-1-t]![q]! + +/-- Later-level inputs are row major, with the low variables selecting the lane. -/ +def encodeExt (message : Array E) (logN foldK rate : Nat) : Array (Array E) := + let n := logN-foldK + let lanes := 2^foldK + let codes := tab lanes fun lane => encode n rate + (tab (2^n) fun j => message[j*lanes+lane]!) + tab (2^(n+rate)) fun q => tab lanes fun lane => codes[lane]![q]! + +def induced (n : Nat) (queries : Array Nat) (weights : Array E) : Array E := + let cols := queries.map (column n) + tab (2^n) fun j => (tab queries.size fun i => weights[i]! * cols[i]![j]!).foldl (· + ·) E.zero + +def inducedAt (n : Nat) (queries : Array Nat) (weights point : Array E) : E := Id.run do + let mut out := E.zero + for i in [:queries.size] do + let ws := normalizedSubspaces n (UInt64.ofNat queries[i]!) + let mut product := weights[i]! + for k in [:n] do + product := product * (E.one + point[k]! * (E.one + E.ofK ws[k]!)) + out := out + product + return out + +def strata (count depth : Nat) : Array (Nat × Nat) := Id.run do + let mut out := #[] + for g in (List.range (count.log2+1)).reverse do + if count.testBit g then + let bits := min g depth + for j in [:2^g] do out := out.push (bits, j % 2^bits) + return out + +/-- Independent supplied E squeezes, not a Fiat-Shamir implementation. -/ +def deriveQueries (depth count : Nat) (squeezes : Array E) : Option (Array Nat) := do + if depth == 0 || depth > 64 then none else do + let per := 192 / depth + if squeezes.size != (count + per - 1) / per then none else do + let ss := strata count depth + return tab count fun i => + let raw := (squeezes[i/per]!.toNat / 2^((i%per)*depth)) % 2^depth + let (bits, index) := ss[i]! + raw % 2^(depth-bits) + index * 2^(depth-bits) + +end Whir.Concrete diff --git a/verification/whir/Whir/Layout.lean b/verification/whir/Whir/Layout.lean new file mode 100644 index 000000000..b9a1a594d --- /dev/null +++ b/verification/whir/Whir/Layout.lean @@ -0,0 +1,331 @@ +import Mathlib.Data.List.Rotate +import Mathlib.Tactic + +/-! +Executable indexing model for `pcs/whir/commit.rs`, `whir/verify.rs`, +`whir.rs`, and `stack_open.rs` at edafd396120f453de6f75013f231bfda2049f217. +Lane blocks occupy the TOP witness coordinates. Stored L0 rows reverse only +live lanes; restoration prefixes zeros before reversing the full leaf. +No field law or cryptographic assumption is used here. +-/ +namespace Whir.Layout + +/-- The mathematical commit shape. `logRows > 0` is Rust's `log_n > k`. +There is deliberately no assumption that more than half the lanes are live: +the minimum stack-size floor and the public commit interface allow fewer. -/ +structure Shape where + logRows : Nat + logLanes : Nat + liveLanes : Nat + logInvRate : Nat + rowsPositive : 0 < logRows + livePositive : 0 < liveLanes + liveBound : liveLanes ≤ 2 ^ logLanes + ratePositive : 0 < logInvRate + deriving DecidableEq + +def Shape.rows (s : Shape) : Nat := 2 ^ s.logRows +def Shape.lanes (s : Shape) : Nat := 2 ^ s.logLanes +def Shape.positions (s : Shape) : Nat := 2 ^ (s.logRows + s.logInvRate) +def Shape.messageLength (s : Shape) : Nat := s.liveLanes * s.rows +def Shape.cubeLength (s : Shape) : Nat := s.lanes * s.rows + +/-- Additional bounds for Rust's 64-bit shifts and its 4096-word transpose tile. +These are not silently imposed on the algebraic model. -/ +def Shape.machineBounded (s : Shape) : Prop := + s.logRows + s.logLanes < 64 ∧ s.logRows + s.logInvRate < 64 ∧ + s.liveLanes ≤ 4096 ∧ s.positions * s.liveLanes < 2 ^ 64 + + theorem Shape.message_le_cube (s : Shape) : s.messageLength ≤ s.cubeLength := + Nat.mul_le_mul_right s.rows s.liveBound + +/-- Stack index: low row bits, then the high lane bits. -/ +def stackIndex (rows lane row : Nat) : Nat := lane * rows + row + + theorem stackIndex_partition {rows lane row : Nat} (h : row < rows) : + stackIndex rows lane row / rows = lane ∧ + stackIndex rows lane row % rows = row := by + constructor + · rw [stackIndex, Nat.mul_comm, Nat.mul_add_div (by omega)] + simp [Nat.div_eq_of_lt h] + · simp [stackIndex, Nat.add_mod, Nat.mod_eq_of_lt h] + + theorem stackIndex_bound {rows lanes lane row : Nat} + (hl : lane < lanes) (hr : row < rows) : stackIndex rows lane row < lanes * rows := by + unfold stackIndex + nlinarith + + theorem stackIndex_reconstruct (rows index : Nat) : + stackIndex rows (index / rows) (index % rows) = index := by + simpa [stackIndex, Nat.mul_comm, Nat.add_comm] using Nat.mod_add_div index rows + +/-- The actual descending-lane transpose, not a plain matrix transpose. -/ +def transposeIndex (lanes rows : Nat) : (Fin lanes × Fin rows) ≃ (Fin rows × Fin lanes) where + toFun p := (p.2, p.1.rev) + invFun p := (p.2.rev, p.1) + left_inv p := by simp + right_inv p := by simp + + theorem transposeIndex_lane (lanes rows : Nat) (p : Fin lanes × Fin rows) : + ((transposeIndex lanes rows p).2 : Nat) = lanes - 1 - p.1.val := by + change lanes - (p.1.val + 1) = lanes - 1 - p.1.val + omega + + theorem transposeIndex_inverse (lanes rows : Nat) (p : Fin lanes × Fin rows) : + (transposeIndex lanes rows).symm (transposeIndex lanes rows p) = p := + (transposeIndex lanes rows).symm_apply_apply p + + theorem transposeIndex_permutation (lanes rows : Nat) : + Function.Bijective (transposeIndex lanes rows) := + (transposeIndex lanes rows).bijective + +/-- Flat destination address used by `transpose_lane_major`. -/ +def codeIndex (lanes row lane : Nat) : Nat := row * lanes + (lanes - 1 - lane) + + theorem codeIndex_bound {lanes rows lane row : Nat} + (hl : lane < lanes) (hr : row < rows) : codeIndex lanes row lane < rows * lanes := by + have : lanes - 1 - lane < lanes := by omega + exact stackIndex_bound hr this + + theorem codeIndex_partition {lanes lane row : Nat} (hl : lane < lanes) : + codeIndex lanes row lane / lanes = row ∧ + lanes - 1 - (codeIndex lanes row lane % lanes) = lane := by + have hrev : lanes - 1 - lane < lanes := by omega + obtain ⟨hq, hr⟩ := stackIndex_partition (lane := row) hrev + constructor + · exact hq + · change lanes - 1 - (stackIndex lanes row (lanes - 1 - lane) % lanes) = lane + rw [hr] + omega + + theorem codeIndex_injective {lanes row row' lane lane' : Nat} + (h : lane < lanes) (h' : lane' < lanes) + (eq : codeIndex lanes row lane = codeIndex lanes row' lane') : + row = row' ∧ lane = lane' := by + obtain ⟨hq, hl⟩ := codeIndex_partition (row := row) h + obtain ⟨hq', hl'⟩ := codeIndex_partition (row := row') h' + rw [eq] at hq hl + exact ⟨hq.symm.trans hq', hl.symm.trans hl'⟩ + +/-- Executable transpose of bounded data, including the physical row reversal. -/ +def transposeData {α : Type*} {lanes rows : Nat} + (stack : Fin lanes × Fin rows → α) : Fin rows × Fin lanes → α := + fun p => stack ((transposeIndex lanes rows).symm p) + + theorem transposeData_recovers {α : Type*} {lanes rows : Nat} + (stack : Fin lanes × Fin rows → α) (p : Fin lanes × Fin rows) : + transposeData stack (transposeIndex lanes rows p) = stack p := by + simp [transposeData] + +/-- Padding in witness order is trailing; the full Merkle image reverses it. -/ +def padTail {α : Type*} (zero : α) (width : Nat) (live : List α) : List α := + live ++ List.replicate (width - live.length) zero + +def prunedLeaf {α : Type*} (live : List α) : List α := live.reverse + +def restoreLeaf {α : Type*} (zero : α) (width : Nat) (stored : List α) : List α := + List.replicate (width - stored.length) zero ++ stored + + theorem restoreLeaf_eq_full {α : Type*} (zero : α) (width : Nat) (live : List α) : + restoreLeaf zero width (prunedLeaf live) = (padTail zero width live).reverse := by + simp [restoreLeaf, prunedLeaf, padTail, List.reverse_append] + + theorem restored_reverse_eq_padding {α : Type*} (zero : α) (width : Nat) (live : List α) : + (restoreLeaf zero width (prunedLeaf live)).reverse = padTail zero width live := by + rw [restoreLeaf_eq_full, List.reverse_reverse] + + theorem restoreLeaf_length {α : Type*} (zero : α) (width : Nat) (stored : List α) + (h : stored.length ≤ width) : (restoreLeaf zero width stored).length = width := by + simp [restoreLeaf] + omega + + theorem restoreLeaf_drop_prefix {α : Type*} (zero : α) (width : Nat) (stored : List α) : + (restoreLeaf zero width stored).drop (width - stored.length) = stored := by + simp [restoreLeaf] + + theorem prunedLeaf_inverse {α : Type*} (live : List α) : (prunedLeaf live).reverse = live := by + simp [prunedLeaf] + +/-- A finitely supported weight sees no choice of witness outside its live prefix. -/ +theorem padding_noninterference {α : Type*} [MulZeroClass α] + (live width : Nat) (weight witness other : Nat → α) + (same : ∀ i, i < live → witness i = other i) + (support : ∀ i, live ≤ i → weight i = 0) : + (List.range width).map (fun i => witness i * weight i) = + (List.range width).map (fun i => other i * weight i) := by + apply List.map_congr_left + intro i _ + by_cases h : i < live + · rw [same i h] + · simp [support i (by omega)] + +/-- Only the caller's transparent weight consumes witness-coordinate order. -/ +def terminalPoint {α : Type*} (initialK : Nat) (roundPoint : List α) : List α := + roundPoint.rotate initialK + +/-- Induced and OOD weights keep their suffix of ROUND order. -/ +def levelPoint {α : Type*} (start : Nat) (folds tail : List α) : List α := + folds.drop start ++ tail + + theorem terminalPoint_order {α : Type*} (lanes low : List α) : + terminalPoint lanes.length (lanes ++ low) = low ++ lanes := by + simp [terminalPoint] + + theorem terminalPoint_length {α : Type*} (k : Nat) (point : List α) : + (terminalPoint k point).length = point.length := by simp [terminalPoint] + + theorem terminalPoint_permutation {α : Type*} (k : Nat) (point : List α) : + (terminalPoint k point).Perm point := List.rotate_perm point k + + theorem terminalPoint_inverse {α : Type*} (k : Nat) (point : List α) (h : k ≤ point.length) : + terminalPoint (point.length - k) (terminalPoint k point) = point := by + simp [terminalPoint, Nat.add_sub_of_le h] + + theorem terminalPoint_slices {α : Type*} (k : Nat) (point : List α) (h : k ≤ point.length) : + terminalPoint k point = point.drop k ++ point.take k := + List.rotate_eq_drop_append_take h + + theorem levelPoint_order {α : Type*} (before after tail : List α) : + levelPoint before.length (before ++ after) tail = after ++ tail := by + simp [levelPoint] + +/-- Bound-carrying counterpart of Rust's `Stratum`. -/ +structure Stratum (depth : Nat) where + bits : Nat + index : Nat + bits_le : bits ≤ depth + index_lt : index < 2 ^ bits + deriving DecidableEq + +/-- The group's `j`th coset, including modulo wrap beyond the domain size. -/ +def stratumAt (depth g j : Nat) : Stratum depth := + ⟨min g depth, j % 2 ^ min g depth, Nat.min_le_right _ _, Nat.mod_lt _ (by positivity)⟩ + +/-- One set binary digit, enumerated in increasing `j`, not sorted by query. -/ +def stratumGroup (depth g : Nat) : List (Stratum depth) := + (List.range (2 ^ g)).map (stratumAt depth g) + +/-- Scan the `width` binary digits from highest to lowest, just as Rust does. +Correct count requires `count < 2^width`; Rust uses `width = usize::BITS`. -/ +def strataBits (width count depth : Nat) : List (Stratum depth) := + match width with + | 0 => [] + | width + 1 => + if 2 ^ width ≤ count then + stratumGroup depth width ++ strataBits width (count - 2 ^ width) depth + else strataBits width count depth + + theorem stratumGroup_length (depth g : Nat) : (stratumGroup depth g).length = 2 ^ g := by + simp [stratumGroup] + + theorem strataBits_length (width count depth : Nat) (h : count < 2 ^ width) : + (strataBits width count depth).length = count := by + induction width generalizing count with + | zero => simp_all [strataBits] + | succ width ih => + have hp : 2 ^ (width + 1) = 2 ^ width * 2 := by rw [pow_succ] + simp only [strataBits] + split_ifs with hc + · rw [List.length_append, stratumGroup_length, ih (count - 2 ^ width) (by omega)] + omega + · exact ih count (by omega) + +/-- Low bits are sampled; top bits are replaced, never added with carry. -/ +def placeQuery {depth : Nat} (s : Stratum depth) (raw : Nat) : Nat := + raw % 2 ^ (depth - s.bits) + s.index * 2 ^ (depth - s.bits) + + theorem placeQuery_bound {depth : Nat} (s : Stratum depth) (raw : Nat) : + placeQuery s raw < 2 ^ depth := by + have hlo := Nat.mod_lt raw (show 0 < 2 ^ (depth - s.bits) by positivity) + have hpow : 2 ^ depth = 2 ^ s.bits * 2 ^ (depth - s.bits) := by + rw [← pow_add, Nat.add_sub_of_le s.bits_le] + unfold placeQuery + rw [hpow] + have hm := Nat.mul_le_mul_right (2 ^ (depth - s.bits)) (Nat.succ_le_iff.mpr s.index_lt) + nlinarith [s.index_lt] + + theorem placeQuery_top {depth : Nat} (s : Stratum depth) (raw : Nat) : + placeQuery s raw / 2 ^ (depth - s.bits) = s.index := by + have hp : 0 < 2 ^ (depth - s.bits) := by positivity + rw [placeQuery, Nat.add_mul_div_right _ _ hp] + simp [Nat.div_eq_of_lt (Nat.mod_lt raw hp)] + + theorem stratumAt_periodic (depth g j : Nat) : + stratumAt depth g (j + 2 ^ min g depth) = stratumAt depth g j := by + simp [stratumAt] + +/-- Once a group covers the whole domain, its queries are deterministic and +repeat every domain length. This permits counts larger than the domain. -/ +theorem fullDomain_query (depth g j raw : Nat) (h : depth ≤ g) : + placeQuery (stratumAt depth g j) raw = j % 2 ^ depth := by + simp [placeQuery, stratumAt, Nat.min_eq_right h, Nat.mod_one] + +theorem fullDomain_repeated (depth g j raw raw' : Nat) (h : depth ≤ g) : + placeQuery (stratumAt depth g (j + 2 ^ depth)) raw' = + placeQuery (stratumAt depth g j) raw := by + simp [fullDomain_query _ _ _ _ h] + +theorem partialDomain_distinct (depth g i j raw raw' : Nat) (h : g ≤ depth) + (hi : i < 2 ^ g) (hj : j < 2 ^ g) (hne : i ≠ j) : + placeQuery (stratumAt depth g i) raw ≠ placeQuery (stratumAt depth g j) raw' := by + intro heq + have ht := congrArg (fun q => q / 2 ^ (depth - g)) heq + have hti := placeQuery_top (stratumAt depth g i) raw + have htj := placeQuery_top (stratumAt depth g j) raw' + simp only [stratumAt, Nat.min_eq_left h, Nat.mod_eq_of_lt hi, + Nat.mod_eq_of_lt hj] at hti htj ht + rw [hti, htj] at ht + exact hne ht + +/-- The `i`th raw query consumes chunk `i % (192/depth)` of squeeze `i/(192/depth)`. +For the transcript sampler require `0 < depth ≤ 192`; Rust's domains satisfy this. -/ +def rawQuery (depth : Nat) (squeeze : Nat → Nat) (i : Nat) : Nat := + (squeeze (i / (192 / depth)) / 2 ^ ((i % (192 / depth)) * depth)) % 2 ^ depth + + theorem rawQuery_bound (depth : Nat) (squeeze : Nat → Nat) (i : Nat) : + rawQuery depth squeeze i < 2 ^ depth := Nat.mod_lt _ (by positivity) + + theorem query_chunks_positive {depth : Nat} (hpos : 0 < depth) (hmax : depth ≤ 192) : + 0 < 192 / depth := Nat.div_pos hmax hpos + + theorem query_chunk_fits {depth : Nat} (hpos : 0 < depth) (hmax : depth ≤ 192) (i : Nat) : + (i % (192 / depth)) * depth + depth ≤ 192 := by + have hm := Nat.mod_lt i (query_chunks_positive hpos hmax) + have hmul := Nat.mul_le_mul_right depth (Nat.succ_le_iff.mpr hm) + have hd := Nat.div_mul_le_self 192 depth + nlinarith + +/-- Query-indexed map, not a set: no deduplication and no sorting. -/ +def sampleQueries (width count depth : Nat) (squeeze : Nat → Nat) : List Nat := + ((strataBits width count depth).zipIdx).map fun p => placeQuery p.1 (rawQuery depth squeeze p.2) + + theorem sampleQueries_length (width count depth : Nat) (squeeze : Nat → Nat) + (h : count < 2 ^ width) : (sampleQueries width count depth squeeze).length = count := by + simp [sampleQueries, strataBits_length width count depth h] + + theorem sampleQueries_bound (width count depth : Nat) (squeeze : Nat → Nat) + (q : Nat) (h : q ∈ sampleQueries width count depth squeeze) : q < 2 ^ depth := by + obtain ⟨p, _, rfl⟩ := List.mem_map.mp h + exact placeQuery_bound _ _ + + theorem sampleQueries_order (width count depth : Nat) (squeeze : Nat → Nat) + (i : Nat) (hi : i < (strataBits width count depth).length) : + (sampleQueries width count depth squeeze)[i]'(by simp [sampleQueries]; exact hi) = + placeQuery ((strataBits width count depth)[i]) (rawQuery depth squeeze i) := by + simp [sampleQueries] + +/-- Repeated positions re-open the same row and remain repeated list entries. -/ +def openRows {α : Type*} (oracle : Nat → α) (queries : List Nat) : List α := queries.map oracle + + theorem openRows_append {α : Type*} (oracle : Nat → α) (before after : List Nat) (q : Nat) : + openRows oracle (before ++ q :: q :: after) = + openRows oracle before ++ oracle q :: oracle q :: openRows oracle after := by + simp [openRows] + + theorem repeatedQuery_row {α : Type*} (oracle : Nat → α) (queries : List Nat) + (i j : Fin queries.length) (h : queries[i] = queries[j]) : + (openRows oracle queries)[i.val]'(by simp [openRows]) = + (openRows oracle queries)[j.val]'(by simp [openRows]) := by + simpa [openRows] using congrArg oracle h + +end Whir.Layout diff --git a/verification/whir/Whir/Protocol.lean b/verification/whir/Whir/Protocol.lean new file mode 100644 index 000000000..a58d22627 --- /dev/null +++ b/verification/whir/Whir/Protocol.lean @@ -0,0 +1,253 @@ +import Whir.Concrete + +/-! Dense executable replay of the production WHIR opening schedule. +Commitments are ideal immutable row arrays and authentication is exact lookup. +Challenges are an explicit independent input. This is not a hash, Fiat-Shamir, +proof-of-work, succinct verifier, or cryptographic soundness implementation. -/ +namespace Whir.Protocol +open Concrete + +structure Config where + logN : Nat + folds : Array Nat + rates : Array Nat + queries : Array Nat + oodCounts : Array Nat + deriving Repr, Inhabited + +def Config.valid (c : Config) : Bool := Id.run do + let levels := c.folds.size + if levels < 2 || c.rates.size != levels || c.queries.size != levels || + c.oodCounts.size != levels || c.oodCounts[0]! != 0 then return false + let mut n := c.logN + for i in [:levels] do + if c.folds[i]! == 0 || c.folds[i]! >= n || c.rates[i]! == 0 || c.queries[i]! == 0 then return false + n := n-c.folds[i]! + if n+c.rates[i]! >= 64 then return false + return true + +/-- The production query table, not a floating-point soundness derivation. -/ +def productionQueries : Array (Array (Array Nat)) := #[ + #[#[222,55], #[223,56,30], #[223,56,31], #[223,56,32], #[223,56,32], + #[223,56,32,22], #[223,56,32,22], #[224,56,32,23], #[224,56,32,23], + #[224,56,32,23,17], #[224,56,32,23,17], #[224,56,32,23,18], + #[225,56,32,23,18], #[225,56,32,23,18,14]], + #[#[111,45], #[112,45,27], #[112,45,28], #[112,45,28], #[112,45,28], + #[112,45,28,20], #[112,45,28,20], #[112,45,28,21], #[112,45,28,21], + #[112,45,28,21,16], #[112,45,28,21,16], #[112,45,28,21,16], + #[112,45,28,21,16], #[112,45,28,21,16,13]], + #[#[75,37], #[75,37,24], #[75,37,25], #[75,38,25], #[75,38,25], + #[75,38,25,18], #[75,38,25,19], #[75,38,25,19], #[75,38,25,19], + #[75,38,25,19,15], #[75,38,25,19,15], #[75,38,25,19,15], + #[75,38,25,19,15], #[75,38,25,19,15,13]], + #[#[56,32], #[56,32,22], #[56,32,22], #[56,32,23], #[56,32,23], + #[56,32,23,17], #[56,32,23,17], #[56,32,23,18], #[56,32,23,18], + #[56,32,23,18,14], #[56,32,23,18,14], #[56,32,23,18,14], + #[56,32,23,18,15], #[56,32,23,18,15,12]]] + +/-- Production integer ladder. Grinding is deliberately external to this model. -/ +def productionConfig (logN rate : Nat) : Option Config := Id.run do + if logN < 15 || logN > 28 || rate < 1 || rate > 4 then return none + let mut n := logN-6 + let mut folds := #[6] + let mut rates := #[rate] + let mut currentRate := rate + for _ in [:logN] do + if n > 5 then + let k := min 4 n + currentRate := currentRate + 3 + folds := folds.push k + rates := rates.push currentRate + n := n-k + return some ⟨logN, folds, rates, productionQueries[rate-1]![logN-15]!, + tab folds.size (fun i => if i == 0 then 0 else 1)⟩ + +structure LevelChallenges where + folds : Array E + oodPoints : Array (Array E) + querySqueezes : Array E + lambda : E + deriving Repr, Inhabited + +structure Challenges where + levels : Array LevelChallenges + tail : Array E + deriving Repr, Inhabited + +def Challenges.valid (c : Config) (ch : Challenges) : Bool := Id.run do + if !c.valid || ch.levels.size != c.folds.size then return false + let mut n := c.logN + for i in [:c.folds.size] do + n := n-c.folds[i]! + let l := ch.levels[i]! + let count := if i+1 < c.folds.size then c.oodCounts[i+1]! else 0 + if l.folds.size != c.folds[i]! || l.oodPoints.size != count then return false + if !(l.oodPoints.all fun p => p.size == n) then return false + if (deriveQueries (n+c.rates[i]!) c.queries[i]! l.querySqueezes).isNone then return false + return ch.tail.size == n + +/-- The actual two transmitted coefficients. The linear coefficient is claim+u2. -/ +structure Message where + u0 : E + u2 : E + deriving Repr, Inhabited, BEq + +def Message.eval (m : Message) (claim r : E) : E := + m.u0 + r * (claim + m.u2) + (r*r) * m.u2 + +def Message.glue (m other : Message) (s : E) : Message := + ⟨m.u0 + s*other.u0, m.u2 + s*other.u2⟩ + +def roundMessage (f b : Array E) (block : Nat := 1) : Message := Id.run do + let mut m := Message.mk E.zero E.zero + for i in [:f.size/2] do + let offset := (i/block)*(2*block)+i%block + let a := f[offset]! + let a' := f[offset+block]! + let w := b[offset]! + let w' := b[offset+block]! + m := ⟨m.u0 + a*w, m.u2 + (a+a')*(w+w')⟩ + return m + +abbrev Oracle := Array (Array E) + +structure OodClaim where + value : E + intro : Message + deriving Repr, Inhabited + +structure LevelProof where + afterFold : Array Message + nextOracle : Option Oracle + oods : Array OodClaim + rows : Array (Array E) + intro : Message + deriving Repr, Inhabited + +structure Opening where + initial : Message + levels : Array LevelProof + residual : Array E + tailMessages : Array Message + deriving Repr, Inhabited + +def weightGlue (b other : Array E) (s : E) : Array E := + tab b.size fun j => b[j]! + s*other[j]! + +def enforced (rows : Array (Array E)) (rs weights : Array E) (base : Bool) : E := + let eq := eqTable rs + (tab rows.size fun i => weights[i]! * dot (if base then rows[i]!.reverse else rows[i]!) eq).foldl (· + ·) E.zero + +def shapeValid (c : Config) (lanes : Nat) (b : Array E) : Bool := + c.valid && lanes > 0 && lanes ≤ 2^c.folds[0]! && b.size == 2^c.logN && + (b.extract (lanes * 2^(c.logN-c.folds[0]!)) b.size).all (· == E.zero) + +def oracleValid (o : Oracle) (rows width : Nat) : Bool := + o.size == rows && o.all (fun row => row.size == width) + +/-- Honest prover, with the same lane-first, OOD-before-query, intro/glue schedule. -/ +def prove (c : Config) (ch : Challenges) (witness : Array K) (bInitial : Array E) + (target : E) : Except String (Oracle × Opening) := do + if !ch.valid c then throw "configuration/challenges" + let block := 2^(c.logN-c.folds[0]!) + let lanes := witness.size/block + if witness.size != lanes*block || !shapeValid c lanes bInitial then throw "witness/weight shape" + let mut f := tab (2^c.logN) fun i => E.ofK (witness[i]?.getD 0) + let mut b := bInitial + if dot f b != target then throw "incorrect target" + let root := encodeBase witness c.logN c.folds[0]! c.rates[0]! + let mut oracle := root + let initial := roundMessage f b block + let mut levels := #[] + let mut residual := #[] + let mut n := c.logN + for i in [:c.folds.size] do + let cs := ch.levels[i]! + let mut afterFold := #[] + for j in [:cs.folds.size] do + let r := cs.folds[j]! + f := if i == 0 then foldLane f block r else foldLow f r + b := if i == 0 then foldLane b block r else foldLow b r + n := n-1 + afterFold := afterFold.push (roundMessage f b (if i == 0 && j+1 < cs.folds.size then block else 1)) + let nextOracle := if i+1 < c.folds.size then some (encodeExt f n c.folds[i+1]! c.rates[i+1]!) else none + if i+1 == c.folds.size then residual := f + let mut oods := #[] + let mut pending : Array (Array E) := #[] + for z in cs.oodPoints do + let weight := eqTable z + oods := oods.push ⟨dot f weight, roundMessage f weight⟩ + pending := pending.push weight + let qs ← (deriveQueries (n+c.rates[i]!) c.queries[i]! cs.querySqueezes).elim (throw "query challenges") pure + let ws := powers cs.lambda qs.size + let rows := qs.map fun q => oracle[q]! + let basis := induced n qs ws + let intro := roundMessage f basis + let mut scalar := E.one + for weight in pending do + scalar := scalar*cs.lambda + b := weightGlue b weight scalar + scalar := scalar*cs.lambda + b := weightGlue b basis scalar + levels := levels.push ⟨afterFold, nextOracle, oods, rows, intro⟩ + oracle := nextOracle.getD #[] + let mut tailMessages := #[] + for j in [:ch.tail.size] do + f := foldLow f ch.tail[j]! + b := foldLow b ch.tail[j]! + if j+1 < ch.tail.size then tailMessages := tailMessages.push (roundMessage f b) + return (root, ⟨initial, levels, residual, tailMessages⟩) + +/-- Untrusted opening verifier. No access to the original witness or prover state. +The dense weight is retained for clarity; production evaluates it succinctly. -/ +def verify (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (bInitial : Array E) (target : E) (proof : Opening) : Except String Unit := do + if !ch.valid c || !shapeValid c lanes bInitial then throw "configuration/challenges/weight" + let block := 2^(c.logN-c.folds[0]!) + if !oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes then throw "root shape" + if proof.levels.size != c.folds.size || proof.tailMessages.size+1 != ch.tail.size then throw "proof length" + let mut n := c.logN + let mut b := bInitial + let mut oracle := root + let mut claim := target + let mut msg := proof.initial + for i in [:c.folds.size] do + let cs := ch.levels[i]! + let p := proof.levels[i]! + if p.afterFold.size != cs.folds.size || p.oods.size != cs.oodPoints.size then throw "round/OOD length" + for j in [:cs.folds.size] do + claim := msg.eval claim cs.folds[j]! + msg := p.afterFold[j]! + b := if i == 0 then foldLane b block cs.folds[j]! else foldLow b cs.folds[j]! + n := n-1 + if i+1 < c.folds.size then + let next ← p.nextOracle.elim (throw "missing commitment") pure + if !oracleValid next (2^(n-c.folds[i+1]!+c.rates[i+1]!)) (2^c.folds[i+1]!) then throw "commitment shape" + else + if p.nextOracle.isSome || proof.residual.size != 2^n then throw "final length" + let qs ← (deriveQueries (n+c.rates[i]!) c.queries[i]! cs.querySqueezes).elim (throw "query challenges") pure + if p.rows.size != qs.size then throw "query length" + for j in [:qs.size] do + if p.rows[j]! != oracle[qs[j]!]! then throw "authentication" + let ws := powers cs.lambda qs.size + let sum := enforced p.rows cs.folds ws (i == 0) + let mut scalar := E.one + for j in [:p.oods.size] do + scalar := scalar*cs.lambda + let ood := p.oods[j]! + claim := claim + scalar*ood.value + msg := msg.glue ood.intro scalar + b := weightGlue b (eqTable cs.oodPoints[j]!) scalar + scalar := scalar*cs.lambda + claim := claim + scalar*sum + msg := msg.glue p.intro scalar + b := weightGlue b (induced n qs ws) scalar + oracle := p.nextOracle.getD #[] + for j in [:ch.tail.size] do + claim := msg.eval claim ch.tail[j]! + b := foldLow b ch.tail[j]! + if j+1 < ch.tail.size then msg := proof.tailMessages[j]! + if claim != mle proof.residual ch.tail * b[0]! then throw "terminal mismatch" + return () + +end Whir.Protocol diff --git a/verification/whir/Whir/QuerySoundness.lean b/verification/whir/Whir/QuerySoundness.lean new file mode 100644 index 000000000..ea9179bce --- /dev/null +++ b/verification/whir/Whir/QuerySoundness.lean @@ -0,0 +1,47 @@ +import Mathlib.Analysis.MeanInequalities +import Mathlib.Tactic + +namespace Whir.QuerySoundness + +open scoped BigOperators + +/-- Product of coset densities for one independent stratified query per coset. -/ +def missProduct {I : Type*} [Fintype I] (density : I → ℝ) : ℝ := ∏ i, density i + +/-- Annex B's AM-GM step, valid even if a coset density is zero. -/ +theorem strata_amgm {I : Type*} [Fintype I] [Nonempty I] + (density : I → ℝ) (nonneg : ∀ i, 0 ≤ density i) : + missProduct density ≤ ((∑ i, density i) / Fintype.card I) ^ Fintype.card I := by + classical + have hc : 0 < (Fintype.card I : ℝ) := by exact_mod_cast Fintype.card_pos + have h := Real.geom_mean_le_arith_mean Finset.univ (fun _ : I => (1 : ℝ)) density + (by simp) (by simpa using hc) (fun i _ => nonneg i) + simp only [Real.rpow_one, Finset.sum_const, Finset.card_univ, nsmul_eq_mul, + mul_one, one_mul] at h + have raised := pow_le_pow_left₀ (Real.rpow_nonneg (Finset.prod_nonneg (fun i _ => nonneg i)) _) h + (Fintype.card I) + simpa only [Real.rpow_inv_natCast_pow (Finset.prod_nonneg (fun i _ => nonneg i)) + (Nat.ne_of_gt Fintype.card_pos), missProduct] using raised + +/-- A group can repeat every coset equally, including when query count exceeds domain size. +The repeated draws remain independent, not deduplicated. -/ +theorem group_miss_bound {I : Type*} [Fintype I] [Nonempty I] + (density : I → ℝ) (nonneg : ∀ i, 0 ≤ density i) (repetitions : ℕ) : + missProduct density ^ repetitions ≤ + ((∑ i, density i) / Fintype.card I) ^ (Fintype.card I * repetitions) := by + have h := pow_le_pow_left₀ (Finset.prod_nonneg (fun i _ => nonneg i)) + (strata_amgm density nonneg) repetitions + simpa only [pow_mul, missProduct] using h + +/-- Independent binary groups' query counts add in the exponent. -/ +theorem batch_miss_bound {G : Type*} [Fintype G] + (miss : G → ℝ) (counts : G → ℕ) (density : ℝ) + (nonneg : ∀ g, 0 ≤ miss g) (bounds : ∀ g, miss g ≤ density ^ counts g) : + (∏ g, miss g) ≤ density ^ (∑ g, counts g) := by + classical + calc + _ ≤ ∏ g, density ^ counts g := + Finset.prod_le_prod₀ (fun g _ => nonneg g) (fun g _ => bounds g) + _ = _ := (Finset.prod_pow_eq_pow_sum ..) + +end Whir.QuerySoundness diff --git a/verification/whir/Whir/RingSwitch.lean b/verification/whir/Whir/RingSwitch.lean new file mode 100644 index 000000000..8499ad90b --- /dev/null +++ b/verification/whir/Whir/RingSwitch.lean @@ -0,0 +1,110 @@ +import Mathlib.Algebra.BigOperators.Ring.Finset +import Mathlib.Algebra.CharP.Lemmas +import Mathlib.Tactic + +namespace Whir.RingSwitch + +open scoped BigOperators + +variable {E : Type*} [CommRing E] + +/-- Bit multiplication is selection, so an additive map suffices; E-linearity is not assumed. -/ +def bit (b : Bool) : E := if b then 1 else 0 + +theorem map_bit_mul (φ : E →+ E) (b : Bool) (x : E) : + φ (bit b * x) = bit b * φ x := by + cases b <;> simp [bit] + +/-- The six stages in Annex A act additively, not E-linearly. -/ +def stage [CharP E 2] (f : E) (shift : ℕ) : E →+ E where + toFun a := a + f * a ^ (2 ^ shift) + map_zero' := by simp + map_add' a b := by + rw [add_pow_char_pow, mul_add] + abel + +/-- The production shift order is 32,16,8,4,2,1. -/ +def composedMap [CharP E 2] (challenges : Fin 6 → E) : E →+ E := + (List.finRange 6).foldl + (fun φ p => (stage (challenges p) (2 ^ (5 - p.val))).comp φ) + (AddMonoidHom.id E) + +theorem composedMap_add [CharP E 2] (challenges : Fin 6 → E) (a b : E) : + composedMap challenges (a + b) = composedMap challenges a + composedMap challenges b := + map_add _ _ _ + +variable {I U J : Type*} [Fintype I] [Fintype U] [Fintype J] + +/-- Packed words, with the choice of basis explicit. The application uses 64 powers of x. -/ +def packed (basis : I → E) (bits : I → U → Bool) (u : U) : E := + ∑ i, bit (bits i u) * basis i + +/-- A slice evaluation, including an arbitrary claim's point weight. -/ +def slice (weight : U → E) (bits : I → U → Bool) (i : I) : E := + ∑ u, bit (bits i u) * weight u + +/-- Annex A equation (complete), for any additive map and any honest bit slices. -/ +theorem honest_ring_switch (φ : E →+ E) (basis : I → E) + (bits : I → U → Bool) (weight : U → E) : + (∑ i, basis i * φ (slice weight bits i)) = + ∑ u, φ (weight u) * packed basis bits u := by + simp only [slice, packed, map_sum, map_bit_mul, Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro u _ + apply Finset.sum_congr rfl + intro i _ + ring + +/-- The family target applies the map after batching the slices. -/ +def familyTarget (φ : E →+ E) (basis : I → E) + (scales : J → E) (slices : J → I → E) : E := + ∑ i, basis i * φ (∑ j, scales j * slices j i) + +/-- Arbitrary points and repeated regions are allowed. Scales stay inside φ. -/ +theorem honest_family (φ : E →+ E) (basis : I → E) + (bits : J → I → U → Bool) (weights : J → U → E) (scales : J → E) : + familyTarget φ basis scales (fun j => slice (weights j) (bits j)) = + ∑ j, ∑ u, φ (scales j * weights j u) * packed basis (bits j) u := by + unfold familyTarget + simp only [map_sum, Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + have hs (i : I) : scales j * slice (weights j) (bits j) i = + slice (fun u => scales j * weights j u) (bits j) i := by + simp only [slice, Finset.mul_sum] + apply Finset.sum_congr rfl + intro u _ + ring + simp_rw [hs] + exact honest_ring_switch φ basis (bits j) (fun u => scales j * weights j u) + +/-- Stack placements are injections individually; overlapping regions add their weights. -/ +def placeWeight {V : Type*} [Fintype V] [DecidableEq V] + (positions : U → V) (w : U → E) (v : V) : E := + ∑ u, if positions u = v then w u else 0 + +theorem stacked_claim {V : Type*} [Fintype V] [DecidableEq V] + (positions : J → U → V) (weights : J → U → E) (stack : V → E) : + (∑ v, (∑ j, placeWeight (positions j) (weights j) v) * stack v) = + ∑ j, ∑ u, weights j u * stack (positions j u) := by + simp only [placeWeight, Finset.sum_mul] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro u _ + simp + +/-- Padding outside every claim's support cannot change the stacked claim. -/ +theorem padding_noninterference {V : Type*} [Fintype V] [DecidableEq V] + (positions : J → U → V) (weights : J → U → E) (stack padded : V → E) + (agree : ∀ j u, padded (positions j u) = stack (positions j u)) : + (∑ v, (∑ j, placeWeight (positions j) (weights j) v) * padded v) = + ∑ v, (∑ j, placeWeight (positions j) (weights j) v) * stack v := by + rw [stacked_claim, stacked_claim] + simp_rw [agree] + +end Whir.RingSwitch diff --git a/verification/whir/Whir/Soundness.lean b/verification/whir/Whir/Soundness.lean new file mode 100644 index 000000000..cfb5510f3 --- /dev/null +++ b/verification/whir/Whir/Soundness.lean @@ -0,0 +1,199 @@ +import Mathlib.Algebra.Polynomial.Roots +import Mathlib.Data.Fintype.BigOperators +import Mathlib.Tactic + +namespace Whir.Soundness + +open scoped BigOperators +open Polynomial + +/-- Exact probability under the uniform distribution on a finite sample space. -/ +def uniformProb {Ω : Type*} [Fintype Ω] (event : Finset Ω) : ℚ := + (event.card : ℚ) / Fintype.card Ω + +variable {F : Type*} [Field F] [Fintype F] [DecidableEq F] + +/-- A challenge is sampled after the nonzero error polynomial is fixed. -/ +theorem root_count (p : F[X]) (hp : p ≠ 0) : + (Finset.univ.filter (fun x => p.eval x = 0)).card ≤ p.natDegree := by + apply Polynomial.card_le_degree_of_subset_roots + intro x hx + exact (Polynomial.mem_roots hp).mpr (Finset.mem_filter.mp hx).2 + +theorem root_error (p : F[X]) (hp : p ≠ 0) (d : ℕ) (hd : p.natDegree ≤ d) : + uniformProb (Finset.univ.filter (fun x => p.eval x = 0)) ≤ + (d : ℚ) / Fintype.card F := by + unfold uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast (root_count p hp).trans hd) + (by positivity) + +/-- An adaptive prover may choose the error from any finite prior history. The new +challenge is independent and uniform, represented by the product sample space. -/ +theorem adaptive_root_count {History : Type*} [Fintype History] + (errors : History → F[X]) (d : ℕ) (nonzero : ∀ h, errors h ≠ 0) + (degrees : ∀ h, (errors h).natDegree ≤ d) : + (Finset.univ.filter (fun hr : History × F => (errors hr.1).eval hr.2 = 0)).card ≤ + Fintype.card History * d := by + classical + have count : + (Finset.univ.filter (fun hr : History × F => (errors hr.1).eval hr.2 = 0)).card = + ∑ h : History, (Finset.univ.filter fun r => (errors h).eval r = 0).card := by + simp only [Finset.card_filter, Fintype.sum_prod_type] + rw [count] + calc + _ ≤ ∑ _h : History, d := + Finset.sum_le_sum (fun h _ => (root_count _ (nonzero h)).trans (degrees h)) + _ = _ := by simp + +/-- Distinct round polynomials have at most d accepting challenges. -/ +theorem round_error (honest sent : F[X]) (hne : honest ≠ sent) + (d : ℕ) (hh : honest.natDegree ≤ d) (hs : sent.natDegree ≤ d) : + uniformProb (Finset.univ.filter (fun r => honest.eval r = sent.eval r)) ≤ + (d : ℚ) / Fintype.card F := by + have hp : honest - sent ≠ 0 := sub_ne_zero.mpr hne + have hdeg : (honest - sent).natDegree ≤ d := + (natDegree_sub_le honest sent).trans (max_le hh hs) + simpa only [eval_sub, sub_eq_zero] using root_error (honest - sent) hp d hdeg + +omit [Fintype F] in +/-- Distinct RS polynomials agree in at most their degree bound on any domain. -/ +theorem evaluation_agreement (domain : Finset F) (p q : F[X]) (hne : p ≠ q) + (d : ℕ) (hp : p.natDegree ≤ d) (hq : q.natDegree ≤ d) : + (domain.filter fun x => p.eval x = q.eval x).card ≤ d := by + have hsub : (domain.filter fun x => p.eval x = q.eval x).val ⊆ (p - q).roots := by + intro x hx + apply (Polynomial.mem_roots (sub_ne_zero.mpr hne)).mpr + change (p - q).eval x = 0 + simp only [eval_sub, sub_eq_zero] + exact (Finset.mem_filter.mp hx).2 + exact (Polynomial.card_le_degree_of_subset_roots hsub).trans + ((natDegree_sub_le p q).trans (max_le hp hq)) + +omit [Fintype F] in +/-- Absolute Reed-Solomon distance, before any relative-distance division. -/ +theorem reed_solomon_distance (domain : Finset F) (p q : F[X]) (hne : p ≠ q) + (d : ℕ) (hp : p.natDegree ≤ d) (hq : q.natDegree ≤ d) : + domain.card - d ≤ (domain.filter fun x => p.eval x ≠ q.eval x).card := by + have ha := evaluation_agreement domain p q hne d hp hq + have hc := Finset.card_filter_add_card_filter_not (s := domain) (fun x => p.eval x = q.eval x) + change (domain.filter fun x => p.eval x = q.eval x).card + + (domain.filter fun x => p.eval x ≠ q.eval x).card = domain.card at hc + omega + +omit [Fintype F] [DecidableEq F] in +/-- A false incoming sum forces an honest polynomial to differ from every accepted message. -/ +theorem false_claim_distinct (honest sent : F[X]) (claim : F) + (falseClaim : honest.eval 0 + honest.eval 1 ≠ claim) + (acceptedMessage : sent.eval 0 + sent.eval 1 = claim) : honest ≠ sent := by + intro h + exact falseClaim (h ▸ acceptedMessage) + +/-- The quadratic sumcheck round error, including characteristic two. -/ +theorem sumcheck_round_error (honest sent : F[X]) (claim : F) + (falseClaim : honest.eval 0 + honest.eval 1 ≠ claim) + (acceptedMessage : sent.eval 0 + sent.eval 1 = claim) + (hh : honest.natDegree ≤ 2) (hs : sent.natDegree ≤ 2) : + uniformProb (Finset.univ.filter (fun r => honest.eval r = sent.eval r)) ≤ + (2 : ℚ) / Fintype.card F := + round_error honest sent (false_claim_distinct honest sent claim falseClaim acceptedMessage) 2 hh hs + +/-- A nonzero coefficient witnesses that a batched error cannot vanish identically. -/ +theorem batching_error (errors : F[X]) (i d : ℕ) (hi : errors.coeff i ≠ 0) + (hd : errors.natDegree ≤ d) : + uniformProb (Finset.univ.filter (fun r => errors.eval r = 0)) ≤ + (d : ℚ) / Fintype.card F := by + apply root_error errors _ d hd + intro h + exact hi (by simp [h]) + +variable {Ω : Type*} [Fintype Ω] [DecidableEq Ω] + +/-- No independence assumption is required for a union bound. -/ +theorem union_bound {I : Type*} [Fintype I] (events : I → Finset Ω) : + uniformProb (Finset.univ.biUnion events) ≤ ∑ i, uniformProb (events i) := by + classical + unfold uniformProb + rw [← Finset.sum_div] + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_biUnion_le + +/-- A finite list may contain many candidates; every candidate's error remains explicit. -/ +theorem list_root_error {I : Type*} [Fintype I] + (errors : I → F[X]) (d : ℕ) (nonzero : ∀ i, errors i ≠ 0) + (degrees : ∀ i, (errors i).natDegree ≤ d) : + uniformProb (Finset.univ.biUnion fun i => Finset.univ.filter fun r => (errors i).eval r = 0) ≤ + (Fintype.card I : ℚ) * ((d : ℚ) / Fintype.card F) := by + classical + calc + _ ≤ ∑ i, uniformProb (Finset.univ.filter fun r => (errors i).eval r = 0) := union_bound _ + _ ≤ ∑ _i : I, (d : ℚ) / Fintype.card F := + Finset.sum_le_sum (fun i _ => root_error _ (nonzero i) d (degrees i)) + _ = _ := by simp + +/-- First-escape decomposition for a deterministic adversary on a sampled randomness tape. +The invariant means the prover has lost. Prover transitions must preserve it; the caller +supplies bounds only for verifier escapes, not a target whole-protocol soundness bound. -/ +theorem first_escape (lost : ℕ → Prop) [DecidablePred lost] (n : ℕ) + (initial : lost 0) (final : ¬ lost n) : + ∃ i < n, lost i ∧ ¬ lost (i + 1) := by + induction n with + | zero => exact (final initial).elim + | succ n ih => + by_cases h : lost n + · exact ⟨n, Nat.lt_succ_self n, h, final⟩ + · obtain ⟨i, hi, hl, hn⟩ := ih h + exact ⟨i, Nat.lt_succ_of_lt hi, hl, hn⟩ + +/-- Round-by-round error accumulation, for arbitrary (including adaptive) transcripts. -/ +theorem rbr_composition (n : ℕ) (lost : Ω → ℕ → Prop) + [∀ ω, DecidablePred (lost ω)] (accepts : Ω → Prop) [DecidablePred accepts] + (initial : ∀ ω, lost ω 0) (terminal : ∀ ω, lost ω n → ¬ accepts ω) + (errors : Fin n → ℚ) + (roundBounds : ∀ i : Fin n, + uniformProb (Finset.univ.filter fun ω => lost ω i ∧ ¬ lost ω (i + 1)) ≤ errors i) : + uniformProb (Finset.univ.filter accepts) ≤ ∑ i, errors i := by + classical + let events : Fin n → Finset Ω := fun i => Finset.univ.filter fun ω => lost ω i ∧ ¬ lost ω (i + 1) + have sub : Finset.univ.filter accepts ⊆ Finset.univ.biUnion events := by + intro ω hω + have acc := (Finset.mem_filter.mp hω).2 + obtain ⟨i, hi, hl, hn⟩ := first_escape (lost ω) n (initial ω) (fun h => terminal ω h acc) + exact Finset.mem_biUnion.mpr ⟨⟨i, hi⟩, Finset.mem_univ _, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hl, hn⟩⟩ + calc + _ ≤ uniformProb (Finset.univ.biUnion events) := by + unfold uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast Finset.card_le_card sub) (by positivity) + _ ≤ ∑ i, uniformProb (events i) := union_bound events + _ ≤ ∑ i, errors i := Finset.sum_le_sum (fun i _ => roundBounds i) + +omit [Fintype Ω] in +/-- Grinding conditions the tape: the denominator is the number of permitted tapes, +not the original sample-space size. This statement does not justify a ROM compiler. -/ +theorem conditioned_bound (bad permitted : Finset Ω) (bound : ℕ) (h : bad.card ≤ bound) : + ((bad ∩ permitted).card : ℚ) / permitted.card ≤ (bound : ℚ) / permitted.card := by + exact div_le_div_of_nonneg_right + (by exact_mod_cast (Finset.card_le_card Finset.inter_subset_left).trans h) (by positivity) + +/-- Ideal list binding is a relation, not unique binding or a BLAKE2 theorem. -/ +def ListExplains {Commitment Message Claim : Type*} + (candidates : Commitment → Finset Message) (satisfies : Message → Claim → Prop) + (commitment : Commitment) (claims : List Claim) : Prop := + ∃ message ∈ candidates commitment, ∀ claim ∈ claims, satisfies message claim + +/-- Quantified ideal-interactive list binding. The candidate list is chosen from +the commitment before the strategy and its opened claims. The experiment supplies +the actual verifier, rather than allowing the adversary to set an acceptance bit. +No theorem here asserts that WHIR or a concrete transcript satisfies this game. -/ +noncomputable def ListBinding {Commitment Message Claim Strategy : Type*} + (satisfies : Message → Claim → Prop) + (verify : Commitment → Strategy → Ω → Bool) + (claims : Commitment → Strategy → Ω → List Claim) + (listBound : ℕ) (error : ℚ) : Prop := by + classical + exact ∀ commitment, ∃ candidates : Finset Message, candidates.card ≤ listBound ∧ + ∀ strategy, uniformProb (Finset.univ.filter fun tape => + verify commitment strategy tape = true ∧ + ¬ ∃ message ∈ candidates, + ∀ claim ∈ claims commitment strategy tape, satisfies message claim) ≤ error + +end Whir.Soundness diff --git a/verification/whir/differential/Cargo.lock b/verification/whir/differential/Cargo.lock new file mode 100644 index 000000000..4b5531158 --- /dev/null +++ b/verification/whir/differential/Cargo.lock @@ -0,0 +1,203 @@ +# This file is automatically @generated by Cargo. +# It is not intended for manual editing. +version = 4 + +[[package]] +name = "bincode" +version = "1.3.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b1f45e9417d87227c7a56d22e471c6206462cba514c7590c09aff4cf6d1ddcad" +dependencies = [ + "serde", +] + +[[package]] +name = "fiat_shamir" +version = "0.1.0" +dependencies = [ + "bincode", + "parallel", + "primitives", + "serde", + "thiserror", +] + +[[package]] +name = "libc" +version = "0.2.190" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ce5d3ddc6d3fa000eb1536d85e147bfe31aacaba692ed6a876f95cb7c855be78" + +[[package]] +name = "once_cell" +version = "1.21.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9f7c3e4beb33f85d45ae3e3a1792185706c8e16d043238c593331cc7cd313b50" + +[[package]] +name = "parallel" +version = "0.1.0" +dependencies = [ + "libc", +] + +[[package]] +name = "pcs" +version = "0.1.0" +dependencies = [ + "fiat_shamir", + "parallel", + "primitives", + "thiserror", + "tracing", +] + +[[package]] +name = "pin-project-lite" +version = "0.2.17" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "a89322df9ebe1c1578d689c92318e070967d1042b512afbe49518723f4e6d5cd" + +[[package]] +name = "primitives" +version = "0.1.0" +dependencies = [ + "parallel", + "serde", +] + +[[package]] +name = "proc-macro2" +version = "1.0.107" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "985e7ec9bb745e6ce6535b544d84d6cd6f7ad8bd711c398938ae983b91a766d9" +dependencies = [ + "unicode-ident", +] + +[[package]] +name = "quote" +version = "1.0.47" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "1fbf4db142a473a8d80c26bbf18454ed458bf8d26c8219c331daecfdbd079001" +dependencies = [ + "proc-macro2", +] + +[[package]] +name = "serde" +version = "1.0.229" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4148590afebada386688f18773da617792bf2ef03ffc1e4cbd2b1d45b023e0ba" +dependencies = [ + "serde_core", + "serde_derive", +] + +[[package]] +name = "serde_core" +version = "1.0.229" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "67dca2c9c51e58a4791a4b1ed58308b39c64224d349a935ab5039aa360942a48" +dependencies = [ + "serde_derive", +] + +[[package]] +name = "serde_derive" +version = "1.0.229" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e7a5d71263a5a7d47b41f6b3f06ba276f10cc18b0931f1799f710578e2309348" +dependencies = [ + "proc-macro2", + "quote", + "syn 3.0.6", +] + +[[package]] +name = "syn" +version = "2.0.119" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "872831b642d1a07999a962a351ed35b955ea2cfc8f3862091e2a240a84f17297" +dependencies = [ + "proc-macro2", + "quote", + "unicode-ident", +] + +[[package]] +name = "syn" +version = "3.0.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "8593e8e72159ed2257d083c7a454a85cbf854f37a0966d8d483aff8c8a3ebcee" +dependencies = [ + "proc-macro2", + "quote", + "unicode-ident", +] + +[[package]] +name = "thiserror" +version = "2.0.21" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "09e52cb86a36cede5cb101bf8908837b3e4c6e5e59fe7fd85c23fb56200d189e" +dependencies = [ + "thiserror-impl", +] + +[[package]] +name = "thiserror-impl" +version = "2.0.21" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "fe5197923287db20a58125f0bc85c062f7f2c892de97b18c356f9efb14b28524" +dependencies = [ + "proc-macro2", + "quote", + "syn 3.0.6", +] + +[[package]] +name = "tracing" +version = "0.1.44" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "63e71662fa4b2a2c3a26f570f037eb95bb1f85397f3cd8076caed2f026a6d100" +dependencies = [ + "pin-project-lite", + "tracing-attributes", + "tracing-core", +] + +[[package]] +name = "tracing-attributes" +version = "0.1.31" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "7490cfa5ec963746568740651ac6781f701c9c5ea257c58e057f3ba8cf69e8da" +dependencies = [ + "proc-macro2", + "quote", + "syn 2.0.119", +] + +[[package]] +name = "tracing-core" +version = "0.1.36" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "db97caf9d906fbde555dd62fa95ddba9eecfd14cb388e4f491a66d74cd5fb79a" +dependencies = [ + "once_cell", +] + +[[package]] +name = "unicode-ident" +version = "1.0.26" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d245f478577f809a851594d02313b640fb437e0bb33866753cff937863096954" + +[[package]] +name = "whir-lean-differential" +version = "0.1.0" +dependencies = [ + "fiat_shamir", + "pcs", + "primitives", +] diff --git a/verification/whir/differential/Cargo.toml b/verification/whir/differential/Cargo.toml new file mode 100644 index 000000000..a47c25847 --- /dev/null +++ b/verification/whir/differential/Cargo.toml @@ -0,0 +1,13 @@ +[package] +name = "whir-lean-differential" +version = "0.1.0" +edition = "2024" +rust-version = "1.97" +publish = false + +[workspace] + +[dependencies] +pcs = { path = "../../../crates/pcs" } +primitives = { path = "../../../crates/primitives" } +fiat_shamir = { path = "../../../crates/fiat_shamir" } diff --git a/verification/whir/differential/run.py b/verification/whir/differential/run.py new file mode 100755 index 000000000..bbb4da37e --- /dev/null +++ b/verification/whir/differential/run.py @@ -0,0 +1,61 @@ +#!/usr/bin/env python3 +"""Run both implementations, compare live vectors, and require both opening smokes.""" + +import os +import subprocess +from pathlib import Path + +HERE = Path(__file__).resolve().parent +PACKAGE = HERE.parent +SCOPE = ["systemd-run", "--user", "--scope", "-q", "-p", "MemoryMax=16G", "-p", "MemorySwapMax=0"] +ENV = dict(os.environ, CARGO_TARGET_DIR="/tmp/whir-lean-target", CARGO_BUILD_JOBS="2", LEANVM_NUM_THREADS="1") + + +def run(command, cwd=PACKAGE): + result = subprocess.run(SCOPE + command, cwd=cwd, env=ENV, text=True, stdout=subprocess.PIPE, check=True) + return result.stdout + + +def records(text): + result = {} + for line in text.splitlines(): + key, sep, value = line.partition("=") + if not sep or key in result: + raise RuntimeError(f"Malformed or duplicate output: {line!r}") + result[key] = value + return result + + +def main(): + run(["lake", "build", "whirModel"]) + rust = records(run(["cargo", "+1.97", "run", "--release", "--locked", "--manifest-path", str(HERE / "Cargo.toml")])) + executable = str(PACKAGE / ".lake" / "build" / "bin" / "whirModel") + lean = records(run([executable])) + lean_smoke = lean.pop("lean_smoke") + rust_smoke = rust.pop("rust_smoke") + query_cases = [] + for key in list(rust): + if key.startswith("query_input_"): + _, _, depth, count = key.split("_") + values = rust.pop(key) + expected = rust.pop(f"query_output_{depth}_{count}") + limbs = values.split(",") if values else [] + actual = records(run([executable, "query", depth, count, *limbs])) + if actual != {"queries": expected}: + raise AssertionError(f"Query mismatch at depth={depth}, count={count}: {actual} != {expected}") + query_cases.append((int(depth), int(count))) + if lean.keys() != rust.keys(): + raise AssertionError(f"Different vector keys: Lean={lean.keys()}, Rust={rust.keys()}") + for key in lean: + if lean[key] != rust[key]: + raise AssertionError(f"Differential mismatch in {key}:\nLean {lean[key]}\nRust {rust[key]}") + if not lean_smoke.startswith("honest,") or not rust_smoke.startswith("honest,"): + raise AssertionError("Missing successful opening smokes") + print(f"PASS: {len(lean)} live arithmetic/encoding/folding/weight vectors; {len(query_cases)} production query batches {query_cases}") + print("Lean ideal replay: " + lean_smoke) + print("Rust production opening: " + rust_smoke) + print("Boundary: no Lean refinement of bit arithmetic to Field, hash/FS/PoW, or cryptographic soundness is claimed.") + + +if __name__ == "__main__": + main() diff --git a/verification/whir/differential/src/main.rs b/verification/whir/differential/src/main.rs new file mode 100644 index 000000000..1d7401dc2 --- /dev/null +++ b/verification/whir/differential/src/main.rs @@ -0,0 +1,234 @@ +use fiat_shamir::transcript::{Challenger, ProofTranscript, ProverState, Receiver, Transmitter, VerifierState}; +use pcs::ntt::AdditiveNttF64; +use pcs::ring_switch::{RingSwitch, SliceClaim}; +use pcs::stack_open::{self, StackClaim}; +use pcs::verifier::OpeningVerifier; +use pcs::whir; +use primitives::field::{F64, F192}; +use primitives::multilinear::{eq_table, inner_product, interp, mle_eval}; + +fn seed(i: usize) -> u64 { + let x = (i as u64 + 1).wrapping_mul(11400714819323198485); + (x ^ (x >> 29)).wrapping_mul(13787848793156543929) +} + +fn fixture(i: usize) -> F192 { + F192::new(seed(3 * i), seed(3 * i + 1), seed(3 * i + 2)) +} + +fn emit_n(key: &str, xs: impl IntoIterator) { + let values: Vec = xs.into_iter().map(|x| x.to_string()).collect(); + println!("{key}={}", values.join(",")); +} + +fn emit_e(key: &str, xs: impl IntoIterator) { + emit_n(key, xs.into_iter().flat_map(|x| [x.c0, x.c1, x.c2])); +} + +// Use the production NTT over each K limb, not another polynomial evaluator. +fn encode_ext(message: &[F192], lanes: usize, rate: usize) -> Vec { + let len = message.len() << rate; + let depth = (len / lanes).ilog2() as usize; + let ntt = AdditiveNttF64::standard(depth); + let mut limbs = vec![vec![F64::ZERO; len]; 3]; + for (i, x) in message.iter().enumerate() { + limbs[0][i] = F64(x.c0); + limbs[1][i] = F64(x.c1); + limbs[2][i] = F64(x.c2); + } + for limb in &mut limbs { + ntt.encode_interleaved_in_place(limb, lanes, rate); + } + (0..len) + .map(|i| F192::new(limbs[0][i].0, limbs[1][i].0, limbs[2][i].0)) + .collect() +} + +fn vectors() { + emit_n("kmul", (0..40).map(|i| (F64(seed(i)) * F64(seed(i + 41))).0)); + emit_n("kinv", (0..12).map(|i| F64(seed(i)).inv().0)); + emit_e("emul", (0..32).map(|i| fixture(i) * fixture(i + 33))); + emit_e("eq", eq_table(&(0..4).map(fixture).collect::>())); + emit_n("roots", whir::eval_sk_at_vks(8).into_iter().map(|x| x.0)); + for lanes in [1, 3, 4] { + let w: Vec = (0..lanes * 8).map(|i| F64(seed(i))).collect(); + let (_, pd) = whir::commit(&w, 5, 2, 1); + emit_e(&format!("base_{lanes}"), pd.codeword.into_iter().map(F192::from)); + } + let f: Vec = (0..32).map(fixture).collect(); + emit_e("ext", encode_ext(&f, 4, 1)); + let r = fixture(70); + emit_e( + "lane_fold", + (0..16).map(|i| { + let offset = (i / 8) * 16 + i % 8; + interp(f[offset], f[offset + 8], r) + }), + ); + emit_e("low_fold", f.chunks_exact(2).map(|p| interp(p[0], p[1], r))); + let mut point: Vec = (0..5).map(fixture).collect(); + point.rotate_left(2); + emit_e("rotation", point.iter().copied()); + emit_e("rotation_mle", [inner_product(&f, &eq_table(&point))]); + let qs = [0, 5, 5, 13]; + let mut ws = vec![F192::ONE]; + for i in 1..qs.len() { + ws.push(ws[i - 1] * fixture(80)); + } + // Columns are extracted by running unit coefficient vectors through the actual NTT. + let mut basis = vec![F192::ZERO; 8]; + for j in 0..8 { + let mut unit = vec![F192::ZERO; 8]; + unit[j] = F192::ONE; + let col = encode_ext(&unit, 1, 1); + basis[j] = qs + .iter() + .zip(&ws) + .map(|(&q, &w)| col[q] * w) + .fold(F192::ZERO, |a, x| a + x); + } + emit_e("induced", basis.iter().copied()); + emit_e( + "induced_at", + [inner_product( + &basis, + &eq_table(&(0..3).map(fixture).collect::>()), + )], + ); + for rate in 1..=4 { + for n in 15..=28 { + let c = whir::config_for_rate(n, rate).unwrap(); + let values = std::iter::once(c.initial_k()) + .chain(c.level_ks().iter().copied()) + .chain(c.log_inv_rates().iter().copied()) + .chain(c.queries().iter().copied()) + .chain(c.ood_samples().iter().copied()); + emit_n(&format!("config_{n}_{rate}"), values.map(|x| x as u64)); + } + } + for (n, rate) in [(14, 1), (29, 1), (15, 0), (15, 5)] { + assert!(whir::config_for_rate(n, rate).is_err()); + } +} + +fn queries() { + let empty = ProofTranscript { + stream: vec![], + merkle: vec![], + }; + // Includes cross-limb chunks, several squeezes, duplicate positions, count zero, + // and strata wider than the domain. The sampler itself is production code. + for (depth, count) in [(1usize, 9usize), (5, 47), (7, 29), (17, 31), (63, 8), (8, 0)] { + let label = format!("whir-lean-query-{depth}-{count}"); + let mut source = VerifierState::from_label(label.as_bytes(), &empty); + let squeezes: Vec<_> = (0..count.div_ceil(192 / depth)) + .map(|_| Challenger::sample(&mut source)) + .collect(); + let mut verifier = VerifierState::from_label(label.as_bytes(), &empty); + let qs = verifier.sample_queries(depth, count); + emit_e(&format!("query_input_{depth}_{count}"), squeezes); + emit_n( + &format!("query_output_{depth}_{count}"), + qs.into_iter().map(|q| q as u64), + ); + } +} + +fn production_smoke() { + let log_n = whir::MIN_LOG_N; + let config = whir::config_for_rate(log_n, 1).unwrap(); + let vars = log_n - config.initial_k(); + let stack: Vec<_> = (0..1 << vars).map(|i| F64(seed(i))).collect(); + let point: Vec<_> = (0..vars).map(fixture).collect(); + let eq = eq_table(&point); + let slices = (0..64) + .map(|bit| { + stack + .iter() + .zip(&eq) + .filter(|(x, _)| x.0 >> bit & 1 == 1) + .fold(F192::ZERO, |acc, (_, &e)| acc + e) + }) + .collect(); + let rings = vec![RingSwitch { + offset: 0, + qflock_vars: vars, + claims: vec![SliceClaim { + suffix_point: point.clone(), + s_hat_v: slices, + }], + }]; + let claims = vec![StackClaim::Point { + offset: 0, + low_point: point.clone(), + value: mle_eval(&stack, &point), + }]; + let (commitment, pd) = whir::commit(&stack, log_n, config.initial_k(), 1); + let label = b"whir-lean-production-smoke-fixed-statement-v1"; + let mut prover = ProverState::from_label(label); + prover.add_root(&commitment.root); + // Statement values ride the stream exactly once before the opening. + for ring in &rings { + prover.add_scalars(&ring.claims[0].s_hat_v); + } + prover.add_scalar(claims[0].value()); + stack_open::open(&mut prover, log_n, &stack, &pd, &config, &claims, &rings); + let proof = prover.into_proof(); + let accepts = |proof: &ProofTranscript, lanes: usize| -> bool { + let mut verifier = VerifierState::from_label(label, proof); + let Ok(root) = Receiver::next_root(&mut verifier) else { + return false; + }; + if root != commitment.root { + return false; + } + for &expected in &rings[0].claims[0].s_hat_v { + if Receiver::next_scalar(&mut verifier).ok() != Some(expected) { + return false; + } + } + if Receiver::next_scalar(&mut verifier).ok() != Some(claims[0].value()) { + return false; + } + stack_open::verify(&mut verifier, &config, log_n, lanes, root, &claims, &rings).is_ok() + && verifier.finish().is_ok() + }; + assert!(accepts(&proof, 1), "production honest opening rejected"); + let opening_start = 2 + rings[0].claims[0].s_hat_v.len() + claims.len(); + let first_ood = opening_start + 2 + 2 * config.initial_k() + 2; + let mut residual_start = first_ood + 3 * config.ood_samples()[1] + 1 + 2; + for (i, &k) in config.level_ks().iter().enumerate() { + residual_start += 2 * k; + if i + 1 < config.level_steps() { + residual_start += 2 + 3 * config.ood_samples()[i + 2] + 1 + 2; + } + } + let mut bad = proof.clone(); + bad.stream[first_ood] += F192::ONE; + assert!(!accepts(&bad, 1), "production bad OOD value accepted"); + let mut bad = proof.clone(); + bad.stream[residual_start] += F192::ONE; + assert!(!accepts(&bad, 1), "production bad final polynomial accepted"); + let mut bad = proof.clone(); + bad.stream.pop(); + assert!(!accepts(&bad, 1), "production truncated stream accepted"); + let mut bad = proof.clone(); + bad.stream.push(F192::ONE); + assert!(!accepts(&bad, 1), "production trailing stream accepted"); + let mut bad = proof.clone(); + bad.stream[opening_start] += F192::ONE; + assert!(!accepts(&bad, 1), "production bad opening round accepted"); + let mut bad = proof.clone(); + bad.merkle.pop(); + assert!(!accepts(&bad, 1), "production missing authentication accepted"); + assert!(!accepts(&proof, 0), "production zero lanes accepted"); + println!( + "rust_smoke=honest,ring_switch,point_claim,truncated_lanes,short_stream,trailing_stream,bad_round,bad_ood,bad_final,missing_authentication,bad_layout" + ); +} + +fn main() { + vectors(); + queries(); + production_smoke(); +} diff --git a/verification/whir/lake-manifest.json b/verification/whir/lake-manifest.json new file mode 100644 index 000000000..9953533a1 --- /dev/null +++ b/verification/whir/lake-manifest.json @@ -0,0 +1,96 @@ +{"version": "1.2.0", + "packagesDir": ".lake/packages", + "packages": + [{"url": "https://github.com/leanprover-community/mathlib4.git", + "type": "git", + "subDir": null, + "scope": "", + "rev": "5ed2965256430c3649e86755f9576b54eca72435", + "name": "mathlib", + "manifestFile": "lake-manifest.json", + "inputRev": "5ed2965256430c3649e86755f9576b54eca72435", + "inherited": false, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/leanprover-community/plausible", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "118aa17ee84656b8bd727fef7c458ee8c833385c", + "name": "plausible", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/LeanSearchClient", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "ddf04cf3949fa556442341e87d47f9f6e6074707", + "name": "LeanSearchClient", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/import-graph", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "e928b72544873815af278d38681b31c0293588e3", + "name": "importGraph", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/ProofWidgets4", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "106ff4fafc74ef4ac99d81dbf3ab399118f497a5", + "name": "proofwidgets", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/leanprover-community/aesop", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "355695d523e41d0554926416cba2a2b3544fbbc9", + "name": "aesop", + "manifestFile": "lake-manifest.json", + "inputRev": "master", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/quote4", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "6a489d9af5d0c47e5b259e2e8bcdfc1811b5a259", + "name": "Qq", + "manifestFile": "lake-manifest.json", + "inputRev": "master", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/batteries", + "type": "git", + "subDir": null, + "scope": "leanprover-community", + "rev": "f2effa3d803fda822b1f97b806c47cf2adfbcbc2", + "name": "batteries", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover/lean4-cli", + "type": "git", + "subDir": null, + "scope": "leanprover", + "rev": "e92c9f15fdfacc8536f31cfb3b7ad26c3c8cd204", + "name": "Cli", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.34.0", + "inherited": true, + "configFile": "lakefile.toml"}], + "name": "whirVerification", + "lakeDir": ".lake", + "fixedToolchain": false} diff --git a/verification/whir/lakefile.toml b/verification/whir/lakefile.toml new file mode 100644 index 000000000..fd4e585f5 --- /dev/null +++ b/verification/whir/lakefile.toml @@ -0,0 +1,15 @@ +name = "whirVerification" +version = "0.1.0" +defaultTargets = ["Whir", "whirModel"] + +[[require]] +name = "mathlib" +git = "https://github.com/leanprover-community/mathlib4.git" +rev = "5ed2965256430c3649e86755f9576b54eca72435" + +[[lean_lib]] +name = "Whir" + +[[lean_exe]] +name = "whirModel" +root = "Main" diff --git a/verification/whir/lean-toolchain b/verification/whir/lean-toolchain new file mode 100644 index 000000000..12359f928 --- /dev/null +++ b/verification/whir/lean-toolchain @@ -0,0 +1 @@ +leanprover/lean4:v4.34.0 From 69f5499304a6957f6780c8998999d783bae13302 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Thu, 8 Oct 2026 01:29:09 +0100 Subject: [PATCH 02/28] Prove refinement of executable WHIR array transitions --- verification/whir/README.md | 15 ++ verification/whir/Whir.lean | 3 + verification/whir/Whir/ArrayAlgebra.lean | 184 +++++++++++++++ verification/whir/Whir/ArrayLayout.lean | 229 +++++++++++++++++++ verification/whir/Whir/Concrete.lean | 24 +- verification/whir/Whir/Protocol.lean | 84 ++++--- verification/whir/Whir/ReplayRefinement.lean | 146 ++++++++++++ 7 files changed, 642 insertions(+), 43 deletions(-) create mode 100644 verification/whir/Whir/ArrayAlgebra.lean create mode 100644 verification/whir/Whir/ArrayLayout.lean create mode 100644 verification/whir/Whir/ReplayRefinement.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index e4bfb0981..ceac9719a 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -38,6 +38,19 @@ Paths below are relative to `crates/pcs/src`, except the Python mirror, `python- `Completeness.Schedule` is an ideal algebraic schedule with supplied challenges and honest mathematical column answers. Its `all_levels_complete` theorem proves preservation through arbitrary fold blocks, residual/OOD/query batching and closing sumcheck. It is not a theorem about `Protocol.verify`'s arrays or serialization. The executable model and the mathematical specification are deliberately separate where a refinement bridge is missing. +## Refinement of the actual executable kernels + +The operational kernels are now polymorphic over their minimal operations, and the concrete prover/verifier still call those same definitions specialized to `Concrete.E`. This is not a parallel mathematical reimplementation. Only `Zero E` and `One E` were added; no ring or field laws were asserted for E. + +- `ArrayAlgebra.dot_eq_sum` and `roundMessage_eq_sum` prove that the actual array reductions and mutable message loop compute bounded finite sums, including their original min-length and default-index semantics. +- `message_eval`, `roundMessage_cube`, `foldLane_cube` and `honest_round_cube` connect those actual executable definitions to `compactRound`, `roundConstant`, `roundQuadratic`, `foldFirst` and the existing generic `honest_round`, with an explicit equivalence for the remaining Boolean coordinates. +- `honest_foldLane` and `honest_foldLow` prove actual round evaluation equals the dot product of the actual folded arrays, for every aligned shape and equal witness/weight lengths over any characteristic-two commutative ring. `dot_weightGlue` and `roundMessage_weightGlue` prove the actual batched target and intro message match the actual batched weight. +- `ArrayLayout` proves actual array rotation versus `Layout.terminalPoint`, actual `getD` padding and base-encoder leaf reversal versus the list specification, and exact low/top fold indices and lengths. Oversized `rotatePoint` inputs clamp because `Array.extract` clamps; list rotation wraps. The universal bridge uses `min k size`, while the direct protocol bridge states `k ≤ size`. Padding similarly records that a valid live prefix fits the padded width. +- `Protocol.verify` now calls `VerifierState.fold`, `batch` and `checkTerminal` for every algebraic transition. `ReplayRefinement.fold_preserves` and `batch_preserves` prove these exact functions maintain the interpreted array state. `trace_preserves` composes arbitrary numbers of those actual transitions, including block/level changes; `trace_terminal` proves that an honest trace ending in one witness scalar passes the actual Boolean terminal checker. The power-of-two specialization discharges the pairing-shape condition for the protocol's layouts. + +The remaining whole-executor bridge is precise. `HonestTrace` generates the honest message/value of each transition from the executable array kernels, but membership of the honest execution of the complete nested `Protocol.prove`/`verify` loops in that relation is not yet proved. Query batches additionally need an executable theorem equating `Protocol.enforced` with the corresponding `dot` against `Concrete.induced` after folding the authenticated oracle. At the final check, `Concrete.mle proof.residual tail` must be connected to the scalar obtained by repeated `foldLow`; this needs the `eqTable` loop's first-coordinate interleaving identity, not merely the existing mathematical MLE theorem. Finally, the generic arithmetic theorems cannot be specialized to E until its exact XOR/reduced-multiplication operations have a proved ring interpretation. These are missing refinement dependencies, not assumed correctness axioms or a claim that `Protocol.verify (Protocol.prove ...)` is already proved. + + ## Intentional differences from original WHIR The implementation commits in K = GF(2^64), challenges in E = GF(2^192), and uses additive domains and the novel polynomial basis. The original multiplicative WHIR folding formulas cannot be copied into characteristic two. Quadratic messages contain only the constant and quadratic coefficient; the linear coefficient is reconstructed as `claim + quadratic`. @@ -91,6 +104,8 @@ The delivered branch passed `lake build --wfail` and the elaborated axiom census The live differential runner matched 71 record groups: 15 arithmetic/encoding/folding/weight groups plus all 56 production configurations. Six additional production query batches covered `(depth,count)` = `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`, including cross-limb extraction, uneven groups and repeated queries. Lean's three-level opening accepted and rejected wrong targets, short openings/final residuals, changed final residuals, missing queries, changed rows, changed/missing OOD answers, missing challenges and invalid layouts. Rust's real minimum-size stacked opening exercised ring-switch and point claims, truncated lanes, Merkle authentication, Fiat-Shamir and grinding; it rejected short/trailing streams, changed round/OOD/final scalars, missing authentication and invalid layouts. +A separate executed refinement smoke over `ZMod 2 × ZMod 2` used non-Boolean ring challenges through two actual top-lane folds, an actual level batch and an actual low fold. It observed the preserved dot/message invariants, a nonzero final scalar `(1, 0)`, acceptance by the actual terminal checker, and rejection after changing its claim. This exercises the shared polymorphic definitions rather than substituting a copied specification. + The standalone Rust harness also passed release Clippy with warnings denied and rustdoc with warnings denied. Its Rust code was formatted; the Python runner passed Ruff and `ty`. No production Rust or Python verifier was changed, so full VM suites, Python verifier conformance suites, guest fixture rebuilds and LaTeX builds were intentionally not run. No Rust discrepancy was found in this explored scope. That statement is not a proof that untested inputs or the Rust protocol are correct, and no speculative bug-fix PR is warranted. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index 7b2dd1d4a..82ddeb1c9 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -6,3 +6,6 @@ import Whir.QuerySoundness import Whir.Completeness import Whir.Concrete import Whir.Protocol +import Whir.ArrayLayout +import Whir.ArrayAlgebra +import Whir.ReplayRefinement diff --git a/verification/whir/Whir/ArrayAlgebra.lean b/verification/whir/Whir/ArrayAlgebra.lean new file mode 100644 index 000000000..341b53689 --- /dev/null +++ b/verification/whir/Whir/ArrayAlgebra.lean @@ -0,0 +1,184 @@ +import Whir.Algebra +import Whir.Protocol +import Whir.ArrayLayout + +/-! Refinement of the executable array arithmetic. Ring laws are hypotheses on +an arbitrary carrier, not axioms or instances for the concrete machine field. +The sum formulas retain truncation and default-valued indexing on malformed inputs. -/ +namespace Whir.ArrayAlgebra +open Concrete Protocol +open scoped BigOperators + +variable {R : Type*} [CommRing R] [Inhabited R] + +omit [Inhabited R] in +theorem message_eval (m : Message R) (claim r : R) : + m.eval claim r = compactRound claim m.u0 m.u2 r := by + unfold Message.eval compactRound + ring + +theorem dot_eq_sum (f b : Array R) : + dot f b = ∑ i ∈ Finset.range (min f.size b.size), f[i]! * b[i]! := by + unfold dot + rw [← Array.foldl_toList] + simp only [tab, Array.toList_map] + rw [← List.sum_eq_foldl, ← List.sum_toFinset _ List.nodup_range] + congr 1 + ext i + simp + +omit [Inhabited R] in +private theorem message_loop (xs : List Nat) (a c : Nat → R) (m : Message R) : + xs.foldl (fun m i => Message.mk (m.u0 + a i) (m.u2 + c i)) m = + ⟨m.u0 + (xs.map a).sum, m.u2 + (xs.map c).sum⟩ := by + induction xs generalizing m with + | nil => cases m; simp + | cons i xs ih => simp only [List.foldl_cons, ih, List.map_cons, List.sum_cons, add_assoc] + +theorem roundMessage_eq_sum (f b : Array R) (block : Nat) : + roundMessage f b block = + ⟨∑ i ∈ Finset.range (f.size / 2), + f[(i/block)*(2*block)+i%block]! * b[(i/block)*(2*block)+i%block]!, + ∑ i ∈ Finset.range (f.size / 2), + (f[(i/block)*(2*block)+i%block]! + f[(i/block)*(2*block)+i%block+block]!) * + (b[(i/block)*(2*block)+i%block]! + b[(i/block)*(2*block)+i%block+block]!)⟩ := by + unfold roundMessage + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size] + simp only [Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + change (List.range (f.size / 2)).foldl _ _ = _ + rw [message_loop] + simp only [zero_add] + congr 1 + +@[simp] theorem size_weightGlue (b other : Array R) (s : R) : + (weightGlue b other s).size = b.size := by simp [weightGlue] + +theorem dot_weightGlue (f b other : Array R) (s : R) + (hb : b.size = f.size) (ho : other.size = f.size) : + dot f (weightGlue b other s) = dot f b + s * dot f other := by + simp only [dot_eq_sum, size_weightGlue, hb, ho, min_self] + rw [Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + rw [weightGlue, ArrayLayout.getElem!_tab _ _ _ (by simpa [hb] using Finset.mem_range.mp hi)] + ring + +omit [Inhabited R] in +private theorem honest_pair [CharP R 2] (a a' b b' r : R) : + a*b + r * (a*b + a'*b' + (a+a')*(b+b')) + + (r*r)*((a+a')*(b+b')) = + foldPair a a' r * foldPair b b' r := by + have h : a*b + a'*b' + (a+a')*(b+b') = a*b' + a'*b := by + linear_combination b * CharTwo.add_self_eq_zero a + + b' * CharTwo.add_self_eq_zero a' + rw [h] + unfold foldPair + ring_nf + simp [CharTwo.two_eq_zero] + +/-- Full honest top-lane round. Alignment implies even length; equal lengths +ensure both folded arrays and every source pair have the same valid domain. -/ +theorem honest_foldLane [CharP R 2] (f b : Array R) (block lanes : Nat) + (hf : f.size = (lanes * 2) * block) (hb : b.size = f.size) (r : R) : + (roundMessage f b block).eval (dot f b) r = + dot (foldLane f block r) (foldLane b block r) := by + have half : f.size / 2 = lanes * block := by + rw [hf, show lanes * 2 * block = lanes * block * 2 by ring, Nat.mul_div_left _ (by decide : 0 < 2)] + have pairs : + (∑ j ∈ Finset.range ((lanes * 2) * block), f[j]! * b[j]!) = + ∑ i ∈ Finset.range (lanes * block), + (f[(i/block)*(2*block)+i%block]! * b[(i/block)*(2*block)+i%block]! + + f[(i/block)*(2*block)+i%block+block]! * b[(i/block)*(2*block)+i%block+block]!) := by + simpa only [Finset.sum_range] using + ArrayLayout.sum_foldLane_pairs lanes block (fun j => f[j]! * b[j]!) + rw [roundMessage_eq_sum, dot_eq_sum, hb, min_self, hf, pairs] + simp only [Message.eval, ← hf, half] + rw [dot_eq_sum] + simp only [ArrayLayout.size_foldLane, hb, min_self, half] + simp only [Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + have hi' : i < f.size / 2 := by simpa [half] using Finset.mem_range.mp hi + rw [foldLane, foldLane, ArrayLayout.getElem!_tab _ _ _ hi', + ArrayLayout.getElem!_tab _ _ _ (by simpa [hb] using hi')] + exact honest_pair _ _ _ _ _ + +theorem honest_foldLow [CharP R 2] (f b : Array R) (pairs : Nat) + (hf : f.size = pairs * 2) (hb : b.size = f.size) (r : R) : + (roundMessage f b).eval (dot f b) r = dot (foldLow f r) (foldLow b r) := by + simpa [ArrayLayout.foldLane_one] using + honest_foldLane f b 1 pairs (by simpa using hf) hb r + +/-- Batching the actual transmitted coefficients agrees with batching their +weight arrays. Alignment rules out any access to a truncated/default tail. -/ +theorem roundMessage_weightGlue (f b other : Array R) (s : R) (block lanes : Nat) + (hf : f.size = (lanes * 2) * block) (hb : b.size = f.size) : + roundMessage f (weightGlue b other s) block = + (roundMessage f b block).glue (roundMessage f other block) s := by + have half : f.size / 2 = lanes * block := by + rw [hf, show lanes * 2 * block = lanes * block * 2 by ring, + Nat.mul_div_left _ (by decide : 0 < 2)] + have bounds (i : Nat) (hi : i ∈ Finset.range (f.size / 2)) : + (i/block)*(2*block)+i%block < b.size ∧ + (i/block)*(2*block)+i%block+block < b.size := by + have hi' : i < lanes * block := by simpa [half] using Finset.mem_range.mp hi + have hp : 0 < block := by + by_contra h + have : block = 0 := by omega + simp [this] at hi' + simpa [hb, hf, Nat.mul_comm lanes 2] using ArrayLayout.foldLane_indices hp hi' + simp only [roundMessage_eq_sum, Message.glue] + congr 1 <;> { + rw [Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + have h := bounds i hi + simp only [weightGlue, ArrayLayout.getElem!_tab _ _ _ h.1, + ArrayLayout.getElem!_tab _ _ _ h.2] + ring } + +/-- Interpret an executable pairing as a Boolean first coordinate. The remaining +coordinates are supplied explicitly, so this view covers both low and top lanes. -/ +def pairTable {n : Nat} (a : Array R) (block : Nat) (index : Cube n → Nat) : + Cube (n + 1) → R := fun u => + let i := index (fun j => u j.succ) + a[(i/block)*(2*block)+i%block + if u 0 then block else 0]! + +theorem roundMessage_cube {n : Nat} (f b : Array R) (block : Nat) + (index : Cube n ≃ Fin (f.size / 2)) : + roundMessage f b block = + ⟨roundConstant (pairTable b block (fun u => (index u).val)) + (pairTable f block (fun u => (index u).val)), + roundQuadratic (pairTable b block (fun u => (index u).val)) + (pairTable f block (fun u => (index u).val))⟩ := by + rw [roundMessage_eq_sum] + simp only [Finset.sum_range, roundConstant, roundQuadratic, pairTable, + Fin.cons_zero, Fin.cons_succ, Bool.false_eq_true, ↓reduceIte, Nat.add_zero] + congr 1 <;> rw [← Equiv.sum_comp index] <;> + apply Finset.sum_congr rfl <;> intro u _ <;> ring + +theorem foldLane_cube [CharP R 2] {n : Nat} (a : Array R) (block : Nat) + (index : Cube n ≃ Fin (a.size / 2)) (r : R) : + (fun u => (foldLane a block r)[(index u).val]!) = + foldFirst (pairTable a block (fun u => (index u).val)) r := by + funext u + rw [foldFirst_charTwo] + simp only [foldLane, ArrayLayout.getElem!_tab _ _ _ (index u).isLt, + pairTable, Fin.cons_zero, Fin.cons_succ, Bool.false_eq_true, ↓reduceIte, + Nat.add_zero, foldPair] + +/-- The actual message evaluator specializes the pre-existing checked honest +round theorem once its pair layout is interpreted on a Boolean cube. -/ +theorem honest_round_cube [CharP R 2] {n : Nat} (f b : Array R) (block : Nat) + (index : Cube n ≃ Fin (f.size / 2)) (r : R) : + (roundMessage f b block).eval + (innerProduct (pairTable b block (fun u => (index u).val)) + (pairTable f block (fun u => (index u).val))) r = + innerProduct + (foldFirst (pairTable b block (fun u => (index u).val)) r) + (foldFirst (pairTable f block (fun u => (index u).val)) r) := by + rw [message_eval, roundMessage_cube f b block index] + exact honest_round _ _ _ + +end Whir.ArrayAlgebra diff --git a/verification/whir/Whir/ArrayLayout.lean b/verification/whir/Whir/ArrayLayout.lean new file mode 100644 index 000000000..51bed0555 --- /dev/null +++ b/verification/whir/Whir/ArrayLayout.lean @@ -0,0 +1,229 @@ +import Whir.Concrete +import Whir.Layout + +/-! Array/index refinement of the executable kernels. These results use no field +laws. Rotation is clamped by `Array.extract`, unlike unbounded list rotation; +the direct terminal-point bridge therefore records the protocol's length bound. -/ +namespace Whir.ArrayLayout +open Concrete + +variable {α : Type*} + +@[simp] theorem size_tab (n : Nat) (f : Nat → α) : (tab n f).size = n := by + simp [tab] + +@[simp] theorem toList_tab (n : Nat) (f : Nat → α) : + (tab n f).toList = (List.range n).map f := by + simp [tab] + +@[simp] theorem getElem_tab (n : Nat) (f : Nat → α) (i : Nat) (h : i < n) : + (tab n f)[i]'(by simpa using h) = f i := by + simp [tab] + +@[simp] theorem getElem!_tab [Inhabited α] (n : Nat) (f : Nat → α) + (i : Nat) (h : i < n) : (tab n f)[i]! = f i := by + simp [getElem!_pos, h] + + theorem rotatePoint_slices (k : Nat) (point : Array α) : + (rotatePoint k point).toList = point.toList.drop k ++ point.toList.take k := by + simp [rotatePoint, List.extract] + + theorem rotatePoint_terminalPoint (k : Nat) (point : Array α) (h : k ≤ point.size) : + (rotatePoint k point).toList = Layout.terminalPoint k point.toList := by + rw [rotatePoint_slices, Layout.terminalPoint_slices k point.toList (by simpa using h)] + + theorem rotatePoint_terminalPoint_clamped (k : Nat) (point : Array α) : + (rotatePoint k point).toList = Layout.terminalPoint (min k point.size) point.toList := by + rw [rotatePoint_slices, Layout.terminalPoint_slices _ _ (by simp)] + by_cases h : k ≤ point.size + · simp [Nat.min_eq_left h] + · have hs : point.size ≤ k := by omega + have hs' : point.toList.length ≤ k := by simpa only [Array.length_toList] using hs + simp only [Nat.min_eq_right hs, List.drop_eq_nil_of_le hs', + List.take_of_length_le hs', List.nil_append] + simp [← Array.length_toList] + +@[simp] theorem size_rotatePoint (k : Nat) (point : Array α) : + (rotatePoint k point).size = point.size := by + simpa using congrArg List.length (rotatePoint_terminalPoint_clamped k point) |>.trans + (Layout.terminalPoint_length _ _) + + theorem rotatePoint_permutation (k : Nat) (point : Array α) : + (rotatePoint k point).toList.Perm point.toList := by + rw [rotatePoint_terminalPoint_clamped] + exact Layout.terminalPoint_permutation _ _ + + theorem rotatePoint_inverse (k : Nat) (point : Array α) (h : k ≤ point.size) : + rotatePoint (point.size - k) (rotatePoint k point) = point := by + apply Array.toList_inj.mp + rw [rotatePoint_terminalPoint _ _ (by simp), rotatePoint_terminalPoint k point h] + exact Layout.terminalPoint_inverse k point.toList (by simpa using h) + + theorem padding_toList (zero : α) (width : Nat) (live : Array α) + (h : live.size ≤ width) : + (tab width fun i => live[i]?.getD zero).toList = Layout.padTail zero width live.toList := by + apply List.ext_getElem + · simp [Layout.padTail]; omega + · intro i h₁ h₂ + simp only [toList_tab, List.getElem_map, List.getElem_range] + by_cases hi : i < live.size + · simp [Layout.padTail, List.getElem_append_left, hi, getElem?_pos] + · have hs : live.size ≤ i := by omega + simp [Layout.padTail, List.getElem_append_right, hi, hs, getElem?_neg] + + theorem reversed_tab_toList (n : Nat) (f : Nat → α) : + (tab n fun i => f (n - 1 - i)).toList = Layout.prunedLeaf (tab n f).toList := by + apply List.ext_getElem + · simp [Layout.prunedLeaf] + · intro i h₁ h₂ + simp [Layout.prunedLeaf, List.getElem_reverse, Nat.sub_sub] + + theorem restore_reversed_tab (zero : α) (width n : Nat) (f : Nat → α) : + Layout.restoreLeaf zero width (tab n fun i => f (n - 1 - i)).toList = + (Layout.padTail zero width (tab n f).toList).reverse := by + rw [reversed_tab_toList, Layout.restoreLeaf_eq_full] + +@[simp] theorem size_foldLow [Add α] [Mul α] [Inhabited α] (a : Array α) (r : α) : + (foldLow a r).size = a.size / 2 := by simp [foldLow] + +@[simp] theorem size_foldLane [Add α] [Mul α] [Inhabited α] + (a : Array α) (block : Nat) (r : α) : + (foldLane a block r).size = a.size / 2 := by simp [foldLane] + + theorem foldLow_indices {size i : Nat} (h : i < size / 2) : + 2 * i < size ∧ 2 * i + 1 < size := by omega + + theorem getElem_foldLow [Add α] [Mul α] [Inhabited α] + (a : Array α) (r : α) (i : Nat) (h : i < a.size / 2) : + (foldLow a r)[i]'(by simpa using h) = + foldPair (a[2*i]'((foldLow_indices h).1)) (a[2*i+1]'((foldLow_indices h).2)) r := by + simp [foldLow, tab, getElem!_pos, (foldLow_indices h).1, (foldLow_indices h).2] + +/-- A top-lane step preserves the row and selects adjacent high-coordinate lanes. -/ + theorem foldLane_offset {block lane row : Nat} (hr : row < block) : + ((lane * block + row) / block) * (2 * block) + + (lane * block + row) % block = Layout.stackIndex block (2 * lane) row := by + obtain ⟨hq, hm⟩ := Layout.stackIndex_partition (lane := lane) hr + simp only [Layout.stackIndex] at hq hm ⊢ + rw [hq, hm] + ring + + theorem foldLane_indices {block lanes i : Nat} (hb : 0 < block) + (hi : i < lanes * block) : + (i / block) * (2 * block) + i % block < (2 * lanes) * block ∧ + (i / block) * (2 * block) + i % block + block < (2 * lanes) * block := by + have hq : i / block < lanes := (Nat.div_lt_iff_lt_mul hb).2 (by simpa [Nat.mul_comm] using hi) + have hm : i % block < block := Nat.mod_lt _ hb + constructor <;> nlinarith + + theorem getElem_foldLane [Add α] [Mul α] [Inhabited α] + (a : Array α) (r : α) (block lanes lane row : Nat) + (ha : a.size = (2 * lanes) * block) (hl : lane < lanes) (hr : row < block) : + (foldLane a block r)[lane * block + row]'(by + simp only [size_foldLane, ha, Nat.mul_assoc, Nat.mul_div_right _ (by decide : 0 < 2)] + exact Layout.stackIndex_bound hl hr) = + foldPair a[Layout.stackIndex block (2 * lane) row]! + a[Layout.stackIndex block (2 * lane + 1) row]! r := by + simp only [foldLane, tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + rw [foldLane_offset hr] + have he : Layout.stackIndex block (2 * lane) row + block = + Layout.stackIndex block (2 * lane + 1) row := by + simp only [Layout.stackIndex] + ring + rw [he] + +/-- Both source accesses are in bounds; no panic/default value participates. -/ + theorem foldLane_stack_bounds {block lanes lane row : Nat} + (hl : lane < lanes) (hr : row < block) : + Layout.stackIndex block (2 * lane) row < (2 * lanes) * block ∧ + Layout.stackIndex block (2 * lane + 1) row < (2 * lanes) * block := by + constructor <;> apply Layout.stackIndex_bound (by omega) hr + +/-- The exact padding expression in `Protocol.prove`, including base embedding. -/ + theorem padding_map_toList {β : Type*} (zero : α) (embed : α → β) + (width : Nat) (live : Array α) (h : live.size ≤ width) : + (tab width fun i => embed (live[i]?.getD zero)).toList = + Layout.padTail (embed zero) width (live.toList.map embed) := by + have hm : (tab width fun i => embed (live[i]?.getD zero)).toList = + ((tab width fun i => live[i]?.getD zero).toList.map embed) := by + simp [List.map_map] + rw [hm, padding_toList zero width live h] + simp [Layout.padTail] + +/-- Prefix restoration is the physical full leaf, not witness-order padding. -/ + theorem restore_array_toList (zero : α) (width : Nat) (stored : Array α) : + ((tab (width - stored.size) fun _ => zero) ++ stored).toList = + Layout.restoreLeaf zero width stored.toList := by + simp [Layout.restoreLeaf, List.map_const', List.length_range] + + theorem encodeBase_size (message : Array K) (logN initialK rate : Nat) : + (encodeBase message logN initialK rate).size = 2 ^ (logN - initialK + rate) := by + simp [encodeBase] + +/-- The actual encoder drops no occupied lane and reverses only the live lanes. -/ + theorem encodeBase_leaf (message : Array K) (logN initialK rate q : Nat) + (hq : q < 2 ^ (logN - initialK + rate)) : + ((encodeBase message logN initialK rate)[q]!).toList = + Layout.prunedLeaf + (tab (message.size / 2 ^ (logN - initialK)) fun lane => + (encode (logN - initialK) rate + (tab (2 ^ (logN - initialK)) fun j => + E.ofK message[lane * 2 ^ (logN - initialK) + j]!))[q]!).toList := by + simp only [encodeBase, getElem!_tab _ _ _ hq] + rw [← reversed_tab_toList] + congr 1 + apply Array.ext + · simp + · intro t ht ht' + simp only [size_tab] at ht ht' + have hr : message.size / 2 ^ (logN - initialK) - 1 - t < + message.size / 2 ^ (logN - initialK) := by omega + simp [tab, getElem!_pos, hr] + + theorem encodeBase_leaf_size (message : Array K) (logN initialK rate q : Nat) + (hq : q < 2 ^ (logN - initialK + rate)) : + ((encodeBase message logN initialK rate)[q]!).size = + message.size / 2 ^ (logN - initialK) := by + simpa [Layout.prunedLeaf] using congrArg List.length + (encodeBase_leaf message logN initialK rate q hq) + +/-- Every word read while constructing a live lane is inside the message, +even when its length is not a multiple of the block width. -/ + theorem encodeBase_word_bound {size block lane row : Nat} + (hl : lane < size / block) (hr : row < block) : + lane * block + row < size := by + have hb : 0 < block := by omega + have h : (lane + 1) * block ≤ size := + (Nat.le_div_iff_mul_le hb).1 (by omega) + nlinarith + +/-- The top-lane pairing is a permutation of all input coordinates, including +the empty case. Its second coordinate is the folded lane bit, not a row bit. -/ +def foldLaneEquiv (lanes block : Nat) : + (Fin (lanes * block) × Fin 2) ≃ Fin ((lanes * 2) * block) := + (Equiv.prodCongr finProdFinEquiv.symm (Equiv.refl (Fin 2))).trans + ((Equiv.prodAssoc (Fin lanes) (Fin block) (Fin 2)).trans + ((Equiv.prodCongr (Equiv.refl (Fin lanes)) (Equiv.prodComm (Fin block) (Fin 2))).trans + ((Equiv.prodAssoc (Fin lanes) (Fin 2) (Fin block)).symm.trans + ((Equiv.prodCongr finProdFinEquiv (Equiv.refl (Fin block))).trans finProdFinEquiv)))) + + theorem foldLaneEquiv_val (lanes block : Nat) (i : Fin (lanes * block)) (b : Fin 2) : + (foldLaneEquiv lanes block (i, b)).val = + (i.val / block) * (2 * block) + i.val % block + b.val * block := by + simp [foldLaneEquiv, finProdFinEquiv] + ring + + theorem sum_foldLane_pairs {β : Type*} [AddCommMonoid β] + (lanes block : Nat) (g : Nat → β) : + (∑ j : Fin ((lanes * 2) * block), g j.val) = + ∑ i : Fin (lanes * block), + (g ((i.val / block) * (2 * block) + i.val % block) + + g ((i.val / block) * (2 * block) + i.val % block + block)) := by + rw [← Equiv.sum_comp (foldLaneEquiv lanes block)] + simp [Fintype.sum_prod_type, Fin.sum_univ_two, foldLaneEquiv_val] + + theorem foldLane_one [Add α] [Mul α] [Inhabited α] (a : Array α) (r : α) : + foldLane a 1 r = foldLow a r := by + simp [foldLane, foldLow, Nat.mul_comm, Nat.mod_one] + +end Whir.ArrayLayout diff --git a/verification/whir/Whir/Concrete.lean b/verification/whir/Whir/Concrete.lean index 8736277e7..16fa3e812 100644 --- a/verification/whir/Whir/Concrete.lean +++ b/verification/whir/Whir/Concrete.lean @@ -55,11 +55,13 @@ end E instance : Add E := ⟨E.add⟩ instance : Mul E := ⟨E.mul⟩ +instance : Zero E := ⟨E.zero⟩ +instance : One E := ⟨E.one⟩ def tab (n : Nat) (f : Nat → α) : Array α := (List.range n).toArray.map f -def dot (a b : Array E) : E := - (tab (min a.size b.size) fun i => a[i]! * b[i]!).foldl (· + ·) E.zero +def dot {R : Type u} [Zero R] [Add R] [Mul R] [Inhabited R] (a b : Array R) : R := + (tab (min a.size b.size) fun i => a[i]! * b[i]!).foldl (· + ·) 0 def powers (a : E) (n : Nat) : Array E := Id.run do let mut out := #[] @@ -70,26 +72,28 @@ def powers (a : E) (n : Nat) : Array E := Id.run do return out /-- Coordinates and table indices are least-significant-bit first. -/ -def eqTable (point : Array E) : Array E := Id.run do - let mut out := #[E.one] +def eqTable {R : Type u} [One R] [Add R] [Mul R] (point : Array R) : Array R := Id.run do + let mut out := #[(1 : R)] for r in point do - out := (out.map fun x => x * (E.one + r)) ++ (out.map fun x => x * r) + out := (out.map fun x => x * (1 + r)) ++ (out.map fun x => x * r) return out -def foldPair (a b r : E) : E := a + r * (a + b) +def foldPair {R : Type u} [Add R] [Mul R] (a b r : R) : R := a + r * (a + b) -def foldLow (a : Array E) (r : E) : Array E := +def foldLow {R : Type u} [Add R] [Mul R] [Inhabited R] (a : Array R) (r : R) : Array R := tab (a.size / 2) fun i => foldPair a[2*i]! a[2*i+1]! r /-- One of the top-lane rounds: adjacent lane blocks, not adjacent words. -/ -def foldLane (a : Array E) (block : Nat) (r : E) : Array E := +def foldLane {R : Type u} [Add R] [Mul R] [Inhabited R] + (a : Array R) (block : Nat) (r : R) : Array R := tab (a.size / 2) fun i => let offset := (i / block) * (2*block) + i % block foldPair a[offset]! a[offset+block]! r -def mle (a : Array E) (point : Array E) : E := dot a (eqTable point) +def mle {R : Type u} [Zero R] [One R] [Add R] [Mul R] [Inhabited R] + (a : Array R) (point : Array R) : R := dot a (eqTable point) -def rotatePoint (initialK : Nat) (point : Array E) : Array E := +def rotatePoint {R : Type u} (initialK : Nat) (point : Array R) : Array R := point.extract initialK point.size ++ point.extract 0 initialK /-- s_i(v_i), including i=n, using the standard polynomial basis v_i=x^i. -/ diff --git a/verification/whir/Whir/Protocol.lean b/verification/whir/Whir/Protocol.lean index a58d22627..ac763bd54 100644 --- a/verification/whir/Whir/Protocol.lean +++ b/verification/whir/Whir/Protocol.lean @@ -87,19 +87,20 @@ def Challenges.valid (c : Config) (ch : Challenges) : Bool := Id.run do return ch.tail.size == n /-- The actual two transmitted coefficients. The linear coefficient is claim+u2. -/ -structure Message where - u0 : E - u2 : E +structure Message (R : Type u) where + u0 : R + u2 : R deriving Repr, Inhabited, BEq -def Message.eval (m : Message) (claim r : E) : E := +def Message.eval {R : Type u} [Add R] [Mul R] (m : Message R) (claim r : R) : R := m.u0 + r * (claim + m.u2) + (r*r) * m.u2 -def Message.glue (m other : Message) (s : E) : Message := +def Message.glue {R : Type u} [Add R] [Mul R] (m other : Message R) (s : R) : Message R := ⟨m.u0 + s*other.u0, m.u2 + s*other.u2⟩ -def roundMessage (f b : Array E) (block : Nat := 1) : Message := Id.run do - let mut m := Message.mk E.zero E.zero +def roundMessage {R : Type u} [Zero R] [Add R] [Mul R] [Inhabited R] + (f b : Array R) (block : Nat := 1) : Message R := Id.run do + let mut m := Message.mk (0 : R) 0 for i in [:f.size/2] do let offset := (i/block)*(2*block)+i%block let a := f[offset]! @@ -113,27 +114,53 @@ abbrev Oracle := Array (Array E) structure OodClaim where value : E - intro : Message + intro : Message E deriving Repr, Inhabited structure LevelProof where - afterFold : Array Message + afterFold : Array (Message E) nextOracle : Option Oracle oods : Array OodClaim rows : Array (Array E) - intro : Message + intro : Message E deriving Repr, Inhabited structure Opening where - initial : Message + initial : Message E levels : Array LevelProof residual : Array E - tailMessages : Array Message + tailMessages : Array (Message E) deriving Repr, Inhabited -def weightGlue (b other : Array E) (s : E) : Array E := +def weightGlue {R : Type u} [Add R] [Mul R] [Inhabited R] + (b other : Array R) (s : R) : Array R := tab b.size fun j => b[j]! + s*other[j]! +/-- The same low- or top-lane fold used by the prover and verifier. -/ +def foldValues {R : Type u} [Add R] [Mul R] [Inhabited R] + (values : Array R) (block : Nat) (r : R) : Array R := + if block == 1 then foldLow values r else foldLane values block r + +structure VerifierState (R : Type u) where + weight : Array R + claim : R + message : Message R + deriving Repr, Inhabited + +def VerifierState.fold {R : Type u} [Add R] [Mul R] [Inhabited R] + (state : VerifierState R) (block : Nat) (r : R) (next : Message R) : VerifierState R := + ⟨foldValues state.weight block r, state.message.eval state.claim r, next⟩ + +def VerifierState.batch {R : Type u} [Add R] [Mul R] [Inhabited R] + (state : VerifierState R) (basis : Array R) (value scale : R) + (intro : Message R) : VerifierState R := + ⟨weightGlue state.weight basis scale, state.claim + scale * value, + state.message.glue intro scale⟩ + +def VerifierState.checkTerminal {R : Type u} [Mul R] [BEq R] [Inhabited R] + (state : VerifierState R) (value : R) : Bool := + state.claim == value * state.weight[0]! + def enforced (rows : Array (Array E)) (rs weights : Array E) (base : Bool) : E := let eq := eqTable rs (tab rows.size fun i => weights[i]! * dot (if base then rows[i]!.reverse else rows[i]!) eq).foldl (· + ·) E.zero @@ -166,8 +193,8 @@ def prove (c : Config) (ch : Challenges) (witness : Array K) (bInitial : Array E let mut afterFold := #[] for j in [:cs.folds.size] do let r := cs.folds[j]! - f := if i == 0 then foldLane f block r else foldLow f r - b := if i == 0 then foldLane b block r else foldLow b r + f := foldValues f (if i == 0 then block else 1) r + b := foldValues b (if i == 0 then block else 1) r n := n-1 afterFold := afterFold.push (roundMessage f b (if i == 0 && j+1 < cs.folds.size then block else 1)) let nextOracle := if i+1 < c.folds.size then some (encodeExt f n c.folds[i+1]! c.rates[i+1]!) else none @@ -193,8 +220,8 @@ def prove (c : Config) (ch : Challenges) (witness : Array K) (bInitial : Array E oracle := nextOracle.getD #[] let mut tailMessages := #[] for j in [:ch.tail.size] do - f := foldLow f ch.tail[j]! - b := foldLow b ch.tail[j]! + f := foldValues f 1 ch.tail[j]! + b := foldValues b 1 ch.tail[j]! if j+1 < ch.tail.size then tailMessages := tailMessages.push (roundMessage f b) return (root, ⟨initial, levels, residual, tailMessages⟩) @@ -207,18 +234,14 @@ def verify (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) if !oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes then throw "root shape" if proof.levels.size != c.folds.size || proof.tailMessages.size+1 != ch.tail.size then throw "proof length" let mut n := c.logN - let mut b := bInitial + let mut state : VerifierState E := ⟨bInitial, target, proof.initial⟩ let mut oracle := root - let mut claim := target - let mut msg := proof.initial for i in [:c.folds.size] do let cs := ch.levels[i]! let p := proof.levels[i]! if p.afterFold.size != cs.folds.size || p.oods.size != cs.oodPoints.size then throw "round/OOD length" for j in [:cs.folds.size] do - claim := msg.eval claim cs.folds[j]! - msg := p.afterFold[j]! - b := if i == 0 then foldLane b block cs.folds[j]! else foldLow b cs.folds[j]! + state := state.fold (if i == 0 then block else 1) cs.folds[j]! p.afterFold[j]! n := n-1 if i+1 < c.folds.size then let next ← p.nextOracle.elim (throw "missing commitment") pure @@ -235,19 +258,14 @@ def verify (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) for j in [:p.oods.size] do scalar := scalar*cs.lambda let ood := p.oods[j]! - claim := claim + scalar*ood.value - msg := msg.glue ood.intro scalar - b := weightGlue b (eqTable cs.oodPoints[j]!) scalar + state := state.batch (eqTable cs.oodPoints[j]!) ood.value scalar ood.intro scalar := scalar*cs.lambda - claim := claim + scalar*sum - msg := msg.glue p.intro scalar - b := weightGlue b (induced n qs ws) scalar + state := state.batch (induced n qs ws) sum scalar p.intro oracle := p.nextOracle.getD #[] for j in [:ch.tail.size] do - claim := msg.eval claim ch.tail[j]! - b := foldLow b ch.tail[j]! - if j+1 < ch.tail.size then msg := proof.tailMessages[j]! - if claim != mle proof.residual ch.tail * b[0]! then throw "terminal mismatch" + let next := if j+1 < ch.tail.size then proof.tailMessages[j]! else state.message + state := state.fold 1 ch.tail[j]! next + if !state.checkTerminal (mle proof.residual ch.tail) then throw "terminal mismatch" return () end Whir.Protocol diff --git a/verification/whir/Whir/ReplayRefinement.lean b/verification/whir/Whir/ReplayRefinement.lean new file mode 100644 index 000000000..075fce4cc --- /dev/null +++ b/verification/whir/Whir/ReplayRefinement.lean @@ -0,0 +1,146 @@ +import Whir.ArrayAlgebra +import Whir.ArrayLayout + +/-! Refinement of the actual field-parametric verifier state transitions. +No ring instance is supplied for the concrete UInt64-based extension field. -/ +namespace Whir.ReplayRefinement + +open Concrete Protocol +open scoped BigOperators + +variable {R : Type*} [CommRing R] [Inhabited R] + +omit [Inhabited R] in +theorem message_glue_eval (a b : Message R) (ca cb scale r : R) : + (a.glue b scale).eval (ca + scale * cb) r = + a.eval ca r + scale * b.eval cb r := by + simp only [Message.glue, Message.eval] + ring + +theorem foldValues_eq_lane (a : Array R) (block : Nat) (r : R) : + foldValues a block r = foldLane a block r := by + unfold foldValues + split + · rename_i h + have hb : block = 1 := by simpa using h + subst block + exact (ArrayLayout.foldLane_one a r).symm + · rfl + +/-- The logical meaning of a concrete replay state, including its pending intro. -/ +def Represents (state : VerifierState R) (witness : Array R) (block : Nat) : Prop := + state.weight.size = witness.size ∧ + state.claim = dot witness state.weight ∧ + state.message = roundMessage witness state.weight block + +/-- Exact equality of the pending quadratic update under batching. -/ +theorem batch_pending (state : VerifierState R) (basis : Array R) + (value scale r : R) (intro : Message R) : + (state.batch basis value scale intro).message.eval + (state.batch basis value scale intro).claim r = + state.message.eval state.claim r + scale * intro.eval value r := + message_glue_eval _ _ _ _ _ _ + +/-- The verifier's actual fold transition preserves its interpretation with an +honest pending message and honest next intro, for every aligned lane layout. -/ +theorem fold_preserves [CharP R 2] (state : VerifierState R) (f : Array R) + (block nextBlock lanes : Nat) (r : R) (h : Represents state f block) + (shape : f.size = (lanes * 2) * block) : + Represents + (state.fold block r (roundMessage (foldValues f block r) + (foldValues state.weight block r) nextBlock)) + (foldValues f block r) nextBlock := by + refine ⟨?_, ?_, rfl⟩ + · simp only [VerifierState.fold, foldValues_eq_lane, ArrayLayout.size_foldLane, h.1] + · simp only [VerifierState.fold, h.2.1, h.2.2, foldValues_eq_lane] + exact ArrayAlgebra.honest_foldLane f state.weight block lanes shape h.1 r + +/-- Every nonterminal power-of-two witness with a power-of-two lane block +meets the exact pairing shape, without a restriction on the occupied lanes. -/ +theorem fold_preserves_power_of_two [CharP R 2] + (state : VerifierState R) (f : Array R) (m k nextBlock : Nat) (r : R) + (h : Represents state f (2 ^ m)) (size : f.size = 2 ^ (m + k + 1)) : + Represents + (state.fold (2 ^ m) r (roundMessage (foldValues f (2 ^ m) r) + (foldValues state.weight (2 ^ m) r) nextBlock)) + (foldValues f (2 ^ m) r) nextBlock := by + apply fold_preserves state f (2 ^ m) nextBlock (2 ^ k) r h + rw [size] + simp [pow_add, Nat.mul_comm, Nat.mul_left_comm] + +/-- The actual OOD/query batching transition preserves both the claim and intro +polynomial. The supplied value is the honest inner product, not a postulated +whole-verifier acceptance result. -/ +theorem batch_preserves (state : VerifierState R) (f basis : Array R) + (block lanes : Nat) (scale : R) (h : Represents state f block) + (shape : f.size = (lanes * 2) * block) (basisSize : basis.size = f.size) : + Represents + (state.batch basis (dot f basis) scale (roundMessage f basis block)) f block := by + refine ⟨?_, ?_, ?_⟩ + · simpa only [VerifierState.batch, ArrayAlgebra.size_weightGlue] using h.1 + · simp only [VerifierState.batch, h.2.1] + exact (ArrayAlgebra.dot_weightGlue f state.weight basis scale h.1 basisSize).symm + · simp only [VerifierState.batch, h.2.2] + exact (ArrayAlgebra.roundMessage_weightGlue f state.weight basis scale block lanes shape h.1).symm + +/-- A transcript of the actual fold and batch transitions, with honest messages +generated by the executable array kernels. This does not assume that a resulting +state or verifier accepts. Block changes cover the lane/low and level boundaries. -/ +inductive HonestTrace : VerifierState R → Array R → Nat → + VerifierState R → Array R → Nat → Prop + | done (state : VerifierState R) (f : Array R) (block : Nat) : + HonestTrace state f block state f block + | fold {state finish : VerifierState R} {f result : Array R} + {block nextBlock endBlock : Nat} (lanes : Nat) (r : R) + (shape : f.size = (lanes * 2) * block) + (rest : HonestTrace + (state.fold block r (roundMessage (foldValues f block r) + (foldValues state.weight block r) nextBlock)) + (foldValues f block r) nextBlock finish result endBlock) : + HonestTrace state f block finish result endBlock + | batch {state finish : VerifierState R} {f result : Array R} + {block endBlock : Nat} (lanes : Nat) (basis : Array R) (scale : R) + (shape : f.size = (lanes * 2) * block) (basisSize : basis.size = f.size) + (rest : HonestTrace + (state.batch basis (dot f basis) scale (roundMessage f basis block)) + f block finish result endBlock) : + HonestTrace state f block finish result endBlock + +/-- Any number of rounds and level batches preserve the actual array-state +invariant. Remaining obligations are generating this trace from the outer +prover/checking loops and interpreting their authenticated query answers. -/ +theorem trace_preserves [CharP R 2] + {state finish : VerifierState R} {f result : Array R} {block endBlock : Nat} + (trace : HonestTrace state f block finish result endBlock) + (initial : Represents state f block) : Represents finish result endBlock := by + induction trace with + | done => exact initial + | fold lanes r shape rest ih => + exact ih (fold_preserves _ _ _ _ lanes r initial shape) + | batch lanes basis scale shape basisSize rest ih => + exact ih (batch_preserves _ _ basis _ lanes scale initial shape basisSize) + +/-- The actual terminal Boolean comparison accepts an invariant-preserving scalar +state when the supplied final evaluation is that scalar witness. -/ +theorem terminal_complete [BEq R] [LawfulBEq R] + (state : VerifierState R) (witness : Array R) (value : R) + (hs : witness.size = 1) (hw : state.weight.size = witness.size) + (hc : state.claim = dot witness state.weight) (hv : value = witness[0]!) : + state.checkTerminal value = true := by + simp only [VerifierState.checkTerminal, beq_iff_eq] + rw [hc, ArrayAlgebra.dot_eq_sum, hw, hs] + simp only [Nat.min_self, Finset.sum_range_one] + rw [hv] + +/-- Honest actual array messages, through arbitrary folds and level batches, +pass the actual terminal Boolean checker once one witness scalar remains. -/ +theorem trace_terminal [CharP R 2] [BEq R] [LawfulBEq R] + (f weight : Array R) (block : Nat) (sameSize : weight.size = f.size) + {finish : VerifierState R} {result : Array R} {endBlock : Nat} + (trace : HonestTrace ⟨weight, dot f weight, roundMessage f weight block⟩ + f block finish result endBlock) (scalar : result.size = 1) : + finish.checkTerminal result[0]! = true := by + have h := trace_preserves trace ⟨sameSize, rfl, rfl⟩ + exact terminal_complete finish result result[0]! scalar h.1 h.2.1 rfl + +end Whir.ReplayRefinement From 8b5f31377208af12c5f64f61131ddfc7494c9fff Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Thu, 8 Oct 2026 20:19:17 +0100 Subject: [PATCH 03/28] Extend Lean WHIR proofs through raw ROM and native arithmetic --- verification/whir/Main.lean | 9 +- verification/whir/README.md | 95 +- verification/whir/Whir.lean | 130 ++ verification/whir/Whir/AcceptedShapes.lean | 142 ++ .../whir/Whir/AccumulatedTerminalAlgebra.lean | 170 +++ .../Whir/AccumulatedTerminalRefinement.lean | 675 +++++++++ .../Whir/AccumulatedTerminalRegression.lean | 134 ++ verification/whir/Whir/AdditiveBasis.lean | 50 + verification/whir/Whir/AdditiveCode.lean | 336 +++++ verification/whir/Whir/AdditiveColumn.lean | 346 +++++ .../whir/Whir/AdditiveNormalization.lean | 159 +++ .../whir/Whir/BaseCandidateDescent.lean | 277 ++++ .../whir/Whir/BatchingRefinement.lean | 355 +++++ verification/whir/Whir/ByteCodec.lean | 301 ++++ verification/whir/Whir/CandidateFolding.lean | 580 ++++++++ .../whir/Whir/CausalAllocationLabels.lean | 140 ++ verification/whir/Whir/CausalBadEvents.lean | 234 ++++ .../whir/Whir/CausalBindingState.lean | 538 +++++++ verification/whir/Whir/CausalBoundary.lean | 585 ++++++++ verification/whir/Whir/CausalExecution.lean | 224 +++ verification/whir/Whir/CausalFolds.lean | 159 +++ verification/whir/Whir/CausalGame.lean | 239 ++++ verification/whir/Whir/CausalInitial.lean | 53 + verification/whir/Whir/CausalPositions.lean | 122 ++ verification/whir/Whir/CausalPrefix.lean | 250 ++++ verification/whir/Whir/CausalProbability.lean | 399 ++++++ verification/whir/Whir/CausalRefinement.lean | 374 +++++ .../whir/Whir/CausalStateCausality.lean | 267 ++++ verification/whir/Whir/CausalStrategy.lean | 369 +++++ verification/whir/Whir/CausalTerminal.lean | 343 +++++ verification/whir/Whir/CodingBounds.lean | 216 +++ verification/whir/Whir/Concrete.lean | 8 +- .../whir/Whir/ConcreteCandidates.lean | 135 ++ verification/whir/Whir/DuplexCompression.lean | 212 +++ verification/whir/Whir/DuplexEncoding.lean | 359 +++++ verification/whir/Whir/DuplexFraming.lean | 914 ++++++++++++ verification/whir/Whir/DuplexModeGame.lean | 335 +++++ .../whir/Whir/DuplexPublicSimulator.lean | 1242 +++++++++++++++++ verification/whir/Whir/DuplexRawProgram.lean | 171 +++ verification/whir/Whir/DuplexRefinement.lean | 1021 ++++++++++++++ verification/whir/Whir/ExecutableOOD.lean | 181 +++ verification/whir/Whir/ExecutionShapes.lean | 108 ++ verification/whir/Whir/FiatShamirGame.lean | 492 +++++++ verification/whir/Whir/FieldCardinality.lean | 39 + verification/whir/Whir/FieldConjugates.lean | 40 + verification/whir/Whir/FieldEmbedding.lean | 58 + verification/whir/Whir/FieldEquality.lean | 16 + verification/whir/Whir/FieldEquivalence.lean | 55 + verification/whir/Whir/FieldExtension.lean | 188 +++ verification/whir/Whir/FieldFinite.lean | 31 + verification/whir/Whir/FieldInverse.lean | 77 + verification/whir/Whir/FieldIrreducible.lean | 108 ++ verification/whir/Whir/FieldModel.lean | 317 +++++ verification/whir/Whir/FieldTower.lean | 77 + verification/whir/Whir/FoldSoundness.lean | 89 ++ verification/whir/Whir/GroupedChallenges.lean | 95 ++ .../whir/Whir/InducedTerminalRefinement.lean | 254 ++++ verification/whir/Whir/InitialBatching.lean | 279 ++++ verification/whir/Whir/InitialCandidates.lean | 206 +++ verification/whir/Whir/InitialSoundness.lean | 72 + .../whir/Whir/InitialTerminalRefinement.lean | 65 + .../whir/Whir/InteractiveSoundness.lean | 271 ++++ .../whir/Whir/JohnsonListNumerics.lean | 54 + verification/whir/Whir/JohnsonMCA.lean | 159 +++ verification/whir/Whir/JohnsonNumerics.lean | 77 + verification/whir/Whir/LevelBoundary.lean | 137 ++ verification/whir/Whir/MerkleBinding.lean | 344 +++++ verification/whir/Whir/MerkleLevels.lean | 611 ++++++++ verification/whir/Whir/MerkleTransport.lean | 1147 +++++++++++++++ verification/whir/Whir/MutualAgreement.lean | 376 +++++ verification/whir/Whir/OODBounds.lean | 217 +++ .../whir/Whir/OperationalRefinement.lean | 278 ++++ verification/whir/Whir/OracleReplay.lean | 239 ++++ verification/whir/Whir/ParameterBounds.lean | 273 ++++ .../whir/Whir/ProductionTransitions.lean | 81 ++ verification/whir/Whir/Protocol.lean | 145 +- .../whir/Whir/PrunedMerkleProgram.lean | 655 +++++++++ .../whir/Whir/PublicMerkleBinding.lean | 277 ++++ verification/whir/Whir/PublicMerkleLog.lean | 871 ++++++++++++ .../whir/Whir/PublicMerkleProgram.lean | 288 ++++ .../whir/Whir/QueryBatchSoundness.lean | 240 ++++ verification/whir/Whir/QueryRefinement.lean | 779 +++++++++++ verification/whir/Whir/RawOracleCoupling.lean | 471 +++++++ .../whir/Whir/RawOracleProvenance.lean | 728 ++++++++++ verification/whir/Whir/RawWHIRKeys.lean | 564 ++++++++ verification/whir/Whir/RingMapBatching.lean | 188 +++ .../whir/Whir/RingMapBatchingConcrete.lean | 72 + verification/whir/Whir/RingMapConcrete.lean | 38 + .../whir/Whir/RingMapInjectivity.lean | 89 ++ verification/whir/Whir/RingMapSoundness.lean | 310 ++++ verification/whir/Whir/RingPCSGame.lean | 333 +++++ .../whir/Whir/SamplingProbability.lean | 351 +++++ .../whir/Whir/SamplingRefinement.lean | 161 +++ verification/whir/Whir/Soundness.lean | 10 +- verification/whir/Whir/StackWHIRCodec.lean | 188 +++ verification/whir/Whir/StackWHIRROM.lean | 222 +++ verification/whir/Whir/StackWHIRReplay.lean | 334 +++++ verification/whir/Whir/StratifiedDensity.lean | 245 ++++ .../whir/Whir/SuccinctPointWeight.lean | 468 +++++++ .../whir/Whir/SuccinctRingCoefficients.lean | 128 ++ .../whir/Whir/SuccinctRingGroups.lean | 289 ++++ .../whir/Whir/SuccinctRingWeight.lean | 435 ++++++ verification/whir/Whir/TapeValidity.lean | 165 +++ .../whir/Whir/TerminalRefinement.lean | 169 +++ verification/whir/Whir/TerminalSoundness.lean | 311 +++++ .../whir/Whir/TypedFiatShamirGame.lean | 278 ++++ .../whir/Whir/TypedOracleCompiler.lean | 727 ++++++++++ verification/whir/Whir/VerifierInvariant.lean | 101 ++ verification/whir/Whir/WHIRCallerOutputs.lean | 234 ++++ verification/whir/Whir/WHIRCallerPrefix.lean | 355 +++++ verification/whir/Whir/WHIRCallerShape.lean | 174 +++ verification/whir/Whir/WHIRCausalRawROM.lean | 322 +++++ verification/whir/Whir/WHIRFiatShamir.lean | 446 ++++++ verification/whir/Whir/WHIRHistory.lean | 900 ++++++++++++ verification/whir/Whir/WHIRHistoryKey.lean | 412 ++++++ verification/whir/Whir/WHIRModeFinal.lean | 352 +++++ verification/whir/Whir/WHIRModeProgram.lean | 150 ++ verification/whir/Whir/WHIRModeReplay.lean | 143 ++ .../whir/Whir/WHIRNativeArithmetic.lean | 738 ++++++++++ .../Whir/WHIRNativeArithmeticRegression.lean | 110 ++ verification/whir/Whir/WHIRNativeErasure.lean | 51 + verification/whir/Whir/WHIRNativeGuards.lean | 250 ++++ .../whir/Whir/WHIRObservableAllocations.lean | 364 +++++ .../whir/Whir/WHIRPhysicalErasure.lean | 206 +++ .../whir/Whir/WHIRPhysicalHistory.lean | 191 +++ verification/whir/Whir/WHIRPhysicalRows.lean | 93 ++ verification/whir/Whir/WHIRPowProgram.lean | 489 +++++++ .../whir/Whir/WHIRPublicBackfill.lean | 757 ++++++++++ verification/whir/Whir/WHIRROM.lean | 454 ++++++ verification/whir/Whir/WHIRRawHistory.lean | 146 ++ verification/whir/Whir/WHIRRawROM.lean | 177 +++ verification/whir/Whir/WHIRRawReplay.lean | 127 ++ verification/whir/Whir/WHIRReplay.lean | 401 ++++++ .../whir/Whir/WHIRSnapshotReplay.lean | 221 +++ .../whir/Whir/WHIRSourceChronology.lean | 382 +++++ .../whir/Whir/WHIRSourceObserver.lean | 105 ++ verification/whir/differential/run.py | 19 +- verification/whir/lake-manifest.json | 112 +- verification/whir/lakefile.toml | 5 + 139 files changed, 39209 insertions(+), 86 deletions(-) create mode 100644 verification/whir/Whir/AcceptedShapes.lean create mode 100644 verification/whir/Whir/AccumulatedTerminalAlgebra.lean create mode 100644 verification/whir/Whir/AccumulatedTerminalRefinement.lean create mode 100644 verification/whir/Whir/AccumulatedTerminalRegression.lean create mode 100644 verification/whir/Whir/AdditiveBasis.lean create mode 100644 verification/whir/Whir/AdditiveCode.lean create mode 100644 verification/whir/Whir/AdditiveColumn.lean create mode 100644 verification/whir/Whir/AdditiveNormalization.lean create mode 100644 verification/whir/Whir/BaseCandidateDescent.lean create mode 100644 verification/whir/Whir/BatchingRefinement.lean create mode 100644 verification/whir/Whir/ByteCodec.lean create mode 100644 verification/whir/Whir/CandidateFolding.lean create mode 100644 verification/whir/Whir/CausalAllocationLabels.lean create mode 100644 verification/whir/Whir/CausalBadEvents.lean create mode 100644 verification/whir/Whir/CausalBindingState.lean create mode 100644 verification/whir/Whir/CausalBoundary.lean create mode 100644 verification/whir/Whir/CausalExecution.lean create mode 100644 verification/whir/Whir/CausalFolds.lean create mode 100644 verification/whir/Whir/CausalGame.lean create mode 100644 verification/whir/Whir/CausalInitial.lean create mode 100644 verification/whir/Whir/CausalPositions.lean create mode 100644 verification/whir/Whir/CausalPrefix.lean create mode 100644 verification/whir/Whir/CausalProbability.lean create mode 100644 verification/whir/Whir/CausalRefinement.lean create mode 100644 verification/whir/Whir/CausalStateCausality.lean create mode 100644 verification/whir/Whir/CausalStrategy.lean create mode 100644 verification/whir/Whir/CausalTerminal.lean create mode 100644 verification/whir/Whir/CodingBounds.lean create mode 100644 verification/whir/Whir/ConcreteCandidates.lean create mode 100644 verification/whir/Whir/DuplexCompression.lean create mode 100644 verification/whir/Whir/DuplexEncoding.lean create mode 100644 verification/whir/Whir/DuplexFraming.lean create mode 100644 verification/whir/Whir/DuplexModeGame.lean create mode 100644 verification/whir/Whir/DuplexPublicSimulator.lean create mode 100644 verification/whir/Whir/DuplexRawProgram.lean create mode 100644 verification/whir/Whir/DuplexRefinement.lean create mode 100644 verification/whir/Whir/ExecutableOOD.lean create mode 100644 verification/whir/Whir/ExecutionShapes.lean create mode 100644 verification/whir/Whir/FiatShamirGame.lean create mode 100644 verification/whir/Whir/FieldCardinality.lean create mode 100644 verification/whir/Whir/FieldConjugates.lean create mode 100644 verification/whir/Whir/FieldEmbedding.lean create mode 100644 verification/whir/Whir/FieldEquality.lean create mode 100644 verification/whir/Whir/FieldEquivalence.lean create mode 100644 verification/whir/Whir/FieldExtension.lean create mode 100644 verification/whir/Whir/FieldFinite.lean create mode 100644 verification/whir/Whir/FieldInverse.lean create mode 100644 verification/whir/Whir/FieldIrreducible.lean create mode 100644 verification/whir/Whir/FieldModel.lean create mode 100644 verification/whir/Whir/FieldTower.lean create mode 100644 verification/whir/Whir/FoldSoundness.lean create mode 100644 verification/whir/Whir/GroupedChallenges.lean create mode 100644 verification/whir/Whir/InducedTerminalRefinement.lean create mode 100644 verification/whir/Whir/InitialBatching.lean create mode 100644 verification/whir/Whir/InitialCandidates.lean create mode 100644 verification/whir/Whir/InitialSoundness.lean create mode 100644 verification/whir/Whir/InitialTerminalRefinement.lean create mode 100644 verification/whir/Whir/InteractiveSoundness.lean create mode 100644 verification/whir/Whir/JohnsonListNumerics.lean create mode 100644 verification/whir/Whir/JohnsonMCA.lean create mode 100644 verification/whir/Whir/JohnsonNumerics.lean create mode 100644 verification/whir/Whir/LevelBoundary.lean create mode 100644 verification/whir/Whir/MerkleBinding.lean create mode 100644 verification/whir/Whir/MerkleLevels.lean create mode 100644 verification/whir/Whir/MerkleTransport.lean create mode 100644 verification/whir/Whir/MutualAgreement.lean create mode 100644 verification/whir/Whir/OODBounds.lean create mode 100644 verification/whir/Whir/OperationalRefinement.lean create mode 100644 verification/whir/Whir/OracleReplay.lean create mode 100644 verification/whir/Whir/ParameterBounds.lean create mode 100644 verification/whir/Whir/ProductionTransitions.lean create mode 100644 verification/whir/Whir/PrunedMerkleProgram.lean create mode 100644 verification/whir/Whir/PublicMerkleBinding.lean create mode 100644 verification/whir/Whir/PublicMerkleLog.lean create mode 100644 verification/whir/Whir/PublicMerkleProgram.lean create mode 100644 verification/whir/Whir/QueryBatchSoundness.lean create mode 100644 verification/whir/Whir/QueryRefinement.lean create mode 100644 verification/whir/Whir/RawOracleCoupling.lean create mode 100644 verification/whir/Whir/RawOracleProvenance.lean create mode 100644 verification/whir/Whir/RawWHIRKeys.lean create mode 100644 verification/whir/Whir/RingMapBatching.lean create mode 100644 verification/whir/Whir/RingMapBatchingConcrete.lean create mode 100644 verification/whir/Whir/RingMapConcrete.lean create mode 100644 verification/whir/Whir/RingMapInjectivity.lean create mode 100644 verification/whir/Whir/RingMapSoundness.lean create mode 100644 verification/whir/Whir/RingPCSGame.lean create mode 100644 verification/whir/Whir/SamplingProbability.lean create mode 100644 verification/whir/Whir/SamplingRefinement.lean create mode 100644 verification/whir/Whir/StackWHIRCodec.lean create mode 100644 verification/whir/Whir/StackWHIRROM.lean create mode 100644 verification/whir/Whir/StackWHIRReplay.lean create mode 100644 verification/whir/Whir/StratifiedDensity.lean create mode 100644 verification/whir/Whir/SuccinctPointWeight.lean create mode 100644 verification/whir/Whir/SuccinctRingCoefficients.lean create mode 100644 verification/whir/Whir/SuccinctRingGroups.lean create mode 100644 verification/whir/Whir/SuccinctRingWeight.lean create mode 100644 verification/whir/Whir/TapeValidity.lean create mode 100644 verification/whir/Whir/TerminalRefinement.lean create mode 100644 verification/whir/Whir/TerminalSoundness.lean create mode 100644 verification/whir/Whir/TypedFiatShamirGame.lean create mode 100644 verification/whir/Whir/TypedOracleCompiler.lean create mode 100644 verification/whir/Whir/VerifierInvariant.lean create mode 100644 verification/whir/Whir/WHIRCallerOutputs.lean create mode 100644 verification/whir/Whir/WHIRCallerPrefix.lean create mode 100644 verification/whir/Whir/WHIRCallerShape.lean create mode 100644 verification/whir/Whir/WHIRCausalRawROM.lean create mode 100644 verification/whir/Whir/WHIRFiatShamir.lean create mode 100644 verification/whir/Whir/WHIRHistory.lean create mode 100644 verification/whir/Whir/WHIRHistoryKey.lean create mode 100644 verification/whir/Whir/WHIRModeFinal.lean create mode 100644 verification/whir/Whir/WHIRModeProgram.lean create mode 100644 verification/whir/Whir/WHIRModeReplay.lean create mode 100644 verification/whir/Whir/WHIRNativeArithmetic.lean create mode 100644 verification/whir/Whir/WHIRNativeArithmeticRegression.lean create mode 100644 verification/whir/Whir/WHIRNativeErasure.lean create mode 100644 verification/whir/Whir/WHIRNativeGuards.lean create mode 100644 verification/whir/Whir/WHIRObservableAllocations.lean create mode 100644 verification/whir/Whir/WHIRPhysicalErasure.lean create mode 100644 verification/whir/Whir/WHIRPhysicalHistory.lean create mode 100644 verification/whir/Whir/WHIRPhysicalRows.lean create mode 100644 verification/whir/Whir/WHIRPowProgram.lean create mode 100644 verification/whir/Whir/WHIRPublicBackfill.lean create mode 100644 verification/whir/Whir/WHIRROM.lean create mode 100644 verification/whir/Whir/WHIRRawHistory.lean create mode 100644 verification/whir/Whir/WHIRRawROM.lean create mode 100644 verification/whir/Whir/WHIRRawReplay.lean create mode 100644 verification/whir/Whir/WHIRReplay.lean create mode 100644 verification/whir/Whir/WHIRSnapshotReplay.lean create mode 100644 verification/whir/Whir/WHIRSourceChronology.lean create mode 100644 verification/whir/Whir/WHIRSourceObserver.lean diff --git a/verification/whir/Main.lean b/verification/whir/Main.lean index bcdd4daa8..9192e9d74 100644 --- a/verification/whir/Main.lean +++ b/verification/whir/Main.lean @@ -1,4 +1,5 @@ import Whir.Protocol +import Whir.CausalGame open Whir.Concrete Whir.Protocol @@ -47,7 +48,13 @@ def smoke : IO Unit := do let badCh := {ch with levels := ch.levels.set! 0 {ch.levels[0]! with querySqueezes := #[]}} requireIO (!(verify c badCh 3 root b target p).isOk) "missing query challenge accepted" requireIO (!(verify c ch 0 root b target p).isOk) "empty lane layout accepted" - IO.println "lean_smoke=honest,multilevel,truncated_lanes,bad_target,short_opening,short_final,bad_final,missing_query,bad_row,bad_ood,missing_ood,missing_challenge,bad_layout" + let badPublic : Whir.CausalGame.Public := ⟨c, 3, #[], #[⟨b.pop, target⟩]⟩ + let tape : Whir.CausalGame.Tape c := ⟨E.zero, + (fun _ => ⟨(fun _ => E.zero), (fun _ _ => E.zero), (fun _ => E.zero), E.zero⟩), + fun _ => E.zero⟩ + requireIO (!Whir.CausalGame.experiment badPublic (fun _ _ _ => .initial default) tape) + "malformed public claim accepted" + IO.println "lean_smoke=honest,multilevel,truncated_lanes,bad_target,short_opening,short_final,bad_final,missing_query,bad_row,bad_ood,missing_ood,missing_challenge,bad_layout,malformed_public_claim" def vectors : IO Unit := do emitN "kmul" (tab 40 fun i => (kmul (seed i) (seed (i+41))).toNat) diff --git a/verification/whir/README.md b/verification/whir/README.md index ceac9719a..4a4341772 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -1,20 +1,20 @@ -# Executable WHIR model and checked algebra +# Executable WHIR model and checked list binding -This isolated Lean project models leanVM's binary-field, interleaved WHIR variant at production revision [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217). It contains an executable concrete model, generic checked algebra, exact layout/query arithmetic, finite soundness lemmas, and live Rust differential checks. It does **not** prove the Rust source correct, full PCS list binding, or security of the concrete Fiat-Shamir transcript. +This isolated Lean project models leanVM's binary-field, interleaved WHIR variant at production revision [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217). It contains an executable concrete prover/verifier, checked concrete field and encoder mathematics, a proof of adaptive interactive **list binding** for the actual Lean verifier, and ordinary random-oracle bounds for executable standalone and stacked oracle adversaries. Live Rust differential checks provide separate implementation evidence. This is not a kernel proof of Rust compilation or a proof that deterministic BLAKE2s is a random oracle. ## Reproduce -Dependencies are pinned by `lean-toolchain`, `lakefile.toml`, `lake-manifest.json`, and the external Rust harness's `Cargo.lock`. Lean is 4.34.0; Mathlib is `5ed2965256430c3649e86755f9576b54eca72435`. The Rust harness uses toolchain 1.97 and the production crates through relative path dependencies, without changing their APIs. Linux reproduction requires a working user systemd session; scopes cap each command at 16 GiB with no swap. +Dependencies are pinned by `lean-toolchain`, `lakefile.toml`, `lake-manifest.json`, and the external Rust harness's `Cargo.lock`. Lean is 4.34.0; Mathlib is `5ed2965256430c3649e86755f9576b54eca72435`. The imported ArkLib dependency is the [audited fork at `456f4f85acdde6aeb373794d0c5d0b133c2c11ea`](https://github.com/kevaundray/ArkLib/tree/456f4f85acdde6aeb373794d0c5d0b133c2c11ea), with the upstream discrepancy described below. The Rust harness uses toolchain 1.97 and production crates through relative path dependencies, without changing their APIs. Linux reproduction requires a working user systemd session; scopes cap each command at 16 GiB with no swap. ```sh cd verification/whir systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 lake update -systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 lake build --wfail -systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 lake env lean Audit.lean +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake build --wfail +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake env lean Audit.lean python3 differential/run.py ``` -The runner builds and executes `whirModel`, executes the production Rust harness in release mode, and compares newly computed records. Its query mode also feeds actual production challenge limbs to Lean. It uses `/tmp/whir-lean-target`, two Cargo jobs, and one leanVM worker. There are no accepted-output snapshots to regenerate. Lean proof checking is separate from executable differential evidence. +The runner builds and executes `whirModel`, executes the production Rust harness in release mode, and compares newly computed records. Its query mode also feeds actual production challenge limbs to Lean. It uses `/tmp/whir-lean-target`, two Cargo jobs, and one leanVM worker. Lean execution must emit no runtime diagnostic on stderr, including on malformed public inputs. There are no accepted-output snapshots to regenerate. Lean proof checking is separate from executable differential evidence. ## Protocol to code to theorem map @@ -22,25 +22,25 @@ Paths below are relative to `crates/pcs/src`, except the Python mirror, `python- | Protocol step | Production implementation and mirror | Lean executable/specification | Checked guarantee and boundary | | --- | --- | --- | --- | -| Shapes and rate ladder | `whir/config.rs`, Python `WhirConfig` | `Protocol.productionConfig`, `Layout.Shape` | Exact bounded index arithmetic; production tables are compared for every supported log-size/rate, not formally derived from a security target. | -| K/E arithmetic and embedding | `primitives::field::{F64,F192}` | `Concrete.kmul`, `Concrete.E`; `Algebra.novelEncode_lift` | Concrete arithmetic is executable and differentially checked. Generic embedding theorem requires an explicit ring homomorphism; there is no asserted concrete `Field` instance. | -| Interleaved commitment | `whir/commit.rs`, `ntt/additive_ntt_f64.rs` | `Concrete.encodeBase`, `Concrete.encodeExt`, `Layout.transposeIndex`, `Algebra.novelEncode` | Reversed-lane permutation/inverse and padding restoration are proved. Generic encoder is the tensor product of normalized novel-basis factors. NTT-to-spec universal refinement is not proved. | +| Shapes and rate ladder | `whir/config.rs`, Python `WhirConfig` | `Protocol.productionConfig`, `Layout`, `ParameterBounds` | Exact index arithmetic and kernel-checked error inequalities for all 56 profiles: log-size 15 through 28, rate index 1 through 4. | +| K/E arithmetic and embedding | `primitives::field::{F64,F192}` | `Concrete`, `FieldModel`, `FieldIrreducible`, `FieldEquivalence` | Actual XOR/reduced multiplication, inverses, quotient field equivalences, exact cardinalities, embedding and distinct Frobenius conjugates are proved. No concrete field law is assumed. | +| Interleaved commitment | `whir/commit.rs`, `ntt/additive_ntt_f64.rs` | `Concrete.encodeBase/encodeExt`, `AdditiveBasis`, `AdditiveColumn`, `CandidateFolding` | The actual dense Lean encoder is connected to the additive novel-basis Reed-Solomon polynomial, with injectivity, degree, agreement, reversed lanes and zero-tail geometry. Rust's optimized NTT remains differentially checked rather than universally refined. | | Equality weights and MLE | `primitives::multilinear`, Python `eq_kernel` | `Algebra.eqWeight`, `mle`, `foldFirst` | Partition of unity, Boolean interpolation, partial evaluation, constant evaluation, batching linearity. | | Compact quadratic round | `whir/sumcheck.rs`, `verify.rs::Quad`, Python transcript round reader | `Algebra.compactRound`, `roundConstant`, `roundQuadratic` | Characteristic-two endpoint relation, reconstruction, honest round preservation, all-round sumcheck terminal equality. | | Lane fold and later folds | `whir/prove.rs`, `sumcheck.rs`, `commit.rs` | `Concrete.foldLane`, `foldLow`, `Completeness.foldBlock` | Generic block folding is linear; encoding commutes with multilinear folds; all sizes, including empty algebraic blocks, are handled. Production-valid schedules are a subset. | -| OOD and query claims | `verify.rs::Ood`, `LevelCtx`, `induce.rs`; Python `_induced_weight` | `Protocol.prove/verify`, `Algebra.inducedWeight`, `Completeness.nextWeight` | Opened-column/induced inner-product identity and factorized MLE are proved for normalized factors. OOD enters only after subsequent commitments. | -| Query sampling | `whir.rs::strata/sample_queries_ordered`, public `OpeningVerifier`; Python `strata/sample_queries` | `Layout.strataBits`, `rawQuery`, `sampleQueries`; `Concrete.deriveQueries` | Exact counts, bounds, bit-chunk safety, fixed top bits, repeated full-domain groups, order and duplicate row behavior. Product/AM-GM miss bound is separate in `QuerySoundness`. | -| Pruned row authentication | `merkle.rs`, verifier `open_base` operations; Python `Transcript.merkle` | `Layout.prunedLeaf/restoreLeaf`, ideal oracle rows in `Protocol` | Leading-zero restoration and reversed live-lane ordering proved. Authentication in the executable model is exact ideal row lookup, not BLAKE2 or Merkle collision resistance. | +| OOD and query claims | `verify.rs::Ood`, `LevelCtx`, `induce.rs`; Python `_induced_weight` | `QueryRefinement`, `BatchingRefinement`, `ExecutableOOD`, `CausalBoundary` | Actual authenticated-column folds and actual induced-weight dots agree; concrete MLE/OOD root bounds and adaptive query batching preserve the lost-list invariant except for bounded bad events. | +| Query sampling | `whir.rs::strata/sample_queries_ordered`, public `OpeningVerifier`; Python `strata/sample_queries` | `Concrete.deriveQueries`, `SamplingRefinement`, `SamplingProbability`, `StratifiedDensity` | Exact E-limb chunk extraction, stratified product distribution, repeated full-domain groups, unused bits and with-replacement duplicate queries; no replacement by iid whole-domain samples. | +| Pruned row authentication | `merkle.rs`, verifier `open_base` operations; Python `Transcript.merkle` | `ByteCodec`, `MerkleLevels`, `MerkleTransport` | Actual flat octopus walk, sorted unique reconstruction, duplicate/order refanout, byte codecs and pruned lanes refine fixed ideal rows, or exhibit an actual hash collision or fresh target hit. A first-registration registry freezes each root's oracle across clones and later batches. | | Terminal point | `verify.rs::terminal`, Python `verify_whir` | `Layout.terminalPoint/levelPoint`, `Concrete.rotatePoint` | Caller weight receives the left-rotated point; per-level suffix stays in round order. Rotation length, permutation, inverse and slices are proved. | | Last-level closure | `verify.rs::last_level/terminal` | `Protocol.verify`, `Completeness.finalWeight/finalClaim/replay` | Final consistency powers start at one, without OOD; honest residual plus query batching and all-level algebraic terminal equality are proved. | -| Ring switching and stack | `ring_switch.rs::RingFamily/RingShare`, `stack_open.rs`, Python `ring_switch` | `RingSwitch.composedMap`, `honest_family`, `stacked_claim` | Frobenius-map additivity, honest binary-slice reduction, arbitrary-point family batching with scale **inside** the map, overlapping-region addition, padding noninterference. Concrete optimized inverse-Frobenius/prefix-sharing refinement and map injectivity/soundness are not proved. | -| Interactive errors | Annex B `thm:rbr` | `Soundness` | Root counts, RS evaluation distance, false-claim quadratic round bound, adaptive-history product-space root count, list union bound, first escape and finite RBR error accumulation. This does not instantiate the whole WHIR invariant. | +| Ring switching and stack | `ring_switch.rs::RingFamily/RingShare`, `stack_open.rs`, Python `ring_switch` | `RingMapConcrete`, `RingMapBatchingConcrete`, `RingPCSGame` | Exact K-word packing into 64 slices, concrete six-stage map and its error, family gamma batching with scale inside the map, original family/point claims and their actual transformed public weights. | +| Interactive list binding | Annex B `thm:rbr` | `CausalGame`, `InitialCandidates`, `CausalBadEvents`, `InteractiveSoundness` | A commitment-time list of at most 2^32 K-witnesses is fixed before public claims and the causal adversarial strategy. Actual false acceptance implies one of the proved sparse events; the full finite-tape probability bound is instantiated for every production profile. | -`Completeness.Schedule` is an ideal algebraic schedule with supplied challenges and honest mathematical column answers. Its `all_levels_complete` theorem proves preservation through arbitrary fold blocks, residual/OOD/query batching and closing sumcheck. It is not a theorem about `Protocol.verify`'s arrays or serialization. The executable model and the mathematical specification are deliberately separate where a refinement bridge is missing. +`Completeness.Schedule` remains a useful ideal algebraic completeness theorem. The security endpoint does not assume that an execution belongs to that honest schedule: `InteractiveSoundness.accepted_false_cover` reasons from acceptance by the actual checked initializer, fold loops, authenticated query/OOD batches, residual opening and terminal comparison, for arbitrary adversarial replies. ## Refinement of the actual executable kernels -The operational kernels are now polymorphic over their minimal operations, and the concrete prover/verifier still call those same definitions specialized to `Concrete.E`. This is not a parallel mathematical reimplementation. Only `Zero E` and `One E` were added; no ring or field laws were asserted for E. +The operational kernels are polymorphic over their minimal operations, and the concrete prover/verifier call those same definitions specialized to `Concrete.E`. Their array refinements are not a parallel mathematical reimplementation. The concrete ring and field instances are now derived from the exact bit-level operations and kernel-checked irreducibility proofs. - `ArrayAlgebra.dot_eq_sum` and `roundMessage_eq_sum` prove that the actual array reductions and mutable message loop compute bounded finite sums, including their original min-length and default-index semantics. - `message_eval`, `roundMessage_cube`, `foldLane_cube` and `honest_round_cube` connect those actual executable definitions to `compactRound`, `roundConstant`, `roundQuadratic`, `foldFirst` and the existing generic `honest_round`, with an explicit equivalence for the remaining Boolean coordinates. @@ -48,29 +48,57 @@ The operational kernels are now polymorphic over their minimal operations, and t - `ArrayLayout` proves actual array rotation versus `Layout.terminalPoint`, actual `getD` padding and base-encoder leaf reversal versus the list specification, and exact low/top fold indices and lengths. Oversized `rotatePoint` inputs clamp because `Array.extract` clamps; list rotation wraps. The universal bridge uses `min k size`, while the direct protocol bridge states `k ≤ size`. Padding similarly records that a valid live prefix fits the padded width. - `Protocol.verify` now calls `VerifierState.fold`, `batch` and `checkTerminal` for every algebraic transition. `ReplayRefinement.fold_preserves` and `batch_preserves` prove these exact functions maintain the interpreted array state. `trace_preserves` composes arbitrary numbers of those actual transitions, including block/level changes; `trace_terminal` proves that an honest trace ending in one witness scalar passes the actual Boolean terminal checker. The power-of-two specialization discharges the pairing-shape condition for the protocol's layouts. -The remaining whole-executor bridge is precise. `HonestTrace` generates the honest message/value of each transition from the executable array kernels, but membership of the honest execution of the complete nested `Protocol.prove`/`verify` loops in that relation is not yet proved. Query batches additionally need an executable theorem equating `Protocol.enforced` with the corresponding `dot` against `Concrete.induced` after folding the authenticated oracle. At the final check, `Concrete.mle proof.residual tail` must be connected to the scalar obtained by repeated `foldLow`; this needs the `eqTable` loop's first-coordinate interleaving identity, not merely the existing mathematical MLE theorem. Finally, the generic arithmetic theorems cannot be specialized to E until its exact XOR/reduced-multiplication operations have a proved ring interpretation. These are missing refinement dependencies, not assumed correctness axioms or a claim that `Protocol.verify (Protocol.prove ...)` is already proved. +`OperationalRefinement.verify_ok_iff` identifies successful execution of the actual nested verifier with its checked transition trace. `QueryRefinement` and `BatchingRefinement` discharge the actual authenticated-row/induced-weight identities; `TerminalRefinement` connects the actual residual MLE to successive array folds. The soundness proof follows adversarial, not just honest, executions through these same functions. A universal theorem that the full optimized Rust prover and verifier refine this Lean program is not claimed. ## Intentional differences from original WHIR The implementation commits in K = GF(2^64), challenges in E = GF(2^192), and uses additive domains and the novel polynomial basis. The original multiplicative WHIR folding formulas cannot be copied into characteristic two. Quadratic messages contain only the constant and quadratic coefficient; the linear coefficient is reconstructed as `claim + quadratic`. -There is no commitment-time OOD sample, following Flock. The appropriate security relation is **list binding**, not unique binding. Subsequent OOD claims occur after new commitments. The production protocol sends intro polynomials one message ahead; the interactive executable supplies challenges explicitly rather than claiming to reproduce that byte-level binding order or the concurrent transcript rewrite. +There is no commitment-time OOD sample, following Flock. The appropriate security relation is **list binding**, not unique binding. Subsequent OOD claims occur after new commitments. The production protocol sends intro polynomials one message ahead. `CausalGame` and the checked history/replay modules preserve that causal schedule, including the invisible final tail challenge; strategies cannot inspect future tape coordinates. L0 folds the top witness variables because each interleaved lane is a contiguous stack block. Codeword lane order is reversed, so missing zero-tail lanes become leading zeros in a leaf. Only the live suffix is transported. Caller-coordinate rotation must not be applied to per-level induced weights. -Queries are sampled with replacement in binary-sized stratified groups. They are not iid uniform columns and are not deduplicated. Independent raw chunks give independent draws *within their assigned cosets*; `QuerySoundness` proves the product/AM-GM inequality and repeated-coset exponent accounting. The theorem does not prove independence of the concrete transcript's squeezes. `Soundness.conditioned_bound` retains the permitted-tape denominator for grinding rather than treating grinding-conditioned randomness as unconditioned uniform randomness. +Queries are sampled with replacement in binary-sized stratified groups. They are not iid uniform columns and are not deduplicated. The sampling proofs derive the exact finite distribution from uniform raw E chunks, including chunk sharing, unused bits and repeated cosets. Random-oracle compilation counts every allocation and final completion. The advertised numerical bounds are deliberately **unground**: no proof-of-work amplification and no numerical 128-bit security claim is made. -Ring switching combines all 64-slice claims by a gamma challenge before drawing the six-stage additive map. Each claim's scale remains inside that map. Claim points need not be prefixes of one another. The family reduction here proves this algebraic requirement, not the full DP24 compiler. +Ring switching combines all 64-slice claims by a gamma challenge before drawing the six-stage additive map. Each claim's scale remains inside that map. Claim points need not be prefixes of one another. `RingPCSGame` proves false original family/point claims lead to either a quantified ring-map/batching event or false transformed WHIR claims, using the same commitment-time K-witness list. `StackWHIRROM` includes gamma, six map challenges and lambda in one initial 8E allocation, not eight independent oracle opportunities. ## Why this formalization approach -The inspected ArkLib revision is [`35ddcaa83f683011f944f58904be779495a5709a`](https://github.com/Verified-zkEVM/ArkLib/tree/35ddcaa83f683011f944f58904be779495a5709a/ArkLib). Its `ProofSystem/Sumcheck/Impl/Representation.lean` separates executable coefficient messages/Horner evaluation from polynomial interpretation and proves `evaluate_eq`. The modern `Interaction/ComputableSoundness.lean` proves an actual executor/adversarial-strategy bound, unlike several legacy admitted wrappers. `Data/CodingTheory/ProximityGenerator/Interleaving.lean` contains a source proof of exact MCA transfer under an explicit seed-cardinality bound, and `ReedSolomon/MutualCorrelatedAgreement/Johnson/Probability.lean` contains Johnson MCA endpoints with certificate hypotheses. These are useful precedents, not imported conclusions here. +The inspected upstream ArkLib revision is [`35ddcaa83f683011f944f58904be779495a5709a`](https://github.com/Verified-zkEVM/ArkLib/tree/35ddcaa83f683011f944f58904be779495a5709a/ArkLib). Its sumcheck implementation separates executable coefficient messages from polynomial interpretation; `Interaction/ComputableSoundness.lean` proves an actual executor/adversarial-strategy bound. Its Reed-Solomon Johnson/MCA infrastructure is now an imported and instantiated dependency, not merely a precedent: `JohnsonMCA`, `JohnsonNumerics` and `JohnsonListNumerics` discharge the required concrete field, agreement-set and numerical hypotheses. -Source inspection also found admitted FRI input/output relations, admitted generic sequential security/RBR contracts, and admitted Fiat-Shamir interfaces. There is no inspected finished WHIR executor/security endpoint to reuse wholesale. Importing ArkLib's umbrella would not establish an admission-free WHIR proof. This project instead reuses Mathlib algebra/root/finite-sum/AM-GM results and directly audits its own dependency chains. ArkLib itself was inspected, not rebuilt or transitively audited by this project. +Dependency auditing found a genuinely false admitted repeated-size `Fin.sumCases` identity: the sizes `[1,1]` provide a kernel-checked counterexample. [ArkLib PR #1297](https://github.com/Verified-zkEVM/ArkLib/pull/1297) removes that unused identity and an unused admitted polynomial-basis placeholder, and repairs the axiom baseline. The pinned fork contains that fix. Other admitted legacy ArkLib interfaces are not silently treated as proofs of WHIR, Merkle security or Fiat-Shamir security; every imported dependency used by a `Whir` theorem is checked transitively by `Audit.lean`. The inspected Ironwood revision is [`86e3c7026db8c9af27ca731e6b5c7f2d8fc7f0fc`](https://github.com/zcash/ironwood/tree/86e3c7026db8c9af27ca731e6b5c7f2d8fc7f0fc/Zcash). `Arithmetic/NatKernelEquiv.lean` uses a representation map instead of an assumed implementation/spec isomorphism. `Arithmetic/FftSpec.lean` decomposes actual FFT refinement into bit reversal, twiddles and rounds. `Arithmetic/FastMsm.lean` uses a proved `csimp` equality rather than an unchecked implementation replacement. `Meta/AxiomCheck.lean`, `TrustBoundary.lean` and `CensusCheck.lean` motivate direct endpoint and elaborated-environment auditing. Ironwood's multiplicative FFT theorem is not an additive-NTT proof for leanVM. +## Security endpoints and crypto games + +`InteractiveSoundness.adaptive_list_binding` proves the actual `CausalGame.AdaptiveListBinding` predicate, not just its definition. For each commitment oracle and lane count it chooses `InitialCandidates.witnesses` before quantifying over public claims and the adversarial strategy. `production_probability` bounds accepted false openings by 2^-73 when the number of public claims is at most 2^64, for every production profile. The candidate list is a mathematical finite list; enumerating it is not required by the executable verifier. + +The proof constructs concrete initial-batching, fold-restoration, OOD/query-restoration and terminal-collision events. `CausalPrefix` and `CausalStrategy` prove that each event depends only on the current challenge and the strictly earlier reply/tape prefix. Field cardinalities, the additive encoder's RS interpretation, Johnson/MCA list size, same-agreement-set transfer, concrete OOD separation, sampling distribution and all numerical side conditions are proved rather than packaged as a missing-soundness premise. + +`TypedOracleCompiler` executes adaptive oracle machines with a private global memo table. Repeated or cloned requests retain their answers; partial projections do not disclose the rest of a sample. Its whole-history completion is causal, and every payoff agrees with the reference oracle execution. At most `B * (K + 1)` challenge allocations are charged for request depth at most `B` and at most `K` adversarial requests, including the final verifier completion. + +`WHIRROM.rom_list_binding_numeric` bounds actual standalone false acceptance by `min 1 (B * (K + 1) * 2^-79)`. `StackWHIRROM.rom_list_binding_numeric` gives `min 1 (B * (K + 1) * (2^-79 + ringCharge cap))` for original stacked family/point claims. Both prove their concrete replay parsing, strict-prefix event correspondence and terminal trace cover; neither asks the caller to assume accepted false openings are covered by bad events. Immutable statement catalogs and root oracles are explicit inputs, not mutable values chosen after a challenge. + +The production checkout used by the main differential harness still has the older keyed step-chain transcript. The separate concrete duplex model targets exactly [open PR #552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). This is a conditional instantiation, not a merge, a waiver of that PR's failing Counts gate, or a DMV claim for the older transcript. + +`DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove actual framing inverses, message/template injection, canonical WHIR history encoding and the structural DMV conditions. `DuplexCompression` implements the actual BLAKE2s compression evaluator. Structural framing correctness is not a proof of the probabilistic DMV theorem. + +`DuplexModeGame` defines real public-compression and ideal raw-random-oracle/simulator games for adaptive direct and construction queries, including auxiliary and verifier work. Its transfer theorems expose two separate assumptions: `PublicRandomCompressionDMV` is the universal view-distinguishing bound for the actual mode and simulator; `ConcretePrimitiveGap` is the separate restricted-adversary gap between deterministic BLAKE2s and a random compression function. These are ordinary crypto games, not a PCS false-acceptance assumption. The external stochastic DMV theorem and a small concrete BLAKE2s advantage are not kernel-proved here. + +### Published checked integration checkpoint + +`WHIRCausalRawROM.raw_table_list_binding` and `WHIRModeReplay.physical_table_list_binding` extend the bound to exact raw mode inputs, causal first-registration state, and physically completed caller/ancestor/final dependencies. The bound is `min 1 ((40 + callerOutputCap) * (K + 1) * (2^-79 + ringCharge cap))`. Allocation labels retain their pre-draw catalogs and root snapshots; a rejected caller entry is recorded separately from an unseen entry and cannot later be replaced by fabricated or valid claims. This theorem still takes a causal resolver. It is not yet the full production caller/source theorem. + +`DuplexPublicSimulator` supplies a concrete public-query-log simulator, exact repeated-input caching, complete mode-input recognition, a checked private-query bound, and reconstruction of actual raw requests from public observations. `WHIRObservableAllocations` reconstructs the chronological allocation cache and dependency annotations from public raw answers and physically returned completion records, without receiving the adversary program, private coins, or a total oracle. `WHIRSourceObserver.publicReplay_actual` proves that a public-only cut of the returned source events equals the private finite-cache prefix replay. Composing this observer with the concrete production caller resolver and complete source acceptance remains in progress. + +`PrunedMerkleProgram` implements the actual flat pruned opener as counted public compression calls, including malformed-proof branches. `PublicMerkleBinding` reduces accepted deviations from first-frozen rows to observed compression collisions or an actual absent compression node hitting a previously fixed target, including final-first multiblock reconstruction. The probability bound for these ordinary Merkle primitive events is not yet part of this checkpoint. + +`SuccinctPointWeight.eqAt_eq_mle`, `SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle`, and `InducedTerminalRefinement.nativeBasisAt_eq_mle` connect the actual plain/strided selectors, shared-prefix ring evaluator, inverse-Frobenius coefficients, and native induced-basis recurrence to their dense meanings. `AccumulatedTerminalRefinement.stack_terminal_equivalence` composes every saved OOD/query context with the rotated original caller point. `WHIRNativeArithmetic.sourceVerify_refines` proves the complete scalar-only native-style verifier loop refines `Protocol.verify`, under explicit public shapes and authenticated-row premises; it does not assume caller-weight or terminal-evaluator equality. `WHIRNativeErasure.nativeVerify_erased` removes only ghost commitment oracles, preserving actual query rows and errors. + +The checkpoint also fixes a Lean L0 extraction discrepancy: authenticate the full padded leaf, discard only its leading absent lanes, and reverse the occupied lanes exactly once at the protocol boundary. Separately executed pruned and full-width regression cases exercised the real parser and hash path. This is a model correction, distinct from the Rust guard fix below. + ## Original papers and version limits - [WHIR, ePrint 2024/1586](https://eprint.iacr.org/2024/1586): substantive full-paper sections read from the November 21, 2024 PDF. Lemma 4.4 is the interleaved Johnson bound; Definition 4.9 defines MCA; Definition 4.14 and Claim 4.15 concern multiplicative folding; Construction 5.1/Theorem 5.2 give conditional RBR soundness. This numbering is not silently attributed to every later proceedings revision. @@ -80,32 +108,39 @@ The inspected Ironwood revision is [`86e3c7026db8c9af27ca731e6b5c7f2d8fc7f0fc`]( - [BCHKS25, ePrint 2025/2055](https://eprint.iacr.org/2025/2055): recovered and read from [ECCC TR25-169](https://eccc.weizmann.ac.il/report/2025/169/download/), title-page November 7, 2025. Corollary 1.4 is ordinary correlated agreement, so Annex B's stronger same-agreement-set adaptation needs its own argument. Theorem 4.6, pages 28-29, is the required list-correlated-agreement statement. Its rate is `(dimension - 1)/block length` and its multiplicity denominator is the Johnson slack, not twice the slack from Theorem 1.5. Section 3.2 explicitly charges content-factor exceptional roots omitted in an older proof. These security conclusions are not imported as Lean axioms here. - [DT24, ePrint 2024/1038](https://eprint.iacr.org/2024/1038): complete author PDF read and [pinned to hosting commit `3c36f36aa545f514a967a4f157e8476ad2be335b`](https://github.com/quangvdao/quangvdao.github.io/blob/3c36f36aa545f514a967a4f157e8476ad2be335b/papers/authored/constraint-packing-binary-tower-fields.pdf), Git blob `58244673916d0f7c7b140c5c936cb1493b3eae5c`. Claim 1 and equations (11)-(13) use basis independence for deterministic coordinate packing; characteristic two alone does not suffice. Algorithm 3's Wiedemann-tower arithmetic is not leanVM's representation. - [LFKN92, primary author manuscript](https://lance.fortnow.com/papers/files/ip.pdf): recovered through a real browser after the reader's HTTP 406; full protocol/security sections read. Rendered pages 3-4 confirm Theorem 1 (interactive proofs for P raised to a #P oracle), Lemma 3 (reduction to permanent checking), and Lemma 4 (degree-r polynomial agreement bounded by r/p). The manuscript proves the permanent expand/shrink protocol, not a named modern Boolean-cube sumcheck theorem. Its first-escape proof motivates `rbr_composition`; its footnote explicitly distinguishes ideal uniform field sampling from bit-based rejection sampling. +- [DMV18, ToSC 2018(4), pages 197-228](https://tosc.iacr.org/index.php/ToSC/en/article/download/7366/6536/2516), DOI [10.13154/tosc.v2018.i4.197-228](https://doi.org/10.13154/tosc.v2018.i4.197-228): the published original's template-execution model, Definitions 4-6 and 8, Theorem 1, and its random-function simulator/H-coefficient proof in section 5 were read. Theorem 1 counts direct and indirect primitive evaluations and separately bounds the simulator's random-oracle queries. Its probabilistic conclusion remains an explicit external game assumption; the corresponding concrete mode structure is proved in Lean. - [Jo26, ePrint 2026/891](https://eprint.iacr.org/2026/891) and [Gru24](https://eprint.iacr.org/2024/108): full originals remain unavailable after ePrint/publisher, author-site, archive and repository searches. The Jo26 PDF additionally remained behind a Cloudflare security-verification page in a real browser. Jo26 Theorem 4.4 is verified only as a local citation. No unverified original theorem numbering is asserted. The unavailable originals and incomplete revision pins above are explicit research limitations, not claimed completed source readings. SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8d95c310c8deb64e3beac30ce61`; ring switching `e0c9dd03a2e9b4a9c6b88dd3df077db6400668a6e8234b877d046bc60c9949d9`; LFKN `926388d68334bc8cdcd586c70f0b97b2b7e957fe0f360858f4574e91a36622ab`. The PDFs are research inputs, not vendored dependencies. -## Trust boundary and unproved goals +## Trust boundary and remaining limitations `Audit.lean` discovers every exported theorem in the elaborated `Whir` namespace and computes its transitive axioms. It rejects project axioms and every dependency axiom except `propext`, `Classical.choice` and `Quot.sound`. Selected principal algebra endpoints additionally retain `#print axioms` commands. No `sorry`, `admit`, `native_decide`, unsafe proof execution, or new correctness axiom is used in completed chains. Running the compiled model and Rust still trusts their compilers/runtime; differential testing is evidence for tested inputs, not a kernel proof of their correspondence. -Outstanding proof boundaries are concrete K/E irreducibility and field-law refinement, the optimized additive NTT's universal refinement to the generic encoder, full array/length-checked executable verifier refinement, the concrete ring-map injectivity/error bound, Johnson list size/MCA and OOD-separation instantiation, the complete adaptive WHIR list-binding invariant, transcript-prefix binding, Merkle collision resistance, grinding/Fiat-Shamir compilation, and concrete BLAKE2 random-oracle security. `ListExplains` records a list-opening relation; it is not a theorem that commitments satisfy that relation. `rbr_composition` proves error accumulation from individual escape bounds, not those missing WHIR escape bounds. +The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, complete adaptive interactive list binding, typed and exact-raw oracle bounds, and the native scalar arithmetic refinement described above. The full observable production-source/caller/Merkle composition remains unfinished and is not claimed by this publication checkpoint. The Rust compiler, optimized Rust NTT, universal Rust-to-Lean correspondence, external DMV probability theorem, ordinary Merkle collision/target-hit probability bound, and concrete BLAKE2s idealization remain outside its kernel-proved conclusions. -`ListBinding` makes the security quantifiers explicit: for every commitment there must be a bounded candidate list fixed before every adversarial strategy, with failure probability over the finite uniform randomness tape of a supplied verifier experiment. It is a game definition, not a proved WHIR instance. The abstract strategy and verifier interfaces keep challenge correlations and implementation-specific transcript semantics from being assumed away. +Merkle transport gives a fixed commitment-time row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. Concrete CPU/recursion caller decoding, production placement construction, and the physical source driver are being integrated separately; their unfinished files are not included in this checked checkpoint. -Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte-decoding error taxonomy or underflow behavior as production `TranscriptError`. The Rust smoke separately uses the actual stack-opening prover/verifier and its malformed/tampered inputs. No byte-for-byte full transcript refinement is claimed. +Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte-decoding error taxonomy or underflow behavior as production `TranscriptError`. The Rust smoke separately uses the actual stack-opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte-for-byte theorem for the older keyed transcript is claimed. -No production bug is established merely by disagreement with a hand port. Findings must first distinguish model errors, supported-input contracts and genuine Rust discrepancies. This verification addition does not modify production Rust, Python, recursion verifiers, protocol versions, or the LaTeX specification. +Verification found and fixed a Lean model evaluation-order bug: a malformed public weight reached batching before its shape guard and emitted a runtime out-of-bounds diagnostic despite returning rejection. The guard now runs before batching; the maintained executable smoke and runner's stderr check cover it. No production Rust discrepancy follows from that model bug. ## Exercised validation -The delivered branch passed `lake build --wfail` and the elaborated axiom census: every discovered theorem declaration, including generated equations and auxiliary proofs, depended only on the three permitted standard axioms. The protocol properties are enumerated above rather than counting generated declarations as independently substantial results. +The dependency-closed publication checkpoint passed `lake build --wfail +Whir:olean +Main:olean` and the consolidated `lake env lean Audit.lean` census, with only `propext`, `Classical.choice` and `Quot.sound` permitted. Executing `lake env lean --run Main.lean` exercised the honest multilevel opening and its malformed/tampered rejection paths. The build also executed the maintained scalar-verifier, accumulated-terminal, public-simulator and backfill regressions. These are fresh checkpoint checks; the live Rust differential observations below were obtained separately, not rerun during publication. + +A separate executable public-observer smoke captured a pre-query commitment while excluding a reply-derived commitment until its raw answer became available, matched public and private causal prefixes, and confirmed that a source chronology error remains rejected after a later commitment. The protocol properties are enumerated above rather than counting generated declarations as independently substantial results. The live differential runner matched 71 record groups: 15 arithmetic/encoding/folding/weight groups plus all 56 production configurations. Six additional production query batches covered `(depth,count)` = `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`, including cross-limb extraction, uneven groups and repeated queries. Lean's three-level opening accepted and rejected wrong targets, short openings/final residuals, changed final residuals, missing queries, changed rows, changed/missing OOD answers, missing challenges and invalid layouts. Rust's real minimum-size stacked opening exercised ring-switch and point claims, truncated lanes, Merkle authentication, Fiat-Shamir and grinding; it rejected short/trailing streams, changed round/OOD/final scalars, missing authentication and invalid layouts. A separate executed refinement smoke over `ZMod 2 × ZMod 2` used non-Boolean ring challenges through two actual top-lane folds, an actual level batch and an actual low fold. It observed the preserved dot/message invariants, a nonzero final scalar `(1, 0)`, acceptance by the actual terminal checker, and rejection after changing its claim. This exercises the shared polymorphic definitions rather than substituting a copied specification. -The standalone Rust harness also passed release Clippy with warnings denied and rustdoc with warnings denied. Its Rust code was formatted; the Python runner passed Ruff and `ty`. No production Rust or Python verifier was changed, so full VM suites, Python verifier conformance suites, guest fixture rebuilds and LaTeX builds were intentionally not run. +Additional scoped executable checks exercised actual causal honest and false claims, malformed public weights, missing authenticated rows, invisible-final-tail independence, strict reply-prefix replay and absent-slot defaults without runtime diagnostics. Actual typed-oracle runs exercised clones, partial projections, cache hits and final completion. A stacked run allocated groups `[8,1,1]`, retained shared gamma/lambda projections, reconstructed the original family weights and rejected a malformed final proof. + +The pinned #552 duplex evaluator matched 37 independently executed Rust state/API fixture records, including the actual BLAKE2s known-answer paths. Flat Merkle transport matched 27 Rust/Lean records over 14 accepted/rejected cases and exercised 13 raw occurrence paths; separate registry checks covered immutable first registration and later batched openings. These are scoped execution observations, not universal Rust refinement theorems. + +The standalone Rust harness previously passed release Clippy and rustdoc with warnings denied, and its Python runner passed Ruff and `ty`. This proof PR changes no production verifier or guest fixtures. Its original baseline includes a Python verifier; the freshly fetched upstream used for the separate fix below no longer does. -No Rust discrepancy was found in this explored scope. That statement is not a proof that untested inputs or the Rust protocol are correct, and no speculative bug-fix PR is warranted. +The native-selector equivalence work also found a confirmed Rust library discrepancy, fixed separately in [PR #565](https://github.com/leanEthereum/leanVM/pull/565): malformed plain/strided offsets or an oversized strided slot were accepted with independently checked wrong slice values because the succinct selectors discarded those bits. The release regression failed for all three cases before the fix. Afterward, five stacked-opening tests, the native/recursive smallest-opening test, and an independent public-API commitment/open/verify executable passed. This is an existing public metadata-contract violation, not a demonstrated production VM proof exploit. Valid proof encodings and transcript domains are unchanged. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index 82ddeb1c9..de66ff4c3 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -9,3 +9,133 @@ import Whir.Protocol import Whir.ArrayLayout import Whir.ArrayAlgebra import Whir.ReplayRefinement +import Whir.AcceptedShapes +import Whir.AdditiveBasis +import Whir.AdditiveCode +import Whir.AdditiveColumn +import Whir.AdditiveNormalization +import Whir.BaseCandidateDescent +import Whir.BatchingRefinement +import Whir.ByteCodec +import Whir.CandidateFolding +import Whir.CausalBadEvents +import Whir.CausalBoundary +import Whir.CausalExecution +import Whir.CausalFolds +import Whir.CausalGame +import Whir.CausalInitial +import Whir.CausalPositions +import Whir.CausalPrefix +import Whir.CausalProbability +import Whir.CausalRefinement +import Whir.CausalStateCausality +import Whir.CausalStrategy +import Whir.CausalTerminal +import Whir.CodingBounds +import Whir.ConcreteCandidates +import Whir.DuplexCompression +import Whir.DuplexEncoding +import Whir.DuplexFraming +import Whir.DuplexModeGame +import Whir.DuplexRefinement +import Whir.ExecutableOOD +import Whir.ExecutionShapes +import Whir.FiatShamirGame +import Whir.FieldCardinality +import Whir.FieldConjugates +import Whir.FieldEmbedding +import Whir.FieldEquality +import Whir.FieldEquivalence +import Whir.FieldExtension +import Whir.FieldFinite +import Whir.FieldInverse +import Whir.FieldIrreducible +import Whir.FieldModel +import Whir.FieldTower +import Whir.FoldSoundness +import Whir.GroupedChallenges +import Whir.InitialBatching +import Whir.InitialCandidates +import Whir.InitialSoundness +import Whir.InteractiveSoundness +import Whir.JohnsonListNumerics +import Whir.JohnsonMCA +import Whir.JohnsonNumerics +import Whir.LevelBoundary +import Whir.MerkleBinding +import Whir.MerkleLevels +import Whir.MerkleTransport +import Whir.MutualAgreement +import Whir.OODBounds +import Whir.OperationalRefinement +import Whir.OracleReplay +import Whir.ParameterBounds +import Whir.ProductionTransitions +import Whir.QueryBatchSoundness +import Whir.QueryRefinement +import Whir.RingMapBatching +import Whir.RingMapBatchingConcrete +import Whir.RingMapConcrete +import Whir.RingMapInjectivity +import Whir.RingMapSoundness +import Whir.RingPCSGame +import Whir.SamplingProbability +import Whir.SamplingRefinement +import Whir.StackWHIRROM +import Whir.StackWHIRReplay +import Whir.StratifiedDensity +import Whir.TapeValidity +import Whir.TerminalRefinement +import Whir.TerminalSoundness +import Whir.TypedFiatShamirGame +import Whir.TypedOracleCompiler +import Whir.VerifierInvariant +import Whir.WHIRFiatShamir +import Whir.WHIRHistory +import Whir.WHIRHistoryKey +import Whir.WHIRROM +import Whir.WHIRReplay +import Whir.RawWHIRKeys +import Whir.StackWHIRCodec +import Whir.DuplexRawProgram +import Whir.CausalAllocationLabels +import Whir.CausalBindingState +import Whir.RawOracleCoupling +import Whir.RawOracleProvenance +import Whir.WHIRCallerOutputs +import Whir.WHIRCallerPrefix +import Whir.WHIRCallerShape +import Whir.WHIRRawReplay +import Whir.WHIRRawHistory +import Whir.WHIRRawROM +import Whir.WHIRCausalRawROM +import Whir.WHIRSnapshotReplay +import Whir.WHIRModeProgram +import Whir.WHIRModeFinal +import Whir.WHIRModeReplay +import Whir.WHIRPublicBackfill +import Whir.WHIRObservableAllocations +import Whir.DuplexPublicSimulator +import Whir.PublicMerkleLog +import Whir.PublicMerkleBinding +import Whir.PublicMerkleProgram +import Whir.PrunedMerkleProgram +import Whir.WHIRPhysicalRows +import Whir.WHIRPhysicalHistory +import Whir.WHIRPhysicalErasure +import Whir.WHIRPowProgram +import Whir.WHIRNativeGuards +import Whir.InducedTerminalRefinement +import Whir.SuccinctPointWeight +import Whir.SuccinctRingWeight +import Whir.SuccinctRingCoefficients +import Whir.SuccinctRingGroups +import Whir.InitialTerminalRefinement +import Whir.AccumulatedTerminalAlgebra +import Whir.AccumulatedTerminalRefinement +import Whir.AccumulatedTerminalRegression +import Whir.WHIRNativeArithmetic +import Whir.WHIRNativeArithmeticRegression +import Whir.WHIRNativeErasure +import Whir.WHIRSourceChronology +import Whir.WHIRSourceObserver diff --git a/verification/whir/Whir/AcceptedShapes.lean b/verification/whir/Whir/AcceptedShapes.lean new file mode 100644 index 000000000..2ff6ca4e5 --- /dev/null +++ b/verification/whir/Whir/AcceptedShapes.lean @@ -0,0 +1,142 @@ +import Whir.ExecutionShapes +import Whir.LevelBoundary + +/-! Actual accepted shape checks connect commitment-fixed candidates to the +operational oracle at every level and to the one-lane close invariant. -/ +namespace Whir.AcceptedShapes +open Concrete Protocol CausalGame CausalExecution ExecutionShapes ParameterBounds +open CandidateFolding VerifierInvariant + +/-- Even an empty public-claim array is subject to the actual initialized lane guard. -/ +theorem accepted_lane_bound (input : Public) (strategy : Strategy) (tape : Tape input.config) + (accepted : experiment input strategy tape = true) : + input.lanes ≤ 2 ^ input.config.folds[0]! := by + have h := (initialize_success _ _ _ _ _ _ _ _ + (accepted_execution input strategy tape accepted).1).1 + simp only [shapeValid, Bool.and_eq_true, decide_eq_true_eq, beq_iff_eq] at h + exact h.1.1.2 + +/-- These are the precise immutable leaf lengths checked by the actual verifier. -/ +theorem accepted_oracle (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (i : Fin (config p).folds.size) : + oracleValid (levelAt (Input p lanes root claims) strategy tape i).oracle (length (config p) i) + (if i.val == 0 then lanes else 2 ^ (config p).folds[i.val]!) = true := by + by_cases zero : i.val = 0 + · have valid := (initialize_success _ _ _ _ _ _ _ _ + (accepted_execution (Input p lanes root claims) strategy tape accepted).1).2.1 + simpa [zero, initial, length, (InitialCandidates.production_initial_facts p).1] + using valid + · let j := i.val - 1 + have ji : j + 1 = i.val := by dsimp [j]; omega + have hj : j < (config p).folds.size := by omega + have hnext : j + 1 < (config p).folds.size := by omega + have checked := accepted_level (Input p lanes root claims) strategy tape accepted j hj + have boundary := boundary_shape (config p) (challenges (config p) tape) + (proof (Input p lanes root claims) strategy tape) j _ _ checked + dsimp only at boundary + rw [← foldAt_end (Input p lanes root claims) strategy tape j hj] at boundary + have ended := (foldAt_shape p lanes root claims strategy tape ⟨j, hj⟩ + (config p).folds[j]! le_rfl).1 + simp only [Nat.sub_self, Nat.add_zero] at ended + rw [ended] at boundary + simp [ji] at boundary + rw [← getElem!_pos (config p).folds i.val i.isLt] at boundary + have dims := production_before p i + have previous : remaining (config p) j = remaining (config p) i + (config p).folds[i.val]! := by + rw [← before_succ, ji] + exact dims + have subdim : remaining (config p) j - (config p).folds[i.val]! = remaining (config p) i := by omega + rw [subdim] at boundary + have oracle : (levelAt (Input p lanes root claims) strategy tape i).oracle = + (proof (Input p lanes root claims) strategy tape).levels[j]!.nextOracle.getD #[] := by + rw [← ji, levelAt_succ] + rfl + rw [oracle] + simpa only [show (i.val == 0) = false from by simp [zero], Bool.false_eq_true, ↓reduceIte, length] + using boundary.2 + +/-- Reversed base leaves may be pruned; extension leaves have the full configured width. -/ +theorem accepted_leaf_bound (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (i : Fin (config p).folds.size) (q : Fin (length (config p) i)) : + ((levelAt (Input p lanes root claims) strategy tape i).oracle[q.val]!).size ≤ + 2 ^ (config p).folds[i.val]! := by + have shape := OracleReplay.oracleValid_row _ _ _ + (accepted_oracle p lanes root claims strategy tape accepted i) q.val q.isLt + by_cases zero : i.val = 0 + · have bound := accepted_lane_bound (Input p lanes root claims) strategy tape accepted + have live : ((levelAt (Input p lanes root claims) strategy tape i).oracle[q.val]!).size = lanes := by + simpa [zero] using shape + simpa only [zero] using live.le.trans bound + · simpa only [show (i.val == 0) = false from by simp [zero], Bool.false_eq_true, ↓reduceIte] + using shape.le + +/-- A completed arbitrary-oracle fold is exactly the singleton-row oracle used by the query kernel. -/ +theorem terminal_candidates (base : Bool) (k n rate threshold : Nat) (root : Oracle) + (folds : Array E) (count : folds.size = k) + (live : ∀ q : Fin (2 ^ (n + rate)), root[q.val]!.size ≤ 2 ^ k) : + arrayCandidates base (concreteEncoder n rate) (OracleReplay.oracleAt base k root folds k) threshold = + arrayCandidates base (concreteEncoder n rate) + (fun _ : Fin 1 => fun q => OracleReplay.postfoldWord base root folds q.val) threshold := by + subst k + have cast : 1 = 2 ^ (folds.size - folds.size) := by simp + have reindex := OracleReplay.arrayCandidates_cast cast base (concreteEncoder n rate) + (OracleReplay.oracleAt base folds.size root folds folds.size) threshold + have columns : (fun lane : Fin 1 => OracleReplay.oracleAt base folds.size root folds folds.size + (Fin.cast cast lane)) = (fun _ : Fin 1 => fun q : Fin (2 ^ (n + rate)) => + OracleReplay.postfoldWord base root folds q.val) := by + funext lane q + exact OracleReplay.oracleAt_terminal base root folds q (live q) (Fin.cast cast lane) + rw [columns] at reindex + exact reindex.symm + +/-- Accepted physical layouts discharge the exact close-invariant premise used by the query theorem. -/ +theorem closeLost_of_terminal_lost (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (i : Fin (config p).folds.size) + (lost : Lost (foldCandidates (Input p lanes root claims) strategy tape i (config p).folds[i.val]!) + (foldAt (Input p lanes root claims) strategy tape i (config p).folds[i.val]!).state) : + LevelBoundary.CloseLost (remaining (config p) i) (config p).rates[i.val]! + (threshold (config p) i) + (fun q => OracleReplay.postfoldWord (i.val == 0) + (levelAt (Input p lanes root claims) strategy tape i).oracle + (challenges (config p) tape).levels[i.val]!.folds q.val) + (foldAt (Input p lanes root claims) strategy tape i (config p).folds[i.val]!).state := by + unfold foldCandidates at lost + rw [terminal_candidates _ _ _ _ _ _ _ (TapeValidity.level_shapes _ tape i i.isLt).1 + (accepted_leaf_bound p lanes root claims strategy tape accepted i)] at lost + exact LevelBoundary.closeLost_of_lost (i.val == 0) _ _ _ _ _ lost + +/-- The initial operational list is literally the commitment-fixed extension list, including pruned base lanes. -/ +theorem initial_candidates (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) + (valid : oracleValid (liftRoot root) (length (config p) 0) lanes = true) : + foldCandidates (Input p lanes root claims) strategy tape 0 0 = + InitialCandidates.extensionCandidates (config p) lanes root := by + have remaining0 := (InitialCandidates.production_initial_facts p).1 + have rootSize : root.size = length (config p) 0 := by + have h := valid + simp only [oracleValid, Bool.and_eq_true, beq_iff_eq] at h + simpa [liftRoot] using h.1 + change arrayCandidates true (concreteEncoder (remaining (config p) 0) (config p).rates[0]!) + (OracleReplay.oracleAt true (config p).folds[0]! (liftRoot root) + (challenges (config p) tape).levels[0]!.folds 0) (threshold (config p) 0) = _ + rw [remaining0] + unfold InitialCandidates.extensionCandidates + congr 1 + funext lane q + have hq : q.val < root.size := by + rw [rootSize] + simpa only [length, remaining0] using q.isLt + have hrow := OracleReplay.oracleValid_row (liftRoot root) (length (config p) 0) lanes valid + q.val (by simpa only [← rootSize] using hq) + have shape : root[q.val]!.size = lanes := by + simpa [liftRoot, getElem!_pos, hq] using hrow + exact OracleReplay.initial_fullRow (config p) lanes root + (challenges (config p) tape).levels[0]!.folds q hq shape lane + +end Whir.AcceptedShapes diff --git a/verification/whir/Whir/AccumulatedTerminalAlgebra.lean b/verification/whir/Whir/AccumulatedTerminalAlgebra.lean new file mode 100644 index 000000000..bfc7b98bf --- /dev/null +++ b/verification/whir/Whir/AccumulatedTerminalAlgebra.lean @@ -0,0 +1,170 @@ +import Whir.BatchingRefinement +import Whir.TerminalRefinement + +namespace Whir.AccumulatedTerminalAlgebra +open Concrete Protocol ArrayLayout ArrayAlgebra TerminalRefinement +open scoped BigOperators +variable {R : Type*} [CommRing R] [Inhabited R] + +theorem mle_weightGlue (b other point : Array R) (s : R) + (hb : b.size = 2 ^ point.size) (ho : other.size = b.size) : + Concrete.mle (weightGlue b other s) point = + Concrete.mle b point + s * Concrete.mle other point := by + simp only [Concrete.mle, dot_eq_sum, size_weightGlue, size_eqTable, hb, ho, min_self] + rw [Finset.mul_sum, ← Finset.sum_add_distrib] + apply Finset.sum_congr rfl + intro i hi + rw [weightGlue, getElem!_tab _ _ _ (by simpa [hb] using Finset.mem_range.mp hi)] + ring + +theorem mle_scale (a point : Array R) (s : R) : + Concrete.mle (a.map (s * ·)) point = s * Concrete.mle a point := by + simp only [Concrete.mle, dot_eq_sum, Array.size_map, Finset.mul_sum] + apply Finset.sum_congr rfl + intro i hi + have h : i < a.size := (Finset.mem_range.mp hi).trans_le (Nat.min_le_left ..) + simp [getElem!_pos, h, mul_assoc] + +theorem foldLow_eqTable_cons [CharP R 2] (z r : R) (zs : Array R) : + foldLow (eqTable (#[z] ++ zs)) r = (eqTable zs).map ((1 + z + r) * ·) := by + apply Array.ext + · simp [pow_succ, Nat.add_comm] + · intro i hi hi' + have h : i < 2 ^ zs.size := by simpa using hi' + have hz := eqTable_cons_get z zs i h + suffices hh : (foldLow (eqTable (#[z] ++ zs)) r)[i]! = + ((eqTable zs).map ((1 + z + r) * ·))[i]! by + simpa only [getElem!_pos, hi, hi'] using hh + rw [foldLow, getElem!_tab _ _ _ (by simpa only [size_foldLow] using hi), hz.1, hz.2] + simp only [getElem!_pos, h, size_eqTable, Array.size_map, Array.getElem_map, foldPair] + ring_nf + simp [CharTwo.two_eq_zero] + +def equalityProduct (z point : List R) : R := + ((z.zip point).map fun (a, b) => 1 + a + b).prod + +theorem mle_eqTable [CharP R 2] (z point : List R) (h : z.length = point.length) : + Concrete.mle (eqTable z.toArray) point.toArray = equalityProduct z point := by + induction z generalizing point with + | nil => + have hp : point = [] := by simpa using h.symm + subst point + simp [equalityProduct, mle_empty, eqTable_empty] + | cons z zs ih => + cases point with + | nil => simp at h + | cons r rs => + have he : zs.length = rs.length := by simpa using h + rw [show (z :: zs).toArray = #[z] ++ zs.toArray by simp, + show (r :: rs).toArray = #[r] ++ rs.toArray by simp] + rw [mle_cons _ _ _ (by simp [he]), foldLow_eqTable_cons, mle_scale] + rw [ih rs he] + simp [equalityProduct] + +inductive Step (R : Type*) where + | fold (r : R) + | glue (weight : Array R) (beta : R) + +def challenges : List (Step R) → List R + | [] => [] + | .fold r :: xs => r :: challenges xs + | .glue _ _ :: xs => challenges xs + +def runDense : List (Step R) → Array R → Array R + | [], b => b + | .fold r :: xs, b => runDense xs (foldLow b r) + | .glue w beta :: xs, b => runDense xs (weightGlue b w beta) + +def Valid : List (Step R) → Nat → Prop + | [], _ => True + | .fold _ :: xs, n => Valid xs n + | .glue w _ :: xs, n => w.size = 2 ^ ((challenges xs).length + n) ∧ Valid xs n + +/-- The term inserted now is evaluated at precisely the future low-coordinate +suffix. No level-local coordinate permutation occurs. -/ +def contributions (tail : List R) : List (Step R) → R + | [] => 0 + | .fold _ :: xs => contributions tail xs + | .glue w beta :: xs => + beta * Concrete.mle w ((challenges xs) ++ tail).toArray + contributions tail xs + +theorem runDense_size (xs : List (Step R)) (b : Array R) (n : Nat) + (hb : b.size = 2 ^ ((challenges xs).length + n)) : + (runDense xs b).size = 2 ^ n := by + induction xs generalizing b with + | nil => simpa [runDense, challenges] using hb + | cons x xs ih => + cases x with + | fold r => + apply ih + simp only [challenges, List.length_cons] at hb + simp only [size_foldLow, hb] + rw [show (challenges xs).length + 1 + n = ((challenges xs).length + n) + 1 by omega, + pow_succ, Nat.mul_div_left _ (by decide : 0 < 2)] + | glue w beta => exact ih _ (by simpa [challenges] using hb) + +theorem accumulated (xs : List (Step R)) (b : Array R) (tail : List R) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length)) (hv : Valid xs tail.length) : + Concrete.mle (runDense xs b) tail.toArray = + Concrete.mle b ((challenges xs) ++ tail).toArray + contributions tail xs := by + induction xs generalizing b with + | nil => simp [runDense, challenges, contributions] + | cons x xs ih => + cases x with + | fold r => + have hs : (foldLow b r).size = 2 ^ ((challenges xs).length + tail.length) := by + simp only [challenges, List.length_cons] at hb + simp only [size_foldLow, hb] + rw [show (challenges xs).length + 1 + tail.length = + ((challenges xs).length + tail.length) + 1 by omega, + pow_succ, Nat.mul_div_left _ (by decide : 0 < 2)] + rw [runDense, ih _ hs hv] + simp only [challenges, List.cons_append, contributions] + rw [show (r :: (challenges xs ++ tail)).toArray = + #[r] ++ (challenges xs ++ tail).toArray by simp] + rw [mle_cons _ _ _ (by simpa [challenges, Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using hb)] + | glue w beta => + obtain ⟨hw, hv⟩ := hv + rw [runDense, ih _ (by simpa [challenges] using hb) hv] + rw [mle_weightGlue _ _ _ _ (by simpa [challenges] using hb) + (by simpa [challenges] using hw.trans hb.symm)] + simp only [challenges, contributions, add_assoc] + +structure Saved (R : Type*) where + risStart : Nat + weight : Array R + beta : R + +def save : List (Step R) → Nat → List (Saved R) + | [], _ => [] + | .fold _ :: xs, start => save xs (start + 1) + | .glue w beta :: xs, start => ⟨start, w, beta⟩ :: save xs start + +def evalSaved (saved : List (Saved R)) (point : List R) : R := + (saved.map fun s => s.beta * Concrete.mle s.weight (point.drop s.risStart).toArray).sum + +theorem save_chronology (xs : List (Step R)) (pre tail : List R) : + evalSaved (save xs pre.length) (pre ++ challenges xs ++ tail) = contributions tail xs := by + induction xs generalizing pre with + | nil => simp [save, evalSaved, contributions] + | cons x xs ih => + cases x with + | fold r => + simpa [save, challenges, contributions, List.append_assoc] using ih (pre ++ [r]) + | glue w beta => + simp only [save, evalSaved, List.map_cons, List.sum_cons, challenges, contributions] + rw [show (pre ++ challenges xs ++ tail).drop pre.length = challenges xs ++ tail by + rw [List.append_assoc, List.drop_left]] + exact congrArg (beta * Concrete.mle w (challenges xs ++ tail).toArray + ·) (ih pre) + +theorem terminal (xs : List (Step R)) (b : Array R) + (hb : b.size = 2 ^ (challenges xs).length) (hv : Valid xs 0) : + (runDense xs b)[0]! = Concrete.mle b (challenges xs).toArray + + evalSaved (save xs 0) (challenges xs) := by + have h := accumulated xs b [] (by simpa using hb) hv + rw [mle_empty _ (by simpa using runDense_size xs b 0 (by simpa using hb))] at h + simp only [List.append_nil] at h + rw [← save_chronology xs [] []] at h + simpa using h + +end Whir.AccumulatedTerminalAlgebra diff --git a/verification/whir/Whir/AccumulatedTerminalRefinement.lean b/verification/whir/Whir/AccumulatedTerminalRefinement.lean new file mode 100644 index 000000000..be5efd874 --- /dev/null +++ b/verification/whir/Whir/AccumulatedTerminalRefinement.lean @@ -0,0 +1,675 @@ +import Whir.AccumulatedTerminalAlgebra +import Whir.InducedTerminalRefinement +import Whir.InitialTerminalRefinement +import Whir.SuccinctRingGroups + +namespace Whir.AccumulatedTerminalRefinement +open Concrete Protocol ArrayLayout TerminalRefinement +open AccumulatedTerminalAlgebra + +/-- Saved contexts retain native source data, never a dense weight table. -/ +inductive Basis where + | ood (z : Array E) + | query (n : Nat) (queries : Array Nat) (lambda : E) + deriving Repr + +def Basis.dense : Basis → Array E + | .ood z => eqTable z + | .query n qs lambda => induced n qs (powers lambda qs.size) + +def Basis.native : Basis → List E → E + | .ood z, point => equalityProduct z.toList point + | .query n qs lambda, point => + InducedTerminalRefinement.nativeBasisAt n qs (powers lambda qs.size) point.toArray + +def Basis.Shape : Basis → Nat → Prop + | .ood z, n => z.size = n + | .query m _ _, n => m = n ∧ m ≤ 64 + +def Basis.dimension : Basis → Nat + | .ood z => z.size + | .query n _ _ => n + +theorem Basis.dimension_eq (b : Basis) (n : Nat) (h : b.Shape n) : b.dimension = n := by + cases b with + | ood z => exact h + | query m qs lambda => exact h.1 + +theorem Basis.size_dense (b : Basis) (n : Nat) (h : b.Shape n) : b.dense.size = 2 ^ n := by + cases b with + | ood z => simp only [Basis.dense, size_eqTable]; rw [h] + | query m qs lambda => + simp [Basis.dense, induced, inducedColumns, show m = n from h.1] + +theorem Basis.native_eq_mle (b : Basis) (point : List E) (h : b.Shape point.length) : + b.native point = Concrete.mle b.dense point.toArray := by + cases b with + | ood z => + exact (mle_eqTable z.toList point (by simpa [Basis.Shape] using h)).symm + | query n qs lambda => + exact InducedTerminalRefinement.nativeBasisAt_eq_mle n qs (powers lambda qs.size) point.toArray + h.2 (BatchingRefinement.size_powers ..) (by simpa using h.1.symm) + +inductive Step where + | fold (r : E) + | glue (basis : Basis) (beta : E) + deriving Repr + +def Step.dense : Step → AccumulatedTerminalAlgebra.Step E + | .fold r => .fold r + | .glue b beta => .glue b.dense beta + +def challenges : List Step → List E + | [] => [] + | .fold r :: xs => r :: challenges xs + | .glue _ _ :: xs => challenges xs + +def runDense (xs : List Step) (b : Array E) : Array E := + AccumulatedTerminalAlgebra.runDense (xs.map Step.dense) b + +def Valid : List Step → Nat → Prop + | [], _ => True + | .fold _ :: xs, n => Valid xs n + | .glue b _ :: xs, n => b.Shape ((challenges xs).length + n) ∧ Valid xs n + +def contributions (tail : List E) : List Step → E + | [] => 0 + | .fold _ :: xs => contributions tail xs + | .glue b beta :: xs => beta * b.native (challenges xs ++ tail) + contributions tail xs + +structure Saved where + risStart : Nat + basis : Basis + beta : E + deriving Repr + +def save : List Step → Nat → List Saved + | [], _ => [] + | .fold _ :: xs, start => save xs (start + 1) + | .glue b beta :: xs, start => ⟨start, b, beta⟩ :: save xs start + +/-- The succinct verifier's logical retained state: challenges plus +native contexts, without any dense weight array. -/ +structure SourceState where + ris : List E + saved : List Saved + deriving Repr + +def SourceState.step (s : SourceState) : Step → SourceState + | .fold r => { s with ris := s.ris ++ [r] } + | .glue b beta => { s with saved := s.saved ++ [⟨s.ris.length, b, beta⟩] } + +def record (xs : List Step) (s : SourceState) : SourceState := xs.foldl SourceState.step s + +/-- Proves the incremental source append operations produce the exact saved +context construction used by the terminal theorem, from any initial prefix. -/ +theorem record_chronology (xs : List Step) (s : SourceState) : + record xs s = ⟨s.ris ++ challenges xs, s.saved ++ save xs s.ris.length⟩ := by + induction xs generalizing s with + | nil => cases s; simp [record, challenges, save] + | cons x xs ih => + change record xs (s.step x) = _ + rw [ih] + cases x <;> simp [SourceState.step, challenges, save, List.append_assoc] + +/-- The point is the unrotated global suffix at the saved `ris_start`. +A terminal residual point is appended exactly once, before dropping the prefix. -/ +def nativeSaved (saved : List Saved) (ris tail : List E) : E := + (saved.map fun s => s.beta * s.basis.native ((ris ++ tail).drop s.risStart)).sum + +theorem save_chronology (xs : List Step) (pre tail : List E) : + nativeSaved (save xs pre.length) (pre ++ challenges xs) tail = contributions tail xs := by + induction xs generalizing pre with + | nil => simp [save, nativeSaved, contributions] + | cons x xs ih => + cases x with + | fold r => + simpa [save, challenges, contributions, List.append_assoc] using ih (pre ++ [r]) + | glue b beta => + simp only [save, nativeSaved, List.map_cons, List.sum_cons, challenges, contributions] + rw [show ((pre ++ challenges xs) ++ tail).drop pre.length = challenges xs ++ tail by + rw [List.append_assoc, List.drop_left]] + exact congrArg (beta * b.native (challenges xs ++ tail) + ·) (ih pre) + +/-- The saved-context invariant is established by the actual append/fold +chronology, rather than required from the physical verifier's caller. -/ +theorem save_valid (xs : List Step) (n start : Nat) (hv : Valid xs n) : + ∀ s ∈ save xs start, + start ≤ s.risStart ∧ s.risStart ≤ start + (challenges xs).length ∧ + s.basis.Shape (start + (challenges xs).length + n - s.risStart) := by + induction xs generalizing start with + | nil => simp [save] + | cons x xs ih => + cases x with + | fold r => + intro s hs + obtain ⟨hlo, hhi, hshape⟩ := ih (start + 1) hv s hs + refine ⟨by omega, by simpa [challenges, Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using hhi, ?_⟩ + simpa [challenges, Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using hshape + | glue b beta => + intro s hs + simp only [save, List.mem_cons] at hs + rcases hs with rfl | hs + · exact ⟨Nat.le_refl _, Nat.le_add_right _ _, by simpa [challenges, Nat.add_assoc] using hv.1⟩ + · exact ih start hv.2 s hs + +/-- Exact source slice length: ris[start .. start + log_msg_cols - tail.len] +followed by the common terminal point, with no local rotation. -/ +theorem saved_suffix (xs : List Step) (pre tail : List E) (hv : Valid xs tail.length) + (s : Saved) (hs : s ∈ save xs pre.length) : + ((pre ++ challenges xs) ++ tail).drop s.risStart = + ((pre ++ challenges xs).drop s.risStart).take (s.basis.dimension - tail.length) ++ tail := by + obtain ⟨_, hstart, hshape⟩ := save_valid xs tail.length pre.length hv s hs + have hdim := s.basis.dimension_eq _ hshape + have hbound : s.risStart ≤ (pre ++ challenges xs).length := by simpa using hstart + have hlen : s.basis.dimension - tail.length = ((pre ++ challenges xs).drop s.risStart).length := by + simp only [List.length_drop, List.length_append] + omega + rw [hlen, List.take_length] + exact List.drop_append_of_le_length hbound + +theorem nativeSaved_source_slices (xs : List Step) (pre tail : List E) + (hv : Valid xs tail.length) : + nativeSaved (save xs pre.length) (pre ++ challenges xs) tail = + ((save xs pre.length).map fun s => s.beta * s.basis.native + (((pre ++ challenges xs).drop s.risStart).take (s.basis.dimension - tail.length) ++ tail)).sum := by + unfold nativeSaved + congr 1 + apply List.map_congr_left + intro s hs + rw [saved_suffix xs pre tail hv s hs] + +@[simp] theorem challenges_dense (xs : List Step) : + AccumulatedTerminalAlgebra.challenges (xs.map Step.dense) = challenges xs := by + induction xs with + | nil => rfl + | cons x xs ih => cases x <;> simp [Step.dense, AccumulatedTerminalAlgebra.challenges, challenges, ih] + +theorem valid_dense (xs : List Step) (n : Nat) (hv : Valid xs n) : + AccumulatedTerminalAlgebra.Valid (xs.map Step.dense) n := by + induction xs with + | nil => trivial + | cons x xs ih => + cases x with + | fold r => exact ih hv + | glue b beta => exact ⟨by simpa using b.size_dense _ hv.1, ih hv.2⟩ + +theorem contributions_dense (xs : List Step) (tail : List E) (hv : Valid xs tail.length) : + AccumulatedTerminalAlgebra.contributions tail (xs.map Step.dense) = contributions tail xs := by + induction xs with + | nil => rfl + | cons x xs ih => + cases x with + | fold r => exact ih hv + | glue b beta => + simp only [List.map_cons, Step.dense, AccumulatedTerminalAlgebra.contributions, + challenges_dense, contributions] + rw [← b.native_eq_mle _ (by simpa using hv.1), ih hv.2] + +/-- Full accumulated dense weight equality, including every OOD and every +query contribution; its only hypotheses are actual shape guards. -/ +theorem accumulated (xs : List Step) (b : Array E) (tail : List E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length)) (hv : Valid xs tail.length) : + Concrete.mle (runDense xs b) tail.toArray = + Concrete.mle b (challenges xs ++ tail).toArray + nativeSaved (save xs 0) (challenges xs) tail := by + have h := AccumulatedTerminalAlgebra.accumulated (xs.map Step.dense) b tail + (by simpa using hb) (valid_dense xs _ hv) + rw [contributions_dense xs tail hv] at h + rw [← save_chronology xs [] tail] at h + simpa [runDense] using h + +theorem terminal (xs : List Step) (b : Array E) + (hb : b.size = 2 ^ (challenges xs).length) (hv : Valid xs 0) : + (runDense xs b)[0]! = Concrete.mle b (challenges xs).toArray + + nativeSaved (save xs 0) (challenges xs) [] := by + have h := accumulated xs b [] (by simpa using hb) hv + rw [mle_empty _ (by simpa [runDense] using + AccumulatedTerminalAlgebra.runDense_size (xs.map Step.dense) b 0 (by simpa using hb))] at h + simpa using h + +/-- Actual post-fold source chronology: OOD coefficients start at lambda, +then the induced query basis is glued with lambda^(ood_count+1). -/ +def oodSteps (oods : Array (Array E)) (lambda : E) : Nat → Nat → List Step + | 0, _ => [] + | count + 1, start => + .glue (.ood oods[start]!) (lambda ^ (start + 1)) :: oodSteps oods lambda count (start + 1) + +def levelBatch (n : Nat) (oods : Array (Array E)) (queries : Array Nat) (lambda : E) : List Step := + oodSteps oods lambda oods.size 0 ++ + [.glue (.query n queries lambda) (lambda ^ (oods.size + 1))] + +def level (folds : Array E) (n : Nat) (oods : Array (Array E)) + (queries : Array Nat) (lambda : E) : List Step := + folds.toList.map Step.fold ++ levelBatch n oods queries lambda + +@[simp] theorem runDense_nil (b : Array E) : runDense [] b = b := rfl +@[simp] theorem runDense_fold (r : E) (xs : List Step) (b : Array E) : + runDense (.fold r :: xs) b = runDense xs (foldLow b r) := rfl +@[simp] theorem runDense_glue (w : Basis) (beta : E) (xs : List Step) (b : Array E) : + runDense (.glue w beta :: xs) b = runDense xs (weightGlue b w.dense beta) := rfl + +theorem runDense_append (xs ys : List Step) (b : Array E) : + runDense (xs ++ ys) b = runDense ys (runDense xs b) := by + induction xs generalizing b with + | nil => rfl + | cons x xs ih => cases x <;> simp only [List.cons_append, runDense_fold, runDense_glue, ih] + +theorem oodSteps_weight (cs : LevelChallenges) (p : LevelProof) + (count start : Nat) (s : VerifierState E) : + runDense (oodSteps cs.oodPoints cs.lambda count start) s.weight = + (runSteps (oodStep cs p) count start (s, cs.lambda ^ start)).1.weight := by + induction count generalizing start s with + | zero => rfl + | succ count ih => + simp only [oodSteps, runDense_glue, Basis.dense, runSteps, oodStep] + rw [pow_succ] + exact ih (start + 1) + (s.batch (eqTable cs.oodPoints[start]!) p.oods[start]!.value + (cs.lambda ^ start * cs.lambda) p.oods[start]!.intro) + +theorem oodSteps_scalar (cs : LevelChallenges) (p : LevelProof) + (count start : Nat) (s : VerifierState E) : + (runSteps (oodStep cs p) count start (s, cs.lambda ^ start)).2 = + cs.lambda ^ (start + count) := by + induction count generalizing start s with + | zero => simp [runSteps] + | succ count ih => + simp only [runSteps, oodStep] + rw [← pow_succ, ih] + congr 1 + omega + +/-- Exactly the weight projection of Protocol's real OOD loop followed by its +query batch, including the scalar carried by that loop. -/ +theorem levelBatch_weight (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : VerifierState E) (h : p.oods.size = cs.oodPoints.size) : + runDense (levelBatch n cs.oodPoints qs cs.lambda) s.weight = + (queryBatch n i cs p qs (oodBatch cs p s)).weight := by + rw [levelBatch, runDense_append, runDense_glue, runDense_nil] + have hw := oodSteps_weight cs p cs.oodPoints.size 0 s + have hs := oodSteps_scalar cs p cs.oodPoints.size 0 s + simp only [pow_zero, Nat.zero_add] at hw hs + change (runSteps (oodStep cs p) cs.oodPoints.size 0 (s, E.one)).2 = + cs.lambda ^ cs.oodPoints.size at hs + simp only [queryBatch, oodBatch, h, VerifierState.batch, Basis.dense] + rw [hw, hs, pow_succ] + rfl + +theorem runDense_folds (rs : List E) (b : Array E) : + runDense (rs.map Step.fold) b = rs.foldl foldLow b := by + induction rs generalizing b with + | nil => rfl + | cons r rs ih => exact ih (foldLow b r) + +theorem foldSteps_weight (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (count start : Nat) (s : CheckedState) : + (runSteps (foldStep block cs p) count start s).state.weight = + (List.range' start count).foldl (fun b j => foldValues b block cs.folds[j]!) s.state.weight := by + induction count generalizing start s with + | zero => rfl + | succ count ih => + simp only [runSteps, List.range'_succ, List.foldl_cons] + exact ih (start + 1) (foldStep block cs p start s) + +/-- The real indexed Protocol loop, not an assumed evaluator identity. -/ +theorem foldBlock_weight (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : CheckedState) : + (foldBlock block cs p s).state.weight = + cs.folds.foldl (fun b r => foldValues b block r) s.state.weight := by + have mapped : (List.range cs.folds.size).map (fun i => cs.folds[i]!) = cs.folds.toList := by + apply List.ext_getElem + · simp + · intro i hi hi' + simp only [List.getElem_map, List.getElem_range, Array.getElem_toList] + simp only [getElem!_pos cs.folds i (by simpa using hi')] + rw [foldBlock, foldSteps_weight, ← List.range_eq_range', ← List.foldl_map, + mapped, Array.foldl_toList] + +theorem foldBlock_weight_lane (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : CheckedState) : + (foldBlock block cs p s).state.weight = + cs.folds.foldl (fun b r => foldLane b block r) s.state.weight := by + rw [foldBlock_weight] + congr 1 + funext b r + simp only [foldValues] + split <;> rename_i h + · have he : block = 1 := by simpa using h + subst block + exact (foldLane_one ..).symm + · rfl + +theorem level_weight (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : CheckedState) (h : p.oods.size = cs.oodPoints.size) : + runDense (level cs.folds n cs.oodPoints qs cs.lambda) s.state.weight = + (queryBatch n i cs p qs (oodBatch cs p (foldBlock 1 cs p s).state)).weight := by + rw [level, runDense_append, runDense_folds, Array.foldl_toList] + have hf := foldBlock_weight 1 cs p s + simp only [foldValues, BEq.rfl, ↓reduceIte] at hf + rw [← hf] + exact levelBatch_weight n i cs p qs _ h + +@[simp] theorem challenges_append (xs ys : List Step) : + challenges (xs ++ ys) = challenges xs ++ challenges ys := by + induction xs with + | nil => rfl + | cons x xs ih => cases x <;> simp [challenges, ih] + +@[simp] theorem challenges_folds (rs : List E) : + challenges (rs.map Step.fold) = rs := by + induction rs with + | nil => rfl + | cons r rs ih => simp [challenges, ih] + +@[simp] theorem challenges_oodSteps (oods : Array (Array E)) (lambda : E) (count start : Nat) : + challenges (oodSteps oods lambda count start) = [] := by + induction count generalizing start with + | zero => rfl + | succ count ih => exact ih (start + 1) + +@[simp] theorem challenges_levelBatch (n : Nat) (oods : Array (Array E)) + (qs : Array Nat) (lambda : E) : challenges (levelBatch n oods qs lambda) = [] := by + simp [levelBatch, challenges] + +@[simp] theorem challenges_level (folds : Array E) (n : Nat) (oods : Array (Array E)) + (qs : Array Nat) (lambda : E) : challenges (level folds n oods qs lambda) = folds.toList := by + simp [level] + +theorem valid_append (xs ys : List Step) (n : Nat) : + Valid (xs ++ ys) n ↔ Valid xs ((challenges ys).length + n) ∧ Valid ys n := by + induction xs with + | nil => simp [Valid] + | cons x xs ih => + cases x <;> simp [Valid, ih, List.length_append, Nat.add_assoc, and_assoc] + +theorem valid_oodSteps (oods : Array (Array E)) (lambda : E) (count start n : Nat) + (bound : start + count ≤ oods.size) + (shape : ∀ j, start ≤ j → j < start + count → oods[j]!.size = n) : + Valid (oodSteps oods lambda count start) n := by + induction count generalizing start with + | zero => trivial + | succ count ih => + constructor + · simpa [Basis.Shape] using shape start (by omega) (by omega) + · exact ih (start + 1) (by omega) (by intro j hj hj'; exact shape j (by omega) (by omega)) + +theorem valid_levelBatch (n : Nat) (oods : Array (Array E)) (qs : Array Nat) (lambda : E) + (hn : n ≤ 64) (ho : ∀ j < oods.size, oods[j]!.size = n) : + Valid (levelBatch n oods qs lambda) n := by + rw [levelBatch, valid_append] + constructor + · simpa [challenges] using valid_oodSteps oods lambda oods.size 0 n + (by omega) (by intro j _ hj; exact ho j (by omega)) + · exact ⟨⟨by simp [challenges], hn⟩, trivial⟩ + +theorem valid_folds (rs : List E) (n : Nat) : Valid (rs.map Step.fold) n := by + induction rs with + | nil => trivial + | cons r rs ih => exact ih + +/-- Source-local dimension guards suffice; callers do not supply a saved-context +invariant or a terminal-evaluator equality. -/ +theorem valid_level (folds : Array E) (n : Nat) (oods : Array (Array E)) + (qs : Array Nat) (lambda : E) (hn : n ≤ 64) + (ho : ∀ j < oods.size, oods[j]!.size = n) : + Valid (level folds n oods qs lambda) n := by + rw [level, valid_append] + exact ⟨valid_folds _ _, valid_levelBatch n oods qs lambda hn ho⟩ + +theorem save_folds (rs : List E) (xs : List Step) (start : Nat) : + save (rs.map Step.fold ++ xs) start = save xs (start + rs.length) := by + induction rs generalizing start with + | nil => simp + | cons r rs ih => + simpa [save, Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using ih (start + 1) + +/-- ris_start is captured after, not before, the current level's folds. -/ +theorem save_level (folds : Array E) (n : Nat) (oods : Array (Array E)) + (qs : Array Nat) (lambda : E) (start : Nat) : + save (level folds n oods qs lambda) start = + save (levelBatch n oods qs lambda) (start + folds.size) := by + simpa [level] using save_folds folds.toList (levelBatch n oods qs lambda) start + +/-- Dense residual polynomial contributes one MLE, not one copy per context. -/ +def nativeTerminal (caller : E) (saved : List Saved) (ris tail : List E) (residual : Array E) : E := + Concrete.mle residual tail.toArray * (caller + nativeSaved saved ris tail) + +theorem residual_terminal (xs : List Step) (b residual : Array E) (tail : List E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length)) (hv : Valid xs tail.length) : + Concrete.mle residual tail.toArray * Concrete.mle (runDense xs b) tail.toArray = + nativeTerminal (Concrete.mle b (challenges xs ++ tail).toArray) + (save xs 0) (challenges xs) tail residual := by + rw [accumulated xs b tail hb hv] + rfl + +/-- End-to-end terminal weight after L0's top-variable folds and any number of +later fold/glue transitions. Only the original caller point rotates. Saved +OOD/query contexts retain offsets in the original, unrotated challenge tape. -/ +theorem initial_accumulated (initial : Array E) (xs : List Step) (b : Array E) + (tail : List E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length + initial.size)) + (hv : Valid xs tail.length) : + Concrete.mle (runDense xs + (initial.foldl (fun b r => foldLane b (2 ^ ((challenges xs).length + tail.length)) r) b)) + tail.toArray = + Concrete.mle b (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray)) + + nativeSaved (save xs initial.size) (initial.toList ++ challenges xs) tail := by + let low := (challenges xs ++ tail).toArray + have hl : low.size = (challenges xs).length + tail.length := by simp [low] + have hshape : (initial.foldl (fun b r => foldLane b (2 ^ low.size) r) b).size = + 2 ^ low.size := by + rw [QueryRefinement.foldLane_blocks b initial (2 ^ low.size) + (by rw [hb, ← hl, pow_add, Nat.mul_comm])] + simp + have h := accumulated xs + (initial.foldl (fun b r => foldLane b (2 ^ low.size) r) b) tail + (by simpa [hl] using hshape) hv + rw [InitialTerminalRefinement.mle_foldLane_initial b initial low (by simpa [hl] using hb)] at h + rw [InitialTerminalRefinement.rotate_initial] + have hsave := save_chronology xs initial.toList tail + have hzero := save_chronology xs [] tail + simp only [Array.length_toList] at hsave + simp only [List.length_nil, List.nil_append] at hzero + rw [hsave] + rw [hzero] at h + simpa [low] using h + +theorem initial_residual_terminal (initial : Array E) (xs : List Step) + (b residual : Array E) (tail : List E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length + initial.size)) + (hv : Valid xs tail.length) : + Concrete.mle residual tail.toArray * + Concrete.mle (runDense xs + (initial.foldl (fun b r => foldLane b (2 ^ ((challenges xs).length + tail.length)) r) b)) + tail.toArray = + nativeTerminal + (Concrete.mle b (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + (save xs initial.size) (initial.toList ++ challenges xs) tail residual := by + rw [initial_accumulated initial xs b tail hb hv] + rfl + +/-- Exactly the source per-context point construction, before either of the +two native context loops evaluates its term. -/ +def Saved.sourcePoint (s : Saved) (ris tail : List E) : List E := + (ris.drop s.risStart).take (s.basis.dimension - tail.length) ++ tail + +def Saved.queryTerm (s : Saved) (ris tail : List E) : E := + match s.basis with + | .query n qs lambda => + s.beta * InducedTerminalRefinement.nativeBasisAt n qs (powers lambda qs.size) + (s.sourcePoint ris tail).toArray + | .ood _ => 0 + +def Saved.oodTerm (s : Saved) (ris tail : List E) : E := + match s.basis with + | .ood z => s.beta * equalityProduct z.toList (s.sourcePoint ris tail) + | .query _ _ _ => 0 + +/-- verify.rs evaluates all LevelCtx terms, then all OodCtx terms, adds the +original caller once, and multiplies by the single residual-polynomial MLE. -/ +def sourceTerminal (caller : E) (saved : List Saved) (ris tail : List E) (residual : Array E) : E := + ((saved.map (fun s => s.queryTerm ris tail)).sum + + (saved.map (fun s => s.oodTerm ris tail)).sum + caller) * + Concrete.mle residual tail.toArray + +theorem source_terms (saved : List Saved) (ris tail : List E) : + (saved.map (fun s => s.beta * s.basis.native (s.sourcePoint ris tail))).sum = + (saved.map (fun s => s.queryTerm ris tail)).sum + + (saved.map (fun s => s.oodTerm ris tail)).sum := by + induction saved with + | nil => simp + | cons s saved ih => + simp only [List.map_cons, List.sum_cons, ih] + have ht : s.beta * s.basis.native (s.sourcePoint ris tail) = + s.queryTerm ris tail + s.oodTerm ris tail := by + cases h : s.basis <;> simp [Saved.queryTerm, Saved.oodTerm, h, Basis.native] + rw [ht] + ac_rfl + +theorem nativeTerminal_eq_sourceTerminal (caller : E) (xs : List Step) + (pre tail : List E) (residual : Array E) (hv : Valid xs tail.length) : + nativeTerminal caller (save xs pre.length) (pre ++ challenges xs) tail residual = + sourceTerminal caller (save xs pre.length) (pre ++ challenges xs) tail residual := by + unfold nativeTerminal + rw [nativeSaved_source_slices xs pre tail hv] + change Concrete.mle residual tail.toArray * + (caller + ((save xs pre.length).map fun s => + s.beta * s.basis.native (s.sourcePoint (pre ++ challenges xs) tail)).sum) = _ + rw [source_terms] + unfold sourceTerminal + ring + +theorem initial_source_terminal (initial : Array E) (xs : List Step) + (b residual : Array E) (tail : List E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length + initial.size)) + (hv : Valid xs tail.length) : + Concrete.mle residual tail.toArray * + Concrete.mle (runDense xs + (initial.foldl (fun b r => foldLane b (2 ^ ((challenges xs).length + tail.length)) r) b)) + tail.toArray = + sourceTerminal + (Concrete.mle b (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + (save xs initial.size) (initial.toList ++ challenges xs) tail residual := by + rw [initial_residual_terminal initial xs b residual tail hb hv] + simpa only [Array.length_toList] using nativeTerminal_eq_sourceTerminal + (Concrete.mle b (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + xs initial.toList tail residual hv + +theorem source_terminal_acceptance (initial : Array E) (xs : List Step) + (b residual : Array E) (tail : List E) (claim : E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length + initial.size)) + (hv : Valid xs tail.length) : + (claim == sourceTerminal + (Concrete.mle b (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + (record xs ⟨initial.toList, []⟩).saved + (record xs ⟨initial.toList, []⟩).ris tail residual) = + (claim == Concrete.mle residual tail.toArray * + Concrete.mle (runDense xs + (initial.foldl (fun b r => foldLane b (2 ^ ((challenges xs).length + tail.length)) r) b)) + tail.toArray) := by + rw [record_chronology] + simp only [List.nil_append, Array.length_toList] + rw [initial_source_terminal initial xs b residual tail hb hv] + +/-- The dense terminal array includes the actual adjacent-pair tail folds. -/ +def terminalWeight (initial : Array E) (xs : List Step) (b : Array E) (tail : List E) : Array E := + tail.toArray.foldl foldLow (runDense xs + (initial.foldl (fun b r => foldLane b (2 ^ ((challenges xs).length + tail.length)) r) b)) + +theorem before_tail_size (initial : Array E) (xs : List Step) (b : Array E) (tail : List E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length + initial.size)) : + (runDense xs + (initial.foldl (fun b r => foldLane b (2 ^ ((challenges xs).length + tail.length)) r) b)).size = + 2 ^ tail.length := by + apply AccumulatedTerminalAlgebra.runDense_size (xs.map Step.dense) + rw [QueryRefinement.foldLane_blocks b initial (2 ^ ((challenges xs).length + tail.length)) + (by rw [hb, pow_add, Nat.mul_comm])] + simp + +theorem initial_source_terminal_folds (initial : Array E) (xs : List Step) + (b residual : Array E) (tail : List E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length + initial.size)) + (hv : Valid xs tail.length) : + Concrete.mle residual tail.toArray * (terminalWeight initial xs b tail)[0]! = + sourceTerminal + (Concrete.mle b (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + (save xs initial.size) (initial.toList ++ challenges xs) tail residual := by + unfold terminalWeight + rw [← mle_eq_foldLow_terminal _ tail.toArray + (by simpa using before_tail_size initial xs b tail hb)] + exact initial_source_terminal initial xs b residual tail hb hv + +/-- The dense Protocol terminal predicate and the native source scalar +predicate are the same Boolean, for arbitrary adversarial claim/message. -/ +theorem checkTerminal_source (initial : Array E) (xs : List Step) + (b residual : Array E) (tail : List E) (claim : E) (message : Message E) + (hb : b.size = 2 ^ ((challenges xs).length + tail.length + initial.size)) + (hv : Valid xs tail.length) : + (VerifierState.mk (terminalWeight initial xs b tail) claim message).checkTerminal + (Concrete.mle residual tail.toArray) = + (claim == sourceTerminal + (Concrete.mle b (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + (record xs ⟨initial.toList, []⟩).saved + (record xs ⟨initial.toList, []⟩).ris tail residual) := by + unfold VerifierState.checkTerminal + rw [initial_source_terminal_folds initial xs b residual tail hb hv, record_chronology] + simp + +/-- Concrete full caller instantiation: the ring-map family, transformed gamma +weights, and original point claims are supplied by the checked succinct caller +formula. No caller-MLE or accumulated-terminal equivalence is a hypothesis. -/ +theorem stack_terminal_equivalence {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (initial : Array E) (xs : List Step) (tail : List E) (residual : Array E) + (familyShape : SuccinctRingWeight.FamilyShape + ((challenges xs).length + tail.length + initial.size) family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape + ((challenges xs).length + tail.length + initial.size) points[i]) + (hv : Valid xs tail.length) : + let n := (challenges xs).length + tail.length + initial.size + let b := (CausalGame.batchClaims (2 ^ n) + (RingPCSGame.transformedClaims (2 ^ n) family points seed) lambda).weight + Concrete.mle residual tail.toArray * (terminalWeight initial xs b tail)[0]! = + sourceTerminal + (SuccinctRingGroups.sourceStackWeightAt family points seed lambda + (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + (save xs initial.size) (initial.toList ++ challenges xs) tail residual := by + dsimp only + have hp : (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray)).size = + (challenges xs).length + tail.length + initial.size := by + simp [Nat.add_comm] + rw [SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle family points seed lambda _ + (by simpa only [hp] using familyShape) (by simpa only [hp] using pointShapes)] + simp only [hp] + exact initial_source_terminal_folds initial xs _ residual tail + (InitialBatching.batchClaims_size ..) hv + +/-- Consumable by the physical scalar verifier: its exact native terminal +comparison and Protocol's actual terminal predicate are equal Booleans, with +the entire original caller stack concretely instantiated. -/ +theorem stack_checkTerminal_source {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (initial : Array E) (xs : List Step) (tail : List E) (residual : Array E) + (claim : E) (message : Message E) + (familyShape : SuccinctRingWeight.FamilyShape + ((challenges xs).length + tail.length + initial.size) family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape + ((challenges xs).length + tail.length + initial.size) points[i]) + (hv : Valid xs tail.length) : + let n := (challenges xs).length + tail.length + initial.size + let b := (CausalGame.batchClaims (2 ^ n) + (RingPCSGame.transformedClaims (2 ^ n) family points seed) lambda).weight + (VerifierState.mk (terminalWeight initial xs b tail) claim message).checkTerminal + (Concrete.mle residual tail.toArray) = + (claim == sourceTerminal + (SuccinctRingGroups.sourceStackWeightAt family points seed lambda + (rotatePoint initial.size (initial ++ (challenges xs ++ tail).toArray))) + (record xs ⟨initial.toList, []⟩).saved + (record xs ⟨initial.toList, []⟩).ris tail residual) := by + dsimp only + unfold VerifierState.checkTerminal + rw [stack_terminal_equivalence family points seed lambda initial xs tail residual + familyShape pointShapes hv, record_chronology] + simp + +end Whir.AccumulatedTerminalRefinement diff --git a/verification/whir/Whir/AccumulatedTerminalRegression.lean b/verification/whir/Whir/AccumulatedTerminalRegression.lean new file mode 100644 index 000000000..f689cdcaf --- /dev/null +++ b/verification/whir/Whir/AccumulatedTerminalRegression.lean @@ -0,0 +1,134 @@ +import Whir.AccumulatedTerminalRefinement +import Whir.ProductionTransitions + +namespace Whir.AccumulatedTerminalRegression +open Concrete Protocol AccumulatedTerminalRefinement + +/-- All 56 production profiles discharge the native subspace recurrence bound; +the profile constructor and its checked dimension ledger are not recopied. -/ +theorem production_native_guard (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) : + CausalGame.remaining (ParameterBounds.config p) i ≤ 64 := by + have h := (ProductionTransitions.production_fold_facts p i).1 + omega + +theorem production_level_valid (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) (folds : Array E) + (oods : Array (Array E)) (qs : Array Nat) (lambda : E) + (ho : ∀ j < oods.size, oods[j]!.size = CausalGame.remaining (ParameterBounds.config p) i) : + Valid (level folds (CausalGame.remaining (ParameterBounds.config p) i) oods qs lambda) + (CausalGame.remaining (ParameterBounds.config p) i) := + valid_level folds _ oods qs lambda (production_native_guard p i) ho + +private def e (n : Nat) : E := E.ofK (UInt64.ofNat n) +private def caller : Array E := #[e 1, e 7, e 19, e 5, e 42, e 99, e 31, e 11] +private def residual : Array E := #[e 23, e 41] +private def z00 : Array E := #[e 13, e 17] +private def z01 : Array E := #[e 29, e 31] +private def z10 : Array E := #[e 37] +private def qs0 : Array Nat := #[0, 1, 3] +private def qs1 : Array Nat := #[0, 2] + +/-- Independent eager dense transitions: fixed source chronology, no source +context compiler and no native basis evaluator are used on this side. -/ +private def denseWeight (original : Array E) (lambda0 lambda1 : E) : Array E := Id.run do + let mut b := foldLane original 4 (e 2) + b := weightGlue b (eqTable z00) lambda0 + b := weightGlue b (eqTable z01) (lambda0 * lambda0) + b := weightGlue b (induced 2 qs0 (powers lambda0 qs0.size)) (lambda0 ^ 3) + b := foldLow b (e 3) + b := weightGlue b (eqTable z10) lambda1 + b := weightGlue b (induced 1 qs1 (powers lambda1 qs1.size)) (lambda1 * lambda1) + b := foldLow b (e 5) + return b + +private def dense (lambda0 lambda1 : E) : E := + (foldLow residual (e 5))[0]! * (denseWeight caller lambda0 lambda1)[0]! + +private def program (lambda0 lambda1 : E) : List Step := + levelBatch 2 #[z00, z01] qs0 lambda0 ++ level #[e 3] 1 #[z10] qs1 lambda1 + +private def native (lambda0 lambda1 : E) : E := + let st := record (program lambda0 lambda1) ⟨[e 2], []⟩ + sourceTerminal (Concrete.mle caller (rotatePoint 1 #[e 2, e 3, e 5])) + st.saved st.ris [e 5] residual + +/-- Deliberately wrong coordinate convention. It rotates each saved suffix, +instead of rotating only the caller's full point. -/ +private def perLevelRotation (lambda0 lambda1 : E) : E := + let saved := save (program lambda0 lambda1) 1 + let wrong := (saved.map fun s => s.beta * + s.basis.native (([e 2, e 3, e 5].drop s.risStart).rotate 1)).sum + Concrete.mle residual #[e 5] * + (Concrete.mle caller (rotatePoint 1 #[e 2, e 3, e 5]) + wrong) + +private def checkCase (label : String) (a b : E) : IO Unit := do + let d := dense a b + let s := native a b + unless d == s do throw (IO.userError s!"{label}: dense/native mismatch {repr d} / {repr s}") + let good : VerifierState E := ⟨denseWeight caller a b, s, ⟨0, 0⟩⟩ + let bad : VerifierState E := { good with claim := s + 1 } + let yr := Concrete.mle residual #[e 5] + unless good.checkTerminal yr && !(bad.checkTerminal yr) do + throw (IO.userError s!"{label}: dense terminal Boolean mismatch") + IO.println s!"{label}: dense=native={d.toNat}" + +#eval do + checkCase "two levels / three OOD / residual / nonzero glue" (e 7) (e 11) + checkCase "zero first-level glue" 0 (e 11) + checkCase "zero second-level glue" (e 7) 0 + checkCase "zero all glue" 0 0 + let wrong := perLevelRotation (e 7) (e 11) + unless wrong != dense (e 7) (e 11) do + throw (IO.userError "coordinate-order discriminator failed") + IO.println s!"per-level rotation rejected: wrong={wrong.toNat}" + let state := record (program (e 7) (e 11)) ⟨[e 2], []⟩ + let wrongCaller := sourceTerminal (Concrete.mle caller #[e 2, e 3, e 5]) + state.saved state.ris [e 5] residual + unless wrongCaller != dense (e 7) (e 11) do + throw (IO.userError "initial top-variable rotation discriminator failed") + IO.println s!"unrotated caller rejected: wrong={wrongCaller.toNat}" + +private def family : Fin 2 → RingPCSGame.FamilyClaim := fun j => + if j.val = 0 then ⟨0, #[e 13, e 17], fun _ => 0⟩ + else ⟨4, #[e 19, e 23], fun _ => 0⟩ + +private def pointClaims : Array RingPCSGame.PointClaim := + #[.point 0 #[e 29, e 31] 0, .strided 4 1 1 #[e 37] 0] + +private def seed : RingPCSGame.Prefix := (⟨3, 1, 0⟩, fun i => e (i.val + 2)) + +private theorem family_shape : SuccinctRingWeight.FamilyShape 3 family := by + intro j + fin_cases j <;> simp [family] + +private theorem point_shapes : ∀ i : Fin pointClaims.size, + SuccinctPointWeight.Shape 3 pointClaims[i] := by + decide +kernel + +#eval do + let b := (CausalGame.batchClaims 8 (RingPCSGame.transformedClaims 8 family pointClaims seed) (e 41)).weight + let d := (foldLow residual (e 5))[0]! * (denseWeight b (e 7) (e 11))[0]! + let st := record (program (e 7) (e 11)) ⟨[e 2], []⟩ + let original := SuccinctRingGroups.sourceStackWeightAt family pointClaims seed (e 41) + (rotatePoint 1 #[e 2, e 3, e 5]) + let s := sourceTerminal original st.saved st.ris [e 5] residual + unless d == s do throw (IO.userError "full ring/point caller accumulated terminal mismatch") + IO.println s!"full ring family + ordinary/strided points + two levels: dense=native={d.toNat}" + +#print axioms AccumulatedTerminalAlgebra.mle_eqTable +#print axioms InitialTerminalRefinement.mle_foldLane_initial +#print axioms AccumulatedTerminalRefinement.levelBatch_weight +#print axioms AccumulatedTerminalRefinement.level_weight +#print axioms AccumulatedTerminalRefinement.save_chronology +#print axioms AccumulatedTerminalRefinement.initial_residual_terminal +#print axioms AccumulatedTerminalRefinement.initial_source_terminal +#print axioms AccumulatedTerminalRefinement.saved_suffix +#print axioms AccumulatedTerminalRefinement.record_chronology +#print axioms AccumulatedTerminalRefinement.source_terminal_acceptance +#print axioms AccumulatedTerminalRefinement.checkTerminal_source +#print axioms AccumulatedTerminalRefinement.stack_terminal_equivalence +#print axioms AccumulatedTerminalRefinement.stack_checkTerminal_source +#print axioms production_level_valid + +end Whir.AccumulatedTerminalRegression diff --git a/verification/whir/Whir/AdditiveBasis.lean b/verification/whir/Whir/AdditiveBasis.lean new file mode 100644 index 000000000..f6264f2d3 --- /dev/null +++ b/verification/whir/Whir/AdditiveBasis.lean @@ -0,0 +1,50 @@ +import Whir.AdditiveNormalization +import Whir.FieldModel + +/-! The exact polynomial basis of the machine words is binary-independent +under any injective, XOR-preserving field representation. -/ +namespace Whir.AdditiveCode +open Whir.Concrete Whir.FieldModel Polynomial +noncomputable section +variable {F : Type*} [Field F] + +private theorem representation_zero (f : BaseRepresentation F) : f.map 0 = 0 := by + have h := f.add 0 0 + simp only [UInt64.xor_self] at h + linear_combination -h + +/-- A span element is represented by an actual word whose polynomial has no +coefficient at or above the span dimension. This proves independence from the +machine bit basis, rather than assuming an RS encoder property. -/ +private theorem binarySpan_preimage (f : BaseRepresentation F) (n : Nat) (hn : n ≤ 64) + (x : F) (hx : x ∈ binarySpan (bitBasis f.map) n) : + ∃ a : K, f.map a = x ∧ ∀ i, n ≤ i → (wordPoly a).coeff i = 0 := by + induction n generalizing x with + | zero => + have hx0 : x = 0 := hx + subst x + exact ⟨0, representation_zero f, by simp⟩ + | succ n ih => + rcases hx with hx | ⟨y, hy, rfl⟩ + · obtain ⟨a, ha, hc⟩ := ih (by omega) x hx + exact ⟨a, ha, fun i hi => hc i (by omega)⟩ + · obtain ⟨a, ha, hc⟩ := ih (by omega) y hy + refine ⟨a ^^^ ((1 : K) <<< UInt64.ofNat n), ?_, ?_⟩ + · rw [f.add, ha]; rfl + · intro i hi + rw [wordPoly_xor, coeff_add, hc i (by omega), wordPoly_basis n (by omega)] + simp [coeff_X_pow, show i ≠ n by omega] + +/-- All first 64 actual bit-basis words remain binary independent. Multiplicative +or inverse correctness is not used in this argument. -/ +theorem bitBasis_independent (f : BaseRepresentation F) (hinj : Function.Injective f.map) + (n : Nat) (hn : n ≤ 64) : Independent (bitBasis f.map) n := by + intro i hi hmem + obtain ⟨a, ha, hc⟩ := binarySpan_preimage f i (by omega) (bitBasis f.map i) hmem + have hae : a = (1 : K) <<< UInt64.ofNat i := hinj ha + have hz := hc i le_rfl + rw [hae, wordPoly_basis i (by omega), coeff_X_pow_self] at hz + exact one_ne_zero hz + +end +end Whir.AdditiveCode diff --git a/verification/whir/Whir/AdditiveCode.lean b/verification/whir/Whir/AdditiveCode.lean new file mode 100644 index 000000000..dacd694fd --- /dev/null +++ b/verification/whir/Whir/AdditiveCode.lean @@ -0,0 +1,336 @@ +import Whir.CodingBounds +import Mathlib.Algebra.Polynomial.Sequence +import Mathlib.Algebra.CharP.Two + +/-! Annex D's dense additive encoder. Independence is a binary-span condition, +not a coding-theoretic assumption. Optimized NTT refinement is separate. -/ +namespace Whir.AdditiveCode +open Polynomial +open scoped BigOperators +noncomputable section + +variable {F : Type*} [Field F] + +/-- The unnormalized recursion used by `Concrete.subspaceRoots`. -/ +def subspace (v : ℕ → F) : ℕ → F[X] + | 0 => X + | n + 1 => subspace v n * (subspace v n + C ((subspace v n).eval (v n))) + +theorem subspace_degree (v : ℕ → F) (n : ℕ) : + (subspace v n).natDegree = 2^n ∧ (subspace v n).Monic := by + induction n with + | zero => simp [subspace] + | succ n ih => + have hp : 0 < (subspace v n).natDegree := by rw [ih.1]; positivity + have hm : (subspace v n + C ((subspace v n).eval (v n))).Monic := + ih.2.add_of_left (degree_C_le.trans_lt (by + rw [degree_eq_natDegree ih.2.ne_zero] + exact_mod_cast hp)) + constructor + · rw [subspace, ih.2.natDegree_mul hm, natDegree_add_C, ih.1, pow_succ] + omega + · exact ih.2.mul hm + +/-- Binary span of the first `n` vectors, including zero. -/ +def binarySpan (v : ℕ → F) : ℕ → Set F + | 0 => {0} + | n + 1 => binarySpan v n ∪ (fun x => x + v n) '' binarySpan v n + +/-- Each new vector lies outside the binary span of its predecessors. -/ +def Independent (v : ℕ → F) (n : ℕ) : Prop := + ∀ i < n, v i ∉ binarySpan v i + +section CharTwo +variable [CharP F 2] + +theorem subspace_add (v : ℕ → F) (n : ℕ) (x y : F) : + (subspace v n).eval (x+y) = (subspace v n).eval x + (subspace v n).eval y := by + induction n with + | zero => simp [subspace] + | succ n ih => + simp only [subspace, eval_mul, eval_add, eval_C, ih] + ring_nf + simp [CharTwo.two_eq_zero] + +/-- Additivity as a polynomial identity, not merely on field-valued points. -/ +theorem subspace_comp_add (v : ℕ → F) (n : ℕ) (p q : F[X]) : + (subspace v n).comp (p+q) = + (subspace v n).comp p + (subspace v n).comp q := by + induction n with + | zero => simp [subspace] + | succ n ih => + simp only [subspace, mul_comp, add_comp, C_comp, ih] + ring_nf + simp [CharTwo.two_eq_zero] + +omit [CharP F 2] in +@[simp] theorem subspace_zero (v : ℕ → F) (n : ℕ) : + (subspace v n).eval 0 = 0 := by + induction n with + | zero => simp [subspace] + | succ n ih => simp [subspace, ih] + +/-- The recursion has exactly the intended binary-subspace roots, even before +independence is imposed. -/ +theorem subspace_roots (v : ℕ → F) (n : ℕ) (x : F) : + (subspace v n).eval x = 0 ↔ x ∈ binarySpan v n := by + induction n generalizing x with + | zero => simp [subspace, binarySpan] + | succ n ih => + simp only [subspace, eval_mul, eval_add, eval_C, mul_eq_zero, + binarySpan, Set.mem_union, Set.mem_image] + rw [ih] + constructor + · rintro (h | h) + · exact Or.inl h + · right + refine ⟨x + v n, (ih _).mp ?_, ?_⟩ + · rw [subspace_add]; exact h + · simp [add_assoc, CharTwo.add_self_eq_zero] + · rintro (h | ⟨y, hy, rfl⟩) + · exact Or.inl h + · right + rw [subspace_add, (ih _).mpr hy, zero_add, CharTwo.add_self_eq_zero] + +theorem root_ne_zero {v : ℕ → F} {n i : ℕ} (h : Independent v n) (hi : i < n) : + (subspace v i).eval (v i) ≠ 0 := by + exact fun hz => h i hi ((subspace_roots v i (v i)).mp hz) + +/-- Finite enumeration of exactly the binary span. -/ +def binaryPoints [DecidableEq F] (v : ℕ → F) : ℕ → Finset F + | 0 => {0} + | n+1 => binaryPoints v n ∪ (binaryPoints v n).image (fun x => x + v n) + +omit [CharP F 2] in +@[simp] theorem mem_binaryPoints [DecidableEq F] (v : ℕ → F) (n : ℕ) (x : F) : + x ∈ binaryPoints v n ↔ x ∈ binarySpan v n := by + induction n generalizing x with + | zero => simp [binaryPoints, binarySpan] + | succ n ih => simp [binaryPoints, binarySpan, ih] + +theorem binaryPoints_disjoint [DecidableEq F] {v : ℕ → F} {n : ℕ} + (h : Independent v (n+1)) : + Disjoint (binaryPoints v n) ((binaryPoints v n).image (fun x => x + v n)) := by + rw [Finset.disjoint_left] + intro x hx hy + obtain ⟨y, hy', rfl⟩ := Finset.mem_image.mp hy + have hz := (subspace_roots v n (y + v n)).mpr ((mem_binaryPoints v n _).mp hx) + rw [subspace_add, (subspace_roots v n y).mpr ((mem_binaryPoints v n _).mp hy'), + zero_add] at hz + exact root_ne_zero h (Nat.lt_succ_self n) hz + +theorem binaryPoints_card [DecidableEq F] {v : ℕ → F} {n : ℕ} + (h : Independent v n) : (binaryPoints v n).card = 2^n := by + induction n with + | zero => simp [binaryPoints] + | succ n ih => + rw [binaryPoints, Finset.card_union_of_disjoint (binaryPoints_disjoint h), + Finset.card_image_of_injective _ (add_left_injective (v n)), + ih (fun i hi => h i (by omega)), pow_succ] + omega + +/-- The recursion is exactly Annex D's product over the binary subspace. -/ +theorem subspace_eq_product [DecidableEq F] {v : ℕ → F} {n : ℕ} + (h : Independent v n) : + subspace v n = ∏ x ∈ binaryPoints v n, (X + C x) := by + induction n with + | zero => simp [subspace, binaryPoints] + | succ n ih => + have ih' := ih (fun i hi => h i (by omega)) + rw [binaryPoints, Finset.prod_union (binaryPoints_disjoint h)] + rw [Finset.prod_image (fun a _ b _ hab => add_right_cancel hab)] + have hshift : (∏ x ∈ binaryPoints v n, (X + C (x + v n))) = + (subspace v n).comp (X + C (v n)) := by + rw [ih'] + simp only [prod_comp, add_comp, X_comp, C_comp, map_add] + apply Finset.prod_congr rfl + intro x _ + ring + rw [hshift, subspace_comp_add, comp_X, comp_C, ← ih', subspace] + +end CharTwo + +/-- Division by the nonzero diagonal value normalizes each additive factor. -/ +def normalized (v : ℕ → F) (i : ℕ) : F[X] := + C ((subspace v i).eval (v i))⁻¹ * subspace v i + +theorem normalized_degree {v : ℕ → F} {n i : ℕ} [CharP F 2] + (h : Independent v n) (hi : i < n) : + (normalized v i).natDegree = 2^i ∧ (normalized v i).leadingCoeff ≠ 0 := by + have hr := root_ne_zero h hi + have hp := subspace_degree v i + constructor + · simp [normalized, natDegree_mul (C_ne_zero.mpr (inv_ne_zero hr)) hp.2.ne_zero, hp.1] + · simp [normalized, leadingCoeff_mul, hp.2.leadingCoeff, hr] + +@[simp] theorem normalized_at_basis {v : ℕ → F} {n i : ℕ} [CharP F 2] + (h : Independent v n) (hi : i < n) : (normalized v i).eval (v i) = 1 := by + simp [normalized, root_ne_zero h hi] + +/-- Low-bit-first product basis; the upper half appends the new factor, exactly +as the dense column loop does. Only indices below `2^n` are used. -/ +def novel (v : ℕ → F) : ℕ → ℕ → F[X] + | 0, _ => 1 + | n + 1, j => if j < 2^n then novel v n j + else novel v n (j - 2^n) * normalized v n + +theorem novel_degree {v : ℕ → F} [CharP F 2] {n : ℕ} + (h : Independent v n) {j : ℕ} (hj : j < 2^n) : + (novel v n j).natDegree = j ∧ (novel v n j).leadingCoeff ≠ 0 := by + induction n generalizing j with + | zero => have : j = 0 := by simpa using hj + subst j + simp [novel] + | succ n ih => + have hprev : Independent v n := fun i hi => h i (by omega) + have hn := normalized_degree h (Nat.lt_succ_self n) + simp only [novel] + split_ifs with hj' + · exact ih hprev hj' + · have hlt : j - 2^n < 2^n := by rw [pow_succ] at hj; omega + have hb := ih hprev hlt + constructor + · rw [natDegree_mul (leadingCoeff_ne_zero.mp hb.2) (leadingCoeff_ne_zero.mp hn.2), + hb.1, hn.1] + omega + · rw [leadingCoeff_mul]; exact mul_ne_zero hb.2 hn.2 + +/-- Extend the finite triangular family by monomials to use Mathlib's +polynomial-sequence basis theorem. The extension does not alter the code. -/ +noncomputable def sequence (v : ℕ → F) [CharP F 2] (n : ℕ) (h : Independent v n) : + Polynomial.Sequence F where + elems' j := if j < 2^n then novel v n j else X^j + degree_eq' j := by + split_ifs with hj + · exact (degree_eq_iff_natDegree_eq (leadingCoeff_ne_zero.mp (novel_degree h hj).2)).mpr + (novel_degree h hj).1 + · simp + +/-- The actual coefficient-to-polynomial map. -/ +def polynomial (v : ℕ → F) (n : ℕ) (a : Fin (2^n) → F) : F[X] := + ∑ j, a j • novel v n j + +theorem novel_independent {v : ℕ → F} [CharP F 2] {n : ℕ} + (h : Independent v n) : + LinearIndependent F (fun j : Fin (2^n) => novel v n j) := by + simpa [sequence, Function.comp_def] using + (sequence v n h).linearIndependent.comp (fun j : Fin (2^n) => j.val) Fin.val_injective + +theorem polynomial_injective {v : ℕ → F} [CharP F 2] {n : ℕ} + (h : Independent v n) : Function.Injective (polynomial v n) := by + intro a b hab + have hz : ∑ j, (a j - b j) • novel v n j = 0 := by + simp only [sub_smul, Finset.sum_sub_distrib] + exact sub_eq_zero.mpr hab + have he := Fintype.linearIndependent_iff.mp (novel_independent h) _ hz + funext j + exact sub_eq_zero.mp (he j) + +theorem polynomial_degree_lt {v : ℕ → F} [CharP F 2] {n : ℕ} + (h : Independent v n) (a : Fin (2^n) → F) : + (polynomial v n a).degree < 2^n := by + have he : (2 : WithBot ℕ)^n = ((2^n : ℕ) : WithBot ℕ) := by norm_cast + rw [he, ← mem_degreeLT] + apply Submodule.sum_mem + intro j _ + apply Submodule.smul_mem + rw [mem_degreeLT, + degree_eq_natDegree (leadingCoeff_ne_zero.mp (novel_degree h j.isLt).2), + (novel_degree h j.isLt).1] + exact_mod_cast j.isLt + +/-- Surjectivity onto precisely the RS polynomial space, not a larger space. -/ +theorem polynomial_surjective {v : ℕ → F} [CharP F 2] {n : ℕ} + (h : Independent v n) (p : F[X]) : + (∃ a : Fin (2^n) → F, polynomial v n a = p) ↔ p.degree < 2^n := by + constructor + · rintro ⟨a, rfl⟩; exact polynomial_degree_lt h a + · intro hp + have hs := (sequence v n h).span_degreeLT + (m := 2^n) (fun i _ => isUnit_iff_ne_zero.mpr + (leadingCoeff_ne_zero.mpr ((sequence v n h).ne_zero i))) + have hr : (sequence v n h) '' Set.Iio (2^n) = + Set.range (fun j : Fin (2^n) => novel v n j) := by + ext q + constructor + · rintro ⟨i, hi, rfl⟩ + exact ⟨⟨i, hi⟩, by simp [sequence, show i < 2^n from hi]⟩ + · rintro ⟨i, rfl⟩ + exact ⟨i.val, i.isLt, by simp [sequence]⟩ + rw [hr] at hs + have hm : p ∈ Submodule.span F (Set.range (fun j : Fin (2^n) => novel v n j)) := by + rw [hs, mem_degreeLT]; exact hp + exact (Submodule.mem_span_range_iff_exists_fun F).mp hm + +/-- Distinct novel-basis messages agree at at most `2^n-1` distinct points. -/ +theorem agreement_bound {v : ℕ → F} [CharP F 2] [DecidableEq F] {n : ℕ} + (h : Independent v n) (domain : Finset F) (a b : Fin (2^n) → F) (hab : a ≠ b) : + (domain.filter fun x => (polynomial v n a).eval x = + (polynomial v n b).eval x).card ≤ 2^n - 1 := by + have hd (c : Fin (2^n) → F) : (polynomial v n c).natDegree ≤ 2^n - 1 := by + by_cases hz : polynomial v n c = 0 + · simp [hz] + · exact Nat.le_pred_of_lt ((natDegree_lt_iff_degree_lt hz).mpr (polynomial_degree_lt h c)) + exact Whir.Soundness.evaluation_agreement domain _ _ + (fun he => hab (polynomial_injective h he)) _ (hd a) (hd b) + +/-- The dense novel-basis evaluation code on an arbitrary set of distinct points. -/ +def evaluation (v : ℕ → F) (n : ℕ) (domain : Finset F) (a : Fin (2^n) → F) : + domain → F := fun x => (polynomial v n a).eval x + +theorem evaluation_agreement {v : ℕ → F} [CharP F 2] [DecidableEq F] {n : ℕ} + (h : Independent v n) (domain : Finset F) (a b : Fin (2^n) → F) (hab : a ≠ b) : + CodingBounds.agreement (evaluation v n domain a) (evaluation v n domain b) ≤ 2^n-1 := by + classical + have hc : CodingBounds.agreement (evaluation v n domain a) (evaluation v n domain b) = + (domain.filter fun x => (polynomial v n a).eval x = (polynomial v n b).eval x).card := by + change CodingBounds.agreement + (fun x : domain => (polynomial v n a).eval x.val) + (fun x : domain => (polynomial v n b).eval x.val) = _ + simp only [CodingBounds.agreement, Finset.card_filter] + exact (Finset.sum_subtype domain (fun _ => Iff.rfl) + (fun x => if (polynomial v n a).eval x = (polynomial v n b).eval x then 1 else 0)).symm + rw [hc] + exact agreement_bound h domain a b hab + +/-- Evaluation is injective as soon as the domain contains the code dimension. -/ +theorem evaluation_injective {v : ℕ → F} [CharP F 2] [DecidableEq F] {n : ℕ} + (h : Independent v n) (domain : Finset F) (hd : 2^n ≤ domain.card) : + Function.Injective (evaluation v n domain) := by + intro a b he + by_contra hab + have hc := agreement_bound h domain a b hab + have hp : ∀ x ∈ domain, (polynomial v n a).eval x = (polynomial v n b).eval x := + fun x hx => congrFun he ⟨x, hx⟩ + rw [Finset.filter_true_of_mem hp] at hc + have : 0 < 2^n := by positivity + omega + +/-- Exact set equality with the RS space, suitable for the audited same-set MCA. +The statement neither assumes nor postulates that the additive encoder is RS. -/ +theorem mem_evaluation_range {v : ℕ → F} [CharP F 2] {n : ℕ} + (h : Independent v n) (domain : Finset F) (word : domain → F) : + word ∈ Set.range (evaluation v n domain) ↔ + ∃ p : F[X], p.degree < 2^n ∧ ∀ x : domain, p.eval x.val = word x := by + constructor + · rintro ⟨a, rfl⟩ + exact ⟨polynomial v n a, polynomial_degree_lt h a, fun _ => rfl⟩ + · rintro ⟨p, hp, he⟩ + obtain ⟨a, ha⟩ := (polynomial_surjective h p).mpr hp + exact ⟨a, by funext x; simpa [evaluation, ha] using he x⟩ + +/-- The existing finite-code Johnson bound instantiated by the proved encoder. -/ +theorem evaluation_candidates_card {v : ℕ → F} [CharP F 2] [Fintype F] + [DecidableEq F] {n : ℕ} (h : Independent v n) + (domain : Finset F) (oracle : domain → F) (t : ℕ) + (hd : 2^n - 1 ≤ domain.card) + (threshold : (domain.card : ℚ) * (2^n-1 : ℕ) < (t : ℚ)^2) : + ((CodingBounds.candidates (evaluation v n domain) oracle t).card : ℚ) ≤ + (domain.card * (domain.card - (2^n-1 : ℕ) : ℚ)) / + ((t : ℚ)^2 - domain.card * (2^n-1 : ℕ)) := by + simpa using CodingBounds.candidates_card (evaluation v n domain) oracle t (2^n-1) + (by simpa using hd) (fun a b hab => evaluation_agreement h domain a b hab) + (by simpa using threshold) + +end +end Whir.AdditiveCode diff --git a/verification/whir/Whir/AdditiveColumn.lean b/verification/whir/Whir/AdditiveColumn.lean new file mode 100644 index 000000000..30ab50545 --- /dev/null +++ b/verification/whir/Whir/AdditiveColumn.lean @@ -0,0 +1,346 @@ +import Whir.AdditiveBasis +import Whir.FieldInverse + +/-! Refinement of the actual append/map-scale column loop and dense encoder. +`column_map` and `encode_map` identify the real arrays with novel-polynomial +evaluation; `encode_injective` and `encode_agreement_bound` then discharge the +coding obligations, including binary-basis independence and word-index bounds. + +The generic transport uses field representations preserving individual +machine operations, not an assumed encoder/RS identity. The final +`concrete_*` theorems discharge those representations using `FieldInverse`, +including the actual `kinv`, actual `E.ofK`, and certified field operations. +They retain only dimension and no-word-wrap premises. -/ +namespace Whir.AdditiveCode +open Polynomial Whir.Concrete Whir.ArrayLayout +open scoped BigOperators +noncomputable section + +variable {F : Type*} [Field F] [Inhabited F] + +private theorem column_loop_map + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (scale : ∀ a s, e.map (E.scale a s) = e.map a * f.map s) + (v : Nat → F) (x : F) (ss : List K) : + (∀ i < ss.length, f.map ss[i]! = (normalized v i).eval x) → + (ss.foldl (fun out s => out ++ out.map (fun a => a.scale s)) #[E.one]).map e.map = + tab (2 ^ ss.length) fun j => (novel v ss.length j).eval x := by + induction ss using List.reverseRecOn with + | nil => + intro _ + simp [novel, tab] + exact e.one + | append_singleton ss s ih => + intro hn + have hp : ∀ i < ss.length, f.map ss[i]! = (normalized v i).eval x := by + intro i hi + have h := hn i (by simp; omega) + simpa only [getElem!_pos ss i hi, + getElem!_pos (ss ++ [s]) i (by simp; omega), List.getElem_append_left hi] using h + have hs : f.map s = (normalized v ss.length).eval x := by + simpa [getElem!_pos] using hn ss.length (by simp) + have hscale (a : Array E) : + (a.map (fun a => a.scale s)).map e.map = + (a.map e.map).map (fun a => a * f.map s) := by + simp only [Array.map_map, Function.comp_def] + congr 1 + funext a + exact scale a s + simp only [List.foldl_append, List.foldl_cons, List.foldl_nil, Array.map_append, + hscale, ih hp, List.length_append, List.length_singleton] + apply Array.ext + · simp [pow_succ]; omega + · intro j hj hj' + have hjn : j < 2 ^ (ss.length + 1) := by simpa using hj' + by_cases h : j < 2 ^ ss.length + · rw [Array.getElem_append_left (by simpa using h)] + simp [tab, novel, h] + · rw [Array.getElem_append_right (by simpa using Nat.le_of_not_gt h)] + simp [tab, novel, h, hs] + +/-- Scalar multiplication uses exactly multiplication by the actual base +embedding, proved from the checked carryless-multiplication representation. -/ +theorem scale_eq_mul_ofK (a : E) (s : K) : E.scale a s = a * E.ofK s := by + have hz (x : K) : kmul x 0 = 0 := by + apply FieldModel.toBaseQuotient_injective + simp [FieldModel.toBaseQuotient_kmul] + change E.scale a s = E.mul a (E.ofK s) + simp [E.scale, E.mul, E.ofK, hz] + +/-- Exact novel-basis evaluation of every actual dense column entry. -/ +theorem column_map + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (n q : Nat) : + (column n q).map e.map = + tab (2 ^ n) fun j => (novel (bitBasis f.map) n j).eval (f.map (UInt64.ofNat q)) := by + have scale : ∀ a s, e.map (E.scale a s) = e.map a * f.map s := by + intro a s + rw [scale_eq_mul_ofK, e.mul, ofK] + have h := column_loop_map f e scale (bitBasis f.map) (f.map (UInt64.ofNat q)) + (normalizedSubspaces n (UInt64.ofNat q)).toList (by + intro i hi + simpa only [Array.getElem!_toList] using + normalizedSubspaces_map f n (UInt64.ofNat q) i (by simpa using hi)) + unfold column + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + change ((normalizedSubspaces n (UInt64.ofNat q)).foldl + (fun out s => out ++ out.map (fun a => a.scale s)) #[E.one]).map e.map = _ + rw [← Array.foldl_toList] + simpa only [Array.length_toList, QueryRefinement.size_normalizedSubspaces] using h + +/-- The polynomial represented by the actual dense coefficient array. -/ +def arrayPolynomial (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (n : Nat) (a : Array E) : F[X] := + polynomial (bitBasis f.map) n (fun j => e.map a[j.val]!) + +/-- Actual dense `encode` evaluates precisely the novel-basis polynomial. -/ +theorem encode_map + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (n rate : Nat) (a : Array E) (shape : a.size = 2 ^ n) + (q : Nat) (hq : q < 2 ^ (n + rate)) : + e.map (encode n rate a)[q]! = + (arrayPolynomial f e n a).eval (f.map (UInt64.ofNat q)) := by + rw [encode, getElem!_tab _ _ _ hq, e.map_dot, column_map f e ofK] + simp only [ArrayAlgebra.dot_eq_sum, + Array.size_map, size_tab, shape, min_self, arrayPolynomial, polynomial, + eval_finsetSum, eval_smul, smul_eq_mul] + rw [Finset.sum_range] + apply Finset.sum_congr rfl + intro j hj + rw [getElem!_tab _ _ _ j.isLt] + simp [getElem!_pos, show j.val < a.size by rw [shape]; exact j.isLt] + +/-- The actual coefficient array embeds injectively into its polynomial; +binary-basis independence is discharged from faithful machine representation. -/ +theorem arrayPolynomial_injective + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (hf : Function.Injective f.map) [CharP F 2] + (n : Nat) (hn : n ≤ 64) (a b : Array E) + (ha : a.size = 2 ^ n) (hb : b.size = 2 ^ n) + (h : arrayPolynomial f e n a = arrayPolynomial f e n b) : a = b := by + have hc := polynomial_injective (bitBasis_independent f hf n hn) h + apply Array.ext + · omega + · intro i hi hi' + apply e.injective + have hh := congrFun hc ⟨i, by simpa [ha] using hi⟩ + simpa only [getElem!_pos a i hi, getElem!_pos b i hi'] using hh + +theorem arrayPolynomial_degree_lt + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (hf : Function.Injective f.map) [CharP F 2] (n : Nat) (hn : n ≤ 64) + (a : Array E) : (arrayPolynomial f e n a).degree < 2 ^ n := + polynomial_degree_lt (bitBasis_independent f hf n hn) _ + +/-- Compatible faithful extension representation also proves faithfulness of +the actual base embedding; callers need not postulate base injectivity. -/ +theorem baseRepresentation_injective + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) : Function.Injective f.map := by + intro a b h + have he : E.ofK a = E.ofK b := e.injective (by simpa only [ofK] using h) + exact congrArg E.c0 he + +omit [Inhabited F] in +/-- Distinct in-range machine query indices are distinct field points. -/ +theorem evaluationPoint_injective (f : BaseRepresentation F) + (hf : Function.Injective f.map) {i j : Nat} (hi : i < 2 ^ 64) (hj : j < 2 ^ 64) + (h : f.map (UInt64.ofNat i) = f.map (UInt64.ofNat j)) : i = j := by + have hn := congrArg UInt64.toNat (hf h) + simpa only [UInt64.toNat_ofNat', Nat.mod_eq_of_lt hi, Nat.mod_eq_of_lt hj] using hn + +/-- The exact machine query domain as an embedding suitable for RS/MCA +theorems indexed by `Fin N`; no surrogate evaluation points are introduced. -/ +def machineDomain (f : BaseRepresentation F) (hf : Function.Injective f.map) + (depth : Nat) (hd : depth ≤ 64) : Fin (2 ^ depth) ↪ F where + toFun q := f.map (UInt64.ofNat q.val) + inj' a b h := by + apply Fin.ext + have hmax : 2 ^ depth ≤ 2 ^ 64 := Nat.pow_le_pow_right (by decide) hd + exact evaluationPoint_injective f hf (a.isLt.trans_le hmax) (b.isLt.trans_le hmax) h + +/-- The actual encoder, represented as a whole array, is polynomial evaluation +on the actual word-index domain. -/ +theorem encode_map_array + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (n rate : Nat) (a : Array E) (shape : a.size = 2 ^ n) : + (encode n rate a).map e.map = + tab (2 ^ (n + rate)) fun q => + (arrayPolynomial f e n a).eval (f.map (UInt64.ofNat q)) := by + apply Array.ext + · simp [encode] + · intro q hq hq' + have hqn : q < 2 ^ (n + rate) := by simpa using hq' + have hqa : q < (encode n rate a).size := by simpa [encode] using hqn + simp only [Array.getElem_map, tab, List.getElem_toArray, List.getElem_range] + simpa only [getElem!_pos (encode n rate a) q hqa] using + encode_map f e ofK n rate a shape q hqn + +/-- Distinct actual coefficient arrays agree at at most `2^n-1` actual encoded +positions. Both novel-basis independence and query-domain injectivity are +proved from machine representation and the no-word-wrap bound. -/ +theorem encode_agreement_bound + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (hf : Function.Injective f.map) [CharP F 2] + (n rate : Nat) (depth : n + rate ≤ 64) + (a b : Array E) (ha : a.size = 2 ^ n) (hb : b.size = 2 ^ n) (hne : a ≠ b) : + ((Finset.range (2 ^ (n + rate))).filter fun q => + (encode n rate a)[q]! = (encode n rate b)[q]!).card ≤ 2 ^ n - 1 := by + classical + let point := fun q => f.map (UInt64.ofNat q) + let domain := (Finset.range (2 ^ (n + rate))).image point + have hn : n ≤ 64 := by omega + have hpoly : arrayPolynomial f e n a ≠ arrayPolynomial f e n b := + fun h => hne (arrayPolynomial_injective f e hf n hn a b ha hb h) + have hdegree (c : Array E) : (arrayPolynomial f e n c).natDegree ≤ 2 ^ n - 1 := by + by_cases hz : arrayPolynomial f e n c = 0 + · simp [hz] + · exact Nat.le_pred_of_lt ((natDegree_lt_iff_degree_lt hz).mpr + (arrayPolynomial_degree_lt f e hf n hn c)) + have hagree := Whir.Soundness.evaluation_agreement domain _ _ hpoly + (2 ^ n - 1) (hdegree a) (hdegree b) + apply Nat.le_trans _ hagree + apply Finset.card_le_card_of_injOn point + · intro q hq + obtain ⟨hqr, he⟩ := Finset.mem_filter.mp hq + refine Finset.mem_filter.mpr ⟨Finset.mem_image.mpr ⟨q, hqr, rfl⟩, ?_⟩ + have hm := congrArg e.map he + simpa only [encode_map f e ofK n rate a ha q (Finset.mem_range.mp hqr), + encode_map f e ofK n rate b hb q (Finset.mem_range.mp hqr)] using hm + · intro i hi j hj he + have hmax : 2 ^ (n + rate) ≤ 2 ^ 64 := Nat.pow_le_pow_right (by decide) depth + exact evaluationPoint_injective f hf + ((Finset.mem_range.mp (Finset.mem_filter.mp hi).1).trans_le hmax) + ((Finset.mem_range.mp (Finset.mem_filter.mp hj).1).trans_le hmax) he + +/-- Faithful dense encoding follows from the actual agreement bound, not an +assumed encoder-is-RS identity. -/ +theorem encode_injective + (f : BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (hf : Function.Injective f.map) [CharP F 2] + (n rate : Nat) (depth : n + rate ≤ 64) + (a b : Array E) (ha : a.size = 2 ^ n) (hb : b.size = 2 ^ n) + (h : encode n rate a = encode n rate b) : a = b := by + by_contra hne + have hagree := encode_agreement_bound f e ofK hf n rate depth a b ha hb hne + simp only [h, Finset.filter_true, Finset.card_range] at hagree + have hpow : 2 ^ n ≤ 2 ^ (n + rate) := Nat.pow_le_pow_right (by decide) (by omega) + have hpos : 0 < 2 ^ n := by positivity + omega + +/-- All representation laws for the actual base embedding, including the +executable inverse, are supplied by checked field-model theorems. -/ +def concreteBaseRepresentation : BaseRepresentation E where + map := E.ofK + one := FieldModel.ofK_one + add := FieldModel.ofK_xor + mul := FieldModel.ofK_kmul + inv := FieldModel.ofK_kinv + +theorem concrete_bitBasis_independent (n : Nat) (hn : n ≤ 64) : + Independent (bitBasis E.ofK) n := + bitBasis_independent concreteBaseRepresentation FieldModel.ofK_injective n hn + +/-- Actual machine query points as a proved injective field domain. -/ +def concreteDomain (depth : Nat) (hd : depth ≤ 64) : Fin (2 ^ depth) ↪ E := + machineDomain concreteBaseRepresentation FieldModel.ofK_injective depth hd + +/-- The actual novel-basis polynomial of the actual coefficient array. -/ +def concretePolynomial (n : Nat) (a : Array E) : E[X] := + arrayPolynomial concreteBaseRepresentation QueryRefinement.concreteRepresentation n a + +/-- No remaining representation hypothesis: actual columns are the evaluated +novel basis for the actual normalized binary field. -/ +theorem concrete_column (n q : Nat) : + column n q = + tab (2 ^ n) fun j => (novel (bitBasis E.ofK) n j).eval (E.ofK (UInt64.ofNat q)) := by + simpa only [concreteBaseRepresentation, QueryRefinement.concreteRepresentation, + id_eq, Array.map_id] using + column_map concreteBaseRepresentation QueryRefinement.concreteRepresentation + (fun _ => rfl) n q + +/-- Full actual dense encoder/polynomial correspondence with only shape and +query bounds; no field or encoder-correctness premise remains. -/ +theorem concrete_encode_eval (n rate : Nat) (a : Array E) (shape : a.size = 2 ^ n) + (q : Nat) (hq : q < 2 ^ (n + rate)) : + (encode n rate a)[q]! = (concretePolynomial n a).eval (E.ofK (UInt64.ofNat q)) := + encode_map concreteBaseRepresentation QueryRefinement.concreteRepresentation + (fun _ => rfl) n rate a shape q hq + +theorem concrete_encode_array (n rate : Nat) (a : Array E) (shape : a.size = 2 ^ n) : + encode n rate a = + tab (2 ^ (n + rate)) fun q => + (concretePolynomial n a).eval (E.ofK (UInt64.ofNat q)) := by + simpa only [concretePolynomial, concreteBaseRepresentation, + QueryRefinement.concreteRepresentation, id_eq, Array.map_id] using + encode_map_array concreteBaseRepresentation QueryRefinement.concreteRepresentation + (fun _ => rfl) n rate a shape + +theorem concrete_polynomial_injective (n : Nat) (hn : n ≤ 64) (a b : Array E) + (ha : a.size = 2 ^ n) (hb : b.size = 2 ^ n) + (h : concretePolynomial n a = concretePolynomial n b) : a = b := + arrayPolynomial_injective concreteBaseRepresentation QueryRefinement.concreteRepresentation + FieldModel.ofK_injective n hn a b ha hb h + +theorem concrete_polynomial_degree_lt (n : Nat) (hn : n ≤ 64) (a : Array E) : + (concretePolynomial n a).degree < 2 ^ n := + arrayPolynomial_degree_lt concreteBaseRepresentation QueryRefinement.concreteRepresentation + FieldModel.ofK_injective n hn a + +/-- Every polynomial in the RS degree space is represented by an actual +coefficient array of the required length, and conversely. -/ +theorem concrete_polynomial_surjective (n : Nat) (hn : n ≤ 64) (p : E[X]) : + (∃ a : Array E, a.size = 2 ^ n ∧ concretePolynomial n a = p) ↔ + p.degree < 2 ^ n := by + constructor + · rintro ⟨a, _, rfl⟩ + exact concrete_polynomial_degree_lt n hn a + · intro hp + obtain ⟨a, ha⟩ := (polynomial_surjective (concrete_bitBasis_independent n hn) p).mpr hp + refine ⟨Array.ofFn a, by simp, ?_⟩ + change polynomial (bitBasis E.ofK) n (fun j => (Array.ofFn a)[j.val]!) = p + have he : (fun j : Fin (2 ^ n) => (Array.ofFn a)[j.val]!) = a := by + funext j + simp [getElem!_pos, j.isLt] + rw [he] + exact ha + +/-- Exact image equality for the actual dense encoder and the RS evaluation +space, not merely an upper degree bound for honest messages. -/ +theorem concrete_encode_range (n rate : Nat) (hn : n ≤ 64) (word : Array E) : + (∃ a : Array E, a.size = 2 ^ n ∧ encode n rate a = word) ↔ + ∃ p : E[X], p.degree < 2 ^ n ∧ + (tab (2 ^ (n + rate)) fun q => p.eval (E.ofK (UInt64.ofNat q))) = word := by + constructor + · rintro ⟨a, ha, rfl⟩ + exact ⟨concretePolynomial n a, concrete_polynomial_degree_lt n hn a, + (concrete_encode_array n rate a ha).symm⟩ + · rintro ⟨p, hp, he⟩ + obtain ⟨a, ha, hap⟩ := (concrete_polynomial_surjective n hn p).mpr hp + refine ⟨a, ha, ?_⟩ + rw [concrete_encode_array n rate a ha, hap] + exact he + +/-- Actual encoded words have the exact RS agreement bound, proved without +assuming that the executable encoder is a Reed–Solomon code. -/ +theorem concrete_encode_agreement_bound (n rate : Nat) (depth : n + rate ≤ 64) + (a b : Array E) (ha : a.size = 2 ^ n) (hb : b.size = 2 ^ n) (hne : a ≠ b) : + ((Finset.range (2 ^ (n + rate))).filter fun q => + (encode n rate a)[q]! = (encode n rate b)[q]!).card ≤ 2 ^ n - 1 := + encode_agreement_bound concreteBaseRepresentation QueryRefinement.concreteRepresentation + (fun _ => rfl) FieldModel.ofK_injective n rate depth a b ha hb hne + +/-- The actual encoder is injective on its valid coefficient arrays. -/ +theorem concrete_encode_injective (n rate : Nat) (depth : n + rate ≤ 64) + (a b : Array E) (ha : a.size = 2 ^ n) (hb : b.size = 2 ^ n) + (h : encode n rate a = encode n rate b) : a = b := + encode_injective concreteBaseRepresentation QueryRefinement.concreteRepresentation + (fun _ => rfl) FieldModel.ofK_injective n rate depth a b ha hb h + +end +end Whir.AdditiveCode diff --git a/verification/whir/Whir/AdditiveNormalization.lean b/verification/whir/Whir/AdditiveNormalization.lean new file mode 100644 index 000000000..2ad5ecacd --- /dev/null +++ b/verification/whir/Whir/AdditiveNormalization.lean @@ -0,0 +1,159 @@ +import Whir.AdditiveCode +import Whir.QueryRefinement + +/-! Refinement of the actual dense encoder's subspace loops. The remaining +representation obligations are operation preservation, not an RS-code axiom. -/ +namespace Whir.AdditiveCode +open Polynomial +open Whir.Concrete +noncomputable section +variable {F : Type*} [Field F] + +/-- Exact operations needed from the concrete base-field representation. -/ +structure BaseRepresentation (F : Type*) [Field F] where + map : K → F + one : map 1 = 1 + add : ∀ x y, map (x ^^^ y) = map x + map y + mul : ∀ x y, map (kmul x y) = map x * map y + inv : ∀ x, map (kinv x) = (map x)⁻¹ + +def bitBasis (f : K → F) (i : ℕ) : F := f ((1 : K) <<< UInt64.ofNat i) + +private def rootStep (state : Array K × Array K) (i : Nat) : Array K × Array K := + let layer := state.2.map fun x => kmul x (x ^^^ state.1[i]!) + (state.1.push layer[0]!, layer.extract 1 layer.size) + +private def rootState (n k : Nat) : Array K × Array K := + (List.range k).foldl rootStep (#[1], tab n fun i => (1 : K) <<< UInt64.ofNat (i+1)) + +private theorem rootState_succ (n k : Nat) : + rootState n (k+1) = rootStep (rootState n k) k := by + simp [rootState, List.range_succ] + +private theorem rootState_invariant (f : BaseRepresentation F) (n k : Nat) (hk : k ≤ n) : + (rootState n k).1.size = k+1 ∧ (rootState n k).2.size = n-k ∧ + (∀ i < k+1, f.map (rootState n k).1[i]! = + (subspace (bitBasis f.map) i).eval (bitBasis f.map i)) ∧ + (∀ j < n-k, f.map (rootState n k).2[j]! = + (subspace (bitBasis f.map) k).eval (bitBasis f.map (k+j+1))) := by + induction k with + | zero => + simp only [rootState, List.range_zero, List.foldl_nil, Nat.zero_add, Nat.sub_zero] + refine ⟨rfl, by simp, ?_, ?_⟩ + · intro i hi + have : i = 0 := by omega + subst i + simp [subspace, bitBasis] + · intro j hj + simp [tab, hj, getElem!_pos, subspace, bitBasis] + | succ k ih => + obtain ⟨hrs, hls, hroot, hlayer⟩ := ih (by omega) + have hkn : k < n := by omega + have hks : k < (rootState n k).1.size := by omega + have h0 : 0 < (rootState n k).2.size := by omega + rw [rootState_succ] + have hnew (j : Nat) (hj : j < (rootState n k).2.size) : + f.map ((rootState n k).2.map (fun x => kmul x (x ^^^ (rootState n k).1[k]!)))[j]! = + (subspace (bitBasis f.map) (k+1)).eval (bitBasis f.map (k+j+1)) := by + rw [getElem!_pos _ _ (by simpa using hj), Array.getElem_map, f.mul, f.add, + ← getElem!_pos (rootState n k).2 j hj, hlayer j (by omega), hroot k (by omega)] + simp [subspace] + constructor + · simp [rootStep, hrs] + constructor + · simp [rootStep, hls]; omega + constructor + · intro i hi + by_cases hik : i < k+1 + · have his : i < (rootState n k).1.size := by omega + simp only [rootStep] + rw [getElem!_pos _ _ (by simpa using Nat.lt_succ_of_lt his), + Array.getElem_push_lt his, ← getElem!_pos (rootState n k).1 i his] + exact hroot i hik + · have hieq : i = k+1 := by omega + subst i + simpa [rootStep, getElem!_pos, ← hrs, Array.getElem_push_eq] using hnew 0 h0 + · intro j hj + have hj' : j+1 < (rootState n k).2.size := by omega + have h := hnew (j+1) hj' + simp only [rootStep] + rw [getElem!_pos _ _ (by simp [hls]; omega), Array.getElem_extract] + have hm : j+1 < ((rootState n k).2.map + (fun x => kmul x (x ^^^ (rootState n k).1[k]!))).size := by simpa using hj' + simpa only [getElem!_pos ((rootState n k).2.map + (fun x => kmul x (x ^^^ (rootState n k).1[k]!))) (j+1) hm, + Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using h + +/-- Every diagonal value produced by the actual root-table loop is the +mathematical subspace polynomial at the actual bit-basis vector. -/ +theorem subspaceRoots_map (f : BaseRepresentation F) (n i : Nat) (hi : i < n+1) : + f.map (subspaceRoots n)[i]! = + (subspace (bitBasis f.map) i).eval (bitBasis f.map i) := by + have he : subspaceRoots n = (rootState n n).1 := by + unfold subspaceRoots + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + rfl + rw [he] + exact (rootState_invariant f n n le_rfl).2.2.1 i hi + +private def normalizedStep (roots : Array K) (state : Array K × K) (i : Nat) : + Array K × K := + (state.1.push (kmul state.2 (kinv roots[i]!)), kmul state.2 (state.2 ^^^ roots[i]!)) + +private def normalizedState (n : Nat) (x : K) (k : Nat) : Array K × K := + (List.range k).foldl (normalizedStep (subspaceRoots n)) (#[], x) + +private theorem normalizedState_invariant (f : BaseRepresentation F) (n : Nat) (x : K) + (k : Nat) (hk : k ≤ n) : + (normalizedState n x k).1.size = k ∧ + f.map (normalizedState n x k).2 = (subspace (bitBasis f.map) k).eval (f.map x) ∧ + ∀ i < k, f.map (normalizedState n x k).1[i]! = + (normalized (bitBasis f.map) i).eval (f.map x) := by + induction k with + | zero => simp [normalizedState, subspace] + | succ k ih => + obtain ⟨hs, hx, hout⟩ := ih (by omega) + have he : normalizedState n x (k+1) = + normalizedStep (subspaceRoots n) (normalizedState n x k) k := by + simp [normalizedState, List.range_succ] + rw [he] + constructor + · simp [normalizedStep, hs] + constructor + · simp only [normalizedStep, f.mul, f.add, hx, subspaceRoots_map f n k (by omega)] + simp [subspace] + · intro i hi + by_cases hik : i < k + · simp only [normalizedStep] + have his : i < (normalizedState n x k).1.size := by omega + rw [getElem!_pos _ _ (by simpa using Nat.lt_succ_of_lt his), + Array.getElem_push_lt his, ← getElem!_pos (normalizedState n x k).1 i his] + exact hout i hik + · have hieq : i = k := by omega + subst i + simp only [normalizedStep] + rw [getElem!_pos _ _ (by simp [hs])] + have hp := Array.getElem_push_eq (xs := (normalizedState n x k).1) + (x := kmul (normalizedState n x k).2 (kinv (subspaceRoots n)[k]!)) + simp only [hs] at hp + rw [hp, f.mul, f.inv, hx, subspaceRoots_map f n k (by omega)] + simp [normalized, mul_comm] + +/-- Exact scalar-by-scalar refinement of the executable normalization loop. -/ +theorem normalizedSubspaces_map (f : BaseRepresentation F) (n : Nat) (x : K) + (i : Nat) (hi : i < n) : + f.map (normalizedSubspaces n x)[i]! = + (normalized (bitBasis f.map) i).eval (f.map x) := by + have he : normalizedSubspaces n x = (normalizedState n x n).1 := by + unfold normalizedSubspaces + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + rfl + rw [he] + exact (normalizedState_invariant f n x n le_rfl).2.2 i hi + +end +end Whir.AdditiveCode diff --git a/verification/whir/Whir/BaseCandidateDescent.lean b/verification/whir/Whir/BaseCandidateDescent.lean new file mode 100644 index 000000000..53156b8b3 --- /dev/null +++ b/verification/whir/Whir/BaseCandidateDescent.lean @@ -0,0 +1,277 @@ +import Whir.AdditiveCode +import Whir.MutualAgreement +import Whir.FieldEquivalence +import Mathlib.LinearAlgebra.Lagrange + +/-! Initial candidates cannot acquire extension-field coefficients or nonzero padded +lanes: enough authenticated base-field evaluations force polynomial descent. +The novel-basis corollaries use the actual additive encoder polynomial. -/ +namespace Whir.BaseCandidateDescent + +open Polynomial Classical +open scoped BigOperators +noncomputable section + +variable {K E I : Type*} [Field K] [Field E] + +/-- Interpolate the committed values over the base field, then use polynomial +uniqueness over the extension. No decoder or descent property is assumed. -/ +theorem polynomial_descent (embed : K →+* E) (s : Finset I) + (domain values : I → K) (hinj : Set.InjOn domain s) + (k : ℕ) (p : E[X]) (hp : p.degree < k) (hsize : k ≤ s.card) + (hmatch : ∀ i ∈ s, p.eval (embed (domain i)) = embed (values i)) : + ∃ q : K[X], q.degree < k ∧ q.map embed = p := by + classical + let q := Lagrange.interpolate s domain values + have heq : p = q.map embed := by + apply Polynomial.eq_of_degrees_lt_of_eval_index_eq s + (fun i hi j hj hij => hinj hi hj (embed.injective hij)) + (hp.trans_le (by exact_mod_cast hsize)) + · simpa [q] using Lagrange.degree_interpolate_lt values hinj + · intro i hi + rw [hmatch i hi, Polynomial.eval_map_apply] + exact congrArg embed (Lagrange.eval_interpolate_at_node values hinj hi).symm + refine ⟨q, ?_, heq.symm⟩ + simpa [heq] using hp + +/-- Zero padding is forced by the same root bound, including dimension zero. -/ +theorem polynomial_zero (embed : K →+* E) (s : Finset I) + (domain : I → K) (hinj : Set.InjOn domain s) + (k : ℕ) (p : E[X]) (hp : p.degree < k) (hsize : k ≤ s.card) + (hzero : ∀ i ∈ s, p.eval (embed (domain i)) = 0) : p = 0 := by + exact Polynomial.eq_zero_of_degree_lt_of_eval_index_eq_zero s + (fun i hi j hj hij => hinj hi hj (embed.injective hij)) + (hp.trans_le (by exact_mod_cast hsize)) hzero + +/-- The restriction applies to the exact `ofFn` coefficient interpretation of +`MutualAgreement.rsCode` and `CodingBounds`, not a separately postulated decoder. -/ +theorem coefficients_descent (embed : K →+* E) (s : Finset I) + (domain values : I → K) (hinj : Set.InjOn domain s) + (k : ℕ) (a : Fin k → E) (hsize : k ≤ s.card) + (hmatch : ∀ i ∈ s, (Polynomial.ofFn k a).eval (embed (domain i)) = + embed (values i)) : + ∃ b : Fin k → K, ∀ j, embed (b j) = a j := by + obtain ⟨q, _, hq⟩ := polynomial_descent embed s domain values hinj k + (Polynomial.ofFn k a) (Polynomial.ofFn_degree_lt a) hsize hmatch + refine ⟨fun j => q.coeff j, fun j => ?_⟩ + have h := congrArg (fun p : E[X] => p.coeff j) hq + simpa [Polynomial.ofFn_coeff_eq_val_of_lt a j.isLt] using h + +theorem coefficients_zero (embed : K →+* E) (s : Finset I) + (domain : I → K) (hinj : Set.InjOn domain s) + (k : ℕ) (a : Fin k → E) (hsize : k ≤ s.card) + (hzero : ∀ i ∈ s, (Polynomial.ofFn k a).eval (embed (domain i)) = 0) : + ∀ j, a j = 0 := by + have hp := polynomial_zero embed s domain hinj k (Polynomial.ofFn k a) + (Polynomial.ofFn_degree_lt a) hsize hzero + intro j + have h := congrArg (fun p : E[X] => p.coeff j) hp + simpa [Polynomial.ofFn_coeff_eq_val_of_lt a j.isLt] using h + +/-- Every close RS word has base-field coefficients on the entire domain, not +just on its agreement set. -/ +theorem rsCode_descent (embed : K →+* E) (s : Finset I) + (domain values : I → K) (hinj : Set.InjOn domain s) + (k : ℕ) (w : I → E) + (hw : w ∈ MutualAgreement.rsCode (fun i => embed (domain i)) k) + (hsize : k ≤ s.card) (hmatch : ∀ i ∈ s, w i = embed (values i)) : + ∃ b : Fin k → K, ∀ i, + w i = embed ((Polynomial.ofFn k b).eval (domain i)) := by + obtain ⟨p, hp, heval⟩ := (MutualAgreement.mem_rsCode _ _ _).mp hw + obtain ⟨q, hq, hmap⟩ := polynomial_descent embed s domain values hinj k p hp hsize + (fun i hi => (heval i).trans (hmatch i hi)) + have hmem : (fun i => q.eval (domain i)) ∈ MutualAgreement.rsCode domain k := + (MutualAgreement.mem_rsCode _ _ _).mpr ⟨q, hq, fun _ => rfl⟩ + obtain ⟨b, hb⟩ := (MutualAgreement.mem_rsCode_iff_coefficients _ _ _).mp hmem + refine ⟨b, fun i => ?_⟩ + rw [hb i, ← Polynomial.eval_map_apply, hmap, heval] + +open AdditiveCode + +@[simp] theorem map_subspace (embed : K →+* E) (v : ℕ → K) (n : ℕ) : + (subspace v n).map embed = subspace (fun i => embed (v i)) n := by + induction n with + | zero => simp [subspace] + | succ n ih => + simp only [subspace, Polynomial.map_mul, Polynomial.map_add, Polynomial.map_C] + rw [← Polynomial.eval_map_apply, ih] + +@[simp] theorem map_normalized (embed : K →+* E) (v : ℕ → K) (n : ℕ) : + (normalized v n).map embed = normalized (fun i => embed (v i)) n := by + simp only [normalized, Polynomial.map_mul, Polynomial.map_C, map_inv₀] + rw [← Polynomial.eval_map_apply, map_subspace] + +@[simp] theorem map_novel (embed : K →+* E) (v : ℕ → K) (n j : ℕ) : + (novel v n j).map embed = novel (fun i => embed (v i)) n j := by + induction n generalizing j with + | zero => simp [novel] + | succ n ih => + simp only [novel] + split_ifs <;> simp [ih] + +@[simp] theorem map_polynomial (embed : K →+* E) (v : ℕ → K) (n : ℕ) + (a : Fin (2^n) → K) : + (polynomial v n a).map embed = + polynomial (fun i => embed (v i)) n (fun j => embed (a j)) := by + simp [polynomial, Polynomial.map_sum] + +/-- Binary independence is preserved by the field embedding; hence the +extension novel-basis decoder is proved injective, never assumed injective. -/ +theorem independent_map (embed : K →+* E) (v : ℕ → K) (n : ℕ) + (h : Independent v n) : Independent (fun i => embed (v i)) n := by + have hspan (m : ℕ) : binarySpan (fun i => embed (v i)) m = embed '' binarySpan v m := by + induction m with + | zero => simp [binarySpan] + | succ m ih => + rw [binarySpan, ih, binarySpan, Set.image_union] + congr 1 + ext x + simp only [Set.mem_image] + constructor + · rintro ⟨y, ⟨z, hz, rfl⟩, rfl⟩ + exact ⟨z + v m, ⟨z, hz, rfl⟩, map_add embed z (v m)⟩ + · rintro ⟨y, ⟨z, hz, rfl⟩, rfl⟩ + exact ⟨embed z, ⟨z, hz, rfl⟩, (map_add embed z (v m)).symm⟩ + intro i hi hm + rw [hspan] at hm + obtain ⟨x, hx, he⟩ := hm + exact h i hi (embed.injective he ▸ hx) + +/-- A close initial novel-basis candidate is the embedding of a base-field +message. This is the message to which concrete GF2^64 bit decomposition applies. -/ +theorem novel_coefficients_descent [CharP K 2] [CharP E 2] + (embed : K →+* E) (v : ℕ → K) (n : ℕ) (hv : Independent v n) + (s : Finset I) (domain values : I → K) (hinj : Set.InjOn domain s) + (a : Fin (2^n) → E) (hsize : 2^n ≤ s.card) + (hmatch : ∀ i ∈ s, + (polynomial (fun j => embed (v j)) n a).eval (embed (domain i)) = + embed (values i)) : + ∃ b : Fin (2^n) → K, ∀ j, embed (b j) = a j := by + have hvE := independent_map embed v n hv + obtain ⟨q, hq, heq⟩ := polynomial_descent embed s domain values hinj (2^n) + (polynomial (fun j => embed (v j)) n a) + (by simpa using polynomial_degree_lt hvE a) hsize hmatch + obtain ⟨b, hb⟩ := (polynomial_surjective hv q).mpr (by simpa using hq) + have he : (fun j => embed (b j)) = a := by + apply polynomial_injective hvE + rw [← map_polynomial, hb, heq] + exact ⟨b, fun j => congrFun he j⟩ + +theorem novel_coefficients_zero [CharP K 2] [CharP E 2] + (embed : K →+* E) (v : ℕ → K) (n : ℕ) (hv : Independent v n) + (s : Finset I) (domain : I → K) (hinj : Set.InjOn domain s) + (a : Fin (2^n) → E) (hsize : 2^n ≤ s.card) + (hzero : ∀ i ∈ s, + (polynomial (fun j => embed (v j)) n a).eval (embed (domain i)) = 0) : + ∀ j, a j = 0 := by + have hvE := independent_map embed v n hv + have hp := polynomial_zero embed s domain hinj (2^n) + (polynomial (fun j => embed (v j)) n a) + (by simpa using polynomial_degree_lt hvE a) hsize hzero + have ha : a = 0 := polynomial_injective hvE (by simpa [polynomial] using hp) + intro j + exact congrFun ha j + +/-- The Johnson threshold implies strictly more than the degree bound. -/ +theorem johnson_threshold_gt_degree (N D t : ℕ) (hD : D ≤ N) + (hthreshold : N * D < t^2) : D < t := by + by_contra h + have ht : t ≤ D := by omega + nlinarith + +/-- Thus any agreement set of size at least `t > D` determines all `D+1` +coefficients, including base-field and zero-padding restrictions above. -/ +theorem enough_matches (s : Finset I) (D t : ℕ) + (ht : D < t) (hclose : t ≤ s.card) : D + 1 ≤ s.card := by omega + +/-- Same-set interleaved candidates restrict lane by lane. The threshold is +strictly above the encoder's degree bound; absent lanes are forced to zero. -/ +theorem interleaved_novel_restriction {L : Type*} [CharP K 2] [CharP E 2] + (embed : K →+* E) (v : ℕ → K) (n : ℕ) (hv : Independent v n) + (s : Finset I) (domain : I → K) (hinj : Set.InjOn domain s) + (values : L → I → K) (active : Set L) + (hpadding : ∀ l, l ∉ active → ∀ i ∈ s, values l i = 0) + (a : L → Fin (2^n) → E) (t : ℕ) + (ht : 2^n - 1 < t) (hclose : t ≤ s.card) + (hmatch : ∀ l i, i ∈ s → + (polynomial (fun j => embed (v j)) n (a l)).eval (embed (domain i)) = + embed (values l i)) : + ∃ b : L → Fin (2^n) → K, + (∀ l j, embed (b l j) = a l j) ∧ + (∀ l, l ∉ active → ∀ j, b l j = 0) := by + have hsize : 2^n ≤ s.card := by omega + have hd (l : L) := novel_coefficients_descent embed v n hv s domain (values l) + hinj (a l) hsize (hmatch l) + choose b hb using hd + refine ⟨b, hb, fun l hl j => ?_⟩ + have hz := novel_coefficients_zero embed v n hv s domain hinj (a l) hsize + (fun i hi => by rw [hmatch l i hi, hpadding l hl i hi, map_zero]) + apply embed.injective + rw [hb, hz, map_zero] + +/-- Reify the descended message in the actual base-word representation. Only +surjectivity of the representation is needed; no candidate decoder injectivity +is assumed. In particular a checked GF2^64 representation gives GF2^64 words, +and every absent lane is literally the zero word before bit decomposition. -/ +theorem word_candidates_restrict {L W : Type*} [Zero W] [CharP K 2] [CharP E 2] + (embed : K →+* E) (repr : W → K) (hrepr : Function.Surjective repr) + (hzero : repr 0 = 0) + (v : ℕ → K) (n : ℕ) (hv : Independent v n) + (s : Finset I) (domain : I → K) (hinj : Set.InjOn domain s) + (values : L → I → K) (active : Set L) + (hpadding : ∀ l, l ∉ active → ∀ i ∈ s, values l i = 0) + (a : L → Fin (2^n) → E) (t : ℕ) + (ht : 2^n - 1 < t) (hclose : t ≤ s.card) + (hmatch : ∀ l i, i ∈ s → + (polynomial (fun j => embed (v j)) n (a l)).eval (embed (domain i)) = + embed (values l i)) : + ∃ words : L → Fin (2^n) → W, + (∀ l j, embed (repr (words l j)) = a l j) ∧ + (∀ l, l ∉ active → ∀ j, words l j = 0) := by + obtain ⟨b, hb, hpad⟩ := interleaved_novel_restriction embed v n hv s domain hinj + values active hpadding a t ht hclose hmatch + choose word hword using fun l j => hrepr (b l j) + refine ⟨fun l j => if l ∈ active then word l j else 0, ?_, ?_⟩ + · intro l j + dsimp only + split_ifs with hl + · rw [hword, hb] + · rw [hzero, ← hpad l hl j, hb] + · intro l hl j + simp [hl] + +/-- Concrete restriction to GF2^64 machine words. All field-tower and word +representation obligations are discharged by the checked exact field model. -/ +theorem actual_word_candidates_restrict {L : Type*} + (v : ℕ → Concrete.K) (n : ℕ) + (hv : Independent (fun j => FieldModel.toBaseQuotient (v j)) n) + (s : Finset I) (domain : I → Concrete.K) (hinj : Set.InjOn domain s) + (values : L → I → Concrete.K) (active : Set L) + (hpadding : ∀ l, l ∉ active → ∀ i ∈ s, values l i = 0) + (a : L → Fin (2^n) → Concrete.E) (t : ℕ) + (ht : 2^n - 1 < t) (hclose : t ≤ s.card) + (hmatch : ∀ l i, i ∈ s → + (polynomial (fun j => Concrete.E.ofK (v j)) n (a l)).eval + (Concrete.E.ofK (domain i)) = Concrete.E.ofK (values l i)) : + ∃ words : L → Fin (2^n) → Concrete.K, + (∀ l j, Concrete.E.ofK (words l j) = a l j) ∧ + (∀ l, l ∉ active → ∀ j, words l j = 0) := by + have h := word_candidates_restrict FieldModel.baseEmbedding + FieldModel.toBaseQuotient FieldModel.toBaseQuotient_bijective.2 + FieldModel.toBaseQuotient_zero + (fun j => FieldModel.toBaseQuotient (v j)) n hv s + (fun i => FieldModel.toBaseQuotient (domain i)) + (fun i hi j hj he => hinj hi hj (FieldModel.toBaseQuotient_bijective.1 he)) + (fun l i => FieldModel.toBaseQuotient (values l i)) active + (fun l hl i hi => by rw [hpadding l hl i hi, FieldModel.toBaseQuotient_zero]) + a t ht hclose (by simpa only [FieldModel.baseEmbedding_word] using hmatch) + simpa only [FieldModel.baseEmbedding_word] using h + +end +end Whir.BaseCandidateDescent + +#print axioms Whir.BaseCandidateDescent.polynomial_descent +#print axioms Whir.BaseCandidateDescent.rsCode_descent +#print axioms Whir.BaseCandidateDescent.novel_coefficients_zero +#print axioms Whir.BaseCandidateDescent.word_candidates_restrict +#print axioms Whir.BaseCandidateDescent.actual_word_candidates_restrict diff --git a/verification/whir/Whir/BatchingRefinement.lean b/verification/whir/Whir/BatchingRefinement.lean new file mode 100644 index 000000000..e660e024c --- /dev/null +++ b/verification/whir/Whir/BatchingRefinement.lean @@ -0,0 +1,355 @@ +import Whir.OperationalRefinement +import Whir.QueryRefinement +import Whir.Soundness +import Whir.FieldEquality + +/-! The actual adjacent OOD/query batch uses one lambda. Its discrepancy is a +polynomial with disjoint coefficient positions; transmitted intros do not enter +claim/weight equality. Concrete identities use the checked ring bridge only. +Root counting is stated generically for a field, separately from these identities. -/ +namespace Whir.BatchingRefinement +open Concrete Protocol ArrayAlgebra ArrayLayout QueryRefinement +open scoped BigOperators + +/-- The discrepancy used by batching, without any pending-message assumption. -/ +def discrepancy {R : Type*} [CommRing R] [Inhabited R] + (f : Array R) (s : VerifierState R) : R := dot f s.weight - s.claim + +theorem discrepancy_batch {R : Type*} [CommRing R] [Inhabited R] + (f basis : Array R) (s : VerifierState R) (value scale : R) (intro : Message R) + (hs : s.weight.size = f.size) (hb : basis.size = f.size) : + discrepancy f (s.batch basis value scale intro) = + discrepancy f s + scale * (dot f basis - value) := by + unfold discrepancy + simp only [VerifierState.batch] + rw [dot_weightGlue f s.weight basis scale hs hb] + ring + +private theorem runSteps_add {S : Type*} (step : Nat → S → S) + (a b start : Nat) (s : S) : + runSteps step (a+b) start s = runSteps step b (start+a) (runSteps step a start s) := by + induction a generalizing start s with + | zero => simp [runSteps] + | succ a ih => + simpa [runSteps, Nat.succ_add, Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using + ih (start+1) (step start s) + +theorem runSteps_succ_last {S : Type*} (step : Nat → S → S) (count : Nat) (s : S) : + runSteps step (count+1) 0 s = step count (runSteps step count 0 s) := by + rw [runSteps_add] + simp [runSteps] + +private theorem power_loop (a : E) (count : Nat) : + (List.range count).foldl (fun s (_ : Nat) => (s.1.push s.2, s.2 * a)) + ((#[] : Array E), (1 : E)) = + (tab count (fun j => a^j), a^count) := by + induction count with + | zero => simp [tab] + | succ count ih => + rw [List.range_succ, List.foldl_append, ih] + simp only [List.foldl_cons, List.foldl_nil, pow_succ] + congr 1 + apply Array.toList_inj.mp + simp [tab, List.range_succ] + +theorem powers_eq_tab (a : E) (count : Nat) : + powers a count = tab count (fun j => a^j) := by + unfold powers + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + change ((List.range count).foldl + (fun s (_ : Nat) => (s.1.push s.2, s.2 * a)) ((#[] : Array E), (1 : E))).1 = _ + rw [power_loop] + +@[simp] theorem size_powers (a : E) (count : Nat) : (powers a count).size = count := by + simp [powers_eq_tab] + +theorem get_powers (a : E) (count j : Nat) (hj : j < count) : + (powers a count)[j]! = a^j := by + rw [powers_eq_tab, getElem!_tab _ _ _ hj] + +def oodError (f : Array E) (cs : LevelChallenges) (p : LevelProof) (j : Nat) : E := + dot f (eqTable cs.oodPoints[j]!) - p.oods[j]!.value + +def queryError (f : Array E) (n : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (base : Bool) (j : Nat) : E := + dot f (column n qs[j]!) - + dot (if base then p.rows[j]!.reverse else p.rows[j]!) (eqTable cs.folds) + +/-- Prefix induction for the actual OOD kernel, including its running scalar. +No truth assumption is made about an OOD value or its transmitted intro. -/ +theorem ood_prefix (f : Array E) (cs : LevelChallenges) (p : LevelProof) + (s : VerifierState E) (count : Nat) (hs : s.weight.size = f.size) + (shape : ∀ j < count, (eqTable cs.oodPoints[j]!).size = f.size) : + let out := runSteps (oodStep cs p) count 0 (s, E.one) + out.1.weight.size = f.size ∧ out.2 = cs.lambda^count ∧ + discrepancy f out.1 = discrepancy f s + + ∑ j ∈ Finset.range count, cs.lambda^(j+1) * oodError f cs p j := by + induction count with + | zero => simpa [runSteps, ← FieldModel.E_one_def] using hs + | succ count ih => + obtain ⟨hw, scalar, err⟩ := ih (by intro j hj; exact shape j (by omega)) + dsimp only + rw [runSteps_succ_last] + simp only [oodStep] + refine ⟨?_, ?_, ?_⟩ + · simpa only [VerifierState.batch, size_weightGlue] using hw + · rw [scalar, pow_succ] + · rw [discrepancy_batch _ _ _ _ _ _ hw (shape count (by omega))] + rw [scalar, err, Finset.sum_range_succ] + simp only [oodError, pow_succ] + ring + +/-- The authenticated-query discrepancy expands per row using the actual dense +column and enforced kernels; honesty of those rows is not assumed. -/ +theorem query_error_sum (f : Array E) (n : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (base : Bool) + (shape : f.size = 2^n) (rows : p.rows.size = qs.size) : + dot f (induced n qs (powers cs.lambda qs.size)) - + enforced p.rows cs.folds (powers cs.lambda qs.size) base = + ∑ j ∈ Finset.range qs.size, cs.lambda^j * queryError f n cs p qs base j := by + have hd := dot_inducedColumns f (qs.map (column n)) (powers cs.lambda qs.size) + (by + intro j hj + have hj' : j < qs.size := by simpa using hj + simp [getElem!_pos, hj', shape]) + rw [shape] at hd + rw [induced, hd, enforced, tab_sum, rows] + simp only [Array.size_map] + rw [← Finset.sum_sub_distrib] + apply Finset.sum_congr rfl + intro j hj + have hj' := Finset.mem_range.mp hj + rw [get_powers _ _ _ hj'] + simp only [queryError] + have hm : (qs.map (column n))[j]! = column n qs[j]! := by + simp [getElem!_pos, hj'] + rw [hm] + ring + +/-- Exact final discrepancy after both adjacent batches, with a single lambda. +In particular a lambda-dependent `p.intro` changes neither side. -/ +theorem batch_discrepancy (f : Array E) (n i : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (s : VerifierState E) + (shape : f.size = 2^n) (hs : s.weight.size = f.size) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = f.size) + (rows : p.rows.size = qs.size) : + discrepancy f (queryBatch n i cs p qs (oodBatch cs p s)) = + discrepancy f s + + (∑ j ∈ Finset.range p.oods.size, cs.lambda^(j+1) * oodError f cs p j) + + ∑ j ∈ Finset.range qs.size, + cs.lambda^(p.oods.size+1+j) * queryError f n cs p qs (i == 0) j := by + obtain ⟨hw, scalar, err⟩ := ood_prefix f cs p s p.oods.size hs oods + change (oodBatch cs p s).1.weight.size = f.size at hw + change (oodBatch cs p s).2 = cs.lambda^p.oods.size at scalar + change discrepancy f (oodBatch cs p s).1 = _ at err + unfold queryBatch + rw [discrepancy_batch _ _ _ _ _ _ hw (by simp [shape])] + rw [query_error_sum f n cs p qs (i == 0) shape rows, err, scalar] + rw [Finset.mul_sum] + congr 1 + apply Finset.sum_congr rfl + intro j _ + rw [pow_add, pow_succ] + ring + +open Polynomial + +section Polynomial +variable {R : Type*} [CommRing R] + +private noncomputable def coefficientBlock (start count : Nat) (a : Nat → R) : R[X] := + ∑ j ∈ Finset.range count, monomial (start+j) (a j) + +private theorem coefficientBlock_at (start count j : Nat) (a : Nat → R) (hj : j < count) : + (coefficientBlock start count a).coeff (start+j) = a j := by + simp only [coefficientBlock, finsetSum_coeff, coeff_monomial] + rw [Finset.sum_eq_single j] + · simp + · intro b _ hne + simp [hne] + · simp [hj] + +private theorem coefficientBlock_outside (start count i : Nat) (a : Nat → R) + (outside : i < start ∨ start+count ≤ i) : + (coefficientBlock start count a).coeff i = 0 := by + simp only [coefficientBlock, finsetSum_coeff, coeff_monomial] + apply Finset.sum_eq_zero + intro j hj + have hj' := Finset.mem_range.mp hj + have hne : start+j ≠ i := by omega + simp [hne] + +private theorem coefficientBlock_degree (start count d : Nat) (a : Nat → R) + (bound : ∀ j < count, start+j ≤ d) : + (coefficientBlock start count a).natDegree ≤ d := by + apply natDegree_sum_le_of_forall_le + intro j hj + exact (natDegree_monomial_le _).trans (bound j (Finset.mem_range.mp hj)) + +/-- Distinct monomial slots for the residual, each OOD, and each query error. -/ +noncomputable def batchPolynomial (m k : Nat) (residual : R) (ood query : Nat → R) : R[X] := + C residual + coefficientBlock 1 m ood + coefficientBlock (m+1) k query + +theorem batchPolynomial_eval (m k : Nat) (residual : R) (ood query : Nat → R) (r : R) : + (batchPolynomial m k residual ood query).eval r = + residual + (∑ j ∈ Finset.range m, r^(j+1) * ood j) + + ∑ j ∈ Finset.range k, r^(m+1+j) * query j := by + simp [batchPolynomial, coefficientBlock, eval_finsetSum, Nat.add_comm, mul_comm] + +theorem batchPolynomial_coeff_zero (m k : Nat) (residual : R) (ood query : Nat → R) : + (batchPolynomial m k residual ood query).coeff 0 = residual := by + simp only [batchPolynomial, coeff_add, coeff_C_zero] + rw [coefficientBlock_outside _ _ _ _ (Or.inl (by omega)), + coefficientBlock_outside _ _ _ _ (Or.inl (by omega))] + simp + +theorem batchPolynomial_coeff_ood (m k j : Nat) (residual : R) (ood query : Nat → R) + (hj : j < m) : + (batchPolynomial m k residual ood query).coeff (j+1) = ood j := by + simp only [batchPolynomial, coeff_add] + rw [show j+1 = 1+j by omega, coefficientBlock_at _ _ _ _ hj, + coefficientBlock_outside _ _ _ _ (Or.inl (by omega))] + simp [coeff_C] + +theorem batchPolynomial_coeff_query (m k j : Nat) (residual : R) (ood query : Nat → R) + (hj : j < k) : + (batchPolynomial m k residual ood query).coeff (m+1+j) = query j := by + simp only [batchPolynomial, coeff_add] + rw [coefficientBlock_at _ _ _ _ hj, + coefficientBlock_outside _ _ _ _ (Or.inr (by omega))] + simp [coeff_C] + +theorem batchPolynomial_degree (m k : Nat) (residual : R) (ood query : Nat → R) : + (batchPolynomial m k residual ood query).natDegree ≤ m+k := by + apply (natDegree_add_le _ _).trans + apply max_le + · apply (natDegree_add_le _ _).trans + apply max_le + · simp + · exact coefficientBlock_degree 1 m (m+k) ood (by intro j hj; omega) + · exact coefficientBlock_degree (m+1) k (m+k) query (by intro j hj; omega) + +/-- Any false constituent prevents the shared-lambda error polynomial from being +identically zero, including when the incoming residual discrepancy is zero. -/ +theorem batchPolynomial_ne_zero (m k : Nat) (residual : R) (ood query : Nat → R) + (bad : residual ≠ 0 ∨ (∃ j < m, ood j ≠ 0) ∨ (∃ j < k, query j ≠ 0)) : + batchPolynomial m k residual ood query ≠ 0 := by + intro h + rcases bad with hr | ⟨j, hj, he⟩ | ⟨j, hj, he⟩ + · apply hr + have hc := batchPolynomial_coeff_zero m k residual ood query + simpa [h] using hc.symm + · apply he + have hc := batchPolynomial_coeff_ood m k j residual ood query hj + simpa [h] using hc.symm + · apply he + have hc := batchPolynomial_coeff_query m k j residual ood query hj + simpa [h] using hc.symm +end Polynomial + +/-- This polynomial is fixed by the pre-lambda state, OOD values, and sampled +rows. Its definition does not inspect lambda or any transmitted intro. -/ +noncomputable def errorPolynomial (f : Array E) (n i : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (s : VerifierState E) : E[X] := + batchPolynomial p.oods.size qs.size (discrepancy f s) + (oodError f cs p) (queryError f n cs p qs (i == 0)) + +theorem batch_discrepancy_eq_eval (f : Array E) (n i : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (s : VerifierState E) + (shape : f.size = 2^n) (hs : s.weight.size = f.size) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = f.size) + (rows : p.rows.size = qs.size) : + discrepancy f (queryBatch n i cs p qs (oodBatch cs p s)) = + (errorPolynomial f n i cs p qs s).eval cs.lambda := by + rw [errorPolynomial, batchPolynomial_eval] + exact batch_discrepancy f n i cs p qs s shape hs oods rows + +theorem errorPolynomial_degree (f : Array E) (n i : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (s : VerifierState E) : + (errorPolynomial f n i cs p qs s).natDegree ≤ p.oods.size+qs.size := + batchPolynomial_degree _ _ _ _ _ + +theorem errorPolynomial_ne_zero (f : Array E) (n i : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (s : VerifierState E) + (bad : discrepancy f s ≠ 0 ∨ + (∃ j < p.oods.size, oodError f cs p j ≠ 0) ∨ + (∃ j < qs.size, queryError f n cs p qs (i == 0) j ≠ 0)) : + errorPolynomial f n i cs p qs s ≠ 0 := + batchPolynomial_ne_zero _ _ _ _ _ bad + +/-- The polynomial is chosen before lambda, even when the query intro is chosen +after seeing that same lambda. This is definitional, not an independence axiom. -/ +theorem errorPolynomial_lambda_intro (f : Array E) (n i : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (s : VerifierState E) (r : E) (intro : Message E) : + errorPolynomial f n i {cs with lambda := r} {p with intro := intro} qs s = + errorPolynomial f n i cs p qs s := rfl + +/-- Uniform-in-lambda operational identity for any adaptive query-intro function. +The rows and OOD values, not the pending intro, determine all coefficients. -/ +theorem batch_discrepancy_vary_lambda (f : Array E) (n i : Nat) (cs : LevelChallenges) + (p : LevelProof) (qs : Array Nat) (s : VerifierState E) (intro : E → Message E) + (shape : f.size = 2^n) (hs : s.weight.size = f.size) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = f.size) + (rows : p.rows.size = qs.size) (r : E) : + discrepancy f (queryBatch n i {cs with lambda := r} {p with intro := intro r} qs + (oodBatch {cs with lambda := r} {p with intro := intro r} s)) = + (errorPolynomial f n i cs p qs s).eval r := by + exact batch_discrepancy_eq_eval f n i {cs with lambda := r} + {p with intro := intro r} qs s shape hs oods rows + +/-- Authentication fixes even adversarially supplied rows to immutable oracle +lookups. Therefore the query-error coefficients cannot depend on lambda through +the prover's row messages. Duplicated query indices are retained. -/ +theorem authenticated_rows_eq (oracle : Oracle) (qs : Array Nat) (p : LevelProof) + (rows : p.rows.size = qs.size) + (auth : ∀ j, j < qs.size → (p.rows[j]! != oracle[qs[j]!]!) = false) : + p.rows = qs.map (fun q => oracle[q]!) := by + apply Array.ext + · simpa using rows + · intro j hj hk + have hq : j < qs.size := by simpa using hk + have he : p.rows[j]! = oracle[qs[j]!]! := by simpa using auth j hq + simpa [getElem!_pos, hj, hq] using he + +/-- The exact actual authentication loop supplies canonical rows. -/ +theorem checked_rows_eq (oracle : Oracle) (qs : Array Nat) (p : LevelProof) + (rows : p.rows.size = qs.size) + (checked : runChecked (authenticateRow oracle qs p) qs.size 0 () = .ok ()) : + p.rows = qs.map (fun q => oracle[q]!) := + authenticated_rows_eq oracle qs p rows + ((OperationalRefinement.authentication_ok_iff oracle qs p).mp checked) + +/-- Even lambda-dependent rows and query intros cannot alter the fixed polynomial +on authenticated executions. The only row premise is the actual Boolean lookup +check, not an algebraic batching-correctness assertion. -/ +theorem authenticated_batch_vary_lambda (f : Array E) (n i : Nat) + (cs : LevelChallenges) (p : LevelProof) (qs : Array Nat) (oracle : Oracle) + (s : VerifierState E) (rowsAt : E → Oracle) (intro : E → Message E) + (shape : f.size = 2^n) (hs : s.weight.size = f.size) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = f.size) + (r : E) (rows : (rowsAt r).size = qs.size) + (auth : ∀ j, j < qs.size → ((rowsAt r)[j]! != oracle[qs[j]!]!) = false) : + discrepancy f + (queryBatch n i {cs with lambda := r} {p with rows := rowsAt r, intro := intro r} qs + (oodBatch {cs with lambda := r} {p with rows := rowsAt r, intro := intro r} s)) = + (errorPolynomial f n i cs {p with rows := qs.map (fun q => oracle[q]!)} qs s).eval r := by + have hr : rowsAt r = qs.map (fun q => oracle[q]!) := + authenticated_rows_eq oracle qs {p with rows := rowsAt r} rows auth + rw [hr] + exact batch_discrepancy_vary_lambda f n i cs + {p with rows := qs.map (fun q => oracle[q]!)} qs s intro shape hs oods (by simp) r + +/-- Field-generic bridge: concrete operational equality above requires only the +proved ring laws. Root counting additionally requires an actual field instance. -/ +theorem batchPolynomial_root_error {F : Type*} [Field F] [Fintype F] [DecidableEq F] + (m k : Nat) (residual : F) (ood query : Nat → F) + (bad : residual ≠ 0 ∨ (∃ j < m, ood j ≠ 0) ∨ (∃ j < k, query j ≠ 0)) : + Soundness.uniformProb (Finset.univ.filter fun r => + (batchPolynomial m k residual ood query).eval r = 0) ≤ + ((m+k : Nat) : ℚ) / Fintype.card F := + Soundness.root_error _ (batchPolynomial_ne_zero m k residual ood query bad) + (m+k) (batchPolynomial_degree m k residual ood query) + +end Whir.BatchingRefinement diff --git a/verification/whir/Whir/ByteCodec.lean b/verification/whir/Whir/ByteCodec.lean new file mode 100644 index 000000000..02a884e83 --- /dev/null +++ b/verification/whir/Whir/ByteCodec.lean @@ -0,0 +1,301 @@ +import Whir.Concrete +import Whir.FiatShamirGame + +/-! Little-endian codecs of baseline `fiat_shamir/src/merkle.rs:15-37,47-51,62-67` +at `69f5499304a6957f6780c8998999d783bae13302`. The Merkle file is byte-identical +in conditional #552 (`ff6a275304a3b577118b066ddcff83bfafa5998d`). +These are byte encodings, not assumptions about the hash primitive or a +Fiat–Shamir security claim for either transcript version. -/ +namespace Whir.ByteCodec +open Concrete FiatShamirGame + +def encodeNat : (n : Nat) → Nat → (Fin n → Byte) + | 0, _, i => Fin.elim0 i + | n + 1, x, i => Fin.cases ⟨x % 256, Nat.mod_lt _ (by decide)⟩ + (encodeNat n (x / 256)) i + +def decodeNat : (n : Nat) → (Fin n → Byte) → Nat + | 0, _ => 0 + | n + 1, b => (b 0).val + 256 * decodeNat n (fun i => b i.succ) + +theorem decodeNat_lt (n : Nat) (b : Fin n → Byte) : decodeNat n b < 256 ^ n := by + induction n with + | zero => simp [decodeNat] + | succ n ih => + have h := ih (fun i => b i.succ) + have hb := (b 0).isLt + simp only [decodeNat, pow_succ] + omega + +theorem decodeNat_encodeNat (n x : Nat) (h : x < 256 ^ n) : + decodeNat n (encodeNat n x) = x := by + induction n generalizing x with + | zero => simp only [pow_zero] at h; simp [decodeNat]; omega + | succ n ih => + have hd : x / 256 < 256 ^ n := by + apply (Nat.div_lt_iff_lt_mul (by decide)).mpr + simpa [pow_succ] using h + simp only [decodeNat, encodeNat, Fin.cases_zero, Fin.cases_succ] + rw [ih _ hd] + exact Nat.mod_add_div x 256 + +theorem encodeNat_decodeNat (n : Nat) (b : Fin n → Byte) : + encodeNat n (decodeNat n b) = b := by + induction n with + | zero => exact Subsingleton.elim _ _ + | succ n ih => + funext i + refine Fin.cases ?_ (fun j => ?_) i + · apply Fin.ext + simp [encodeNat, decodeNat, Nat.add_mod, Nat.mod_eq_of_lt (b 0).isLt] + · simp only [encodeNat, decodeNat, Fin.cases_succ] + rw [Nat.add_mul_div_left _ _ (by decide)] + rw [Nat.div_eq_of_lt (b 0).isLt, Nat.zero_add] + exact congrFun (ih (fun i => b i.succ)) j + +/-- Byte `i` is exactly the base-256 little-endian digit, not merely an +arbitrary injective representation of the machine word. -/ +theorem encodeNat_byte (n x : Nat) (i : Fin n) : + (encodeNat n x i).val = (x / 256 ^ i.val) % 256 := by + induction n generalizing x with + | zero => exact Fin.elim0 i + | succ n ih => + refine Fin.cases ?_ (fun j => ?_) i + · simp [encodeNat] + · simp only [encodeNat, Fin.cases_succ, Fin.val_succ] + rw [ih] + simp [Nat.div_div_eq_div_mul, pow_succ, Nat.mul_comm] + +def encodeK (x : K) : Fin 8 → Byte := encodeNat 8 x.toNat +def decodeK (b : Fin 8 → Byte) : K := UInt64.ofNat (decodeNat 8 b) + +theorem encodeK_byte (x : K) (i : Fin 8) : + (encodeK x i).val = (x.toNat / 256 ^ i.val) % 256 := + encodeNat_byte 8 x.toNat i + +theorem decodeK_encodeK (x : K) : decodeK (encodeK x) = x := by + unfold decodeK encodeK + rw [decodeNat_encodeNat] + · simp + · exact x.toNat_lt + +theorem encodeK_decodeK (b : Fin 8 → Byte) : encodeK (decodeK b) = b := by + unfold encodeK decodeK + rw [UInt64.toNat_ofNat', Nat.mod_eq_of_lt (show decodeNat 8 b < 2 ^ 64 from decodeNat_lt 8 b)] + exact encodeNat_decodeNat 8 b + +theorem encodeK_injective : Function.Injective encodeK := + Function.LeftInverse.injective decodeK_encodeK + +def encodeE (x : E) : Scalar24 := fun i => + if h : i.val < 8 then encodeK x.c0 ⟨i.val, h⟩ + else if h' : i.val < 16 then encodeK x.c1 ⟨i.val - 8, by omega⟩ + else encodeK x.c2 ⟨i.val - 16, by omega⟩ + +def decodeE (b : Scalar24) : E := + ⟨decodeK (fun i => b ⟨i.val, by omega⟩), + decodeK (fun i => b ⟨i.val + 8, by omega⟩), + decodeK (fun i => b ⟨i.val + 16, by omega⟩)⟩ + +theorem decodeE_encodeE (x : E) : decodeE (encodeE x) = x := by + have h0 : (fun i : Fin 8 => encodeE x ⟨i.val, by omega⟩) = encodeK x.c0 := by + funext i; simp [encodeE, i.isLt] + have h1 : (fun i : Fin 8 => encodeE x ⟨i.val + 8, by omega⟩) = encodeK x.c1 := by + funext i; simp [encodeE, show ¬i.val + 8 < 8 by omega, show i.val + 8 < 16 by omega] + have h2 : (fun i : Fin 8 => encodeE x ⟨i.val + 16, by omega⟩) = encodeK x.c2 := by + funext i; simp [encodeE, show ¬i.val + 16 < 8 by omega, show ¬i.val + 16 < 16 by omega] + simp only [decodeE, h0, h1, h2, decodeK_encodeK] + +theorem encodeE_decodeE (b : Scalar24) : encodeE (decodeE b) = b := by + funext i + unfold encodeE decodeE + split <;> try split + all_goals simp only [encodeK_decodeK] + all_goals congr 1 + all_goals apply Fin.ext; dsimp; omega + +theorem encodeE_injective : Function.Injective encodeE := + Function.LeftInverse.injective decodeE_encodeE + +def pairBytes (p : Digest32 × Digest32) : Fin 64 → Byte := fun i => + if h : i.val < 32 then p.1 ⟨i.val, h⟩ else p.2 ⟨i.val - 32, by omega⟩ + +theorem pairBytes_injective : Function.Injective pairBytes := by + intro a b h + apply Prod.ext + · funext i + have := congrFun h ⟨i.val, by omega⟩ + simpa [pairBytes, i.isLt] using this + · funext i + have := congrFun h ⟨i.val + 32, by omega⟩ + simpa [pairBytes, show ¬ i.val + 32 < 32 by omega] using this + +def hashToScalars (b : Digest32) : E × E := + (⟨decodeK (fun i => b ⟨i.val, by omega⟩), + decodeK (fun i => b ⟨i.val + 8, by omega⟩), 0⟩, + ⟨decodeK (fun i => b ⟨i.val + 16, by omega⟩), + decodeK (fun i => b ⟨i.val + 24, by omega⟩), 0⟩) + +def scalarHalves (p : E × E) : Digest32 := fun i => + if h : i.val < 8 then encodeK p.1.c0 ⟨i.val, h⟩ + else if h' : i.val < 16 then encodeK p.1.c1 ⟨i.val - 8, by omega⟩ + else if h'' : i.val < 24 then encodeK p.2.c0 ⟨i.val - 16, by omega⟩ + else encodeK p.2.c1 ⟨i.val - 24, by omega⟩ + +def scalarsToHash (p : E × E) : Option Digest32 := + if p.1.c2 = 0 ∧ p.2.c2 = 0 then some (scalarHalves p) else none + +theorem scalarsToHash_hashToScalars (b : Digest32) : + scalarsToHash (hashToScalars b) = some b := by + simp only [scalarsToHash, hashToScalars, and_self, ite_true] + congr 1 + funext i + unfold scalarHalves + split <;> try split <;> try split + all_goals simp only [encodeK_decodeK] + all_goals congr 1 + all_goals apply Fin.ext; dsimp; omega + +theorem hashToScalars_scalarHalves (p : E × E) : + hashToScalars (scalarHalves p) = + (⟨p.1.c0, p.1.c1, 0⟩, ⟨p.2.c0, p.2.c1, 0⟩) := by + have h0 : (fun i : Fin 8 => scalarHalves p ⟨i.val, by omega⟩) = encodeK p.1.c0 := by + funext i; simp [scalarHalves, i.isLt] + have h1 : (fun i : Fin 8 => scalarHalves p ⟨i.val + 8, by omega⟩) = encodeK p.1.c1 := by + funext i; simp [scalarHalves, show ¬i.val + 8 < 8 by omega, show i.val + 8 < 16 by omega] + have h2 : (fun i : Fin 8 => scalarHalves p ⟨i.val + 16, by omega⟩) = encodeK p.2.c0 := by + funext i + simp [scalarHalves, show ¬i.val + 16 < 8 by omega, + show ¬i.val + 16 < 16 by omega, show i.val + 16 < 24 by omega] + have h3 : (fun i : Fin 8 => scalarHalves p ⟨i.val + 24, by omega⟩) = encodeK p.2.c1 := by + funext i + simp [scalarHalves, show ¬i.val + 24 < 8 by omega, + show ¬i.val + 24 < 16 by omega, show ¬i.val + 24 < 24 by omega] + simp only [hashToScalars, h0, h1, h2, h3, decodeK_encodeK] + +theorem hashToScalars_scalarsToHash (p : E × E) (b : Digest32) + (accepted : scalarsToHash p = some b) : hashToScalars b = p := by + unfold scalarsToHash at accepted + split at accepted + · rename_i h + cases accepted + rw [hashToScalars_scalarHalves] + rcases p with ⟨⟨a,b,c⟩,⟨d,e,f⟩⟩ + simp only at h + rcases h with ⟨rfl,rfl⟩ + rfl + · contradiction + +theorem scalarsToHash_noncanonical (p : E × E) (h : p.1.c2 ≠ 0 ∨ p.2.c2 ≠ 0) : + scalarsToHash p = none := by + simp only [scalarsToHash] + split + · rename_i hp; rcases h with h | h <;> simp_all + · rfl + +/-- Exact leaf preimage: consecutive little-endian K words, without a tag. -/ +def wordsBytes (words : List K) : List Byte := + words.flatMap (fun x => List.ofFn (encodeK x)) + +theorem wordsBytes_injective : Function.Injective wordsBytes := by + intro a + induction a with + | nil => + intro b h + cases b with + | nil => rfl + | cons x xs => + have := congrArg List.length h + simp [wordsBytes] at this + | cons x xs ih => + intro b h + cases b with + | nil => + have := congrArg List.length h + simp [wordsBytes] at this + | cons y ys => + have first := congrArg (List.take 8) h + have rest := congrArg (List.drop 8) h + have ex : x = y := by + apply encodeK_injective + apply List.ofFn_injective + simpa [wordsBytes, List.take_append] using first + have er : xs = ys := ih (by simpa [wordsBytes, List.drop_append] using rest) + exact congrArg₂ List.cons ex er + +theorem hashToScalars_injective : Function.Injective hashToScalars := by + intro a b h + have := congrArg scalarsToHash h + simpa [scalarsToHash_hashToScalars] using this + +/-- Intermediate WHIR rows (`pcs/src/whir/verify.rs:224-227`) use consecutive +three-word groups, in c0/c1/c2 order, with no lane reversal. These are arbitrary +E elements, not digest halves: a nonzero third word is valid here. -/ +def fieldWords (fields : List E) : List K := + fields.flatMap (fun x => [x.c0,x.c1,x.c2]) + +def wordsToFields : List K → Option (List E) + | [] => some [] + | a :: b :: c :: rest => (wordsToFields rest).map (⟨a,b,c⟩ :: ·) + | _ => none + +theorem wordsToFields_fieldWords (fields : List E) : + wordsToFields (fieldWords fields) = some fields := by + induction fields with + | nil => rfl + | cons x xs ih => + change (wordsToFields (fieldWords xs)).map (x :: ·) = some (x :: xs) + rw [ih] + rfl + +theorem fieldWords_wordsToFields (words : List K) (fields : List E) + (decoded : wordsToFields words = some fields) : fieldWords fields = words := by + induction words using (measure List.length).wf.induction generalizing fields with + | _ words ih => + cases words with + | nil => simp [wordsToFields] at decoded; subst fields; rfl + | cons a ws => + cases ws with + | nil => simp [wordsToFields] at decoded + | cons b ws => + cases ws with + | nil => simp [wordsToFields] at decoded + | cons c rest => + simp only [wordsToFields, Option.map_eq_some_iff] at decoded + obtain ⟨tail,ht,rfl⟩ := decoded + have he := ih rest (by change rest.length < (a :: b :: c :: rest).length; simp; omega) tail ht + change a :: b :: c :: fieldWords tail = a :: b :: c :: rest + rw [he] + +theorem fieldWords_length (fields : List E) : (fieldWords fields).length = 3 * fields.length := by + induction fields with + | nil => rfl + | cons x xs ih => simp [fieldWords] at *; omega + +theorem wordsToFields_length (words : List K) (fields : List E) + (decoded : wordsToFields words = some fields) : words.length = 3 * fields.length := by + rw [← fieldWords_wordsToFields words fields decoded, fieldWords_length] + +theorem wordsToFields_total (words : List K) (width : Nat) + (shape : words.length = 3 * width) : + ∃ fields, wordsToFields words = some fields ∧ fields.length = width := by + induction width generalizing words with + | zero => simp at shape; subst words; exact ⟨[],rfl,rfl⟩ + | succ width ih => + cases words with + | nil => simp at shape + | cons a ws => + cases ws with + | nil => simp at shape; omega + | cons b ws => + cases ws with + | nil => simp at shape; omega + | cons c rest => + obtain ⟨fields,hf,hlen⟩ := ih rest (by simp at shape; omega) + exact ⟨⟨a,b,c⟩ :: fields, by simp [wordsToFields,hf], by simp [hlen]⟩ + +theorem fieldWords_injective : Function.Injective fieldWords := + fun _ _ h => Option.some.inj ((wordsToFields_fieldWords _).symm.trans + ((congrArg wordsToFields h).trans (wordsToFields_fieldWords _))) + +end Whir.ByteCodec diff --git a/verification/whir/Whir/CandidateFolding.lean b/verification/whir/Whir/CandidateFolding.lean new file mode 100644 index 000000000..64bc48830 --- /dev/null +++ b/verification/whir/Whir/CandidateFolding.lean @@ -0,0 +1,580 @@ +import Whir.AdditiveColumn +import Whir.JohnsonMCA +import Whir.ReplayRefinement +import Whir.FieldCardinality + +/-! Commitment-fixed coefficient lists and same-set MCA lifting through the +executable array folds. Both physical lane orders are represented explicitly. -/ +namespace Whir.CandidateFolding +open Concrete MutualAgreement +open scoped BigOperators + +variable {F I : Type*} [Field F] + +/-- One coefficient table per lane, with a single common agreement set. -/ +def Agrees {k lanes : ℕ} (enc : (Fin k → F) →ₗ[F] (I → F)) + (oracle : Fin lanes → I → F) (threshold : ℕ) + (table : Fin lanes → Fin k → F) : Prop := + ∃ T : Finset I, threshold ≤ T.card ∧ ∀ lane i, i ∈ T → + enc (table lane) i = oracle lane i + +noncomputable def candidates [Fintype F] {k lanes : ℕ} + (enc : (Fin k → F) →ₗ[F] (I → F)) (oracle : Fin lanes → I → F) + (threshold : ℕ) : Finset (Fin lanes → Fin k → F) := by + classical + exact Finset.univ.filter (Agrees enc oracle threshold) + +@[simp] theorem mem_candidates [Fintype F] {k lanes : ℕ} + (enc : (Fin k → F) →ₗ[F] (I → F)) (oracle : Fin lanes → I → F) + (threshold : ℕ) (table : Fin lanes → Fin k → F) : + table ∈ candidates enc oracle threshold ↔ Agrees enc oracle threshold table := by + classical + simp [candidates] + +/-- Bounded adjacent-lane indices, independent of physical array order. -/ +def evenLane {lanes : ℕ} (lane : Fin lanes) : Fin (lanes * 2) := + ⟨2 * lane.val, by omega⟩ +def oddLane {lanes : ℕ} (lane : Fin lanes) : Fin (lanes * 2) := + ⟨2 * lane.val + 1, by omega⟩ + +def foldTable {k lanes : ℕ} (table : Fin (lanes * 2) → Fin k → F) (z : F) : + Fin lanes → Fin k → F := + fun lane j => (1-z) * table (evenLane lane) j + z * table (oddLane lane) j + +def foldOracle {lanes : ℕ} (oracle : Fin (lanes * 2) → I → F) (z : F) : + Fin lanes → I → F := + fun lane i => (1-z) * oracle (evenLane lane) i + z * oracle (oddLane lane) i + +/-- Actual codeword folding commutes with every linear row encoder. -/ +theorem encode_foldTable {k lanes : ℕ} (enc : (Fin k → F) →ₗ[F] (I → F)) + (table : Fin (lanes * 2) → Fin k → F) (z : F) (lane : Fin lanes) : + enc (foldTable table z lane) = + (1-z) • enc (table (evenLane lane)) + z • enc (table (oddLane lane)) := by + change enc ((1-z) • table (evenLane lane) + z • table (oddLane lane)) = _ + simp only [map_add, map_smul] + +/-- Interleave two tables using quotient/remainder, including the empty case. -/ +def joinTable {k lanes : ℕ} (p₀ p₁ : Fin lanes → Fin k → F) : + Fin (lanes * 2) → Fin k → F := fun lane => + if lane.val % 2 = 0 then p₀ ⟨lane.val / 2, by omega⟩ + else p₁ ⟨lane.val / 2, by omega⟩ + +omit [Field F] in +@[simp] theorem joinTable_even {k lanes : ℕ} (p₀ p₁ : Fin lanes → Fin k → F) + (lane : Fin lanes) : joinTable p₀ p₁ (evenLane lane) = p₀ lane := by + simp [joinTable, evenLane] +omit [Field F] in +@[simp] theorem joinTable_odd {k lanes : ℕ} (p₀ p₁ : Fin lanes → Fin k → F) + (lane : Fin lanes) : joinTable p₀ p₁ (oddLane lane) = p₁ lane := by + simp [joinTable, oddLane, Nat.add_div] + +/-- Decode the MCA witnesses and correct inside the encoder kernel. Thus no +injectivity or extra domain-size premise is needed to lift the *given* table. -/ +theorem coefficient_lifts [Fintype F] {k lanes : ℕ} + (enc : (Fin k → F) →ₗ[F] (I → F)) (C : Submodule F (I → F)) + (range_eq : LinearMap.range enc = C) + (oracle : Fin (lanes * 2) → I → F) (threshold : ℕ) (z : F) + (good : ¬ RowBad foldGenerator C threshold + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)] z) + (v : Fin lanes → Fin k → F) + (hv : v ∈ candidates enc (foldOracle oracle z) threshold) : + ∃ p ∈ candidates enc oracle threshold, v = foldTable p z := by + classical + obtain ⟨T, hT, hagree⟩ := (mem_candidates _ _ _ _).mp hv + have hmem (lane : Fin lanes) : enc (v lane) ∈ C := by + rw [← range_eq] + exact LinearMap.mem_range_self enc _ + obtain ⟨P₀, P₁, hP, hPT, hfold⟩ := fold_candidate_lifts C threshold + (fun lane => oracle (evenLane lane)) (fun lane => oracle (oddLane lane)) + (fun lane => enc (v lane)) z hmem T hT hagree good + have hdecode (lane : Fin lanes) : + ∃ a b : Fin k → F, enc a = P₀ lane ∧ enc b = P₁ lane := by + have h₀ := (hP lane).1 + have h₁ := (hP lane).2 + rw [← range_eq] at h₀ h₁ + obtain ⟨a, ha⟩ := h₀ + obtain ⟨b, hb⟩ := h₁ + exact ⟨a, b, ha, hb⟩ + choose a b ha hb using hdecode + let d := fun lane => b lane - a lane + let p₀ := fun lane => v lane - z • d lane + let p₁ := fun lane => p₀ lane + d lane + have hp₀ (lane : Fin lanes) : enc (p₀ lane) = P₀ lane := by + funext i + simp only [p₀, d, map_sub, map_smul, Pi.sub_apply, Pi.smul_apply, + smul_eq_mul, ha, hb, hfold] + ring + have hp₁ (lane : Fin lanes) : enc (p₁ lane) = P₁ lane := by + simp only [p₁, d, map_add, map_sub, hp₀, ha, hb] + abel + refine ⟨joinTable p₀ p₁, (mem_candidates _ _ _ _).mpr ⟨T, hT, ?_⟩, ?_⟩ + · intro lane i hi + let l : Fin lanes := ⟨lane.val / 2, by omega⟩ + by_cases he : lane.val % 2 = 0 + · have hl : evenLane l = lane := by apply Fin.ext; simp only [evenLane, l]; omega + rw [← hl, joinTable_even, hp₀] + exact (hPT l i hi).1 + · have hl : oddLane l = lane := by apply Fin.ext; simp only [oddLane, l]; omega + rw [← hl, joinTable_odd, hp₁] + exact (hPT l i hi).2 + · funext lane j + simp only [foldTable, joinTable_even, joinTable_odd, p₀, p₁, d, + Pi.sub_apply, Pi.smul_apply, Pi.add_apply, smul_eq_mul] + ring + +/-- Novel-basis row encoder, the polynomial proved by AdditiveColumn to be +computed by the executable dense column kernel. -/ +noncomputable def novelEncoder (basis : ℕ → F) (n : ℕ) (domain : I → F) : + (Fin (2^n) → F) →ₗ[F] (I → F) where + toFun a i := (AdditiveCode.polynomial basis n a).eval (domain i) + map_add' a b := by + funext i + simp [AdditiveCode.polynomial, add_smul, Finset.sum_add_distrib] + map_smul' c a := by + funext i + simp only [AdditiveCode.polynomial, Pi.smul_apply, smul_eq_mul, + mul_smul, ← Finset.smul_sum, Polynomial.eval_smul, RingHom.id_apply] + +/-- RS identification is derived from the novel-basis spanning theorem. -/ +theorem novelEncoder_range [CharP F 2] (basis : ℕ → F) (n : ℕ) + (independent : AdditiveCode.Independent basis n) (domain : I → F) : + LinearMap.range (novelEncoder basis n domain) = rsCode domain (2^n) := by + ext word + rw [mem_rsCode] + constructor + · rintro ⟨a, rfl⟩ + exact ⟨_, AdditiveCode.polynomial_degree_lt independent a, fun _ => rfl⟩ + · rintro ⟨p, hp, he⟩ + obtain ⟨a, ha⟩ := (AdditiveCode.polynomial_surjective independent p).mpr hp + exact ⟨a, by funext i; simpa [novelEncoder, ha] using he i⟩ + +/-- Column-major and row-major bounded index equivalences. -/ +def topIndex (lanes k : ℕ) : Fin lanes × Fin k ≃ Fin (lanes * k) := + finProdFinEquiv +def lowIndex (lanes k : ℕ) : Fin lanes × Fin k ≃ Fin (lanes * k) := + (Equiv.prodComm _ _).trans (finProdFinEquiv.trans (finCongr (Nat.mul_comm k lanes))) + +def packTop {k lanes : ℕ} (table : Fin lanes → Fin k → F) : Array F := + Array.ofFn fun i => table ((topIndex lanes k).symm i).1 ((topIndex lanes k).symm i).2 +def packLow {k lanes : ℕ} (table : Fin lanes → Fin k → F) : Array F := + Array.ofFn fun i => table ((lowIndex lanes k).symm i).1 ((lowIndex lanes k).symm i).2 + +omit [Field F] in +@[simp] theorem size_packTop {k lanes : ℕ} (table : Fin lanes → Fin k → F) : + (packTop table).size = lanes * k := by simp [packTop] +omit [Field F] in +@[simp] theorem size_packLow {k lanes : ℕ} (table : Fin lanes → Fin k → F) : + (packLow table).size = lanes * k := by simp [packLow] + +omit [Field F] in +theorem get_packTop [Inhabited F] {k lanes : ℕ} + (table : Fin lanes → Fin k → F) (lane : Fin lanes) (j : Fin k) : + (packTop table)[lane.val * k + j.val]! = table lane j := by + have h : lane.val * k + j.val = (topIndex lanes k (lane,j)).val := by + simp [topIndex, Nat.add_comm, Nat.mul_comm] + rw [h] + simp [packTop] + +omit [Field F] in +theorem get_packLow [Inhabited F] {k lanes : ℕ} + (table : Fin lanes → Fin k → F) (lane : Fin lanes) (j : Fin k) : + (packLow table)[j.val * lanes + lane.val]! = table lane j := by + have h : j.val * lanes + lane.val = (lowIndex lanes k (lane,j)).val := by + simp [lowIndex, Nat.add_comm, Nat.mul_comm] + rw [h] + simp [packLow] + +private theorem foldPair_eq [CharP F 2] (a b z : F) : + foldPair a b z = (1-z)*a + z*b := by + simp only [foldPair] + linear_combination z * CharTwo.add_self_eq_zero a + +theorem packTop_fold [Inhabited F] [CharP F 2] {k lanes : ℕ} + (table : Fin (lanes * 2) → Fin k → F) (z : F) : + packTop (foldTable table z) = foldLane (packTop table) k z := by + have hs : (lanes * 2 * k) / 2 = lanes * k := by + rw [Nat.mul_right_comm, Nat.mul_div_cancel _ (by decide : 0 < 2)] + apply Array.ext + · simp [hs] + · intro i hi hi' + have hi0 : i < lanes * k := by simpa using hi + let ij := (topIndex lanes k).symm ⟨i,hi0⟩ + have he : i = ij.1.val * k + ij.2.val := by + have h := congrArg Fin.val ((topIndex lanes k).apply_symm_apply ⟨i,hi0⟩) + simpa [ij, topIndex, Nat.add_comm, Nat.mul_comm] using h.symm + have hiHalf : i < (packTop table).size / 2 := by simpa [hs] using hi0 + suffices hlookup : (packTop (foldTable table z))[i]! = + (foldLane (packTop table) k z)[i]! by + simpa only [_root_.getElem!_pos (packTop (foldTable table z)) i hi, + _root_.getElem!_pos (foldLane (packTop table) k z) i hi'] using hlookup + rw [he, get_packTop] + rw [foldLane, ArrayLayout.getElem!_tab _ _ _ (by simpa [← he] using hiHalf)] + rw [ArrayLayout.foldLane_offset ij.2.isLt] + have heven : Layout.stackIndex k (2 * ij.1.val) ij.2.val = + (evenLane ij.1).val * k + ij.2.val := rfl + have hodd : Layout.stackIndex k (2 * ij.1.val) ij.2.val + k = + (oddLane ij.1).val * k + ij.2.val := by + simp only [Layout.stackIndex, oddLane]; ring + dsimp only + rw [hodd, heven, get_packTop, get_packTop, foldPair_eq] + rfl + +theorem packLow_fold [Inhabited F] [CharP F 2] {k lanes : ℕ} + (table : Fin (lanes * 2) → Fin k → F) (z : F) : + packLow (foldTable table z) = foldLow (packLow table) z := by + have hs : (lanes * 2 * k) / 2 = lanes * k := by + rw [Nat.mul_right_comm, Nat.mul_div_cancel _ (by decide : 0 < 2)] + apply Array.ext + · simp [hs] + · intro i hi hi' + have hi0 : i < lanes * k := by simpa using hi + let ij := (lowIndex lanes k).symm ⟨i,hi0⟩ + have he : i = ij.2.val * lanes + ij.1.val := by + have h := congrArg Fin.val ((lowIndex lanes k).apply_symm_apply ⟨i,hi0⟩) + simpa [ij, lowIndex, Nat.add_comm, Nat.mul_comm] using h.symm + have hiHalf : i < (packLow table).size / 2 := by simpa [hs] using hi0 + suffices hlookup : (packLow (foldTable table z))[i]! = + (foldLow (packLow table) z)[i]! by + simpa only [_root_.getElem!_pos (packLow (foldTable table z)) i hi, + _root_.getElem!_pos (foldLow (packLow table) z) i hi'] using hlookup + rw [he, get_packLow] + rw [foldLow, ArrayLayout.getElem!_tab _ _ _ (by simpa [← he] using hiHalf)] + have heven : 2 * (ij.2.val * lanes + ij.1.val) = + ij.2.val * (lanes * 2) + (evenLane ij.1).val := by + simp only [evenLane]; ring + have hodd : 2 * (ij.2.val * lanes + ij.1.val) + 1 = + ij.2.val * (lanes * 2) + (oddLane ij.1).val := by + simp only [oddLane]; ring + rw [hodd, heven, get_packLow, get_packLow, foldPair_eq] + rfl + +/-- Layout-selecting packing; `true` is the initial contiguous-lane layout. -/ +def pack (top : Bool) {k lanes : ℕ} (table : Fin lanes → Fin k → F) : Array F := + if top then packTop table else packLow table + +def foldBlock (top : Bool) (k : ℕ) : ℕ := if top then k else 1 + +omit [Field F] in +@[simp] theorem size_pack (top : Bool) {k lanes : ℕ} (table : Fin lanes → Fin k → F) : + (pack top table).size = lanes * k := by cases top <;> simp [pack] + +theorem pack_fold [Inhabited F] [CharP F 2] (top : Bool) {k lanes : ℕ} + (table : Fin (lanes * 2) → Fin k → F) (z : F) : + pack top (foldTable table z) = + Protocol.foldValues (pack top table) (foldBlock top k) z := by + cases top + · simpa [pack, foldBlock, ReplayRefinement.foldValues_eq_lane, + ArrayLayout.foldLane_one] using packLow_fold table z + · simpa [pack, foldBlock, ReplayRefinement.foldValues_eq_lane] using packTop_fold table z + +/-- This list is fixed solely by the oracle, threshold and current lane count, +not by the pending message, strategy, weights, claim or future challenge. -/ +noncomputable def arrayCandidates [Fintype F] (top : Bool) {k lanes : ℕ} + (enc : (Fin k → F) →ₗ[F] (I → F)) (oracle : Fin lanes → I → F) + (threshold : ℕ) : Finset (Array F) := by + classical + exact (candidates enc oracle threshold).image (pack top) + +theorem arrayCandidates_size [Fintype F] (top : Bool) {k lanes : ℕ} + (enc : (Fin k → F) →ₗ[F] (I → F)) (oracle : Fin lanes → I → F) + (threshold : ℕ) (a : Array F) (ha : a ∈ arrayCandidates top enc oracle threshold) : + a.size = lanes * k := by + classical + obtain ⟨table, -, rfl⟩ := Finset.mem_image.mp ha + exact size_pack _ _ + +/-- The exact lifting interface consumed by `VerifierInvariant.fold_lost`. -/ +theorem array_lifts [Fintype F] [Inhabited F] [CharP F 2] (top : Bool) + {k lanes : ℕ} (enc : (Fin k → F) →ₗ[F] (I → F)) + (C : Submodule F (I → F)) (range_eq : LinearMap.range enc = C) + (oracle : Fin (lanes * 2) → I → F) (threshold : ℕ) (z : F) + (good : ¬ RowBad foldGenerator C threshold + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)] z) : + ∀ folded ∈ arrayCandidates top enc (foldOracle oracle z) threshold, + ∃ witness ∈ arrayCandidates top enc oracle threshold, + folded = Protocol.foldValues witness (foldBlock top k) z := by + classical + intro folded hfolded + obtain ⟨v, hv, rfl⟩ := Finset.mem_image.mp hfolded + obtain ⟨p, hp, rfl⟩ := coefficient_lifts enc C range_eq oracle threshold z good v hv + exact ⟨pack top p, Finset.mem_image.mpr ⟨p, hp, rfl⟩, pack_fold top p z⟩ + +/-- Instantiated novel-code lifting, with no assumed encoder/RS identity. +The only excluded seeds are the explicit same-set RowBad event. -/ +theorem novel_array_lifts [Fintype F] [Inhabited F] [CharP F 2] (top : Bool) + (basis : ℕ → F) (n : ℕ) (independent : AdditiveCode.Independent basis n) + (domain : I → F) {lanes : ℕ} (oracle : Fin (lanes * 2) → I → F) + (threshold : ℕ) (z : F) + (good : ¬ RowBad foldGenerator (rsCode domain (2^n)) threshold + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)] z) : + ∀ folded ∈ arrayCandidates top (novelEncoder basis n domain) + (foldOracle oracle z) threshold, + ∃ witness ∈ arrayCandidates top (novelEncoder basis n domain) oracle threshold, + folded = Protocol.foldValues witness (foldBlock top (2^n)) z := + array_lifts top _ _ (novelEncoder_range basis n independent domain) oracle threshold z good + +/-- The arbitrary column-major oracle is folded with the executable adjacent +array helper, rather than replaced by a separate correlated-agreement model. -/ +theorem foldOracle_column [Inhabited F] [CharP F 2] {lanes : ℕ} + (oracle : Fin (lanes * 2) → I → F) (z : F) (i : I) : + Array.ofFn (fun lane => foldOracle oracle z lane i) = + foldLow (Array.ofFn (fun lane => oracle lane i)) z := by + apply Array.ext + · simp + · intro j hj hj' + have hjl : j < lanes := by simpa using hj + have he : 2*j < lanes*2 := by omega + have ho : 2*j+1 < lanes*2 := by omega + simp [foldLow, tab, getElem!_pos, he, ho, foldOracle, evenLane, oddLane, foldPair_eq] + +/-- The concrete dense encoder is exactly this linear map on its mapped +coefficient array, at every bounded machine query. -/ +theorem novelEncoder_encode [Inhabited F] + (f : AdditiveCode.BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (n rate : ℕ) (a : Array E) (shape : a.size = 2^n) + (q : Fin (2^(n+rate))) : + novelEncoder (AdditiveCode.bitBasis f.map) n + (fun q : Fin (2^(n+rate)) => f.map (UInt64.ofNat q.val)) + (fun j => e.map a[j.val]!) q = e.map (encode n rate a)[q.val]! := + (AdditiveCode.encode_map f e ofK n rate a shape q.val q.isLt).symm + +/-- Machine basis independence is discharged from the checked word +representation; the caller supplies neither an RS equality nor a basis axiom. -/ +theorem machineEncoder_range [Inhabited F] [CharP F 2] + (f : AdditiveCode.BaseRepresentation F) (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (n rate : ℕ) (depth : n+rate ≤ 64) : + LinearMap.range (novelEncoder (AdditiveCode.bitBasis f.map) n + (fun q : Fin (2^(n+rate)) => f.map (UInt64.ofNat q.val))) = + rsCode (AdditiveCode.machineDomain f + (AdditiveCode.baseRepresentation_injective f e ofK) (n+rate) depth) (2^n) := + novelEncoder_range _ _ (AdditiveCode.bitBasis_independent f + (AdditiveCode.baseRepresentation_injective f e ofK) n (by omega)) _ + +open Classical in +/-- The novel encoder uses exactly the coefficient-table RS code employed by +the Johnson/list-size development, not a second notion of polynomial code. -/ +theorem novelEncoder_monomial_coefficients [CharP F 2] + (basis : ℕ → F) (n : ℕ) (independent : AdditiveCode.Independent basis n) + (domain : I → F) (table : Fin (2^n) → F) : + ∃ coefficients : Fin (2^n) → F, ∀ i, + (Polynomial.ofFn (2^n) coefficients).eval (domain i) = + novelEncoder basis n domain table i := by + apply (mem_rsCode_iff_coefficients _ _ _).mp + rw [← novelEncoder_range basis n independent domain] + exact LinearMap.mem_range_self _ _ + +/-- Correct physical shape for either branch of `foldValues`. -/ +theorem arrayCandidates_round_shape [Fintype F] (top : Bool) {k lanes : ℕ} + (enc : (Fin k → F) →ₗ[F] (I → F)) (oracle : Fin (lanes * 2) → I → F) + (threshold : ℕ) (a : Array F) (ha : a ∈ arrayCandidates top enc oracle threshold) : + a.size = ((if top then lanes else lanes*k) * 2) * foldBlock top k := by + rw [arrayCandidates_size top enc oracle threshold a ha] + cases top <;> simp [foldBlock] + ring + +/-- Checked MCA provider for the proved novel code. The exceptional set is +derived, not assumed: its exact BCHKS numerator is independent of lane count. +Every surviving new array candidate lifts to the commitment-fixed old list. -/ +theorem novel_candidate_provider [Fintype F] [Inhabited F] [CharP F 2] + (top : Bool) (basis : ℕ → F) (n : ℕ) + (independent : AdditiveCode.Independent basis n) + {N lanes : ℕ} (domain : Fin N ↪ F) + (degree_pos : 1 ≤ 2^n-1) (degree_bound : 2^n-1 ≤ N-2) + (radius : ℝ) (radius_nonneg : 0 ≤ radius) + (johnson : radius < 1 - Real.sqrt (((2^n-1 : ℕ) : ℝ) / N)) + (oracle : Fin (lanes * 2) → Fin N → F) : + ∃ bad : Finset F, + (Soundness.uniformProb bad : ℝ) ≤ + johnsonNumerator N (2^n) radius / Fintype.card F ∧ + ∀ z ∉ bad, ∀ folded ∈ + arrayCandidates top (novelEncoder basis n domain) (foldOracle oracle z) + ⌈(N : ℝ) * (1-radius)⌉₊, + ∃ witness ∈ arrayCandidates top (novelEncoder basis n domain) oracle + ⌈(N : ℝ) * (1-radius)⌉₊, + folded = Protocol.foldValues witness (foldBlock top (2^n)) z := by + classical + let U : Fin 2 → Fin lanes → Fin N → F := + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)] + let bad := Finset.univ.filter (RowBad foldGenerator (rsCode domain (2^n)) + ⌈(N : ℝ) * (1-radius)⌉₊ U) + have hd : (2^n : ℕ)-1+1 = 2^n := by omega + refine ⟨bad, ?_, ?_⟩ + · simpa only [hd] using johnson_row_bad_probability domain degree_pos degree_bound + radius radius_nonneg johnson U + · intro z hz + exact novel_array_lifts top basis n independent domain oracle _ z + (by simpa [bad, U] using hz) + +/-- Final machine-domain provider. Binary-basis independence, distinct machine +indices, exact RS identification and the MCA estimate are all proved internally. +Representation parameters concern primitive machine operations only. -/ +theorem machine_candidate_provider [Fintype F] [Inhabited F] [CharP F 2] + (top : Bool) (f : AdditiveCode.BaseRepresentation F) + (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (n rate : ℕ) (depth : n+rate ≤ 64) {lanes : ℕ} + (degree_pos : 1 ≤ 2^n-1) (degree_bound : 2^n-1 ≤ 2^(n+rate)-2) + (radius : ℝ) (radius_nonneg : 0 ≤ radius) + (johnson : radius < 1 - Real.sqrt (((2^n-1 : ℕ) : ℝ) / 2^(n+rate))) + (oracle : Fin (lanes * 2) → Fin (2^(n+rate)) → F) : + let enc := novelEncoder (AdditiveCode.bitBasis f.map) n + (fun q : Fin (2^(n+rate)) => f.map (UInt64.ofNat q.val)) + let threshold := ⌈((2^(n+rate) : ℕ) : ℝ) * (1-radius)⌉₊ + ∃ bad : Finset F, + (Soundness.uniformProb bad : ℝ) ≤ + johnsonNumerator (2^(n+rate)) (2^n) radius / Fintype.card F ∧ + ∀ z ∉ bad, ∀ folded ∈ arrayCandidates top enc (foldOracle oracle z) threshold, + ∃ witness ∈ arrayCandidates top enc oracle threshold, + folded = Protocol.foldValues witness (foldBlock top (2^n)) z := by + have hf := AdditiveCode.baseRepresentation_injective f e ofK + exact novel_candidate_provider top (AdditiveCode.bitBasis f.map) n + (AdditiveCode.bitBasis_independent f hf n (by omega)) + (AdditiveCode.machineDomain f hf (n+rate) depth) + degree_pos degree_bound radius radius_nonneg (by simpa using johnson) oracle + +/-- Total coefficient extraction at the bounded physical matrix indices. -/ +def unpack [Inhabited F] (top : Bool) (lanes k : ℕ) (a : Array F) : + Fin lanes → Fin k → F := + fun lane j => a[(if top then topIndex lanes k else lowIndex lanes k) (lane,j) |>.val]! + +omit [Field F] in +theorem unpack_pack [Inhabited F] (top : Bool) {lanes k : ℕ} + (table : Fin lanes → Fin k → F) : + unpack top lanes k (pack top table) = table := by + funext lane j + cases top <;> simp [unpack, pack, packTop, packLow] + +omit [Field F] in +theorem pack_unpack [Inhabited F] (top : Bool) {lanes k : ℕ} + (a : Array F) (shape : a.size = lanes*k) : + pack top (unpack top lanes k a) = a := by + apply Array.ext + · simpa using shape.symm + · intro i hi hi' + cases top <;> + simp [pack, packTop, packLow, unpack, _root_.getElem!_pos a i hi'] + +/-- Every exact-size array is represented; candidate coverage is a theorem, +not a decoder assumption or one-way image inclusion. -/ +theorem arrayCandidates_mem_iff [Fintype F] [Inhabited F] (top : Bool) {k lanes : ℕ} + (enc : (Fin k → F) →ₗ[F] (I → F)) (oracle : Fin lanes → I → F) + (threshold : ℕ) (a : Array F) : + a ∈ arrayCandidates top enc oracle threshold ↔ + a.size = lanes*k ∧ Agrees enc oracle threshold (unpack top lanes k a) := by + classical + constructor + · intro ha + obtain ⟨table, htable, rfl⟩ := Finset.mem_image.mp ha + exact ⟨size_pack _ _, by + rw [unpack_pack] + exact (mem_candidates _ _ _ _).mp htable⟩ + · rintro ⟨shape, hagree⟩ + exact Finset.mem_image.mpr ⟨unpack top lanes k a, + (mem_candidates _ _ _ _).mpr hagree, pack_unpack top a shape⟩ + +omit [Field F] in +theorem unpack_one [Inhabited F] (top : Bool) (k : ℕ) (a : Array F) (j : Fin k) : + unpack top 1 k a 0 j = a[j.val]! := by + cases top <;> simp [unpack, topIndex, lowIndex] + +open Classical in +/-- One remaining lane is exactly the ordinary row-encoding agreement list, +for every physical array of the right size. -/ +theorem oneLane_arrayCandidates_mem_iff [Fintype F] [Fintype I] [Inhabited F] + (top : Bool) {k : ℕ} (enc : (Fin k → F) →ₗ[F] (I → F)) + (word : I → F) (threshold : ℕ) (a : Array F) : + a ∈ arrayCandidates top enc (fun _ : Fin 1 => word) threshold ↔ + a.size = k ∧ threshold ≤ + (Finset.univ.filter fun i => enc (fun j => a[j.val]!) i = word i).card := by + rw [arrayCandidates_mem_iff] + simp only [one_mul] + apply and_congr_right + intro _ + constructor + · rintro ⟨T, hT, hagree⟩ + apply hT.trans + apply Finset.card_le_card + intro i hi + apply Finset.mem_filter.mpr + refine ⟨Finset.mem_univ _, ?_⟩ + simpa only [show unpack top 1 k a 0 = (fun j => a[j.val]!) from + funext (unpack_one top k a)] using hagree 0 i hi + · intro hcard + refine ⟨_, hcard, ?_⟩ + intro lane i hi + fin_cases lane + change enc (unpack top 1 k a 0) i = word i + simpa only [show unpack top 1 k a 0 = (fun j => a[j.val]!) from + funext (unpack_one top k a)] using (Finset.mem_filter.mp hi).2 + +open Classical in +/-- Every actual coefficient array with enough exact encoded matches belongs +to the one-lane list after mapping primitive machine operations into the field. -/ +theorem oneLane_encode_coverage [Fintype F] [Inhabited F] + (top : Bool) (f : AdditiveCode.BaseRepresentation F) + (e : QueryRefinement.Representation F) + (ofK : ∀ s, e.map (E.ofK s) = f.map s) + (n rate threshold : ℕ) (a : Array E) (shape : a.size = 2^n) + (word : Fin (2^(n+rate)) → E) + (hmatches : threshold ≤ + (Finset.univ.filter fun q => (encode n rate a)[q.val]! = word q).card) : + a.map e.map ∈ arrayCandidates top + (novelEncoder (AdditiveCode.bitBasis f.map) n + (fun q : Fin (2^(n+rate)) => f.map (UInt64.ofNat q.val))) + (fun _ : Fin 1 => fun q => e.map (word q)) threshold := by + apply (oneLane_arrayCandidates_mem_iff _ _ _ _ _).mpr + refine ⟨by simpa using shape, hmatches.trans (Finset.card_le_card ?_)⟩ + intro q hq + refine Finset.mem_filter.mpr ⟨Finset.mem_univ _, ?_⟩ + have hcoeff : (fun j : Fin (2^n) => (a.map e.map)[j.val]!) = + (fun j : Fin (2^n) => e.map a[j.val]!) := by + funext j + have hj : j.val < a.size := by rw [shape]; exact j.isLt + simp [_root_.getElem!_pos, hj] + rw [hcoeff, novelEncoder_encode f e ofK n rate a shape q, (Finset.mem_filter.mp hq).2] + +/-- The actual field's actual dense row encoder as a linear map. -/ +noncomputable def concreteEncoder (n rate : ℕ) : + (Fin (2^n) → E) →ₗ[E] (Fin (2^(n+rate)) → E) := + novelEncoder (AdditiveCode.bitBasis E.ofK) n + (fun q => E.ofK (UInt64.ofNat q.val)) + +open Classical in +/-- Exact one-lane candidate membership for executable `encode`. This gives +the direct actual close invariant from `Lost`, with no coverage assumption. -/ +theorem concrete_oneLane_mem_iff (top : Bool) (n rate threshold : ℕ) + (word : Fin (2^(n+rate)) → E) (a : Array E) : + a ∈ arrayCandidates top (concreteEncoder n rate) (fun _ : Fin 1 => word) threshold ↔ + a.size = 2^n ∧ threshold ≤ + (Finset.univ.filter fun q => (encode n rate a)[q.val]! = word q).card := by + rw [oneLane_arrayCandidates_mem_iff] + apply and_congr_right + intro shape + have heq (q : Fin (2^(n+rate))) : + concreteEncoder n rate (fun j => a[j.val]!) q = (encode n rate a)[q.val]! := + (AdditiveCode.concrete_encode_eval n rate a shape q.val q.isLt).symm + simp only [heq] + +/-- Fully concrete PCS folding provider: actual E, actual dense encoder and +actual executable array folds, with no field-representation or MCA premise. -/ +theorem concrete_candidate_provider (top : Bool) (n rate : ℕ) + (depth : n+rate ≤ 64) {lanes : ℕ} + (degree_pos : 1 ≤ 2^n-1) (degree_bound : 2^n-1 ≤ 2^(n+rate)-2) + (radius : ℝ) (radius_nonneg : 0 ≤ radius) + (johnson : radius < 1 - Real.sqrt (((2^n-1 : ℕ) : ℝ) / 2^(n+rate))) + (oracle : Fin (lanes * 2) → Fin (2^(n+rate)) → E) : + let threshold := ⌈((2^(n+rate) : ℕ) : ℝ) * (1-radius)⌉₊ + ∃ bad : Finset E, + (Soundness.uniformProb bad : ℝ) ≤ + johnsonNumerator (2^(n+rate)) (2^n) radius / Fintype.card E ∧ + ∀ z ∉ bad, ∀ folded ∈ + arrayCandidates top (concreteEncoder n rate) (foldOracle oracle z) threshold, + ∃ witness ∈ arrayCandidates top (concreteEncoder n rate) oracle threshold, + folded = Protocol.foldValues witness (foldBlock top (2^n)) z := + machine_candidate_provider top AdditiveCode.concreteBaseRepresentation + QueryRefinement.concreteRepresentation (fun _ => rfl) n rate depth degree_pos + degree_bound radius radius_nonneg johnson oracle + +end Whir.CandidateFolding diff --git a/verification/whir/Whir/CausalAllocationLabels.lean b/verification/whir/Whir/CausalAllocationLabels.lean new file mode 100644 index 000000000..ed6eddf13 --- /dev/null +++ b/verification/whir/Whir/CausalAllocationLabels.lean @@ -0,0 +1,140 @@ +import Whir.RawOracleCoupling + +/-! A causal allocation decorator freezes the selected label before sampling. +Labels are retained in the emitted draw trace, never rebuilt from final state. -/ +namespace Whir.CausalAllocationLabels +open TypedOracleCompiler +open RawOracleCoupling (average_equiv) + +universe u v w x y z + +structure Decorator (State : Type u) (Key : Type v) (Answer : Key → Type w) + (Label : Type x) (LabelAnswer : Label → Type y) where + prepare : State → Key → State × Label + answer : ∀ state key, Answer key ≃ LabelAnswer (prepare state key).2 + advance : State → (label : Label) → LabelAnswer label → State + +namespace Decorator +variable {State : Type u} {Key : Type v} {Answer : Key → Type w} +variable {Label : Type x} {LabelAnswer : Label → Type y} +variable (decorator : Decorator State Key Answer Label LabelAnswer) + +/-- Only the original requested answer reaches the original continuation. +`prepare` cannot inspect that answer; `advance` runs after its fresh sampling. -/ +def decorate {R : Type z} {n} : Sampling Key Answer R n → State → + Sampling Label LabelAnswer (R × State) n + | .ret result, state => .ret (result,state) + | .draw key next, state => + let prepared := decorator.prepare state key + .draw prepared.2 (fun answer => + decorate (next ((decorator.answer state key).symm answer)) + (decorator.advance prepared.1 prepared.2 answer)) + +/-- Executable causal trace translation. The original full allocation trace is +an analysis object, not an additional input available to the strategy. -/ +def traceRecode : State → List (Sigma Answer) → List (Sigma LabelAnswer) × State + | state, [] => ([],state) + | state, ⟨key,answer⟩ :: rest => + let prepared := decorator.prepare state key + let labeled := decorator.answer state key answer + let after := decorator.advance prepared.1 prepared.2 labeled + let tail := traceRecode after rest + (⟨prepared.2,labeled⟩ :: tail.1,tail.2) + +/-- This relation exposes the exact chronological state transitions, including +both the before-draw preparation and after-answer advancement. -/ +inductive Evolves : State → List (Sigma Answer) → List (Sigma LabelAnswer) → State → Prop where + | nil (state : State) : Evolves state [] [] state + | cons (state : State) (key : Key) (answer : Answer key) {raw labeled final} + (tail : Evolves + (decorator.advance (decorator.prepare state key).1 (decorator.prepare state key).2 + (decorator.answer state key answer)) raw labeled final) : + Evolves state (⟨key,answer⟩ :: raw) + (⟨(decorator.prepare state key).2,decorator.answer state key answer⟩ :: labeled) final + + theorem traceRecode_evolves (state : State) (raw : List (Sigma Answer)) : + decorator.Evolves state raw (decorator.traceRecode state raw).1 + (decorator.traceRecode state raw).2 := by + induction raw generalizing state with + | nil => exact .nil state + | cons entry rest ih => exact .cons state entry.1 entry.2 (ih _) + + theorem Evolves.exact {state raw labeled final} + (evolution : decorator.Evolves state raw labeled final) : + decorator.traceRecode state raw = (labeled,final) := by + induction evolution with + | nil => rfl + | cons state key answer tail ih => simp only [traceRecode, ih] + + theorem traceRecode_length (state : State) (raw : List (Sigma Answer)) : + (decorator.traceRecode state raw).1.length = raw.length := by + induction raw generalizing state with + | nil => rfl + | cons entry rest ih => simp only [traceRecode, List.length_cons, ih] + +/-- Exact operational correspondence for every branch, including early stops. +A label is the one selected at its allocation time, not a final-state lookup. -/ +theorem runs_iff {R : Type z} {n} (program : Sampling Key Answer R n) (state : State) + (labeled : List (Sigma LabelAnswer)) (result : R) (final : State) : + Sampling.Runs (decorator.decorate program state) labeled (result,final) ↔ + ∃ raw, Sampling.Runs program raw result ∧ + decorator.traceRecode state raw = (labeled,final) := by + induction program generalizing state labeled final with + | ret value => + constructor + · intro run + cases run + exact ⟨[],.ret _,rfl⟩ + · rintro ⟨raw,run,equal⟩ + cases run + cases equal + exact .ret _ + | draw key next ih => + constructor + · intro run + cases run with + | draw answer run => + obtain ⟨raw,original,equal⟩ := (ih _ _ _ _).mp run + refine ⟨⟨key,(decorator.answer state key).symm answer⟩ :: raw, + .draw _ original,?_⟩ + simp only [traceRecode, Equiv.apply_symm_apply, equal] + · rintro ⟨raw,original,equal⟩ + cases original with + | draw answer original => + simp only [traceRecode] at equal + cases equal + apply Sampling.Runs.draw (decorator.answer state key answer) + simpa only [Equiv.symm_apply_apply] using + (ih answer _ _ _).mpr ⟨_,original,rfl⟩ + + theorem runs_causal {R : Type z} {n} (program : Sampling Key Answer R n) (state : State) + {labeled result final} (run : Sampling.Runs (decorator.decorate program state) labeled (result,final)) : + ∃ raw, Sampling.Runs program raw result ∧ decorator.Evolves state raw labeled final := by + obtain ⟨raw,original,equal⟩ := (decorator.runs_iff program state labeled result final).mp run + refine ⟨raw,original,?_⟩ + have evolution := decorator.traceRecode_evolves state raw + rw [equal] at evolution + exact evolution + + theorem all_branch_cap {R : Type z} {n} (program : Sampling Key Answer R n) (state : State) + {trace result} (run : Sampling.Runs (decorator.decorate program state) trace result) : + trace.length ≤ n := run.length_le + +variable [∀ key, Fintype (Answer key)] +variable [∀ label, Fintype (LabelAnswer label)] + +/-- Exact every-payoff distribution preservation for the original result. +The decorator's private adaptive state is not passed to the original strategy. -/ +theorem expectation {R : Type z} {n} (program : Sampling Key Answer R n) (state : State) + (payoff : R → ℚ) : + Sampling.expectation (fun result => payoff result.1) (decorator.decorate program state) = + Sampling.expectation payoff program := by + induction program generalizing state with + | ret result => rfl + | draw key next ih => + simp only [decorate, Sampling.expectation, ih] + exact average_equiv (decorator.answer state key).symm + (fun answer => Sampling.expectation payoff (next answer)) + +end Decorator +end Whir.CausalAllocationLabels diff --git a/verification/whir/Whir/CausalBadEvents.lean b/verification/whir/Whir/CausalBadEvents.lean new file mode 100644 index 000000000..305bae18b --- /dev/null +++ b/verification/whir/Whir/CausalBadEvents.lean @@ -0,0 +1,234 @@ +import Whir.CausalInitial +import Whir.CausalFolds +import Whir.CausalBoundary + +/-! One dependent-alphabet bad-prefix relation for the actual WHIR execution. +Every constructor corresponds to one indivisible random challenge message. -/ +namespace Whir.CausalBadEvents +open Concrete Protocol CausalGame CausalProbability + +/-- The final tail coordinate is included although it has no following prover response. -/ +def Bad (input : Public) (strategy : Strategy) (q : Coordinate input.config) + (tape : Tape input.config) : Prop := + match q with + | .initial => CausalInitial.Event input tape + | .fold i j => CausalFolds.Event input strategy i j tape + | .ood i j => CausalBoundary.OodEvent input strategy i j tape + | .query i => CausalBoundary.QueryEvent input strategy i tape + | .tail j => + dot (CausalTerminal.candidate input strategy tape j) + (CausalTerminal.pending input strategy tape j).weight ≠ + (CausalTerminal.pending input strategy tape j).claim ∧ + tape.2.2 j ∈ TerminalSoundness.collision (CausalTerminal.candidate input strategy tape j) + (CausalTerminal.pending input strategy tape j) + +/-- Conservative unground production envelopes, before any hash or ROM losses. -/ +def localError (input : Public) (q : Coordinate input.config) : ℚ := + match q with + | .initial => GroupedChallenges.initialBatch input.config + (ParameterBounds.estimates input.config) input.claims.size + | .fold i _ => GroupedChallenges.foldError input.config + (ParameterBounds.estimates input.config) i + | .ood i _ => ((2 ^ 32).choose 2 : ℚ) * (remaining input.config i : ℚ) / 2 ^ 192 + | .query i => GroupedChallenges.queryBatchError input.config + (ParameterBounds.estimates input.config) i + | .tail _ => 2 / 2 ^ 192 + +open ParameterBounds GroupedChallenges +open scoped BigOperators +open Classical +set_option maxHeartbeats 800000 +set_option maxRecDepth 100000 +attribute [local irreducible] CausalTerminal.candidate CausalTerminal.pending TerminalSoundness.collision + +theorem initial_fiber (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (lane_bound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) + (strategy : Strategy) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun x : E => + Bad ⟨config p, lanes, root, claims⟩ strategy .initial (set .initial t x)) ≤ + initialBatch (config p) (estimates (config p)) claims.size := by + have he : (Finset.univ.filter fun x : E => + Bad ⟨config p, lanes, root, claims⟩ strategy .initial (set .initial t x)) = + InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) lanes root) claims := by + have hs : (Finset.univ.filter fun x : E => + Bad ⟨config p, lanes, root, claims⟩ strategy .initial (set .initial t x)) = + (Finset.univ.filter fun x : E => x ∈ InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) lanes root) claims) := by + apply Finset.filter_congr + intro x _ + change (get .initial (set .initial t x) ∈ _) ↔ _ + rw [get_set] + rw [hs, Finset.filter_mem_eq_inter, Finset.univ_inter] + rw [he] + apply (InitialSoundness.initial_escape_probability p lanes root lane_bound claims shape).trans_eq + unfold initialBatch + rw [dite_eq_left (production_config_valid p).2.1] + simp only [estimates, fieldSize, Nat.cast_pow, Nat.cast_ofNat] + ring + +theorem tail_fiber (input : Public) (strategy : Strategy) (valid : input.config.valid = true) + (j : Fin (input.config.logN - input.config.folds.toList.sum)) (t : Tape input.config) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample (.tail j) => + Bad input strategy (.tail j) (set (.tail j) t x)) ≤ 2 / fieldSize := by + have eq (x : E) : Bad input strategy (.tail j) (set (.tail j) t x) ↔ + dot (CausalTerminal.candidate input strategy t j) + (CausalTerminal.pending input strategy t j).weight ≠ + (CausalTerminal.pending input strategy t j).claim ∧ + x ∈ TerminalSoundness.collision (CausalTerminal.candidate input strategy t j) + (CausalTerminal.pending input strategy t j) := by + obtain ⟨ha, hs⟩ := CausalTerminal.kernels_set input strategy valid j t x + dsimp only [Bad] + rw [ha, hs] + simp only [set_tail, Function.update_self] + simp_rw [eq] + by_cases lost : dot (CausalTerminal.candidate input strategy t j) + (CausalTerminal.pending input strategy t j).weight ≠ + (CausalTerminal.pending input strategy t j).claim + · have he : (Finset.univ.filter fun x : E => + dot (CausalTerminal.candidate input strategy t j) + (CausalTerminal.pending input strategy t j).weight ≠ + (CausalTerminal.pending input strategy t j).claim ∧ + x ∈ TerminalSoundness.collision (CausalTerminal.candidate input strategy t j) + (CausalTerminal.pending input strategy t j)) = + TerminalSoundness.collision (CausalTerminal.candidate input strategy t j) + (CausalTerminal.pending input strategy t j) := by + apply Finset.ext + intro x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨And.right, fun h => ⟨lost, h⟩⟩ + rw [he] + have h := TerminalSoundness.collision_probability _ _ lost + rw [field_cardinality] at h + exact h + · simp only [lost, false_and, Finset.filter_false, Soundness.uniformProb, + Finset.card_empty, Nat.cast_zero, zero_div] + norm_num [fieldSize] + +/-- No acceptance or local-escape hypothesis: each case is the checked actual +strategy fiber bound, including arbitrary current replies and authenticated rows. -/ +theorem fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (lane_bound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) + (strategy : Strategy) (q : Coordinate (config p)) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => + Bad ⟨config p, lanes, root, claims⟩ strategy q (set q t x)) ≤ + localError ⟨config p, lanes, root, claims⟩ q := by + cases q with + | initial => exact initial_fiber p lanes root claims lane_bound shape strategy t + | fold i j => exact CausalFolds.fiber_bound p lanes root claims strategy i j t + | ood i j => + have h := CausalBoundary.ood_fiber_bound ⟨config p, lanes, root, claims⟩ strategy p rfl i j + ⟨set (.ood i j) t 0, get_set _ _ _⟩ + change Soundness.uniformProb (Finset.univ.filter fun x : Sample (.ood i j) => + CausalBoundary.OodEvent ⟨config p, lanes, root, claims⟩ strategy i j (set (.ood i j) t x)) ≤ _ + convert h using 1 <;> simp only [set_set, localError] + | query i => + have h := CausalBoundary.query_fiber_bound ⟨config p, lanes, root, claims⟩ strategy p rfl i + ⟨set (.query i) t 0, get_set _ _ _⟩ + change Soundness.uniformProb (Finset.univ.filter fun x : Sample (.query i) => + CausalBoundary.QueryEvent ⟨config p, lanes, root, claims⟩ strategy i (set (.query i) t x)) ≤ _ + convert h using 1 <;> simp only [set_set, localError] + | tail j => + change _ ≤ 2 / fieldSize + exact tail_fiber ⟨config p, lanes, root, claims⟩ strategy (production_config_valid p).1 j t + +theorem coordinate_bound (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (lane_bound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) + (strategy : Strategy) (q : Coordinate (config p)) : + Soundness.uniformProb (Finset.univ.filter (Bad ⟨config p, lanes, root, claims⟩ strategy q)) ≤ + localError ⟨config p, lanes, root, claims⟩ q := + fiber_event_bound q _ _ (fun rest => fiber_bound p lanes root claims lane_bound shape strategy q rest.val) + +private theorem le_foldl_max_start (xs : List ℚ) (a : ℚ) : + a ≤ xs.foldl max a := by + induction xs generalizing a with + | nil => exact le_rfl + | cons x xs ih => exact (le_max_left a x).trans (ih _) + +private theorem le_foldl_max_of_mem (xs : List ℚ) (a x : ℚ) (hx : x ∈ xs) : + x ≤ xs.foldl max a := by + induction xs generalizing a with + | nil => simp at hx + | cons y ys ih => + rcases List.mem_cons.mp hx with rfl | h + · exact (le_max_right a x).trans (le_foldl_max_start ys _) + · exact ih _ h + +theorem level_le_groupedMaximum (c : Config) (claims : Nat) (i : Fin c.folds.size) : + max (foldError c (estimates c) i) + (max (oodError c (estimates c) i) (queryBatchError c (estimates c) i)) ≤ + groupedMaximum c (estimates c) claims := by + apply le_trans (le_foldl_max_of_mem _ 0 _ (List.mem_ofFn.mpr ⟨i, rfl⟩)) + exact (le_max_right _ _).trans (le_max_right _ _) + +theorem localError_le_groupedMaximum (input : Public) (q : Coordinate input.config) : + localError input q ≤ groupedMaximum input.config (estimates input.config) input.claims.size := by + cases q with + | initial => exact le_max_left _ _ + | fold i j => exact (le_max_left _ _).trans (level_le_groupedMaximum _ _ i) + | query i => exact (le_max_right _ _).trans ((le_max_right _ _).trans (level_le_groupedMaximum _ _ i)) + | tail j => exact (le_max_left _ _).trans (le_max_right _ _) + | ood i j => + apply le_trans _ ((le_max_left _ _).trans ((le_max_right _ _).trans + (level_le_groupedMaximum _ _ i))) + have hn : i.val + 1 < input.config.folds.size := by + by_contra h + have := j.isLt + simp [oodCount, h] at this + have hj : (1 : ℚ) ≤ oodCount input.config i := by + exact_mod_cast (Nat.zero_lt_of_lt j.isLt) + simp only [localError, oodError, hn, ↓reduceDIte, estimates, fieldSize] + have hm := mul_le_mul_of_nonneg_right hj + (show (0 : ℚ) ≤ ((2^32).choose 2 : ℚ) * remaining input.config i / 2^192 from + div_nonneg (mul_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _)) (by norm_num)) + simpa only [one_mul, mul_div_assoc, mul_assoc] using hm + +/-- Exact dependent-coordinate ledger, including all individual OOD vectors. -/ +theorem localError_sum (input : Public) : + (∑ q : Coordinate input.config, localError input q) = + interactiveError input.config (estimates input.config) input.claims.size := by + rw [← Equiv.sum_comp (Coordinate.proxyTypeEquiv input.config)] + simp only [Fintype.sum_sum_type, Fintype.sum_sigma, Fintype.sum_unique] + change initialBatch input.config (estimates input.config) input.claims.size + + ((∑ i : Fin input.config.folds.size, ∑ _j : Fin input.config.folds[i.val]!, + foldError input.config (estimates input.config) i) + + ((∑ i : Fin input.config.folds.size, ∑ _j : Fin (oodCount input.config i), + ((2^32).choose 2 : ℚ) * (remaining input.config i : ℚ) / 2^192) + + ((∑ i : Fin input.config.folds.size, queryBatchError input.config (estimates input.config) i) + + ∑ _j : Fin (input.config.logN - input.config.folds.toList.sum), (2 / 2^192 : ℚ)))) = _ + simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul] + have ood (i : Fin input.config.folds.size) : + (oodCount input.config i : ℚ) * + (((2 ^ 32).choose 2 : ℚ) * (remaining input.config i : ℚ) / 2 ^ 192) = + oodError input.config (estimates input.config) i := by + unfold oodError + split_ifs with h + · simp only [estimates, fieldSize] + ring + · simp only [oodCount, h, ↓reduceIte, Nat.cast_zero, zero_mul] + simp_rw [ood] + simp only [interactiveError, Finset.sum_add_distrib, fieldSize] + ring + +/-- The concrete accepted-cover consumer needs only deterministic public syntax. +The event probability itself contains no acceptance condition. -/ +theorem bad_probability (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (lane_bound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) : + Soundness.uniformProb (Finset.univ.filter fun tape : Tape (config p) => + ∃ q, Bad ⟨config p, lanes, root, claims⟩ strategy q tape) ≤ + interactiveError (config p) (estimates (config p)) claims.size := by + have he : (Finset.univ.filter fun tape : Tape (config p) => + ∃ q, Bad ⟨config p, lanes, root, claims⟩ strategy q tape) = + Finset.univ.biUnion (fun q => Finset.univ.filter + (Bad ⟨config p, lanes, root, claims⟩ strategy q)) := by + ext tape + simp + rw [he, ← localError_sum (⟨config p, lanes, root, claims⟩ : Public)] + exact (Soundness.union_bound _).trans (Finset.sum_le_sum fun q _ => + coordinate_bound p lanes root claims lane_bound shape strategy q) + +end Whir.CausalBadEvents diff --git a/verification/whir/Whir/CausalBindingState.lean b/verification/whir/Whir/CausalBindingState.lean new file mode 100644 index 000000000..7496e491f --- /dev/null +++ b/verification/whir/Whir/CausalBindingState.lean @@ -0,0 +1,538 @@ +import Whir.MerkleTransport +import Whir.WHIRSnapshotReplay +import Whir.DuplexModeGame +import Whir.WHIRPhysicalRows + +/-! Causal ghost state for the PCS boundary. Root extraction closes over finite answers captured at first registration, never over a future primitive table. Bindings are identified by the complete actual caller entry, so cloned histories sharing a seed remain distinct. Actual caller claim binding remains the library's input contract. -/ +namespace Whir.CausalBindingState +open Concrete Protocol ParameterBounds CausalGame +open FiatShamirGame (Digest32 Byte FramedHistory) +open MerkleTransport.Commitments +open Classical + +structure State (cap : Nat) where + records : Records := [] + registry : Registry := [] + frozen : Digest32 → Option Records := fun _ => none + entries : (p : Profile) → FramedHistory → Option (Option (WHIRFiatShamir.StackInitial p cap)) := fun _ _ => none + rawAnswers : (Q : Nat) → List (DuplexModeGame.RawKey Q × Digest32) := fun _ => [] + publicLog : List (DuplexFraming.Node × Digest32) := [] + frozenLog : Digest32 → Option (List (DuplexFraming.Node × Digest32)) := fun _ => none + sourceError : Option Digest32 := none + +/-- Flatten the first recorded caller result, retaining rejected entries separately. -/ +def State.catalog {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) : + Option (WHIRFiatShamir.StackInitial p cap) := + (s.entries p entry).getD none + +def empty (cap : Nat) : State cap := {} + +def localCatalog {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) : + StackWHIRReplay.Catalog p cap := + fun seed => if seed = entry.statement then s.catalog p entry else none + +def snapshot (records : Records) : Snapshot := ⟨recordDomain records,[]⟩ + +def observe {cap : Nat} (s : State cap) (input : List Byte) (value : Digest32) : State cap := + match recordLookup input s.records with + | some _ => s + | none => {s with records := (input,value) :: s.records} + +def registerRoot {cap : Nat} (s : State cap) (root : Digest32) : State cap := + match lookup root s.registry with + | some _ => s + | none => {s with + registry := register s.registry root (snapshot s.records) + frozen := Function.update s.frozen root (some s.records) + frozenLog := Function.update s.frozenLog root (some s.publicLog)} + +def registerRoots {cap : Nat} (s : State cap) (roots : List Digest32) : State cap := + roots.foldl registerRoot s + +def registerStatement {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (data : Option (WHIRFiatShamir.StackInitial p cap)) : State cap := + match s.entries p entry with + | some _ => s + | none => {s with + entries := Function.update s.entries p (Function.update (s.entries p) entry (some data))} + +structure Extends {cap : Nat} (old new : State cap) : Prop where + records : ∀ input value, recordLookup input old.records = some value → + recordLookup input new.records = some value + registry : ∀ root snap, lookup root old.registry = some snap → + lookup root new.registry = some snap + frozen : ∀ root snap, lookup root old.registry = some snap → old.frozen root = new.frozen root + entries : ∀ p entry data, old.entries p entry = some data → new.entries p entry = some data + frozenLog : ∀ root snap, lookup root old.registry = some snap → old.frozenLog root = new.frozenLog root + +theorem Extends.catalog {cap : Nat} {old new : State cap} (growth : Extends old new) + (p : Profile) (entry : FramedHistory) (data : WHIRFiatShamir.StackInitial p cap) + (known : old.catalog p entry = some data) : new.catalog p entry = some data := by + cases h : old.entries p entry with + | none => simp [State.catalog, h] at known + | some result => + simpa only [State.catalog, h, growth.entries p entry result h, Option.getD_some] using known + +/-- A first rejection cannot become an accepted catalog entry after any extension. -/ +theorem Extends.rejected {cap : Nat} {old new : State cap} (growth : Extends old new) + (p : Profile) (entry : FramedHistory) (known : old.entries p entry = some none) : + new.entries p entry = some none ∧ new.catalog p entry = none := + ⟨growth.entries p entry none known, by + simp [State.catalog, growth.entries p entry none known]⟩ + +theorem Extends.refl {cap : Nat} (s : State cap) : Extends s s := + ⟨fun _ _ h => h, fun _ _ h => h, fun _ _ _ => rfl, fun _ _ _ h => h, fun _ _ _ => rfl⟩ + +theorem Extends.trans {cap : Nat} {a b c : State cap} (ab : Extends a b) (bc : Extends b c) : + Extends a c := + ⟨fun x y h => bc.records x y (ab.records x y h), + fun r snap h => bc.registry r snap (ab.registry r snap h), + fun r snap h => (ab.frozen r snap h).trans (bc.frozen r snap (ab.registry r snap h)), + fun p entry data h => bc.entries p entry data (ab.entries p entry data h), + fun r snap h => (ab.frozenLog r snap h).trans (bc.frozenLog r snap (ab.registry r snap h))⟩ + +theorem observe_extends {cap : Nat} (s : State cap) (input : List Byte) (value : Digest32) : + Extends s (observe s input value) := by + unfold observe + cases found : recordLookup input s.records with + | some _ => exact .refl s + | none => + refine ⟨?_,fun _ _ h => h,fun _ _ _ => rfl,fun _ _ _ h => h,fun _ _ _ => rfl⟩ + intro x d old + have ne : x ≠ input := by intro eq; subst x; simp [found] at old + simp [recordLookup,ne,old] + +theorem registerRoot_extends {cap : Nat} (s : State cap) (root : Digest32) : + Extends s (registerRoot s root) := by + unfold registerRoot + cases found : lookup root s.registry with + | some _ => exact .refl s + | none => + refine ⟨fun _ _ h => h,?_,?_,fun _ _ _ h => h,?_⟩ + · intro r snap old + exact register_preserves s.registry r root snap (snapshot s.records) old + · intro r snap old + have ne : r ≠ root := by intro eq; subst r; simp [found] at old + simp [Function.update_of_ne ne] + · intro r snap old + have ne : r ≠ root := by intro eq; subst r; simp [found] at old + simp [Function.update_of_ne ne] + +theorem registerRoot_known {cap : Nat} (s : State cap) (root : Digest32) : + ∃ snap, lookup root (registerRoot s root).registry = some snap := by + unfold registerRoot + cases found : lookup root s.registry with + | some snap => exact ⟨snap,found⟩ + | none => exact ⟨snapshot s.records,register_first _ _ _ found⟩ + +theorem registerRoots_extends {cap : Nat} (s : State cap) (roots : List Digest32) : + Extends s (registerRoots s roots) := by + induction roots generalizing s with + | nil => exact .refl s + | cons root rest ih => + exact (registerRoot_extends s root).trans (ih (registerRoot s root)) + +theorem registerRoots_known {cap : Nat} (s : State cap) (roots : List Digest32) + (root : Digest32) (member : root ∈ roots) : + ∃ snap, lookup root (registerRoots s roots).registry = some snap := by + induction roots generalizing s with + | nil => simp at member + | cons r rest ih => + rcases List.mem_cons.mp member with eq | member + · subst r + obtain ⟨snap,known⟩ := registerRoot_known s root + exact ⟨snap,(registerRoots_extends (registerRoot s root) rest).registry _ _ known⟩ + · exact ih (registerRoot s r) member + +theorem registerStatement_extends {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (data : Option (WHIRFiatShamir.StackInitial p cap)) : + Extends s (registerStatement s p entry data) := by + unfold registerStatement + cases found : s.entries p entry with + | some _ => exact .refl s + | none => + refine ⟨fun _ _ h => h,fun _ _ h => h,fun _ _ _ => rfl,?_,fun _ _ _ => rfl⟩ + intro q other old known + by_cases hp : q = p + · subst q + by_cases hs : other = entry + · subst other; simp [found] at known + · simpa [Function.update_of_ne hs] using known + · simpa [Function.update_of_ne hp] using known + +def selected {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (data : Option (WHIRFiatShamir.StackInitial p cap)) : Option (WHIRFiatShamir.StackInitial p cap) := + (s.entries p entry).getD data + +theorem registerStatement_found {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (data : Option (WHIRFiatShamir.StackInitial p cap)) : + (registerStatement s p entry data).entries p entry = some (selected s p entry data) := by + unfold registerStatement selected + cases found : s.entries p entry <;> simp [found] + +structure Commitment (p : Profile) where + digest : Digest32 + lanes : Nat + lane_bound : lanes ≤ 2 ^ (config p).folds[0]! + snapshot : Snapshot + records : Records + +def capture {cap : Nat} (s : State cap) (p : Profile) (root : Digest32) (lanes : Nat) + (bound : lanes ≤ 2 ^ (config p).folds[0]!) : Commitment p := + ⟨root,lanes,bound,(lookup root s.registry).getD (snapshot []),(s.frozen root).getD []⟩ + +/-- Call at the actual commitment announcement, before choosing opening claims. Prequeried roots retain the earlier snapshot instead of being reassigned. -/ +def commit {cap : Nat} (s : State cap) (p : Profile) (root : Digest32) (lanes : Nat) + (bound : lanes ≤ 2 ^ (config p).folds[0]!) : State cap × Commitment p := + let next := registerRoot s root + (next,capture next p root lanes bound) + +noncomputable def Commitment.base {p : Profile} (c : Commitment p) : CausalGame.BaseOracle := + WHIRPhysicalRows.compactBaseOracle (recordedHash c.records (fun _ => 0)) c.snapshot c.digest + (remaining (config p) 0 + (config p).rates[0]!) (ParameterBounds.length (config p) 0) + (2 ^ (config p).folds[0]!) c.lanes + +structure OriginalClaims (cap : Nat) where + count : Nat + family : Fin count → RingPCSGame.FamilyClaim + family_bound : count ≤ cap + points : Array RingPCSGame.PointClaim + claim_bound : points.size + 1 ≤ 2^64 + +noncomputable def bindClaims {cap : Nat} {p : Profile} (c : Commitment p) + (claims : OriginalClaims cap) : WHIRFiatShamir.StackInitial p cap where + lanes := c.lanes + root := c.base + lane_bound := c.lane_bound + familyCount := claims.count + family := claims.family + family_bound := claims.family_bound + points := claims.points + claim_bound := claims.claim_bound + +/-- The witness list is chosen from the captured commitment, before the original family or point claims are supplied. -/ +noncomputable def Commitment.witnesses {p : Profile} (c : Commitment p) := + InitialCandidates.witnesses (config p) c.lanes c.base + +theorem Commitment.witnesses_bound {p : Profile} (c : Commitment p) : c.witnesses.card ≤ 2^32 := + InitialCandidates.production_witnesses_card p c.lanes c.base + +theorem bindClaims_witnesses {cap : Nat} {p : Profile} (c : Commitment p) + (claims : OriginalClaims cap) : + InitialCandidates.witnesses (config p) (bindClaims c claims).lanes (bindClaims c claims).root = + c.witnesses := rfl + +theorem capture_stable {cap : Nat} {old new : State cap} (growth : Extends old new) + (p : Profile) (root : Digest32) (lanes : Nat) (bound : lanes ≤ 2 ^ (config p).folds[0]!) + (snap : Snapshot) (known : lookup root old.registry = some snap) : + capture old p root lanes bound = capture new p root lanes bound := by + simp only [capture,known,growth.registry root snap known,growth.frozen root snap known] + +noncomputable def roots {cap : Nat} (s : State cap) (p : Profile) : WHIRReplay.Roots := + fun root level => intermediateOracle + (recordedHash ((s.frozen root).getD []) (fun _ => 0)) + ((lookup root s.registry).getD (snapshot [])) root + (remaining (config p) level + (config p).rates[level]!) + (ParameterBounds.length (config p) level) (2 ^ (config p).folds[level]!) + +theorem roots_stable {cap : Nat} {old new : State cap} (growth : Extends old new) + (p : Profile) (root : Digest32) (level : Nat) (snap : Snapshot) + (known : lookup root old.registry = some snap) : roots old p root level = roots new p root level := by + simp only [roots,known,growth.registry root snap known,growth.frozen root snap known] + +def Prepared {cap : Nat} (s : State cap) (p : Profile) (key : StackWHIRReplay.Key p) : Prop := + ∀ ref ∈ WHIRSnapshotReplay.historyFootprint p key.statement key.messages, + ∃ snap, lookup ref.1 s.registry = some snap + +def registerFootprint {cap : Nat} (s : State cap) (p : Profile) (key : StackWHIRReplay.Key p) : State cap := + registerRoots s ((WHIRSnapshotReplay.historyFootprint p key.statement key.messages).map Prod.fst) + +theorem registerFootprint_extends {cap : Nat} (s : State cap) (p : Profile) (key : StackWHIRReplay.Key p) : + Extends s (registerFootprint s p key) := registerRoots_extends _ _ + +theorem registerFootprint_prepared {cap : Nat} (s : State cap) (p : Profile) (key : StackWHIRReplay.Key p) : + Prepared (registerFootprint s p key) p key := by + intro ref member + exact registerRoots_known _ _ ref.1 (List.mem_map.mpr ⟨ref,member,rfl⟩) + +structure Label (cap : Nat) (p : Profile) where + state : State cap + entry : FramedHistory + key : StackWHIRReplay.Key p + original : Option (WHIRFiatShamir.StackInitial p cap) + found : state.entries p entry = some original + prepared : Prepared state p key + +/-- `proposed` is computed by the source-resolvable caller binding before the fresh packet is sampled. Existing registration wins, including a prequery's earlier registration. -/ +def prepare {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (key : StackWHIRReplay.Key p) (proposed : Option (WHIRFiatShamir.StackInitial p cap)) : State cap × Label cap p := + let registered := registerStatement s p entry proposed + let next := registerFootprint registered p key + (next,⟨next,entry,key,selected s p entry proposed, + (registerFootprint_extends registered p key).entries p entry _ + (registerStatement_found s p entry proposed), + registerFootprint_prepared registered p key⟩) + +theorem prepare_extends {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (key : StackWHIRReplay.Key p) (proposed : Option (WHIRFiatShamir.StackInitial p cap)) : + Extends s (prepare s p entry key proposed).1 := + (registerStatement_extends s p entry proposed).trans (registerFootprint_extends _ p key) + +noncomputable def Label.bad {cap : Nat} {p : Profile} (label : Label cap p) + (x : StackWHIRReplay.Answer p label.key) : Prop := + StackWHIRROM.keyBad p cap (localCatalog label.state p label.entry) (roots label.state p) label.key x + +theorem Label.sparse {cap : Nat} {p : Profile} (label : Label cap p) : + FiatShamirGame.average (fun x => if label.bad x then 1 else 0) ≤ WHIRFiatShamir.stackEta p cap := by + classical + exact StackWHIRROM.key_sparse p cap (localCatalog label.state p label.entry) (roots label.state p) label.key + +theorem Label.final_agreement {cap : Nat} {p : Profile} (label : Label cap p) (final : State cap) + (growth : Extends label.state final) : + localCatalog label.state p label.entry label.key.statement = localCatalog final p label.entry label.key.statement ∧ + WHIRSnapshotReplay.AgreeOn + (WHIRSnapshotReplay.historyFootprint p label.key.statement label.key.messages) + (roots label.state p) (roots final p) := by + constructor + · have stored := label.found.trans (growth.entries p label.entry label.original label.found).symm + simp only [localCatalog, State.catalog, stored] + · intro ref member + obtain ⟨snap,known⟩ := label.prepared ref member + exact roots_stable growth p ref.1 ref.2 snap known + +theorem Label.bad_final {cap : Nat} {p : Profile} (label : Label cap p) (final : State cap) + (growth : Extends label.state final) (x : StackWHIRReplay.Answer p label.key) : + label.bad x ↔ StackWHIRROM.keyBad p cap (localCatalog final p label.entry) (roots final p) label.key x := by + obtain ⟨catalog,agree⟩ := label.final_agreement final growth + exact WHIRSnapshotReplay.stack_keyBad_congr p cap (localCatalog label.state p label.entry) + (localCatalog final p label.entry) (roots label.state p) (roots final p) label.key x catalog agree + +/-- Rejected entries contribute no bad event, even after an arbitrary future extension. -/ +theorem Label.rejected_final {cap : Nat} {p : Profile} (label : Label cap p) + (rejected : label.original = none) (final : State cap) + (growth : Extends label.state final) (x : StackWHIRReplay.Answer p label.key) : + final.entries p label.entry = some none ∧ final.catalog p label.entry = none ∧ + ¬ StackWHIRROM.keyBad p cap (localCatalog final p label.entry) (roots final p) label.key x := by + have frozen := growth.rejected p label.entry (label.found.trans (congrArg some rejected)) + refine ⟨frozen.1, frozen.2, ?_⟩ + have absent : localCatalog final p label.entry label.key.statement = none := by + simp [localCatalog, frozen.2] + have initial : StackWHIRReplay.decodeInitial p cap (localCatalog final p label.entry) label.key = none := by + unfold StackWHIRReplay.decodeInitial + split <;> simp [absent] + simp [StackWHIRROM.keyBad, initial, StackWHIRReplay.decode, absent] + +theorem Label.rejected_bad {cap : Nat} {p : Profile} (label : Label cap p) + (rejected : label.original = none) (x : StackWHIRReplay.Answer p label.key) : + ¬ label.bad x := + (label.rejected_final rejected label.state (.refl _) x).2.2 + +structure ClaimRequest (cap : Nat) (p : Profile) where + root : Digest32 + lanes : Nat + lane_bound : lanes ≤ 2 ^ (config p).folds[0]! + claims : OriginalClaims cap + +/-- Resolve before sampling. A real request's root is captured before binding; +an unresolved caller is registered as a permanent rejection, without fake claims. -/ +noncomputable def prepareClaims {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) : State cap × Label cap p := + match request with + | none => prepare s p entry key none + | some request => + let committed := commit s p request.root request.lanes request.lane_bound + prepare committed.1 p entry key (some (bindClaims committed.2 request.claims)) + +@[simp] theorem prepareClaims_key {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) : + (prepareClaims s p entry key request).2.key = key := by + cases request <;> rfl + +@[simp] theorem prepareClaims_entry {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) : + (prepareClaims s p entry key request).2.entry = entry := by + cases request <;> rfl + +@[simp] theorem prepareClaims_state {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) : + (prepareClaims s p entry key request).2.state = (prepareClaims s p entry key request).1 := by + cases request <;> rfl + +theorem prepareClaims_extends {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) : + Extends s (prepareClaims s p entry key request).1 := by + cases request with + | none => exact prepare_extends _ _ _ _ _ + | some request => + exact (registerRoot_extends s request.root).trans (prepare_extends _ _ _ _ _) + +/-- The first unresolved caller is recorded, rather than left available for replacement. -/ +theorem prepareClaims_first_rejected {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (fresh : s.entries p entry = none) : + (prepareClaims s p entry key none).1.entries p entry = some none := by + exact (registerFootprint_extends (registerStatement s p entry none) p key).entries p entry none + (by simpa [selected, fresh] using registerStatement_found s p entry none) + +/-- Any later resolver request, valid or invalid, preserves an earlier rejection. -/ +theorem prepareClaims_preserves_rejection {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) + (rejected : s.entries p entry = some none) : + (prepareClaims s p entry key request).1.entries p entry = some none ∧ + (prepareClaims s p entry key request).1.catalog p entry = none := + (prepareClaims_extends s p entry key request).rejected p entry rejected + +theorem commit_persists {cap : Nat} (s : State cap) (p : Profile) (root : Digest32) + (lanes : Nat) (bound : lanes ≤ 2 ^ (config p).folds[0]!) (later : State cap) + (growth : Extends (commit s p root lanes bound).1 later) : + (commit s p root lanes bound).2 = capture later p root lanes bound := by + obtain ⟨snap,known⟩ := registerRoot_known s root + exact capture_stable growth p root lanes bound snap known + +theorem commitment_before_claims (cap : Nat) (p : Profile) (c : Commitment p) : + ∃ candidates : Finset (Witness (config p) c.lanes), + candidates.card ≤ 2^32 ∧ ∀ claims : OriginalClaims cap, + InitialCandidates.witnesses (config p) (bindClaims c claims).lanes + (bindClaims c claims).root = candidates := + ⟨c.witnesses,c.witnesses_bound,fun claims => bindClaims_witnesses c claims⟩ + +def Covered {cap : Nat} (s : State cap) : Prop := + ∀ root snap, lookup root s.registry = some snap → + snap.table ⊆ recordDomain ((s.frozen root).getD []) + +theorem empty_covered (cap : Nat) : Covered (empty cap) := by + intro root snap known + simp [empty,lookup] at known + +theorem observe_covered {cap : Nat} (s : State cap) (input : List Byte) (value : Digest32) + (covered : Covered s) : Covered (observe s input value) := by + unfold observe + cases recordLookup input s.records <;> exact covered + +theorem registerRoot_covered {cap : Nat} (s : State cap) (root : Digest32) + (covered : Covered s) : Covered (registerRoot s root) := by + unfold registerRoot + cases found : lookup root s.registry with + | some _ => exact covered + | none => + intro r snap known + by_cases eq : r = root + · subst r + have hs : snap = snapshot s.records := by + simpa [register,found,lookup] using known.symm + subst snap + simp [snapshot] + · have old : lookup r s.registry = some snap := by + simpa [register,found,lookup,eq] using known + simpa [Function.update_of_ne eq] using covered r snap old + +theorem registerRoots_covered {cap : Nat} (s : State cap) (rs : List Digest32) + (covered : Covered s) : Covered (registerRoots s rs) := by + induction rs generalizing s with + | nil => exact covered + | cons r rs ih => exact ih (registerRoot s r) (registerRoot_covered s r covered) + +theorem registerStatement_covered {cap : Nat} (s : State cap) (p : Profile) + (entry : FramedHistory) (data : Option (WHIRFiatShamir.StackInitial p cap)) (covered : Covered s) : + Covered (registerStatement s p entry data) := by + unfold registerStatement + cases s.entries p entry <;> exact covered + +theorem prepare_covered {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (key : StackWHIRReplay.Key p) (proposed : Option (WHIRFiatShamir.StackInitial p cap)) + (covered : Covered s) : Covered (prepare s p entry key proposed).1 := + registerRoots_covered _ _ (registerStatement_covered s p entry proposed covered) + +theorem prepareClaims_covered {cap : Nat} (s : State cap) (p : Profile) (entry : FramedHistory) + (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) (covered : Covered s) : + Covered (prepareClaims s p entry key request).1 := by + cases request with + | none => exact prepare_covered _ _ _ _ _ covered + | some request => exact prepare_covered _ _ _ _ _ (registerRoot_covered s request.root covered) + +def AuthenticState {cap : Nat} (hash : MerkleTransport.Primitive) (s : State cap) : Prop := + Authentic hash s.records ∧ ∀ root records, s.frozen root = some records → Authentic hash records + +theorem empty_authentic (hash : MerkleTransport.Primitive) (cap : Nat) : + AuthenticState hash (empty cap) := by + simp [AuthenticState,empty,Authentic] + +theorem observe_authentic {cap : Nat} (hash : MerkleTransport.Primitive) (s : State cap) + (input : List Byte) (value : Digest32) (authentic : AuthenticState hash s) + (answer : hash input = value) : AuthenticState hash (observe s input value) := by + unfold observe + cases recordLookup input s.records with + | some _ => exact authentic + | none => + refine ⟨?_,authentic.2⟩ + intro x d member + rcases List.mem_cons.mp member with eq | member + · cases eq; exact answer + · exact authentic.1 x d member + +theorem registerRoot_authentic {cap : Nat} (hash : MerkleTransport.Primitive) (s : State cap) + (root : Digest32) (authentic : AuthenticState hash s) : + AuthenticState hash (registerRoot s root) := by + unfold registerRoot + cases lookup root s.registry with + | some _ => exact authentic + | none => + refine ⟨authentic.1,?_⟩ + intro r records known + by_cases eq : r = root + · subst r + have hr : records = s.records := by simpa using known.symm + subst records + exact authentic.1 + · exact authentic.2 r records (by simpa [Function.update_of_ne eq] using known) + +theorem registerRoots_authentic {cap : Nat} (hash : MerkleTransport.Primitive) (s : State cap) + (rs : List Digest32) (authentic : AuthenticState hash s) : + AuthenticState hash (registerRoots s rs) := by + induction rs generalizing s with + | nil => exact authentic + | cons r rs ih => exact ih (registerRoot s r) (registerRoot_authentic hash s r authentic) + +theorem registerStatement_authentic {cap : Nat} (hash : MerkleTransport.Primitive) + (s : State cap) (p : Profile) (entry : FramedHistory) (data : Option (WHIRFiatShamir.StackInitial p cap)) + (authentic : AuthenticState hash s) : AuthenticState hash (registerStatement s p entry data) := by + unfold registerStatement + cases s.entries p entry <;> exact authentic + +theorem frozen_authentic {cap : Nat} (hash : MerkleTransport.Primitive) (s : State cap) + (authentic : AuthenticState hash s) (root : Digest32) : + Authentic hash ((s.frozen root).getD []) := by + cases found : s.frozen root with + | none => simp [Authentic] + | some records => exact authentic.2 root records found + +theorem capture_covered {cap : Nat} (s : State cap) (p : Profile) (root : Digest32) + (lanes : Nat) (bound : lanes ≤ 2 ^ (config p).folds[0]!) (covered : Covered s) : + (capture s p root lanes bound).snapshot.table ⊆ + recordDomain (capture s p root lanes bound).records := by + cases found : lookup root s.registry with + | none => simp [capture,found,snapshot,recordDomain] + | some snap => simpa [capture,found] using covered root snap found + +/-- This is a locality theorem about genuine exposed hash answers, not a future-dependent choice of an ideal row oracle. -/ +theorem capture_base_actual {cap : Nat} (hash : MerkleTransport.Primitive) (s : State cap) + (p : Profile) (root : Digest32) (lanes : Nat) (bound : lanes ≤ 2 ^ (config p).folds[0]!) + (covered : Covered s) (authentic : AuthenticState hash s) : + (capture s p root lanes bound).base = + WHIRPhysicalRows.compactBaseOracle hash (capture s p root lanes bound).snapshot root + (remaining (config p) 0 + (config p).rates[0]!) (ParameterBounds.length (config p) 0) + (2 ^ (config p).folds[0]!) lanes := + (WHIRPhysicalRows.compactBaseOracle_eq_recorded hash _ root _ _ _ _ _ _ + (frozen_authentic hash s authentic root) (capture_covered s p root lanes bound covered)).symm + +theorem roots_actual {cap : Nat} (hash : MerkleTransport.Primitive) (s : State cap) + (p : Profile) (root : Digest32) (level : Nat) (snap : Snapshot) + (known : lookup root s.registry = some snap) (covered : Covered s) + (authentic : AuthenticState hash s) : + roots s p root level = intermediateOracle hash snap root + (remaining (config p) level + (config p).rates[level]!) + (ParameterBounds.length (config p) level) (2 ^ (config p).folds[level]!) := by + simp only [roots,known,Option.getD_some] + exact (intermediateOracle_eq_recorded hash snap root _ _ _ _ _ + (frozen_authentic hash s authentic root) (covered root snap known)).symm + +end Whir.CausalBindingState diff --git a/verification/whir/Whir/CausalBoundary.lean b/verification/whir/Whir/CausalBoundary.lean new file mode 100644 index 000000000..cfb28a331 --- /dev/null +++ b/verification/whir/Whir/CausalBoundary.lean @@ -0,0 +1,585 @@ +import Whir.CausalExecution +import Whir.CausalProbability +import Whir.QueryBatchSoundness +import Whir.ConcreteCandidates +import Whir.CausalPositions +import Whir.CausalStateCausality + +namespace Whir.CausalBoundary +open Concrete Protocol CausalGame CausalExecution CausalProbability +open Classical +open scoped BigOperators + +set_option maxRecDepth 4096 +set_option maxHeartbeats 800000 + +/-- The list is fixed by the last fold response, not by an OOD answer. -/ +def OodEvent (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (j : Fin (oodCount input.config i)) + (tape : Tape input.config) : Prop := + ¬ LevelBoundary.Separated (followingCandidates input strategy tape i) + (challenges input.config tape).levels[i.val]!.oodPoints[j.val]! + +/-- The actual incoming state immediately after the complete fold block. -/ +def boundary (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Nat) : CheckedState := + foldAt input strategy tape i input.config.folds[i]! + +/-- All shape, separation, and authentication conditions are guards of this +prefix event. No acceptance test or future response occurs in the event. -/ +def QueryEvent (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (tape : Tape input.config) : Prop := + let c := input.config + let cs := (challenges c tape).levels[i.val]! + let p := (proof input strategy tape).levels[i.val]! + let s := boundary input strategy tape i + let n := remaining c i + let qs := (deriveQueries (n + c.rates[i.val]!) c.queries[i.val]! cs.querySqueezes).getD #[] + s.n = n ∧ s.state.weight.size = 2 ^ n ∧ + LevelBoundary.CloseLost n c.rates[i.val]! (ParameterBounds.threshold c i) + (QueryBatchSoundness.oldWord n c.rates[i.val]! + (levelAt input strategy tape i).oracle (i.val == 0) cs.folds) s.state ∧ + (if i.val + 1 < c.folds.size then + ∃ j < p.oods.size, LevelBoundary.Separated (followingCandidates input strategy tape i) + cs.oodPoints[j]! + else (proof input strategy tape).residual.size = 2 ^ n) ∧ + p.rows.size = qs.size ∧ + runChecked (authenticateRow (levelAt input strategy tape i).oracle qs p) qs.size 0 () = .ok () ∧ + ¬ VerifierInvariant.Lost (followingCandidates input strategy tape i) + (levelAt input strategy tape (i.val + 1)).state + +set_option maxHeartbeats 0 in +/-- Arithmetic of the supported production ladder, including the genuine +zero-OOD last level and the next commitment's coefficient dimension. -/ +theorem production_boundary_facts : ∀ p : ParameterBounds.Profile, + ∀ i : Fin (ParameterBounds.config p).folds.size, + 0 < remaining (ParameterBounds.config p) i + (ParameterBounds.config p).rates[i.val]! ∧ + remaining (ParameterBounds.config p) i + (ParameterBounds.config p).rates[i.val]! ≤ 64 ∧ + (i.val + 1 < (ParameterBounds.config p).folds.size → + remaining (ParameterBounds.config p) (i.val + 1) + + (ParameterBounds.config p).folds[i.val + 1]! = + remaining (ParameterBounds.config p) i ∧ + 0 < oodCount (ParameterBounds.config p) i) := by + decide +kernel + + theorem followingCandidates_card (input : Public) (strategy : Strategy) + (tape : Tape input.config) (p : ParameterBounds.Profile) + (hc : input.config = ParameterBounds.config p) (i : Fin input.config.folds.size) : + (followingCandidates input strategy tape i).card ≤ 2 ^ 32 := by + unfold followingCandidates + split_ifs with hn + · have cap := ConcreteCandidates.production_arrayCandidates_card false p + ⟨i.val + 1, by simpa [← hc] using hn⟩ + (lanes := 2 ^ (input.config.folds[i.val + 1]! - 0)) + simp only [Fin.val_mk] at cap + rw [← hc] at cap + exact cap _ + · simp + + theorem followingCandidates_sizes (input : Public) (strategy : Strategy) + (tape : Tape input.config) (p : ParameterBounds.Profile) + (hc : input.config = ParameterBounds.config p) (i : Fin input.config.folds.size) + (shape : ¬ i.val + 1 < input.config.folds.size → + (proof input strategy tape).residual.size = 2 ^ remaining input.config i) : + ∀ f ∈ followingCandidates input strategy tape i, f.size = 2 ^ remaining input.config i := by + intro f hf + unfold followingCandidates at hf + split_ifs at hf with hn + · have size := OracleReplay.candidate_size false input.config.folds[i.val + 1]! + (remaining input.config (i.val + 1)) input.config.rates[i.val + 1]! 0 + (ParameterBounds.threshold input.config (i.val + 1)) + ((proof input strategy tape).levels[i.val]!.nextOracle.getD #[]) + (challenges input.config tape).levels[i.val + 1]!.folds f hf + have dim := (production_boundary_facts p ⟨i.val, by simp [← hc]⟩).2.2 + (by simpa [← hc] using hn) + have hd : remaining input.config (i.val + 1) + input.config.folds[i.val + 1]! = + remaining input.config i := by simpa only [← hc] using dim.1 + simpa only [Nat.sub_zero, hd] using size + · exact (congrArg Array.size (Finset.mem_singleton.mp hf)).trans (shape hn) + +theorem decoded_oods_size (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) : + (proof input strategy tape).levels[i.val]!.oods.size = oodCount input.config i := by + simp [proof, CausalTerminal.proof, decodedOpening, decodedLevel, challenges, + _root_.getElem!_pos, i.isLt] + +theorem point_size (input : Public) (tape : Tape input.config) + (i : Fin input.config.folds.size) (j : Nat) (hj : j < oodCount input.config i) : + (eqTable (challenges input.config tape).levels[i.val]!.oodPoints[j]!).size = + 2 ^ remaining input.config i := by + simp [challenges, _root_.getElem!_pos, i.isLt, hj, TerminalRefinement.size_eqTable] + +/-- Fixed-prefix transition bound for the real list, state and commitment. +Only the arbitrary rows and intro range over the indivisible query draw. -/ +theorem actual_transition (input : Public) (strategy : Strategy) (tape : Tape input.config) + (profile : ParameterBounds.Profile) (hc : input.config = ParameterBounds.config profile) + (i : Fin input.config.folds.size) + (rowsAt : LevelBoundary.QueryTape (remaining input.config i + input.config.rates[i.val]!) + input.config.queries[i.val]! → E → Oracle) + (introAt : LevelBoundary.QueryTape (remaining input.config i + input.config.rates[i.val]!) + input.config.queries[i.val]! → E → Message E) + (weight : (boundary input strategy tape i).state.weight.size = 2 ^ remaining input.config i) + (lost : LevelBoundary.CloseLost (remaining input.config i) input.config.rates[i.val]! + (ParameterBounds.threshold input.config i) + (QueryBatchSoundness.oldWord (remaining input.config i) input.config.rates[i.val]! + (levelAt input strategy tape i).oracle (i.val == 0) + (challenges input.config tape).levels[i.val]!.folds) + (boundary input strategy tape i).state) + (prior : if i.val + 1 < input.config.folds.size then + ∃ j < (proof input strategy tape).levels[i.val]!.oods.size, + LevelBoundary.Separated (followingCandidates input strategy tape i) + (challenges input.config tape).levels[i.val]!.oodPoints[j]! + else (proof input strategy tape).residual.size = 2 ^ remaining input.config i) : + Soundness.uniformProb (Finset.univ.filter + (QueryBatchSoundness.Restores (remaining input.config i) input.config.rates[i.val]! + input.config.queries[i.val]! i (levelAt input strategy tape i).oracle + (challenges input.config tape).levels[i.val]! (proof input strategy tape).levels[i.val]! + (boundary input strategy tape i).state (followingCandidates input strategy tape i) + rowsAt introAt)) ≤ + GroupedChallenges.queryBatchError input.config (ParameterBounds.estimates input.config) i := by + have facts := production_boundary_facts profile ⟨i.val, by simp [← hc]⟩ + dsimp only at facts + rw [← hc] at facts + have alpha := (ParameterBounds.production_level_facts profile + ⟨i.val, by simp [← hc]⟩).2.2.2.2.2.2.1 + dsimp only at alpha + rw [← hc] at alpha + have threshold : ParameterBounds.threshold input.config i = + ⌈(2 ^ (remaining input.config i + input.config.rates[i.val]!) : ℚ) * + ParameterBounds.alpha input.config.rates[i.val]!⌉₊ := by + simp [ParameterBounds.threshold, ParameterBounds.length] + by_cases hn : i.val + 1 < input.config.folds.size + · simp only [hn, ↓reduceIte] at prior + obtain ⟨j, hj, sep⟩ := prior + have bound := QueryBatchSoundness.grouped_transition + (remaining input.config i) input.config.rates[i.val]! input.config.queries[i.val]! i + (ParameterBounds.threshold input.config i) (levelAt input strategy tape i).oracle + (challenges input.config tape).levels[i.val]! (proof input strategy tape).levels[i.val]! + (boundary input strategy tape i).state (followingCandidates input strategy tape i) + rowsAt introAt (ParameterBounds.alpha input.config.rates[i.val]!) alpha.le threshold + facts.1 facts.2.1 + (followingCandidates_sizes input strategy tape profile hc i (by simp [hn])) + weight (by intro k hk; exact point_size input tape i k (by + simpa only [decoded_oods_size] using hk)) lost j hj sep + apply bound.trans + have cap : ((followingCandidates input strategy tape i).card : ℚ) ≤ 2 ^ 32 := by + exact_mod_cast followingCandidates_card input strategy tape profile hc i + simp only [GroupedChallenges.queryBatchError, ParameterBounds.estimates, hn, + ↓reduceDIte, GroupedChallenges.fieldSize, decoded_oods_size] + have mul := mul_le_mul_of_nonneg_right cap + (by positivity : (0 : ℚ) ≤ + ((oodCount input.config i + input.config.queries[i.val]! : Nat) : ℚ) / 2 ^ 192) + push_cast at mul ⊢ + nlinarith + · simp only [hn, ↓reduceIte] at prior + have last : followingCandidates input strategy tape i = + {(proof input strategy tape).residual} := by simp [followingCandidates, hn] + rw [last] + have zero : (proof input strategy tape).levels[i.val]!.oods.size = 0 := by + rw [decoded_oods_size] + simp [oodCount, hn] + have bound := QueryBatchSoundness.final_transition + (remaining input.config i) input.config.rates[i.val]! input.config.queries[i.val]! i + (ParameterBounds.threshold input.config i) (levelAt input strategy tape i).oracle + (challenges input.config tape).levels[i.val]! (proof input strategy tape).levels[i.val]! + (boundary input strategy tape i).state (proof input strategy tape).residual + rowsAt introAt (ParameterBounds.alpha input.config.rates[i.val]!) alpha.le threshold + facts.1 facts.2.1 prior weight zero lost + simpa only [GroupedChallenges.queryBatchError, ParameterBounds.estimates, hn, + ↓reduceDIte, GroupedChallenges.fieldSize] using bound + +theorem decoded_level (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) : + (proof input strategy tape).levels[i.val]! = + decodedLevel input.config (challenges input.config tape) + (run strategy input [] (visibleBatches input.config tape.1 + (challenges input.config tape))).toArray i.val := by + simp [proof, CausalTerminal.proof, decodedOpening, _root_.getElem!_pos, i.isLt] + +theorem nextOracle_set (input : Public) (strategy : Strategy) (tape : Tape input.config) + (q : Coordinate input.config) (x : Sample q) (i : Fin input.config.folds.size) + (before : levelStart (challenges input.config tape) i.val + input.config.folds[i.val]! ≤ + position q) : + (proof input strategy (set q tape x)).levels[i.val]!.nextOracle = + (proof input strategy tape).levels[i.val]!.nextOracle := by + have sizes (t : Tape input.config) : + (challenges input.config t).levels[i.val]!.folds.size = input.config.folds[i.val]! := by + simp [challenges, _root_.getElem!_pos, i.isLt] + simp only [decoded_level, decodedLevel, sizes, CausalPositions.levelStart_set] + split_ifs with h + · simpa using field_before q tape x strategy input rootField + (levelStart (challenges input.config tape) i.val + input.config.folds[i.val]! - 1) + (by omega) + · rfl + +theorem residual_set (input : Public) (strategy : Strategy) (tape : Tape input.config) + (q : Coordinate input.config) (x : Sample q) (i : Fin input.config.folds.size) + (last : ¬ i.val + 1 < input.config.folds.size) + (before : levelStart (challenges input.config tape) i.val + input.config.folds[i.val]! ≤ + position q) : + (proof input strategy (set q tape x)).residual = (proof input strategy tape).residual := by + have hi : input.config.folds.size - 1 = i.val := by omega + have sizes (t : Tape input.config) : + (challenges input.config t).levels[i.val]!.folds.size = input.config.folds[i.val]! := by + simp [challenges, _root_.getElem!_pos, i.isLt] + simp only [proof, CausalTerminal.proof, decodedOpening, hi, sizes, + CausalPositions.levelStart_set] + split_ifs with h + · simpa using field_before q tape x strategy input residualField + (levelStart (challenges input.config tape) i.val + input.config.folds[i.val]! - 1) + (by omega) + · rfl + +theorem followingCandidates_set (input : Public) (strategy : Strategy) (tape : Tape input.config) + (q : Coordinate input.config) (x : Sample q) (i : Fin input.config.folds.size) + (before : levelStart (challenges input.config tape) i.val + input.config.folds[i.val]! ≤ + position q) : + followingCandidates input strategy (set q tape x) i = + followingCandidates input strategy tape i := by + unfold followingCandidates + split_ifs with hn + · apply congrArg (fun oracle : Fin (2 ^ (input.config.folds[i.val + 1]! - 0)) → + Fin (2 ^ (remaining input.config (i.val + 1) + input.config.rates[i.val + 1]!)) → E => + CandidateFolding.arrayCandidates false + (CandidateFolding.concreteEncoder (remaining input.config (i.val + 1)) + input.config.rates[i.val + 1]!) oracle + (ParameterBounds.threshold input.config (i.val + 1))) + funext lane col + simp only [OracleReplay.oracleAt, OracleReplay.rowAt_zero] + rw [nextOracle_set input strategy tape q x i before] + · rw [residual_set input strategy tape q x i hn before] + +theorem ood_fiber_bound (input : Public) (strategy : Strategy) + (profile : ParameterBounds.Profile) (hc : input.config = ParameterBounds.config profile) + (i : Fin input.config.folds.size) (j : Fin (oodCount input.config i)) + (rest : Rest (.ood i j)) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample (.ood i j) => + OodEvent input strategy i j (set (.ood i j) rest.val x)) ≤ + ((2 ^ 32).choose 2 : ℚ) * (remaining input.config i : ℚ) / 2 ^ 192 := by + have hn : i.val + 1 < input.config.folds.size := by + by_contra h + have := j.isLt + simp [oodCount, h] at this + have event : (fun x : Sample (.ood i j) => + OodEvent input strategy i j (set (.ood i j) rest.val x)) = + (fun x : Fin (remaining input.config i) → E => + ¬ LevelBoundary.Separated (followingCandidates input strategy rest.val i) + (Array.ofFn x)) := by + funext x + unfold OodEvent + rw [followingCandidates_set input strategy rest.val (.ood i j) x i (by + rw [CausalPositions.position_ood i j rest.val]; omega)] + have h := challengeBatch_eq (.ood i j) (set (.ood i j) rest.val x) + rw [get_set] at h + exact congrArg (fun point => ¬ LevelBoundary.Separated + (followingCandidates input strategy rest.val i) point) (Batch.ood.inj h).2.2 + simp only [event] + have bound := LevelBoundary.separation_probability (remaining input.config i) + (followingCandidates input strategy rest.val i) + (followingCandidates_sizes input strategy rest.val profile hc i (by simp [hn])) + have cap : ((followingCandidates input strategy rest.val i).card.choose 2 : ℚ) ≤ + (2 ^ 32).choose 2 := by + exact_mod_cast Nat.choose_le_choose 2 (followingCandidates_card input strategy rest.val profile hc i) + have enlarged := bound.trans (mul_le_mul_of_nonneg_right cap + (div_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _))) + rw [ParameterBounds.field_cardinality] at enlarged + exact enlarged.trans_eq (mul_div_assoc _ _ _).symm + +theorem ood_coordinate_probability (input : Public) (strategy : Strategy) + (profile : ParameterBounds.Profile) (hc : input.config = ParameterBounds.config profile) + (i : Fin input.config.folds.size) (j : Fin (oodCount input.config i)) : + Soundness.uniformProb (Finset.univ.filter (OodEvent input strategy i j)) ≤ + ((2 ^ 32).choose 2 : ℚ) * (remaining input.config i : ℚ) / 2 ^ 192 := + fiber_event_bound (.ood i j) _ _ (ood_fiber_bound input strategy profile hc i j) + +theorem ood_probability (input : Public) (strategy : Strategy) + (profile : ParameterBounds.Profile) (hc : input.config = ParameterBounds.config profile) + (i : Fin input.config.folds.size) : + Soundness.uniformProb (Finset.univ.biUnion fun j : Fin (oodCount input.config i) => + Finset.univ.filter (OodEvent input strategy i j)) ≤ + GroupedChallenges.oodError input.config (ParameterBounds.estimates input.config) i := by + apply (Soundness.union_bound _).trans + calc + _ ≤ ∑ _j : Fin (oodCount input.config i), + ((2 ^ 32).choose 2 : ℚ) * (remaining input.config i : ℚ) / 2 ^ 192 := + Finset.sum_le_sum fun j _ => ood_coordinate_probability input strategy profile hc i j + _ ≤ _ := by + by_cases hn : i.val + 1 < input.config.folds.size + · simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul, + GroupedChallenges.oodError, ParameterBounds.estimates, hn, ↓reduceDIte, + GroupedChallenges.fieldSize, mul_div_assoc, mul_assoc, le_refl] + · have hz : oodCount input.config i = 0 := by simp only [oodCount, hn, ↓reduceIte] + simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, hz, zero_nsmul, + GroupedChallenges.oodError, hn, ↓reduceDIte, le_refl] + +theorem oods_set (input : Public) (strategy : Strategy) (tape : Tape input.config) + (q : Coordinate input.config) (x : Sample q) (i : Fin input.config.folds.size) + (before : levelStart (challenges input.config tape) i.val + input.config.folds[i.val]! + + oodCount input.config i ≤ position q) : + (proof input strategy (set q tape x)).levels[i.val]!.oods = + (proof input strategy tape).levels[i.val]!.oods := by + have fs (t : Tape input.config) : + (challenges input.config t).levels[i.val]!.folds.size = input.config.folds[i.val]! := by + simp [challenges, _root_.getElem!_pos, i.isLt] + have os (t : Tape input.config) : + (challenges input.config t).levels[i.val]!.oodPoints.size = oodCount input.config i := by + simp [challenges, _root_.getElem!_pos, i.isLt] + simp only [decoded_level, decodedLevel, fs, os, CausalPositions.levelStart_set] + apply Array.ext + · simp only [Array.size_ofFn, os] + · intro j hj hj' + simp only [Array.getElem_ofFn] + simpa using field_before q tape x strategy input oodField + (levelStart (challenges input.config tape) i.val + input.config.folds[i.val]! + j) + (by simp only [Array.size_ofFn, os] at hj; omega) + +theorem query_challenges (input : Public) (tape : Tape input.config) + (i : Fin input.config.folds.size) (x : Sample (.query i)) : + (challenges input.config (set (.query i) tape x)).levels[i.val]! = + { (challenges input.config tape).levels[i.val]! with querySqueezes := Array.ofFn x.1, lambda := x.2 } := by + have folds : (challenges input.config (set (.query i) tape x)).levels[i.val]!.folds = + (challenges input.config tape).levels[i.val]!.folds := by + simp only [challenges, _root_.getElem!_pos, Array.size_ofFn, i.isLt, Array.getElem_ofFn] + apply congrArg Array.ofFn + funext j + exact get_set_ne (.query i) (.fold i j) tape x (by intro h; cases h) + have oods : (challenges input.config (set (.query i) tape x)).levels[i.val]!.oodPoints = + (challenges input.config tape).levels[i.val]!.oodPoints := by + simp only [challenges, _root_.getElem!_pos, Array.size_ofFn, i.isLt, Array.getElem_ofFn] + apply congrArg Array.ofFn + funext j + apply congrArg Array.ofFn + exact get_set_ne (.query i) (.ood i j) tape x (by intro h; cases h) + have query := challengeBatch_eq (.query i) (set (.query i) tape x) + rw [get_set] at query + have values := Batch.query.inj query + cases left : (challenges input.config (set (.query i) tape x)).levels[i.val]! + cases right : (challenges input.config tape).levels[i.val]! + simp_all only + +theorem boundary_eq_foldBlock (input : Public) (strategy : Strategy) + (tape : Tape input.config) (i : Fin input.config.folds.size) : + boundary input strategy tape i = + Protocol.foldBlock (block input.config i) (challenges input.config tape).levels[i.val]! + (proof input strategy tape).levels[i.val]! (levelAt input strategy tape i) := by + have sizes : (challenges input.config tape).levels[i.val]!.folds.size = + input.config.folds[i.val]! := by + simp [challenges, _root_.getElem!_pos, i.isLt] + simp only [boundary, foldAt, Protocol.foldBlock, sizes] + +theorem next_state (input : Public) (strategy : Strategy) + (tape : Tape input.config) (i : Fin input.config.folds.size) : + (levelAt input strategy tape (i.val + 1)).state = + queryBatch (boundary input strategy tape i).n i + (challenges input.config tape).levels[i.val]! (proof input strategy tape).levels[i.val]! + ((deriveQueries ((boundary input strategy tape i).n + input.config.rates[i.val]!) + input.config.queries[i.val]! (challenges input.config tape).levels[i.val]!.querySqueezes).getD #[]) + (oodBatch (challenges input.config tape).levels[i.val]! + (proof input strategy tape).levels[i.val]! (boundary input strategy tape i).state) := by + rw [levelAt_succ] + simp only [next, boundary_eq_foldBlock] + +def QueryPrior (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (tape : Tape input.config) : Prop := + let c := input.config + let cs := (challenges c tape).levels[i.val]! + let p := (proof input strategy tape).levels[i.val]! + let s := boundary input strategy tape i + let n := remaining c i + s.n = n ∧ s.state.weight.size = 2 ^ n ∧ + LevelBoundary.CloseLost n c.rates[i.val]! (ParameterBounds.threshold c i) + (QueryBatchSoundness.oldWord n c.rates[i.val]! + (levelAt input strategy tape i).oracle (i.val == 0) cs.folds) s.state ∧ + (if i.val + 1 < c.folds.size then + ∃ j < p.oods.size, LevelBoundary.Separated (followingCandidates input strategy tape i) + cs.oodPoints[j]! + else (proof input strategy tape).residual.size = 2 ^ n) + +theorem query_level_set (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) (x : Sample (.query i)) : + levelAt input strategy (set (.query i) tape x) i = levelAt input strategy tape i := + CausalStateCausality.levelAt_set input strategy (.query i) tape x i i.isLt.le + (by rw [CausalPositions.position_query i tape]; omega) + +theorem query_boundary_set (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) (x : Sample (.query i)) : + boundary input strategy (set (.query i) tape x) i = boundary input strategy tape i := + CausalStateCausality.foldAt_set input strategy (.query i) tape x i _ le_rfl + (by rw [CausalPositions.position_query i tape]; omega) + +theorem query_prior_set (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) (x : Sample (.query i)) : + QueryPrior input strategy i (set (.query i) tape x) = QueryPrior input strategy i tape := by + dsimp only [QueryPrior] + rw [query_challenges, query_level_set, query_boundary_set, + followingCandidates_set input strategy tape (.query i) x i (by + rw [CausalPositions.position_query i tape]; omega)] + simp only + by_cases hn : i.val + 1 < input.config.folds.size + · rw [ite_eq_left hn, ite_eq_left hn, oods_set input strategy tape (.query i) x i (by + rw [CausalPositions.position_query])] + · rw [ite_eq_right hn, ite_eq_right hn, residual_set input strategy tape (.query i) x i hn (by + rw [CausalPositions.position_query i tape]; omega)] + +def queryRows (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) + (squeezes : LevelBoundary.QueryTape (remaining input.config i + input.config.rates[i.val]!) + input.config.queries[i.val]!) (lambda : E) : Oracle := + (proof input strategy (set (.query i) tape (squeezes, lambda))).levels[i.val]!.rows + +def queryIntro (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) + (squeezes : LevelBoundary.QueryTape (remaining input.config i + input.config.rates[i.val]!) + input.config.queries[i.val]!) (lambda : E) : Message E := + (proof input strategy (set (.query i) tape (squeezes, lambda))).levels[i.val]!.intro + +private theorem batch_fields_congr (n i : Nat) (cs : LevelChallenges) + (p q : LevelProof) (qs : Array Nat) (s : VerifierState E) + (oods : p.oods = q.oods) (rows : p.rows = q.rows) (intro : p.intro = q.intro) : + queryBatch n i cs p qs (oodBatch cs p s) = + queryBatch n i cs q qs (oodBatch cs q s) := by + cases p + cases q + cases oods + cases rows + cases intro + rfl + +theorem query_event_fiber (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) (x : Sample (.query i)) + (hd : 0 < remaining input.config i + input.config.rates[i.val]!) + (hb : remaining input.config i + input.config.rates[i.val]! ≤ 64) + (h : QueryEvent input strategy i (set (.query i) tape x)) : + QueryPrior input strategy i tape ∧ + QueryBatchSoundness.Restores (remaining input.config i) input.config.rates[i.val]! + input.config.queries[i.val]! i (levelAt input strategy tape i).oracle + (challenges input.config tape).levels[i.val]! (proof input strategy tape).levels[i.val]! + (boundary input strategy tape i).state (followingCandidates input strategy tape i) + (queryRows input strategy tape i) (queryIntro input strategy tape i) x := by + rcases h with ⟨dimension, weight, lost, prior, rows, auth, failure⟩ + have hp : QueryPrior input strategy i (set (.query i) tape x) := + ⟨dimension, weight, lost, prior⟩ + refine ⟨by rwa [query_prior_set] at hp, ?_⟩ + have sampled : + (deriveQueries (remaining input.config i + input.config.rates[i.val]!) + input.config.queries[i.val]! + (challenges input.config (set (.query i) tape x)).levels[i.val]!.querySqueezes).getD #[] = + QueryBatchSoundness.queries (remaining input.config i + input.config.rates[i.val]!) + input.config.queries[i.val]! x.1 := by + rw [query_challenges] + dsimp only + erw [QueryBatchSoundness.queries_actual _ _ x.1 hd hb] + rfl + have fixed := followingCandidates_set input strategy tape (.query i) x i (by + rw [CausalPositions.position_query i tape]; omega) + have answers := oods_set input strategy tape (.query i) x i (by + rw [CausalPositions.position_query]) + rw [next_state, dimension, sampled, fixed, query_boundary_set, query_challenges] at failure + rw [sampled] at rows auth + rw [query_level_set] at auth + unfold QueryBatchSoundness.Restores + dsimp only [queryRows, queryIntro] + refine ⟨rows, ?_, ?_⟩ + · exact auth + · have kernel := batch_fields_congr (remaining input.config i) i + { (challenges input.config tape).levels[i.val]! with querySqueezes := Array.ofFn x.1, lambda := x.2 } + (proof input strategy (set (.query i) tape x)).levels[i.val]! + { (proof input strategy tape).levels[i.val]! with + rows := (proof input strategy (set (.query i) tape x)).levels[i.val]!.rows + intro := (proof input strategy (set (.query i) tape x)).levels[i.val]!.intro } + (QueryBatchSoundness.queries (remaining input.config i + input.config.rates[i.val]!) + input.config.queries[i.val]! x.1) + (boundary input strategy tape i).state answers rfl rfl + erw [kernel] at failure + exact failure + +private theorem probability_mono {A : Type*} [Fintype A] (P Q : A → Prop) + (h : ∀ x, P x → Q x) : + Soundness.uniformProb (Finset.univ.filter P) ≤ + Soundness.uniformProb (Finset.univ.filter Q) := by + classical + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_le_card (by + intro x hx + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h x (Finset.mem_filter.mp hx).2⟩) + +theorem query_fiber_bound (input : Public) (strategy : Strategy) + (profile : ParameterBounds.Profile) (hc : input.config = ParameterBounds.config profile) + (i : Fin input.config.folds.size) (rest : Rest (.query i)) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample (.query i) => + QueryEvent input strategy i (set (.query i) rest.val x)) ≤ + GroupedChallenges.queryBatchError input.config (ParameterBounds.estimates input.config) i := by + classical + have facts := production_boundary_facts profile ⟨i.val, by simp [← hc]⟩ + dsimp only at facts + rw [← hc] at facts + by_cases prior : QueryPrior input strategy i rest.val + · have localBound := actual_transition input strategy rest.val profile hc i + (queryRows input strategy rest.val i) (queryIntro input strategy rest.val i) + prior.2.1 prior.2.2.1 prior.2.2.2 + apply le_trans _ localBound + apply probability_mono + intro x hx + exact (query_event_fiber input strategy rest.val i x facts.1 facts.2.1 hx).2 + · have empty : (Finset.univ.filter fun x : Sample (.query i) => + QueryEvent input strategy i (set (.query i) rest.val x)) = ∅ := by + apply Finset.eq_empty_iff_forall_notMem.mpr + intro x hx + exact prior (query_event_fiber input strategy rest.val i x facts.1 facts.2.1 + (Finset.mem_filter.mp hx).2).1 + rw [empty] + simp only [Soundness.uniformProb, Finset.card_empty, Nat.cast_zero, zero_div] + have alpha := (ParameterBounds.production_level_facts profile + ⟨i.val, by simp [← hc]⟩).2.2.2.2.2.2.1 + dsimp only at alpha + rw [← hc] at alpha + unfold GroupedChallenges.queryBatchError ParameterBounds.estimates GroupedChallenges.fieldSize + split_ifs <;> positivity + +theorem query_probability (input : Public) (strategy : Strategy) + (profile : ParameterBounds.Profile) (hc : input.config = ParameterBounds.config profile) + (i : Fin input.config.folds.size) : + Soundness.uniformProb (Finset.univ.filter (QueryEvent input strategy i)) ≤ + GroupedChallenges.queryBatchError input.config (ParameterBounds.estimates input.config) i := + fiber_event_bound (.query i) _ _ (query_fiber_bound input strategy profile hc i) + +/-- A later random-oracle message cannot change an already exposed OOD event. -/ +theorem oodEvent_set_future (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) (j : Fin (oodCount input.config i)) + (q : Coordinate input.config) (x : Sample q) (later : position (.ood i j) < position q) : + OodEvent input strategy i j (set q tape x) = OodEvent input strategy i j tape := by + have before : levelStart (challenges input.config tape) i.val + + input.config.folds[i.val]! ≤ position q := by + rw [CausalPositions.position_ood i j tape] at later + omega + simp only [OodEvent, followingCandidates_set input strategy tape q x i before, + CausalStateCausality.challenge_ood] + rw [get_set_ne q (.ood i j) tape x (by intro h; rw [h] at later; omega)] + +/-- The query event is measurable immediately after the one query/lambda reply; +future proof validity or future challenges do not appear in its definition. -/ +theorem queryEvent_set_future (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Fin input.config.folds.size) (q : Coordinate input.config) (x : Sample q) + (later : levelStart (challenges input.config tape) (i.val + 1) ≤ position q) : + QueryEvent input strategy i (set q tape x) = QueryEvent input strategy i tape := by + have before : levelStart (challenges input.config tape) i.val + + input.config.folds[i.val]! ≤ position q := by + rw [CausalRefinement.levelStart_succ, CausalStateCausality.challenge_folds_size, + CausalStateCausality.challenge_oods_size] at later + omega + have state := CausalStateCausality.foldAt_set input strategy q tape x i + input.config.folds[i.val]! le_rfl before + change boundary input strategy (set q tape x) i = boundary input strategy tape i at state + have level := CausalStateCausality.levelAt_set input strategy q tape x i i.isLt.le (by omega) + have after := CausalStateCausality.levelAt_set input strategy q tape x (i.val + 1) + (by omega) later + simp only [QueryEvent, state, level, after, + CausalStateCausality.challenge_level_set input.config q tape x i later, + CausalStateCausality.proof_level_set input strategy q tape x i later, + followingCandidates_set input strategy tape q x i before] + by_cases hn : i.val + 1 < input.config.folds.size + · simp only [hn, ↓reduceIte] + · rw [ite_eq_right hn, ite_eq_right hn, residual_set input strategy tape q x i hn before] + +end Whir.CausalBoundary diff --git a/verification/whir/Whir/CausalExecution.lean b/verification/whir/Whir/CausalExecution.lean new file mode 100644 index 000000000..c1d2d2dfd --- /dev/null +++ b/verification/whir/Whir/CausalExecution.lean @@ -0,0 +1,224 @@ +import Whir.CausalTerminal +import Whir.OracleReplay +import Whir.BatchingRefinement + +/-! Total projections of the actual operational kernels make each finite +challenge-prefix event explicit. Successful checked execution is proved to +coincide with these projections; totalization never changes acceptance. -/ +namespace Whir.CausalExecution +open Concrete Protocol CausalGame OperationalRefinement + +abbrev proof := CausalTerminal.proof + +def initial (input : Public) (strategy : Strategy) (tape : Tape input.config) : CheckedState := + let batched := batchClaims (2 ^ input.config.logN) input.claims tape.1 + ⟨input.config.logN, ⟨batched.weight, batched.value, (proof input strategy tape).initial⟩, + liftRoot input.root⟩ + +def block (c : Config) (i : Nat) : Nat := + if i == 0 then 2 ^ (c.logN - c.folds[0]!) else 1 + +/-- Only the actual verifier's fold and batching kernels are evaluated. -/ +def next (c : Config) (ch : Challenges) (p : Opening) (i : Nat) (s : CheckedState) : CheckedState := + let cs := ch.levels[i]! + let level := p.levels[i]! + let folded := Protocol.foldBlock (block c i) cs level s + let qs := (deriveQueries (folded.n + c.rates[i]!) c.queries[i]! cs.querySqueezes).getD #[] + ⟨folded.n, queryBatch folded.n i cs level qs (oodBatch cs level folded.state), + level.nextOracle.getD #[]⟩ + +def levelAt (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Nat) : CheckedState := + runSteps (next input.config (challenges input.config tape) (proof input strategy tape)) + i 0 (initial input strategy tape) + +def foldAt (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i j : Nat) : CheckedState := + let ch := challenges input.config tape + let p := proof input strategy tape + runSteps (foldStep (block input.config i) ch.levels[i]! p.levels[i]!) + j 0 (levelAt input strategy tape i) + +noncomputable def foldCandidates (input : Public) (strategy : Strategy) + (tape : Tape input.config) (i j : Nat) : Finset (Array E) := + CandidateFolding.arrayCandidates (i == 0) + (CandidateFolding.concreteEncoder (remaining input.config i) input.config.rates[i]!) + (OracleReplay.oracleAt (i == 0) input.config.folds[i]! + (levelAt input strategy tape i).oracle (challenges input.config tape).levels[i]!.folds j) + (ParameterBounds.threshold input.config i) + +/-- The next candidate set uses the boundary commitment, before OOD/query +challenges. The last level instead has the transmitted singleton residual. -/ +noncomputable def followingCandidates (input : Public) (strategy : Strategy) + (tape : Tape input.config) (i : Nat) : Finset (Array E) := + if i + 1 < input.config.folds.size then + CandidateFolding.arrayCandidates false + (CandidateFolding.concreteEncoder (remaining input.config (i + 1)) + input.config.rates[i + 1]!) + (OracleReplay.oracleAt false input.config.folds[i + 1]! + ((proof input strategy tape).levels[i]!.nextOracle.getD #[]) + (challenges input.config tape).levels[i + 1]!.folds 0) + (ParameterBounds.threshold input.config (i + 1)) + else {(proof input strategy tape).residual} + +@[simp] theorem levelAt_zero (input : Public) (strategy : Strategy) (tape : Tape input.config) : + levelAt input strategy tape 0 = initial input strategy tape := rfl + +@[simp] theorem foldAt_zero (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Nat) : foldAt input strategy tape i 0 = levelAt input strategy tape i := rfl + +theorem levelAt_succ (input : Public) (strategy : Strategy) (tape : Tape input.config) (i : Nat) : + levelAt input strategy tape (i + 1) = + next input.config (challenges input.config tape) (proof input strategy tape) i + (levelAt input strategy tape i) := + BatchingRefinement.runSteps_succ_last _ i _ + +theorem foldAt_succ (input : Public) (strategy : Strategy) (tape : Tape input.config) (i j : Nat) : + foldAt input strategy tape i (j + 1) = + foldStep (block input.config i) (challenges input.config tape).levels[i]! + (proof input strategy tape).levels[i]! j (foldAt input strategy tape i j) := + BatchingRefinement.runSteps_succ_last _ j _ + +/-- Every accepted actual level has exactly the total kernel result. -/ +theorem next_of_success (c : Config) (ch : Challenges) (p : Opening) + (i : Nat) (s finish : CheckedState) (h : verifyLevel c ch p i s = .ok finish) : + next c ch p i s = finish := by + obtain ⟨_, _, qs, sampled, _, _, result⟩ := verifyLevel_success c ch p i s finish h + unfold next block + dsimp only + rw [sampled] + exact result.symm + +private theorem except_pure {S : Type*} (s : S) : + (pure s : Except String S) = .ok s := rfl +private theorem except_bind_ok {S T : Type u} (s : S) (f : S → Except String T) : + (Except.ok s >>= f) = f s := rfl +private theorem except_bind_error {S T : Type u} (e : String) (f : S → Except String T) : + (Except.error e >>= f) = .error e := rfl +private theorem except_throw {S : Type*} (e : String) : + (throw e : Except String S) = .error e := rfl +attribute [local simp] except_pure except_bind_ok except_bind_error except_throw + +/-- Actual initialization both validates the public shape and fixes the state. -/ +theorem initialize_success (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (weight : Array E) (target : E) (p : Opening) (s : CheckedState) + (h : initializeVerifier c ch lanes root weight target p = .ok s) : + shapeValid c lanes weight = true ∧ + oracleValid root (2 ^ (c.logN - c.folds[0]! + c.rates[0]!)) lanes = true ∧ + s = ⟨c.logN, ⟨weight, target, p.initial⟩, root⟩ := by + unfold initializeVerifier at h + simp only [except_throw, except_pure, except_bind_error] at h + split_ifs at h + simp_all + +/-- Checked recursion agrees with total recursion along every successful path. -/ +theorem runSteps_of_success {S : Type*} (checked : Nat → S → Except String S) + (total : Nat → S → S) (agrees : ∀ i s t, checked i s = .ok t → total i s = t) + (count start : Nat) (s finish : S) + (h : runChecked checked count start s = .ok finish) : + runSteps total count start s = finish := by + induction count generalizing start s with + | zero => simpa [runChecked, runSteps] using h + | succ count ih => + cases step : checked start s with + | error e => simp [runChecked, step] at h + | ok after => + have rest : runChecked checked count (start + 1) after = .ok finish := by + simpa [runChecked, step] using h + simpa only [runSteps, agrees start s after step] using ih (start + 1) after rest + +/-- Every accepted execution visits exactly the exposed total level states. -/ +theorem accepted_execution (input : Public) (strategy : Strategy) (tape : Tape input.config) + (accepted : experiment input strategy tape = true) : + initializeVerifier input.config (challenges input.config tape) input.lanes + (liftRoot input.root) (batchClaims (2 ^ input.config.logN) input.claims tape.1).weight + (batchClaims (2 ^ input.config.logN) input.claims tape.1).value + (proof input strategy tape) = .ok (initial input strategy tape) ∧ + replayLevels input.config (challenges input.config tape) (proof input strategy tape) + (initial input strategy tape) = .ok (levelAt input strategy tape input.config.folds.size) ∧ + (levelAt input strategy tape input.config.folds.size).state = + CausalTerminal.before input strategy tape := by + obtain ⟨_, p, first, finish, parsed, initialized, trace, _⟩ := + (CausalRefinement.experiment_iff input strategy tape).mp accepted + have hp : p = proof input strategy tape := + CausalRefinement.opening_eq_decoded _ _ _ _ parsed + subst p + have hfirst : first = initial input strategy tape := + (initialize_success _ _ _ _ _ _ _ _ initialized).2.2 + subst first + have replay : replayLevels input.config (challenges input.config tape) (proof input strategy tape) + (initial input strategy tape) = .ok finish := + (runChecked_ok_iff_trace _ _ _ _ _).mpr trace + have hfinish : levelAt input strategy tape input.config.folds.size = finish := + runSteps_of_success _ _ (next_of_success input.config (challenges input.config tape) + (proof input strategy tape)) _ _ _ _ replay + refine ⟨initialized, ?_, ?_⟩ + · simpa only [hfinish] using replay + · simp only [CausalTerminal.before, CausalTerminal.beforeChecked, initialized, + except_bind_ok, replay, Except.toOption, Option.getD, hfinish] + +/-- Successful checked execution exposes every prefix transition, not only its final state. -/ +theorem runChecked_prefix {S : Type*} (checked : Nat → S → Except String S) + (total : Nat → S → S) (agrees : ∀ i s t, checked i s = .ok t → total i s = t) + (count start : Nat) (s finish : S) + (success : runChecked checked count start s = .ok finish) + (i : Nat) (hi : i < count) : + checked (start + i) (runSteps total i start s) = + .ok (runSteps total (i + 1) start s) := by + induction count generalizing start s i with + | zero => omega + | succ count ih => + cases step : checked start s with + | error e => simp [runChecked, step] at success + | ok after => + have rest : runChecked checked count (start + 1) after = .ok finish := by + simpa [runChecked, step] using success + have totalStep := agrees start s after step + cases i with + | zero => simpa [runSteps, totalStep] using step + | succ i => + simpa only [runSteps, totalStep, Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using + ih (start + 1) after rest i (by omega) + +theorem accepted_level (input : Public) (strategy : Strategy) (tape : Tape input.config) + (accepted : experiment input strategy tape = true) (i : Nat) + (hi : i < input.config.folds.size) : + verifyLevel input.config (challenges input.config tape) (proof input strategy tape) i + (levelAt input strategy tape i) = .ok (levelAt input strategy tape (i + 1)) := by + have replay := (accepted_execution input strategy tape accepted).2.1 + simpa only [Nat.zero_add, levelAt] using runChecked_prefix _ _ + (next_of_success input.config (challenges input.config tape) (proof input strategy tape)) + input.config.folds.size 0 (initial input strategy tape) + (levelAt input strategy tape input.config.folds.size) replay i hi + +/-- The boundary commitment's list is exactly the next level's incoming list. -/ +theorem following_eq_next (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Nat) (hasNext : i + 1 < input.config.folds.size) : + followingCandidates input strategy tape i = foldCandidates input strategy tape (i + 1) 0 := by + have base : ((i + 1) == 0) = false := by simp + simp only [followingCandidates, hasNext, ↓reduceIte, foldCandidates, base, levelAt_succ, next] + +/-- The actual level verifier validates its boundary commitment or residual before deriving queries. -/ +theorem boundary_shape (c : Config) (ch : Challenges) (p : Opening) (i : Nat) + (s finish : CheckedState) (success : verifyLevel c ch p i s = .ok finish) : + let folded := Protocol.foldBlock (block c i) ch.levels[i]! p.levels[i]! s + if i + 1 < c.folds.size then + p.levels[i]!.nextOracle.isSome = true ∧ + oracleValid (p.levels[i]!.nextOracle.getD #[]) + (2 ^ (folded.n - c.folds[i + 1]! + c.rates[i + 1]!)) + (2 ^ c.folds[i + 1]!) = true + else p.levels[i]!.nextOracle = none ∧ p.residual.size = 2 ^ folded.n := by + dsimp only + unfold verifyLevel at success + simp only [except_throw, except_bind_error, except_pure] at success + generalize hf : Protocol.foldBlock (block c i) ch.levels[i]! p.levels[i]! s = folded at ⊢ + have hf' : Protocol.foldBlock (if i == 0 then 2 ^ (c.logN - c.folds[0]!) else 1) + ch.levels[i]! p.levels[i]! s = folded := hf + rw [hf'] at success + cases hn : p.levels[i]!.nextOracle <;> + cases hq : deriveQueries (folded.n + c.rates[i]!) c.queries[i]! ch.levels[i]!.querySqueezes + all_goals + simp only [hn, hq, Option.elim, except_pure, except_bind_ok, except_bind_error] at success + split_ifs at success <;> simp_all + +end Whir.CausalExecution diff --git a/verification/whir/Whir/CausalFolds.lean b/verification/whir/Whir/CausalFolds.lean new file mode 100644 index 000000000..2fe166de0 --- /dev/null +++ b/verification/whir/Whir/CausalFolds.lean @@ -0,0 +1,159 @@ +import Whir.CausalStateCausality +import Whir.ProductionTransitions + +/-! Actual prefix restoration events for production fold coordinates. -/ +namespace Whir.CausalFolds +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStateCausality +open VerifierInvariant ParameterBounds GroupedChallenges + +set_option maxRecDepth 100000 +set_option maxHeartbeats 0 + +/-- A local invariant restoration, guarded by the incoming physical shape. +No future acceptance test occurs in this event. -/ +def Event (input : Public) (strategy : Strategy) (i : Fin input.config.folds.size) + (j : Fin input.config.folds[i.val]!) (t : Tape input.config) : Prop := + (foldAt input strategy t i j).state.weight.size = + 2 ^ (input.config.folds[i.val]! - j.val) * dimension input.config i ∧ + Lost (foldCandidates input strategy t i j) (foldAt input strategy t i j).state ∧ + ¬ Lost (foldCandidates input strategy t i (j.val+1)) + (foldAt input strategy t i (j.val+1)).state + +/-- Physical pair indexing agrees with the actual current lane width. -/ +theorem pair_width (k j : Nat) (h : j < k) : + 2 ^ (k-j) = 2 ^ (k-(j+1)) * 2 := by + rw [show k-j = (k-(j+1))+1 by omega, pow_succ] + +theorem block_eq (c : Config) (i : Fin c.folds.size) : + block c i = CandidateFolding.foldBlock (i.val == 0) (dimension c i) := by + unfold block CandidateFolding.foldBlock dimension remaining + by_cases hi : i.val = 0 + · simp only [hi, beq_self_eq_true, ↓reduceIte] + have hz : 0 < c.folds.size := by omega + rw [List.take_one] + simp [List.head?_eq_getElem?, _root_.getElem!_pos, hz] + · simp [hi] + +theorem foldError_nonneg (p : Profile) (i : Fin (config p).folds.size) : + 0 ≤ foldError (config p) (estimates (config p)) i := by + change (0 : ℚ) ≤ (2 * 2^32 + 2^108) / 2^192 + positivity + +/-- Prefix measurability: replacing any coordinate after this indivisible +fold-and-reply leaves the event unchanged, without conditioning on acceptance. -/ +theorem event_set (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (before : levelStart (challenges input.config t) i.val + (j.val+1) ≤ position q) : + Event input strategy i j (set q t x) ↔ Event input strategy i j t := by + unfold Event + rw [foldAt_set input strategy q t x i j.val (by omega) (by omega), + foldAt_set input strategy q t x i (j.val+1) (by omega) before, + foldCandidates_set input strategy q t x i j.val (by omega) (by omega), + foldCandidates_set input strategy q t x i (j.val+1) (by omega) before] + +theorem pairedOracle_set (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (before : levelStart (challenges input.config t) i.val + j.val ≤ position q) {N : Nat} : + OracleReplay.pairedOracle (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy (set q t x) i.val).oracle + (challenges input.config (set q t x)).levels[i.val]!.folds j.val j.isLt (N := N) = + OracleReplay.pairedOracle (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy t i.val).oracle + (challenges input.config t).levels[i.val]!.folds j.val j.isLt := by + unfold OracleReplay.pairedOracle + rw [oracleAt_set input strategy q t x i j.val (by omega) before] + +open Classical in +/-- Every exact coordinate fiber is bounded. The decoded pending message remains +an arbitrary function of the fresh scalar; only its incoming state is fixed. -/ +theorem fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) + (t : Tape (config p)) : + let input : Public := ⟨config p, lanes, root, claims⟩ + Soundness.uniformProb (Finset.univ.filter fun r : E => + Event input strategy i j (set (.fold i j) t r)) ≤ + foldError (config p) (estimates (config p)) i := by + classical + let input : Public := ⟨config p, lanes, root, claims⟩ + let old := (foldAt input strategy t i j).state + let oracle := OracleReplay.pairedOracle (i.val == 0) (config p).folds[i.val]! + (levelAt input strategy t i).oracle (challenges (config p) t).levels[i.val]!.folds j.val j.isLt + (N := 2 ^ (remaining (config p) i + (config p).rates[i.val]!)) + let pending := fun r => (proof input strategy (set (.fold i j) t r)).levels[i.val]!.afterFold[j.val]! + have position : levelStart (challenges input.config t) i.val + j.val = + CausalProbability.position (.fold i j) := (CausalPositions.position_fold i j t).symm + have hs (r : E) : foldAt input strategy (set (.fold i j) t r) i j = + foldAt input strategy t i j := + foldAt_set input strategy (.fold i j) t r i j.val j.isLt.le position.le + have hc (r : E) : foldCandidates input strategy (set (.fold i j) t r) i j = + foldCandidates input strategy t i j := + foldCandidates_set input strategy (.fold i j) t r i j.val j.isLt.le position.le + have paired : + CandidateFolding.arrayCandidates (i.val == 0) + (CandidateFolding.concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) + oracle (threshold (config p) i) = foldCandidates input strategy t i j := + OracleReplay.paired_candidates _ _ _ _ _ _ _ _ _ + have ha (r : E) : (foldAt input strategy (set (.fold i j) t r) i (j.val+1)).state = + old.fold (CandidateFolding.foldBlock (i.val == 0) (dimension (config p) i)) r (pending r) := by + rw [foldAt_succ, hs] + simp only [foldStep, challenge_fold input.config _ i j, get_set, block_eq] + rfl + have hl (r : E) : foldCandidates input strategy (set (.fold i j) t r) i (j.val+1) = + CandidateFolding.arrayCandidates (i.val == 0) + (CandidateFolding.concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) + (CandidateFolding.foldOracle oracle r) (threshold (config p) i) := by + unfold foldCandidates + rw [OracleReplay.oracleAt_succ _ _ _ _ j.val j.isLt, + pairedOracle_set input strategy i j (.fold i j) t r position.le, + challenge_fold input.config _ i j, get_set] + change Soundness.uniformProb (Finset.univ.filter fun r : E => + Event input strategy i j (set (.fold i j) t r)) ≤ _ + by_cases guard : old.weight.size = + 2 ^ ((config p).folds[i.val]! - j.val) * dimension (config p) i ∧ + Lost (foldCandidates input strategy t i j) old + · have shape : old.weight.size = + (2 ^ ((config p).folds[i.val]! - (j.val+1)) * 2) * dimension (config p) i := by + rw [← pair_width _ _ j.isLt] + exact guard.1 + have bound := ProductionTransitions.production_fold_escape (i.val == 0) p i + oracle old pending shape (by rw [paired]; exact guard.2) + have events : (Finset.univ.filter fun r : E => + Event input strategy i j (set (.fold i j) t r)) = + (Finset.univ.filter fun r : E => + ¬ Lost (CandidateFolding.arrayCandidates (i.val == 0) + (CandidateFolding.concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) + (CandidateFolding.foldOracle oracle r) (threshold (config p) i)) + (old.fold (CandidateFolding.foldBlock (i.val == 0) (dimension (config p) i)) r (pending r))) := by + apply Finset.filter_congr + intro r _ + unfold Event + rw [hs, hc, hl, ha] + change (old.weight.size = _ ∧ Lost (foldCandidates input strategy t i j) old ∧ _) ↔ _ + simp only [input, guard.1, guard.2, true_and] + rw [events] + exact bound + · have empty : (Finset.univ.filter fun r : E => + Event input strategy i j (set (.fold i j) t r)) = ∅ := by + apply Finset.filter_eq_empty_iff.mpr + intro r _ he + unfold Event at he + rw [hs, hc] at he + exact guard ⟨he.1, he.2.1⟩ + rw [empty] + simpa [Soundness.uniformProb] using foldError_nonneg p i + +open Classical in +/-- Exact product averaging over the actual tape; events need not be independent. -/ +theorem event_bound (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) : + Soundness.uniformProb (Finset.univ.filter + (Event (⟨config p, lanes, root, claims⟩ : Public) strategy i j)) ≤ + foldError (config p) (estimates (config p)) i := by + classical + apply fiber_event_bound (.fold i j) + intro rest + exact fiber_bound p lanes root claims strategy i j rest.val + +end Whir.CausalFolds diff --git a/verification/whir/Whir/CausalGame.lean b/verification/whir/Whir/CausalGame.lean new file mode 100644 index 000000000..8c0eade34 --- /dev/null +++ b/verification/whir/Whir/CausalGame.lean @@ -0,0 +1,239 @@ +import Whir.Protocol +import Whir.Soundness +import Whir.FieldCardinality + +/-! Causal adversaries for the actual dense verifier. The honest `prove` function +may accept a complete challenge tape; an adversary in this game never receives it. +Query squeezes and their adjacent batching scalar form one verifier message. -/ +namespace Whir.CausalGame +open Concrete Protocol + +structure Claim where + weight : Array E + value : E + deriving Repr, Inhabited + +abbrev BaseOracle := Array (Array K) + +/-- The commitment message contains exactly the occupied base-field lanes. -/ +abbrev Witness (c : Config) (lanes : Nat) := + Fin (lanes * 2 ^ (c.logN - c.folds[0]!)) → K + +def paddedWitness (c : Config) (lanes : Nat) (witness : Witness c lanes) : Array E := + let words := Array.ofFn witness + tab (2 ^ c.logN) fun i => E.ofK (words[i]?.getD 0) + +def liftRoot (root : BaseOracle) : Oracle := root.map fun row => row.map E.ofK + +structure Public where + config : Config + lanes : Nat + root : BaseOracle + claims : Array Claim + deriving Repr, Inhabited + +/-- Each constructor is one verifier message, not one coordinate of that message. -/ +inductive Batch where + | initial (lambda : E) + | fold (level round : Nat) (r : E) + | ood (level index : Nat) (point : Array E) + | query (level : Nat) (squeezes : Array E) (lambda : E) + | tail (round : Nat) (r : E) + deriving Repr, Inhabited + +/-- Boundary data is sent with the last fold response, before OOD/query randomness. +Only the appropriate boundary field is parsed at a level boundary. -/ +inductive Reply where + | initial (message : Message E) + | fold (message : Message E) (next : Option Oracle) (residual : Array E) + | ood (claim : OodClaim) + | query (rows : Oracle) (intro : Message E) + | tail (message : Message E) + deriving Repr, Inhabited + +/-- Reverse chronological history, allowing constant-time extension. -/ +abbrev History := List (Batch × Reply) +abbrev Strategy := Public → History → Batch → Reply + +/-- The only interface through which an adversary selects a response. -/ +def run (strategy : Strategy) (input : Public) (past : History) : List Batch → List Reply + | [] => [] + | batch :: rest => + let answer := strategy input past batch + answer :: run strategy input ((batch, answer) :: past) rest + +/-- Executed response prefixes use only the corresponding challenge prefix. -/ +theorem run_take (strategy : Strategy) (input : Public) (n : Nat) + (past : History) (batches : List Batch) : + (run strategy input past batches).take n = run strategy input past (batches.take n) := by + induction n generalizing past batches with + | zero => simp [run] + | succ n ih => + cases batches with + | nil => simp [run] + | cons batch rest => simp [run, ih] + +/-- No suffix, including an unrevealed final challenge, can change earlier replies. -/ +theorem prefix_independent (strategy : Strategy) (input : Public) (n : Nat) + (past : History) (left right : List Batch) (same : left.take n = right.take n) : + (run strategy input past left).take n = (run strategy input past right).take n := by + rw [run_take, run_take, same] + +/-- Raw independent field elements required by one production-shaped level. -/ +def remaining (c : Config) (i : Nat) : Nat := c.logN - (c.folds.toList.take (i + 1)).sum + +def oodCount (c : Config) (i : Nat) : Nat := + if i + 1 < c.folds.size then c.oodCounts[i + 1]! else 0 + +def queryChunks (c : Config) (i : Nat) : Nat := + let per := 192 / (remaining c i + c.rates[i]!) + (c.queries[i]! + per - 1) / per + +abbrev LevelTape (c : Config) (i : Fin c.folds.size) := + (Fin c.folds[i.val]! → E) × + (Fin (oodCount c i.val) → Fin (remaining c i.val) → E) × + (Fin (queryChunks c i.val) → E) × E + +abbrev Tape (c : Config) := + E × (∀ i : Fin c.folds.size, LevelTape c i) × + (Fin (c.logN - c.folds.toList.sum) → E) + +/-- Sampling has no prover-dependent rejection or postselection. -/ +def challenges (c : Config) (tape : Tape c) : Challenges := + ⟨Array.ofFn (fun i : Fin c.folds.size => + let t := tape.2.1 i + ⟨Array.ofFn t.1, Array.ofFn (fun j => Array.ofFn (t.2.1 j)), + Array.ofFn t.2.2.1, t.2.2.2⟩), Array.ofFn tape.2.2⟩ + +/-- Batching all externally supplied claims happens after commitment, before intro. -/ +def batchClaims (width : Nat) (claims : Array Claim) (lambda : E) : Claim := Id.run do + let mut out : Claim := ⟨tab width fun _ => E.zero, E.zero⟩ + let mut power := E.one + for claim in claims do + out := ⟨weightGlue out.weight claim.weight power, out.value + power * claim.value⟩ + power := power * lambda + return out + +/-- One level's wire order. Queries and lambda are one indivisible message. -/ +def levelBatches (ch : Challenges) (i : Nat) : List Batch := + let cs := ch.levels[i]! + (List.ofFn fun j : Fin cs.folds.size => Batch.fold i j cs.folds[j]) ++ + (List.ofFn fun j : Fin cs.oodPoints.size => Batch.ood i j cs.oodPoints[j]) ++ + [Batch.query i cs.querySqueezes cs.lambda] + +/-- Position immediately before a level's first fold response. -/ +def levelStart (ch : Challenges) (i : Nat) : Nat := + 1 + ((List.range i).flatMap (levelBatches ch)).length + +def tailStart (c : Config) (ch : Challenges) : Nat := levelStart ch c.folds.size + +/-- The final tail challenge has no following prover message. -/ +def visibleBatches (c : Config) (initial : E) (ch : Challenges) : List Batch := + [.initial initial] ++ (List.range c.folds.size).flatMap (levelBatches ch) ++ + (List.ofFn fun j : Fin (ch.tail.size - 1) => Batch.tail j ch.tail[j.val]!) + +/-- Check precisely the wire tags, in wire order, with the original parser errors. -/ +def checkReplies : List Batch → List Reply → Except String Unit + | [], [] => .ok () + | [], _ :: _ => .error "trailing response" + | .initial _ :: bs, .initial _ :: rs => checkReplies bs rs + | .fold _ _ _ :: bs, .fold _ _ _ :: rs => checkReplies bs rs + | .ood _ _ _ :: bs, .ood _ :: rs => checkReplies bs rs + | .query _ _ _ :: bs, .query _ _ :: rs => checkReplies bs rs + | .tail _ _ :: bs, .tail _ :: rs => checkReplies bs rs + | .initial _ :: _, _ => .error "initial response" + | .fold _ _ _ :: _, _ => .error "fold response" + | .ood _ _ _ :: _, _ => .error "OOD response" + | .query _ _ _ :: _, _ => .error "query response" + | .tail _ _ :: _, _ => .error "tail response" + +def initialField : Reply → Message E + | .initial m => m + | _ => default + +def foldField : Reply → Message E + | .fold m _ _ => m + | _ => default + +def rootField : Reply → Option Oracle + | .fold _ next _ => next + | _ => none + +def residualField : Reply → Array E + | .fold _ _ residual => residual + | _ => #[] + +def oodField : Reply → OodClaim + | .ood claim => claim + | _ => default + +def rowsField : Reply → Oracle + | .query rows _ => rows + | _ => #[] + +def introField : Reply → Message E + | .query _ intro => intro + | _ => default + +def tailField : Reply → Message E + | .tail m => m + | _ => default + +/-- Total projections are used only after all wire tags have been checked. Each +field reads one response position; no field reads later responses. -/ +def decodedLevel (c : Config) (ch : Challenges) (answers : Array Reply) (i : Nat) : + LevelProof := + let cs := ch.levels[i]! + let start := levelStart ch i + let query := start + cs.folds.size + cs.oodPoints.size + ⟨Array.ofFn (fun j : Fin cs.folds.size => foldField answers[start + j.val]!), + if i + 1 < c.folds.size ∧ 0 < cs.folds.size then + rootField answers[start + cs.folds.size - 1]! else none, + Array.ofFn (fun j : Fin cs.oodPoints.size => + oodField answers[start + cs.folds.size + j.val]!), + rowsField answers[query]!, introField answers[query]!⟩ + +def decodedOpening (c : Config) (ch : Challenges) (answers : Array Reply) : Opening := + let last := c.folds.size - 1 + let count := ch.levels[last]!.folds.size + ⟨initialField answers[0]!, + Array.ofFn (fun i : Fin c.folds.size => decodedLevel c ch answers i.val), + if 0 < c.folds.size ∧ 0 < count then + residualField answers[levelStart ch last + count - 1]! else #[], + Array.ofFn (fun j : Fin (ch.tail.size - 1) => + tailField answers[tailStart c ch + j.val]!)⟩ + +/-- Decode arbitrary replies; malformed tags and extra/missing replies reject. +The challenge values are not used by the tag check or field projections. -/ +def opening (c : Config) (ch : Challenges) (answers : Array Reply) : Except String Opening := do + checkReplies (visibleBatches c E.zero ch) answers.toList + return decodedOpening c ch answers + +/-- The accepting experiment invokes the actual length/authentication/algebra +verifier, after deriving an opening through only causal response calls. -/ +def experiment (input : Public) (strategy : Strategy) (tape : Tape input.config) : Bool := + let c := input.config + let ch := challenges c tape + if !(input.claims.all fun claim => shapeValid c input.lanes claim.weight) then false + else + let statement := batchClaims (2 ^ c.logN) input.claims tape.1 + let answers := run strategy input [] (visibleBatches c tape.1 ch) + match opening c ch answers.toArray with + | .error _ => false + | .ok proof => (verify c ch input.lanes (liftRoot input.root) statement.weight statement.value proof).isOk + +/-- All claims in this opening must be explained by one commitment-fixed candidate. +The existential candidate list precedes both the claims and the adaptive strategy. -/ +noncomputable def AdaptiveListBinding (c : Config) + (listBound : Nat) (error : Nat → ℚ) : Prop := by + classical + exact ∀ (lanes : Nat) (root : BaseOracle), ∃ candidates : Finset (Witness c lanes), + candidates.card ≤ listBound ∧ + ∀ (claims : Array Claim) (strategy : Strategy), + Soundness.uniformProb (Finset.univ.filter fun tape : Tape c => + experiment ⟨c, lanes, root, claims⟩ strategy tape = true ∧ + ¬ ∃ witness ∈ candidates, + ∀ claim ∈ claims.toList, + dot (paddedWitness c lanes witness) claim.weight = claim.value) ≤ error claims.size + +end Whir.CausalGame diff --git a/verification/whir/Whir/CausalInitial.lean b/verification/whir/Whir/CausalInitial.lean new file mode 100644 index 000000000..2a78b547c --- /dev/null +++ b/verification/whir/Whir/CausalInitial.lean @@ -0,0 +1,53 @@ +import Whir.InitialSoundness +import Whir.CausalProbability +import Whir.CausalExecution + +/-! Initial batching draws its fresh scalar after the commitment-fixed base-field +list and all public claims. Later messages do not enter this event. -/ +namespace Whir.CausalInitial +open Concrete Protocol CausalGame CausalProbability ParameterBounds GroupedChallenges + +/-- The bad set is fixed by the commitment and public claims, before the initial scalar. -/ +def Event (input : Public) (tape : Tape input.config) : Prop := + tape.1 ∈ InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates input.config input.lanes input.root) input.claims + +open Classical in +theorem event_bound (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (lane_bound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) : + Soundness.uniformProb (Finset.univ.filter (Event ⟨config p, lanes, root, claims⟩)) ≤ + initialBatch (config p) (estimates (config p)) claims.size := by + classical + apply fiber_event_bound Coordinate.initial + intro rest + have coordinate (x : E) : (set Coordinate.initial rest.val x).1 = x := + get_set Coordinate.initial rest.val x + have event : (Finset.univ.filter fun x : E => + Event ⟨config p, lanes, root, claims⟩ (set Coordinate.initial rest.val x)) = + InitialBatching.candidateEscape (InitialCandidates.extensionCandidates (config p) lanes root) claims := by + have same : (Finset.univ.filter fun x : E => + Event ⟨config p, lanes, root, claims⟩ (set Coordinate.initial rest.val x)) = + (Finset.univ.filter fun x : E => x ∈ InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) lanes root) claims) := by + apply Finset.filter_congr + intro x _ + simp only [Event, coordinate] + rw [same, Finset.filter_mem_eq_inter, Finset.univ_inter] + rw [event] + have bounded := InitialSoundness.initial_escape_probability p lanes root lane_bound claims shape + have envelope : ((claims.size - 1 : Nat) : ℚ) / 2 ^ 160 = + initialBatch (config p) (estimates (config p)) claims.size := by + unfold initialBatch + rw [dite_eq_left (production_config_valid p).2.1] + simp only [estimates, fieldSize, Nat.cast_pow, Nat.cast_ofNat] + ring + exact bounded.trans_eq envelope + +/-- Any replacement of a later coordinate preserves the initial event exactly. -/ +theorem event_set (input : Public) (tape : Tape input.config) (q : Coordinate input.config) + (x : Sample q) (later : q ≠ .initial) : Event input (set q tape x) ↔ Event input tape := by + have same : (set q tape x).1 = tape.1 := get_set_ne q .initial tape x (Ne.symm later) + simp only [Event, same] + +end Whir.CausalInitial diff --git a/verification/whir/Whir/CausalPositions.lean b/verification/whir/Whir/CausalPositions.lean new file mode 100644 index 000000000..6e400c057 --- /dev/null +++ b/verification/whir/Whir/CausalPositions.lean @@ -0,0 +1,122 @@ +import Whir.CausalProbability + +namespace Whir.CausalPositions +open Concrete Protocol CausalGame CausalProbability +open Classical + +private theorem idxOf_ofFn {A : Type*} [DecidableEq A] {n : Nat} + (f : Fin n → A) (hf : Function.Injective f) (j : Fin n) : + (List.ofFn f).idxOf (f j) = j.val := by + have hm : f j ∈ List.ofFn f := List.mem_ofFn.mpr ⟨j, rfl⟩ + have hi := List.idxOf_lt_length_of_mem hm + have he := List.getElem_idxOf hi + simp only [List.getElem_ofFn] at he + exact congrArg Fin.val (hf he) + +def levelOf {c : Config} : Coordinate c → Option Nat + | .fold i _ => some i.val + | .ood i _ => some i.val + | .query i => some i.val + | _ => none + +private theorem levelOf_mem {c : Config} (k : Nat) (q : Coordinate c) + (h : q ∈ levelCoordinates c k) : levelOf q = some k := by + unfold levelCoordinates at h + split_ifs at h with hk + · simp only [List.mem_append, List.mem_ofFn, List.mem_singleton] at h + rcases h with (⟨j, rfl⟩ | ⟨j, rfl⟩) | rfl <;> rfl + · simp at h + + theorem levelStart_eq (c : Config) (t u : Tape c) (i : Nat) : + levelStart (challenges c t) i = levelStart (challenges c u) i := by + simp only [levelStart, List.length_flatMap] + congr 1 + congr 1 + apply List.map_congr_left + intro k hk + simp only [CausalRefinement.levelBatches_length] + by_cases h : k < c.folds.size + · simp [challenges, _root_.getElem!_pos, h] + · simp [challenges, getElem!_neg, h] + + theorem levelStart_set {c : Config} (q : Coordinate c) (t : Tape c) + (x : Sample q) (i : Nat) : + levelStart (challenges c (set q t x)) i = levelStart (challenges c t) i := + levelStart_eq c _ _ i + +private theorem position_level {c : Config} (i : Fin c.folds.size) + (q : Coordinate c) (hq : q ∈ levelCoordinates c i.val) (t : Tape c) : + position q = levelStart (challenges c t) i.val + (levelCoordinates c i.val).idxOf q := by + have hr : List.range c.folds.size = List.range i.val ++ [i.val] ++ + (List.range (c.folds.size-(i.val+1))).map (fun x => i.val+1+x) := by + calc + List.range c.folds.size = + List.range ((i.val+1)+(c.folds.size-(i.val+1))) := congrArg List.range (by omega) + _ = _ := by rw [List.range_add, List.range_succ] + have hl := levelOf_mem i.val q hq + have hinit : q ∉ [Coordinate.initial] := by + intro h + have : q = .initial := by simpa using h + simp [this, levelOf] at hl + have hprior : q ∉ (List.range i.val).flatMap (levelCoordinates c) := by + intro h + obtain ⟨k, hk, hqk⟩ := List.mem_flatMap.mp h + have he := levelOf_mem k q hqk + have : i.val = k := Option.some.inj (hl.symm.trans he) + have := List.mem_range.mp hk + omega + unfold position visibleCoordinates + rw [hr] + simp only [List.flatMap_append, List.flatMap_singleton, List.append_assoc] + rw [List.idxOf_append_of_notMem hinit, List.idxOf_append_of_notMem hprior, + List.idxOf_append_of_mem hq] + have lengths : ((List.range i.val).flatMap (levelCoordinates c)).length = + ((List.range i.val).flatMap (levelBatches (challenges c t))).length := by + rw [← List.length_map (f := fun q => batch q (get q t))] + simp only [List.map_flatMap] + congr 1 + apply List.flatMap_congr + intro k hk + exact levelCoordinates_map c t k (lt_trans (List.mem_range.mp hk) i.isLt) + simp only [List.length_singleton, lengths, levelStart] + omega + +@[simp] theorem position_initial (c : Config) : position (.initial : Coordinate c) = 0 := by + simp [position, visibleCoordinates] + + theorem position_fold {c : Config} (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) + (t : Tape c) : position (.fold i j) = levelStart (challenges c t) i.val + j.val := by + have hm : Coordinate.fold i j ∈ levelCoordinates c i.val := by + unfold levelCoordinates + rw [dite_eq_left i.isLt] + exact List.mem_append_left _ (List.mem_append_left _ (List.mem_ofFn.mpr ⟨j, rfl⟩)) + rw [position_level i _ hm t] + congr 1 + simp only [levelCoordinates, i.isLt, dite_true, List.append_assoc] + rw [List.idxOf_append_of_mem (List.mem_ofFn.mpr ⟨j, rfl⟩)] + exact idxOf_ofFn _ (by intro a b h; cases h; rfl) j + + theorem position_ood {c : Config} (i : Fin c.folds.size) (j : Fin (oodCount c i.val)) + (t : Tape c) : position (.ood i j) = + levelStart (challenges c t) i.val + c.folds[i.val]! + j.val := by + have hm : Coordinate.ood i j ∈ levelCoordinates c i.val := by + simp [levelCoordinates, i.isLt] + rw [position_level i _ hm t] + simp only [levelCoordinates, i.isLt, dite_true, List.append_assoc] + rw [List.idxOf_append_of_notMem (by simp), + List.idxOf_append_of_mem (List.mem_ofFn.mpr ⟨j, rfl⟩), + idxOf_ofFn _ (by intro a b h; cases h; rfl)] + simp only [List.length_ofFn] + omega + + theorem position_query {c : Config} (i : Fin c.folds.size) (t : Tape c) : + position (.query i) = + levelStart (challenges c t) i.val + c.folds[i.val]! + oodCount c i.val := by + have hm : Coordinate.query i ∈ levelCoordinates c i.val := by + simp [levelCoordinates, i.isLt] + rw [position_level i _ hm t] + simp only [levelCoordinates, i.isLt, dite_true, List.append_assoc] + rw [List.idxOf_append_of_notMem (by simp), List.idxOf_append_of_notMem (by simp)] + simp [Nat.add_assoc] + +end Whir.CausalPositions diff --git a/verification/whir/Whir/CausalPrefix.lean b/verification/whir/Whir/CausalPrefix.lean new file mode 100644 index 000000000..98fa51373 --- /dev/null +++ b/verification/whir/Whir/CausalPrefix.lean @@ -0,0 +1,250 @@ +import Whir.CausalBadEvents + +/-! Prefix extensionality for every actual indivisible WHIR challenge, including +its final scalar that has no subsequent prover response. -/ +namespace Whir.CausalPrefix +open Concrete Protocol CausalGame CausalProbability CausalPositions +open Classical + +private def pre (c : Config) : List (Coordinate c) := + [.initial] ++ (List.range c.folds.size).flatMap (levelCoordinates c) + +private theorem level_mem_pre {c : Config} (i : Fin c.folds.size) (q : Coordinate c) + (h : q ∈ levelCoordinates c i.val) : q ∈ pre c := by + apply List.mem_append_right + exact List.mem_flatMap.mpr ⟨i.val, List.mem_range.mpr i.isLt, h⟩ + +private theorem tail_not_pre {c : Config} (j : Fin (c.logN - c.folds.toList.sum)) : + Coordinate.tail j ∉ pre c := by + simp only [pre, List.mem_append, List.mem_singleton, List.mem_flatMap] + rintro (impossible | ⟨i, _, member⟩) + · cases impossible + · unfold levelCoordinates at member + split_ifs at member <;> simp at member + +private theorem pre_length (c : Config) (t : Tape c) : + (pre c).length = tailStart c (challenges c t) := by + have size : (challenges c t).tail.size = c.logN - c.folds.toList.sum := by simp [challenges] + have lengths := congrArg List.length (visibleCoordinates_map c t) + simp only [List.length_map, visibleCoordinates, visibleBatches, List.length_append, + List.length_cons, List.length_nil, List.length_ofFn, size] at lengths + simp only [pre, List.length_append, List.length_cons, List.length_nil, tailStart, levelStart] + omega + +private def tailIndex {c : Config} : Coordinate c → Nat + | .tail j => j.val + | _ => 0 + +/-- The invisible last tail challenge occupies the unique next position after the visible stream. -/ +theorem position_tail {c : Config} (j : Fin (c.logN - c.folds.toList.sum)) (t : Tape c) : + position (.tail j) = tailStart c (challenges c t) + j.val := by + unfold position visibleCoordinates + change (pre c ++ List.ofFn (fun k : Fin (c.logN - c.folds.toList.sum - 1) => + Coordinate.tail ⟨k.val, by omega⟩)).idxOf (Coordinate.tail j) = _ + rw [List.idxOf_append_of_notMem (tail_not_pre j), pre_length c t] + congr 1 + let f : Fin (c.logN - c.folds.toList.sum - 1) → Coordinate c := + fun k => .tail ⟨k.val, by omega⟩ + change (List.ofFn f).idxOf (.tail j) = j.val + by_cases h : j.val < c.logN - c.folds.toList.sum - 1 + · have member : Coordinate.tail j ∈ List.ofFn f := List.mem_ofFn.mpr ⟨⟨j.val, h⟩, rfl⟩ + have atIndex := List.getElem_idxOf (List.idxOf_lt_length_of_mem member) + simp only [List.getElem_ofFn] at atIndex + simpa only [f, tailIndex] using congrArg tailIndex atIndex + · rw [List.idxOf_of_notMem ?_, List.length_ofFn] + · omega + · simp only [List.mem_ofFn, not_exists] + intro k equal + have same := congrArg tailIndex equal + simp only [f, tailIndex] at same + have bound := k.isLt + omega + +private theorem fold_mem_level {c : Config} (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) : + Coordinate.fold i j ∈ levelCoordinates c i.val := by + unfold levelCoordinates + rw [dite_eq_left i.isLt] + exact List.mem_append_left _ (List.mem_append_left _ (List.mem_ofFn.mpr ⟨j, rfl⟩)) + +theorem visible_or_last {c : Config} (q : Coordinate c) : + q ∈ visibleCoordinates c ∨ ∃ j : Fin (c.logN - c.folds.toList.sum), + q = .tail j ∧ j.val + 1 = c.logN - c.folds.toList.sum := by + cases q with + | initial => exact Or.inl (by simp [visibleCoordinates]) + | fold i j => + left + apply List.mem_append_left + exact level_mem_pre i _ (fold_mem_level i j) + | ood i j => + left + apply List.mem_append_left + exact level_mem_pre i _ (by simp [levelCoordinates, i.isLt]) + | query i => + left + apply List.mem_append_left + exact level_mem_pre i _ (by simp [levelCoordinates, i.isLt]) + | tail j => + by_cases h : j.val < c.logN - c.folds.toList.sum - 1 + · left + exact List.mem_append_right _ (List.mem_ofFn.mpr ⟨⟨j.val, h⟩, rfl⟩) + · exact Or.inr ⟨j, rfl, by omega⟩ + +/-- Distinct dependent challenge alphabets never occupy the same protocol position. -/ +theorem position_injective (c : Config) : Function.Injective (@position c) := by + intro q r same + by_cases hq : q ∈ visibleCoordinates c + · exact (List.idxOf_inj hq).mp same + by_cases hr : r ∈ visibleCoordinates c + · exact ((List.idxOf_inj hr).mp same.symm).symm + obtain ⟨j, rfl, hj⟩ := (visible_or_last q).resolve_left hq + obtain ⟨k, rfl, hk⟩ := (visible_or_last r).resolve_left hr + congr 1 + apply Fin.ext + omega + +private theorem pre_position {c : Config} (q : Coordinate c) (t : Tape c) (h : q ∈ pre c) : + position q < tailStart c (challenges c t) := by + unfold position visibleCoordinates + change (pre c ++ List.ofFn (fun k : Fin (c.logN - c.folds.toList.sum - 1) => + Coordinate.tail ⟨k.val, by omega⟩)).idxOf q < _ + rw [List.idxOf_append_of_mem h, ← pre_length c t] + exact List.idxOf_lt_length_of_mem h + +private theorem before_tail_or_tail {c : Config} (q : Coordinate c) (t : Tape c) : + position q < tailStart c (challenges c t) ∨ + ∃ j : Fin (c.logN - c.folds.toList.sum), q = .tail j := by + cases q with + | initial => exact Or.inl (pre_position _ t (by simp [pre])) + | fold i j => exact Or.inl (pre_position _ t (level_mem_pre i _ (fold_mem_level i j))) + | ood i j => exact Or.inl (pre_position _ t (level_mem_pre i _ (by simp [levelCoordinates, i.isLt]))) + | query i => exact Or.inl (pre_position _ t (level_mem_pre i _ (by simp [levelCoordinates, i.isLt]))) + | tail j => exact Or.inr ⟨j, rfl⟩ + +private theorem tail_kernels_set_future (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) (t : Tape input.config) + (j k : Fin (input.config.logN - input.config.folds.toList.sum)) (x : E) + (later : j.val < k.val) : + CausalTerminal.candidate input strategy (set (.tail k) t x) j = + CausalTerminal.candidate input strategy t j ∧ + CausalTerminal.pending input strategy (set (.tail k) t x) j = + CausalTerminal.pending input strategy t j := by + apply CausalTerminal.kernels_congr input strategy valid _ t j + · simp only [set_tail] + · exact (tail_challenges_prefix k t x).1 + · intro m hm + have hmn : m < input.config.logN - input.config.folds.toList.sum := by omega + have hne : (⟨m, hmn⟩ : Fin (input.config.logN - input.config.folds.toList.sum)) ≠ k := + Fin.ne_of_val_ne (by change m ≠ k.val; omega) + simp only [set_tail, challenges] + rw [getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hmn), + getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hmn)] + simp only [Array.getElem_ofFn, Function.update_of_ne hne] + · have starts : tailStart input.config (challenges input.config (set (.tail k) t x)) = + tailStart input.config (challenges input.config t) := + levelStart_set (.tail k) t x input.config.folds.size + rw [starts] + have shortened := congrArg (List.take (tailStart input.config (challenges input.config t) + j.val)) + (tail_visible_prefix k t x) + simpa only [List.take_take, Nat.min_eq_left (by omega : + tailStart input.config (challenges input.config t) + j.val ≤ + tailStart input.config (challenges input.config t) + k.val)] using shortened + +/-- A later random coordinate cannot change an already determined bad-prefix event. -/ +theorem event_set_future (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) (q r : Coordinate input.config) + (t : Tape input.config) (x : Sample r) (later : position q < position r) : + CausalBadEvents.Bad input strategy q (set r t x) ↔ CausalBadEvents.Bad input strategy q t := by + cases q with + | initial => + exact CausalInitial.event_set input t r x (by + intro equal + subst r + omega) + | fold i j => + apply CausalFolds.event_set input strategy i j r t x + rw [position_fold i j t] at later + omega + | ood i j => + change CausalBoundary.OodEvent input strategy i j (set r t x) ↔ + CausalBoundary.OodEvent input strategy i j t + rw [CausalBoundary.oodEvent_set_future input strategy t i j r x later] + | query i => + change CausalBoundary.QueryEvent input strategy i (set r t x) ↔ + CausalBoundary.QueryEvent input strategy i t + apply Iff.of_eq + apply CausalBoundary.queryEvent_set_future input strategy t i r x + have shapes := TapeValidity.level_shapes input.config t i i.isLt + rw [CausalRefinement.levelStart_succ, shapes.1, shapes.2.1] + rw [position_query i t] at later + omega + | tail j => + obtain earlier | ⟨k, rfl⟩ := before_tail_or_tail r t + · rw [position_tail j t] at later + omega + · have jk : j.val < k.val := by + simpa only [position_tail j t, position_tail k t, Nat.add_lt_add_iff_left] using later + have kernels := tail_kernels_set_future input strategy valid t j k x jk + have draw : (set (.tail k) t x).2.2 j = t.2.2 j := + get_set_ne (.tail k) (.tail j) t x (by + intro equal + have same := congrArg tailIndex equal + simp only [tailIndex] at same + omega) + simp only [CausalBadEvents.Bad, kernels.1, kernels.2, draw] + +private theorem finite_pred_congr {I : Type*} [Fintype I] [DecidableEq I] {A : I → Type*} + (P : ((i : I) → A i) → Prop) (locked : I → Prop) + (step : ∀ f i, ¬ locked i → ∀ x, P (Function.update f i x) ↔ P f) + (f g : (i : I) → A i) (same : ∀ i, locked i → f i = g i) : P f ↔ P g := by + have repair (s : Finset I) : ∀ f g : (i : I) → A i, + (∀ i, i ∉ s → f i = g i) → + (∀ i, locked i → f i = g i) → (P f ↔ P g) := by + induction s using Finset.induction_on with + | empty => + intro f g outside _ + have equal : f = g := funext fun i => outside i (by simp) + rw [equal] + | @insert i s absent ih => + intro f g outside fixed + by_cases equal : f i = g i + · apply ih f g ?_ fixed + intro j hj + by_cases ji : j = i + · subst j; exact equal + · exact outside j (by simp [hj, ji]) + · have unlocked : ¬ locked i := fun h => equal (fixed i h) + let mid := Function.update f i (g i) + have outside' : ∀ j, j ∉ s → mid j = g j := by + intro j hj + by_cases ji : j = i + · subst j; simp [mid] + · simpa only [mid, Function.update_of_ne ji] using outside j (by simp [hj, ji]) + have fixed' : ∀ j, locked j → mid j = g j := by + intro j hj + have ji : j ≠ i := by intro equal; subst j; exact unlocked hj + simpa only [mid, Function.update_of_ne ji] using fixed j hj + exact (step f i unlocked (g i)).symm.trans (ih mid g outside' fixed') + exact repair Finset.univ f g (by intro i impossible; simp at impossible) same + +/-- The actual bad event depends only on challenge coordinates through its current position. +No future tape or hidden oracle table is supplied to a prefix adversary. -/ +theorem bad_congr (input : Public) (strategy : Strategy) (valid : input.config.valid = true) + (q : Coordinate input.config) (t u : Tape input.config) + (same : ∀ r, position r ≤ position q → get r t = get r u) : + CausalBadEvents.Bad input strategy q t ↔ CausalBadEvents.Bad input strategy q u := by + let P := fun f : (r : Coordinate input.config) → Sample r => + CausalBadEvents.Bad input strategy q ((coordinates input.config).symm f) + have step : ∀ f r, ¬ position r ≤ position q → ∀ x, + P (Function.update f r x) ↔ P f := by + intro f r future x + have replaced : (coordinates input.config).symm (Function.update f r x) = + set r ((coordinates input.config).symm f) x := by + simp only [CausalProbability.set, Equiv.apply_symm_apply] + dsimp only [P] + rw [replaced] + exact event_set_future input strategy valid q r _ x (Nat.lt_of_not_ge future) + have result := finite_pred_congr P (fun r => position r ≤ position q) step + (coordinates input.config t) (coordinates input.config u) same + simpa only [P, Equiv.symm_apply_apply] using result + +end Whir.CausalPrefix diff --git a/verification/whir/Whir/CausalProbability.lean b/verification/whir/Whir/CausalProbability.lean new file mode 100644 index 000000000..96672f0a1 --- /dev/null +++ b/verification/whir/Whir/CausalProbability.lean @@ -0,0 +1,399 @@ +import Whir.CausalRefinement +import Mathlib.Data.Fintype.BigOperators + +/-! Exact finite-coordinate disintegration of the production tape. OOD points and +query squeezes together with lambda are indivisible samples. No validity test or +prover-dependent rejection occurs in this factorization. -/ +namespace Whir.CausalProbability +open Concrete Protocol CausalGame + +noncomputable local instance {c : Config} : DecidableEq (Tape c) := Classical.decEq _ + +inductive Coordinate (c : Config) where + | initial + | fold (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) + | ood (i : Fin c.folds.size) (j : Fin (oodCount c i.val)) + | query (i : Fin c.folds.size) + | tail (j : Fin (c.logN - c.folds.toList.sum)) + deriving DecidableEq, Fintype + +abbrev Sample {c : Config} : Coordinate c → Type + | .initial => E + | .fold _ _ => E + | .ood i _ => Fin (remaining c i.val) → E + | .query i => (Fin (queryChunks c i.val) → E) × E + | .tail _ => E + +instance {c : Config} (q : Coordinate c) : Fintype (Sample q) := by + cases q <;> unfold Sample <;> infer_instance + +instance {c : Config} (q : Coordinate c) : Zero (Sample q) := by + cases q <;> unfold Sample <;> infer_instance + +instance {c : Config} (q : Coordinate c) : Nonempty (Sample q) := ⟨0⟩ + +def get {c : Config} (q : Coordinate c) (t : Tape c) : Sample q := + match q with + | .initial => t.1 + | .fold i j => (t.2.1 i).1 j + | .ood i j => (t.2.1 i).2.1 j + | .query i => (t.2.1 i).2.2 + | .tail j => t.2.2 j + +/-- Regrouping only: the underlying tape values are not transformed. -/ +def coordinates (c : Config) : Tape c ≃ (∀ q : Coordinate c, Sample q) where + toFun t q := get q t + invFun f := ⟨f .initial, (fun i => ⟨(fun j => f (.fold i j)), + (fun j => f (.ood i j)), f (.query i)⟩), (fun j => f (.tail j))⟩ + left_inv t := rfl + right_inv f := by funext q; cases q <;> rfl + +def set {c : Config} (q : Coordinate c) (t : Tape c) (x : Sample q) : Tape c := + (coordinates c).symm (Function.update (coordinates c t) q x) + +@[simp] theorem get_set {c : Config} (q : Coordinate c) (t : Tape c) (x : Sample q) : + get q (set q t x) = x := by + classical + change (coordinates c (set q t x)) q = x + simp [set] + +@[simp] theorem get_set_ne {c : Config} (q r : Coordinate c) (t : Tape c) + (x : Sample q) (h : r ≠ q) : get r (set q t x) = get r t := by + classical + change (coordinates c (set q t x)) r = (coordinates c t) r + simp [set, h] + +@[simp] theorem set_get {c : Config} (q : Coordinate c) (t : Tape c) : + set q t (get q t) = t := by + classical + simp [set, get, coordinates, Function.update_eq_self] + +@[simp] theorem set_set {c : Config} (q : Coordinate c) (t : Tape c) + (x y : Sample q) : set q (set q t x) y = set q t y := by + classical + simp [set, Function.update_idem] + +abbrev Rest {c : Config} (q : Coordinate c) := {t : Tape c // get q t = 0} + +noncomputable instance {c : Config} (q : Coordinate c) : Fintype (Rest q) := by + classical + unfold Rest + infer_instance + +instance {c : Config} (q : Coordinate c) : Nonempty (Rest q) := + ⟨⟨set q (0, (fun _ => (0, 0, 0, 0)), 0) 0, get_set _ _ _⟩⟩ + +/-- Exact product decomposition, with inverse given by coordinate replacement. -/ +noncomputable def split {c : Config} (q : Coordinate c) : Tape c ≃ Rest q × Sample q where + toFun t := (⟨set q t 0, get_set _ _ _⟩, get q t) + invFun p := set q p.1.val p.2 + left_inv t := by simp + right_inv p := by + rcases p with ⟨⟨t, ht⟩, x⟩ + apply Prod.ext + · apply Subtype.ext + simp [← ht] + · simp + +private theorem card_equiv_fibers {A B C : Type*} [Fintype A] [Fintype B] [Fintype C] + (e : A ≃ B × C) (p : A → Prop) [DecidablePred p] : + (Finset.univ.filter p).card = + ∑ b : B, (Finset.univ.filter fun x : C => p (e.symm (b, x))).card := by + classical + have h := Fintype.sum_equiv e + (fun a => if p a then (1 : ℕ) else 0) + (fun bc => if p (e.symm bc) then (1 : ℕ) else 0) + (by intro a; simp) + rw [Fintype.sum_prod_type] at h + simpa only [Finset.sum_boole, Nat.cast_id] using h + +/-- Counting all fibers is an identity, including for history-dependent events. -/ +theorem card_event {c : Config} (q : Coordinate c) (event : Tape c → Prop) + [DecidablePred event] : + (Finset.univ.filter event).card = + ∑ rest : Rest q, (Finset.univ.filter fun x : Sample q => + event (set q rest.val x)).card := by + exact card_equiv_fibers (split q) event + +/-- Exact averaging of conditional uniform probabilities, with no independence +hypothesis on the events themselves. -/ +theorem uniformProb_event {c : Config} (q : Coordinate c) (event : Tape c → Prop) + [DecidablePred event] : + Soundness.uniformProb (Finset.univ.filter event) = + (∑ rest : Rest q, Soundness.uniformProb + (Finset.univ.filter fun x : Sample q => event (set q rest.val x))) / + Fintype.card (Rest q) := by + classical + have hc : Fintype.card (Tape c) = + Fintype.card (Rest q) * Fintype.card (Sample q) := + (Fintype.card_congr (split q)).trans (Fintype.card_prod _ _) + simp only [Soundness.uniformProb, card_event q event, Nat.cast_sum, hc, + Nat.cast_mul, ← Finset.sum_div] + rw [div_div, mul_comm] + +theorem fiber_event_bound {c : Config} (q : Coordinate c) (event : Tape c → Prop) + [DecidablePred event] (bound : ℚ) + (h : ∀ rest : Rest q, Soundness.uniformProb + (Finset.univ.filter fun x : Sample q => event (set q rest.val x)) ≤ bound) : + Soundness.uniformProb (Finset.univ.filter event) ≤ bound := by + classical + rw [uniformProb_event q event] + have hp : (0 : ℚ) < Fintype.card (Rest q) := by + exact_mod_cast Fintype.card_pos + apply (div_le_iff₀ hp).mpr + calc + _ ≤ ∑ _rest : Rest q, bound := Finset.sum_le_sum (fun rest _ => h rest) + _ = _ := by simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul, mul_comm] + +/-- Fixed coordinate families compose by the union bound, not event independence. -/ +theorem coordinate_union_bound {c : Config} {I : Type*} [Fintype I] + (q : I → Coordinate c) (event : I → Tape c → Prop) + [∀ i, DecidablePred (event i)] (bound : I → ℚ) + (h : ∀ i (rest : Rest (q i)), Soundness.uniformProb + (Finset.univ.filter fun x : Sample (q i) => event i (set (q i) rest.val x)) ≤ bound i) : + Soundness.uniformProb (Finset.univ.biUnion fun i => + Finset.univ.filter (event i)) ≤ ∑ i, bound i := by + classical + exact (Soundness.union_bound _).trans + (Finset.sum_le_sum fun i _ => fiber_event_bound (q i) (event i) (bound i) (h i)) + +@[simp] theorem set_tail {c : Config} (j : Fin (c.logN - c.folds.toList.sum)) + (t : Tape c) (x : E) : + set (.tail j) t x = (t.1, t.2.1, Function.update t.2.2 j x) := by + classical + apply (coordinates c).injective + funext q + change get q (set (.tail j) t x) = + get q (t.1, t.2.1, Function.update t.2.2 j x) + cases q with + | initial => rw [get_set_ne _ _ _ _ (by intro h; cases h)]; rfl + | fold i k => rw [get_set_ne _ _ _ _ (by intro h; cases h)]; rfl + | ood i k => rw [get_set_ne _ _ _ _ (by intro h; cases h)]; rfl + | query i => rw [get_set_ne _ _ _ _ (by intro h; cases h)]; rfl + | tail k => + by_cases h : k = j + · subst k; rw [get_set]; simp [get] + · rw [get_set_ne _ _ _ _ (by simpa using h)] + simp [get, h] + +/-- Replacing a tail scalar leaves all levels and earlier tail entries unchanged. -/ +theorem tail_challenges_prefix {c : Config} (j : Fin (c.logN - c.folds.toList.sum)) + (t : Tape c) (x : E) : + (challenges c (set (.tail j) t x)).levels = (challenges c t).levels ∧ + (challenges c (set (.tail j) t x)).tail.toList.take j.val = + (challenges c t).tail.toList.take j.val := by + classical + constructor + · simp [challenges] + · simp only [set_tail, challenges, Array.toList_ofFn] + apply List.ext_getElem + · simp + · intro k hk hk' + simp only [List.getElem_take, List.getElem_ofFn] + apply Function.update_of_ne + have : k < j.val := lt_of_lt_of_le hk (List.length_take_le _ _) + exact Fin.ne_of_val_ne (by simpa only [Fin.val_mk] using Nat.ne_of_lt this) + +/-- Actual strategy input before a tail draw is invariant under replacing it. -/ +theorem tail_visible_prefix {c : Config} (j : Fin (c.logN - c.folds.toList.sum)) + (t : Tape c) (x : E) : + (visibleBatches c (set (.tail j) t x).1 (challenges c (set (.tail j) t x))).take + (tailStart c (challenges c t) + j.val) = + (visibleBatches c t.1 (challenges c t)).take + (tailStart c (challenges c t) + j.val) := by + classical + rw [set_tail] + let pre := [Batch.initial t.1] ++ + (List.range c.folds.size).flatMap (levelBatches (challenges c t)) + have hl : pre.length = tailStart c (challenges c t) := by + simp only [pre, List.length_append, List.length_singleton, tailStart, levelStart] + unfold visibleBatches + simp only [challenges, Array.size_ofFn] + change (pre ++ (List.ofFn fun k : Fin (c.logN - c.folds.toList.sum - 1) => + Batch.tail k (Array.ofFn (Function.update t.2.2 j x))[k.val]!)).take _ = + (pre ++ (List.ofFn fun k : Fin (c.logN - c.folds.toList.sum - 1) => + Batch.tail k (Array.ofFn t.2.2)[k.val]!)).take _ + simp only [challenges] at hl + rw [← hl] + simp only [List.take_append, Nat.add_sub_cancel_left] + congr 1 + apply List.ext_getElem + · simp only [List.length_take, List.length_ofFn] + · intro k hk hk' + simp only [List.getElem_take, List.getElem_ofFn] + congr 1 + have hkj : k < j.val := lt_of_lt_of_le hk (List.length_take_le _ _) + have hkn : k < c.logN - c.folds.toList.sum := lt_trans hkj j.isLt + have hne : (⟨k, hkn⟩ : Fin (c.logN - c.folds.toList.sum)) ≠ j := + Fin.ne_of_val_ne (by simpa using Nat.ne_of_lt hkj) + rw [_root_.getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hkn), + _root_.getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hkn)] + simp only [Array.getElem_ofFn, Function.update_of_ne hne] + +theorem final_tail_visible {c : Config} (j : Fin (c.logN - c.folds.toList.sum)) + (last : j.val + 1 = c.logN - c.folds.toList.sum) (t : Tape c) (x : E) : + visibleBatches c (set (.tail j) t x).1 (challenges c (set (.tail j) t x)) = + visibleBatches c t.1 (challenges c t) := by + classical + rw [set_tail] + apply CausalRefinement.visible_tail_congr + · rfl + · simp [challenges] + · intro k hk + simp only [challenges, Array.size_ofFn] at hk + have hkn : k < c.logN - c.folds.toList.sum := by omega + have hne : (⟨k, hkn⟩ : Fin (c.logN - c.folds.toList.sum)) ≠ j := + Fin.ne_of_val_ne (by change k ≠ j.val; omega) + simp only [challenges] + rw [_root_.getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hkn), + _root_.getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hkn)] + simp only [Array.getElem_ofFn, Function.update_of_ne hne] + +/-- Coordinate order is fixed by the configuration, never by prover messages. -/ +def levelCoordinates (c : Config) (i : Nat) : List (Coordinate c) := + if hi : i < c.folds.size then + (List.ofFn fun j => Coordinate.fold ⟨i, hi⟩ j) ++ + (List.ofFn fun j => Coordinate.ood ⟨i, hi⟩ j) ++ [.query ⟨i, hi⟩] + else [] + +def visibleCoordinates (c : Config) : List (Coordinate c) := + [.initial] ++ (List.range c.folds.size).flatMap (levelCoordinates c) ++ + (List.ofFn fun j : Fin (c.logN - c.folds.toList.sum - 1) => + Coordinate.tail ⟨j.val, by omega⟩) + +def batch {c : Config} (q : Coordinate c) (x : Sample q) : Batch := + match q with + | .initial => .initial x + | .fold i j => .fold i.val j.val x + | .ood i j => .ood i.val j.val (Array.ofFn x) + | .query i => .query i.val (Array.ofFn x.1) x.2 + | .tail j => .tail j.val x + +theorem levelCoordinates_map (c : Config) (t : Tape c) (i : Nat) + (hi : i < c.folds.size) : + (levelCoordinates c i).map (fun q => batch q (get q t)) = + levelBatches (challenges c t) i := by + simp [levelCoordinates, hi, List.map_ofFn, levelBatches, challenges, + _root_.getElem!_pos, batch, get, Function.comp_def] + congr 1 + +/-- This is the actual Array.ofFn challenge conversion and actual wire stream. -/ +theorem visibleCoordinates_map (c : Config) (t : Tape c) : + (visibleCoordinates c).map (fun q => batch q (get q t)) = + visibleBatches c t.1 (challenges c t) := by + simp only [visibleCoordinates, visibleBatches, List.map_append, List.map_cons, + List.map_nil, batch, get, List.map_flatMap] + congr 1 + · congr 1 + apply List.flatMap_congr + intro i hi + exact levelCoordinates_map c t i (List.mem_range.mp hi) + · simp only [challenges, Array.size_ofFn, List.map_ofFn] + apply List.ofFn_inj.mpr + funext j + dsimp + congr 1 + rw [_root_.getElem!_pos _ _ (by + simp only [Array.size_ofFn] + exact Nat.lt_of_lt_of_le j.isLt (Nat.sub_le _ _))] + simp only [Array.getElem_ofFn] + rfl + +/-- Zero-based position of the indivisible batch; the invisible final tail has +position equal to the length of the entire visible stream. -/ +def position {c : Config} (q : Coordinate c) : Nat := (visibleCoordinates c).idxOf q + +private theorem not_mem_take_idxOf {A : Type*} [DecidableEq A] (q : A) (xs : List A) : + q ∉ xs.take (xs.idxOf q) := by + induction xs with + | nil => simp + | cons a xs ih => + by_cases h : a = q + · subst a; simp + · simp [h, Ne.symm h, ih] + +/-- Replacing one real tape coordinate cannot alter the actual challenge prefix +before its batch, including arbitrary malformed strategy executions. -/ +theorem visible_prefix {c : Config} (q : Coordinate c) (t : Tape c) (x : Sample q) : + (visibleBatches c (set q t x).1 (challenges c (set q t x))).take (position q) = + (visibleBatches c t.1 (challenges c t)).take (position q) := by + rw [← visibleCoordinates_map, ← visibleCoordinates_map] + simp only [← List.map_take] + apply List.map_congr_left + intro r hr + rw [get_set_ne q r t x] + intro h + subst r + exact not_mem_take_idxOf q (visibleCoordinates c) hr + +/-- The causal strategy itself, not an assumed adaptedness predicate, supplies +identical earlier responses. No parser success or proof validity is required. -/ +theorem response_prefix {c : Config} (q : Coordinate c) (t : Tape c) (x : Sample q) + (strategy : Strategy) (input : Public) : + (run strategy input [] + (visibleBatches c (set q t x).1 (challenges c (set q t x)))).take (position q) = + (run strategy input [] (visibleBatches c t.1 (challenges c t))).take (position q) := + prefix_independent strategy input (position q) [] _ _ (visible_prefix q t x) + +/-- Read one indivisible coordinate through the verifier's actual arrays. -/ +def challengeBatch {c : Config} (q : Coordinate c) (t : Tape c) : Batch := + let ch := challenges c t + match q with + | .initial => .initial t.1 + | .fold i j => .fold i.val j.val ch.levels[i.val]!.folds[j.val]! + | .ood i j => .ood i.val j.val ch.levels[i.val]!.oodPoints[j.val]! + | .query i => .query i.val ch.levels[i.val]!.querySqueezes ch.levels[i.val]!.lambda + | .tail j => .tail j.val ch.tail[j.val]! + +theorem challengeBatch_eq {c : Config} (q : Coordinate c) (t : Tape c) : + challengeBatch q t = batch q (get q t) := by + cases q with + | initial => rfl + | fold i j => + simp [challengeBatch, challenges, _root_.getElem!_pos, i.isLt, batch, get] + rw [_root_.getElem!_pos _ _ (by simpa only [Array.size_ofFn] using j.isLt)] + exact Array.getElem_ofFn _ + | ood i j => + simp [challengeBatch, challenges, _root_.getElem!_pos, i.isLt, j.isLt, batch, get] + | query i => + simp [challengeBatch, challenges, _root_.getElem!_pos, i.isLt, batch, get] + | tail j => + simp only [challengeBatch, challenges, batch, get] + congr 1 + rw [_root_.getElem!_pos _ _ (by simpa only [Array.size_ofFn] using j.isLt)] + exact Array.getElem_ofFn _ + +theorem challengeBatch_set_ne {c : Config} (q r : Coordinate c) (t : Tape c) + (x : Sample q) (h : r ≠ q) : + challengeBatch r (set q t x) = challengeBatch r t := by + rw [challengeBatch_eq, challengeBatch_eq, get_set_ne q r t x h] + +theorem challenges_prefix {c : Config} (q : Coordinate c) (t : Tape c) (x : Sample q) : + ((visibleCoordinates c).take (position q)).map (fun r => challengeBatch r (set q t x)) = + ((visibleCoordinates c).take (position q)).map (fun r => challengeBatch r t) := by + apply List.map_congr_left + intro r hr + apply challengeBatch_set_ne + intro h + subst r + exact not_mem_take_idxOf q (visibleCoordinates c) hr + +theorem field_before {c : Config} {R : Type*} (q : Coordinate c) + (t : Tape c) (x : Sample q) (strategy : Strategy) (input : Public) + (field : Reply → R) (n : Nat) (hn : n < position q) : + field (run strategy input [] + (visibleBatches c (set q t x).1 (challenges c (set q t x))))[n]! = + field (run strategy input [] (visibleBatches c t.1 (challenges c t)))[n]! := by + apply CausalRefinement.field_prefix + have h := congrArg (List.take (n+1)) (visible_prefix q t x) + simpa only [List.take_take, Nat.min_eq_left (by omega : n+1 ≤ position q)] using h + +theorem final_tail_response {c : Config} (j : Fin (c.logN - c.folds.toList.sum)) + (last : j.val + 1 = c.logN - c.folds.toList.sum) (t : Tape c) (x : E) + (strategy : Strategy) (input : Public) : + run strategy input [] + (visibleBatches c (set (.tail j) t x).1 (challenges c (set (.tail j) t x))) = + run strategy input [] (visibleBatches c t.1 (challenges c t)) := by + rw [final_tail_visible j last t x] + +end Whir.CausalProbability diff --git a/verification/whir/Whir/CausalRefinement.lean b/verification/whir/Whir/CausalRefinement.lean new file mode 100644 index 000000000..384bd2c18 --- /dev/null +++ b/verification/whir/Whir/CausalRefinement.lean @@ -0,0 +1,374 @@ +import Whir.TapeValidity +import Whir.OperationalRefinement + +/-! Actual causal wire refinement, without an honest-prover relation. +`TapeValidity.challenges_valid` certifies every supplied tape without rejection. +`parsed_*` identifies every opening field with a truncated strategy execution; +`visible_*` identifies those truncations with the precise wire order, including +the indivisible queries-plus-lambda message and the invisible final tail coordinate. +`experiment_iff` exposes actual operational transitions and the concrete closing +check. Together these interfaces permit fresh-challenge counting on arbitrary +accepted messages, without exposing future tape coordinates to the strategy. -/ +namespace Whir.CausalRefinement +open Concrete Protocol CausalGame OperationalRefinement + +@[simp] theorem levelBatches_length (ch : Challenges) (i : Nat) : + (levelBatches ch i).length = + ch.levels[i]!.folds.size + ch.levels[i]!.oodPoints.size + 1 := by + simp [levelBatches, Nat.add_assoc] + +@[simp] theorem levelStart_zero (ch : Challenges) : levelStart ch 0 = 1 := by + simp [levelStart] + +@[simp] theorem levelStart_succ (ch : Challenges) (i : Nat) : + levelStart ch (i+1) = levelStart ch i + ch.levels[i]!.folds.size + + ch.levels[i]!.oodPoints.size + 1 := by + simp [levelStart, List.range_succ, Nat.add_assoc] + +/-- The reply at position n can be evaluated using only n+1 visible messages. -/ +def response (strategy : Strategy) (input : Public) (batches : List Batch) (n : Nat) : Reply := + (run strategy input [] (batches.take (n+1)))[n]! + +theorem response_eq (strategy : Strategy) (input : Public) (batches : List Batch) (n : Nat) : + response strategy input batches n = (run strategy input [] batches)[n]! := by + rw [response, ← run_take] + simp + +theorem response_prefix (strategy : Strategy) (input : Public) (left right : List Batch) + (n : Nat) (same : left.take (n+1) = right.take (n+1)) : + response strategy input left n = response strategy input right n := by + simp only [response, same] + +/-- Universal projection rule: no projection of an earlier response sees a suffix. -/ +theorem field_prefix {R : Type*} (field : Reply → R) (strategy : Strategy) + (input : Public) (left right : List Batch) (n : Nat) + (same : left.take (n+1) = right.take (n+1)) : + field (run strategy input [] left)[n]! = field (run strategy input [] right)[n]! := by + rw [← response_eq, ← response_eq, response_prefix strategy input left right n same] + +/-- Successful parsing fixes all fields to the explicit wire-position projections. -/ +theorem opening_eq_decoded (c : Config) (ch : Challenges) (answers : Array Reply) + (proof : Opening) (h : opening c ch answers = .ok proof) : + proof = decodedOpening c ch answers := by + unfold opening at h + cases hc : checkReplies (visibleBatches c E.zero ch) answers.toList <;> simp [hc] at h + exact h.symm + +/-- Successful parsing requires every tag check; malformed replies cannot be +converted to arbitrary default fields and accepted. -/ +theorem opening_ok_iff (c : Config) (ch : Challenges) (answers : Array Reply) + (proof : Opening) : opening c ch answers = .ok proof ↔ + checkReplies (visibleBatches c E.zero ch) answers.toList = .ok () ∧ + proof = decodedOpening c ch answers := by + unfold opening + cases hc : checkReplies (visibleBatches c E.zero ch) answers.toList <;> simp + exact eq_comm + +theorem checkReplies_length (batches : List Batch) (answers : List Reply) + (h : checkReplies batches answers = .ok ()) : answers.length = batches.length := by + induction batches generalizing answers with + | nil => cases answers <;> simp_all [checkReplies] + | cons batch batches ih => + cases batch <;> cases answers with + | nil => simp_all [checkReplies] + | cons answer answers => cases answer <;> simp_all [checkReplies] + +/-- Actual parser initial message, computed before the first fold challenge. -/ +theorem parsed_initial (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) : + proof.initial = initialField (response strategy input batches 0) := by + rw [opening_eq_decoded _ _ _ _ h, response_eq] + simp [decodedOpening] + +theorem parsed_level (c : Config) (ch : Challenges) (answers : Array Reply) + (proof : Opening) (h : opening c ch answers = .ok proof) (i : Fin c.folds.size) : + proof.levels[i.val]! = decodedLevel c ch answers i := by + rw [opening_eq_decoded _ _ _ _ h] + simp [decodedOpening] + +/-- The sent fold intro is fixed before the next fold challenge. -/ +theorem parsed_afterFold (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (i : Fin c.folds.size) (j : Fin ch.levels[i.val]!.folds.size) : + proof.levels[i.val]!.afterFold[j.val]! = + foldField (response strategy input batches (levelStart ch i + j)) := by + rw [parsed_level _ _ _ _ h i, response_eq] + simp [decodedLevel] + +/-- Commitment chosen with the final fold response, before the OOD or query batch. -/ +theorem parsed_nextOracle (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (i : Fin c.folds.size) (next : i.val+1 < c.folds.size) + (folds : 0 < ch.levels[i.val]!.folds.size) : + proof.levels[i.val]!.nextOracle = rootField (response strategy input batches + (levelStart ch i + ch.levels[i.val]!.folds.size - 1)) := by + rw [parsed_level _ _ _ _ h i, response_eq] + simp [decodedLevel, next, folds] + +/-- Both the OOD value and its intro precede the whole queries-plus-lambda message. -/ +theorem parsed_ood (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (i : Fin c.folds.size) (j : Fin ch.levels[i.val]!.oodPoints.size) : + proof.levels[i.val]!.oods[j.val]! = oodField (response strategy input batches + (levelStart ch i + ch.levels[i.val]!.folds.size + j)) := by + rw [parsed_level _ _ _ _ h i, response_eq] + simp [decodedLevel] + +/-- Rows and query intro may depend on the whole query batch, including lambda. -/ +theorem parsed_query (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (i : Fin c.folds.size) : + let answer := response strategy input batches + (levelStart ch i + ch.levels[i.val]!.folds.size + ch.levels[i.val]!.oodPoints.size) + proof.levels[i.val]!.rows = rowsField answer ∧ + proof.levels[i.val]!.intro = introField answer := by + rw [parsed_level _ _ _ _ h i, response_eq] + simp [decodedLevel] + +theorem parsed_residual (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (levels : 0 < c.folds.size) (folds : 0 < ch.levels[c.folds.size-1]!.folds.size) : + proof.residual = residualField (response strategy input batches + (levelStart ch (c.folds.size-1) + ch.levels[c.folds.size-1]!.folds.size - 1)) := by + rw [opening_eq_decoded _ _ _ _ h, response_eq] + simp [decodedOpening, levels, folds] + +theorem parsed_tail (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (j : Fin (ch.tail.size-1)) : + proof.tailMessages[j.val]! = tailField (response strategy input batches (tailStart c ch+j)) := by + rw [opening_eq_decoded _ _ _ _ h, response_eq] + simp [decodedOpening] + +/-- Acceptance exposes the actual verifier's successful transition trace, including +its concrete closing comparison. There is no executor-correctness premise. -/ +theorem experiment_iff (input : Public) (strategy : Strategy) (tape : Tape input.config) : + experiment input strategy tape = true ↔ + (input.claims.all fun claim => shapeValid input.config input.lanes claim.weight) = true ∧ + ∃ proof initial finish, + opening input.config (challenges input.config tape) + (run strategy input [] (visibleBatches input.config tape.1 + (challenges input.config tape))).toArray = .ok proof ∧ + initializeVerifier input.config (challenges input.config tape) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims tape.1).weight + (batchClaims (2^input.config.logN) input.claims tape.1).value proof = .ok initial ∧ + CheckedTrace (verifyLevel input.config (challenges input.config tape) proof) + input.config.folds.size 0 initial finish ∧ + (closeTail (challenges input.config tape) proof finish.state).checkTerminal + (Concrete.mle proof.residual (challenges input.config tape).tail) = true := by + unfold experiment + cases hc : input.claims.all (fun claim => shapeValid input.config input.lanes claim.weight) + · simp [hc] + · simp only [hc, Bool.not_true, Bool.false_eq_true, ↓reduceIte, true_and] + cases hp : opening input.config (challenges input.config tape) + (run strategy input [] (visibleBatches input.config tape.1 + (challenges input.config tape))).toArray with + | error e => simp + | ok proof => + have hv : (verify input.config (challenges input.config tape) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims tape.1).weight + (batchClaims (2^input.config.logN) input.claims tape.1).value proof).isOk = true ↔ + verify input.config (challenges input.config tape) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims tape.1).weight + (batchClaims (2^input.config.logN) input.claims tape.1).value proof = .ok () := by + cases verify input.config (challenges input.config tape) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims tape.1).weight + (batchClaims (2^input.config.logN) input.claims tape.1).value proof <;> simp [Except.isOk, Except.toBool] + rw [hv, verify_ok_iff] + constructor + · rintro ⟨s, t, hi, ht, hc⟩ + exact ⟨proof, s, t, rfl, hi, ht, hc⟩ + · rintro ⟨p, s, t, hp, hi, ht, hc⟩ + cases hp + exact ⟨s, t, hi, ht, hc⟩ + +/-- Locate an actual level in the wire stream, with an arbitrary later suffix. -/ +theorem visible_level_split (c : Config) (ch : Challenges) (initial : E) + (i : Nat) (hi : i < c.folds.size) : + ∃ suffix, visibleBatches c initial ch = + ([Batch.initial initial] ++ (List.range i).flatMap (levelBatches ch)) ++ + levelBatches ch i ++ suffix := by + have hr : List.range c.folds.size = + List.range i ++ [i] ++ + (List.range (c.folds.size-(i+1))).map (fun x => i+1+x) := by + calc + List.range c.folds.size = + List.range ((i+1)+(c.folds.size-(i+1))) := congrArg List.range (by omega) + _ = _ := by rw [List.range_add, List.range_succ] + simp only [visibleBatches, hr, List.flatMap_append, List.flatMap_singleton] + refine ⟨((List.range (c.folds.size-(i+1))).map (fun x => i+1+x)).flatMap + (levelBatches ch) ++ + (List.ofFn fun j : Fin (ch.tail.size-1) => Batch.tail j ch.tail[j.val]!), ?_⟩ + simp only [List.append_assoc] + +/-- Exact prefix used by a response inside a level. The later OOD, query/lambda, +levels and tail are not inputs to this response computation. -/ +theorem visible_level_prefix (c : Config) (ch : Challenges) (initial : E) + (i k : Nat) (hi : i < c.folds.size) (hk : k ≤ (levelBatches ch i).length) : + (visibleBatches c initial ch).take (levelStart ch i + k) = + ([Batch.initial initial] ++ (List.range i).flatMap (levelBatches ch)) ++ + (levelBatches ch i).take k := by + obtain ⟨suffix, hs⟩ := visible_level_split c ch initial i hi + rw [hs, List.append_assoc, List.take_append] + have hl : ([Batch.initial initial] ++ (List.range i).flatMap (levelBatches ch)).length = + levelStart ch i := by simp only [List.length_append, List.length_singleton, levelStart] + rw [hl, Nat.add_sub_cancel_left, List.take_append_of_le_length hk] + rw [List.take_of_length_le (by rw [hl]; omega)] + +/-- Initial response receives exactly the initial batching challenge. -/ +theorem visible_initial_prefix (c : Config) (ch : Challenges) (initial : E) : + (visibleBatches c initial ch).take 1 = [.initial initial] := by + simp [visibleBatches] + +/-- The root/residual prefix ends at the last fold and excludes every OOD/query. -/ +theorem visible_boundary_prefix (c : Config) (ch : Challenges) (initial : E) + (i : Nat) (hi : i < c.folds.size) : + (visibleBatches c initial ch).take (levelStart ch i + ch.levels[i]!.folds.size) = + ([Batch.initial initial] ++ (List.range i).flatMap (levelBatches ch)) ++ + (List.ofFn fun j : Fin ch.levels[i]!.folds.size => + Batch.fold i j ch.levels[i]!.folds[j]) := by + rw [visible_level_prefix c ch initial i _ hi (by simp; omega)] + simp [levelBatches] + +/-- The OOD prefix ends before the indivisible whole-query-plus-lambda batch. -/ +theorem visible_before_query (c : Config) (ch : Challenges) (initial : E) + (i : Nat) (hi : i < c.folds.size) : + (visibleBatches c initial ch).take + (levelStart ch i + (ch.levels[i]!.folds.size + ch.levels[i]!.oodPoints.size)) = + ([Batch.initial initial] ++ (List.range i).flatMap (levelBatches ch)) ++ + ((List.ofFn fun j : Fin ch.levels[i]!.folds.size => + Batch.fold i j ch.levels[i]!.folds[j]) ++ + (List.ofFn fun j : Fin ch.levels[i]!.oodPoints.size => + Batch.ood i j ch.levels[i]!.oodPoints[j])) := by + rw [visible_level_prefix c ch initial i _ hi (by simp)] + congr 1 + simpa only [levelBatches, List.length_append, List.length_ofFn] using + (List.take_append_length (l₁ := + (List.ofFn fun j : Fin ch.levels[i]!.folds.size => + Batch.fold i j ch.levels[i]!.folds[j]) ++ + (List.ofFn fun j : Fin ch.levels[i]!.oodPoints.size => + Batch.ood i j ch.levels[i]!.oodPoints[j])) + (l₂ := [Batch.query i ch.levels[i]!.querySqueezes ch.levels[i]!.lambda])) + +/-- All visible tail coordinates are strictly before the final coordinate. -/ +theorem visible_tail_congr (c : Config) (initial : E) (left right : Challenges) + (levels : left.levels = right.levels) (size : left.tail.size = right.tail.size) + (past : ∀ j, j+1 < left.tail.size → left.tail[j]! = right.tail[j]!) : + visibleBatches c initial left = visibleBatches c initial right := by + unfold visibleBatches + have hl : levelBatches left = levelBatches right := by + funext i + simp [levelBatches, levels] + rw [hl] + congr 1 + rw [← size] + apply List.ofFn_inj.mpr + funext j + congr 1 + exact past j (by omega) + +/-- Varying only the final tail challenge changes no adversarial response. -/ +theorem terminal_response_invisible (c : Config) (initial : E) (left right : Challenges) + (levels : left.levels = right.levels) (size : left.tail.size = right.tail.size) + (past : ∀ j, j+1 < left.tail.size → left.tail[j]! = right.tail[j]!) + (strategy : Strategy) (input : Public) : + run strategy input [] (visibleBatches c initial left) = + run strategy input [] (visibleBatches c initial right) := by + rw [visible_tail_congr c initial left right levels size past] + +/-- The actual fold kernel consumes the causal response projection just proved; +the adversary-supplied intro is not replaced with an honest polynomial. -/ +theorem foldStep_parsed (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (i : Fin c.folds.size) (j : Fin ch.levels[i.val]!.folds.size) + (block : Nat) (state : CheckedState) : + foldStep block ch.levels[i.val]! proof.levels[i.val]! j state = + ⟨state.n-1, state.state.fold block ch.levels[i.val]!.folds[j.val]! + (foldField (response strategy input batches (levelStart ch i+j))), state.oracle⟩ := by + unfold foldStep + rw [parsed_afterFold c ch strategy input batches proof h i j] + +/-- The actual OOD transition uses the earlier OOD response, while its shared +batching lambda is taken from the later query batch exactly as in the verifier. -/ +theorem oodStep_parsed (c : Config) (ch : Challenges) (strategy : Strategy) + (input : Public) (batches : List Batch) (proof : Opening) + (h : opening c ch (run strategy input [] batches).toArray = .ok proof) + (i : Fin c.folds.size) (j : Fin ch.levels[i.val]!.oodPoints.size) + (state : VerifierState E × E) : + let claim := oodField (response strategy input batches + (levelStart ch i+ch.levels[i.val]!.folds.size+j)) + oodStep ch.levels[i.val]! proof.levels[i.val]! j state = + (state.1.batch (eqTable ch.levels[i.val]!.oodPoints[j.val]!) + claim.value (state.2*ch.levels[i.val]!.lambda) claim.intro, + state.2*ch.levels[i.val]!.lambda) := by + dsimp only + unfold oodStep + rw [parsed_ood c ch strategy input batches proof h i j] + +/-- A final-coordinate change leaves the parsed opening itself unchanged, not +merely the transcript. The concrete closing check still consumes that coordinate. -/ +theorem parsed_terminal_invisible (c : Config) (initial : E) (left right : Challenges) + (levels : left.levels = right.levels) (size : left.tail.size = right.tail.size) + (past : ∀ j, j+1 < left.tail.size → left.tail[j]! = right.tail[j]!) + (strategy : Strategy) (input : Public) (p q : Opening) + (hp : opening c left (run strategy input [] (visibleBatches c initial left)).toArray = .ok p) + (hq : opening c right (run strategy input [] (visibleBatches c initial right)).toArray = .ok q) : + p = q := by + rw [opening_eq_decoded _ _ _ _ hp, opening_eq_decoded _ _ _ _ hq, + terminal_response_invisible c initial left right levels size past strategy input] + cases left with + | mk ls ts => + cases right with + | mk rs us => + dsimp only at levels size + subst rs + dsimp only [decodedOpening, decodedLevel, tailStart, levelStart, levelBatches] + congr 1 + apply Array.ext + · simp only [Array.size_ofFn, size] + · intro j h₁ h₂ + simp + +def batchKind : Batch → Nat + | .initial _ => 0 + | .fold _ _ _ => 1 + | .ood _ _ _ => 2 + | .query _ _ _ => 3 + | .tail _ _ => 4 + +def replyKind : Reply → Nat + | .initial _ => 0 + | .fold _ _ _ => 1 + | .ood _ => 2 + | .query _ _ => 3 + | .tail _ => 4 + +/-- Successful parsing entails exactly the scheduled tags, including their order. -/ +theorem checkReplies_tags (batches : List Batch) (answers : List Reply) + (h : checkReplies batches answers = .ok ()) : + batches.map batchKind = answers.map replyKind := by + induction batches generalizing answers with + | nil => cases answers <;> simp_all [checkReplies] + | cons batch batches ih => + cases batch <;> cases answers with + | nil => simp_all [checkReplies] + | cons answer answers => + cases answer <;> simp_all [checkReplies, batchKind, replyKind] + all_goals exact ih answers h + +/-- No malformed tag sequence can produce an accepted parser output. -/ +theorem malformed_reject (c : Config) (ch : Challenges) (answers : Array Reply) + (bad : (visibleBatches c E.zero ch).map batchKind ≠ answers.toList.map replyKind) + (proof : Opening) : opening c ch answers ≠ .ok proof := by + intro h + exact bad (checkReplies_tags _ _ ((opening_ok_iff c ch answers proof).mp h).1) + +end Whir.CausalRefinement diff --git a/verification/whir/Whir/CausalStateCausality.lean b/verification/whir/Whir/CausalStateCausality.lean new file mode 100644 index 000000000..e241cc1dc --- /dev/null +++ b/verification/whir/Whir/CausalStateCausality.lean @@ -0,0 +1,267 @@ +import Whir.CausalExecution +import Whir.CausalPositions + +/-! Prefix causality of total actual execution, including malformed replies. -/ +namespace Whir.CausalStateCausality +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalRefinement +open CausalPositions + +set_option maxRecDepth 100000 +set_option maxHeartbeats 0 + +@[simp] theorem challenge_folds_size (c : Config) (t : Tape c) (i : Fin c.folds.size) : + (challenges c t).levels[i.val]!.folds.size = c.folds[i.val]! := by + simp [challenges, _root_.getElem!_pos, i.isLt] + +@[simp] theorem challenge_oods_size (c : Config) (t : Tape c) (i : Fin c.folds.size) : + (challenges c t).levels[i.val]!.oodPoints.size = oodCount c i.val := by + simp [challenges, _root_.getElem!_pos, i.isLt] + +@[simp] theorem challenge_fold (c : Config) (t : Tape c) (i : Fin c.folds.size) + (j : Fin c.folds[i.val]!) : + (challenges c t).levels[i.val]!.folds[j.val]! = get (.fold i j) t := by + have h := challengeBatch_eq (.fold i j) t + exact Batch.fold.inj h |>.2.2 + +@[simp] theorem challenge_ood (c : Config) (t : Tape c) (i : Fin c.folds.size) + (j : Fin (oodCount c i.val)) : + (challenges c t).levels[i.val]!.oodPoints[j.val]! = Array.ofFn (get (.ood i j) t) := by + have h := challengeBatch_eq (.ood i j) t + exact Batch.ood.inj h |>.2.2 + +@[simp] theorem challenge_query (c : Config) (t : Tape c) (i : Fin c.folds.size) : + (challenges c t).levels[i.val]!.querySqueezes = Array.ofFn (get (.query i) t).1 ∧ + (challenges c t).levels[i.val]!.lambda = (get (.query i) t).2 := by + have h := challengeBatch_eq (.query i) t + exact Batch.query.inj h |>.2 + +/-- Total decoding is a field projection even when tags are malformed. -/ +theorem proof_level (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Fin input.config.folds.size) : + (proof input strategy t).levels[i.val]! = decodedLevel input.config + (challenges input.config t) + (run strategy input [] (visibleBatches input.config t.1 (challenges input.config t))).toArray i := by + simp [proof, CausalTerminal.proof, decodedOpening, _root_.getElem!_pos, i.isLt] + +theorem proof_fold (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) : + (proof input strategy t).levels[i.val]!.afterFold[j.val]! = + foldField (run strategy input [] + (visibleBatches input.config t.1 (challenges input.config t)))[levelStart + (challenges input.config t) i.val + j.val]! := by + rw [proof_level] + dsimp only [decodedLevel] + rw [_root_.getElem!_pos _ _ (by simpa using j.isLt)] + simp + +/-- Oracle replay consumes precisely the earlier fold scalars. -/ +theorem rowAt_congr (a : Array E) (left right : Array E) (j : Nat) + (h : ∀ k, k < j → left[k]! = right[k]!) : + OracleReplay.rowAt left a j = OracleReplay.rowAt right a j := by + unfold OracleReplay.rowAt + apply List.foldl_ext + intro b k hk + exact congrArg (Concrete.foldLow b) (h k (List.mem_range.mp hk)) + +theorem oracleAt_congr (base : Bool) (k : Nat) (root : Oracle) (left right : Array E) + (j : Nat) {N : Nat} (h : ∀ l, l < j → left[l]! = right[l]!) : + OracleReplay.oracleAt base k root left j (N := N) = + OracleReplay.oracleAt base k root right j := by + funext lane q + simp only [OracleReplay.oracleAt, rowAt_congr _ left right j h] + +theorem decodedLevel_prefix (c : Config) (left right : Challenges) + (i : Nat) (cs : left.levels[i]! = right.levels[i]!) + (start : levelStart left i = levelStart right i) + (strategy other : Strategy) (input : Public) (bs ds : List Batch) + (past : ∀ n, n < levelStart left (i+1) → + (run strategy input [] bs)[n]! = (run other input [] ds)[n]!) : + decodedLevel c left (run strategy input [] bs).toArray i = + decodedLevel c right (run other input [] ds).toArray i := by + have bound := levelStart_succ left i + have ans (n : Nat) (hn : n < levelStart left (i+1)) : + (run strategy input [] bs).toArray[n]! = + (run other input [] ds).toArray[n]! := by simpa using past n hn + unfold decodedLevel + dsimp only + rw [← cs, ← start] + congr 1 + · apply congrArg Array.ofFn + funext j + rw [ans _ (by omega)] + · split_ifs with h + · rw [ans _ (by omega)] + · rfl + · apply congrArg Array.ofFn + funext j + rw [ans _ (by omega)] + · rw [ans _ (by omega)] + · rw [ans _ (by omega)] + +theorem levelAt_congr (input : Public) (strategy other : Strategy) (t u : Tape input.config) + (i : Nat) (initial : CausalExecution.initial input strategy t = + CausalExecution.initial input other u) + (cs : ∀ k, k < i → (challenges input.config t).levels[k]! = + (challenges input.config u).levels[k]!) + (ps : ∀ k, k < i → (proof input strategy t).levels[k]! = + (proof input other u).levels[k]!) : + levelAt input strategy t i = levelAt input other u i := by + induction i with + | zero => exact initial + | succ i ih => + rw [levelAt_succ, levelAt_succ, ih (fun k hk => cs k (by omega)) + (fun k hk => ps k (by omega))] + simp only [next, cs i (by omega), ps i (by omega)] + +theorem foldAt_congr (input : Public) (strategy other : Strategy) (t u : Tape input.config) + (i j : Nat) (initial : levelAt input strategy t i = levelAt input other u i) + (cs : ∀ k, k < j → (challenges input.config t).levels[i]!.folds[k]! = + (challenges input.config u).levels[i]!.folds[k]!) + (ps : ∀ k, k < j → (proof input strategy t).levels[i]!.afterFold[k]! = + (proof input other u).levels[i]!.afterFold[k]!) : + foldAt input strategy t i j = foldAt input other u i j := by + induction j with + | zero => exact initial + | succ j ih => + rw [foldAt_succ, foldAt_succ, ih (fun k hk => cs k (by omega)) + (fun k hk => ps k (by omega))] + simp only [foldStep, cs j (by omega), ps j (by omega)] + +theorem levelStart_pos (ch : Challenges) (i : Nat) : 0 < levelStart ch i := by + unfold levelStart + omega + +theorem levelStart_mono (ch : Challenges) {i k : Nat} (h : i ≤ k) : + levelStart ch i ≤ levelStart ch k := by + induction h with + | refl => exact le_rfl + | @step k h ih => rw [levelStart_succ]; omega + +theorem initial_set (input : Public) (strategy : Strategy) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (before : 0 < position q) : + CausalExecution.initial input strategy (set q t x) = + CausalExecution.initial input strategy t := by + have hq : Coordinate.initial ≠ q := by + intro h + subst q + simp [position, visibleCoordinates] at before + have scalar : (set q t x).1 = t.1 := get_set_ne q .initial t x hq + have sent := field_before q t x strategy input initialField 0 before + simpa only [CausalExecution.initial, scalar, proof, CausalTerminal.proof, + decodedOpening, List.getElem!_toArray] using + congrArg (fun m => (⟨input.config.logN, + ⟨(batchClaims (2 ^ input.config.logN) input.claims t.1).weight, + (batchClaims (2 ^ input.config.logN) input.claims t.1).value, m⟩, + liftRoot input.root⟩ : CheckedState)) sent + +theorem challenge_level_set (c : Config) (q : Coordinate c) (t : Tape c) (x : Sample q) + (i : Fin c.folds.size) (before : levelStart (challenges c t) (i.val+1) ≤ position q) : + (challenges c (set q t x)).levels[i.val]! = (challenges c t).levels[i.val]! := by + have limit : levelStart (challenges c t) i.val + c.folds[i.val]! + oodCount c i.val + 1 ≤ + position q := by simpa only [levelStart_succ, challenge_folds_size, challenge_oods_size] using before + have hf : ((set q t x).2.1 i).1 = (t.2.1 i).1 := by + funext j + exact get_set_ne q (.fold i j) t x (by + intro h + have hp := congrArg position h + rw [position_fold i j t] at hp + omega) + have ho : ((set q t x).2.1 i).2.1 = (t.2.1 i).2.1 := by + funext j + exact get_set_ne q (.ood i j) t x (by + intro h + have hp := congrArg position h + rw [position_ood i j t] at hp + omega) + have hq : ((set q t x).2.1 i).2.2 = (t.2.1 i).2.2 := + get_set_ne q (.query i) t x (by + intro h + have hp := congrArg position h + rw [position_query i t] at hp + omega) + have ht : (set q t x).2.1 i = t.2.1 i := Prod.ext hf (Prod.ext ho hq) + simp [challenges, _root_.getElem!_pos, i.isLt, ht] + +theorem proof_level_set (input : Public) (strategy : Strategy) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (i : Fin input.config.folds.size) + (before : levelStart (challenges input.config t) (i.val+1) ≤ position q) : + (proof input strategy (set q t x)).levels[i.val]! = (proof input strategy t).levels[i.val]! := by + rw [proof_level, proof_level] + apply decodedLevel_prefix + · exact challenge_level_set input.config q t x i before + · exact levelStart_set q t x i.val + · intro n hn + apply field_before q t x strategy input id n + rw [levelStart_set] at hn + omega + +theorem levelAt_set (input : Public) (strategy : Strategy) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (i : Nat) (hi : i ≤ input.config.folds.size) + (before : levelStart (challenges input.config t) i ≤ position q) : + levelAt input strategy (set q t x) i = levelAt input strategy t i := by + apply levelAt_congr + · exact initial_set input strategy q t x (lt_of_lt_of_le (levelStart_pos _ i) before) + · intro k hk + exact challenge_level_set input.config q t x ⟨k, by omega⟩ + ((levelStart_mono _ (by omega : k+1 ≤ i)).trans before) + · intro k hk + exact proof_level_set input strategy q t x ⟨k, by omega⟩ + ((levelStart_mono _ (by omega : k+1 ≤ i)).trans before) + +theorem foldAt_set (input : Public) (strategy : Strategy) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (i : Fin input.config.folds.size) (j : Nat) (hj : j ≤ input.config.folds[i.val]!) + (before : levelStart (challenges input.config t) i.val + j ≤ position q) : + foldAt input strategy (set q t x) i.val j = foldAt input strategy t i.val j := by + apply foldAt_congr + · exact levelAt_set input strategy q t x i.val (by omega) (by omega) + · intro k hk + rw [challenge_fold input.config _ i ⟨k, by omega⟩, + challenge_fold input.config _ i ⟨k, by omega⟩] + apply get_set_ne + intro h + have hp := congrArg position h + rw [position_fold _ _ t] at hp + dsimp only [Fin.val_mk] at hp + omega + · intro k hk + rw [proof_fold input strategy _ i ⟨k, by omega⟩, + proof_fold input strategy _ i ⟨k, by omega⟩, levelStart_set] + exact field_before q t x strategy input foldField + (levelStart (challenges input.config t) i.val + k) (by omega) + +theorem oracleAt_set (input : Public) (strategy : Strategy) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (i : Fin input.config.folds.size) (j : Nat) (hj : j ≤ input.config.folds[i.val]!) + (before : levelStart (challenges input.config t) i.val + j ≤ position q) {N : Nat} : + OracleReplay.oracleAt (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy (set q t x) i.val).oracle + (challenges input.config (set q t x)).levels[i.val]!.folds j (N := N) = + OracleReplay.oracleAt (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy t i.val).oracle + (challenges input.config t).levels[i.val]!.folds j := by + rw [levelAt_set input strategy q t x i.val (by omega) (by omega)] + apply oracleAt_congr + intro k hk + rw [challenge_fold input.config _ i ⟨k, by omega⟩, + challenge_fold input.config _ i ⟨k, by omega⟩] + apply get_set_ne + intro h + have hp := congrArg position h + rw [position_fold _ _ t] at hp + dsimp only [Fin.val_mk] at hp + omega + +theorem foldCandidates_set (input : Public) (strategy : Strategy) + (q : Coordinate input.config) (t : Tape input.config) (x : Sample q) + (i : Fin input.config.folds.size) (j : Nat) (hj : j ≤ input.config.folds[i.val]!) + (before : levelStart (challenges input.config t) i.val + j ≤ position q) : + foldCandidates input strategy (set q t x) i.val j = + foldCandidates input strategy t i.val j := by + unfold foldCandidates + rw [oracleAt_set input strategy q t x i j hj before] + +end Whir.CausalStateCausality diff --git a/verification/whir/Whir/CausalStrategy.lean b/verification/whir/Whir/CausalStrategy.lean new file mode 100644 index 000000000..155852b23 --- /dev/null +++ b/verification/whir/Whir/CausalStrategy.lean @@ -0,0 +1,369 @@ +import Whir.WHIRFiatShamir + +/-! Concrete replay of already decoded prover messages. Later response slots are +irrelevant to an earlier allocated challenge's canonical loss envelope. -/ +namespace Whir.CausalStrategy +open Concrete Protocol CausalGame CausalProbability CausalExecution + +/-- Only the number of already processed messages is inspected, never a future challenge. -/ +def indexedStrategy (replies : Array Reply) : Strategy := fun _ past _ => replies[past.length]?.getD default + +@[simp] theorem indexedStrategy_apply (replies : Array Reply) (input : Public) + (past : History) (batch : Batch) : + indexedStrategy replies input past batch = replies[past.length]! := by + unfold indexedStrategy + by_cases h : past.length < replies.size + · simp [getElem!_pos, getElem?_pos, h] + · simp [getElem!_neg, getElem?_neg, h] + +theorem run_length (strategy : Strategy) (input : Public) (past : History) (batches : List Batch) : + (run strategy input past batches).length = batches.length := by + induction batches generalizing past with + | nil => rfl + | cons batch batches ih => simp only [run, List.length_cons, ih] + +/-- The executable response slot, including the total default for absent replies. -/ +theorem indexed_response (replies : Array Reply) (input : Public) (past : History) + (batches : List Batch) (i : Nat) (hi : i < batches.length) : + (run (indexedStrategy replies) input past batches)[i]! = replies[past.length+i]! := by + induction batches generalizing past i with + | nil => simp at hi + | cons batch batches ih => + cases i with + | zero => simp only [run, indexedStrategy_apply, List.getElem!_cons_zero, Nat.add_zero] + | succ i => + have bound : i < batches.length := by simpa using hi + have result := ih ((batch, replies[past.length]!) :: past) i bound + simpa only [run, indexedStrategy_apply, List.getElem!_cons_succ, List.length_cons, + Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using result + +theorem run_indexed_congr (left right : Array Reply) (input : Public) (past : History) + (batches : List Batch) + (same : ∀ i, i < batches.length → left[past.length+i]! = right[past.length+i]!) : + run (indexedStrategy left) input past batches = run (indexedStrategy right) input past batches := by + apply List.ext_getElem! (by simp only [run_length]) + intro i + by_cases hi : i < batches.length + · rw [indexed_response left input past batches i hi, indexed_response right input past batches i hi] + exact same i hi + · simp [getElem!_neg, run_length, hi] + +/-- Extending the decoded reply array cannot change any already replayed prefix. -/ +theorem run_indexed_prefix (left right : Array Reply) (input : Public) (batches : List Batch) + (n : Nat) (same : ∀ i, i < n → left[i]! = right[i]!) : + (run (indexedStrategy left) input [] batches).take n = + (run (indexedStrategy right) input [] batches).take n := by + rw [run_take, run_take] + apply run_indexed_congr + intro i hi + simpa only [List.length_nil, Nat.zero_add] using same i + (Nat.lt_of_lt_of_le hi (List.length_take_le _ _)) + +open CausalStateCausality CausalRefinement CausalPositions + +theorem response_eq (left right : Array Reply) (input : Public) (t : Tape input.config) (n : Nat) + (same : left[n]! = right[n]!) : + (run (indexedStrategy left) input [] (visibleBatches input.config t.1 (challenges input.config t)))[n]! = + (run (indexedStrategy right) input [] (visibleBatches input.config t.1 (challenges input.config t)))[n]! := by + by_cases h : n < (visibleBatches input.config t.1 (challenges input.config t)).length + · rw [indexed_response left input [] _ n h, indexed_response right input [] _ n h] + simpa only [List.length_nil, Nat.zero_add] using same + · simp [getElem!_neg, run_length, h] + +theorem proof_initial_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (same : left[0]! = right[0]!) : + (proof input (indexedStrategy left) t).initial = (proof input (indexedStrategy right) t).initial := by + simpa only [proof, CausalTerminal.proof, decodedOpening, List.getElem!_toArray] using + congrArg initialField (response_eq left right input t 0 same) + +theorem proof_level_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) + (same : ∀ n, n < levelStart (challenges input.config t) (i.val+1) → left[n]! = right[n]!) : + (proof input (indexedStrategy left) t).levels[i.val]! = + (proof input (indexedStrategy right) t).levels[i.val]! := by + rw [proof_level, proof_level] + apply decodedLevel_prefix + · rfl + · rfl + · intro n hn + exact response_eq left right input t n (same n hn) + +theorem initial_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (same : left[0]! = right[0]!) : + initial input (indexedStrategy left) t = initial input (indexedStrategy right) t := by + unfold initial + rw [proof_initial_eq input left right t same] + +theorem levelAt_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Nat) (hi : i ≤ input.config.folds.size) + (same : ∀ n, n < levelStart (challenges input.config t) i → left[n]! = right[n]!) : + levelAt input (indexedStrategy left) t i = levelAt input (indexedStrategy right) t i := by + apply CausalStateCausality.levelAt_congr + · exact initial_eq input left right t (same 0 (levelStart_pos _ _)) + · intro k hk + rfl + · intro k hk + apply proof_level_eq input left right t ⟨k, by omega⟩ + intro n hn + exact same n (lt_of_lt_of_le hn (levelStart_mono _ (by omega : k+1 ≤ i))) + +theorem foldAt_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Nat) (hj : j ≤ input.config.folds[i.val]!) + (same : ∀ n, n < levelStart (challenges input.config t) i.val+j → left[n]! = right[n]!) : + foldAt input (indexedStrategy left) t i j = foldAt input (indexedStrategy right) t i j := by + apply CausalStateCausality.foldAt_congr + · apply levelAt_eq input left right t i.val i.isLt.le + intro n hn + exact same n (by omega) + · intro k hk + rfl + · intro k hk + rw [proof_fold input (indexedStrategy left) t i ⟨k, by omega⟩, + proof_fold input (indexedStrategy right) t i ⟨k, by omega⟩] + exact congrArg foldField (response_eq left right input t + (levelStart (challenges input.config t) i.val+k) (same _ (by omega))) + +theorem foldCandidates_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Nat) + (same : ∀ n, n < levelStart (challenges input.config t) i.val → left[n]! = right[n]!) : + foldCandidates input (indexedStrategy left) t i j = foldCandidates input (indexedStrategy right) t i j := by + unfold foldCandidates + rw [levelAt_eq input left right t i.val i.isLt.le same] + +theorem proof_nextOracle_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) + (same : ∀ n, n < levelStart (challenges input.config t) i.val+input.config.folds[i.val]! → + left[n]! = right[n]!) : + (proof input (indexedStrategy left) t).levels[i.val]!.nextOracle = + (proof input (indexedStrategy right) t).levels[i.val]!.nextOracle := by + rw [proof_level, proof_level] + dsimp only [decodedLevel] + simp only [challenge_folds_size] + split_ifs with guard + · have response := response_eq left right input t + (levelStart (challenges input.config t) i.val+input.config.folds[i.val]!-1) + (same _ (by omega)) + simpa using congrArg rootField response + · rfl + +theorem proof_residual_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) (last : ¬ i.val+1 < input.config.folds.size) + (same : ∀ n, n < levelStart (challenges input.config t) i.val+input.config.folds[i.val]! → + left[n]! = right[n]!) : + (proof input (indexedStrategy left) t).residual = (proof input (indexedStrategy right) t).residual := by + have index : input.config.folds.size-1 = i.val := by omega + simp only [proof, CausalTerminal.proof, decodedOpening] + rw [index, challenge_folds_size] + split_ifs with guard + · have response := response_eq left right input t + (levelStart (challenges input.config t) i.val+input.config.folds[i.val]!-1) + (same _ (by omega)) + simpa using congrArg residualField response + · rfl + +theorem followingCandidates_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) + (same : ∀ n, n < levelStart (challenges input.config t) i.val+input.config.folds[i.val]! → + left[n]! = right[n]!) : + followingCandidates input (indexedStrategy left) t i = + followingCandidates input (indexedStrategy right) t i := by + unfold followingCandidates + split_ifs with next + · rw [proof_nextOracle_eq input left right t i same] + · rw [proof_residual_eq input left right t i next same] + +theorem proof_oods_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) + (same : ∀ n, n < position (.query i) → left[n]! = right[n]!) : + (proof input (indexedStrategy left) t).levels[i.val]!.oods = + (proof input (indexedStrategy right) t).levels[i.val]!.oods := by + rw [proof_level, proof_level] + dsimp only [decodedLevel] + apply congrArg Array.ofFn + funext j + have bound : j.val < oodCount input.config i.val := by simpa using j.isLt + have response := response_eq left right input t + (levelStart (challenges input.config t) i.val+ + (challenges input.config t).levels[i.val]!.folds.size+j.val) + (same _ (by rw [position_query i t, challenge_folds_size]; omega)) + simpa using congrArg oodField response + +theorem proof_levels_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (same : ∀ n, n < tailStart input.config (challenges input.config t) → left[n]! = right[n]!) : + (proof input (indexedStrategy left) t).levels = (proof input (indexedStrategy right) t).levels := by + dsimp only [proof, CausalTerminal.proof, decodedOpening] + apply congrArg Array.ofFn + funext i + apply decodedLevel_prefix + · rfl + · rfl + · intro n hn + exact response_eq left right input t n (same n (lt_of_lt_of_le hn + (levelStart_mono _ (by omega : i.val+1 ≤ input.config.folds.size)))) + +theorem terminal_residual_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (same : ∀ n, n < tailStart input.config (challenges input.config t) → left[n]! = right[n]!) : + (proof input (indexedStrategy left) t).residual = (proof input (indexedStrategy right) t).residual := by + by_cases positive : 0 < input.config.folds.size + · let last : Fin input.config.folds.size := ⟨input.config.folds.size-1, by omega⟩ + have lastEnd : last.val+1 = input.config.folds.size := by dsimp [last]; omega + apply proof_residual_eq input left right t last (by omega) + intro n hn + apply same n + have next := levelStart_succ (challenges input.config t) last.val + rw [challenge_folds_size, lastEnd] at next + change n < levelStart (challenges input.config t) input.config.folds.size + omega + · simp only [proof, CausalTerminal.proof, decodedOpening, positive, false_and, ↓reduceIte] + +theorem terminal_before_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (same : ∀ n, n < tailStart input.config (challenges input.config t) → left[n]! = right[n]!) : + CausalTerminal.before input (indexedStrategy left) t = + CausalTerminal.before input (indexedStrategy right) t := by + have hp := proof_initial_eq input left right t (same 0 (levelStart_pos _ _)) + have hl := proof_levels_eq input left right t same + have hr := terminal_residual_eq input left right t same + have init : initializeVerifier input.config (challenges input.config t) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims t.1).weight + (batchClaims (2^input.config.logN) input.claims t.1).value (proof input (indexedStrategy left) t) = + initializeVerifier input.config (challenges input.config t) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims t.1).weight + (batchClaims (2^input.config.logN) input.claims t.1).value (proof input (indexedStrategy right) t) := by + simp only [initializeVerifier, hp, hl] + simp [proof, CausalTerminal.proof, decodedOpening] + have replay : replayLevels input.config (challenges input.config t) (proof input (indexedStrategy left) t) = + replayLevels input.config (challenges input.config t) (proof input (indexedStrategy right) t) := by + unfold replayLevels + have step : verifyLevel input.config (challenges input.config t) (proof input (indexedStrategy left) t) = + verifyLevel input.config (challenges input.config t) (proof input (indexedStrategy right) t) := by + funext i s + simp only [verifyLevel, hl, hr] + rw [step] + simp only [CausalTerminal.before, CausalTerminal.beforeChecked, init, replay] + +theorem proof_tail_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (j : Fin (input.config.logN-input.config.folds.toList.sum)) (k : Nat) (hk : k < j.val) + (same : ∀ n, n < position (.tail j) → left[n]! = right[n]!) : + (proof input (indexedStrategy left) t).tailMessages[k]! = + (proof input (indexedStrategy right) t).tailMessages[k]! := by + simp only [proof, CausalTerminal.proof, decodedOpening] + have bound : k < (challenges input.config t).tail.size-1 := by + rw [CausalTerminal.tail_size] + omega + rw [getElem!_pos _ _ (by simpa only [Array.size_ofFn] using bound), + getElem!_pos _ _ (by simpa only [Array.size_ofFn] using bound)] + simp only [Array.getElem_ofFn] + have response := response_eq left right input t (tailStart input.config (challenges input.config t)+k) + (same _ (by rw [CausalPrefix.position_tail j t]; omega)) + simpa using congrArg tailField response + +theorem tail_kernels_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (j : Fin (input.config.logN-input.config.folds.toList.sum)) + (same : ∀ n, n < position (.tail j) → left[n]! = right[n]!) : + CausalTerminal.candidate input (indexedStrategy left) t j = + CausalTerminal.candidate input (indexedStrategy right) t j ∧ + CausalTerminal.pending input (indexedStrategy left) t j = + CausalTerminal.pending input (indexedStrategy right) t j := by + have prior (n : Nat) (hn : n < tailStart input.config (challenges input.config t)) : + left[n]! = right[n]! := same n (by rw [CausalPrefix.position_tail j t]; omega) + have residual := terminal_residual_eq input left right t prior + have before := terminal_before_eq input left right t prior + constructor + · simp only [CausalTerminal.candidate] + rw [residual] + · have every (k : Nat) (hk : k ≤ j.val) : + TerminalSoundness.stateAt (challenges input.config t) (proof input (indexedStrategy left) t) + (CausalTerminal.before input (indexedStrategy left) t) k = + TerminalSoundness.stateAt (challenges input.config t) (proof input (indexedStrategy right) t) + (CausalTerminal.before input (indexedStrategy right) t) k := by + induction k with + | zero => exact before + | succ k ih => + rw [TerminalSoundness.stateAt_succ, TerminalSoundness.stateAt_succ, ih (by omega)] + unfold tailStep + rw [proof_tail_eq input left right t j k (by omega) same] + exact every j le_rfl + +theorem query_envelope_eq (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) + (same : ∀ n, n < position (.query i) → left[n]! = right[n]!) : + WHIRFiatShamir.QueryEnvelope input (indexedStrategy left) i t = + WHIRFiatShamir.QueryEnvelope input (indexedStrategy right) i t := by + have boundaryPast (n : Nat) (hn : n < levelStart (challenges input.config t) i.val+input.config.folds[i.val]!) : + left[n]! = right[n]! := same n (by rw [position_query i t]; omega) + have level := levelAt_eq input left right t i i.isLt.le + (fun n hn => boundaryPast n (by omega)) + have folded := foldAt_eq input left right t i input.config.folds[i.val]! le_rfl boundaryPast + have following := followingCandidates_eq input left right t i boundaryPast + have oods := proof_oods_eq input left right t i same + have prior : CausalBoundary.QueryPrior input (indexedStrategy left) i t = + CausalBoundary.QueryPrior input (indexedStrategy right) i t := by + unfold CausalBoundary.QueryPrior CausalBoundary.boundary + dsimp only + rw [level, folded, following, oods] + by_cases next : i.val+1 < input.config.folds.size + · simp only [next, ↓reduceIte] + · rw [proof_residual_eq input left right t i next boundaryPast] + funext x + unfold WHIRFiatShamir.QueryEnvelope CausalBoundary.boundary + rw [prior, level, folded, following] + simp only [QueryBatchSoundness.Restores, queryBatch, oodBatch, oods] + rfl + +/-- Allocation envelopes inspect only replies strictly before their own random draw. -/ +theorem envelope_indexed_eq (input : Public) (left right : Array Reply) + (q : Coordinate input.config) (t : Tape input.config) + (same : ∀ n, n < position q → left[n]! = right[n]!) : + WHIRFiatShamir.Envelope input (indexedStrategy left) q t = + WHIRFiatShamir.Envelope input (indexedStrategy right) q t := by + funext x + cases q with + | initial => rfl + | fold i j => + let u := set (.fold i j) t x + have prior (n : Nat) (hn : n < levelStart (challenges input.config u) i.val+j.val) : + left[n]! = right[n]! := same n (by rw [position_fold i j u]; exact hn) + have early (n : Nat) (hn : n < levelStart (challenges input.config u) i.val) : + left[n]! = right[n]! := prior n (by omega) + have state := foldAt_eq input left right u i j j.isLt.le prior + have oldList := foldCandidates_eq input left right u i j early + have newList := foldCandidates_eq input left right u i (j.val+1) early + change CausalFolds.Event input (indexedStrategy left) i j u = + CausalFolds.Event input (indexedStrategy right) i j u + unfold CausalFolds.Event + rw [oldList, newList, state, foldAt_succ, foldAt_succ, state] + rfl + | ood i j => + let u := set (.ood i j) t x + have boundaryPast (n : Nat) + (hn : n < levelStart (challenges input.config u) i.val+input.config.folds[i.val]!) : + left[n]! = right[n]! := same n (by rw [position_ood i j u]; omega) + change CausalBoundary.OodEvent input (indexedStrategy left) i j u = + CausalBoundary.OodEvent input (indexedStrategy right) i j u + unfold CausalBoundary.OodEvent + rw [followingCandidates_eq input left right u i boundaryPast] + | query i => exact congrFun (query_envelope_eq input left right t i same) x + | tail j => + have kernels := tail_kernels_eq input left right (set (.tail j) t x) j same + dsimp only [WHIRFiatShamir.Envelope, CausalBadEvents.Bad] + rw [kernels.1, kernels.2] + +/-- Concrete replay realizations agreeing on strict prior replies and challenges +have exactly the same allocation-time event on the whole next draw. -/ +theorem allocationBad_indexed_congr (p : ParameterBounds.Profile) (s : WHIRFiatShamir.Statement p) + (left right : Array Reply) (q : Coordinate (ParameterBounds.config p)) + (t u : Tape (ParameterBounds.config p)) (x : Sample q) + (replies : ∀ j, j < position q → left[j]! = right[j]!) + (tape : ∀ r, position r < position q → get r t = get r u) : + WHIRFiatShamir.allocationBad (WHIRFiatShamir.requestOfTape s (indexedStrategy left) q t) x ↔ + WHIRFiatShamir.allocationBad (WHIRFiatShamir.requestOfTape s (indexedStrategy right) q u) x := by + have past : WHIRFiatShamir.Prefix.ofTape q t = WHIRFiatShamir.Prefix.ofTape q u := by + funext r hr + exact tape r hr + unfold WHIRFiatShamir.allocationBad WHIRFiatShamir.requestOfTape + dsimp only + rw [past] + exact Iff.of_eq (congrFun (envelope_indexed_eq s.input left right q + (WHIRFiatShamir.Prefix.ofTape q u).tape replies) x) + +end Whir.CausalStrategy diff --git a/verification/whir/Whir/CausalTerminal.lean b/verification/whir/Whir/CausalTerminal.lean new file mode 100644 index 000000000..68d018138 --- /dev/null +++ b/verification/whir/Whir/CausalTerminal.lean @@ -0,0 +1,343 @@ +import Whir.CausalRefinement +import Whir.TerminalSoundness +import Whir.CausalProbability + +namespace Whir.CausalTerminal +open Concrete Protocol CausalGame CausalRefinement OperationalRefinement TerminalSoundness + +/-- Total wire projections; acceptance separately enforces the parser tags. -/ +def proof (input : Public) (strategy : Strategy) (t : Tape input.config) : Opening := + decodedOpening input.config (challenges input.config t) + (run strategy input [] (visibleBatches input.config t.1 (challenges input.config t))).toArray + +/-- Actual checked execution up to, but not including, the terminal folds. -/ +def beforeChecked (input : Public) (strategy : Strategy) (t : Tape input.config) : + Except String CheckedState := do + let ch := challenges input.config t + let p := proof input strategy t + let claim := batchClaims (2^input.config.logN) input.claims t.1 + let initial ← initializeVerifier input.config ch input.lanes (liftRoot input.root) + claim.weight claim.value p + replayLevels input.config ch p initial + +/-- Totalization never accepts an error: the event below requires the actual experiment. -/ +def before (input : Public) (strategy : Strategy) (t : Tape input.config) : VerifierState E := + ((beforeChecked input strategy t).toOption.getD default).state + +def candidate (input : Public) (strategy : Strategy) (t : Tape input.config) (j : Nat) : Array E := + residualAt (challenges input.config t) (proof input strategy t).residual j + +def pending (input : Public) (strategy : Strategy) (t : Tape input.config) (j : Nat) : VerifierState E := + stateAt (challenges input.config t) (proof input strategy t) (before input strategy t) j + +private theorem levelStart_mono (ch : Challenges) {i k : Nat} (h : i ≤ k) : + levelStart ch i ≤ levelStart ch k := by + induction h with + | refl => exact le_rfl + | @step k h ih => rw [levelStart_succ]; omega + +private theorem answer_prefix (strategy : Strategy) (input : Public) (left right : List Batch) + (n k : Nat) (hn : n < k) (h : left.take k = right.take k) : + (run strategy input [] left).toArray[n]! = (run strategy input [] right).toArray[n]! := by + have he : left.take (n+1) = right.take (n+1) := by + have := congrArg (List.take (n+1)) h + simpa [List.take_take, Nat.min_eq_left (by omega : n+1 ≤ k)] using this + simpa using field_prefix id strategy input left right n he + +/-- Before the tail starts, every level, residual, and initial projection is fixed. +This is a statement about arbitrary replies, including malformed wire tags. -/ +theorem decoded_prefix (c : Config) (left right : Challenges) + (levels : left.levels = right.levels) (strategy : Strategy) (input : Public) + (bs ds : List Batch) (h : bs.take (tailStart c left) = ds.take (tailStart c left)) : + let p := decodedOpening c left (run strategy input [] bs).toArray + let q := decodedOpening c right (run strategy input [] ds).toArray + p.initial = q.initial ∧ p.levels = q.levels ∧ p.residual = q.residual := by + have starts : levelStart left = levelStart right := by + funext i + simp [levelStart, levelBatches, levels] + have ans (n : Nat) (hn : n < tailStart c left) := + answer_prefix strategy input bs ds n (tailStart c left) hn h + have lastBound (i : Nat) (hi : i < c.folds.size) : + levelStart left i + left.levels[i]!.folds.size + left.levels[i]!.oodPoints.size < + tailStart c left := by + have hm := levelStart_mono left (Nat.succ_le_of_lt hi) + rw [levelStart_succ] at hm + unfold tailStart + omega + dsimp only + refine ⟨?_, ?_, ?_⟩ + · simp only [decodedOpening] + rw [ans 0 (by have := levelStart_mono left (Nat.zero_le c.folds.size) + rw [levelStart_zero] at this; exact this)] + · simp only [decodedOpening] + apply congrArg Array.ofFn + funext i + have hb := lastBound i i.isLt + simp only [decodedLevel, ← levels, ← starts] + congr 1 + · apply Array.ext + · simp [levels] + intro j hj hk + simp only [Array.size_ofFn] at hj + simp only [Array.getElem_ofFn] + rw [ans _ (by omega)] + · split_ifs <;> try rfl + rw [ans _ (by omega)] + · apply Array.ext + · simp [levels] + intro j hj hk + simp only [Array.size_ofFn] at hj + simp only [Array.getElem_ofFn] + rw [ans _ (by omega)] + · rw [ans _ hb] + · rw [ans _ hb] + · simp only [decodedOpening, ← levels, ← starts] + split_ifs with hp + · have hb := lastBound (c.folds.size-1) (by omega) + rw [ans _ (by omega)] + · rfl + +/-- Checked initialization and replay read no terminal challenge values. -/ +theorem before_congr (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) (t u : Tape input.config) + (initial : t.1 = u.1) + (levels : (challenges input.config t).levels = (challenges input.config u).levels) + (samePrefix : + (visibleBatches input.config t.1 (challenges input.config t)).take + (tailStart input.config (challenges input.config t)) = + (visibleBatches input.config u.1 (challenges input.config u)).take + (tailStart input.config (challenges input.config t))) : + before input strategy t = before input strategy u := by + obtain ⟨hp, hl, hr⟩ := decoded_prefix input.config _ _ levels strategy input _ _ samePrefix + change (proof input strategy t).initial = (proof input strategy u).initial at hp + change (proof input strategy t).levels = (proof input strategy u).levels at hl + change (proof input strategy t).residual = (proof input strategy u).residual at hr + have init : + initializeVerifier input.config (challenges input.config t) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims t.1).weight + (batchClaims (2^input.config.logN) input.claims t.1).value (proof input strategy t) = + initializeVerifier input.config (challenges input.config u) input.lanes + (liftRoot input.root) (batchClaims (2^input.config.logN) input.claims u.1).weight + (batchClaims (2^input.config.logN) input.claims u.1).value (proof input strategy u) := by + simp only [initializeVerifier, TapeValidity.challenges_valid _ valid, + initial, hp, hl] + simp [proof, decodedOpening, challenges] + have replay : replayLevels input.config (challenges input.config t) (proof input strategy t) = + replayLevels input.config (challenges input.config u) (proof input strategy u) := by + unfold replayLevels + have step : verifyLevel input.config (challenges input.config t) (proof input strategy t) = + verifyLevel input.config (challenges input.config u) (proof input strategy u) := by + funext i s + simp only [verifyLevel, levels, hl, hr] + rw [step] + simp only [before, beforeChecked, init, replay] + +private theorem take_shorter {α : Type*} (a b : List α) {m n : Nat} + (hm : m ≤ n) (h : a.take n = b.take n) : a.take m = b.take m := by + have := congrArg (List.take m) h + simpa [List.take_take, Nat.min_eq_left hm] using this + +@[simp] theorem tail_size (c : Config) (t : Tape c) : + (challenges c t).tail.size = c.logN - c.folds.toList.sum := by + simp [challenges] + +/-- The actual residual and pending state at round `j` depend only on its strict +challenge prefix. The next transmitted message remains completely arbitrary. -/ +theorem kernels_congr (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) (t u : Tape input.config) (j : Nat) + (initial : t.1 = u.1) + (levels : (challenges input.config t).levels = (challenges input.config u).levels) + (past : ∀ k < j, (challenges input.config t).tail[k]! = + (challenges input.config u).tail[k]!) + (samePrefix : + (visibleBatches input.config t.1 (challenges input.config t)).take + (tailStart input.config (challenges input.config t)+j) = + (visibleBatches input.config u.1 (challenges input.config u)).take + (tailStart input.config (challenges input.config t)+j)) : + candidate input strategy t j = candidate input strategy u j ∧ + pending input strategy t j = pending input strategy u j := by + have short := take_shorter _ _ (Nat.le_add_right _ j) samePrefix + have hb := before_congr input strategy valid t u initial levels short + have hr := (decoded_prefix input.config _ _ levels strategy input _ _ short).2.2 + change (proof input strategy t).residual = (proof input strategy u).residual at hr + have starts : tailStart input.config (challenges input.config t) = + tailStart input.config (challenges input.config u) := by + simp [tailStart, levelStart, levelBatches, levels] + have messages (k : Nat) (hk : k < j) : + (proof input strategy t).tailMessages[k]! = (proof input strategy u).tailMessages[k]! := by + dsimp only [proof, decodedOpening] + by_cases hlen : k < input.config.logN - input.config.folds.toList.sum - 1 + · rw [getElem!_pos _ _ (by simpa using hlen), getElem!_pos _ _ (by simpa using hlen)] + simp only [Array.getElem_ofFn] + rw [← starts] + exact congrArg tailField (answer_prefix strategy input _ _ _ _ (by omega) samePrefix) + · rw [getElem!_neg _ _ (by simpa using hlen), getElem!_neg _ _ (by simpa using hlen)] + have all (k : Nat) (hk : k ≤ j) : + candidate input strategy t k = candidate input strategy u k ∧ + pending input strategy t k = pending input strategy u k := by + induction k with + | zero => exact ⟨hr, hb⟩ + | succ k ih => + obtain ⟨ha, hs⟩ := ih (by omega) + constructor + · simp only [candidate] at ha ⊢ + rw [residualAt_succ, residualAt_succ, ha, past k (by omega)] + · simp only [pending] at hs ⊢ + rw [stateAt_succ, stateAt_succ] + simp only [tailStep, hs, tail_size, past k (by omega), messages k (by omega)] + exact all j le_rfl + +/-- Acceptance identifies the totalized pre-tail kernel with the successful actual +checked replay. Parser failures and verifier failures cannot enter this lemma. -/ +theorem accepted_closing (input : Public) (strategy : Strategy) (t : Tape input.config) + (accepted : experiment input strategy t = true) : + checkClosing (challenges input.config t) (proof input strategy t) + (closeTail (challenges input.config t) (proof input strategy t) (before input strategy t)) = + .ok () := by + obtain ⟨_, p, s, finish, parsed, init, trace, close⟩ := + (experiment_iff input strategy t).mp accepted + have hp : p = proof input strategy t := + opening_eq_decoded _ _ _ _ parsed + subst p + have replay := (runChecked_ok_iff_trace _ _ _ _ _).mpr trace + have hb : beforeChecked input strategy t = .ok finish := by + simp only [beforeChecked, init] + exact replay + have hs : before input strategy t = finish.state := by rw [before, hb]; rfl + rw [hs, checkClosing_ok_iff] + exact close + +/-- Only accepted executions with a well-shaped false incoming residual claim +are charged. No condition is imposed on rejected or malformed strategy outputs. -/ +def Event (input : Public) (strategy : Strategy) (t : Tape input.config) : Prop := + experiment input strategy t = true ∧ + (proof input strategy t).residual.size = 2^(input.config.logN-input.config.folds.toList.sum) ∧ + (before input strategy t).weight.size = (proof input strategy t).residual.size ∧ + dot (proof input strategy t).residual (before input strategy t).weight ≠ + (before input strategy t).claim + +attribute [local irreducible] collision +set_option maxRecDepth 2048 in +theorem event_has_collision (input : Public) (strategy : Strategy) (t : Tape input.config) + (h : Event input strategy t) : + ∃ j : Fin (input.config.logN-input.config.folds.toList.sum), + dot (candidate input strategy t j) (pending input strategy t j).weight ≠ + (pending input strategy t j).claim ∧ + t.2.2 j ∈ collision (candidate input strategy t j) (pending input strategy t j) := by + classical + obtain ⟨ha, shape, weights, lost⟩ := h + obtain ⟨j, hj, hl, hc⟩ := accepted_has_collision (challenges input.config t) + (proof input strategy t) (before input strategy t) (by simpa using shape) weights lost + (accepted_closing input strategy t ha) + have hn : j < input.config.logN-input.config.folds.toList.sum := by simpa only [tail_size] using hj + let i : Fin (input.config.logN-input.config.folds.toList.sum) := ⟨j, hn⟩ + have fresh : (challenges input.config t).tail[j]! = t.2.2 i := by + rw [getElem!_pos (challenges input.config t).tail j hj] + exact Array.getElem_ofFn hj + refine ⟨i, hl, ?_⟩ + change t.2.2 i ∈ collision (residualAt (challenges input.config t) (proof input strategy t).residual j) + (stateAt (challenges input.config t) (proof input strategy t) (before input strategy t) j) + rw [← fresh] + exact hc + +open CausalProbability + +/-- Replacing the fresh actual tape coordinate cannot alter either collision +polynomial, including the adversarial pending message. -/ +theorem kernels_set (input : Public) (strategy : Strategy) (valid : input.config.valid = true) + (j : Fin (input.config.logN-input.config.folds.toList.sum)) (t : Tape input.config) (x : E) : + candidate input strategy (set (.tail j) t x) j = candidate input strategy t j ∧ + pending input strategy (set (.tail j) t x) j = pending input strategy t j := by + classical + apply kernels_congr input strategy valid _ t j + · simp only [set_tail] + · exact (tail_challenges_prefix j t x).1 + · intro k hk + have hkn := lt_trans hk j.isLt + have hne : (⟨k, hkn⟩ : Fin (input.config.logN-input.config.folds.toList.sum)) ≠ j := + Fin.ne_of_val_ne (by simpa using Nat.ne_of_lt hk) + simp only [set_tail, challenges] + rw [getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hkn), + getElem!_pos _ _ (by simpa only [Array.size_ofFn] using hkn)] + simp only [Array.getElem_ofFn, Function.update_of_ne hne] + · have hs : tailStart input.config (challenges input.config (set (.tail j) t x)) = + tailStart input.config (challenges input.config t) := by + have hl : levelBatches (challenges input.config (set (.tail j) t x)) = + levelBatches (challenges input.config t) := by + rw [set_tail] + rfl + simp only [tailStart, levelStart, hl] + rw [hs] + exact tail_visible_prefix j t x + +noncomputable local instance {c : Config} : DecidableEq (Tape c) := Classical.decEq _ +noncomputable local instance : DecidableEq E := Classical.decEq _ +attribute [local instance] Classical.propDecidable +attribute [local irreducible] Event proof before candidate pending + +set_option maxRecDepth 2048 +/-- Actual-strategy terminal soundness. Shape and incoming loss are guarded +inside the charged event, not assumed on every possible challenge tape. -/ +theorem actual_strategy_bound (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) : + Soundness.uniformProb (Finset.univ.filter (Event input strategy)) ≤ + (input.config.logN-input.config.folds.toList.sum : Nat) * + (2 / (Fintype.card E : ℚ)) := by + classical + let n := input.config.logN-input.config.folds.toList.sum + let bad : Fin n → Tape input.config → Prop := fun j t => + dot (candidate input strategy t j) (pending input strategy t j).weight ≠ + (pending input strategy t j).claim ∧ + t.2.2 j ∈ collision (candidate input strategy t j) (pending input strategy t j) + have sub : Finset.univ.filter (Event input strategy) ⊆ + Finset.univ.biUnion (fun j : Fin n => Finset.univ.filter (bad j)) := by + simp only [Finset.subset_iff, Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_biUnion] + intro t ht + exact event_has_collision input strategy t ht + have fiber (j : Fin n) (rest : Rest (.tail j)) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample (.tail j) => + bad j (set (.tail j) rest.val x)) ≤ 2 / (Fintype.card E : ℚ) := by + have eq (x : E) : bad j (set (.tail j) rest.val x) ↔ + dot (candidate input strategy rest.val j) (pending input strategy rest.val j).weight ≠ + (pending input strategy rest.val j).claim ∧ + x ∈ collision (candidate input strategy rest.val j) (pending input strategy rest.val j) := by + obtain ⟨ha, hs⟩ := kernels_set input strategy valid j rest.val x + dsimp only [bad] + rw [ha, hs] + simp only [set_tail, Function.update_self] + simp_rw [eq] + by_cases lost : dot (candidate input strategy rest.val j) (pending input strategy rest.val j).weight ≠ + (pending input strategy rest.val j).claim + · have he : (Finset.univ.filter fun x : E => + dot (candidate input strategy rest.val j) (pending input strategy rest.val j).weight ≠ + (pending input strategy rest.val j).claim ∧ + x ∈ collision (candidate input strategy rest.val j) (pending input strategy rest.val j)) = + collision (candidate input strategy rest.val j) (pending input strategy rest.val j) := by + ext x + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨And.right, fun h => ⟨lost, h⟩⟩ + rw [he] + exact collision_probability _ _ lost + · simp only [lost, false_and, Finset.filter_false, Soundness.uniformProb, + Finset.card_empty, Nat.cast_zero, zero_div] + positivity + calc + _ ≤ Soundness.uniformProb (Finset.univ.biUnion + (fun j : Fin n => Finset.univ.filter (bad j))) := by + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_le_card sub + _ ≤ ∑ _j : Fin n, 2 / (Fintype.card E : ℚ) := + by simpa only using coordinate_union_bound (fun j : Fin n => .tail j) bad _ fiber + _ = _ := by simp [n] + +/-- The current concrete cubic tower has exactly `2^192` elements. -/ +theorem actual_strategy_bound_exact (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) : + Soundness.uniformProb (Finset.univ.filter (Event input strategy)) ≤ + (input.config.logN-input.config.folds.toList.sum : Nat) * 2 / (2 : ℚ)^192 := by + have h := actual_strategy_bound input strategy valid + rw [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at h + simpa only [mul_div_assoc] using h + +end Whir.CausalTerminal diff --git a/verification/whir/Whir/CodingBounds.lean b/verification/whir/Whir/CodingBounds.lean new file mode 100644 index 000000000..d3b8c4c3d --- /dev/null +++ b/verification/whir/Whir/CodingBounds.lean @@ -0,0 +1,216 @@ +import Whir.Soundness +import Mathlib.Algebra.Order.BigOperators.Ring.Finset +import Mathlib.Algebra.Polynomial.OfFn +import Mathlib.Analysis.SpecialFunctions.Pow.Real + +/-! Finite-code list bounds. The list is a deterministic filter of the committed +oracle; no opening strategy or challenge is an argument. -/ +namespace Whir.CodingBounds +open scoped BigOperators + +noncomputable def agreement {X A : Type*} [Fintype X] (u v : X → A) : ℕ := by + classical + exact (Finset.univ.filter fun x => u x = v x).card + +noncomputable def candidates {M X A : Type*} [Fintype M] [Fintype X] + (encode : M → X → A) (oracle : X → A) (threshold : ℕ) : Finset M := by + classical + exact Finset.univ.filter fun m => threshold ≤ agreement (encode m) oracle + +/-- Johnson's second-moment inequality, derived from the actual agreement +relation. This slightly relaxed integer form avoids square roots and rounding. -/ +theorem johnson_second_moment {I X A : Type*} [Fintype I] [Fintype X] + (code : I → X → A) (oracle : X → A) (t d : ℕ) + (close : ∀ i, t ≤ agreement (code i) oracle) + (hd : d ≤ Fintype.card X) + (pairwise : ∀ i j, i ≠ j → agreement (code i) (code j) ≤ d) : + (Fintype.card I : ℚ) * ((t : ℚ)^2 - Fintype.card X * d) ≤ + Fintype.card X * (Fintype.card X - (d : ℚ)) := by + classical + let a : I → X → ℚ := fun i x => if code i x = oracle x then 1 else 0 + let L : ℚ := Fintype.card I + let N : ℚ := Fintype.card X + have row (i : I) : ∑ x, a i x = (agreement (code i) oracle : ℚ) := by + simp only [a, agreement, Finset.card_filter, Nat.cast_sum, Nat.cast_ite, + Nat.cast_one, Nat.cast_zero] + have low : L * t ≤ ∑ x, ∑ i, a i x := by + rw [Finset.sum_comm] + calc + L * t = ∑ _i : I, (t : ℚ) := by simp [L] + _ ≤ _ := Finset.sum_le_sum fun i _ => by rw [row]; exact_mod_cast close i + have overlap (i j : I) : ∑ x, a i x * a j x ≤ if i = j then N else (d : ℚ) := by + by_cases h : i = j + · subst j + simp only [ite_true] + calc + _ ≤ ∑ _x : X, (1 : ℚ) := Finset.sum_le_sum fun x _ => by + dsimp [a]; split_ifs <;> norm_num + _ = N := by simp [N] + · rw [ite_eq_right h] + calc + _ ≤ (agreement (code i) (code j) : ℚ) := by + simp only [agreement, Finset.card_filter, Nat.cast_sum, Nat.cast_ite, + Nat.cast_one, Nat.cast_zero] + apply Finset.sum_le_sum + intro x _ + dsimp [a] + split_ifs <;> simp_all + _ ≤ d := by exact_mod_cast pairwise i j h + have square : ∑ x, (∑ i, a i x)^2 ≤ L * N + L * (L - 1) * d := by + simp_rw [sq, Finset.sum_mul_sum] + rw [Finset.sum_comm] + calc + _ = ∑ i, ∑ j, ∑ x, a i x * a j x := by + apply Finset.sum_congr rfl + intro i _ + rw [Finset.sum_comm] + _ ≤ ∑ i : I, ∑ j : I, if i = j then N else (d : ℚ) := + Finset.sum_le_sum fun i _ => Finset.sum_le_sum fun j _ => overlap i j + _ = L * N + L * (L - 1) * d := by + have each (i : I) : + (∑ j : I, if i = j then N else (d : ℚ)) = N + (L - 1) * d := by + calc + _ = ∑ j : I, ((if j = i then N - d else 0) + d) := by + apply Finset.sum_congr rfl + intro j _ + by_cases h : i = j <;> simp [h, Ne.symm] + _ = _ := by simp [Finset.sum_add_distrib, L]; ring + simp_rw [each] + simp [L] + ring + have cs := Finset.sum_mul_sq_le_sq_mul_sq (Finset.univ : Finset X) + (fun _ => (1 : ℚ)) (fun x => ∑ i, a i x) + simp only [one_mul, one_pow, Finset.sum_const, Finset.card_univ, nsmul_eq_mul, + mul_one] at cs + have nonneg : 0 ≤ L * (t : ℚ) := by positivity + have sqLow : (L * (t : ℚ))^2 ≤ (∑ x, ∑ i, a i x)^2 := by nlinarith + have upper : (L * (t : ℚ))^2 ≤ N * (L * N + L * (L - 1) * d) := + sqLow.trans (cs.trans (mul_le_mul_of_nonneg_left square (by positivity))) + by_cases hL : L = 0 + · have hd' : (d : ℚ) ≤ N := by dsimp [N]; exact_mod_cast hd + change L * ((t : ℚ)^2 - N * d) ≤ N * (N - d) + rw [hL, zero_mul] + exact mul_nonneg (by dsimp [N]; positivity) (sub_nonneg.mpr hd') + · have pos : 0 < L := lt_of_le_of_ne (by dsimp [L]; positivity) (Ne.symm hL) + change L * ((t : ℚ)^2 - N * d) ≤ N * (N - d) + nlinarith + +/-- Exact rational list-size bound above the Johnson agreement threshold. -/ +theorem candidates_card {M X A : Type*} [Fintype M] [Fintype X] + (encode : M → X → A) (oracle : X → A) (t d : ℕ) + (hd : d ≤ Fintype.card X) + (pairwise : ∀ i j, i ≠ j → agreement (encode i) (encode j) ≤ d) + (threshold : (Fintype.card X : ℚ) * d < (t : ℚ)^2) : + ((candidates encode oracle t).card : ℚ) ≤ + (Fintype.card X * (Fintype.card X - (d : ℚ))) / + ((t : ℚ)^2 - Fintype.card X * d) := by + classical + rw [le_div_iff₀ (sub_pos.mpr threshold)] + simpa using johnson_second_moment + (fun i : ↥(candidates encode oracle t) => encode i) oracle t d + (fun i => (Finset.mem_filter.mp i.property).2) hd + (fun i j hij => pairwise i j (fun h => hij (Subtype.ext h))) + +/-- Annex B's relaxed square-root/slack bound, without an incidence certificate. +The absolute threshold can be the ceiling used in Annex B. -/ +theorem annexB_johnson {I X A : Type*} [Fintype I] [Fintype X] + (code : I → X → A) (oracle : X → A) (t d : ℕ) + (close : ∀ i, t ≤ agreement (code i) oracle) + (hd : d ≤ Fintype.card X) + (pairwise : ∀ i j, i ≠ j → agreement (code i) (code j) ≤ d) + (rho eta : ℝ) (hrho : 0 < rho) (heta : 0 < eta) + (hN : 0 < Fintype.card X) + (rate : (d : ℝ) ≤ rho * Fintype.card X) + (threshold : (Real.sqrt rho + eta) * Fintype.card X ≤ t) : + (Fintype.card I : ℝ) ≤ 1 / (2 * eta * Real.sqrt rho) := by + have h := johnson_second_moment code oracle t d close hd pairwise + have hreal : (Fintype.card I : ℝ) * ((t : ℝ)^2 - Fintype.card X * d) ≤ + Fintype.card X * (Fintype.card X - (d : ℝ)) := by exact_mod_cast h + let N : ℝ := Fintype.card X + let L : ℝ := Fintype.card I + have npos : 0 < N := by dsimp [N]; exact_mod_cast hN + have lnonneg : 0 ≤ L := by positivity + have spos : 0 < Real.sqrt rho := Real.sqrt_pos.mpr hrho + have hs : (Real.sqrt rho)^2 = rho := Real.sq_sqrt hrho.le + have square : ((Real.sqrt rho + eta) * N)^2 ≤ (t : ℝ)^2 := by + apply pow_le_pow_left₀ (by positivity) threshold + have rate' : N * d ≤ rho * N^2 := by + have := mul_le_mul_of_nonneg_left rate npos.le + dsimp [N] at * + nlinarith + have denom : 2 * eta * Real.sqrt rho * N^2 ≤ (t : ℝ)^2 - N * d := by + nlinarith [sq_nonneg (eta * N)] + have combined := mul_le_mul_of_nonneg_left denom lnonneg + have simple : L * (2 * eta * Real.sqrt rho) * N^2 ≤ 1 * N^2 := by + have nd : 0 ≤ N * (d : ℝ) := by positivity + change L * ((t : ℝ)^2 - N * d) ≤ N * (N - d) at hreal + nlinarith + have cancelled := (mul_le_mul_iff_left₀ (sq_pos_of_pos npos)).mp simple + exact (le_div_iff₀ (by positivity)).mpr cancelled + +section ReedSolomon +variable {F : Type*} [Field F] [DecidableEq F] + +/-- Finite coefficient tables, with all lanes evaluated at the same coordinate. -/ +def interleavedEncode {lanes k : ℕ} (v : Fin lanes → Fin k → F) + (x : F) : Fin lanes → F := fun j => (Polynomial.ofFn k (v j)).eval x + +/-- Injectivity of decoding into polynomial coefficient tables, not a +postulated injectivity of the evaluation code. -/ +theorem coefficient_tables_injective (lanes k : ℕ) : + Function.Injective (fun v : Fin lanes → Fin k → F => + fun j => Polynomial.ofFn k (v j)) := by + intro u v h + funext j + exact Polynomial.injective_ofFn k (congrFun h j) + +theorem interleaved_agreement {lanes k : ℕ} (domain : Finset F) + (u v : Fin lanes → Fin k → F) (hne : u ≠ v) (hk : 0 < k) : + (domain.filter fun x => interleavedEncode u x = interleavedEncode v x).card ≤ k - 1 := by + classical + obtain ⟨j, hj⟩ := Function.ne_iff.mp hne + have hp : Polynomial.ofFn k (u j) ≠ Polynomial.ofFn k (v j) := + fun h => hj (Polynomial.injective_ofFn k h) + calc + _ ≤ (domain.filter fun x => + (Polynomial.ofFn k (u j)).eval x = (Polynomial.ofFn k (v j)).eval x).card := + Finset.card_le_card fun x hx => Finset.mem_filter.mpr + ⟨(Finset.mem_filter.mp hx).1, congrFun (Finset.mem_filter.mp hx).2 j⟩ + _ ≤ k - 1 := Soundness.evaluation_agreement domain _ _ hp (k - 1) + (Nat.le_pred_of_lt (Polynomial.ofFn_natDegree_lt hk _)) + (Nat.le_pred_of_lt (Polynomial.ofFn_natDegree_lt hk _)) + +theorem interleaved_domain_agreement {lanes k : ℕ} (domain : Finset F) + (u v : Fin lanes → Fin k → F) (hne : u ≠ v) (hk : 0 < k) : + agreement (fun x : ↥domain => interleavedEncode u x) + (fun x : ↥domain => interleavedEncode v x) ≤ k - 1 := by + classical + have hc : agreement (fun x : ↥domain => interleavedEncode u x) + (fun x : ↥domain => interleavedEncode v x) = + (domain.filter fun x => interleavedEncode u x = interleavedEncode v x).card := by + simp only [agreement, Finset.card_filter] + exact (Finset.sum_subtype domain (fun _ => Iff.rfl) + (fun x => if interleavedEncode u x = interleavedEncode v x then 1 else 0)).symm + rw [hc] + exact interleaved_agreement domain u v hne hk + +/-- Finite interleaved RS candidate list, decoded to coefficient tables and fixed +solely by the committed oracle. Single-lane RS is `lanes = 1`. -/ +theorem interleaved_candidates_card [Fintype F] {lanes k : ℕ} + (domain : Finset F) (oracle : ↥domain → Fin lanes → F) (t : ℕ) + (hk : 0 < k) (hd : k - 1 ≤ domain.card) + (threshold : (domain.card : ℚ) * (k - 1 : ℕ) < (t : ℚ)^2) : + ((candidates (fun v : Fin lanes → Fin k → F => + fun x : ↥domain => interleavedEncode v x) oracle t).card : ℚ) ≤ + (domain.card * (domain.card - (k - 1 : ℕ) : ℚ)) / + ((t : ℚ)^2 - domain.card * (k - 1 : ℕ)) := by + classical + simpa using candidates_card + (fun v : Fin lanes → Fin k → F => fun x : ↥domain => interleavedEncode v x) + oracle t (k - 1) (by simpa using hd) + (fun u v hne => interleaved_domain_agreement domain u v hne hk) + (by simpa using threshold) + +end ReedSolomon + +end Whir.CodingBounds diff --git a/verification/whir/Whir/Concrete.lean b/verification/whir/Whir/Concrete.lean index 16fa3e812..cbefcca70 100644 --- a/verification/whir/Whir/Concrete.lean +++ b/verification/whir/Whir/Concrete.lean @@ -141,9 +141,13 @@ def encodeExt (message : Array E) (logN foldK rate : Nat) : Array (Array E) := (tab (2^n) fun j => message[j*lanes+lane]!) tab (2^(n+rate)) fun q => tab lanes fun lane => codes[lane]![q]! +/-- Executable weighted column combination, retaining default indexing on malformed inputs. -/ +def inducedColumns {R : Type u} [Zero R] [Add R] [Mul R] [Inhabited R] + (width : Nat) (cols : Array (Array R)) (weights : Array R) : Array R := + tab width fun j => (tab cols.size fun i => weights[i]! * cols[i]![j]!).foldl (· + ·) 0 + def induced (n : Nat) (queries : Array Nat) (weights : Array E) : Array E := - let cols := queries.map (column n) - tab (2^n) fun j => (tab queries.size fun i => weights[i]! * cols[i]![j]!).foldl (· + ·) E.zero + inducedColumns (2^n) (queries.map (column n)) weights def inducedAt (n : Nat) (queries : Array Nat) (weights point : Array E) : E := Id.run do let mut out := E.zero diff --git a/verification/whir/Whir/ConcreteCandidates.lean b/verification/whir/Whir/ConcreteCandidates.lean new file mode 100644 index 000000000..2995cda18 --- /dev/null +++ b/verification/whir/Whir/ConcreteCandidates.lean @@ -0,0 +1,135 @@ +import Whir.CandidateFolding +import Whir.ParameterBounds + +/-! Actual novel-coefficient candidate lists satisfy the production Johnson +list cap for every lane count. Distinct matrices differ in some lane, so full +column agreement has the row-code distance, without a lane-count factor. -/ +namespace Whir.ConcreteCandidates +open Whir.Concrete Whir.CandidateFolding + +private theorem agreement_le_coordinate {I R F : Type*} [Fintype I] + (u v : I → R → F) (lane : R) : + CodingBounds.agreement u v ≤ + CodingBounds.agreement (fun i => u i lane) (fun i => v i lane) := by + classical + apply Finset.card_le_card + intro i hi + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, congrFun (Finset.mem_filter.mp hi).2 lane⟩ + +private theorem arrayCandidates_card_le {F I : Type*} [Field F] [Fintype F] + (top : Bool) {k lanes : ℕ} (enc : (Fin k → F) →ₗ[F] (I → F)) + (oracle : Fin lanes → I → F) (threshold : ℕ) : + (arrayCandidates top enc oracle threshold).card ≤ + (CandidateFolding.candidates enc oracle threshold).card := by + classical + exact Finset.card_image_le + +/-- Same-set existential agreement equals the ordinary column-vector agreement +count; this identification concerns fixed lists, not the MCA exceptional event. -/ +theorem candidates_eq_codingCandidates {F I : Type*} [Field F] [Fintype F] [Fintype I] + {k lanes : ℕ} (enc : (Fin k → F) →ₗ[F] (I → F)) + (oracle : Fin lanes → I → F) (threshold : ℕ) : + CandidateFolding.candidates enc oracle threshold = + CodingBounds.candidates (fun table i lane => enc (table lane) i) + (fun i lane => oracle lane i) threshold := by + classical + ext table + rw [CandidateFolding.mem_candidates] + simp only [CodingBounds.candidates, Finset.mem_filter, Finset.mem_univ, true_and, + CodingBounds.agreement] + constructor + · rintro ⟨T, hT, hagree⟩ + apply hT.trans + apply Finset.card_le_card + intro i hi + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, funext fun lane => hagree lane i hi⟩ + · intro hcount + refine ⟨_, hcount, ?_⟩ + intro lane i hi + exact congrFun (Finset.mem_filter.mp hi).2 lane + +/-- No abstract encoding map replaces the actual dense array encoder. -/ +theorem concreteEncoder_ofFn (n rate : ℕ) (a : Fin (2^n) → E) + (q : Fin (2^(n+rate))) : + concreteEncoder n rate a q = (encode n rate (Array.ofFn a))[q.val]! := by + have h := AdditiveCode.concrete_encode_eval n rate (Array.ofFn a) (by simp) q.val q.isLt + simpa [AdditiveCode.concretePolynomial, AdditiveCode.arrayPolynomial, + AdditiveCode.concreteBaseRepresentation, QueryRefinement.concreteRepresentation, + concreteEncoder, novelEncoder] using h.symm + +/-- The complete matrix code inherits the distance of any differing row. -/ +theorem concrete_interleaved_agreement (n rate : ℕ) (depth : n+rate ≤ 64) + {lanes : ℕ} (u v : Fin lanes → Fin (2^n) → E) (hne : u ≠ v) : + CodingBounds.agreement (fun q lane => concreteEncoder n rate (u lane) q) + (fun q lane => concreteEncoder n rate (v lane) q) ≤ 2^n-1 := by + classical + obtain ⟨lane, hlane⟩ := Function.ne_iff.mp hne + have harray : Array.ofFn (u lane) ≠ Array.ofFn (v lane) := by + intro heq + apply hlane + funext j + have hj := congrArg (fun a : Array E => a[j.val]!) heq + simpa using hj + have hrow := AdditiveCode.concrete_encode_agreement_bound n rate depth + (Array.ofFn (u lane)) (Array.ofFn (v lane)) (by simp) (by simp) harray + have hcard : CodingBounds.agreement (concreteEncoder n rate (u lane)) + (concreteEncoder n rate (v lane)) = + ((Finset.range (2^(n+rate))).filter fun q => + (encode n rate (Array.ofFn (u lane)))[q]! = + (encode n rate (Array.ofFn (v lane)))[q]!).card := by + simp only [CodingBounds.agreement, concreteEncoder_ofFn, Finset.card_filter, + Finset.sum_range] + exact (agreement_le_coordinate _ _ lane).trans (hcard.trans_le hrow) + +/-- Actual arrays have at most as many candidates as their coefficient tables. -/ +theorem concrete_arrayCandidates_card (top : Bool) (n rate threshold : ℕ) + (depth : n+rate ≤ 64) {lanes : ℕ} + (oracle : Fin lanes → Fin (2^(n+rate)) → E) + (hd : 2^n-1 ≤ 2^(n+rate)) + (hthreshold : ((2^(n+rate) : ℕ) : ℚ) * (2^n-1 : ℕ) < (threshold : ℚ)^2) : + ((arrayCandidates top (concreteEncoder n rate) oracle threshold).card : ℚ) ≤ + (((2^(n+rate) : ℕ) : ℚ) * (((2^(n+rate) : ℕ) : ℚ) - (2^n-1 : ℕ))) / + ((threshold : ℚ)^2 - ((2^(n+rate) : ℕ) : ℚ) * (2^n-1 : ℕ)) := by + classical + apply le_trans (Nat.cast_le.mpr + (arrayCandidates_card_le top (concreteEncoder n rate) oracle threshold)) + rw [candidates_eq_codingCandidates] + simpa only [Fintype.card_fin] using CodingBounds.candidates_card + (fun (table : Fin lanes → Fin (2^n) → E) q lane => + concreteEncoder n rate (table lane) q) + (fun q lane => oracle lane q) threshold (2^n-1) (by simpa using hd) + (fun u v huv => concrete_interleaved_agreement n rate depth u v huv) + (by simpa using hthreshold) + +/-- The actual configured candidate list cap, for every oracle, layout and +remaining lane count. Neither a list-size nor an encoder-correctness assumption +is supplied: the production certificate and executable encoder prove both. -/ +theorem production_arrayCandidates_card (top : Bool) (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) {lanes : ℕ} + (oracle : Fin lanes → Fin (ParameterBounds.length (ParameterBounds.config p) i) → E) : + (arrayCandidates top + (concreteEncoder (CausalGame.remaining (ParameterBounds.config p) i) + (ParameterBounds.config p).rates[i.val]!) oracle + (ParameterBounds.threshold (ParameterBounds.config p) i)).card ≤ 2^32 := by + obtain ⟨hd, hdn, hn, hr, hu, hup, ha, ha1, hgap, hq⟩ := + ParameterBounds.production_level_facts p i + have hexp : CausalGame.remaining (ParameterBounds.config p) i + + (ParameterBounds.config p).rates[i.val]! ≤ 26 := by + apply (pow_le_pow_iff_right₀ (by decide : (1:ℕ) < 2)).mp + exact hn + have hnum := JohnsonListNumerics.johnson_bound_le_two_pow32 + (ParameterBounds.length (ParameterBounds.config p) i) + (ParameterBounds.dimension (ParameterBounds.config p) i - 1) + (ParameterBounds.threshold (ParameterBounds.config p) i) (by omega) + (ParameterBounds.rho (ParameterBounds.config p) i) + (ParameterBounds.alpha (ParameterBounds.config p).rates[i.val]!) + rfl hr ha.le hgap (Nat.le_ceil _) + have hlist := concrete_arrayCandidates_card top + (CausalGame.remaining (ParameterBounds.config p) i) + (ParameterBounds.config p).rates[i.val]! + (ParameterBounds.threshold (ParameterBounds.config p) i) + (by omega) oracle (by exact hdn.le) hnum.1 + have hfinal := hlist.trans hnum.2 + exact_mod_cast hfinal + +end Whir.ConcreteCandidates diff --git a/verification/whir/Whir/DuplexCompression.lean b/verification/whir/Whir/DuplexCompression.lean new file mode 100644 index 000000000..ae5c63b7a --- /dev/null +++ b/verification/whir/Whir/DuplexCompression.lean @@ -0,0 +1,212 @@ +import Whir.DuplexRefinement + +/-! Executable BLAKE2s compression, hand-ported from RFC 7693 and the pinned +#552 `crates/primitives/src/hash/mod.rs`. Equality to machine-compiled Rust is +not claimed; known-answer and cross-language traces exercise this evaluator. -/ +namespace Whir.DuplexCompression +open FiatShamirGame DuplexRefinement + +def primitiveSourceSHA256 : String := + "8c8cb68504ed8552bb6e3b9e09efbfd493522c61120ce9d04a0cc1992e20150c" + +def ivWords : Array UInt32 := + #[0x6A09E667, 0xBB67AE85, 0x3C6EF372, 0xA54FF53A, + 0x510E527F, 0x9B05688C, 0x1F83D9AB, 0x5BE0CD19] + +def sigma : Array (Array Nat) := #[ + #[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15], + #[14,10,4,8,9,15,13,6,1,12,0,2,11,7,5,3], + #[11,8,12,0,5,2,15,13,10,14,3,6,7,1,9,4], + #[7,9,3,1,13,12,11,14,2,6,5,10,4,0,15,8], + #[9,0,5,7,2,4,10,15,14,1,11,12,6,8,3,13], + #[2,12,6,10,0,11,8,3,4,13,7,5,15,14,1,9], + #[12,5,1,15,14,13,4,10,0,7,6,3,9,2,8,11], + #[13,11,7,14,12,1,3,9,5,0,15,4,8,6,2,10], + #[6,15,14,9,11,3,0,8,12,2,13,7,1,4,10,5], + #[10,2,8,4,7,6,1,5,15,11,9,14,3,12,13,0]] + +def lanes : Array (Nat × Nat × Nat × Nat) := + #[(0,4,8,12),(1,5,9,13),(2,6,10,14),(3,7,11,15), + (0,5,10,15),(1,6,11,12),(2,7,8,13),(3,4,9,14)] + +def rotate (x : UInt32) (n : UInt32) : UInt32 := (x >>> n) ||| (x <<< (32 - n)) + +def mix (v : Array UInt32) (a b c d : Nat) (x y : UInt32) : Array UInt32 := Id.run do + let mut v := v + v := v.set! a (v[a]! + v[b]! + x) + v := v.set! d (rotate (v[d]! ^^^ v[a]!) 16) + v := v.set! c (v[c]! + v[d]!) + v := v.set! b (rotate (v[b]! ^^^ v[c]!) 12) + v := v.set! a (v[a]! + v[b]! + y) + v := v.set! d (rotate (v[d]! ^^^ v[a]!) 8) + v := v.set! c (v[c]! + v[d]!) + v := v.set! b (rotate (v[b]! ^^^ v[c]!) 7) + return v + +def word {n : Nat} (bytes : Fin n → Byte) (i : Nat) : UInt32 := + (List.range 4).foldl (fun acc j => + if h : 4*i+j < n then acc ||| ((UInt32.ofNat (bytes ⟨4*i+j,h⟩).val) <<< UInt32.ofNat (8*j)) + else acc) 0 + +def digest (ws : Array UInt32) : Digest32 := fun i => + ⟨((ws[i.val / 4]!.toNat / 256^(i.val % 4)) % 256), Nat.mod_lt _ (by decide)⟩ + +def parameterIV : Digest32 := digest (ivWords.set! 0 (ivWords[0]! ^^^ 0x01010020)) + +def compress : Compression := fun h block counter last => Id.run do + let hw := (Array.range 8).map (word h) + let m := (Array.range 16).map (word block) + let mut v := hw ++ ivWords + v := v.set! 12 (v[12]! ^^^ counter.toUInt32) + v := v.set! 13 (v[13]! ^^^ (counter >>> 32).toUInt32) + if last then v := v.set! 14 (~~~v[14]!) + for schedule in sigma do + for g in [0:8] do + let (a,b,c,d) := lanes[g]! + v := mix v a b c d m[schedule[2*g]!]! m[schedule[2*g+1]!]! + return digest ((Array.range 8).map fun i => hw[i]! ^^^ v[i]! ^^^ v[i+8]!) + +/-- Ordinary one-block BLAKE2s-256 (inputs of length at most 64). -/ +def hashBlock (bytes : Array Byte) : Digest32 := + compress parameterIV (padded bytes) (UInt64.ofNat bytes.size) true + +/-- Ordinary BLAKE2s PoW test; not a claimed soundness amplification. -/ +def powOK (base : Digest32) (nonce : Scalar24) (bits : Nat) : Bool := + let bs := List.ofFn base ++ List.ofFn nonce ++ littleWord 0x31574f502d534646 + let d := hashBlock bs.toArray + let low := ByteCodec.decodeNat 8 (fun i => d ⟨i.val, by omega⟩) + low % 2^bits == 0 + +def hex (bs : List Byte) : String := + String.ofList (bs.flatMap fun b => + let digits := "0123456789abcdef".toList.toArray + [digits[b.val / 16]!, digits[b.val % 16]!]) + +/-- RFC 7693 BLAKE2s-256 known-answer vectors, evaluated by the executable +compression (not native_decide and not an assumed oracle). -/ +def knownAnswers : Bool := + hex (List.ofFn (hashBlock #[])) == "69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9" && + hex (List.ofFn (hashBlock #[97,98,99])) == "508c5e8c327c14e2e1a72ba34eeb452f37458b209ed63a294d999b4c86675982" + +/-- Observable snapshot used by the source-pinned external Rust differential +probe: CV, active pending bytes, first flag, prior cursor, consumed cursor, +cached output block, nonmutating commitment. -/ +def snapshot (label : String) (s : State) : String := + label ++ "|" ++ hex (List.ofFn s.cv) ++ "|" ++ hex s.pending.toList ++ "|" ++ + toString s.first ++ "|" ++ toString s.previous ++ "|" ++ toString s.consumed ++ "|" ++ + hex (List.ofFn s.output) ++ "|" ++ hex (List.ofFn (commitment compress s)) + +def traceDraw (label : String) (s : State) (n : Nat) : State × List String := + match squeeze compress s n with + | .error e => (s, [label ++ ":error:" ++ reprStr e]) + | .ok (t, bs) => (t, [label ++ ":" ++ hex bs, snapshot label t]) + +def traceNonce (label : String) (s : State) (nonce : Concrete.E) (bits : Nat) : State × List String := + match verifyNonce compress powOK s (ByteCodec.encodeE nonce) bits with + | .error e => (s, [label ++ ":error:" ++ reprStr e]) + | .ok (t, ok) => (t, [label ++ ":" ++ toString ok, snapshot label t]) + +/-- The same scenario was executed against the original pinned Rust source in +an external harness. The error-limit injection is harness-only, not an API. -/ +def differentialTrace : List String := Id.run do + let d : Digest32 := fun i => (wordsBlock [1,2,3,4]) ⟨i.val, by omega⟩ + let st : Digest32 := fun i => (wordsBlock [5,6,7,8]) ⟨i.val, by omega⟩ + let mut s := seed compress parameterIV d st + let mut out := [snapshot "seed" s, snapshot "empty" (absorb compress s [])] + s := absorb compress s ((List.range 64).map fun n => ⟨n % 256, Nat.mod_lt _ (by decide)⟩) + out := out ++ [snapshot "held64" s] + let held := traceDraw "held-final" s 3 + out := out ++ held.2 + s := absorb compress s [64] + out := out ++ [snapshot "continued65" s] + let p := traceDraw "partial3" s 3 + s := p.1 + out := out ++ p.2 + let clone := traceDraw "clone29" s 29 + out := out ++ clone.2 ++ (traceDraw "clone-next5" clone.1 5).2 + s := absorb compress s [201,202] + out := out ++ [snapshot "switch-after3" s] + let p := traceDraw "switch-out" s 35 + s := p.1 + out := out ++ p.2 + let p := traceNonce "nonce-zero" s ⟨1,2,3⟩ 0 + s := p.1 + out := out ++ p.2 + let p := traceNonce "nonce-one" s ⟨4,5,6⟩ 1 + s := p.1 + out := out ++ p.2 + let p := traceDraw "nonce-out" s 24 + s := p.1 + out := out ++ p.2 + let bitsBad := match verifyNonce compress powOK s (fun _ => 0) 64 with + | .error .grindingBits => true | _ => false + s := { s with consumed := maxCursor - 1 } + let cursorBad := match squeeze compress s 2 with + | .error .cursorExhausted => true | _ => false + let vectorBad := match squeeze compress s 24 with + | .error .cursorExhausted => true | _ => false + return out ++ ["bits-limit:" ++ toString bitsBad, "cursor-limit:" ++ toString cursorBad, + "vector-limit:" ++ toString vectorBad, "pow-base:" ++ hex (List.ofFn (powBase compress s 63))] + +/-- Observed verbatim from the pinned Rust source in an external Rust 1.97 +harness. Fixtures retain state as well as challenges and all export families. +The source's private cursor was changed only in that external harness to +exercise exhaustion without allocating 2^49 bytes. -/ +def rustTraceFixture : List String := [ + "seed|f9b7641c1107505a7dc29b6e2f6d5419d81aa6e3db1582d0d3a980dad6c9aa88||true|0|0|0000000000000000000000000000000000000000000000000000000000000000|4243e176df0d5a88b09ce8f6459d98d7f4b289f646b6bb41a6cc73ff323d4fb0", + "empty|f9b7641c1107505a7dc29b6e2f6d5419d81aa6e3db1582d0d3a980dad6c9aa88||true|0|0|0000000000000000000000000000000000000000000000000000000000000000|4243e176df0d5a88b09ce8f6459d98d7f4b289f646b6bb41a6cc73ff323d4fb0", + "held64|f9b7641c1107505a7dc29b6e2f6d5419d81aa6e3db1582d0d3a980dad6c9aa88|000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f|true|0|0|0000000000000000000000000000000000000000000000000000000000000000|3fe42619bf69ded577ed52a1dcf47f4ca81ad8c6ad69b412610257628383db8f", + "held-final:aa39f5", + "held-final|b3847dfdbba2659c2082c59641ed04122ccbd7403be2c94ac26de99d268ecc6b||true|0|3|aa39f5e2c2dee165c4301949e5c312dd571e1b56a3684e47391b257d89b3eab3|bbf57ef6abbf095ed11df18ee51f2048f39db2b31b2c622c6982210dca674f76", + "continued65|8918b3e8cf02981bb37faa42fd12a5344cb797984ca296d661cd6e2fdc73e922|40|false|0|0|0000000000000000000000000000000000000000000000000000000000000000|3c9d937dd79de7002235489eb991cc8fc239dcc4c2e93363b89c52aa3548db03", + "partial3:4b1c12", + "partial3|a1c6ea7ab811e887a75ac5a3093d430cb183e0f915a89c84c47234760bc915f4||true|0|3|4b1c1262a749750dbd6a94310607e3efadd9bca951ed52bc43a14f49573e47db|99f4dcf23768253b283078549d20e0ecaa5291e391d244484e004032e82217ab", + "clone29:62a749750dbd6a94310607e3efadd9bca951ed52bc43a14f49573e47db", + "clone29|a1c6ea7ab811e887a75ac5a3093d430cb183e0f915a89c84c47234760bc915f4||true|0|32|4b1c1262a749750dbd6a94310607e3efadd9bca951ed52bc43a14f49573e47db|398daa7b0892b7371b3ebb4a69ebe463028dc61c28a59c47c34ad413faf6b88f", + "clone-next5:fdbfbedf61", + "clone-next5|a1c6ea7ab811e887a75ac5a3093d430cb183e0f915a89c84c47234760bc915f4||true|0|37|fdbfbedf613888be548d62f49e4bb7f16f2c8994c34519fab7a4876b661037f7|3058d92de67869758f1c21ea5f1e45a4911a10cb921c1449d4db52cfb1fe60cf", + "switch-after3|a1c6ea7ab811e887a75ac5a3093d430cb183e0f915a89c84c47234760bc915f4|c9ca|true|3|0|4b1c1262a749750dbd6a94310607e3efadd9bca951ed52bc43a14f49573e47db|a7419fc1a361d104e33d71e4cd22e0dee502d30e7f7152de78d74d6ddd1f4744", + "switch-out:f76b7e535e58b7d79561247790580736a4c51ea1f0100e85c8e3b32dbe5e3d30c69cab", + "switch-out|c7cedd71b8626817650cb469d6413991078483cdd972eb880c85013f54888fe9||true|0|35|c69cab915ec6fc162f0cf1421edabdfbf949798238daa1f89196808eec7eb0d2|730c83f9945acc52f98f5d3ef3c2c5b5087e438f6a1f65e763a0ef676ef33d92", + "nonce-zero:false", + "nonce-zero|279f961dcab6a188c6639ecc9089dfcdf18bd032c0afcb35fdd1079274e84be5||true|0|0|c69cab915ec6fc162f0cf1421edabdfbf949798238daa1f89196808eec7eb0d2|d20b6d5da7cec21b26a8984945210db60552a526f864d48cd5aa3f03caa080ba", + "nonce-one:true", + "nonce-one|20b039e7908ab97ddf2ea9dca086f3a4a3fc78f1778cf367597594910a24506c||true|0|0|c69cab915ec6fc162f0cf1421edabdfbf949798238daa1f89196808eec7eb0d2|427e62417ffdeb3b15e5fc9b15b40951f83003fd704b0c33b4641d26f88e42f8", + "nonce-out:e30163f8a9ba146e7cd0dd0e3d6da1d9d7b867dd43e8cccd", + "nonce-out|20b039e7908ab97ddf2ea9dca086f3a4a3fc78f1778cf367597594910a24506c||true|0|24|e30163f8a9ba146e7cd0dd0e3d6da1d9d7b867dd43e8cccdeb53ee7acc5b1d67|8e331280b224acf3b4f68ddd86e5f0f1345b1fafada4e60c02b6f07fb45cc418", + "bits-limit:true", "cursor-limit:true", "vector-limit:true", + "pow-base:6cf65dfb60d1c8a81f229ce0a191d0d1479429ee015618b1b74d3d2259a85271"] + +def differentialMatches : Bool := differentialTrace == rustTraceFixture + +def apiTrace : List String := Id.run do + let d : Digest32 := fun i => (wordsBlock [1,2,3,4]) ⟨i.val, by omega⟩ + let st : Digest32 := fun i => (wordsBlock [5,6,7,8]) ⟨i.val, by omega⟩ + let s := observe compress (seed compress parameterIV d st) ⟨9,10,11⟩ + let .ok (s,n) := grind compress powOK s 3 | return ["api-grind3:error"] + let mut out := ["api-grind3:" ++ toString n, snapshot "api-grind3" s] + let .ok (s,xs) := sampleVec compress s 3 | return ["api-vector:error"] + out := out ++ ["api-vector:" ++ hex (xs.flatMap (fun x => List.ofFn (ByteCodec.encodeE x))), + snapshot "api-vector" s] + let .ok (s,n) := grind compress powOK s 0 | return ["api-grind0:error"] + out := out ++ ["api-grind0:" ++ toString n, snapshot "api-grind0" s] + for (first,last,len,previous) in + [(true,false,63,0),(false,true,1,1),(true,true,0,0),(true,true,65,0),(true,true,64,2^49)] do + let rejected := match checkedAbsorbTweak first last len previous with + | .error _ => true | .ok _ => false + out := out ++ ["api-tweak-reject:" ++ toString rejected] + return out ++ ["api-tweak-boundary:" ++ toString (absorbTweak true true 64 maxCursor)] + +def rustApiFixture : List String := [ + "api-grind3:1", + "api-grind3|d6d61dc3f4a842892b2d816deaf911c1ff44896b6a0893bab457d4435f6146f5||true|0|0|0000000000000000000000000000000000000000000000000000000000000000|80990a0f41fdb6fa0c86c237dc3d21029a9011f4f7d3a1cdc2e25cc32e15c293", + "api-vector:0989abe44a783a912d29a169e0b83f808b2d6cd8cc0c1652bd9ff61b30484260b76e9f6d1b25b94db5ab2334186c9efea849323576c2aab71ddf33f809ff4a39aae0c1255b4bb2d8", + "api-vector|d6d61dc3f4a842892b2d816deaf911c1ff44896b6a0893bab457d4435f6146f5||true|0|72|aae0c1255b4bb2d82f916cf475ad0716c8e25aaf516026a43603cb36c96d56bf|be23b5805506586077b6ef9e4d006c1067d2218bb51670f2fcc2edfed1ec8220", + "api-grind0:0", + "api-grind0|143b9f06ddb8b4cc02a1723a20943ff29da1cf1341ed18eb41dcb28e28ba8024||true|0|0|aae0c1255b4bb2d82f916cf475ad0716c8e25aaf516026a43603cb36c96d56bf|86c2ecb55c84fe50bbfac2b939c219472682b55c7b375e9ee88a81565dd9d79d", + "api-tweak-reject:true", "api-tweak-reject:true", "api-tweak-reject:true", + "api-tweak-reject:true", "api-tweak-reject:true", "api-tweak-boundary:324822123124097023"] + +def apiMatches : Bool := apiTrace == rustApiFixture + +end Whir.DuplexCompression diff --git a/verification/whir/Whir/DuplexEncoding.lean b/verification/whir/Whir/DuplexEncoding.lean new file mode 100644 index 000000000..7ab6b41f4 --- /dev/null +++ b/verification/whir/Whir/DuplexEncoding.lean @@ -0,0 +1,359 @@ +import Whir.DuplexRefinement + +/-! Exact syntactic encoding of the normalized #552 framed-byte history. +Observe call boundaries and empty calls are absent from `Frame`; nonempty runs +are separated only by an actual squeeze or nonce event. No compression function +or collision assumption occurs in this codec. -/ +namespace Whir.DuplexEncoding +open FiatShamirGame DuplexRefinement + +abbrev Instruction := Block64 × UInt64 + +def chunk (first last : Bool) (previous : Nat) (bytes : List Byte) : Instruction := + (padded bytes.toArray, absorbTweak first last bytes.length previous) + +/-- Retain a full block until another byte proves it nonfinal. -/ +def chunks (first : Bool) (previous : Nat) (pending : List Byte) : List Byte → List Instruction + | [] => if pending = [] then [] else [chunk first true previous pending] + | b :: bs => + if pending.length = 64 then + chunk first false previous pending :: chunks false 0 [b] bs + else chunks first previous (pending ++ [b]) bs + +def framePlan : Frame → List Instruction + | .absorb previous bytes => chunks true previous [] bytes + | .nonce previous bits nonce => [(nonceBlock nonce previous bits, UInt64.ofNat (9 * 2^56))] + +def terminalPlan : Terminal → Instruction + | .output block => (wordsBlock [block], UInt64.ofNat (6 * 2^56)) + | .commitment consumed => (wordsBlock [consumed], UInt64.ofNat (7 * 2^56)) + | .powBase consumed bits => (wordsBlock [consumed,bits], UInt64.ofNat (8 * 2^56)) + +/-- Chronological public-compression inputs. The parameter IV is fixed externally, +not a selectable field in the semantic history. Every compression final flag is true. -/ +def plan (q : Coordinate) : List Instruction := + (ByteCodec.pairBytes (q.history.domain,q.history.statement), UInt64.ofNat (2^56)) :: + q.history.frames.flatMap framePlan ++ [terminalPlan q.terminal] + +def FrameValid : Frame → Prop + | .absorb previous bytes => previous < 2^49 ∧ bytes ≠ [] + | .nonce previous bits _ => previous < 2^49 ∧ bits ≤ 63 + +def TerminalValid : Terminal → Prop + | .output block => block < 2^44 + | .commitment consumed => consumed < 2^49 + | .powBase consumed bits => consumed < 2^49 ∧ bits ≤ 63 + +/-- A syntactic superdomain of reachable normalized histories: no empty ordinary +frame, bounded cursors/difficulties, and a bounded output block. Actual source +reachability may restrict it further without weakening the injection theorem. -/ +def Admissible (q : Coordinate) : Prop := + (∀ f ∈ q.history.frames, FrameValid f) ∧ TerminalValid q.terminal + +def blockBytes (b : Block64) : List Byte := List.ofFn b + +def takeBytes (b : Block64) (n : Nat) : List Byte := (blockBytes b).take n + +def wordAt (b : Block64) (offset : Nat) : Nat := + ByteCodec.decodeNat 8 (fun i => ((blockBytes b)[offset + i.val]?).getD 0) + +def readRole (t : UInt64) : Nat := t.toNat / 2^56 +def readLength (t : UInt64) : Nat := t.toNat / 2^49 % 128 +def readPrevious (t : UInt64) : Nat := t.toNat % 2^49 + +/-- Read one ordinary run. Its continuation cursor is always zero. -/ +def readRun (first : Bool) : List Instruction → Option (Nat × List Byte × List Instruction) + | [] => none + | (b,t) :: rest => + if readRole t = role first true then + some (readPrevious t, takeBytes b (readLength t), rest) + else if readRole t = role first false then + match readRun false rest with + | some (_, bytes, tail) => some (readPrevious t, takeBytes b (readLength t) ++ bytes, tail) + | none => none + else none + +theorem readRun_shorter (first : Bool) (xs : List Instruction) (p : Nat) (bs : List Byte) + (tail : List Instruction) (h : readRun first xs = some (p,bs,tail)) : + tail.length < xs.length := by + induction xs generalizing first p bs tail with + | nil => simp [readRun] at h + | cons x xs ih => + rcases x with ⟨b,t⟩ + simp only [readRun] at h + split at h + · cases h; simp + · split at h + · split at h + · cases h + have := ih _ _ _ _ (by assumption) + simp only [List.length_cons]; omega + · cases h + · cases h + +/-- The raw parser is deliberately permissive about padding. `decode` below +rejects every noncanonical encoding by checking the reconstructed exact plan. -/ +def readBody : List Instruction → Option (List Frame × Terminal) + | [] => none + | [(b,t)] => + if readRole t = 6 then some ([], .output (wordAt b 0)) + else if readRole t = 7 then some ([], .commitment (wordAt b 0)) + else if readRole t = 8 then some ([], .powBase (wordAt b 0) (wordAt b 8)) + else none + | (b,t) :: next :: rest => + if readRole t = 9 then + match readBody (next :: rest) with + | some (fs, terminal) => some (.nonce (wordAt b 24) (wordAt b 32) + (fun i => b ⟨i.val, by omega⟩) :: fs, terminal) + | none => none + else + match h : readRun true ((b,t) :: next :: rest) with + | some (previous, bytes, tail) => + match readBody tail with + | some (fs, terminal) => some (.absorb previous bytes :: fs, terminal) + | none => none + | none => none +termination_by xs => xs.length + +decreasing_by + · simp_wf + · have hs := readRun_shorter true _ _ _ _ h + simp_all only [List.length_cons] +def parse : List Instruction → Option Coordinate + | [] => none + | (b,t) :: rest => + if readRole t = 1 then + match readBody rest with + | some (fs, terminal) => some ⟨⟨(fun i => b ⟨i.val, by omega⟩), + (fun i => b ⟨i.val + 32, by omega⟩), fs⟩, terminal⟩ + | none => none + else none + +instance (f : Frame) : Decidable (FrameValid f) := by cases f <;> unfold FrameValid <;> infer_instance +instance (t : Terminal) : Decidable (TerminalValid t) := by cases t <;> unfold TerminalValid <;> infer_instance +instance (q : Coordinate) : Decidable (Admissible q) := inferInstanceAs (Decidable (_ ∧ _)) + +def decode (xs : List Instruction) : Option Coordinate := + match parse xs with + | none => none + | some q => if Admissible q ∧ plan q = xs then some q else none + + theorem decode_sound {xs : List Instruction} {q : Coordinate} (h : decode xs = some q) : + Admissible q ∧ plan q = xs := by + unfold decode at h + split at h + · cases h + · split at h + · cases h; assumption + · cases h + +theorem packed_fields (first last : Bool) (len previous : Nat) + (hl : len ≤ 64) (hp : previous < 2^49) : + readRole (absorbTweak first last len previous) = role first last ∧ + readLength (absorbTweak first last len previous) = len ∧ + readPrevious (absorbTweak first last len previous) = previous := by + have hr : role first last < 256 := by cases first <;> cases last <;> decide + simp only [readRole, readLength, readPrevious, absorbTweak, UInt64.toNat_ofNat', packTweak] + omega + +theorem takeBytes_padded (bs : List Byte) (h : bs.length ≤ 64) : + takeBytes (padded bs.toArray) bs.length = bs := by + apply List.ext_getElem + · simp [takeBytes, blockBytes, Nat.min_eq_left h] + · intro i hi hi' + simp only [takeBytes, blockBytes, List.getElem_take, List.getElem_ofFn, padded] + simp [hi'] + +theorem wordAt_padded (bs : List Byte) (offset : Nat) (h : offset + 8 ≤ 64) : + wordAt (padded bs.toArray) offset = + ByteCodec.decodeNat 8 (fun i => (bs[offset + i.val]?).getD 0) := by + unfold wordAt + congr 1 + funext i + have hi : offset + i.val < 64 := by omega + simp only [blockBytes, List.getElem?_ofFn, dite_eq_left hi, padded, Option.getD_some] + simp + +theorem readRun_chunks (first : Bool) (previous : Nat) (pending bs : List Byte) + (tail : List Instruction) (hp : previous < 2^49) + (hlen : pending.length ≤ 64) (hne : pending ++ bs ≠ []) : + readRun first (chunks first previous pending bs ++ tail) = + some (previous, pending ++ bs, tail) := by + induction bs generalizing first previous pending with + | nil => + have hn : pending ≠ [] := by simpa using hne + simp only [chunks, hn, ↓reduceIte, List.singleton_append, readRun, chunk] + rw [(packed_fields first true pending.length previous hlen hp).1] + simp only [↓reduceIte] + rw [(packed_fields first true pending.length previous hlen hp).2.1, + (packed_fields first true pending.length previous hlen hp).2.2, takeBytes_padded pending hlen] + simp + | cons b bs ih => + by_cases full : pending.length = 64 + · simp only [chunks, full, ↓reduceIte, List.cons_append, readRun, chunk] + rw [← full, (packed_fields first false pending.length previous hlen hp).1] + have roles : role first false ≠ role first true := by cases first <;> decide + simp only [roles, ↓reduceIte] + rw [ih false 0 [b] (by decide) (by simp) (by simp)] + rw [(packed_fields first false pending.length previous hlen hp).2.1, + (packed_fields first false pending.length previous hlen hp).2.2, + takeBytes_padded pending hlen] + rfl + · simp only [chunks, full, ↓reduceIte] + have hs : (pending ++ [b]).length ≤ 64 := by simp; omega + simpa only [List.append_assoc, List.singleton_append] using + ih first previous (pending ++ [b]) hp hs (by simp) + +theorem wordAt_segment (pre post : List Byte) (n : Nat) + (hoff : pre.length + 8 ≤ 64) (hn : n < 256^8) : + wordAt (padded (pre ++ littleWord n ++ post).toArray) pre.length = n := by + rw [wordAt_padded _ _ hoff] + have he : (fun i : Fin 8 => + ((pre ++ littleWord n ++ post)[pre.length + i.val]?).getD 0) = ByteCodec.encodeNat 8 n := by + funext i + have hi : i.val < (littleWord n).length := by simpa only [littleWord, List.length_ofFn] using i.isLt + rw [List.append_assoc, List.getElem?_append_right (by omega : pre.length ≤ pre.length + i.val), + Nat.add_sub_cancel_left, List.getElem?_append_left hi] + simp only [littleWord, List.getElem?_ofFn, dite_eq_left i.isLt, Option.getD_some] + rw [he, ByteCodec.decodeNat_encodeNat _ _ hn] + +theorem wordAt_words_one (n : Nat) (hn : n < 256^8) : + wordAt (wordsBlock [n]) 0 = n := by + exact wordAt_segment [] [] n (by decide) hn + +theorem wordAt_words_two_first (n m : Nat) (hn : n < 256^8) : + wordAt (wordsBlock [n,m]) 0 = n := by + exact wordAt_segment [] (littleWord m) n (by decide) hn + +theorem wordAt_words_two_second (n m : Nat) (hm : m < 256^8) : + wordAt (wordsBlock [n,m]) 8 = m := by + exact wordAt_segment (littleWord n) [] m (by simp [littleWord]) hm + +theorem wordAt_nonce_previous (nonce : Scalar24) (previous bits : Nat) (hp : previous < 256^8) : + wordAt (nonceBlock nonce previous bits) 24 = previous := by + exact wordAt_segment (List.ofFn nonce) (littleWord bits) previous (by simp) hp + +theorem wordAt_nonce_bits (nonce : Scalar24) (previous bits : Nat) (hb : bits < 256^8) : + wordAt (nonceBlock nonce previous bits) 32 = bits := by + exact wordAt_segment (List.ofFn nonce ++ littleWord previous) [] bits + (by simp [littleWord]) hb + +theorem nonce_prefix (nonce : Scalar24) (previous bits : Nat) : + (fun i : Fin 24 => nonceBlock nonce previous bits ⟨i.val, by omega⟩) = nonce := by + funext i + simp only [nonceBlock, padded, List.getElem?_toArray] + have hi : i.val < (List.ofFn nonce).length := by simp + simp only [List.append_assoc, List.getElem?_append_left hi, List.getElem?_ofFn, + dite_eq_left i.isLt, Option.getD_some] + +theorem terminal_recovery (t : Terminal) (ht : TerminalValid t) : + readBody [terminalPlan t] = some ([],t) := by + cases t with + | output n => + have hn : n < 256^8 := by dsimp [TerminalValid] at ht; omega + simp [readBody, terminalPlan, readRole, wordAt_words_one n hn] + | commitment n => + have hn : n < 256^8 := by dsimp [TerminalValid] at ht; omega + simp [readBody, terminalPlan, readRole, wordAt_words_one n hn] + | powBase n m => + have hn : n < 256^8 := by dsimp [TerminalValid] at ht; omega + have hm : m < 256^8 := by dsimp [TerminalValid] at ht; omega + simp [readBody, terminalPlan, readRole, wordAt_words_two_first n m hn, + wordAt_words_two_second n m hm] + +theorem readRun_not_nonce (b : Block64) (t : UInt64) (xs : List Instruction) + (p : Nat) (bs : List Byte) (tail : List Instruction) + (h : readRun true ((b,t) :: xs) = some (p,bs,tail)) : readRole t ≠ 9 := by + simp only [readRun] at h + split at h + · simp_all [role] + · split at h + · simp_all [role] + · cases h + +theorem readBody_run (xs : List Instruction) (p : Nat) (bs : List Byte) + (tail : List Instruction) (fs : List Frame) (t : Terminal) + (hr : readRun true xs = some (p,bs,tail)) (hn : tail ≠ []) + (hb : readBody tail = some (fs,t)) : + readBody xs = some (.absorb p bs :: fs,t) := by + have hl := readRun_shorter true xs p bs tail hr + cases xs with + | nil => simp [readRun] at hr + | cons x xs => + rcases x with ⟨b,tweak⟩ + cases xs with + | nil => + have ht : tail.length = 0 := by simpa using Nat.lt_one_iff.mp hl + exact False.elim (hn (List.length_eq_zero_iff.mp ht)) + | cons x xs => + have hrole := readRun_not_nonce b tweak (x :: xs) p bs tail hr + simp only [readBody, hrole, ↓reduceIte] + split + · rename_i p' bs' tail' he + have hparts := Option.some.inj (he.symm.trans hr) + obtain ⟨rfl, rfl, rfl⟩ := Prod.mk.inj hparts |>.imp_right Prod.mk.inj + simp only [hb] + · rename_i he + rw [hr] at he + cases he + +theorem frames_recovery (fs : List Frame) (t : Terminal) + (hf : ∀ f ∈ fs, FrameValid f) (ht : TerminalValid t) : + readBody (fs.flatMap framePlan ++ [terminalPlan t]) = some (fs,t) := by + induction fs with + | nil => exact terminal_recovery t ht + | cons f fs ih => + have hv := hf f (by simp) + have hb := ih (by intro f h; exact hf f (by simp [h])) + cases f with + | absorb p bs => + simp only [FrameValid] at hv + have hr := readRun_chunks true p [] bs + (fs.flatMap framePlan ++ [terminalPlan t]) hv.1 (by simp) (by simpa using hv.2) + simp only [List.nil_append] at hr + simpa only [List.flatMap_cons, framePlan, List.append_assoc] using + readBody_run _ p bs _ fs t hr (by simp) hb + | nonce p bits nonce => + simp only [FrameValid] at hv + have hp : p < 256^8 := by omega + have hbits : bits < 256^8 := by omega + have hn : fs.flatMap framePlan ++ [terminalPlan t] ≠ [] := by simp + generalize he : fs.flatMap framePlan ++ [terminalPlan t] = tail at * + cases tail with + | nil => contradiction + | cons x xs => + simp only [List.flatMap_cons, framePlan, List.cons_append, List.nil_append, he] + simp only [readBody, readRole, UInt64.toNat_ofNat', Nat.reducePow, Nat.reduceMul, + Nat.reduceMod, Nat.reduceDiv, ↓reduceIte, hb] + rw [wordAt_nonce_previous nonce p bits hp, wordAt_nonce_bits nonce p bits hbits, + nonce_prefix] + +theorem parse_plan (q : Coordinate) (h : Admissible q) : parse (plan q) = some q := by + rcases q with ⟨⟨domain,statement,fs⟩,t⟩ + have hb := frames_recovery fs t h.1 h.2 + simp only [plan, List.cons_append, parse, readRole, UInt64.toNat_ofNat', Nat.reducePow, Nat.reduceMod, + Nat.reduceDiv, ↓reduceIte, hb] + congr 3 + funext i + simp [ByteCodec.pairBytes, i.isLt] + +theorem decode_plan (q : Coordinate) (h : Admissible q) : decode (plan q) = some q := by + simp only [decode, parse_plan q h, h, and_self, ↓reduceIte] + +theorem plan_injective {a b : Coordinate} (ha : Admissible a) (hb : Admissible b) + (h : plan a = plan b) : a = b := by + have := congrArg decode h + simpa only [decode_plan a ha, decode_plan b hb, Option.some.injEq] using this + +/-- The accepted raw language is exactly the image of the explicit syntactic +domain, not a decoder-correctness hypothesis. In particular this rejects +nonzero padding, empty ordinary chunks, bad role/length combinations, nonzero +continuation cursors, and out-of-range semantic metadata. -/ +theorem decode_iff (xs : List Instruction) (q : Coordinate) : + decode xs = some q ↔ Admissible q ∧ plan q = xs := by + constructor + · exact decode_sound + · rintro ⟨h, rfl⟩ + exact decode_plan q h + +end Whir.DuplexEncoding diff --git a/verification/whir/Whir/DuplexFraming.lean b/verification/whir/Whir/DuplexFraming.lean new file mode 100644 index 000000000..10cf0aca7 --- /dev/null +++ b/verification/whir/Whir/DuplexFraming.lean @@ -0,0 +1,914 @@ +import Whir.DuplexRefinement +import Whir.DuplexEncoding + +/-! Structural DMV18 conditions for a public-compression *supermode* of #552. +Every node's whole 64-byte block is message data, including prescribed padding; +the tweak is template data. Restricting to canonical duplex blocks is permitted. +This avoids silently assuming a semantic frame encoder to be injective. Trees +are linear, root first, and all nonseed links occupy the complete CV field. +This module proves structural properties, not DMV's probabilistic theorem. -/ +namespace Whir.DuplexFraming +open FiatShamirGame DuplexRefinement + +/-- Actual public compression input, including adversarially chosen CVs. -/ +structure Node where + cv : Digest32 + block : Block64 + tweak : UInt64 + last : Bool + +def tag (n : Node) : Nat := n.tweak.toNat / 2^56 + +def isSeed (n : Node) : Prop := tag n = 1 ∧ n.last = true + +def isInternal (n : Node) : Prop := + (tag n = 2 ∨ tag n = 3 ∨ tag n = 4 ∨ tag n = 5 ∨ tag n = 9) ∧ n.last = true + +def isTerminal (n : Node) : Prop := + (tag n = 6 ∨ tag n = 7 ∨ tag n = 8) ∧ n.last = true + +instance (n : Node) : Decidable (isSeed n) := inferInstanceAs (Decidable (_ ∧ _)) +instance (n : Node) : Decidable (isInternal n) := inferInstanceAs (Decidable (_ ∧ _)) +instance (n : Node) : Decidable (isTerminal n) := inferInstanceAs (Decidable (_ ∧ _)) + +/-- Root-first body: internal nodes followed by exactly one seed. Chaining +positions are not inferred from message contents: they are always the CV field. -/ +inductive Body : List Node → Prop where + | seed {s} : isSeed s → Body [s] + | step {n ns} : isInternal n → Body ns → Body (n :: ns) + +def Complete (ns : List Node) : Prop := + ∃ t rest, ns = t :: rest ∧ isTerminal t ∧ Body rest + +/-- An efficient deterministic parser for complete bodies. -/ +def body? : List Node → Bool + | [] => false + | [s] => decide (isSeed s) + | n :: m :: rest => decide (isInternal n) && body? (m :: rest) + + theorem body?_correct (ns : List Node) : body? ns = true ↔ Body ns := by + induction ns with + | nil => simp [body?]; intro h; cases h + | cons n ns ih => + cases ns with + | nil => + simp only [body?, decide_eq_true_eq] + constructor + · exact Body.seed + · intro h; cases h with + | seed h => exact h + | step _ h => cases h + | cons m ns => + simp only [body?, Bool.and_eq_true, decide_eq_true_eq] + rw [ih] + constructor + · rintro ⟨hn, hr⟩; exact Body.step hn hr + · intro h; cases h with | step hn hr => exact ⟨hn, hr⟩ + + def complete? : List Node → Bool + | [] => false + | t :: rest => decide (isTerminal t) && body? rest + + theorem complete?_correct (ns : List Node) : complete? ns = true ↔ Complete ns := by + cases ns with + | nil => simp [complete?, Complete] + | cons t rest => simp [complete?, Complete, body?_correct] + + theorem body_nonempty {ns : List Node} (h : Body ns) : ns ≠ [] := by cases h <;> simp + + theorem terminal_not_seed {n : Node} (ht : isTerminal n) : ¬isSeed n := by + simp only [isTerminal, isSeed] at *; omega + + theorem terminal_not_internal {n : Node} (ht : isTerminal n) : ¬isInternal n := by + simp only [isTerminal, isInternal] at *; omega + + theorem seed_not_internal {n : Node} (hs : isSeed n) : ¬isInternal n := by + simp only [isSeed, isInternal] at *; omega + + theorem body_no_terminal {ns : List Node} (h : Body ns) : + ∀ n ∈ ns, ¬isTerminal n := by + induction h with + | seed hs => + intro n hn ht + simp only [List.mem_singleton] at hn + subst n + exact terminal_not_seed ht hs + | step hi hb ih => + intro n hn ht + rcases List.mem_cons.mp hn with rfl | hn + · exact terminal_not_internal ht hi + · exact ih n hn ht + +theorem body_cons {n : Node} {ns : List Node} (h : Body (n :: ns)) : + (ns = [] ∧ isSeed n) ∨ (isInternal n ∧ Body ns) := by + cases h with + | seed hs => exact Or.inl ⟨rfl, hs⟩ + | step hi hb => exact Or.inr ⟨hi, hb⟩ + +/-- A body's seed can never acquire descendants in another complete body. -/ +theorem body_prefix_free {xs ys : List Node} (hx : Body xs) (hy : Body (xs ++ ys)) : ys = [] := by + induction hx with + | seed hs => + rcases body_cons hy with ⟨he, _⟩ | ⟨hi, _⟩ + · exact he + · exact False.elim (seed_not_internal hs hi) + | step hi hb ih => + rcases body_cons hy with ⟨he, hs⟩ | ⟨_, ht⟩ + · exact False.elim (seed_not_internal hs hi) + · exact ih ht + +/-- Every connected subtree of a linear compression tree is an interval. +No complete tree is a proper interval of any other complete tree. -/ + theorem subtree_free {pre tree suffix : List Node} + (small : Complete tree) (large : Complete (pre ++ tree ++ suffix)) : + pre = [] ∧ suffix = [] := by + obtain ⟨t, rest, rfl, ht, hb⟩ := small + cases pre with + | nil => + simp only [List.nil_append, List.cons_append] at large + obtain ⟨t', rest', he, _, hb'⟩ := large + cases he + exact ⟨rfl, body_prefix_free hb hb'⟩ + | cons p ps => + obtain ⟨t', rest', he, _, hb'⟩ := large + simp only [List.cons_append, List.cons.injEq] at he + obtain ⟨rfl, rfl⟩ := he + exact False.elim (body_no_terminal hb' t (by simp) ht) + +/-- Proper final subchains have a terminal followed only by internal nodes. +Their dangling radical is precisely the entire 256-bit CV of the last node. -/ +def Radical (ns : List Node) : Prop := + ∃ t rest, ns = t :: rest ∧ isTerminal t ∧ ∀ n ∈ rest, isInternal n + + def radical? : List Node → Option Nat + | [] => none + | t :: rest => + if isTerminal t ∧ rest.all (fun n => decide (isInternal n)) then some rest.length else none + + theorem radical?_correct (ns : List Node) : + (radical? ns).isSome = true ↔ Radical ns := by + cases ns with + | nil => simp [radical?, Radical] + | cons t rest => + simp only [radical?, Radical, List.cons.injEq] + split <;> simp_all + + theorem body_split {pre suffix : List Node} (h : Body (pre ++ suffix)) (hs : suffix ≠ []) : + (∀ n ∈ pre, isInternal n) ∧ Body suffix := by + induction pre with + | nil => simpa using h + | cons p ps ih => + rcases body_cons h with ⟨he, _⟩ | ⟨hn, hb⟩ + · have he' : ps ++ suffix = [] := he + have hl := congrArg List.length he' + simp only [List.length_append, List.length_nil] at hl + exact False.elim (hs (List.length_eq_zero_iff.mp (by omega))) + · obtain ⟨hp, ht⟩ := ih hb + exact ⟨by intro n hm; rcases List.mem_cons.mp hm with rfl | hm; exact hn; exact hp n hm, ht⟩ + + theorem final_subchain_radical {pre suffix : List Node} + (h : Complete (pre ++ suffix)) (hp : pre ≠ []) (hs : suffix ≠ []) : Radical pre := by + cases pre with + | nil => exact False.elim (hp rfl) + | cons t rest => + obtain ⟨t', rest', he, ht, hb⟩ := h + simp only [List.cons_append, List.cons.injEq] at he + obtain ⟨rfl, rfl⟩ := he + exact ⟨t, rest, rfl, ht, (body_split hb hs).1⟩ + +/-- Every recognized radical is a proper final subchain of the supermode: a +single seed completes it, without changing the full-width dangling CV slot. -/ + theorem radical_extend {ns : List Node} (h : Radical ns) (s : Node) (hs : isSeed s) : + Complete (ns ++ [s]) := by + obtain ⟨t, rest, rfl, ht, hr⟩ := h + refine ⟨t, rest ++ [s], rfl, ht, ?_⟩ + induction rest with + | nil => exact Body.seed hs + | cons n rest ih => + exact Body.step (hr n (by simp)) (ih (fun n hn => hr n (by simp [hn]))) + +/-- In the supermode the seed's CV input is extra message data, never a +chaining pointer. #552 restricts it to the fixed parameter IV. Other CV fields +are exclusively full-width chaining pointers, absent from message extraction. -/ +def payload (n : Node) : Option Digest32 × Block64 := + (if isSeed n then some n.cv else none, n.block) + +structure Extracted where + message : List (Option Digest32 × Block64) + template : List (UInt64 × Bool) + +def extract (ns : List Node) : Option Extracted := + if complete? ns then some ⟨ns.map payload, ns.map (fun n => (n.tweak,n.last))⟩ + else none + +/-- Chaining values are supplied by the generic tree interpreter, not returned +as part of the decoded message or used as template bits. -/ +def rebuild : List (Option Digest32 × Block64) → List (UInt64 × Bool) → List Digest32 → List Node + | (leaf,b) :: bs, (t,l) :: ts, cv :: cvs => ⟨leaf.getD cv,b,t,l⟩ :: rebuild bs ts cvs + | _, _, _ => [] + +theorem rebuild_payload (ns : List Node) : + rebuild (ns.map payload) (ns.map (fun n => (n.tweak,n.last))) (ns.map Node.cv) = ns := by + induction ns with + | nil => rfl + | cons n ns ih => + simp only [List.map_cons, payload, rebuild] + split <;> simp_all + +/-- The complete raw message/template pair is efficiently decoded; malformed +trees are rejected. No injectivity or decoder-correctness premise is assumed. -/ +theorem message_decodable (ns : List Node) (h : Complete ns) : + ∃ e, extract ns = some e ∧ rebuild e.message e.template (ns.map Node.cv) = ns := by + refine ⟨⟨ns.map payload, ns.map (fun n => (n.tweak,n.last))⟩, ?_, rebuild_payload ns⟩ + simp [extract, (complete?_correct ns).mpr h] + +theorem extract_rejects (ns : List Node) (h : ¬Complete ns) : extract ns = none := by + have hc : complete? ns = false := by + cases he : complete? ns + · rfl + · exact False.elim (h ((complete?_correct ns).mp he)) + simp [extract, hc] + +theorem packed_tag (cv : Digest32) (block : Block64) (r len previous : Nat) + (hr : r < 256) (hl : len < 128) (hp : previous < 2^49) : + tag ⟨cv,block,UInt64.ofNat (packTweak r len previous),true⟩ = r := by + simp only [tag, UInt64.toNat_ofNat', packTweak] + omega + +theorem absorb_node_internal (cv : Digest32) (block : Block64) (first last : Bool) + (len previous : Nat) (hl : len ≤ 64) (hp : previous ≤ maxCursor) : + isInternal ⟨cv,block,absorbTweak first last len previous,true⟩ := by + have hp' : previous < 2^49 := by unfold maxCursor at hp; omega + have hl' : len < 128 := by omega + have hr : role first last < 256 := by cases first <;> cases last <;> decide + have ht := packed_tag cv block (role first last) len previous hr hl' hp' + simp only [absorbTweak, isInternal] + rw [ht] + cases first <;> cases last <;> simp [role] + +theorem seed_node (iv domain statement : Digest32) : + isSeed ⟨iv,ByteCodec.pairBytes (domain,statement),UInt64.ofNat (2^56),true⟩ := by + norm_num [isSeed, tag] + +theorem nonce_node (cv : Digest32) (nonce : Scalar24) (previous bits : Nat) : + isInternal ⟨cv,nonceBlock nonce previous bits,UInt64.ofNat (9*2^56),true⟩ := by + norm_num [isInternal, tag] + +def terminalNode (cv : Digest32) : Terminal → Node + | .output block => ⟨cv,wordsBlock [block],UInt64.ofNat (6*2^56),true⟩ + | .commitment consumed => ⟨cv,wordsBlock [consumed],UInt64.ofNat (7*2^56),true⟩ + | .powBase consumed bits => ⟨cv,wordsBlock [consumed,bits],UInt64.ofNat (8*2^56),true⟩ + +theorem terminal_node (cv : Digest32) (t : Terminal) : isTerminal (terminalNode cv t) := by + cases t <;> norm_num [terminalNode, isTerminal, tag] + +theorem terminal_evaluation (c : Compression) (cv : Digest32) (t : Terminal) : + c (terminalNode cv t).cv (terminalNode cv t).block + (terminalNode cv t).tweak (terminalNode cv t).last = evalTerminal c cv t := by + cases t <;> rfl + +theorem body_has_seed {ns : List Node} (h : Body ns) : ∃ s ∈ ns, isSeed s := by + induction h with + | seed hs => exact ⟨_, by simp, hs⟩ + | step hi hb ih => + obtain ⟨s, hs, ht⟩ := ih + exact ⟨s, by simp [hs], ht⟩ + +theorem radical_no_seed {ns : List Node} (h : Radical ns) : ∀ n ∈ ns, ¬isSeed n := by + obtain ⟨t, rest, rfl, ht, hr⟩ := h + intro n hn hs + rcases List.mem_cons.mp hn with rfl | hn + · exact terminal_not_seed ht hs + · exact seed_not_internal hs (hr n hn) + +theorem radical_not_complete {ns : List Node} (h : Radical ns) : ¬Complete ns := by + rintro ⟨t,rest,rfl,ht,hb⟩ + obtain ⟨s,hs,hseed⟩ := body_has_seed hb + exact radical_no_seed h s (by simp [hs]) hseed + +/-- Universality of the radical, not merely a recognizer on valid examples: +in *every* complete tree containing a recognized interval, that interval +contains the root and omits the child of its last node. The missing link is +the last node's fixed full-width CV position, independent of its message. -/ +theorem radical_universal {pre ns suffix : List Node} (h : Radical ns) + (whole : Complete (pre ++ ns ++ suffix)) : pre = [] ∧ suffix ≠ [] := by + have start : pre = [] := by + obtain ⟨t,rest,rfl,ht,hr⟩ := h + cases pre with + | nil => rfl + | cons p ps => + obtain ⟨t',rest',he,_,hb⟩ := whole + simp only [List.cons_append, List.cons.injEq] at he + obtain ⟨rfl,rfl⟩ := he + exact False.elim (body_no_terminal hb t (by simp) ht) + refine ⟨start, ?_⟩ + intro he + exact radical_not_complete h (by simpa [start, he] using whole) + +/-- Seed-less recognized intervals cannot be leaf subtrees: every leaf subtree +of a linear complete tree contains that tree's seed. -/ +theorem radical_not_leaf {ns : List Node} (h : Radical ns) : + ¬ ∃ s ∈ ns, isSeed s := by + rintro ⟨s,hs,hseed⟩ + exact radical_no_seed h s hs hseed + +def nodeValue (c : Compression) (n : Node) : Digest32 := c n.cv n.block n.tweak n.last + +/-- Compression-consistent tree instances: each internal node's entire CV +field is exactly its child's output. No hash/collision assumption is used. -/ +inductive Tree (c : Compression) : Digest32 → List Node → Prop where + | seed (n : Node) (h : isSeed n) : Tree c (nodeValue c n) [n] + | step (n : Node) (ns : List Node) (h : isInternal n) (child : Tree c n.cv ns) : + Tree c (nodeValue c n) (n :: ns) + +theorem Tree.body {c : Compression} {cv : Digest32} {ns : List Node} (h : Tree c cv ns) : + Body ns := by + induction h with + | seed n hn => exact Body.seed hn + | step n ns hn ht ih => exact Body.step hn ih + +def Bounds (s : State) : Prop := + s.pending.size ≤ 64 ∧ s.previous ≤ maxCursor ∧ s.consumed ≤ maxCursor + +/-- Trace allocation is specification-only. Executable State has no nodes. -/ +structure Traced where + state : State + nodes : List Node + +def Traced.Valid (c : Compression) (t : Traced) : Prop := + Tree c t.state.cv t.nodes ∧ Bounds t.state + +def shifted (s : State) : State := + if s.consumed = 0 then s else {s with previous := s.consumed, consumed := 0} + +@[simp] theorem shifted_cv (s : State) : (shifted s).cv = s.cv := by + unfold shifted; split <;> rfl + +@[simp] theorem shifted_consumed (s : State) : (shifted s).consumed = 0 := by + unfold shifted; split <;> simp_all + +theorem shifted_bounds (s : State) (h : Bounds s) : Bounds (shifted s) := by + unfold shifted; split + · exact h + · exact ⟨h.1,h.2.2,by simp [maxCursor]⟩ + +def absorbNode (s : State) (last : Bool) : Node := + ⟨s.cv,padded s.pending,absorbTweak s.first last s.pending.size s.previous,true⟩ + +def traceAbsorbByte (c : Compression) (t : Traced) (b : Byte) : Traced := + let s := shifted t.state + {state := absorbByte c s b, + nodes := if s.pending.size = 64 then absorbNode s false :: t.nodes else t.nodes} + +theorem absorbByte_shifted (c : Compression) (s : State) (b : Byte) : + absorbByte c (shifted s) b = absorbByte c s b := by + unfold shifted + split + · rfl + · rename_i hc; simp [absorbByte, hc] + +@[simp] theorem traceAbsorbByte_state (c : Compression) (t : Traced) (b : Byte) : + (traceAbsorbByte c t b).state = absorbByte c t.state b := absorbByte_shifted c t.state b + +theorem absorbByte_bounds (c : Compression) (s : State) (b : Byte) (h : Bounds s) : + Bounds (absorbByte c s b) := by + rcases h with ⟨hb,hp,hc⟩ + by_cases hz : s.consumed = 0 <;> by_cases hf : s.pending.size = 64 + all_goals simp_all [absorbByte, Bounds, maxCursor] <;> omega + +theorem traceAbsorbByte_valid (c : Compression) (t : Traced) (b : Byte) (h : t.Valid c) : + (traceAbsorbByte c t b).Valid c := by + have hb := shifted_bounds t.state h.2 + have ht : Tree c (shifted t.state).cv t.nodes := by simpa using h.1 + refine ⟨?_, absorbByte_bounds c _ b hb⟩ + have hc := shifted_consumed t.state + by_cases hp : (shifted t.state).pending.size = 64 + · have hi := absorb_node_internal (shifted t.state).cv (padded (shifted t.state).pending) + (shifted t.state).first false (shifted t.state).pending.size (shifted t.state).previous hb.1 hb.2.1 + have hn := Tree.step (c := c) (absorbNode (shifted t.state) false) t.nodes hi ht + simpa only [traceAbsorbByte, hp, ↓reduceIte, absorbByte, hc, absorbNode, nodeValue] using hn + · simpa only [traceAbsorbByte, hp, ↓reduceIte, absorbByte, hc] using ht + +def traceAbsorb (c : Compression) (t : Traced) (bs : List Byte) : Traced := + bs.foldl (traceAbsorbByte c) t + +@[simp] theorem traceAbsorb_state (c : Compression) (t : Traced) (bs : List Byte) : + (traceAbsorb c t bs).state = absorb c t.state bs := by + induction bs generalizing t with + | nil => rfl + | cons b bs ih => + simp only [traceAbsorb, absorb, List.foldl_cons] at * + rw [ih, traceAbsorbByte_state] + +theorem traceAbsorb_valid (c : Compression) (t : Traced) (bs : List Byte) (h : t.Valid c) : + (traceAbsorb c t bs).Valid c := by + induction bs generalizing t with + | nil => exact h + | cons b bs ih => exact ih _ (traceAbsorbByte_valid c t b h) + +def traceFinish (c : Compression) (t : Traced) : Traced := + {state := finish c t.state, + nodes := if t.state.pending.isEmpty then t.nodes else absorbNode t.state true :: t.nodes} + +theorem traceFinish_valid (c : Compression) (t : Traced) (h : t.Valid c) : + (traceFinish c t).Valid c := by + by_cases hp : t.state.pending.isEmpty = true + · simpa [traceFinish, finish, hp] using h + · refine ⟨?_, ?_⟩ + · have hi := absorb_node_internal t.state.cv (padded t.state.pending) + t.state.first true t.state.pending.size t.state.previous h.2.1 h.2.2.1 + have hn := Tree.step (c := c) (absorbNode t.state true) t.nodes hi h.1 + simpa [traceFinish, finish, hp, finalized, absorbNode, nodeValue] using hn + · simpa [traceFinish, finish, hp, Bounds, maxCursor] using h.2.2.2 + +def traceSeed (c : Compression) (iv domain statement : Digest32) : Traced := + {state := seed c iv domain statement, + nodes := [⟨iv,ByteCodec.pairBytes (domain,statement),UInt64.ofNat (2^56),true⟩]} + +theorem traceSeed_valid (c : Compression) (iv domain statement : Digest32) : + (traceSeed c iv domain statement).Valid c := by + refine ⟨Tree.seed _ (seed_node iv domain statement), ?_⟩ + simp [traceSeed, seed, Bounds, maxCursor] + + +def traceFrame (c : Compression) (t : Traced) : Frame → Traced + | .absorb previous bs => + traceFinish c (traceAbsorb c ⟨{cv := t.state.cv, previous := previous},t.nodes⟩ bs) + | .nonce previous bits nonce => + let n : Node := ⟨t.state.cv,nonceBlock nonce previous bits,UInt64.ofNat (9*2^56),true⟩ + ⟨{cv := nodeValue c n},n :: t.nodes⟩ + +theorem traceFrame_cv (c : Compression) (t : Traced) (f : Frame) : + (traceFrame c t f).state.cv = evalFrame c t.state.cv f := by + cases f with + | absorb previous bs => + simp only [traceFrame, traceFinish, finish_cv, traceAbsorb_state, evalFrame] + | nonce previous bits nonce => rfl + +theorem traceFrame_valid (c : Compression) (t : Traced) (f : Frame) + (h : t.Valid c) (hf : DuplexEncoding.FrameValid f) : (traceFrame c t f).Valid c := by + cases f with + | absorb previous bs => + apply traceFinish_valid + apply traceAbsorb_valid + refine ⟨h.1, ?_⟩ + exact ⟨by simp, by change previous ≤ maxCursor; have := hf.1; unfold maxCursor; omega, by simp [maxCursor]⟩ + | nonce previous bits nonce => + refine ⟨Tree.step _ _ (nonce_node t.state.cv nonce previous bits) h.1, ?_⟩ + simp [traceFrame, Bounds, maxCursor] + +def traceHistory (c : Compression) (iv : Digest32) (h : FramedHistory) : Traced := + h.frames.foldl (traceFrame c) (traceSeed c iv h.domain h.statement) + +theorem traceFrame_fold_cv (c : Compression) (t : Traced) (fs : List Frame) : + (fs.foldl (traceFrame c) t).state.cv = fs.foldl (evalFrame c) t.state.cv := by + induction fs generalizing t with + | nil => rfl + | cons f fs ih => simp only [List.foldl_cons, ih, traceFrame_cv] + +theorem traceHistory_cv (c : Compression) (iv : Digest32) (h : FramedHistory) : + (traceHistory c iv h).state.cv = evalHistory c iv h := by + exact traceFrame_fold_cv c _ _ + +theorem traceHistory_valid (c : Compression) (iv : Digest32) (h : FramedHistory) + (admissible : ∀ f ∈ h.frames, DuplexEncoding.FrameValid f) : (traceHistory c iv h).Valid c := by + have step : ∀ (fs : List Frame) (t : Traced), t.Valid c → + (∀ f ∈ fs, DuplexEncoding.FrameValid f) → (fs.foldl (traceFrame c) t).Valid c := by + intro fs + induction fs with + | nil => intro t ht _; exact ht + | cons f fs ih => + intro t ht hf + exact ih _ (traceFrame_valid c t f ht (hf f (by simp))) (fun g hg => hf g (by simp [hg])) + exact step _ _ (traceSeed_valid c iv h.domain h.statement) admissible + +def coordinateTree (c : Compression) (iv : Digest32) (q : Coordinate) : List Node := + let t := traceHistory c iv q.history + terminalNode t.state.cv q.terminal :: t.nodes + +theorem coordinateTree_complete (c : Compression) (iv : Digest32) (q : Coordinate) + (admissible : ∀ f ∈ q.history.frames, DuplexEncoding.FrameValid f) : + Complete (coordinateTree c iv q) := by + exact ⟨_,_,rfl,terminal_node _ _,(traceHistory_valid c iv q.history admissible).1.body⟩ + +theorem coordinateTree_evaluates (c : Compression) (iv : Digest32) (q : Coordinate) : + nodeValue c (terminalNode (traceHistory c iv q.history).state.cv q.terminal) = + evalCoordinate c iv q := by + have he := terminal_evaluation c (traceHistory c iv q.history).state.cv q.terminal + change nodeValue c (terminalNode (traceHistory c iv q.history).state.cv q.terminal) = _ at he + rw [he, traceHistory_cv] + rfl + +/-- Erase chaining fields to obtain the chronological primitive plan. -/ +def rawPlan (ns : List Node) : List DuplexEncoding.Instruction := + ns.reverse.map (fun n => (n.block,n.tweak)) + +theorem trace_chunks (c : Compression) (t : Traced) (bs : List Byte) + (cursor : t.state.consumed = 0) : + rawPlan (traceFinish c (traceAbsorb c t bs)).nodes = + rawPlan t.nodes ++ DuplexEncoding.chunks t.state.first t.state.previous t.state.pending.toList bs := by + induction bs generalizing t with + | nil => + by_cases hp : t.state.pending = #[] + · simp [traceAbsorb, traceFinish, rawPlan, DuplexEncoding.chunks, hp] + · simp [traceAbsorb, traceFinish, rawPlan, DuplexEncoding.chunks, DuplexEncoding.chunk, + absorbNode, hp, Array.isEmpty_iff] + | cons b bs ih => + change rawPlan (traceFinish c (traceAbsorb c (traceAbsorbByte c t b) bs)).nodes = _ + rw [ih _ (by rw [traceAbsorbByte_state]; exact absorbByte_cursor c t.state b)] + by_cases hp : t.state.pending.size = 64 + · simp [traceAbsorbByte, shifted, cursor, hp, absorbByte, rawPlan, DuplexEncoding.chunks, + DuplexEncoding.chunk, absorbNode, List.append_assoc] + · simp [traceAbsorbByte, shifted, cursor, hp, absorbByte, rawPlan, DuplexEncoding.chunks] + +theorem traceFrame_plan (c : Compression) (t : Traced) (f : Frame) : + rawPlan (traceFrame c t f).nodes = rawPlan t.nodes ++ DuplexEncoding.framePlan f := by + cases f with + | absorb previous bs => + simpa only [traceFrame, DuplexEncoding.framePlan, Array.toList_empty] using + trace_chunks c ⟨{cv := t.state.cv, previous := previous},t.nodes⟩ bs rfl + | nonce previous bits nonce => + simp [traceFrame, rawPlan, DuplexEncoding.framePlan] + +theorem traceFrames_plan (c : Compression) (t : Traced) (fs : List Frame) : + rawPlan (fs.foldl (traceFrame c) t).nodes = rawPlan t.nodes ++ fs.flatMap DuplexEncoding.framePlan := by + induction fs generalizing t with + | nil => simp + | cons f fs ih => + simp only [List.foldl_cons, ih, traceFrame_plan, List.flatMap_cons, List.append_assoc] + +/-- The actual compression trace has exactly the independently encoded plan; +the template constructor does not query or depend on the compression oracle. -/ +theorem coordinateTree_plan (c : Compression) (iv : Digest32) (q : Coordinate) : + rawPlan (coordinateTree c iv q) = DuplexEncoding.plan q := by + have h := traceFrames_plan c (traceSeed c iv q.history.domain q.history.statement) q.history.frames + unfold coordinateTree rawPlan + simp only [List.reverse_cons, List.map_append, List.map_cons, List.map_nil] + change rawPlan (traceHistory c iv q.history).nodes ++ + [((terminalNode (traceHistory c iv q.history).state.cv q.terminal).block, + (terminalNode (traceHistory c iv q.history).state.cv q.terminal).tweak)] = _ + rw [show rawPlan (traceHistory c iv q.history).nodes = + rawPlan (traceSeed c iv q.history.domain q.history.statement).nodes ++ + q.history.frames.flatMap DuplexEncoding.framePlan from h] + unfold DuplexEncoding.plan + cases q.terminal <;> + simp [rawPlan, traceSeed, terminalNode, DuplexEncoding.terminalPlan] + +def evalPlan (c : Compression) (cv : Digest32) (xs : List DuplexEncoding.Instruction) : Digest32 := + xs.foldl (fun cv i => c cv i.1 i.2 true) cv + +theorem evalPlan_append (c : Compression) (cv : Digest32) (xs ys : List DuplexEncoding.Instruction) : + evalPlan c cv (xs ++ ys) = evalPlan c (evalPlan c cv xs) ys := by + simp [evalPlan, List.foldl_append] + +theorem chunks_evaluate (c : Compression) (s : State) (bs : List Byte) (cursor : s.consumed = 0) : + evalPlan c s.cv (DuplexEncoding.chunks s.first s.previous s.pending.toList bs) = + finalized c (absorb c s bs) := by + induction bs generalizing s with + | nil => + by_cases hp : s.pending = #[] + · simp [DuplexEncoding.chunks, hp, evalPlan, finalized] + · simp [DuplexEncoding.chunks, DuplexEncoding.chunk, evalPlan, finalized, hp, Array.isEmpty_iff] + | cons b bs ih => + change _ = finalized c (absorb c (absorbByte c s b) bs) + rw [← ih _ (absorbByte_cursor c s b)] + by_cases hp : s.pending.size = 64 + · simp [DuplexEncoding.chunks, DuplexEncoding.chunk, absorbByte, cursor, hp, evalPlan] + · simp [DuplexEncoding.chunks, absorbByte, cursor, hp] + +theorem framePlan_evaluate (c : Compression) (cv : Digest32) (f : Frame) : + evalPlan c cv (DuplexEncoding.framePlan f) = evalFrame c cv f := by + cases f with + | absorb previous bs => + exact chunks_evaluate c {cv := cv, previous := previous} bs rfl + | nonce previous bits nonce => rfl + +theorem framesPlan_evaluate (c : Compression) (cv : Digest32) (fs : List Frame) : + evalPlan c cv (fs.flatMap DuplexEncoding.framePlan) = fs.foldl (evalFrame c) cv := by + induction fs generalizing cv with + | nil => rfl + | cons f fs ih => + simp only [List.flatMap_cons, evalPlan_append, framePlan_evaluate, List.foldl_cons, ih] + +/-- Full executable-to-mode correspondence with no assumed framing bridge. -/ +theorem plan_evaluate (c : Compression) (iv : Digest32) (q : Coordinate) : + evalPlan c iv (DuplexEncoding.plan q) = evalCoordinate c iv q := by + unfold DuplexEncoding.plan + change evalPlan c (seed c iv q.history.domain q.history.statement).cv + (q.history.frames.flatMap DuplexEncoding.framePlan ++ [DuplexEncoding.terminalPlan q.terminal]) = _ + rw [evalPlan_append, framesPlan_evaluate] + unfold evalCoordinate evalHistory + cases q.terminal <;> rfl + +def extractedPlan (e : Extracted) : List DuplexEncoding.Instruction := + ((e.message.zip e.template).map (fun p => (p.1.2,p.2.1))).reverse + +theorem extractedPlan_payload (ns : List Node) : + extractedPlan ⟨ns.map payload, ns.map (fun n => (n.tweak,n.last))⟩ = rawPlan ns := by + have he : ((ns.map payload).zip (ns.map (fun n => (n.tweak,n.last)))).map + (fun p => (p.1.2,p.2.1)) = ns.map (fun n => (n.block,n.tweak)) := by + induction ns with + | nil => rfl + | cons n ns ih => simp [payload, ih] + simp only [extractedPlan, he, rawPlan, List.map_reverse] + +theorem extract_plan (ns : List Node) (complete : Complete ns) : + (extract ns).map extractedPlan = some (rawPlan ns) := by + simp only [extract, (complete?_correct ns).mpr complete, ↓reduceIte, Option.map_some, + extractedPlan_payload] + +/-- Injectivity into the actual DMV message/template domain, not an assumed +abstract framing map. Holds even for trees evaluated using different public +compression functions; chaining fields never occur in the decoded message. -/ +theorem canonical_mode_injective (c d : Compression) (iv : Digest32) {a b : Coordinate} + (ha : DuplexEncoding.Admissible a) (hb : DuplexEncoding.Admissible b) + (same : extract (coordinateTree c iv a) = extract (coordinateTree d iv b)) : a = b := by + have h := congrArg (Option.map extractedPlan) same + rw [extract_plan _ (coordinateTree_complete c iv a ha.1), + extract_plan _ (coordinateTree_complete d iv b hb.1), coordinateTree_plan, coordinateTree_plan] at h + exact DuplexEncoding.plan_injective ha hb (Option.some.inj h) + +/-- These are concrete structural conditions of DMV18 Definitions 4--6. +The probabilistic public-random-compression theorem is a separate boundary. -/ +theorem radical_subtree {ns : List Node} (h : Radical ns) : + ∃ whole, Complete whole ∧ ∃ suffix, suffix ≠ [] ∧ whole = ns ++ suffix := by + let s : Node := ⟨zeroDigest, ByteCodec.pairBytes (zeroDigest,zeroDigest), UInt64.ofNat (2^56), true⟩ + exact ⟨ns ++ [s], radical_extend h s (seed_node _ _ _), [s], by simp, rfl⟩ + +structure DMVConditions : Prop where + subtreeFree : ∀ {pre tree suffix}, Complete tree → Complete (pre ++ tree ++ suffix) → + pre = [] ∧ suffix = [] + radicalRecognizer : ∀ ns, (radical? ns).isSome = true ↔ Radical ns + finalRadicals : ∀ {pre suffix}, Complete (pre ++ suffix) → pre ≠ [] → suffix ≠ [] → Radical pre + radicalSubtree : ∀ {ns}, Radical ns → + ∃ whole, Complete whole ∧ ∃ suffix, suffix ≠ [] ∧ whole = ns ++ suffix + radicalUniversal : ∀ {pre ns suffix}, Radical ns → Complete (pre ++ ns ++ suffix) → + pre = [] ∧ suffix ≠ [] + radicalNotLeaf : ∀ {ns}, Radical ns → ¬ ∃ s ∈ ns, isSeed s + messageDecoder : ∀ ns, Complete ns → + ∃ e, extract ns = some e ∧ rebuild e.message e.template (ns.map Node.cv) = ns + decoderRejects : ∀ ns, ¬Complete ns → extract ns = none + +theorem dmv_conditions : DMVConditions := + ⟨subtree_free, radical?_correct, final_subchain_radical, radical_subtree, radical_universal, + radical_not_leaf, message_decodable, extract_rejects⟩ + +def HistoryValid (m : Model) : Prop := ∀ f ∈ m.history.frames, DuplexEncoding.FrameValid f + +theorem closeRun_history_valid (m : Model) (hm : m.Valid) (h : HistoryValid m) : + HistoryValid (closeRun m) := by + by_cases hr : m.run = [] + · simpa [closeRun, hr] using h + · intro f hf + simp only [closeRun, hr, ↓reduceIte, List.mem_append, List.mem_singleton] at hf + rcases hf with hf | rfl + · exact h f hf + · exact ⟨by have := hm.2.2.2; unfold maxCursor at this; omega, hr⟩ + +theorem reachable_history_valid (c : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (h : Reachable c iv domain statement m s) : HistoryValid m := by + induction h with + | seed => simp [HistoryValid] + | absorb h bs ih => + unfold modelAbsorb + split <;> exact ih + | squeeze h n ok ih => + have hm := (reachable_represents c iv domain statement h).1 + unfold modelSqueeze + split + · exact ih + · exact closeRun_history_valid _ hm ih + | nonce h nonce bits limit ih => + have hm := (reachable_represents c iv domain statement h).1 + have hc := closeRun_history_valid _ hm ih + intro f hf + simp only [modelNonce, List.mem_append, List.mem_singleton] at hf + rcases hf with hf | rfl + · exact hc f hf + · refine ⟨?_, limit⟩ + rw [closeRun_consumed] + have := hm.2.2.1 + unfold maxCursor at this + omega + +theorem reachable_closed_history_valid (c : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (h : Reachable c iv domain statement m s) : + HistoryValid (closeRun m) := + closeRun_history_valid m (reachable_represents c iv domain statement h).1 + (reachable_history_valid c iv domain statement h) + +theorem reachable_commitment_admissible (c : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (h : Reachable c iv domain statement m s) : + DuplexEncoding.Admissible ⟨(closeRun m).history,.commitment m.consumed⟩ := by + refine ⟨reachable_closed_history_valid c iv domain statement h, ?_⟩ + have := (reachable_represents c iv domain statement h).1.2.2.1 + change m.consumed < 2^49 + unfold maxCursor at this + omega + +theorem reachable_powBase_admissible (c : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (h : Reachable c iv domain statement m s) (bits : Nat) (limit : bits ≤ 63) : + DuplexEncoding.Admissible ⟨(closeRun m).history,.powBase m.consumed bits⟩ := + ⟨reachable_closed_history_valid c iv domain statement h, + (reachable_commitment_admissible c iv domain statement h).2, limit⟩ + +/-- Charge the complete uncached seed-to-terminal path for each coordinate. +Direct public-primitive calls, other constructions, verification and PoW +trials remain additional global charges; this is not a cached-call bound. -/ +def pathCost (q : Coordinate) : Nat := (DuplexEncoding.plan q).length + +theorem coordinateTree_cost (c : Compression) (iv : Digest32) (q : Coordinate) : + (coordinateTree c iv q).length = pathCost q := by + have h := congrArg List.length (coordinateTree_plan c iv q) + simpa [rawPlan, pathCost] using h + +def Anchored (iv : Digest32) (ns : List Node) : Prop := + ∀ n ∈ ns, isSeed n → n.cv = iv + +theorem anchored_internal (iv : Digest32) (n : Node) (ns : List Node) + (hn : isInternal n) (h : Anchored iv ns) : Anchored iv (n :: ns) := by + intro m hm hs + rcases List.mem_cons.mp hm with rfl | hm + · exact False.elim (seed_not_internal hs hn) + · exact h m hm hs + +theorem traceAbsorbByte_anchored (c : Compression) (iv : Digest32) (t : Traced) (b : Byte) + (ht : t.Valid c) (h : Anchored iv t.nodes) : Anchored iv (traceAbsorbByte c t b).nodes := by + have hb := shifted_bounds t.state ht.2 + by_cases hp : (shifted t.state).pending.size = 64 + · simp only [traceAbsorbByte, hp, ↓reduceIte] + apply anchored_internal + · exact absorb_node_internal _ _ _ _ _ _ hb.1 hb.2.1 + · exact h + · simpa [traceAbsorbByte, hp] using h + +theorem traceAbsorb_anchored (c : Compression) (iv : Digest32) (t : Traced) (bs : List Byte) + (ht : t.Valid c) (h : Anchored iv t.nodes) : Anchored iv (traceAbsorb c t bs).nodes := by + induction bs generalizing t with + | nil => exact h + | cons b bs ih => + exact ih _ (traceAbsorbByte_valid c t b ht) (traceAbsorbByte_anchored c iv t b ht h) + +theorem traceFinish_anchored (c : Compression) (iv : Digest32) (t : Traced) + (ht : t.Valid c) (h : Anchored iv t.nodes) : Anchored iv (traceFinish c t).nodes := by + by_cases hp : t.state.pending.isEmpty = true + · simpa [traceFinish, hp] using h + · have hi := absorb_node_internal t.state.cv (padded t.state.pending) t.state.first true + t.state.pending.size t.state.previous ht.2.1 ht.2.2.1 + simpa [traceFinish, hp] using anchored_internal iv (absorbNode t.state true) t.nodes hi h + +theorem traceFrame_anchored (c : Compression) (iv : Digest32) (t : Traced) (f : Frame) + (ht : t.Valid c) (h : Anchored iv t.nodes) (hf : DuplexEncoding.FrameValid f) : + Anchored iv (traceFrame c t f).nodes := by + cases f with + | absorb previous bs => + have hstart : (Traced.mk {cv := t.state.cv, previous := previous} t.nodes).Valid c := by + refine ⟨ht.1, by simp, ?_, by simp [maxCursor]⟩ + change previous ≤ maxCursor + have := hf.1 + unfold maxCursor + omega + exact traceFinish_anchored c iv _ (traceAbsorb_valid c _ bs hstart) + (traceAbsorb_anchored c iv _ bs hstart h) + | nonce previous bits nonce => + exact anchored_internal iv _ _ (nonce_node t.state.cv nonce previous bits) h + +theorem traceHistory_anchored (c : Compression) (iv : Digest32) (h : FramedHistory) + (admissible : ∀ f ∈ h.frames, DuplexEncoding.FrameValid f) : + Anchored iv (traceHistory c iv h).nodes := by + have step : ∀ (fs : List Frame) (t : Traced), t.Valid c → Anchored iv t.nodes → + (∀ f ∈ fs, DuplexEncoding.FrameValid f) → Anchored iv (fs.foldl (traceFrame c) t).nodes := by + intro fs + induction fs with + | nil => intro _ _ ha _; exact ha + | cons f fs ih => + intro t ht ha hf + exact ih _ (traceFrame_valid c t f ht (hf f (by simp))) + (traceFrame_anchored c iv t f ht ha (hf f (by simp))) (fun g hg => hf g (by simp [hg])) + apply step _ _ (traceSeed_valid c iv h.domain h.statement) ?_ admissible + intro n hn _ + simp only [traceSeed, List.mem_singleton] at hn + subst n + rfl + +theorem coordinateTree_anchored (c : Compression) (iv : Digest32) (q : Coordinate) + (h : DuplexEncoding.Admissible q) : Anchored iv (coordinateTree c iv q) := by + intro n hn hs + rcases List.mem_cons.mp hn with rfl | hn + · exact False.elim (terminal_not_seed (terminal_node _ _) hs) + · exact traceHistory_anchored c iv q.history h.1 n hn hs + +theorem body_flags {ns : List Node} (h : Body ns) : ∀ n ∈ ns, n.last = true := by + induction h with + | seed hs => simpa using hs.2 + | step hi hb ih => + intro n hn + rcases List.mem_cons.mp hn with rfl | hn + · exact hi.2 + · exact ih n hn + +theorem complete_flags {ns : List Node} (h : Complete ns) : ∀ n ∈ ns, n.last = true := by + obtain ⟨t,rest,rfl,ht,hb⟩ := h + intro n hn + rcases List.mem_cons.mp hn with rfl | hn + · exact ht.2 + · exact body_flags hb n hn + +/-- Concrete DMV (message,template) coordinate, computable without compression. +All seed CV bits are fixed to the primitive parameter IV in this submode. -/ +def keyFromPlan (iv : Digest32) (p : List DuplexEncoding.Instruction) : Extracted := + {message := p.reverse.map (fun i => (if DuplexEncoding.readRole i.2 = 1 then some iv else none, i.1)), + template := p.reverse.map (fun i => (i.2,true))} + +def modeKey (iv : Digest32) (q : Coordinate) : Extracted := keyFromPlan iv (DuplexEncoding.plan q) + +theorem extract_anchored (iv : Digest32) (ns : List Node) + (hc : Complete ns) (ha : Anchored iv ns) : + extract ns = some (keyFromPlan iv (rawPlan ns)) := by + have hf := complete_flags hc + simp only [extract, (complete?_correct ns).mpr hc, ↓reduceIte, keyFromPlan, rawPlan, + ← List.map_reverse, List.reverse_reverse, List.map_map] + congr 2 + · apply List.map_congr_left + intro n hn + have hnflag := hf n hn + by_cases hs : isSeed n + · have ht := hs.1 + unfold tag at ht + simp only [payload, hs, ↓reduceIte, Function.comp_apply, DuplexEncoding.readRole, ht, ha n hn hs] + · have htag : tag n ≠ 1 := by intro he; exact hs ⟨he,hnflag⟩ + unfold tag at htag + simp only [payload, hs, ↓reduceIte, Function.comp_apply, DuplexEncoding.readRole, htag] + · apply List.map_congr_left + intro n hn + simp only [Function.comp_apply, hf n hn] + +/-- The actual raw-mode key is independent of all compression outputs, not an +assumed parsing or state-correctness bridge. -/ +theorem coordinateTree_key (c : Compression) (iv : Digest32) (q : Coordinate) + (h : DuplexEncoding.Admissible q) : + extract (coordinateTree c iv q) = some (modeKey iv q) := by + rw [extract_anchored iv _ (coordinateTree_complete c iv q h.1) (coordinateTree_anchored c iv q h), + coordinateTree_plan] + rfl + +theorem modeKey_injective (iv : Digest32) {a b : Coordinate} + (ha : DuplexEncoding.Admissible a) (hb : DuplexEncoding.Admissible b) + (same : modeKey iv a = modeKey iv b) : a = b := by + have he : extractedPlan (modeKey iv a) = extractedPlan (modeKey iv b) := congrArg extractedPlan same + have recover : ∀ q, extractedPlan (modeKey iv q) = DuplexEncoding.plan q := by + intro q + unfold modeKey keyFromPlan extractedPlan + have step : ∀ p : List DuplexEncoding.Instruction, + ((p.map (fun i => (if DuplexEncoding.readRole i.2 = 1 then some iv else none,i.1))).zip + (p.map (fun i => (i.2,true)))).map (fun p => (p.1.2,p.2.1)) = p := by + intro p; induction p with + | nil => rfl + | cons i p ih => simp [ih] + rw [step, List.reverse_reverse] + rw [recover a, recover b] at he + exact DuplexEncoding.plan_injective ha hb he + +/-- Box each intermediate reply over stored bytes before it becomes another +CV. The data-valued fold is essential: a Digest32-valued helper can be eta +expanded into a byte function that recomputes the whole predecessor chain. +This evaluator allocates neither mode Programs nor public execution traces. -/ +private def evalPlanStoredResult (c : Compression) (cv : Digest32) : + List DuplexEncoding.Instruction → Option Digest32 + | [] => some cv + | i :: rest => + let bytes := Array.ofFn (c cv i.1 i.2 true) + evalPlanStoredResult c (fun j => bytes[j.val]'(by + simp only [bytes,Array.size_ofFn] + exact j.isLt)) rest + +private theorem evalPlanStoredResult_eq (c : Compression) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + evalPlanStoredResult c cv xs = some (evalPlan c cv xs) := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => simp [evalPlanStoredResult,ih,evalPlan] + +def evalCoordinateStored (c : Compression) (iv : Digest32) (q : Coordinate) : Digest32 := + let result := evalPlanStoredResult c iv (DuplexEncoding.plan q) + result.get (by simp only [result,evalPlanStoredResult_eq,Option.isSome_some]) + +/-- Checked runtime refinement for the actual construction evaluator; the +logical semantics, all compression inputs, and all resource bounds are unchanged. -/ +@[csimp] theorem evalCoordinate_stored : evalCoordinate = evalCoordinateStored := by + funext c iv q + simp only [evalCoordinateStored,evalPlanStoredResult_eq,Option.get_some,plan_evaluate] + +/-- A data-valued consumer can force the complete construction once, rather +than invoking the Digest32-valued wrapper separately for each requested byte. -/ +def withCoordinate {Result : Type} (c : Compression) (iv : Digest32) (q : Coordinate) + (next : Digest32 → Result) : Result := + let result := evalPlanStoredResult c iv (DuplexEncoding.plan q) + next (result.get (by simp only [result,evalPlanStoredResult_eq,Option.isSome_some])) + +theorem withCoordinate_eq {Result : Type} (c : Compression) (iv : Digest32) (q : Coordinate) + (next : Digest32 → Result) : + withCoordinate c iv q next = next (evalCoordinate c iv q) := by + simp only [withCoordinate,evalPlanStoredResult_eq,Option.get_some,plan_evaluate] + +end Whir.DuplexFraming diff --git a/verification/whir/Whir/DuplexModeGame.lean b/verification/whir/Whir/DuplexModeGame.lean new file mode 100644 index 000000000..304077b44 --- /dev/null +++ b/verification/whir/Whir/DuplexModeGame.lean @@ -0,0 +1,335 @@ +import Whir.DuplexFraming +import Whir.DuplexCompression + +/-! Source-pinned, classical public-compression games for #552. These definitions +contain no PCS relation or acceptance predicate. All primitive calls (including +verification, auxiliary hashing, and PoW) use the same public oracle; each +construction occurrence pays its complete uncached path. The only external +cryptographic boundaries below are explicitly named distinguishing games. +No small concrete-BLAKE2s idealization gap is proved or asserted. -/ +namespace Whir.DuplexModeGame +open FiatShamirGame DuplexRefinement DuplexFraming + +local instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +noncomputable local instance : Fintype UInt64 := Fintype.ofFinite _ + +private def nodeFields (n : Node) : Digest32 × Block64 × UInt64 × Bool := + (n.cv,n.block,n.tweak,n.last) + +private theorem nodeFields_injective : Function.Injective nodeFields := by + intro a b h + cases a; cases b + simp_all [nodeFields] + +local instance : Finite Node := Finite.of_injective nodeFields nodeFields_injective +noncomputable local instance : Fintype Node := Fintype.ofFinite _ + +abbrev PrimitiveOracle := Node → Digest32 + +/-- The DMV capacity is the actual full, untruncated chaining-value space. -/ +theorem digest_card : Fintype.card Digest32 = 2^256 := by + norm_num [Digest32, Byte, Fintype.card_fun] + +def compressionOf (oracle : PrimitiveOracle) : Compression := + fun cv block tweak last => oracle ⟨cv,block,tweak,last⟩ + +def blake2sOracle : PrimitiveOracle := fun n => + DuplexCompression.compress n.cv n.block n.tweak n.last + +/-- Every purpose shares one primitive budget. The labels are accounting data, +not disjoint oracles or a reason to exclude verification/PoW from Q. -/ +inductive Purpose where + | direct | verification | auxiliary | pow + deriving DecidableEq, Repr + +inductive Query where + | primitive (purpose : Purpose) (input : Node) + | construction (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + +def Query.cost : Query → Nat + | .primitive _ _ => 1 + | .construction q _ => pathCost q + +/-- An adaptive, single-stage oracle interaction. A continuation sees the +complete 256-bit answer. Branching, repeated coordinates, statements and clones +all remain in this one interaction with its one shared oracle. -/ +inductive Program (Result : Type) where + | done (result : Result) + | ask (query : Query) (next : Digest32 → Program Result) + +/-- A genuine worst-case resource certificate, quantified over every reply, +including replies on rejecting continuations. No budget is waived. -/ +def Counts {Result : Type} : Nat → Program Result → Prop + | _, .done _ => True + | Q, .ask q next => q.cost ≤ Q ∧ ∀ d, Counts (Q-q.cost) (next d) + +structure Observation where + query : Query + answer : Digest32 + +structure View (Result : Type) where + observations : List Observation + result : Result + +/-- Internal meter state is deliberately absent from the distinguisher's view: +the ideal simulator's private RO queries are not public observations. -/ +structure Execution (Result : Type) where + view : View Result + primitiveCost : Nat + constructionRequests : Nat + simulatorQueries : Nat + +def prepend {Result : Type} (q : Query) (answer : Digest32) (simulatorCalls : Nat) + (rest : Execution Result) : Execution Result := + {view := ⟨⟨q,answer⟩ :: rest.view.observations,rest.view.result⟩, + primitiveCost := q.cost + rest.primitiveCost, + constructionRequests := (match q with | .primitive _ _ => 0 | .construction _ _ => 1) + rest.constructionRequests, + simulatorQueries := simulatorCalls + rest.simulatorQueries} + +def realAnswer (oracle : PrimitiveOracle) (iv : Digest32) : Query → Digest32 + | .primitive _ input => oracle input + | .construction q _ => evalCoordinate (compressionOf oracle) iv q + +def runReal {Result : Type} (oracle : PrimitiveOracle) (iv : Digest32) : Program Result → Execution Result + | .done r => ⟨⟨[],r⟩,0,0,0⟩ + | .ask q next => + let answer := realAnswer oracle iv q + prepend q answer 0 (runReal oracle iv (next answer)) + +theorem runReal_counts {Result : Type} (oracle : PrimitiveOracle) (iv : Digest32) + (p : Program Result) (Q : Nat) (h : Counts Q p) : (runReal oracle iv p).primitiveCost ≤ Q := by + induction p generalizing Q with + | done r => simp [runReal] + | ask q next ih => + have hr := ih (realAnswer oracle iv q) (Q-q.cost) (h.2 _) + simp only [runReal, prepend] + have := h.1 + omega + +/-- A finite representation of lists of length at most Q, used only to make +uniform random-oracle tables a literal finite probability experiment. -/ +abbrev ShortList (α : Type) (Q : Nat) := (n : Fin (Q+1)) × (Fin n.val → α) +abbrev RawKey (Q : Nat) := ShortList (Option Digest32 × Block64) Q × ShortList (UInt64 × Bool) Q + +/-- Explicit finite-table witnesses for downstream distributional couplings; +these do not install global UInt64 or function-space instances. -/ +@[instance_reducible] +noncomputable def rawKeyFintype (Q : Nat) : Fintype (RawKey Q) := by + classical + infer_instance + +@[instance_reducible] +noncomputable def rawOracleFintype (Q : Nat) : Fintype (RawKey Q → Digest32) := by + classical + infer_instance + +def shortList {α : Type} (Q : Nat) (xs : List α) (h : xs.length ≤ Q) : ShortList α Q := + ⟨⟨xs.length,by omega⟩,fun i => xs[i.val]⟩ + +def expandShort {α : Type} {Q : Nat} (xs : ShortList α Q) : List α := List.ofFn xs.2 + +@[simp] theorem expandShort_shortList {α : Type} (Q : Nat) (xs : List α) (h : xs.length ≤ Q) : + expandShort (shortList Q xs h) = xs := by simp [expandShort, shortList] + +def expandKey {Q : Nat} (key : RawKey Q) : Extracted := + ⟨expandShort key.1,expandShort key.2⟩ + +def restrictKey (Q : Nat) (key : Extracted) (hm : key.message.length ≤ Q) + (ht : key.template.length ≤ Q) : RawKey Q := + (shortList Q key.message hm,shortList Q key.template ht) + +@[simp] theorem expandKey_restrictKey (Q : Nat) (key : Extracted) + (hm : key.message.length ≤ Q) (ht : key.template.length ≤ Q) : + expandKey (restrictKey Q key hm ht) = key := by + cases key + simp [expandKey, restrictKey] + +theorem modeKey_lengths (iv : Digest32) (q : Coordinate) : + (modeKey iv q).message.length = pathCost q ∧ (modeKey iv q).template.length = pathCost q := by + simp [modeKey, keyFromPlan, pathCost] + +def constructionKey (Q : Nat) (iv : Digest32) (q : Coordinate) (h : pathCost q ≤ Q) : RawKey Q := + restrictKey Q (modeKey iv q) (by simpa only [(modeKey_lengths iv q).1] using h) + (by simpa only [(modeKey_lengths iv q).2] using h) + +@[simp] theorem expand_constructionKey (Q : Nat) (iv : Digest32) (q : Coordinate) + (h : pathCost q ≤ Q) : expandKey (constructionKey Q iv q h) = modeKey iv q := by + exact expandKey_restrictKey _ _ _ _ + +/-- The simulator is an actual RO-query program, not a claimed query count. +Its queries are metered by the interpreter, and are not exposed to the caller. -/ +inductive ROProgram (Q : Nat) (Result : Type) where + | done (result : Result) + | ask (key : RawKey Q) (next : Digest32 → ROProgram Q Result) + +def runRO {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) : ROProgram Q Result → Result × Nat + | .done result => (result,0) + | .ask key next => + let r := runRO ro (next (ro key)) + (r.1,r.2+1) + +structure Simulator (Q : Nat) (Seed State : Type) where + initial : Seed → State + answer : State → Node → ROProgram Q (State × Digest32) + +def runIdeal {Q : Nat} {Seed State Result : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) : + (p : Program Result) → (remaining : Nat) → remaining ≤ Q → Counts remaining p → Execution Result + | .done r, _, _, _ => ⟨⟨[],r⟩,0,0,0⟩ + | .ask (.primitive purpose input) next, remaining, cap, counted => + let answer := runRO ro (sim.answer state input) + prepend (.primitive purpose input) answer.1.2 answer.2 + (runIdeal sim ro iv answer.1.1 (next answer.1.2) (remaining-1) (by omega) (counted.2 _)) + | .ask (.construction q valid) next, remaining, cap, counted => + let key := constructionKey Q iv q (by exact counted.1.trans cap) + let answer := ro key + prepend (.construction q valid) answer 0 + (runIdeal sim ro iv state (next answer) (remaining-pathCost q) (by omega) (counted.2 _)) + +theorem runIdeal_counts {Q : Nat} {Seed State Result : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (h : Counts remaining p) : + (runIdeal sim ro iv state p remaining cap h).primitiveCost ≤ remaining := by + induction p generalizing state remaining with + | done r => simp [runIdeal] + | ask q next ih => + cases q with + | primitive purpose input => + have hr := ih (runRO ro (sim.answer state input)).1.2 + (runRO ro (sim.answer state input)).1.1 (remaining-1) (by omega) (h.2 _) + simp only [runIdeal, prepend, Query.cost] + have hh : 1 ≤ remaining := h.1 + omega + | construction q valid => + have hr := ih (ro (constructionKey Q iv q (h.1.trans cap))) state + (remaining-pathCost q) (by omega) (h.2 _) + simp only [runIdeal, prepend, Query.cost] + have hh : pathCost q ≤ remaining := h.1 + omega + +/-- Classical real experiment: a uniformly sampled *public* compression table. +All direct and construction uses share it, including chosen chaining values. -/ +noncomputable def realProbability {AdvCoins Result : Type} [Fintype AdvCoins] + (iv : Digest32) (adversary : AdvCoins → Program Result) (D : View Result → Bool) : ℚ := by + classical + exact distinguishProbability + (fun coins : PrimitiveOracle × AdvCoins => (runReal coins.1 iv (adversary coins.2)).view) D + +/-- Classical ideal experiment: one uniformly sampled raw message/template RO +shared by construction requests and the stateful primitive simulator. -/ +noncomputable def idealProbability {Q : Nat} {Seed State AdvCoins Result : Type} + [Fintype Seed] [Fintype AdvCoins] (sim : Simulator Q Seed State) (iv : Digest32) + (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) + (D : View Result → Bool) : ℚ := by + classical + exact distinguishProbability + (fun coins : (RawKey Q → Digest32) × Seed × AdvCoins => + (runIdeal sim coins.1 iv (sim.initial coins.2.1) (adversary coins.2.2) Q (by omega) + (counted coins.2.2)).view) D + +noncomputable def concreteProbability {AdvCoins Result : Type} [Fintype AdvCoins] + (iv : Digest32) (adversary : AdvCoins → Program Result) (D : View Result → Bool) : ℚ := + distinguishProbability (fun a => (runReal blake2sOracle iv (adversary a)).view) D + +/-- Advantage in the actual public-compression construction/simulator games. -/ +noncomputable def ModeAdv {Q : Nat} {Seed State AdvCoins Result : Type} + [Fintype Seed] [Fintype AdvCoins] (sim : Simulator Q Seed State) (iv : Digest32) + (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) + (D : View Result → Bool) : ℚ := + |realProbability iv adversary D - idealProbability sim iv adversary counted D| + +/-- Precise remaining DMV18 Theorem 1 boundary for the proved concrete mode. +It is universally quantified over adaptive programs and view distinguishers, +not a PCS acceptance assertion. The actual simulator's RO calls are bounded. -/ +structure PublicRandomCompressionDMV (Q : Nat) (Seed State : Type) [Fintype Seed] + (sim : Simulator Q Seed State) (iv : Digest32) : Prop where + simulatorBound : ∀ (AdvCoins Result : Type) [Fintype AdvCoins] + (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) + (ro : RawKey Q → Digest32) (seed : Seed) (a : AdvCoins), + (runIdeal sim ro iv (sim.initial seed) (adversary a) Q (by omega) (counted a)).simulatorQueries ≤ Q + distinguishing : ∀ (AdvCoins Result : Type) [Fintype AdvCoins] + (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) + (D : View Result → Bool), + ModeAdv sim iv adversary counted D ≤ dmvLoss Q + +/-- An explicit concrete-primitive idealization game, with its own loss and +permitted computational class. No small bound for deterministic public BLAKE2s +is asserted: in particular this is not an unconditional random-oracle theorem. -/ +def ConcretePrimitiveGap (Q : Nat) (iv : Digest32) (loss : ℚ) + (Allowed : (AdvCoins : Type) → [Fintype AdvCoins] → (Result : Type) → + (AdvCoins → Program Result) → (View Result → Bool) → Prop) : Prop := + ∀ (AdvCoins Result : Type) [Fintype AdvCoins] (adversary : AdvCoins → Program Result) + (D : View Result → Bool), Allowed AdvCoins Result adversary D → + (∀ a, Counts Q (adversary a)) → + |concreteProbability iv adversary D - realProbability iv adversary D| ≤ loss + +/-- The structural prerequisites and executable construction equation are +checked facts, never fields in either external cryptographic assumption. -/ +theorem pinned_mode_structure : DMVConditions := dmv_conditions + +theorem real_construction_refines (oracle : PrimitiveOracle) (iv : Digest32) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) : + realAnswer oracle iv (.construction q valid) = evalPlan (compressionOf oracle) iv (DuplexEncoding.plan q) := + (plan_evaluate (compressionOf oracle) iv q).symm + +/-- Literal bounded raw-key encoding is injective on the exact checked +coordinate domain; no codec/framing bridge is an external assumption. -/ +theorem constructionKey_injective (Q : Nat) (iv : Digest32) + {a b : Coordinate} (ha : DuplexEncoding.Admissible a) (hb : DuplexEncoding.Admissible b) + (ca : pathCost a ≤ Q) (cb : pathCost b ≤ Q) + (same : constructionKey Q iv a ca = constructionKey Q iv b cb) : a = b := by + apply modeKey_injective iv ha hb + have h := congrArg expandKey same + simpa only [expand_constructionKey] using h + +/-- Any event of the full interaction view transfers. This theorem contains +no PCS relation and cannot supply or replace a caller's Counts certificate. -/ +theorem randomCompression_transfer {Q : Nat} {Seed State AdvCoins Result : Type} + [Fintype Seed] [Fintype AdvCoins] (sim : Simulator Q Seed State) (iv : Digest32) + (security : PublicRandomCompressionDMV Q Seed State sim iv) + (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) + (D : View Result → Bool) {bound : ℚ} + (ideal : idealProbability sim iv adversary counted D ≤ bound) : + realProbability iv adversary D ≤ bound + dmvLoss Q := by + have h := (abs_le.mp (security.distinguishing AdvCoins Result adversary counted D)).2 + linarith + +/-- The optional concrete-hash modeling gap is a *separate* public-primitive +game assumption and a separate additive term. It is never absorbed into DMV. -/ +theorem concrete_transfer {Q : Nat} {Seed State AdvCoins Result : Type} + [Fintype Seed] [Fintype AdvCoins] (sim : Simulator Q Seed State) (iv : Digest32) + (security : PublicRandomCompressionDMV Q Seed State sim iv) + (Allowed : (Coins : Type) → [Fintype Coins] → (Output : Type) → + (Coins → Program Output) → (View Output → Bool) → Prop) + {primitiveLoss bound : ℚ} (primitive : ConcretePrimitiveGap Q iv primitiveLoss Allowed) + (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) + (D : View Result → Bool) (permitted : Allowed AdvCoins Result adversary D) + (ideal : idealProbability sim iv adversary counted D ≤ bound) : + concreteProbability iv adversary D ≤ bound + dmvLoss Q + primitiveLoss := by + have hp := (abs_le.mp (primitive AdvCoins Result adversary D permitted counted)).2 + have hm := randomCompression_transfer sim iv security adversary counted D ideal + linarith + +/-- Force a construction's boxed instruction fold once at the data-valued +execution boundary. Merely returning a Digest32 from realAnswer permits the +compiler to defer the entire construction until each individual byte lookup. -/ +def runRealStored {Result : Type} (oracle : PrimitiveOracle) (iv : Digest32) : + Program Result → Execution Result + | .done r => ⟨⟨[],r⟩,0,0,0⟩ + | .ask (.primitive purpose input) next => + let answer := oracle input + prepend (.primitive purpose input) answer 0 (runRealStored oracle iv (next answer)) + | .ask (.construction q valid) next => + DuplexFraming.withCoordinate (compressionOf oracle) iv q fun answer => + prepend (.construction q valid) answer 0 (runRealStored oracle iv (next answer)) + +@[csimp] theorem runReal_stored : @runReal = @runRealStored := by + funext Result oracle iv program + induction program with + | done r => rfl + | ask q next ih => + cases q <;> simp only [runReal,runRealStored,realAnswer, + DuplexFraming.withCoordinate_eq,ih] + +end Whir.DuplexModeGame diff --git a/verification/whir/Whir/DuplexPublicSimulator.lean b/verification/whir/Whir/DuplexPublicSimulator.lean new file mode 100644 index 000000000..b9bc76952 --- /dev/null +++ b/verification/whir/Whir/DuplexPublicSimulator.lean @@ -0,0 +1,1242 @@ +import Whir.DuplexModeGame + +/-! The deterministic, public-log part of radicalExtend. The private randomness +is a finite-domain fallback table, never a source of raw-query coordinates. +Output collisions choose the first matching public record. The stochastic DMV +coupling and its bad-event probability remain an external theorem. -/ +namespace Whir.DuplexPublicSimulator +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame + +abbrev PublicLog := List (Node × Digest32) +abbrev Seed := Node → Digest32 + +instance : DecidableEq Node := fun a b => + if h : (a.cv,a.block,a.tweak,a.last) = (b.cv,b.block,b.tweak,b.last) then + isTrue (by cases a; cases b; simpa using h) + else isFalse (fun e => h (by cases e; rfl)) + +/-- Newest record wins; every public primitive answer, including a repeated +input, is recorded. Construction answers are not primitive records. -/ +def observe (log : PublicLog) (input : Node) (answer : Digest32) : PublicLog := + (input,answer) :: log + +def lookup (log : PublicLog) (input : Node) : Option Digest32 := + (log.find? (fun e => decide (e.1 = input))).map Prod.snd + +def predecessor (log : PublicLog) (cv : Digest32) : Option Node := + (log.find? (fun e => decide (e.2 = cv))).map Prod.fst + +/-- Fuel counts prior public calls, not the private raw-oracle budget. Complete +chains retain the entire seed input; only nonseed CVs are chaining pointers. -/ +def extend (log : PublicLog) : Nat → Digest32 → Option (List Node) + | 0, _ => none + | fuel+1, cv => + match predecessor log cv with + | none => none + | some n => + if isSeed n then some [n] + else if isInternal n then (extend log fuel n.cv).map (n :: ·) + else none + +def recognized (log : PublicLog) (input : Node) : Option (List Node) := + if isTerminal input then (extend log log.length input.cv).map (input :: ·) + else none + +theorem extend_sound {log : PublicLog} {fuel : Nat} {cv : Digest32} {ns : List Node} + (h : extend log fuel cv = some ns) : Body ns ∧ ns.length ≤ fuel := by + induction fuel generalizing cv ns with + | zero => simp [extend] at h + | succ fuel ih => + simp only [extend] at h + cases hp : predecessor log cv with + | none => simp [hp] at h + | some n => + simp only [hp] at h + split at h + · simp only [Option.some.injEq] at h + subst ns + exact ⟨Body.seed (by assumption), by simp⟩ + · split at h + · cases he : extend log fuel n.cv with + | none => simp [he] at h + | some rest => + simp only [he, Option.map_some, Option.some.injEq] at h + subst ns + obtain ⟨hb, hl⟩ := ih he + exact ⟨Body.step (by assumption) hb, by simpa using Nat.succ_le_succ hl⟩ + · simp at h + +theorem recognized_sound {log : PublicLog} {input : Node} {ns : List Node} + (h : recognized log input = some ns) : Complete ns ∧ ns.length ≤ log.length+1 := by + unfold recognized at h + split at h + · cases he : extend log log.length input.cv with + | none => simp [he] at h + | some rest => + simp only [he, Option.map_some, Option.some.injEq] at h + subst ns + obtain ⟨hb, hl⟩ := extend_sound he + exact ⟨⟨input,rest,rfl,by assumption,hb⟩, by simpa using Nat.succ_le_succ hl⟩ + · simp at h + +/-- The length check only totalizes the API on unreachable oversized logs. +`privateKey_of_recognized` proves it cannot drop a tree in a counted run. -/ +def privateKey (Q : Nat) (log : PublicLog) (input : Node) : Option (RawKey Q) := + if (lookup log input).isSome then none else + match recognized log input with + | none => none + | some ns => + if h : ns.length ≤ Q then + some (restrictKey Q ⟨ns.map payload, ns.map (fun n => (n.tweak,n.last))⟩ + (by simpa using h) (by simpa using h)) + else none + +theorem privateKey_of_recognized {Q : Nat} {log : PublicLog} {input : Node} {ns : List Node} + (fresh : lookup log input = none) (tree : recognized log input = some ns) + (budget : log.length+1 ≤ Q) : + ∃ key, privateKey Q log input = some key ∧ extract ns = some (expandKey key) := by + have hs := recognized_sound tree + have hl : ns.length ≤ Q := hs.2.trans budget + simp only [privateKey, fresh, Option.isSome_none, Bool.false_eq_true, ↓reduceIte, tree, hl] + refine ⟨_, rfl, ?_⟩ + simp [extract, (complete?_correct ns).mpr hs.1] + +theorem privateKey_sound {Q : Nat} {log : PublicLog} {input : Node} {key : RawKey Q} + (h : privateKey Q log input = some key) : + ∃ ns, recognized log input = some ns ∧ Complete ns ∧ extract ns = some (expandKey key) := by + unfold privateKey at h + split at h + · simp at h + · cases hr : recognized log input with + | none => simp [hr] at h + | some ns => + simp only [hr] at h + split at h + · simp only [Option.some.injEq] at h + subst key + refine ⟨ns,rfl,(recognized_sound hr).1,?_⟩ + simp [extract, (complete?_correct ns).mpr (recognized_sound hr).1] + · simp at h + +theorem privateKey_lengths_log {Q : Nat} {log : PublicLog} {input : Node} {key : RawKey Q} + (h : privateKey Q log input = some key) : + key.1.1.val ≤ log.length+1 ∧ key.2.1.val ≤ log.length+1 := by + unfold privateKey at h + split at h + · simp at h + · cases hr : recognized log input with + | none => simp [hr] at h + | some ns => + simp only [hr] at h + split at h + · simp only [Option.some.injEq] at h + subst key + simpa [restrictKey, shortList] using + And.intro (recognized_sound hr).2 (recognized_sound hr).2 + · simp at h + +structure State where + seed : Seed + publicLog : PublicLog + +def simulator (Q : Nat) : Simulator Q Seed State where + initial seed := ⟨seed,[]⟩ + answer state input := + match lookup state.publicLog input with + | some answer => .done (⟨state.seed,observe state.publicLog input answer⟩,answer) + | none => + match privateKey Q state.publicLog input with + | some key => .ask key (fun answer => + .done (⟨state.seed,observe state.publicLog input answer⟩,answer)) + | none => + let answer := state.seed input + .done (⟨state.seed,observe state.publicLog input answer⟩,answer) + +theorem repeated_no_query (Q : Nat) (state : State) (input : Node) (answer : Digest32) + (h : lookup state.publicLog input = some answer) : + (simulator Q).answer state input = + .done (⟨state.seed,observe state.publicLog input answer⟩,answer) := by + simp [simulator, h] + +theorem answer_publicLog (Q : Nat) (ro : RawKey Q → Digest32) (state : State) (input : Node) : + (runRO ro ((simulator Q).answer state input)).1.1.publicLog = + observe state.publicLog input (runRO ro ((simulator Q).answer state input)).1.2 := by + simp only [simulator] + cases lookup state.publicLog input <;> simp only + · cases privateKey Q state.publicLog input <;> rfl + · rfl + +theorem answer_seed (Q : Nat) (ro : RawKey Q → Digest32) (state : State) (input : Node) : + (runRO ro ((simulator Q).answer state input)).1.1.seed = state.seed := by + simp only [simulator] + cases lookup state.publicLog input <;> simp only + · cases privateKey Q state.publicLog input <;> rfl + · rfl + +theorem answer_queries_le_one (Q : Nat) (ro : RawKey Q → Digest32) (state : State) (input : Node) : + (runRO ro ((simulator Q).answer state input)).2 ≤ 1 := by + simp only [simulator] + cases lookup state.publicLog input <;> simp only + · cases privateKey Q state.publicLog input <;> simp [runRO] + · simp [runRO] + +theorem simulatorBound {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) (iv : Digest32) + (state : State) (p : Program Result) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining p) : + (runIdeal (simulator Q) ro iv state p remaining cap counted).simulatorQueries ≤ remaining := by + induction p generalizing state remaining with + | done r => simp [runIdeal] + | ask query next ih => + cases query with + | primitive purpose input => + have hr := ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 (remaining-1) (by omega) (counted.2 _) + have ha := answer_queries_le_one Q ro state input + have hc : 1 ≤ remaining := counted.1 + simp only [runIdeal, prepend] + omega + | construction q valid => + have hr := ih (ro (constructionKey Q iv q (counted.1.trans cap))) state + (remaining-pathCost q) (by omega) (counted.2 _) + simp only [runIdeal, prepend] + omega + +/-- Private schedule from public data alone. This includes direct construction +requests, in their actual order; construction replies never enter the log. -/ +def replay (Q : Nat) (iv : Digest32) (log : PublicLog) : List Observation → List (RawKey Q) + | [] => [] + | ⟨.primitive _ input,answer⟩ :: rest => + (privateKey Q log input).toList ++ replay Q iv (observe log input answer) rest + | ⟨.construction q _,_⟩ :: rest => + if h : pathCost q ≤ Q then constructionKey Q iv q h :: replay Q iv log rest + else replay Q iv log rest + +/-- Instrumentation of actual RO programs, used only for the replay theorem. -/ +def requests {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) : ROProgram Q Result → List (RawKey Q) + | .done _ => [] + | .ask key next => key :: requests ro (next (ro key)) + +theorem answer_requests (Q : Nat) (ro : RawKey Q → Digest32) (state : State) (input : Node) : + requests ro ((simulator Q).answer state input) = (privateKey Q state.publicLog input).toList := by + cases h : lookup state.publicLog input with + | none => + simp only [simulator, h] + cases privateKey Q state.publicLog input <;> rfl + | some answer => simp [simulator, h, requests, privateKey] + +def actualRequests {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) (iv : Digest32) + (state : State) : (p : Program Result) → (remaining : Nat) → remaining ≤ Q → + Counts remaining p → List (RawKey Q) + | .done _, _, _, _ => [] + | .ask (.primitive _ input) next, remaining, cap, counted => + let answer := runRO ro ((simulator Q).answer state input) + requests ro ((simulator Q).answer state input) ++ + actualRequests ro iv answer.1.1 (next answer.1.2) (remaining-1) (by omega) (counted.2 _) + | .ask (.construction q _) next, remaining, cap, counted => + let key := constructionKey Q iv q (counted.1.trans cap) + key :: actualRequests ro iv state (next (ro key)) (remaining-pathCost q) (by omega) (counted.2 _) + +theorem replay_actual {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) (iv : Digest32) + (state : State) (p : Program Result) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining p) : + replay Q iv state.publicLog (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations = + actualRequests ro iv state p remaining cap counted := by + induction p generalizing state remaining with + | done r => rfl + | ask query next ih => + cases query with + | primitive purpose input => + simp only [runIdeal, prepend, replay, actualRequests, answer_requests] + rw [← answer_publicLog Q ro state input] + exact congrArg ((privateKey Q state.publicLog input).toList ++ ·) + (ih _ _ _ _ _) + | construction q valid => + have hq : pathCost q ≤ Q := counted.1.trans cap + simp only [runIdeal, prepend, replay, actualRequests, hq, ↓reduceDIte] + exact congrArg (constructionKey Q iv q hq :: ·) (ih _ _ _ _ _) + +/-- Collision ambiguity is the ordinary event that distinct primitive inputs +have the same full 256-bit output. Repeated records are not ambiguities. -/ +def OutputCollision (log : PublicLog) : Prop := + ∃ n m d, (n,d) ∈ log ∧ (m,d) ∈ log ∧ n ≠ m + +theorem predecessor_mem {log : PublicLog} {cv : Digest32} {n : Node} + (h : predecessor log cv = some n) : (n,cv) ∈ log := by + induction log with + | nil => simp [predecessor] at h + | cons entry rest ih => + rcases entry with ⟨m,d⟩ + by_cases hd : d = cv + · simp [predecessor, List.find?, hd] at h + subst n; subst d; simp + · have ht : predecessor rest cv = some n := by + simpa [predecessor, List.find?, hd] using h + exact List.mem_cons_of_mem _ (ih ht) + +theorem predecessor_of_mem {log : PublicLog} (clean : ¬OutputCollision log) + {n : Node} {cv : Digest32} (member : (n,cv) ∈ log) : + predecessor log cv = some n := by + induction log with + | nil => simp at member + | cons entry rest ih => + rcases entry with ⟨m,d⟩ + by_cases hd : d = cv + · have same : m = n := by + by_contra hn + exact clean ⟨m,n,cv,by simp [hd],member,hn⟩ + simp [predecessor, List.find?, hd, same] + · have hm : (n,cv) ∈ rest := by + rcases List.mem_cons.mp member with he | he + · cases he; exact False.elim (hd rfl) + · exact he + have hc : ¬OutputCollision rest := by + rintro ⟨a,b,e,ha,hb,hn⟩ + exact clean ⟨a,b,e,List.mem_cons_of_mem _ ha,List.mem_cons_of_mem _ hb,hn⟩ + simpa [predecessor, List.find?, hd] using ih hc hm + +/-- Full-CV links are witnessed by actual primitive input/output records. -/ +inductive PublicBody (log : PublicLog) : Digest32 → List Node → Prop where + | seed {n d} : (n,d) ∈ log → isSeed n → PublicBody log d [n] + | step {n d ns} : (n,d) ∈ log → isInternal n → + PublicBody log n.cv ns → PublicBody log d (n :: ns) + +theorem PublicBody.body {log : PublicLog} {cv : Digest32} {ns : List Node} + (h : PublicBody log cv ns) : Body ns := by + induction h with + | seed _ hs => exact Body.seed hs + | step _ hi _ ih => exact Body.step hi ih + +theorem PublicBody.members {log : PublicLog} {cv : Digest32} {ns : List Node} + (h : PublicBody log cv ns) : ∀ n ∈ ns, n ∈ log.map Prod.fst := by + induction h with + | seed hm _ => + intro n hn + simp only [List.mem_singleton] at hn + subst n + exact List.mem_map.mpr ⟨_,hm,rfl⟩ + | step hm _ _ ih => + intro n hn + rcases List.mem_cons.mp hn with rfl | hn + · exact List.mem_map.mpr ⟨_,hm,rfl⟩ + · exact ih n hn + +theorem extend_publicBody {log : PublicLog} {fuel : Nat} {cv : Digest32} {ns : List Node} + (h : extend log fuel cv = some ns) : PublicBody log cv ns := by + induction fuel generalizing cv ns with + | zero => simp [extend] at h + | succ fuel ih => + simp only [extend] at h + cases hp : predecessor log cv with + | none => simp [hp] at h + | some n => + simp only [hp] at h + split at h + · simp only [Option.some.injEq] at h + subst ns + exact PublicBody.seed (predecessor_mem hp) (by assumption) + · split at h + · cases he : extend log fuel n.cv with + | none => simp [he] at h + | some rest => + simp only [he, Option.map_some, Option.some.injEq] at h + subst ns + exact PublicBody.step (predecessor_mem hp) (by assumption) (ih he) + · simp at h + +theorem PublicBody.compression {log : PublicLog} {cv : Digest32} {ns : List Node} + (h : PublicBody log cv ns) (oracle : PrimitiveOracle) + (consistent : ∀ n d, (n,d) ∈ log → oracle n = d) : + Tree (compressionOf oracle) cv ns := by + induction h with + | seed hm hs => + have he := consistent _ _ hm + simpa [nodeValue, compressionOf, he] using Tree.seed (c := compressionOf oracle) _ hs + | step hm hi _ ih => + have he := consistent _ _ hm + simpa [nodeValue, compressionOf, he] using Tree.step _ _ hi ih + +/-- On collision-free logs, radicalExtend follows every supplied full-CV link, +not block heuristics, a fixed IV, or private simulator state. -/ +theorem extend_complete {log : PublicLog} (clean : ¬OutputCollision log) + {cv : Digest32} {ns : List Node} (tree : PublicBody log cv ns) + (fuel : Nat) (bound : ns.length ≤ fuel) : extend log fuel cv = some ns := by + induction tree generalizing fuel with + | seed hm hs => + cases fuel with + | zero => simp at bound + | succ fuel => simp [extend, predecessor_of_mem clean hm, hs] + | step hm hi child ih => + cases fuel with + | zero => simp at bound + | succ fuel => + have hn : ¬isSeed _ := fun hs => seed_not_internal hs hi + simp only [extend, predecessor_of_mem clean hm, hn, ↓reduceIte, hi] + rw [ih fuel (by simpa using bound)] + rfl + +/-- The counted public program, not an assumed raw-query budget, supplies fuel +and the key-length bound at every primitive call of the actual run. -/ +def BudgetSafe {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) (iv : Digest32) + (state : State) : (p : Program Result) → (remaining : Nat) → remaining ≤ Q → + Counts remaining p → Prop + | .done _, _, _, _ => True + | .ask (.primitive _ input) next, remaining, cap, counted => + state.publicLog.length+1 ≤ Q ∧ + let answer := runRO ro ((simulator Q).answer state input) + BudgetSafe ro iv answer.1.1 (next answer.1.2) (remaining-1) (by omega) (counted.2 _) + | .ask (.construction q _) next, remaining, cap, counted => + let key := constructionKey Q iv q (counted.1.trans cap) + BudgetSafe ro iv state (next (ro key)) (remaining-pathCost q) (by omega) (counted.2 _) + +theorem budgetSafe {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) (iv : Digest32) + (state : State) (p : Program Result) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining p) (budget : state.publicLog.length + remaining ≤ Q) : + BudgetSafe ro iv state p remaining cap counted := by + induction p generalizing state remaining with + | done r => trivial + | ask query next ih => + cases query with + | primitive purpose input => + have hc : 1 ≤ remaining := counted.1 + refine ⟨by omega, ih _ _ _ _ _ ?_⟩ + rw [answer_publicLog] + simp only [observe, List.length_cons] + omega + | construction q valid => + exact ih _ _ _ _ _ (by omega) + +theorem initial_budgetSafe {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (seed : Seed) (p : Program Result) (counted : Counts Q p) : + BudgetSafe ro iv ((simulator Q).initial seed) p Q (by omega) counted := + budgetSafe ro iv _ p Q (by omega) counted (by simp [simulator]) + +def Functional (log : PublicLog) : Prop := + ∀ n a b, (n,a) ∈ log → (n,b) ∈ log → a = b + +theorem PublicBody.unique {log : PublicLog} (clean : ¬OutputCollision log) + {cv : Digest32} {ns ms : List Node} (a : PublicBody log cv ns) (b : PublicBody log cv ms) : + ns = ms := by + have ha := extend_complete clean a (ns.length+ms.length) (by omega) + have hb := extend_complete clean b (ns.length+ms.length) (by omega) + exact Option.some.inj (ha.symm.trans hb) + +theorem PublicBody.subtree {log : PublicLog} {cv : Digest32} {ns : List Node} + (tree : PublicBody log cv ns) {n : Node} (member : n ∈ ns) : + ∃ d rest, (n,d) ∈ log ∧ PublicBody log d (n :: rest) ∧ (n :: rest).length ≤ ns.length := by + induction tree with + | seed hm hs => + simp only [List.mem_singleton] at member + subst n + exact ⟨_,[],hm,PublicBody.seed hm hs,le_rfl⟩ + | step hm hi child ih => + rcases List.mem_cons.mp member with rfl | member + · exact ⟨_,_,hm,PublicBody.step hm hi child,le_rfl⟩ + · obtain ⟨d,rest,hm,ht,hl⟩ := ih member + exact ⟨d,rest,hm,ht,by simp only [List.length_cons] at *; omega⟩ + +theorem PublicBody.nodup {log : PublicLog} (functional : Functional log) + (clean : ¬OutputCollision log) {cv : Digest32} {ns : List Node} + (tree : PublicBody log cv ns) : ns.Nodup := by + induction tree with + | seed _ _ => simp + | @step n d ns hm hi child ih => + refine List.nodup_cons.mpr ⟨?_,ih⟩ + intro member + obtain ⟨d',rest,hm',ht,hl⟩ := child.subtree member + have hd := functional n d d' hm hm' + subst d' + have he := PublicBody.unique clean (PublicBody.step hm hi child) ht + have he' := congrArg List.length he + simp only [List.length_cons] at * + omega + +theorem PublicBody.length_le {log : PublicLog} (functional : Functional log) + (clean : ¬OutputCollision log) {cv : Digest32} {ns : List Node} + (tree : PublicBody log cv ns) : ns.length ≤ log.length := by + have h := List.Nodup.length_le_of_subset (tree.nodup functional clean) tree.members + simpa using h + +/-- No complete, publicly linked tree is lost to traversal fuel on an ordinary +functional, collision-free oracle log. Cyclic or ambiguous logs are outside this +structural theorem, not silently declared good by the simulator. -/ +theorem recognized_complete {log : PublicLog} (functional : Functional log) + (clean : ¬OutputCollision log) {input : Node} (terminal : isTerminal input) + {ns : List Node} (tree : PublicBody log input.cv ns) : + recognized log input = some (input :: ns) := by + simp only [recognized, terminal, ↓reduceIte] + rw [extend_complete clean tree log.length (tree.length_le functional clean)] + rfl + +theorem lookup_mem {log : PublicLog} {n : Node} {d : Digest32} + (h : lookup log n = some d) : (n,d) ∈ log := by + induction log with + | nil => simp [lookup] at h + | cons entry rest ih => + rcases entry with ⟨m,e⟩ + by_cases hn : m = n + · simp [lookup, List.find?, hn] at h + subst m; subst d; simp + · have ht : lookup rest n = some d := by simpa [lookup, List.find?, hn] using h + exact List.mem_cons_of_mem _ (ih ht) + +theorem lookup_exists {log : PublicLog} {n : Node} {d : Digest32} + (member : (n,d) ∈ log) : ∃ e, lookup log n = some e := by + induction log with + | nil => simp at member + | cons entry rest ih => + rcases entry with ⟨m,e⟩ + by_cases hn : m = n + · exact ⟨e,by simp [lookup, List.find?, hn]⟩ + · have hm : (n,d) ∈ rest := by + rcases List.mem_cons.mp member with he | he + · cases he; exact False.elim (hn rfl) + · exact he + obtain ⟨e,he⟩ := ih hm + exact ⟨e,by simpa [lookup, List.find?, hn] using he⟩ + +theorem observe_functional {log : PublicLog} (functional : Functional log) + (n : Node) (d : Digest32) (agree : ∀ e, (n,e) ∈ log → d = e) : + Functional (observe log n d) := by + intro m a b ha hb + rcases List.mem_cons.mp ha with ha | ha + · cases ha + rcases List.mem_cons.mp hb with hb | hb + · cases hb; rfl + · exact agree _ hb + · rcases List.mem_cons.mp hb with hb | hb + · cases hb; exact (agree _ ha).symm + · exact functional _ _ _ ha hb + +theorem answer_functional (Q : Nat) (ro : RawKey Q → Digest32) (state : State) + (input : Node) (functional : Functional state.publicLog) : + Functional (runRO ro ((simulator Q).answer state input)).1.1.publicLog := by + rw [answer_publicLog] + apply observe_functional functional + intro e member + obtain ⟨d,hd⟩ := lookup_exists member + rw [repeated_no_query Q state input d hd] + exact functional input d e (lookup_mem hd) member + +/-- Explicit finite private seed table; no state is added to `Mode.View`. -/ +@[instance_reducible] +noncomputable def seedFintype : Fintype Seed := by + letI : Finite UInt64 := Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective + let fields : Node → Digest32 × Block64 × UInt64 × Bool := + fun n => (n.cv,n.block,n.tweak,n.last) + have inj : Function.Injective fields := by + intro a b h + cases a; cases b + simpa [fields] using h + letI : Finite Node := Finite.of_injective fields inj + exact Fintype.ofFinite Seed + +/-- Only the probabilistic distinguishing inequality remains external. The +simulator is fixed, its public reconstruction is checked, and the private-call +bound is a theorem rather than a field supplied by the cryptographic premise. -/ +theorem security_of_distinguishing (Q : Nat) (iv : Digest32) + (distinguishing : letI := seedFintype + ∀ (AdvCoins Result : Type) [Fintype AdvCoins] + (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) + (D : View Result → Bool), + ModeAdv (simulator Q) iv adversary counted D ≤ dmvLoss Q) : + letI := seedFintype + PublicRandomCompressionDMV Q Seed State (simulator Q) iv := by + let := seedFintype + exact ⟨fun _ _ _ adversary counted ro seed a => + simulatorBound ro iv _ (adversary a) Q (by omega) (counted a), distinguishing⟩ + +theorem recognized_publicBody {log : PublicLog} {input : Node} {ns : List Node} + (h : recognized log input = some ns) : + ∃ rest, ns = input :: rest ∧ PublicBody log input.cv rest := by + unfold recognized at h + split at h + · cases he : extend log log.length input.cv with + | none => simp [he] at h + | some rest => + simp only [he, Option.map_some, Option.some.injEq] at h + exact ⟨rest,h.symm,extend_publicBody he⟩ + · simp at h + +theorem privateKey_compression {Q : Nat} {log : PublicLog} {input : Node} {key : RawKey Q} + (h : privateKey Q log input = some key) (oracle : PrimitiveOracle) + (consistent : ∀ n d, (n,d) ∈ log → oracle n = d) : + ∃ rest, Complete (input :: rest) ∧ Tree (compressionOf oracle) input.cv rest ∧ + extract (input :: rest) = some (expandKey key) := by + obtain ⟨ns,hr,hc,he⟩ := privateKey_sound h + obtain ⟨rest,rfl,ht⟩ := recognized_publicBody hr + exact ⟨rest,hc,ht.compression oracle consistent,he⟩ + +/-- Exact canonical fresh-terminal behavior under checked structural +prerequisites, including arbitrary chosen/cloned seed CVs. -/ +theorem canonical_terminal {Q : Nat} (state : State) (input : Node) + (functional : Functional state.publicLog) (clean : ¬OutputCollision state.publicLog) + (fresh : lookup state.publicLog input = none) (terminal : isTerminal input) + {ns : List Node} (tree : PublicBody state.publicLog input.cv ns) + (budget : state.publicLog.length+1 ≤ Q) : + ∃ key, extract (input :: ns) = some (expandKey key) ∧ + (simulator Q).answer state input = + .ask key (fun answer => .done (⟨state.seed,observe state.publicLog input answer⟩,answer)) := by + obtain ⟨key,hk,he⟩ := privateKey_of_recognized fresh + (recognized_complete functional clean terminal tree) budget + exact ⟨key,he,by simp [simulator,fresh,hk]⟩ + +theorem same_public_schedule (Q : Nat) (ro : RawKey Q → Digest32) + (a b : State) (input : Node) (same : a.publicLog = b.publicLog) : + requests ro ((simulator Q).answer a input) = requests ro ((simulator Q).answer b input) := by + simp only [answer_requests, same] + +/-- Ordered public-derived raw requests paired with their public answers. +Cached and incomplete primitive calls produce no pair. -/ +def replayAnswers (Q : Nat) (iv : Digest32) (log : PublicLog) : + List Observation → List (RawKey Q × Digest32) + | [] => [] + | ⟨.primitive _ input,answer⟩ :: rest => + ((privateKey Q log input).toList.map (fun key => (key,answer))) ++ + replayAnswers Q iv (observe log input answer) rest + | ⟨.construction q _,answer⟩ :: rest => + if h : pathCost q ≤ Q then (constructionKey Q iv q h,answer) :: replayAnswers Q iv log rest + else replayAnswers Q iv log rest + +theorem replayAnswers_keys (Q : Nat) (iv : Digest32) (log : PublicLog) + (observations : List Observation) : + (replayAnswers Q iv log observations).map Prod.fst = replay Q iv log observations := by + induction observations generalizing log with + | nil => rfl + | cons observation rest ih => + rcases observation with ⟨query,answer⟩ + cases query with + | primitive purpose input => + simp only [replayAnswers, replay, List.map_append, List.map_map, ih] + cases privateKey Q log input <;> rfl + | construction q valid => + by_cases h : pathCost q ≤ Q <;> simp [replayAnswers, replay, h, ih] + +theorem answer_privateKey {Q : Nat} (ro : RawKey Q → Digest32) + (state : State) (input : Node) (key : RawKey Q) + (h : privateKey Q state.publicLog input = some key) : + (runRO ro ((simulator Q).answer state input)).1.2 = ro key := by + cases hl : lookup state.publicLog input with + | none => simp [simulator, hl, h, runRO] + | some answer => simp [privateKey, hl] at h + +theorem replayAnswers_consistent {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program Result) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) : + ∀ entry ∈ replayAnswers Q iv state.publicLog + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations, + entry.2 = ro entry.1 := by + induction p generalizing state remaining with + | done r => simp [runIdeal, replayAnswers] + | ask query next ih => + cases query with + | primitive purpose input => + simp only [runIdeal, prepend, replayAnswers] + intro entry member + rcases List.mem_append.mp member with member | member + · cases hk : privateKey Q state.publicLog input with + | none => simp [hk] at member + | some key => + simp only [hk, Option.toList_some, List.map_cons, List.map_nil, + List.mem_singleton] at member + subst entry + exact answer_privateKey ro state input key hk + · exact ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 (remaining-1) + (by omega) (counted.2 _) entry (by simpa only [answer_publicLog] using member) + | construction q valid => + have hq : pathCost q ≤ Q := counted.1.trans cap + simp only [runIdeal, prepend, replayAnswers, hq, ↓reduceDIte] + intro entry member + rcases List.mem_cons.mp member with rfl | member + · rfl + · exact ih _ _ _ _ _ entry member + +/-- Source accounting is independent of the ambient finite raw-key domain and +the interpreter's remaining meter. This allows a short source prefix to be +embedded in a larger experiment without inflating backfill path bounds. -/ +theorem replayAnswers_lengths {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program Result) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (sourceBudget sourceRemaining : Nat) (sourceCounted : Counts sourceRemaining p) + (budget : state.publicLog.length + sourceRemaining ≤ sourceBudget) : + ∀ entry ∈ replayAnswers Q iv state.publicLog + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations, + entry.1.1.1.val ≤ sourceBudget ∧ entry.1.2.1.val ≤ sourceBudget := by + induction p generalizing state remaining sourceRemaining with + | done r => simp [runIdeal, replayAnswers] + | ask query next ih => + cases query with + | primitive purpose input => + have hc : 1 ≤ sourceRemaining := sourceCounted.1 + simp only [runIdeal, prepend, replayAnswers] + intro entry member + rcases List.mem_append.mp member with member | member + · cases hk : privateKey Q state.publicLog input with + | none => simp [hk] at member + | some key => + simp only [hk, Option.toList_some, List.map_cons, List.map_nil, + List.mem_singleton] at member + subst entry + have hl := privateKey_lengths_log hk + dsimp only + exact ⟨by omega,by omega⟩ + · have hb : (runRO ro ((simulator Q).answer state input)).1.1.publicLog.length + + (sourceRemaining-1) ≤ sourceBudget := by + rw [answer_publicLog] + simp only [observe, List.length_cons] + omega + exact ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 (remaining-1) (by omega) + (counted.2 _) (sourceRemaining-1) (sourceCounted.2 _) hb entry + (by simpa only [answer_publicLog] using member) + | construction q valid => + have hq : pathCost q ≤ Q := counted.1.trans cap + have hs : pathCost q ≤ sourceRemaining := sourceCounted.1 + simp only [runIdeal, prepend, replayAnswers, hq, ↓reduceDIte] + intro entry member + rcases List.mem_cons.mp member with rfl | member + · simp only [constructionKey, restrictKey, shortList, + (modeKey_lengths iv q).1, (modeKey_lengths iv q).2] + exact ⟨by omega,by omega⟩ + · exact ih _ state (remaining-pathCost q) (by omega) (counted.2 _) + (sourceRemaining-pathCost q) (sourceCounted.2 _) (by omega) entry member + +theorem replayAnswers_source_bound {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (seed : Seed) (p : Program Result) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (sourceBudget : Nat) (sourceCounted : Counts sourceBudget p) : + ∀ entry ∈ replayAnswers Q iv [] + (runIdeal (simulator Q) ro iv ((simulator Q).initial seed) p remaining cap counted).view.observations, + entry.1.1.1.val ≤ sourceBudget ∧ entry.1.2.1.val ≤ sourceBudget := + replayAnswers_lengths ro iv ((simulator Q).initial seed) p remaining cap counted + sourceBudget sourceBudget sourceCounted (by simp [simulator]) + +/-- Fold only public primitive observations; neither raw tables nor private +simulator state are arguments of seed reconstruction. -/ +def finalLog (log : PublicLog) : List Observation → PublicLog + | [] => log + | ⟨.primitive _ input,answer⟩ :: rest => finalLog (observe log input answer) rest + | ⟨.construction _ _,_⟩ :: rest => finalLog log rest + +def fallbackFromLog (log : PublicLog) : Seed := + fun input => (lookup log input).getD zeroDigest + +def reconstructSeed (observations : List Observation) : Seed := + fallbackFromLog (finalLog [] observations) + +theorem finalLog_contains (log : PublicLog) (observations : List Observation) : + ∀ entry ∈ log, entry ∈ finalLog log observations := by + induction observations generalizing log with + | nil => exact fun _ h => h + | cons observation rest ih => + rcases observation with ⟨query,answer⟩ + cases query with + | primitive purpose input => exact fun _ h => ih _ _ (List.mem_cons_of_mem _ h) + | construction q valid => exact ih log + +theorem finalLog_functional {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program Result) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) (functional : Functional state.publicLog) : + Functional (finalLog state.publicLog + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations) := by + induction p generalizing state remaining with + | done r => exact functional + | ask query next ih => + cases query with + | primitive purpose input => + simpa only [runIdeal, prepend, finalLog, answer_publicLog] using + ih _ _ _ _ _ (answer_functional Q ro state input functional) + | construction q valid => exact ih _ _ _ _ _ functional + +theorem fallbackFromLog_of_mem {log : PublicLog} (functional : Functional log) + {input : Node} {answer : Digest32} (member : (input,answer) ∈ log) : + fallbackFromLog log input = answer := by + obtain ⟨d,hd⟩ := lookup_exists member + have he := functional input d answer (lookup_mem hd) member + simp [fallbackFromLog, hd, he] + +/-- Agreement is required only where the actual execution consumes fallback +randomness. Complete-tree and cached inputs impose no seed equality premise. -/ +def FallbackAgreement {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (replacement : Seed) (state : State) : + (p : Program Result) → (remaining : Nat) → remaining ≤ Q → Counts remaining p → Prop + | .done _, _, _, _ => True + | .ask (.primitive _ input) next, remaining, cap, counted => + (lookup state.publicLog input = none → privateKey Q state.publicLog input = none → + replacement input = state.seed input) ∧ + let answer := runRO ro ((simulator Q).answer state input) + FallbackAgreement ro iv replacement answer.1.1 (next answer.1.2) + (remaining-1) (by omega) (counted.2 _) + | .ask (.construction q _) next, remaining, cap, counted => + let key := constructionKey Q iv q (counted.1.trans cap) + FallbackAgreement ro iv replacement state (next (ro key)) + (remaining-pathCost q) (by omega) (counted.2 _) + +theorem fallbackAgreement_from_log {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program Result) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) (log : PublicLog) + (functional : Functional log) + (recorded : ∀ entry ∈ finalLog state.publicLog + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations, entry ∈ log) : + FallbackAgreement ro iv (fallbackFromLog log) state p remaining cap counted := by + induction p generalizing state remaining with + | done r => trivial + | ask query next ih => + cases query with + | primitive purpose input => + have recorded' : ∀ entry ∈ finalLog (runRO ro ((simulator Q).answer state input)).1.1.publicLog + (runIdeal (simulator Q) ro iv (runRO ro ((simulator Q).answer state input)).1.1 + (next (runRO ro ((simulator Q).answer state input)).1.2) + (remaining-1) (by omega) (counted.2 _)).view.observations, entry ∈ log := by + simpa only [runIdeal, prepend, finalLog, answer_publicLog] using recorded + refine ⟨?_,ih _ _ _ _ _ recorded'⟩ + intro fresh incomplete + have member : (input,state.seed input) ∈ + (runRO ro ((simulator Q).answer state input)).1.1.publicLog := by + simp [simulator, fresh, incomplete, runRO, observe] + exact fallbackFromLog_of_mem functional + (recorded' _ (finalLog_contains _ _ _ member)) + | construction q valid => exact ih _ _ _ _ _ recorded + +theorem reconstructSeed_agrees {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (seed : Seed) (p : Program Result) (counted : Counts Q p) : + FallbackAgreement ro iv + (reconstructSeed (runIdeal (simulator Q) ro iv ((simulator Q).initial seed) + p Q (by omega) counted).view.observations) + ((simulator Q).initial seed) p Q (by omega) counted := by + apply fallbackAgreement_from_log ro iv ((simulator Q).initial seed) p Q (by omega) counted + · exact finalLog_functional ro iv ((simulator Q).initial seed) p Q (by omega) counted + (by simp [simulator, Functional]) + · exact fun _ h => h + +theorem answer_replace_seed {Q : Nat} (ro : RawKey Q → Digest32) + (state : State) (replacement : Seed) (input : Node) + (agree : lookup state.publicLog input = none → privateKey Q state.publicLog input = none → + replacement input = state.seed input) : + runRO ro ((simulator Q).answer {state with seed := replacement} input) = + let actual := runRO ro ((simulator Q).answer state input) + (({actual.1.1 with seed := replacement},actual.1.2),actual.2) := by + cases hl : lookup state.publicLog input with + | some d => simp [simulator, hl, runRO] + | none => + cases hk : privateKey Q state.publicLog input with + | some key => simp [simulator, hl, hk, runRO] + | none => simp [simulator, hl, hk, runRO, agree hl hk] + +theorem runIdeal_replace_seed {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (replacement : Seed) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) + (agree : FallbackAgreement ro iv replacement state p remaining cap counted) : + runIdeal (simulator Q) ro iv {state with seed := replacement} p remaining cap counted = + runIdeal (simulator Q) ro iv state p remaining cap counted := by + induction p generalizing state remaining with + | done r => rfl + | ask query next ih => + cases query with + | primitive purpose input => + simp only [runIdeal, answer_replace_seed ro state replacement input agree.1] + congr 1 + exact ih _ _ _ _ _ agree.2 + | construction q valid => + simp only [runIdeal] + congr 1 + exact ih _ _ _ _ _ agree + +theorem reconstructSeed_runIdeal {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (seed : Seed) (p : Program Result) (counted : Counts Q p) : + let actual := runIdeal (simulator Q) ro iv ((simulator Q).initial seed) p Q (by omega) counted + runIdeal (simulator Q) ro iv ((simulator Q).initial (reconstructSeed actual.view.observations)) + p Q (by omega) counted = actual := + runIdeal_replace_seed ro iv _ _ p Q (by omega) counted (reconstructSeed_agrees ro iv seed p counted) + +theorem reconstructSeed_actualRequests {Q : Nat} {Result : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (seed : Seed) (p : Program Result) (counted : Counts Q p) : + let actual := runIdeal (simulator Q) ro iv ((simulator Q).initial seed) p Q (by omega) counted + actualRequests ro iv ((simulator Q).initial (reconstructSeed actual.view.observations)) + p Q (by omega) counted = + actualRequests ro iv ((simulator Q).initial seed) p Q (by omega) counted := by + dsimp only + rw [← replay_actual, ← replay_actual, reconstructSeed_runIdeal] + rfl + +/-- A partial raw oracle stops before executing a continuation whose answer +has not been physically acquired. No default digest fills a cache miss. -/ +def runPartialRO {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) : + ROProgram Q Result → Except (RawKey Q) Result + | .done result => .ok result + | .ask key next => + match cache key with + | none => .error key + | some answer => runPartialRO cache (next answer) + +def CacheAgrees {Q : Nat} (cache : RawKey Q → Option Digest32) (ro : RawKey Q → Digest32) : Prop := + ∀ key answer, cache key = some answer → answer = ro key + +theorem runPartialRO_success {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (agrees : CacheAgrees cache ro) (p : ROProgram Q Result) + (result : Result) (success : runPartialRO cache p = .ok result) : + (runRO ro p).1 = result := by + induction p with + | done r => simpa [runPartialRO, runRO] using success + | ask key next ih => + cases hc : cache key with + | none => simp [runPartialRO, hc] at success + | some answer => + have he := agrees key answer hc + subst answer + exact ih (ro key) (by simpa [runPartialRO, hc] using success) + +/-- The reported miss is exactly the first unavailable request in the full +actual raw schedule; every preceding request has its real answer in cache. -/ +theorem runPartialRO_first_miss {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (agrees : CacheAgrees cache ro) (p : ROProgram Q Result) + (key : RawKey Q) (miss : runPartialRO cache p = .error key) : + ∃ before after, requests ro p = before ++ key :: after ∧ + (∀ k ∈ before, cache k = some (ro k)) ∧ cache key = none := by + induction p with + | done r => simp [runPartialRO] at miss + | ask current next ih => + cases hc : cache current with + | none => + simp only [runPartialRO, hc, Except.error.injEq] at miss + subst key + exact ⟨[],requests ro (next (ro current)),rfl,by simp,hc⟩ + | some answer => + have he := agrees current answer hc + subst answer + obtain ⟨before,after,hr,hb,hm⟩ := ih (ro current) (by simpa [runPartialRO, hc] using miss) + refine ⟨current :: before,after,?_,?_,hm⟩ + · simp only [requests, List.cons_append, hr] + · intro k hk + rcases List.mem_cons.mp hk with rfl | hk + · exact hc + · exact hb k hk + +structure PartialExecution (Q : Nat) (Result : Type) where + observations : List Observation + outcome : Except (RawKey Q) Result + +def prependPartial {Q : Nat} {Result : Type} (query : Query) (answer : Digest32) + (rest : PartialExecution Q Result) : PartialExecution Q Result := + ⟨⟨query,answer⟩ :: rest.observations,rest.outcome⟩ + +def runPartial {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) + (iv : Digest32) (state : State) : + (p : Program Result) → (remaining : Nat) → remaining ≤ Q → Counts remaining p → + PartialExecution Q Result + | .done result, _, _, _ => ⟨[],.ok result⟩ + | .ask (.primitive purpose input) next, remaining, cap, counted => + match runPartialRO cache ((simulator Q).answer state input) with + | .error key => ⟨[],.error key⟩ + | .ok answer => prependPartial (.primitive purpose input) answer.2 + (runPartial cache iv answer.1 (next answer.2) (remaining-1) (by omega) (counted.2 _)) + | .ask (.construction q valid) next, remaining, cap, counted => + let key := constructionKey Q iv q (counted.1.trans cap) + match cache key with + | none => ⟨[],.error key⟩ + | some answer => prependPartial (.construction q valid) answer + (runPartial cache iv state (next answer) (remaining-pathCost q) (by omega) (counted.2 _)) + +theorem partialAnswer_replace_seed {Q : Nat} (cache : RawKey Q → Option Digest32) + (state : State) (replacement : Seed) (input : Node) + (agree : lookup state.publicLog input = none → privateKey Q state.publicLog input = none → + replacement input = state.seed input) : + runPartialRO cache ((simulator Q).answer {state with seed := replacement} input) = + (runPartialRO cache ((simulator Q).answer state input)).map + (fun answer => ({answer.1 with seed := replacement},answer.2)) := by + cases hl : lookup state.publicLog input with + | some d => simp [simulator, hl, runPartialRO, Except.map] + | none => + cases hk : privateKey Q state.publicLog input with + | some key => cases hc : cache key <;> simp [simulator, hl, hk, runPartialRO, hc, Except.map] + | none => simp [simulator, hl, hk, runPartialRO, agree hl hk, Except.map] + +theorem runPartial_replace_seed {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (cacheAgrees : CacheAgrees cache ro) + (iv : Digest32) (replacement : Seed) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) + (agree : FallbackAgreement ro iv replacement state p remaining cap counted) : + runPartial cache iv {state with seed := replacement} p remaining cap counted = + runPartial cache iv state p remaining cap counted := by + induction p generalizing state remaining with + | done r => rfl + | ask query next ih => + cases query with + | primitive purpose input => + simp only [runPartial, partialAnswer_replace_seed cache state replacement input agree.1] + cases hp : runPartialRO cache ((simulator Q).answer state input) with + | error key => rfl + | ok answer => + have he := runPartialRO_success cache ro cacheAgrees _ answer hp + subst answer + simp only [Except.map] + congr 1 + exact ih _ _ _ _ _ agree.2 + | construction q valid => + simp only [runPartial] + cases hc : cache (constructionKey Q iv q (counted.1.trans cap)) with + | none => rfl + | some answer => + have he := cacheAgrees _ answer hc + subst answer + dsimp only + congr 1 + exact ih _ _ _ _ _ agree + +theorem reconstructSeed_runPartial {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (cacheAgrees : CacheAgrees cache ro) + (iv : Digest32) (seed : Seed) (p : Program Result) (counted : Counts Q p) : + let actual := runIdeal (simulator Q) ro iv ((simulator Q).initial seed) p Q (by omega) counted + runPartial cache iv ((simulator Q).initial (reconstructSeed actual.view.observations)) + p Q (by omega) counted = + runPartial cache iv ((simulator Q).initial seed) p Q (by omega) counted := + runPartial_replace_seed cache ro cacheAgrees iv _ _ p Q (by omega) counted + (reconstructSeed_agrees ro iv seed p counted) + +theorem runPartial_prefix {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (cacheAgrees : CacheAgrees cache ro) + (iv : Digest32) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + ∃ suffix, (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations = + (runPartial cache iv state p remaining cap counted).observations ++ suffix := by + induction p generalizing state remaining with + | done r => exact ⟨[],rfl⟩ + | ask query next ih => + cases query with + | primitive purpose input => + cases hp : runPartialRO cache ((simulator Q).answer state input) with + | error key => + refine ⟨(runIdeal (simulator Q) ro iv state + (.ask (.primitive purpose input) next) remaining cap counted).view.observations,?_⟩ + simp [runPartial,hp] + | ok answer => + have he := runPartialRO_success cache ro cacheAgrees _ answer hp + subst answer + obtain ⟨suffix,hs⟩ := ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 (remaining-1) (by omega) (counted.2 _) + exact ⟨suffix,by simpa only [runIdeal, prepend, runPartial, hp, prependPartial, + List.cons_append] using congrArg (⟨.primitive purpose input, + (runRO ro ((simulator Q).answer state input)).1.2⟩ :: ·) hs⟩ + | construction q valid => + cases hc : cache (constructionKey Q iv q (counted.1.trans cap)) with + | none => + refine ⟨(runIdeal (simulator Q) ro iv state + (.ask (.construction q valid) next) remaining cap counted).view.observations,?_⟩ + simp [runPartial,hc] + | some answer => + have he := cacheAgrees _ answer hc + subst answer + obtain ⟨suffix,hs⟩ := ih (ro (constructionKey Q iv q (counted.1.trans cap))) + state (remaining-pathCost q) (by omega) (counted.2 _) + exact ⟨suffix,by simpa only [runIdeal, prepend, runPartial, hc, prependPartial, + List.cons_append] using congrArg (⟨.construction q valid, + ro (constructionKey Q iv q (counted.1.trans cap))⟩ :: ·) hs⟩ + +/-- Public-only stopping rule. A raw-cache miss excludes the current +observation: its public answer cannot be consumed before that request is +physically acquired. Out-of-domain construction observations also stop. -/ +def publicCut (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (log : PublicLog) : List Observation → List Observation + | [] => [] + | ⟨.primitive purpose input,answer⟩ :: rest => + match privateKey Q log input with + | none => ⟨.primitive purpose input,answer⟩ :: + publicCut Q iv cache (observe log input answer) rest + | some key => + match cache key with + | none => [] + | some _ => ⟨.primitive purpose input,answer⟩ :: + publicCut Q iv cache (observe log input answer) rest + | ⟨.construction q valid,answer⟩ :: rest => + if h : pathCost q ≤ Q then + match cache (constructionKey Q iv q h) with + | none => [] + | some _ => ⟨.construction q valid,answer⟩ :: publicCut Q iv cache log rest + else [] + +theorem partialAnswer_cache {Q : Nat} (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (agrees : CacheAgrees cache ro) (state : State) (input : Node) : + runPartialRO cache ((simulator Q).answer state input) = + match privateKey Q state.publicLog input with + | none => .ok (runRO ro ((simulator Q).answer state input)).1 + | some key => + match cache key with + | none => .error key + | some _ => .ok (runRO ro ((simulator Q).answer state input)).1 := by + cases hl : lookup state.publicLog input with + | some answer => simp [simulator, hl, privateKey, runPartialRO, runRO] + | none => + cases hk : privateKey Q state.publicLog input with + | none => simp [simulator, hl, hk, runPartialRO, runRO] + | some key => + cases hc : cache key with + | none => simp [simulator, hl, hk, hc, runPartialRO] + | some answer => + have he := agrees key answer hc + subst answer + simp [simulator, hl, hk, hc, runPartialRO, runRO] + +theorem publicCut_runPartial {Q : Nat} {Result : Type} (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (cacheAgrees : CacheAgrees cache ro) + (iv : Digest32) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + publicCut Q iv cache state.publicLog + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations = + (runPartial cache iv state p remaining cap counted).observations := by + induction p generalizing state remaining with + | done r => rfl + | ask query next ih => + cases query with + | primitive purpose input => + have ht := ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 (remaining-1) (by omega) (counted.2 _) + simp only [answer_publicLog] at ht + simp only [runIdeal, prepend, publicCut, runPartial, + partialAnswer_cache cache ro cacheAgrees state input] + cases hk : privateKey Q state.publicLog input with + | none => exact congrArg (⟨.primitive purpose input, + (runRO ro ((simulator Q).answer state input)).1.2⟩ :: ·) ht + | some key => + dsimp only + cases hc : cache key with + | none => rfl + | some answer => exact congrArg (⟨.primitive purpose input, + (runRO ro ((simulator Q).answer state input)).1.2⟩ :: ·) ht + | construction q valid => + have hq : pathCost q ≤ Q := counted.1.trans cap + simp only [runIdeal, prepend, publicCut, runPartial, hq, ↓reduceDIte] + cases hc : cache (constructionKey Q iv q hq) with + | none => rfl + | some answer => + have he := cacheAgrees _ answer hc + subst answer + exact congrArg (⟨.construction q valid,ro (constructionKey Q iv q hq)⟩ :: ·) + (ih _ _ _ _ _) + +-- Executable smoke: real ROProgram interpretation, not an assumed simulator. +#eval do + let digest (n : Nat) : Digest32 := fun _ => ⟨n % 256, Nat.mod_lt _ (by decide)⟩ + let block : Block64 := fun i => ⟨i.val,by omega⟩ + let seedNode : Node := ⟨digest 41,block,UInt64.ofNat (2^56),true⟩ + let internal : Node := ⟨digest 41,block,UInt64.ofNat (2*2^56+17),true⟩ + let terminal : Node := ⟨digest 2,block,UInt64.ofNat (6*2^56+23),true⟩ + let fallback : Seed := fun n => if isSeed n then n.cv else digest 2 + let ro : RawKey 8 → Digest32 := fun _ => digest 99 + let initial := (simulator 8).initial fallback + let s := runRO ro ((simulator 8).answer initial seedNode) + let i := runRO ro ((simulator 8).answer s.1.1 internal) + let t := runRO ro ((simulator 8).answer i.1.1 terminal) + let repeated := runRO ro ((simulator 8).answer t.1.1 terminal) + let incomplete := runRO ro ((simulator 8).answer initial terminal) + let clone : Node := { seedNode with cv := digest 42 } + let c := runRO ro ((simulator 8).answer initial clone) + let ct : Node := { terminal with cv := digest 42 } + let chosen := runRO ro ((simulator 8).answer c.1.1 ct) + let wrongLast : Node := { terminal with last := false } + let program : Program Digest32 := + .ask (.primitive .direct seedNode) (fun _ => + .ask (.primitive .auxiliary internal) (fun _ => + .ask (.primitive .verification terminal) (fun _ => + .ask (.primitive .pow terminal) Program.done))) + have counted : Counts 8 program := by simp [program, Counts, Query.cost] + let execution := runIdeal (simulator 8) ro (digest 0) initial program 8 (by omega) counted + let replayed := replay 8 (digest 0) [] execution.view.observations + let paired := replayAnswers 8 (digest 0) [] execution.view.observations + let publicSeed := reconstructSeed execution.view.observations + let reconstructed := (simulator 8).initial publicSeed + let rerun := runIdeal (simulator 8) ro (digest 0) reconstructed program 8 (by omega) counted + let emptyCache : RawKey 8 → Option Digest32 := fun _ => none + let fullCache : RawKey 8 → Option Digest32 := fun key => some (ro key) + let stopped := runPartial emptyCache (digest 0) initial program 8 (by omega) counted + let restopped := runPartial emptyCache (digest 0) reconstructed program 8 (by omega) counted + let completed := runPartial fullCache (digest 0) reconstructed program 8 (by omega) counted + let missed (r : PartialExecution 8 Digest32) := + match r.outcome with + | .error key => some (expandKey key).message + | .ok _ => none + let coordinate : Coordinate := ⟨⟨digest 0,digest 1,[]⟩,.output 0⟩ + have valid : DuplexEncoding.Admissible coordinate := by + simp [coordinate, DuplexEncoding.Admissible, DuplexEncoding.TerminalValid] + let constructor : Program Digest32 := .ask (.construction coordinate valid) Program.done + have constructorCounted : Counts 8 constructor := by + simp [constructor, Counts, Query.cost, pathCost, DuplexEncoding.plan, coordinate] + let constructed := runIdeal (simulator 8) ro (digest 0) initial constructor + 8 (by omega) constructorCounted + let checks : List (String × Bool) := [ + ("seed fallback", s.2 == 0 && decide (s.1.2 = digest 41)), + ("internal fallback", i.2 == 0 && decide (i.1.2 = digest 2)), + ("terminal one raw query", t.2 == 1 && decide (t.1.2 = digest 99)), + ("repeat cached no query", repeated.2 == 0 && decide (repeated.1.2 = t.1.2)), + ("incomplete no raw query", incomplete.2 == 0), + ("counted public-view replay", execution.simulatorQueries == 1 && + execution.primitiveCost == 4 && decide (execution.view.result = digest 99) && + decide (replayed.map (fun k => (expandKey k).template) = + [[(terminal.tweak,true),(internal.tweak,true),(seedNode.tweak,true)]]) && + decide (replayed.map (fun k => (expandKey k).message) = + [[(none,block),(none,block),(some (digest 41),block)]])), + ("paired public raw answer", decide (paired.map Prod.snd = [digest 99]) && + decide (paired.map (fun (entry : RawKey 8 × Digest32) => (expandKey entry.1).message) = + [[(none,block),(none,block),(some (digest 41),block)]])), + ("reconstructed fallback only", decide (publicSeed seedNode = digest 41) && + decide (publicSeed internal = digest 2) && decide (publicSeed terminal = digest 99) && + decide (fallback terminal = digest 2) && decide (publicSeed wrongLast = zeroDigest)), + ("reconstructed actual execution", rerun.simulatorQueries == 1 && + decide (rerun.view.result = digest 99) && + decide (rerun.view.observations.map Observation.answer = + [digest 41,digest 2,digest 99,digest 99])), + ("partial first missing raw key", decide (stopped.observations.map Observation.answer = + [digest 41,digest 2]) && + decide (missed stopped = some [(none,block),(none,block),(some (digest 41),block)])), + ("reconstructed partial prefix", decide (restopped.observations.map Observation.answer = + [digest 41,digest 2]) && + decide (missed restopped = some [(none,block),(none,block),(some (digest 41),block)])), + ("partial full-cache completion", decide (completed.observations.map Observation.answer = + [digest 41,digest 2,digest 99,digest 99]) && + (match completed.outcome with | .ok answer => decide (answer = digest 99) | .error _ => false)), + ("public cut before missing reply", decide ( + (publicCut 8 (digest 0) emptyCache [] execution.view.observations).map Observation.answer = + [digest 41,digest 2])), + ("public cut full cache", decide ( + (publicCut 8 (digest 0) fullCache [] execution.view.observations).map Observation.answer = + [digest 41,digest 2,digest 99,digest 99])), + ("public cut cached input needs no cache", decide ( + (publicCut 8 (digest 0) emptyCache t.1.1.publicLog + [⟨.primitive .direct terminal,digest 99⟩]).map Observation.answer = [digest 99])), + ("public cut incomplete needs no cache", decide ( + (publicCut 8 (digest 0) emptyCache [] + [⟨.primitive .direct terminal,digest 2⟩]).map Observation.answer = [digest 2])), + ("public cut construction miss", (publicCut 8 (digest 0) emptyCache [] + constructed.view.observations).isEmpty), + ("public cut construction hit", decide ( + (publicCut 8 (digest 0) fullCache [] constructed.view.observations).map Observation.answer = + [digest 99])), + ("chosen seed CV", chosen.2 == 1 && + decide ((privateKey 8 c.1.1.publicLog ct).map (fun k => (expandKey k).message) = + some [(none,block),(some (digest 42),block)])), + ("exact blocks tweaks last", decide ( + (privateKey 8 i.1.1.publicLog terminal).map (fun k => (expandKey k).template) = + some [(terminal.tweak,true),(internal.tweak,true),(seedNode.tweak,true)])), + ("last flag checked", (privateKey 8 i.1.1.publicLog wrongLast).isNone), + ("public answer stored", decide (t.1.1.publicLog = + [(terminal,digest 99),(internal,digest 2),(seedNode,digest 41)]))] + for (label,ok) in checks do + if ok = true then IO.println s!"{label}: ok" else throw (IO.userError s!"{label}: FAILED") + +#print axioms canonical_terminal +#print axioms privateKey_compression +#print axioms recognized_complete +#print axioms initial_budgetSafe +#print axioms simulatorBound +#print axioms replay_actual +#print axioms security_of_distinguishing +#print axioms replayAnswers_consistent +#print axioms reconstructSeed_agrees +#print axioms reconstructSeed_runIdeal +#print axioms reconstructSeed_actualRequests +#print axioms runPartialRO_first_miss +#print axioms reconstructSeed_runPartial +#print axioms runPartial_prefix +#print axioms replayAnswers_source_bound +#print axioms publicCut_runPartial + +end Whir.DuplexPublicSimulator diff --git a/verification/whir/Whir/DuplexRawProgram.lean b/verification/whir/Whir/DuplexRawProgram.lean new file mode 100644 index 000000000..1d58f9367 --- /dev/null +++ b/verification/whir/Whir/DuplexRawProgram.lean @@ -0,0 +1,171 @@ +import Whir.DuplexModeGame +import Whir.TypedOracleCompiler + +/-! Exact, executable lowering of the #552 ideal public-mode interaction to +raw-key oracle calls. Simulator calls and construction calls share the same +oracle. Bounded sampling stops only on actual fuel exhaustion. The semantic +bridge and accounting equations are proved; caller-supplied Counts and the +primitive simulator budget remain explicit. -/ +namespace Whir.DuplexRawProgram +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +namespace ROProgram +variable {Q : Nat} {R S : Type} + +def bind : DuplexModeGame.ROProgram Q R → (R → DuplexModeGame.ROProgram Q S) → DuplexModeGame.ROProgram Q S + | .done r, f => f r + | .ask key next, f => .ask key (fun a => bind (next a) f) + +def map (f : R → S) : DuplexModeGame.ROProgram Q R → DuplexModeGame.ROProgram Q S + | .done r => .done (f r) + | .ask key next => .ask key (fun a => map f (next a)) + +@[simp] theorem run_bind (ro : RawKey Q → Digest32) (p : DuplexModeGame.ROProgram Q R) + (f : R → DuplexModeGame.ROProgram Q S) : + runRO ro (bind p f) = ((runRO ro (f (runRO ro p).1)).1, + (runRO ro p).2 + (runRO ro (f (runRO ro p).1)).2) := by + induction p with + | done r => simp [bind, runRO] + | ask key next ih => simp [bind, runRO, ih, Nat.add_assoc, Nat.add_comm] + +@[simp] theorem run_map (ro : RawKey Q → Digest32) (f : R → S) (p : DuplexModeGame.ROProgram Q R) : + runRO ro (map f p) = (f (runRO ro p).1, (runRO ro p).2) := by + induction p with + | done => rfl + | ask key next ih => simp [map, runRO, ih] +end ROProgram + +def observe {R : Type} (q : Query) (answer : Digest32) (v : View R) : View R := + ⟨⟨q,answer⟩ :: v.observations,v.result⟩ + +/-- Flatten the actual ideal interpreter, including its private simulator state. +The returned value exposes exactly the public view, never simulator state. -/ +def compileIdeal {Q : Nat} {Seed State Result : Type} (sim : Simulator Q Seed State) + (iv : Digest32) (state : State) : + (p : Program Result) → (remaining : Nat) → remaining ≤ Q → Counts remaining p → DuplexModeGame.ROProgram Q (View Result) + | .done result, _, _, _ => .done ⟨[],result⟩ + | .ask (.primitive purpose input) next, remaining, cap, counted => + ROProgram.bind (sim.answer state input) fun answer => + ROProgram.map (observe (.primitive purpose input) answer.2) + (compileIdeal sim iv answer.1 (next answer.2) (remaining-1) (by omega) (counted.2 _)) + | .ask (.construction q valid) next, remaining, cap, counted => + .ask (constructionKey Q iv q (counted.1.trans cap)) fun answer => + ROProgram.map (observe (.construction q valid) answer) + (compileIdeal sim iv state (next answer) (remaining-pathCost q) (by omega) (counted.2 _)) + +/-- Both the value and exact raw-call count are preserved. Every construction +occurrence contributes one raw call, and every simulator ask is retained. -/ +theorem run_compileIdeal {Q : Nat} {Seed State Result : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + runRO ro (compileIdeal sim iv state p remaining cap counted) = + ((runIdeal sim ro iv state p remaining cap counted).view, + (runIdeal sim ro iv state p remaining cap counted).constructionRequests + + (runIdeal sim ro iv state p remaining cap counted).simulatorQueries) := by + induction p generalizing state remaining with + | done result => rfl + | ask q next ih => + cases q with + | primitive purpose input => + have h := ih (runRO ro (sim.answer state input)).1.2 + (runRO ro (sim.answer state input)).1.1 (remaining-1) (by omega) (counted.2 _) + simp only [compileIdeal, ROProgram.run_bind, ROProgram.run_map, h, runIdeal, prepend, observe] + simp [Nat.add_left_comm] + | construction q valid => + have h := ih (ro (constructionKey Q iv q (counted.1.trans cap))) state + (remaining-pathCost q) (by omega) (counted.2 _) + simp only [compileIdeal, runRO, ROProgram.run_map, h, runIdeal, prepend, observe] + simp [Nat.add_comm, Nat.add_left_comm] + +theorem pathCost_pos (q : Coordinate) : 1 ≤ pathCost q := by + simp [pathCost, DuplexEncoding.plan] + +/-- Construction RO calls do not disappear when a coordinate is repeated. -/ +theorem constructionRequests_le {Q : Nat} {Seed State Result : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + (runIdeal sim ro iv state p remaining cap counted).constructionRequests ≤ remaining := by + induction p generalizing state remaining with + | done result => simp [runIdeal] + | ask q next ih => + cases q with + | primitive purpose input => + have h := ih (runRO ro (sim.answer state input)).1.2 + (runRO ro (sim.answer state input)).1.1 (remaining-1) (by omega) (counted.2 _) + simp only [runIdeal, prepend] + omega + | construction q valid => + have h := ih (ro (constructionKey Q iv q (counted.1.trans cap))) state + (remaining-pathCost q) (by omega) (counted.2 _) + have hp := pathCost_pos q + have hc : pathCost q ≤ remaining := counted.1 + simp only [runIdeal, prepend] + omega + +/-- The two budgets are distinct: Q real primitive calls and Q simulator RO +calls imply at most 2Q total ideal raw calls, not at most Q. -/ +theorem compileIdeal_calls_le {Q : Nat} {Seed State Result : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) + (simulatorBound : (runIdeal sim ro iv state p remaining cap counted).simulatorQueries ≤ Q) : + (runRO ro (compileIdeal sim iv state p remaining cap counted)).2 ≤ 2*Q := by + rw [run_compileIdeal] + have h := constructionRequests_le sim ro iv state p remaining cap counted + dsimp only + omega + +/-- Fuel belongs to raw calls, including duplicate keys and private simulator +calls. Exhaustion returns none and performs no additional oracle request. -/ +def stop {Q : Nat} {R : Type} : (fuel : Nat) → DuplexModeGame.ROProgram Q R → + Sampling (RawKey Q) (fun _ => Digest32) (Option R) fuel + | _, .done r => .ret (some r) + | 0, .ask _ _ => .ret none + | fuel+1, .ask key next => .draw key (fun answer => stop fuel (next answer)) + +theorem eval_stop {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (fuel : Nat) (p : DuplexModeGame.ROProgram Q R) : + Sampling.eval ro (stop fuel p) = + if (runRO ro p).2 ≤ fuel then some (runRO ro p).1 else none := by + induction fuel generalizing p with + | zero => cases p <;> simp [stop, Sampling.eval, runRO] + | succ fuel ih => + cases p with + | done r => simp [stop, Sampling.eval, runRO] + | ask key next => simpa [stop, Sampling.eval, runRO] using ih (next (ro key)) + +theorem stop_exact {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (fuel : Nat) (p : DuplexModeGame.ROProgram Q R) (counted : (runRO ro p).2 ≤ fuel) : + Sampling.eval ro (stop fuel p) = some (runRO ro p).1 := by + simp only [eval_stop, counted, ↓reduceIte] + +theorem stop_exhausted {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (fuel : Nat) (p : DuplexModeGame.ROProgram Q R) : + Sampling.eval ro (stop fuel p) = none ↔ fuel < (runRO ro p).2 := by + rw [eval_stop] + split_ifs <;> simp_all + +/-- Operational trace length is exactly the number of raw calls executed before +termination or stopping. Duplicate keys are not erased by this compiler. -/ +theorem execute_stop_length {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (fuel : Nat) (p : DuplexModeGame.ROProgram Q R) : + (Sampling.execute ro (stop fuel p)).2.length = min fuel (runRO ro p).2 := by + induction fuel generalizing p with + | zero => cases p <;> simp [stop, Sampling.execute, runRO] + | succ fuel ih => + cases p with + | done r => simp [stop, Sampling.execute, runRO] + | ask key next => + simp only [stop, Sampling.execute, List.length_cons, runRO] + rw [ih] + omega + +theorem bounded_compileIdeal_exact {Q : Nat} {Seed State Result : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program Result) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) + (simulatorBound : (runIdeal sim ro iv state p remaining cap counted).simulatorQueries ≤ Q) : + Sampling.eval ro (stop (2*Q) (compileIdeal sim iv state p remaining cap counted)) = + some (runIdeal sim ro iv state p remaining cap counted).view := by + rw [stop_exact ro _ _ (compileIdeal_calls_le sim ro iv state p remaining cap counted simulatorBound)] + rw [run_compileIdeal] + +end Whir.DuplexRawProgram diff --git a/verification/whir/Whir/DuplexRefinement.lean b/verification/whir/Whir/DuplexRefinement.lean new file mode 100644 index 000000000..b0238f513 --- /dev/null +++ b/verification/whir/Whir/DuplexRefinement.lean @@ -0,0 +1,1021 @@ +import Whir.FiatShamirGame +import Whir.ByteCodec + +/-! The byte state machine of conditional #552, not the baseline step chain. +The compression function is public and includes the complete CV, block, counter +and final flag. This is a hand-port semantics, not a Rust compiler theorem. -/ +namespace Whir.DuplexRefinement +open FiatShamirGame + +def sourceRevision : String := "ff6a275304a3b577118b066ddcff83bfafa5998d" +def modeVersion : String := "#552/LVFS-1/framed-byte-duplex" +def libSourceSHA256 : String := "cadcb014afca2f228f597131b5ac0ee63693358e65c793fc2b357bf445bbba79" +def transportSourceSHA256 : String := "5b8f4190afea759cc37c289f7f3af9597f6d416b944a66fa229078dea1d793c5" +abbrev Block64 := Fin 64 → Byte +abbrev Compression := Digest32 → Block64 → UInt64 → Bool → Digest32 + +def maxCursor : Nat := 2^49 - 1 + +def role (first last : Bool) : Nat := + if first then (if last then 4 else 2) else (if last then 5 else 3) + +/-- The three fields occupy disjoint bit intervals: 8, 7, and 49 bits. -/ +def packTweak (r len previous : Nat) : Nat := r * 2^56 + len * 2^49 + previous + +def absorbTweak (first last : Bool) (len previous : Nat) : UInt64 := + UInt64.ofNat (packTweak (role first last) len previous) + +def zeroDigest : Digest32 := fun _ => 0 + +def padded (bytes : Array Byte) : Block64 := fun i => bytes[i.val]?.getD 0 + +def littleWord (n : Nat) : List Byte := + List.ofFn (ByteCodec.encodeNat 8 n) + +def wordsBlock (ns : List Nat) : Block64 := padded (ns.flatMap littleWord).toArray + +/-- Only bounded buffering lives in the executable state; no transcript log. -/ +structure State where + cv : Digest32 + pending : Array Byte := #[] + first : Bool := true + previous : Nat := 0 + consumed : Nat := 0 + output : Digest32 := zeroDigest + +/-- Eagerly close a finite digest over 32 stored bytes, rather than retaining a +closure that recursively recomputes the previous compression history. -/ +def memoCV (s : State) (d : Digest32) : State := + let bytes := Array.ofFn d + {s with cv := fun i => bytes[i.val]'(by simp only [bytes, Array.size_ofFn]; exact i.isLt)} + +def memoOutput (s : State) (d : Digest32) : State := + let bytes := Array.ofFn d + {s with output := fun i => bytes[i.val]'(by simp only [bytes, Array.size_ofFn]; exact i.isLt)} + +@[simp] theorem memoCV_eq (s : State) (d : Digest32) : memoCV s d = {s with cv := d} := by + simp [memoCV] + +@[simp] theorem memoOutput_eq (s : State) (d : Digest32) : memoOutput s d = {s with output := d} := by + simp [memoOutput] + +/-- Seed uses exactly domain || statement with the parameter IV supplied by the +primitive instantiation. There is no API for injecting a live chaining value. -/ +def seed (compress : Compression) (iv domain statement : Digest32) : State := + { cv := compress iv (ByteCodec.pairBytes (domain, statement)) (UInt64.ofNat (2^56)) true } + +def seedMemo (c : Compression) (iv domain statement : Digest32) : State := + memoCV {cv := zeroDigest} (c iv (ByteCodec.pairBytes (domain,statement)) (UInt64.ofNat (2^56)) true) + +@[csimp] theorem seed_memo : seed = seedMemo := by + funext c iv domain statement + simp [seed, seedMemo] + +/-- One byte, retaining a full block until a subsequent byte proves nonfinality. -/ +def absorbByte (compress : Compression) (s : State) (b : Byte) : State := + let s := if s.consumed = 0 then s + else { s with previous := s.consumed, consumed := 0 } + let s := if s.pending.size = 64 then + { s with + cv := compress s.cv (padded s.pending) (absorbTweak s.first false 64 s.previous) true + pending := #[] + first := false + previous := 0 } + else s + { s with pending := s.pending.push b } + +def absorbByteMemo (c : Compression) (s : State) (b : Byte) : State := + let s := if s.consumed = 0 then s else {s with previous := s.consumed, consumed := 0} + let s := if s.pending.size = 64 then + let s := memoCV s (c s.cv (padded s.pending) (absorbTweak s.first false 64 s.previous) true) + {s with pending := #[], first := false, previous := 0} + else s + {s with pending := s.pending.push b} + +@[csimp] theorem absorbByte_memo : absorbByte = absorbByteMemo := by + funext c s b + simp only [absorbByte, absorbByteMemo, memoCV_eq] + +def absorb (compress : Compression) (s : State) (bytes : List Byte) : State := + bytes.foldl (absorbByte compress) s + +/-- Nonmutating finalization used by both export families. -/ +def finalized (compress : Compression) (s : State) : Digest32 := + if s.pending.isEmpty then s.cv else + compress s.cv (padded s.pending) + (absorbTweak s.first true s.pending.size s.previous) true + +def finish (compress : Compression) (s : State) : State := + if s.pending.isEmpty then s else + { s with cv := finalized compress s, pending := #[], first := true, previous := 0 } + +def finishMemo (c : Compression) (s : State) : State := + if s.pending.isEmpty then s else + let s := memoCV s (finalized c s) + {s with pending := #[], first := true, previous := 0} + +@[csimp] theorem finish_memo : finish = finishMemo := by + funext c s + simp only [finish, finishMemo, memoCV_eq] + +def outputBlock (compress : Compression) (cv : Digest32) (index : Nat) : Digest32 := + compress cv (wordsBlock [index]) (UInt64.ofNat (6 * 2^56)) true + +/-- Retains unused output bytes rather than recomputing their block. -/ +def squeezeByte (compress : Compression) (s : State) : State × Byte := + let digest := if s.consumed % 32 = 0 then outputBlock compress s.cv (s.consumed / 32) + else s.output + ({ s with consumed := s.consumed + 1, output := digest }, + digest ⟨s.consumed % 32, Nat.mod_lt _ (by decide)⟩) + +def squeezeByteMemo (c : Compression) (s : State) : State × Byte := + let s := if s.consumed % 32 = 0 then memoOutput s (outputBlock c s.cv (s.consumed / 32)) else s + ({s with consumed := s.consumed + 1}, s.output ⟨s.consumed % 32, Nat.mod_lt _ (by decide)⟩) + +@[csimp] theorem squeezeByte_memo : squeezeByte = squeezeByteMemo := by + funext c s + simp only [squeezeByte, squeezeByteMemo, memoOutput_eq] + split <;> rfl + +def squeezeLoop (compress : Compression) : Nat → State → State × List Byte + | 0, s => (s, []) + | n + 1, s => + let (s', b) := squeezeByte compress s + let (s'', bs) := squeezeLoop compress n s' + (s'', b :: bs) + +inductive Error where + | cursorExhausted + | grindingBits + | nonceExhausted + | absorbLength + | absorbCursor + deriving DecidableEq, Repr + +/-- Limits are checked before finishing pending input or consuming output. -/ +def squeeze (compress : Compression) (s : State) (n : Nat) : Except Error (State × List Byte) := + if n = 0 then .ok (s, []) + else if s.consumed + n ≤ maxCursor then .ok (squeezeLoop compress n (finish compress s)) + else .error .cursorExhausted + +def commitment (compress : Compression) (s : State) : Digest32 := + compress (finalized compress s) (wordsBlock [s.consumed]) (UInt64.ofNat (7 * 2^56)) true + +def powBase (compress : Compression) (s : State) (bits : Nat) : Digest32 := + compress (finalized compress s) (wordsBlock [s.consumed, bits]) + (UInt64.ofNat (8 * 2^56)) true + +def nonceBlock (nonce : Scalar24) (consumed bits : Nat) : Block64 := + padded ((List.ofFn nonce ++ littleWord consumed ++ littleWord bits).toArray) + +/-- Internal nonce event. In verification even a failed PoW predicate binds its +nonce; the caller must reject. No ordinary scalar absorption is performed. -/ +def bindNonce (compress : Compression) (s : State) (nonce : Scalar24) (bits : Nat) : State := + let s := finish compress s + { s with cv := (compress s.cv (nonceBlock nonce s.consumed bits) + (UInt64.ofNat (9 * 2^56)) true), consumed := 0 } + +def bindNonceMemo (c : Compression) (s : State) (nonce : Scalar24) (bits : Nat) : State := + let s := finish c s + let s := memoCV s (c s.cv (nonceBlock nonce s.consumed bits) (UInt64.ofNat (9 * 2^56)) true) + {s with consumed := 0} + +@[csimp] theorem bindNonce_memo : bindNonce = bindNonceMemo := by + funext c s nonce bits + simp only [bindNonce, bindNonceMemo, memoCV_eq] + +def verifyNonce (compress : Compression) (powOK : Digest32 → Scalar24 → Nat → Bool) + (s : State) (nonce : Scalar24) (bits : Nat) : Except Error (State × Bool) := + if bits ≤ 63 then + let s := finish compress s + let ok := if bits = 0 then decide (nonce = fun _ => 0) else powOK (powBase compress s bits) nonce bits + .ok (bindNonce compress s nonce bits, ok) + else .error .grindingBits + +@[simp] theorem absorb_empty (c : Compression) (s : State) : absorb c s [] = s := rfl + +/-- All positive/empty call chunkings denote the same absorb run. -/ +theorem absorb_append (c : Compression) (s : State) (a b : List Byte) : + absorb c s (a ++ b) = absorb c (absorb c s a) b := by + simp [absorb, List.foldl_append] + +@[simp] theorem squeeze_empty (c : Compression) (s : State) : + squeeze c s 0 = .ok (s, []) := by simp [squeeze] + +@[simp] theorem finish_pending (c : Compression) (s : State) : + (finish c s).pending = #[] := by + simp only [finish] + split + next h => simpa using Array.isEmpty_iff.mp h + next => rfl + +@[simp] theorem finish_cv (c : Compression) (s : State) : + (finish c s).cv = finalized c s := by + simp only [finish, finalized] + split <;> rfl + +@[simp] theorem finish_consumed (c : Compression) (s : State) : + (finish c s).consumed = s.consumed := by + simp only [finish]; split <;> rfl + +@[simp] theorem finish_idempotent (c : Compression) (s : State) : + finish c (finish c s) = finish c s := by + unfold finish + split <;> simp_all + +@[simp] theorem squeezeLoop_consumed (c : Compression) (n : Nat) (s : State) : + (squeezeLoop c n s).1.consumed = s.consumed + n := by + induction n generalizing s with + | zero => simp [squeezeLoop] + | succ n ih => + simp only [squeezeLoop, ih, squeezeByte] + omega + +@[simp] theorem squeezeLoop_length (c : Compression) (n : Nat) (s : State) : + (squeezeLoop c n s).2.length = n := by + induction n generalizing s with + | zero => rfl + | succ n ih => simp [squeezeLoop, ih] + +/-- The exact cursor, not the padded output length, is committed. -/ +theorem squeeze_exact_cursor (c : Compression) (s t : State) (n : Nat) (bs : List Byte) + (h : squeeze c s n = .ok (t, bs)) : t.consumed = s.consumed + n ∧ bs.length = n := by + unfold squeeze at h + split at h + next hn => cases h; simp_all + next => + split at h + next => + have he := Except.ok.inj h + have hc := congrArg (fun p : State × List Byte => p.1.consumed) he + have hl := congrArg (fun p : State × List Byte => p.2.length) he + exact ⟨by simpa using hc.symm, by simpa using hl.symm⟩ + next => cases h + +theorem squeeze_exhausted (c : Compression) (s : State) (n : Nat) + (positive : n ≠ 0) (large : maxCursor < s.consumed + n) : + squeeze c s n = .error .cursorExhausted := by simp [squeeze, positive, Nat.not_le.mpr large] + +/-- Nonmutating exports and Lean value cloning preserve the complete pending +buffer and unused output; the two independent continuations start identically. -/ +theorem clone_continuation (s : State) (f : State → State) : f (id s) = f s := rfl + +/-- No carry can turn length/cursor data into a different role. -/ +theorem packTweak_injective {r r' len len' previous previous' : Nat} + (hl : len < 128) (hl' : len' < 128) + (hp : previous < 2^49) (hp' : previous' < 2^49) + (h : packTweak r len previous = packTweak r' len' previous') : + r = r' ∧ len = len' ∧ previous = previous' := by + unfold packTweak at h + omega + +theorem role_injective {f l f' l' : Bool} (h : role f l = role f' l') : + f = f' ∧ l = l' := by + cases f <;> cases l <;> cases f' <;> cases l' <;> simp_all [role] + +def observe (c : Compression) (s : State) (x : Concrete.E) : State := + absorb c s (List.ofFn (ByteCodec.encodeE x)) + +def observeMany (c : Compression) (s : State) (xs : List Concrete.E) : State := + xs.foldl (observe c) s + +/-- The root is transported as two canonical E scalars, hence 48 bytes, +including the two zero spare limbs. It is never absorbed a second time. -/ +def observeRoot (c : Compression) (s : State) (root : Digest32) : State := + let p := ByteCodec.hashToScalars root + observe c (observe c s p.1) p.2 + +theorem observeRoot_bytes (c : Compression) (s : State) (root : Digest32) : + observeRoot c s root = absorb c s + (List.ofFn (ByteCodec.encodeE (ByteCodec.hashToScalars root).1) ++ + List.ofFn (ByteCodec.encodeE (ByteCodec.hashToScalars root).2)) := by + simp only [observeRoot, observe, absorb_append] + +theorem scalar_codec_bijection : + Function.Bijective ByteCodec.encodeE := by + exact ⟨ByteCodec.encodeE_injective, fun b => ⟨ByteCodec.decodeE b, ByteCodec.encodeE_decodeE b⟩⟩ + +/-- Exactly the transmitted coefficients, not the reconstructed coefficient. -/ +def transmittedCoefficients (coefficients : List Concrete.E) (eqFactored : Bool) : List Concrete.E := + (coefficients.zipIdx.filter (fun p => p.2 != (if eqFactored then 0 else 1))).map Prod.fst + +def observeRound (c : Compression) (s : State) (coefficients : List Concrete.E) + (eqFactored : Bool) : State := + observeMany c s (transmittedCoefficients coefficients eqFactored) + +/-- Side authentication is deliberately outside the byte transcript. -/ +def authenticate (_level : Nat) (s : State) : State := s + +theorem authenticate_preserves (level : Nat) (s : State) : authenticate level s = s := rfl + +theorem absorbByte_bounded (c : Compression) (s : State) (b : Byte) + (h : s.pending.size ≤ 64) : (absorbByte c s b).pending.size ≤ 64 := by + simp only [absorbByte] + split <;> split <;> simp_all only [Array.size_push, Array.size_empty] <;> omega + +theorem absorb_bounded (c : Compression) (s : State) (bs : List Byte) + (h : s.pending.size ≤ 64) : (absorb c s bs).pending.size ≤ 64 := by + induction bs generalizing s with + | nil => exact h + | cons b bs ih => exact ih _ (absorbByte_bounded c s b h) + +theorem absorbByte_cursor (c : Compression) (s : State) (b : Byte) : + (absorbByte c s b).consumed = 0 := by + simp only [absorbByte] + split <;> split <;> simp_all + +theorem squeezeLoop_append (c : Compression) (a b : Nat) (s : State) : + squeezeLoop c (a + b) s = + let p := squeezeLoop c a s + let q := squeezeLoop c b p.1 + (q.1, p.2 ++ q.2) := by + induction a generalizing s with + | zero => simp [squeezeLoop] + | succ a ih => + simp only [Nat.succ_add, squeezeLoop, ih, List.cons_append] + +theorem squeezeLoop_pending (c : Compression) (n : Nat) (s : State) : + (squeezeLoop c n s).1.pending = s.pending := by + induction n generalizing s with + | zero => rfl + | succ n ih => simp only [squeezeLoop, ih, squeezeByte] + +theorem squeezeLoop_cv (c : Compression) (n : Nat) (s : State) : + (squeezeLoop c n s).1.cv = s.cv := by + induction n generalizing s with + | zero => rfl + | succ n ih => simp only [squeezeLoop, ih, squeezeByte] + +theorem squeezeLoop_finish (c : Compression) (n : Nat) (s : State) : + finish c (squeezeLoop c n (finish c s)).1 = (squeezeLoop c n (finish c s)).1 := by + have hp : (squeezeLoop c n (finish c s)).1.pending = #[] := by + rw [squeezeLoop_pending, finish_pending] + generalize he : (squeezeLoop c n (finish c s)).1 = t at hp ⊢ + simp only [finish, hp, Array.isEmpty_empty, ↓reduceIte] + +/-- Consecutive output calls concatenate, including calls crossing block +boundaries; no intervening frame or challenge opportunity is introduced. -/ +theorem squeeze_concat (c : Compression) (s : State) (a b : Nat) + (ha : a ≠ 0) (hb : b ≠ 0) (limit : s.consumed + (a+b) ≤ maxCursor) : + squeeze c s (a+b) = + match squeeze c s a with + | .error e => .error e + | .ok (t,xs) => match squeeze c t b with + | .error e => .error e + | .ok (u,ys) => .ok (u,xs++ys) := by + have ha' : s.consumed + a ≤ maxCursor := by omega + have hab : a+b ≠ 0 := by omega + simp only [squeeze, ha, hb, hab, ↓reduceIte, ha', limit, + squeezeLoop_consumed, finish_consumed, squeezeLoop_finish] + rw [ite_eq_left (by omega), squeezeLoop_append] + +/-- The cache is relevant only inside a partially consumed block. -/ +def CacheValid (c : Compression) (s : State) : Prop := + s.consumed % 32 ≠ 0 → s.output = outputBlock c s.cv (s.consumed / 32) + +theorem squeezeByte_value (c : Compression) (s : State) (h : CacheValid c s) : + (squeezeByte c s).2 = + outputBlock c s.cv (s.consumed / 32) ⟨s.consumed % 32, Nat.mod_lt _ (by decide)⟩ := by + unfold squeezeByte + split + · rfl + · rename_i hn; rw [h hn] + +theorem squeezeByte_cache (c : Compression) (s : State) (h : CacheValid c s) : + CacheValid c (squeezeByte c s).1 := by + intro hn + have hd : (s.consumed + 1) / 32 = s.consumed / 32 := by + change (s.consumed + 1) % 32 ≠ 0 at hn + omega + simp only [squeezeByte, hd] + split + · rfl + · rename_i hz; exact h hz + +def stream (c : Compression) (cv : Digest32) : Nat → Nat → List Byte + | _, 0 => [] + | offset, n+1 => + outputBlock c cv (offset / 32) ⟨offset % 32, Nat.mod_lt _ (by decide)⟩ :: + stream c cv (offset+1) n + +theorem squeezeLoop_stream (c : Compression) (s : State) (n : Nat) (h : CacheValid c s) : + (squeezeLoop c n s).2 = stream c s.cv s.consumed n := by + induction n generalizing s with + | zero => rfl + | succ n ih => + simp only [squeezeLoop, stream] + rw [squeezeByte_value c s h, ih _ (squeezeByte_cache c s h)] + rfl + +theorem squeezeLoop_cache (c : Compression) (s : State) (n : Nat) (h : CacheValid c s) : + CacheValid c (squeezeLoop c n s).1 := by + induction n generalizing s with + | zero => exact h + | succ n ih => exact ih _ (squeezeByte_cache c s h) + +theorem held_full_block (c : Compression) (s : State) (b : Byte) + (cursor : s.consumed = 0) (full : s.pending.size = 64) : + (absorbByte c s b).cv = + c s.cv (padded s.pending) (absorbTweak s.first false 64 s.previous) true ∧ + (absorbByte c s b).pending = #[b] ∧ + (absorbByte c s b).first = false ∧ (absorbByte c s b).previous = 0 := by + simp [absorbByte, cursor, full] + +theorem held_final_block (c : Compression) (s : State) + (full : s.pending.size = 64) : + finalized c s = c s.cv (padded s.pending) (absorbTweak s.first true 64 s.previous) true := by + have hn : s.pending.isEmpty = false := by + simp only [Array.isEmpty_eq_false_iff] + intro he + simp [he] at full + simp [finalized, hn, full] + +theorem absorbByte_output (c : Compression) (s : State) (b : Byte) : + (absorbByte c s b).output = s.output := by + simp only [absorbByte]; split <;> split <;> rfl + +theorem absorb_output (c : Compression) (s : State) (bs : List Byte) : + (absorb c s bs).output = s.output := by + induction bs generalizing s with + | nil => rfl + | cons b bs ih => exact (ih _).trans (absorbByte_output c s b) + +theorem absorb_nonempty_cursor (c : Compression) (s : State) (bs : List Byte) + (h : bs ≠ []) : (absorb c s bs).consumed = 0 := by + induction bs generalizing s with + | nil => exact False.elim (h rfl) + | cons b bs ih => + cases bs with + | nil => exact absorbByte_cursor c s b + | cons b' bs => exact ih _ (by simp) + +theorem absorb_nonempty_pending (c : Compression) (s : State) (bs : List Byte) + (h : bs ≠ []) : (absorb c s bs).pending.isEmpty = false := by + induction bs generalizing s with + | nil => exact False.elim (h rfl) + | cons b bs ih => + cases bs with + | nil => + simp only [absorb, List.foldl_cons, List.foldl_nil, absorbByte] + split <;> split <;> simp + | cons b' bs => exact ih _ (by simp) + +/-- Completed canonical history interpretation. Squeeze counts are metadata: +replaying a frame does not expand an earlier stream. -/ +def evalFrame (c : Compression) (cv : Digest32) : Frame → Digest32 + | .absorb previous bytes => finalized c (absorb c {cv, previous} bytes) + | .nonce previous bits nonce => + c cv (nonceBlock nonce previous bits) (UInt64.ofNat (9 * 2^56)) true + +def evalHistory (c : Compression) (iv : Digest32) (h : FramedHistory) : Digest32 := + h.frames.foldl (evalFrame c) (seed c iv h.domain h.statement).cv + +def evalTerminal (c : Compression) (cv : Digest32) : Terminal → Digest32 + | .output block => outputBlock c cv block + | .commitment consumed => c cv (wordsBlock [consumed]) (UInt64.ofNat (7 * 2^56)) true + | .powBase consumed bits => c cv (wordsBlock [consumed,bits]) (UInt64.ofNat (8 * 2^56)) true + +def evalCoordinate (c : Compression) (iv : Digest32) (q : Coordinate) : Digest32 := + evalTerminal c (evalHistory c iv q.history) q.terminal + +theorem evalHistory_append (c : Compression) (iv : Digest32) (h : FramedHistory) (fs : List Frame) : + evalHistory c iv {h with frames := h.frames ++ fs} = fs.foldl (evalFrame c) (evalHistory c iv h) := by + simp [evalHistory, List.foldl_append] + +/-- Ghost-only history with an unfinished absorb run. No executable operation +stores this record or copies its history. -/ +structure Model where + history : FramedHistory + run : List Byte := [] + previous : Nat := 0 + consumed : Nat := 0 + +def materialize (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) : State := + absorb c {cv := evalHistory c iv m.history, previous := m.previous, consumed := m.consumed, output := out} m.run + +def Model.Valid (m : Model) : Prop := + (m.run ≠ [] → m.consumed = 0) ∧ (m.run = [] → m.previous = 0) ∧ m.consumed ≤ maxCursor ∧ m.previous ≤ maxCursor + +def Represents (c : Compression) (iv : Digest32) (m : Model) (s : State) : Prop := + m.Valid ∧ s = materialize c iv m s.output ∧ CacheValid c s + +def closeRun (m : Model) : Model := + if m.run = [] then m else + {m with + history := {m.history with frames := m.history.frames ++ [.absorb m.previous m.run]} + run := [] + previous := 0} + +theorem absorbByte_setOutput (c : Compression) (s : State) (out : Digest32) (b : Byte) : + absorbByte c {s with output := out} b = {absorbByte c s b with output := out} := by + simp only [absorbByte] + split <;> split <;> rfl + +theorem absorb_setOutput (c : Compression) (s : State) (out : Digest32) (bs : List Byte) : + absorb c {s with output := out} bs = {absorb c s bs with output := out} := by + induction bs generalizing s with + | nil => rfl + | cons b bs ih => + simp only [absorb, List.foldl_cons] + rw [absorbByte_setOutput] + exact ih _ + +@[simp] theorem finalized_setOutput (c : Compression) (s : State) (out : Digest32) : + finalized c {s with output := out} = finalized c s := rfl + +theorem absorb_switch (c : Compression) (s : State) (bs : List Byte) (hb : bs ≠ []) : + absorb c s bs = absorb c + {s with consumed := 0, previous := if s.consumed = 0 then s.previous else s.consumed} bs := by + cases bs with + | nil => exact False.elim (hb rfl) + | cons b bs => + simp only [absorb, List.foldl_cons] + congr 1 + by_cases hc : s.consumed = 0 + · have he : {s with consumed := 0, previous := s.previous} = s := by + cases s; simp_all + simp only [hc, ↓reduceIte, he] + · simp only [absorbByte, hc, ↓reduceIte] + +theorem materialize_output (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) : + (materialize c iv m out).output = out := absorb_output c _ _ + +theorem materialize_consumed (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) + (valid : m.Valid) : (materialize c iv m out).consumed = m.consumed := by + by_cases hr : m.run = [] + · simp [materialize, hr] + · rw [valid.1 hr] + exact absorb_nonempty_cursor c _ _ hr + +theorem closeRun_valid (m : Model) (h : m.Valid) : (closeRun m).Valid := by + unfold closeRun + split + · exact h + · simp only [Model.Valid] + exact ⟨by simp, by simp, h.2.2.1, by simp [maxCursor]⟩ + +theorem closeRun_empty (m : Model) : (closeRun m).run = [] := by + unfold closeRun; split <;> simp_all + +theorem finish_materialize (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) + (h : m.Valid) : + finish c (materialize c iv m out) = materialize c iv (closeRun m) out := by + by_cases hr : m.run = [] + · simp [closeRun, hr, materialize, finish] + · have hc := h.1 hr + have hp := absorb_nonempty_pending c + ({cv := evalHistory c iv m.history, previous := m.previous, consumed := m.consumed, output := out} : State) m.run hr + have ho := absorb_output c + ({cv := evalHistory c iv m.history, previous := m.previous, consumed := m.consumed, output := out} : State) m.run + have hz := absorb_nonempty_cursor c + ({cv := evalHistory c iv m.history, previous := m.previous, consumed := m.consumed, output := out} : State) m.run hr + simp only [closeRun, hr, ↓reduceIte, materialize, finish, hp, Bool.false_eq_true, + ↓reduceIte, absorb_empty, evalHistory_append, List.foldl_cons, List.foldl_nil] + simp only [hc] at ho hz ⊢ + simp only [ho, hz, evalFrame] + have he := absorb_setOutput c + ({cv := evalHistory c iv m.history, previous := m.previous} : State) out m.run + change absorb c {cv := evalHistory c iv m.history, previous := m.previous, output := out} m.run = + {absorb c {cv := evalHistory c iv m.history, previous := m.previous} m.run with output := out} at he + rw [he, finalized_setOutput] + +def modelAbsorb (m : Model) (bs : List Byte) : Model := + if bs = [] then m else + {m with run := m.run ++ bs, previous := if m.consumed = 0 then m.previous else m.consumed, consumed := 0} + +theorem absorb_materialize (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) + (h : m.Valid) (bs : List Byte) : + absorb c (materialize c iv m out) bs = materialize c iv (modelAbsorb m bs) out := by + by_cases hb : bs = [] + · simp [modelAbsorb, hb] + · by_cases hr : m.run = [] + · simp only [materialize, hr, absorb_empty, modelAbsorb, hb, ↓reduceIte, List.nil_append] + exact absorb_switch c _ _ hb + · have hc := h.1 hr + simp only [modelAbsorb, hb, ↓reduceIte, hc, materialize, absorb_append] + +theorem modelAbsorb_valid (m : Model) (h : m.Valid) (bs : List Byte) : + (modelAbsorb m bs).Valid := by + by_cases hb : bs = [] + · simpa [modelAbsorb, hb] using h + · simp only [modelAbsorb, hb, ↓reduceIte, Model.Valid] + refine ⟨by simp, ?_, by simp [maxCursor], ?_⟩ + · intro he + exact False.elim (hb (List.append_eq_nil_iff.mp he).2) + · split + · exact h.2.2.2 + · exact h.2.2.1 + +theorem absorb_represents (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) (bs : List Byte) : + Represents c iv (modelAbsorb m bs) (absorb c s bs) := by + refine ⟨modelAbsorb_valid m h.1 bs, ?_, ?_⟩ + · rw [absorb_output] + calc + absorb c s bs = absorb c (materialize c iv m s.output) bs := congrArg (fun t => absorb c t bs) h.2.1 + _ = materialize c iv (modelAbsorb m bs) s.output := absorb_materialize c iv m s.output h.1 bs + · by_cases hb : bs = [] + · simpa [hb] using h.2.2 + · intro hn + have hz := absorb_nonempty_cursor c s bs hb + exact False.elim (hn (by rw [hz])) + +theorem seed_represents (c : Compression) (iv domain statement : Digest32) : + Represents c iv ⟨⟨domain,statement,[]⟩,[],0,0⟩ (seed c iv domain statement) := by + refine ⟨?_, ?_, ?_⟩ + · simp [Model.Valid, maxCursor] + · rfl + · simp [CacheValid, seed] + +theorem closeRun_consumed (m : Model) : (closeRun m).consumed = m.consumed := by + unfold closeRun; split <;> rfl + +theorem materialize_closed (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) + (valid : m.Valid) (empty : m.run = []) : + materialize c iv m out = {cv := evalHistory c iv m.history, consumed := m.consumed, output := out} := by + simp only [materialize, empty, absorb_empty, valid.2.1 empty] + +theorem finish_cache (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) : CacheValid c (finish c s) := by + by_cases hr : m.run = [] + · have he : finish c s = s := by + rw [h.2.1, finish_materialize c iv m s.output h.1] + simp [closeRun, hr] + rw [he] + exact h.2.2 + · have hz : s.consumed = 0 := by + rw [h.2.1, materialize_consumed c iv m s.output h.1, h.1.1 hr] + intro hn + exact False.elim (hn (by rw [finish_consumed, hz])) + +theorem finish_represents (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) : Represents c iv (closeRun m) (finish c s) := by + refine ⟨closeRun_valid m h.1, ?_, finish_cache c iv m s h⟩ + have ho : (finish c s).output = s.output := by unfold finish; split <;> rfl + rw [ho] + exact (congrArg (finish c) h.2.1).trans (finish_materialize c iv m s.output h.1) + +theorem state_ext {s t : State} (cv : s.cv = t.cv) (pending : s.pending = t.pending) + (first : s.first = t.first) (previous : s.previous = t.previous) + (consumed : s.consumed = t.consumed) (output : s.output = t.output) : s = t := by + cases s; cases t; simp_all + +theorem squeezeLoop_first (c : Compression) (n : Nat) (s : State) : + (squeezeLoop c n s).1.first = s.first := by + induction n generalizing s with + | zero => rfl + | succ n ih => simp only [squeezeLoop, ih, squeezeByte] + +theorem squeezeLoop_previous (c : Compression) (n : Nat) (s : State) : + (squeezeLoop c n s).1.previous = s.previous := by + induction n generalizing s with + | zero => rfl + | succ n ih => simp only [squeezeLoop, ih, squeezeByte] + +def modelSqueeze (m : Model) (n : Nat) : Model := + if n = 0 then m else {closeRun m with consumed := m.consumed + n} + +theorem squeeze_represents (c : Compression) (iv : Digest32) (m : Model) (s t : State) + (h : Represents c iv m s) (n : Nat) (bs : List Byte) + (ok : squeeze c s n = .ok (t,bs)) : + Represents c iv (modelSqueeze m n) t := by + by_cases hn : n = 0 + · subst n + simp only [squeeze_empty, Except.ok.injEq, Prod.mk.injEq] at ok + rcases ok with ⟨rfl, rfl⟩ + simpa [modelSqueeze] using h + · have hc : s.consumed = m.consumed := by + rw [h.2.1, materialize_consumed c iv m s.output h.1] + unfold squeeze at ok + simp only [hn, ↓reduceIte] at ok + split at ok + next limit => + have he := Except.ok.inj ok + have ht : t = (squeezeLoop c n (finish c s)).1 := (congrArg Prod.fst he).symm + subst t + have hf := finish_represents c iv m s h + have hem := closeRun_empty m + have hm := materialize_closed c iv (closeRun m) (finish c s).output hf.1 hem + have hs : finish c s = {cv := evalHistory c iv (closeRun m).history, consumed := m.consumed, output := (finish c s).output} := by + simpa only [closeRun_consumed] using hf.2.1.trans hm + refine ⟨?_, ?_, squeezeLoop_cache c (finish c s) n hf.2.2⟩ + · simp only [modelSqueeze, hn, ↓reduceIte, Model.Valid, hem] + refine ⟨by simp, fun _ => hf.1.2.1 hem, ?_, hf.1.2.2.2⟩ + simpa only [hc] using limit + · simp only [modelSqueeze, hn, ↓reduceIte, materialize, hem, absorb_empty] + apply state_ext + · rw [squeezeLoop_cv, hs] + · rw [squeezeLoop_pending, finish_pending] + · rw [squeezeLoop_first, hs] + · rw [squeezeLoop_previous, hs, hf.1.2.1 hem] + · rw [squeezeLoop_consumed, finish_consumed, hc] + · rfl + next => cases ok + +/-- The actual bytes, including a partial final block, are exactly the +canonical terminal stream at the completed history; unused bytes are not new +independent challenges and never enter the live chaining value. -/ +theorem squeeze_frame_bytes (c : Compression) (iv : Digest32) (m : Model) (s t : State) + (h : Represents c iv m s) (n : Nat) (bs : List Byte) + (ok : squeeze c s n = .ok (t,bs)) : + bs = stream c (evalHistory c iv (closeRun m).history) m.consumed n := by + by_cases hn : n = 0 + · subst n; simp only [squeeze_empty, Except.ok.injEq, Prod.mk.injEq] at ok + simpa [stream] using ok.2.symm + · have hf := finish_represents c iv m s h + have hm := materialize_closed c iv (closeRun m) (finish c s).output hf.1 (closeRun_empty m) + have hcv := congrArg State.cv (hf.2.1.trans hm) + have hc := materialize_consumed c iv m s.output h.1 + have hsc : s.consumed = m.consumed := (congrArg State.consumed h.2.1).trans hc + unfold squeeze at ok + simp only [hn, ↓reduceIte] at ok + split at ok + next => + have hb := congrArg Prod.snd (Except.ok.inj ok) + rw [squeezeLoop_stream c _ n hf.2.2, hcv, finish_consumed, hsc] at hb + exact hb.symm + next => cases ok + +def modelNonce (m : Model) (nonce : Scalar24) (bits : Nat) : Model := + let m := closeRun m + {history := {m.history with frames := m.history.frames ++ [.nonce m.consumed bits nonce]}} + +theorem nonce_represents (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) (nonce : Scalar24) (bits : Nat) : + Represents c iv (modelNonce m nonce bits) (bindNonce c s nonce bits) := by + have hf := finish_represents c iv m s h + have hm := materialize_closed c iv (closeRun m) (finish c s).output hf.1 (closeRun_empty m) + have hs := hf.2.1.trans hm + refine ⟨?_, ?_, ?_⟩ + · simp [modelNonce, Model.Valid, maxCursor] + · simp only [bindNonce, modelNonce, materialize, absorb_empty, + evalHistory_append, List.foldl_cons, List.foldl_nil, evalFrame] + rw [hs] + · simp [CacheValid, bindNonce] + +theorem bindNonce_finish (c : Compression) (s : State) (nonce : Scalar24) (bits : Nat) : + bindNonce c (finish c s) nonce bits = bindNonce c s nonce bits := by + simp only [bindNonce, finish_idempotent] + +/-- The verification result does not suppress the nonce event on failure. -/ +theorem verifyNonce_represents (c : Compression) (powOK : Digest32 → Scalar24 → Nat → Bool) + (iv : Digest32) (m : Model) (s t : State) (h : Represents c iv m s) + (nonce : Scalar24) (bits : Nat) (accepted : Bool) + (ok : verifyNonce c powOK s nonce bits = .ok (t,accepted)) : + Represents c iv (modelNonce m nonce bits) t := by + unfold verifyNonce at ok + split at ok + next => + have he := congrArg Prod.fst (Except.ok.inj ok) + simp only [bindNonce_finish] at he + rw [← he] + exact nonce_represents c iv m s h nonce bits + next => cases ok + +theorem finalized_history (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) : + finalized c s = evalHistory c iv (closeRun m).history := by + have hf := finish_represents c iv m s h + have hm := materialize_closed c iv (closeRun m) (finish c s).output hf.1 (closeRun_empty m) + exact (finish_cv c s).symm.trans (congrArg State.cv (hf.2.1.trans hm)) + +theorem commitment_frame (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) : + commitment c s = evalCoordinate c iv ⟨(closeRun m).history, .commitment m.consumed⟩ := by + have hc : s.consumed = m.consumed := + (congrArg State.consumed h.2.1).trans (materialize_consumed c iv m s.output h.1) + simp only [commitment, evalCoordinate, evalTerminal, finalized_history c iv m s h, hc] + +theorem powBase_frame (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) (bits : Nat) : + powBase c s bits = evalCoordinate c iv ⟨(closeRun m).history, .powBase m.consumed bits⟩ := by + have hc : s.consumed = m.consumed := + (congrArg State.consumed h.2.1).trans (materialize_consumed c iv m s.output h.1) + simp only [powBase, evalCoordinate, evalTerminal, finalized_history c iv m s h, hc] + +/-- Source-level operations only: finish is internal, not a history-splitting +API. Export and cloning are nonmutating; their correspondence is above. -/ +inductive Reachable (c : Compression) (iv domain statement : Digest32) : Model → State → Prop where + | seed : Reachable c iv domain statement ⟨⟨domain,statement,[]⟩,[],0,0⟩ (seed c iv domain statement) + | absorb {m s} (h : Reachable c iv domain statement m s) (bs : List Byte) : + Reachable c iv domain statement (modelAbsorb m bs) (absorb c s bs) + | squeeze {m s t bs} (h : Reachable c iv domain statement m s) (n : Nat) + (ok : squeeze c s n = .ok (t,bs)) : + Reachable c iv domain statement (modelSqueeze m n) t + | nonce {m s} (h : Reachable c iv domain statement m s) (nonce : Scalar24) (bits : Nat) + (limit : bits ≤ 63) : + Reachable c iv domain statement (modelNonce m nonce bits) (bindNonce c s nonce bits) + +theorem reachable_represents (c : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (h : Reachable c iv domain statement m s) : Represents c iv m s := by + induction h with + | seed => exact seed_represents c iv domain statement + | absorb _ bs ih => exact absorb_represents c iv _ _ ih bs + | squeeze _ n ok ih => exact squeeze_represents c iv _ _ _ ih n _ ok + | nonce _ nonce bits limit ih => exact nonce_represents c iv _ _ ih nonce bits + +/-- Public helper's panic conditions, represented as explicit model errors. -/ +def checkedAbsorbTweak (first last : Bool) (len previous : Nat) : Except Error UInt64 := + if 0 < len ∧ len ≤ 64 ∧ (last = true ∨ len = 64) then + if previous ≤ maxCursor ∧ (first = true ∨ previous = 0) then + .ok (absorbTweak first last len previous) + else .error .absorbCursor + else .error .absorbLength + +theorem checkedAbsorbTweak_ok (first last : Bool) (len previous : Nat) (v : UInt64) + (h : checkedAbsorbTweak first last len previous = .ok v) : + 0 < len ∧ len ≤ 64 ∧ (last = true ∨ len = 64) ∧ + previous ≤ maxCursor ∧ (first = true ∨ previous = 0) ∧ + v = absorbTweak first last len previous := by + unfold checkedAbsorbTweak at h + split at h + next hl => + split at h + next hp => cases h; exact ⟨hl.1,hl.2.1,hl.2.2,hp.1,hp.2,rfl⟩ + next => cases h + next => cases h + +def sample (c : Compression) (s : State) : Except Error (State × Concrete.E) := + match h : squeeze c s 24 with + | .error e => .error e + | .ok (t,bs) => + .ok (t, ByteCodec.decodeE (fun i => bs[i.val]'(by + have hl := (squeeze_exact_cursor c s t 24 bs h).2 + omega))) + +/-- One globally checked request before allocating the vector. Squeezing the +concatenation agrees with repeated samples by `squeeze_concat`. -/ +def sampleVec (c : Compression) (s : State) (n : Nat) : Except Error (State × List Concrete.E) := + match h : squeeze c s (24*n) with + | .error e => .error e + | .ok (t,bs) => + .ok (t, List.ofFn (fun j : Fin n => ByteCodec.decodeE (fun i => + bs[24*j.val+i.val]'(by + have hl := (squeeze_exact_cursor c s t (24*n) bs h).2 + have := j.isLt + have := i.isLt + omega)))) + +theorem sample_frame (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) (t : State) (x : Concrete.E) (ok : sample c s = .ok (t,x)) : + Represents c iv (modelSqueeze m 24) t := by + unfold sample at ok + split at ok + next e he => cases ok + next t' bs hs => + have ht := congrArg Prod.fst (Except.ok.inj ok) + cases ht + exact squeeze_represents c iv m s t h 24 bs hs + +def searchNonce (test : UInt64 → Bool) : Nat → Nat → Option UInt64 + | 0, _ => none + | remaining+1, start => + let n := UInt64.ofNat start + if test n then some n else searchNonce test remaining (start+1) + +/-- Reference smallest-nonce search. Parallel Rust's contiguous-window search +has the same selection rule; this model does not reproduce its scheduling. -/ +def grind (c : Compression) (powOK : Digest32 → Scalar24 → Nat → Bool) + (s : State) (bits : Nat) : Except Error (State × UInt64) := + if bits ≤ 63 then + let s := finish c s + let candidate := if bits = 0 then some (0 : UInt64) else + let base := Array.ofFn (powBase c s bits) + searchNonce (fun n => powOK (fun i => base[i.val]'(by simp only [base, Array.size_ofFn]; exact i.isLt)) + (ByteCodec.encodeE ⟨n,0,0⟩) bits) (2^64) 0 + match candidate with + | none => .error .nonceExhausted + | some n => .ok (bindNonce c s (ByteCodec.encodeE ⟨n,0,0⟩) bits,n) + else .error .grindingBits + +theorem grind_zero (c : Compression) (powOK : Digest32 → Scalar24 → Nat → Bool) (s : State) : + grind c powOK s 0 = .ok (bindNonce c s (ByteCodec.encodeE ⟨0,0,0⟩) 0,0) := by + simp [grind, bindNonce_finish] + +theorem searchNonce_smallest (test : UInt64 → Bool) (remaining start : Nat) (n : UInt64) + (bound : start + remaining ≤ 2^64) (ok : searchNonce test remaining start = some n) : + start ≤ n.toNat ∧ n.toNat < start + remaining ∧ test n = true ∧ + ∀ k, start ≤ k → k < n.toNat → test (UInt64.ofNat k) = false := by + induction remaining generalizing start with + | zero => simp [searchNonce] at ok + | succ remaining ih => + have hs : start < 2^64 := by omega + simp only [searchNonce] at ok + split at ok + next ht => + cases ok + have hn : (UInt64.ofNat start).toNat = start := by + simp only [UInt64.toNat_ofNat', Nat.mod_eq_of_lt hs] + rw [hn] + exact ⟨by omega, by omega, ht, by intros; omega⟩ + next ht => + obtain ⟨hl,hu,hpass,hprior⟩ := ih (start+1) (by omega) ok + refine ⟨by omega, by omega, hpass, ?_⟩ + intro k hk hkn + by_cases he : k = start + · subst k; simpa using ht + · exact hprior k (by omega) hkn + +theorem sampleVec_frame (c : Compression) (iv : Digest32) (m : Model) (s : State) + (h : Represents c iv m s) (n : Nat) (t : State) (xs : List Concrete.E) + (ok : sampleVec c s n = .ok (t,xs)) : + Represents c iv (modelSqueeze m (24*n)) t ∧ xs.length = n := by + unfold sampleVec at ok + split at ok + next e he => cases ok + next t' bs hs => + have ht := congrArg Prod.fst (Except.ok.inj ok) + have hx := congrArg Prod.snd (Except.ok.inj ok) + cases ht + refine ⟨squeeze_represents c iv m s t h (24*n) bs hs, ?_⟩ + simpa using congrArg List.length hx.symm + +theorem squeeze_concatenates (c : Compression) (s : State) (a b : Nat) + (limit : s.consumed + (a+b) ≤ maxCursor) : + squeeze c s (a+b) = + match squeeze c s a with + | .error e => .error e + | .ok (t,xs) => match squeeze c t b with + | .error e => .error e + | .ok (u,ys) => .ok (u,xs++ys) := by + by_cases ha : a = 0 + · subst a + simp only [Nat.zero_add, squeeze_empty, List.nil_append] + cases squeeze c s b <;> rfl + · by_cases hb : b = 0 + · subst b + simp only [Nat.add_zero] + cases squeeze c s a <;> simp [squeeze_empty] + · exact squeeze_concat c s a b ha hb limit + +/-- The query vector and its adjacent lambda occupy one uninterrupted squeeze +run, with exactly 24*(chunks+1) consumed bytes and no intervening message. -/ +theorem query_lambda_concatenates (c : Compression) (s : State) (chunks : Nat) + (limit : s.consumed + 24*(chunks+1) ≤ maxCursor) : + squeeze c s (24*(chunks+1)) = + match squeeze c s (24*chunks) with + | .error e => .error e + | .ok (t,xs) => match squeeze c t 24 with + | .error e => .error e + | .ok (u,ys) => .ok (u,xs++ys) := by + simpa only [Nat.mul_add, Nat.mul_one] using squeeze_concatenates c s (24*chunks) 24 + (by simpa only [Nat.mul_add, Nat.mul_one] using limit) + +theorem grind_frame (c : Compression) (powOK : Digest32 → Scalar24 → Nat → Bool) + (iv : Digest32) (m : Model) (s t : State) (h : Represents c iv m s) + (bits : Nat) (n : UInt64) (ok : grind c powOK s bits = .ok (t,n)) : + Represents c iv (modelNonce m (ByteCodec.encodeE ⟨n,0,0⟩) bits) t := by + unfold grind at ok + split at ok + next hb => + dsimp only at ok + split at ok + next => cases ok + next nonce hc => + have he := Except.ok.inj ok + have hs := congrArg Prod.fst he + have hn := congrArg Prod.snd he + cases hn + simp only [bindNonce_finish] at hs + rw [← hs] + exact nonce_represents c iv m s h _ bits + next => cases ok + +theorem absorbTweak_injective {first last first' last' : Bool} {len previous len' previous' : Nat} + (hl : len ≤ 64) (hl' : len' ≤ 64) (hp : previous ≤ maxCursor) (hp' : previous' ≤ maxCursor) + (same : absorbTweak first last len previous = absorbTweak first' last' len' previous') : + first = first' ∧ last = last' ∧ len = len' ∧ previous = previous' := by + have hr : role first last ≤ 5 := by cases first <;> cases last <;> decide + have hr' : role first' last' ≤ 5 := by cases first' <;> cases last' <;> decide + have hp0 : previous < 2^49 := by unfold maxCursor at hp; omega + have hp0' : previous' < 2^49 := by unfold maxCursor at hp'; omega + have hb : packTweak (role first last) len previous < 2^64 := by unfold packTweak; omega + have hb' : packTweak (role first' last') len' previous' < 2^64 := by unfold packTweak; omega + have he := congrArg UInt64.toNat same + simp only [absorbTweak, UInt64.toNat_ofNat', Nat.mod_eq_of_lt hb, Nat.mod_eq_of_lt hb'] at he + obtain ⟨hrole, hlen, hprev⟩ := packTweak_injective (by omega) (by omega) hp0 hp0' he + obtain ⟨hf,hlast⟩ := role_injective hrole + exact ⟨hf,hlast,hlen,hprev⟩ + +/-- Arithmetic framing is exactly the source's disjoint-field bitwise OR, +not merely an injective alternative encoding. -/ +theorem packTweak_or (r len previous : Nat) (hl : len < 128) (hp : previous < 2^49) : + packTweak r len previous = ((r <<< 56) ||| (len <<< 49)) ||| previous := by + have lower : len * 2^49 + previous < 2^56 := by omega + have h0 := Nat.shiftLeft_add_eq_or_of_lt hp len + have h1 := Nat.shiftLeft_add_eq_or_of_lt lower r + simp only [Nat.shiftLeft_eq] at h0 h1 ⊢ + unfold packTweak + rw [Nat.add_assoc, h1, h0, Nat.or_assoc] + +theorem absorbTweak_source_bits (first last : Bool) (len previous : Nat) + (hl : len ≤ 64) (hp : previous ≤ maxCursor) : + absorbTweak first last len previous = + ((UInt64.ofNat (role first last) <<< 56) ||| (UInt64.ofNat len <<< 49)) ||| + UInt64.ofNat previous := by + have hp' : previous < 2^49 := by unfold maxCursor at hp; omega + rw [absorbTweak, packTweak_or _ _ _ (by omega) hp'] + simp only [UInt64.ofNat_or, UInt64.ofNat_shiftLeft _ 56 (by decide), UInt64.ofNat_shiftLeft _ 49 (by decide)] + rfl + +end Whir.DuplexRefinement diff --git a/verification/whir/Whir/ExecutableOOD.lean b/verification/whir/Whir/ExecutableOOD.lean new file mode 100644 index 000000000..42f0a2578 --- /dev/null +++ b/verification/whir/Whir/ExecutableOOD.lean @@ -0,0 +1,181 @@ +import Whir.TerminalRefinement +import Whir.OODBounds + +/-! OOD separation for the executable array evaluator. Boolean coordinates are +mapped to physical coefficient indices with the first coordinate as the low bit. +Candidate arrays are fixed before the sampled `Array.ofFn` challenge point. -/ +namespace Whir.ExecutableOOD +open Concrete ArrayLayout TerminalRefinement +open scoped BigOperators + +/-- Physical little-endian index of a Boolean vertex. -/ +def cubeIndex : {n : Nat} → Cube n → Nat + | 0, _ => 0 + | n + 1, u => 2 * cubeIndex (fun i : Fin n => u i.succ) + if u 0 then 1 else 0 + +@[simp] theorem cubeIndex_cons {n : Nat} (b : Bool) (u : Cube n) : + cubeIndex (Fin.cons b u) = 2 * cubeIndex u + if b then 1 else 0 := rfl + +theorem cubeIndex_lt {n : Nat} (u : Cube n) : cubeIndex u < 2 ^ n := by + induction n with + | zero => simp [cubeIndex] + | succ n ih => + have h := ih (fun i => u i.succ) + simp only [cubeIndex, pow_succ] + split <;> omega + +theorem cubeIndex_surjective {n : Nat} (i : Nat) (hi : i < 2 ^ n) : + ∃ u : Cube n, cubeIndex u = i := by + induction n generalizing i with + | zero => + refine ⟨Fin.elim0, ?_⟩ + simp only [pow_zero] at hi + simp [cubeIndex, show i = 0 by omega] + | succ n ih => + have hq : i / 2 < 2 ^ n := by + rw [pow_succ] at hi + omega + obtain ⟨u, hu⟩ := ih (i / 2) hq + by_cases hb : i % 2 = 0 + · refine ⟨Fin.cons false u, ?_⟩ + simp only [cubeIndex_cons, Bool.false_eq_true, ↓reduceIte, hu, Nat.add_zero] + omega + · refine ⟨Fin.cons true u, ?_⟩ + simp only [cubeIndex_cons, ↓reduceIte, hu] + omega + +variable {R : Type*} [Inhabited R] + +/-- The actual array coefficient at the explicitly specified Boolean index. -/ +def decode (n : Nat) (a : Array R) : Cube n → R := fun u => a[cubeIndex u]! + +theorem decode_injective (n : Nat) : + Function.Injective (fun a : {a : Array R // a.size = 2 ^ n} => decode n a.val) := by + intro a b h + apply Subtype.ext + apply Array.ext + · exact a.property.trans b.property.symm + · intro i hi hj + obtain ⟨u, hu⟩ := cubeIndex_surjective i (by simpa [a.property] using hi) + have he := congrFun h u + simpa only [decode, hu, getElem!_pos, hi, hj] using he + +variable [CommRing R] [CharP R 2] + +theorem decode_foldLow {n : Nat} (a : Array R) (r : R) + (ha : a.size = 2 ^ (n + 1)) : + decode n (foldLow a r) = foldFirst (decode (n + 1) a) r := by + funext u + have hi : cubeIndex u < a.size / 2 := by + simpa [ha, pow_succ] using cubeIndex_lt u + simp only [decode, foldLow, getElem!_tab _ _ _ hi, foldFirst, cubeIndex_cons, + Bool.false_eq_true, ↓reduceIte, Nat.add_zero, CharTwo.sub_eq_add, foldPair] + ring + +/-- Exact bridge: the executable MLE uses the same coordinate order as `Cube`. +No executable/abstract-evaluator equality is an assumption. -/ +theorem mle_eq_cube {n : Nat} (a : Array R) (r : Fin n → R) + (ha : a.size = 2 ^ n) : + Concrete.mle a (Array.ofFn r) = Whir.mle (decode n a) r := by + induction n generalizing a with + | zero => + have he : Array.ofFn r = #[] := by apply Array.eq_empty_of_size_eq_zero; simp + rw [he, mle_empty a (by simpa using ha)] + simp [Whir.mle, innerProduct, eqWeight, decode, cubeIndex, Cube] + | succ n ih => + rw [Array.ofFn_succ', mle_cons a _ _ (by simpa using ha)] + rw [ih (foldLow a (r 0)) (fun i => r i.succ) (by simp [ha, pow_succ])] + rw [decode_foldLow a (r 0) ha, mle_foldFirst] + congr 1 + ext i + exact Fin.cases rfl (fun _ => rfl) i + +variable {F : Type*} [Field F] [CharP F 2] [Inhabited F] + +/-- The executable evaluator itself, run on symbolic coordinates. -/ +noncomputable def arrayPolynomial {n : Nat} (a : Array F) : + MvPolynomial (Fin n) F := + Concrete.mle (a.map MvPolynomial.C) (Array.ofFn MvPolynomial.X) + +theorem arrayPolynomial_eq {n : Nat} (a : Array F) (ha : a.size = 2 ^ n) : + arrayPolynomial (n := n) a = OODBounds.mlePolynomial (decode n a) := by + unfold arrayPolynomial + rw [mle_eq_cube _ _ (by simpa using ha)] + unfold OODBounds.mlePolynomial + congr 1 + funext u + have hi : cubeIndex u < a.size := by simpa [ha] using cubeIndex_lt u + simp [decode, getElem!_pos, hi] + +theorem eval_arrayPolynomial {n : Nat} (a : Array F) (ha : a.size = 2 ^ n) + (r : Fin n → F) : + MvPolynomial.eval r (arrayPolynomial a) = Concrete.mle a (Array.ofFn r) := by + rw [arrayPolynomial_eq a ha, OODBounds.eval_mlePolynomial, mle_eq_cube a r ha] + +theorem arrayPolynomial_degree {n : Nat} (a : Array F) (ha : a.size = 2 ^ n) : + (arrayPolynomial (n := n) a).totalDegree ≤ n := by + rw [arrayPolynomial_eq a ha] + exact OODBounds.mlePolynomial_degree _ + +theorem arrayPolynomial_injective (n : Nat) : + Function.Injective + (fun a : {a : Array F // a.size = 2 ^ n} => arrayPolynomial (n := n) a.val) := by + intro a b h + change arrayPolynomial (n := n) a.val = arrayPolynomial (n := n) b.val at h + rw [arrayPolynomial_eq a.val a.property, arrayPolynomial_eq b.val b.property] at h + exact decode_injective n (OODBounds.mlePolynomial_injective n h) + +variable [Fintype F] [DecidableEq F] + +/-- Uniform coordinates sampled in array order collide with probability at most +`n / |F|`. The two arrays are fixed, distinct, and have the required exact size. -/ +theorem mle_collision_probability {n : Nat} (a b : Array F) + (ha : a.size = 2 ^ n) (hb : b.size = 2 ^ n) (hne : a ≠ b) : + Soundness.uniformProb (Finset.univ.filter fun r : Fin n → F => + Concrete.mle a (Array.ofFn r) = Concrete.mle b (Array.ofFn r)) ≤ + (n : ℚ) / Fintype.card F := by + classical + simp_rw [mle_eq_cube a _ ha, mle_eq_cube b _ hb] + apply OODBounds.mle_collision_probability + intro h + exact hne (congrArg Subtype.val (decode_injective n (a₁ := ⟨a, ha⟩) (a₂ := ⟨b, hb⟩) h)) + +/-- Commitment-fixed executable candidate arrays are separated except with +probability `choose L 2 * n / |F|`, with unordered pairs charged once. +The valid-size premise is local to the list and does not alter malformed-input +semantics of the executable evaluator. -/ +theorem candidate_separation {n : Nat} (list : Finset (Array F)) + (valid : ∀ a ∈ list, a.size = 2 ^ n) : + Soundness.uniformProb (Finset.univ.filter fun r : Fin n → F => + ∃ a ∈ list, ∃ b ∈ list, a ≠ b ∧ + Concrete.mle a (Array.ofFn r) = Concrete.mle b (Array.ofFn r)) ≤ + (list.card.choose 2 : ℚ) * ((n : ℚ) / Fintype.card F) := by + classical + have hinj : Set.InjOn (decode n) (↑list : Set (Array F)) := by + intro a ha b hb he + exact congrArg Subtype.val + (decode_injective n (a₁ := ⟨a, valid a ha⟩) (a₂ := ⟨b, valid b hb⟩) he) + have h := OODBounds.candidate_separation (list.image (decode n)) + have he : (Finset.univ.filter fun r : Fin n → F => + ∃ f ∈ list.image (decode n), ∃ g ∈ list.image (decode n), + f ≠ g ∧ Whir.mle f r = Whir.mle g r) = + (Finset.univ.filter fun r : Fin n → F => + ∃ a ∈ list, ∃ b ∈ list, a ≠ b ∧ + Concrete.mle a (Array.ofFn r) = Concrete.mle b (Array.ofFn r)) := by + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_image] + constructor + · rintro ⟨_, ⟨a, ha, rfl⟩, _, ⟨b, hb, rfl⟩, hne, he⟩ + exact ⟨a, ha, b, hb, fun h => hne (congrArg (decode n) h), + by simpa only [mle_eq_cube a r (valid a ha), mle_eq_cube b r (valid b hb)] using he⟩ + · rintro ⟨a, ha, b, hb, hne, he⟩ + exact ⟨decode n a, ⟨a, ha, rfl⟩, decode n b, ⟨b, hb, rfl⟩, + fun h => hne (hinj ha hb h), + by simpa only [mle_eq_cube a r (valid a ha), mle_eq_cube b r (valid b hb)] using he⟩ + rw [Finset.card_image_of_injOn hinj] at h + convert h using 1 + apply congrArg Soundness.uniformProb + ext r + simpa only [Finset.mem_filter, Finset.mem_univ, true_and] using Finset.ext_iff.mp he.symm r + +end Whir.ExecutableOOD diff --git a/verification/whir/Whir/ExecutionShapes.lean b/verification/whir/Whir/ExecutionShapes.lean new file mode 100644 index 000000000..79678e77a --- /dev/null +++ b/verification/whir/Whir/ExecutionShapes.lean @@ -0,0 +1,108 @@ +import Whir.CausalExecution +import Whir.InitialSoundness +import Whir.ProductionTransitions + +/-! Dimensions of total actual execution, including malformed prover messages. +Message values never determine weight lengths or the configured fold ladder. -/ +namespace Whir.ExecutionShapes +open Concrete Protocol CausalGame CausalExecution ParameterBounds + +abbrev Input (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) : Public := + ⟨config p, lanes, root, claims⟩ + +def before (c : Config) (i : Nat) : Nat := c.logN - (c.folds.toList.take i).sum + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_before : ∀ p : Profile, ∀ i : Fin (config p).folds.size, + before (config p) i = remaining (config p) i + (config p).folds[i.val]! := by + decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_ood_positive : ∀ p : Profile, ∀ i : Fin (config p).folds.size, + i.val + 1 < (config p).folds.size → 0 < oodCount (config p) i := by + decide +kernel + +@[simp] theorem before_succ (c : Config) (i : Nat) : before c (i + 1) = remaining c i := rfl + +@[simp] theorem ood_weight (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) : + (oodBatch cs p s).1.weight.size = s.weight.size := by + have h := OperationalRefinement.runSteps_invariant (oodStep cs p) + (fun _ pair => pair.1.weight.size = s.weight.size) p.oods.size 0 (s, E.one) rfl + (by intro i pair _ _ h; simpa [oodStep, VerifierState.batch] using h) + exact h + +@[simp] theorem query_weight (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : VerifierState E × E) : + (queryBatch n i cs p qs s).weight.size = s.1.weight.size := by + simp [queryBatch, VerifierState.batch] + +theorem next_shape (c : Config) (ch : Challenges) (p : Opening) (i : Nat) + (s : CheckedState) (n k : Nat) (folds : ch.levels[i]!.folds.size = k) + (start : s.n = n + k) (weight : s.state.weight.size = 2 ^ (n + k)) : + (next c ch p i s).n = n ∧ (next c ch p i s).state.weight.size = 2 ^ n := by + have folded := OracleReplay.foldBlock_prefix_shape (block c i) ch.levels[i]! p.levels[i]! + s n k k le_rfl start weight + simp only [Nat.sub_self, Nat.add_zero] at folded + unfold next Protocol.foldBlock + dsimp only + rw [folds] + exact ⟨folded.1, by simpa only [query_weight, ood_weight] using folded.2⟩ + +/-- Every configured prefix has its exact expected state and weight dimensions. -/ +theorem levelAt_shape (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) (i : Nat) (hi : i ≤ (config p).folds.size) : + (levelAt (Input p lanes root claims) strategy tape i).n = before (config p) i ∧ + (levelAt (Input p lanes root claims) strategy tape i).state.weight.size = + 2 ^ before (config p) i := by + induction i with + | zero => simp [initial, before] + | succ i ih => + have index : i < (config p).folds.size := by omega + have prior := ih (by omega) + have dims := production_before p ⟨i, index⟩ + have start := prior.1.trans dims + have weight := prior.2.trans (congrArg (fun n => 2 ^ n) dims) + rw [levelAt_succ, before_succ] + exact next_shape _ _ _ i _ (remaining (config p) i) (config p).folds[i]! + (TapeValidity.level_shapes (config p) tape i index).1 start weight + +/-- Each individual actual fold prefix matches the physical candidate array width. -/ +theorem foldAt_shape (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) (i : Fin (config p).folds.size) + (j : Nat) (hj : j ≤ (config p).folds[i.val]!) : + (foldAt (Input p lanes root claims) strategy tape i j).n = + remaining (config p) i + ((config p).folds[i.val]! - j) ∧ + (foldAt (Input p lanes root claims) strategy tape i j).state.weight.size = + 2 ^ (remaining (config p) i + ((config p).folds[i.val]! - j)) := by + have prior := levelAt_shape p lanes root claims strategy tape i i.isLt.le + have dims := production_before p i + exact OracleReplay.foldBlock_prefix_shape _ _ _ _ _ _ j hj + (prior.1.trans dims) (prior.2.trans (congrArg (fun n => 2 ^ n) dims)) + +theorem foldAt_end (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i : Nat) (hi : i < input.config.folds.size) : + foldAt input strategy tape i input.config.folds[i]! = + Protocol.foldBlock (block input.config i) (challenges input.config tape).levels[i]! + (proof input strategy tape).levels[i]! (levelAt input strategy tape i) := by + simp only [foldAt, Protocol.foldBlock, (TapeValidity.level_shapes input.config tape i hi).1] + +/-- No honest-witness assumption enters candidate and pending-weight shape alignment. -/ +theorem candidate_weight_size (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) (i : Fin (config p).folds.size) + (j : Nat) (hj : j ≤ (config p).folds[i.val]!) (a : Array E) + (ha : a ∈ foldCandidates (Input p lanes root claims) strategy tape i j) : + (foldAt (Input p lanes root claims) strategy tape i j).state.weight.size = a.size := by + rw [(foldAt_shape p lanes root claims strategy tape i j hj).2] + exact (OracleReplay.candidate_size _ _ _ _ _ _ _ _ a ha).symm + +/-- No fold changes the oracle against which that level authenticates its rows. -/ +theorem foldAt_oracle (input : Public) (strategy : Strategy) (tape : Tape input.config) + (i j : Nat) : + (foldAt input strategy tape i j).oracle = (levelAt input strategy tape i).oracle := by + induction j with + | zero => rfl + | succ j ih => simpa only [foldAt_succ, foldStep] using ih + +end Whir.ExecutionShapes diff --git a/verification/whir/Whir/FiatShamirGame.lean b/verification/whir/Whir/FiatShamirGame.lean new file mode 100644 index 000000000..291f7e35a --- /dev/null +++ b/verification/whir/Whir/FiatShamirGame.lean @@ -0,0 +1,492 @@ +import Whir.Soundness + +/-! Ordinary, classical full-transcript ROM adapter for the #552 framed-history +contract. This module proves causal ancestor completion, its finite allocation +cap, and a stopped grouped sparse-relation reduction. It does not assert Rust +refinement, a compression-mode theorem, PCS RBR soundness, or a PoW advantage. +All those boundaries are explicit below. The reference is #552's +`doc/leanvm/body/08-end-to-end-protocol.tex:60-80` at +`ff6a275304a3b577118b066ddcff83bfafa5998d`; the older #551 transcript +does not inherit this correspondence automatically. -/ +namespace Whir.FiatShamirGame +open scoped BigOperators + +abbrev Byte := Fin 256 +abbrev Digest32 := Fin 32 → Byte +abbrev Scalar24 := Fin 24 → Byte + +/-- Completed absorb runs, not raw API-call logs. The consumed count is history +data: it does not instruct the adapter to expand earlier streams. -/ +inductive Frame where + | absorb (previousConsumed : Nat) (bytes : List Byte) + | nonce (previousConsumed difficulty : Nat) (nonce : Scalar24) + deriving DecidableEq + +structure FramedHistory where + domain : Digest32 + statement : Digest32 + frames : List Frame + deriving DecidableEq + +/-- The three disjoint terminal families of the single DMV mode. -/ +inductive Terminal where + | output (block : Nat) + | commitment (consumed : Nat) + | powBase (consumed difficulty : Nat) + +structure Coordinate where + history : FramedHistory + terminal : Terminal + +/-- The query-vector squeezes and adjacent lambda are indivisible here. -/ +inductive BatchKind where + | initial + | fold (level round : Nat) + | ood (level index dimension : Nat) + | queryAndLambda (level queryChunks : Nat) + | tail (round : Nat) + deriving DecidableEq + +/-- Typed transcript messages identify what must be absorbed/reconstructed. +Merkle side hints are deliberately absent: their authentication is separate. -/ +inductive Message where + | root (digest : Digest32) + | intro (coefficients : List Scalar24) + | roundPolynomial (coefficients : List Scalar24) + | oodAnswer (value : Scalar24) + | residual (values : List Scalar24) + | nonce (difficulty : Nat) (value : Scalar24) + +structure Turn where + messages : List Message + batch : BatchKind + +/-- Specification events, including authenticated but unabsorbed side data. +These fragments state the order required of the source-specific parser; they +are not a theorem equating a hand port to Rust. -/ +inductive Event where + | seed (domain statement : Digest32) + | absorb (message : Message) + | challenge (batch : BatchKind) + | authenticate (level : Nat) + +def initialTrace (domain statement root : Digest32) (boundClaims : List Message) + (intro : List Scalar24) : List Event := + [.seed domain statement, .absorb (.root root)] ++ boundClaims.map Event.absorb ++ + [.challenge .initial, .absorb (.intro intro)] + +def foldTrace (level round : Nat) (coefficients : List Scalar24) : List Event := + [.challenge (.fold level round), .absorb (.roundPolynomial coefficients)] + +def oodTrace (level index dimension : Nat) (answer : Scalar24) + (intro : List Scalar24) : List Event := + [.challenge (.ood level index dimension), .absorb (.oodAnswer answer), + .absorb (.intro intro)] + +/-- `queryChunks` field squeezes plus one scalar are one maximal run, before +authentication/intro. No intermediate prover turn or extra ROM query is added. -/ +def queryTrace (level queryChunks : Nat) (intro : List Scalar24) : List Event := + [.challenge (.queryAndLambda level queryChunks), .authenticate level, + .absorb (.intro intro)] + +/-- A boundary announcement precedes every OOD and query challenge. The final +boundary sends the residual instead of a further commitment. PoW is bound before +the grouped query, but its unground error is used by the theorem below. -/ +def boundaryTrace (level queryChunks : Nat) (boundary : Digest32 ⊕ List Scalar24) + (oods : List (Nat × Scalar24 × List Scalar24)) (dimension difficulty : Nat) + (nonce : Scalar24) (intro : List Scalar24) : List Event := + [Event.absorb (match boundary with | .inl root => .root root | .inr ys => .residual ys)] ++ + oods.flatMap (fun o => oodTrace level o.1 dimension o.2.1 o.2.2) ++ + [.absorb (.nonce difficulty nonce)] ++ queryTrace level queryChunks intro + +/-- A source-specific parser must enforce this boundary on *all* queried +histories, including rejecting continuations. `encode` reconstructs omitted +coefficients using ancestor challenges; the injectivity obligation is on +canonical protocol inputs, not arbitrary raw serialization call logs. -/ +structure TranscriptInterface (Statement ProverMessage Challenge : Type*) where + admissible : Statement → List ProverMessage → Prop + depthCap : Nat + depth_bound : ∀ s p, admissible s p → p.length ≤ depthCap + classify : Statement → List ProverMessage → Turn + encode : Statement → List (ProverMessage × Challenge) → ProverMessage → Coordinate + paddedBlocks : Statement → List ProverMessage → Nat + /-- Charge output expansion and encoding, separately from primitive queries. -/ + encodingCost : Statement → List ProverMessage → Nat + +/-- Full-transcript inputs include every preceding verifier batch. Lists here +are reverse chronological, so the head is the latest prover turn. -/ +structure FullInput (Statement ProverMessage Challenge : Type*) where + statement : Statement + ancestors : List (ProverMessage × Challenge) + current : ProverMessage + deriving DecidableEq + +variable {S M C : Type*} + +/-- Functional semantics of the global cache: repeated inputs necessarily reuse +the same answer. A lazy implementation need only materialize allocated prefixes. -/ +def complete (oracle : FullInput S M C → C) (statement : S) : List M → List (M × C) + | [] => [] + | m :: older => + let ancestors := complete oracle statement older + (m, oracle ⟨statement, ancestors, m⟩) :: ancestors + + theorem complete_erases (oracle : FullInput S M C → C) (s : S) (p : List M) : + (complete oracle s p).map Prod.fst = p := by + induction p with + | nil => rfl + | cons m p ih => simp [complete, ih] + + theorem complete_length (oracle : FullInput S M C → C) (s : S) (p : List M) : + (complete oracle s p).length = p.length := by + have h := congrArg List.length (complete_erases oracle s p) + simpa using h + + theorem full_input_injective (oracle : FullInput S M C → C) + {s t : S} {p q : List M} {m n : M} + (same : (FullInput.mk s (complete oracle s p) m) = + FullInput.mk t (complete oracle t q) n) : s = t ∧ m :: p = n :: q := by + refine ⟨congrArg FullInput.statement same, ?_⟩ + have hm := congrArg FullInput.current same + have hp := congrArg (fun a : FullInput S M C => a.ancestors.map Prod.fst) same + simp only [complete_erases] at hp + change m = n at hm + rw [hm, hp] + +abbrev Cache (S M C : Type*) := (S × List M) → Option C + +structure Allocation (S M C : Type*) where + history : List (M × C) + cache : Cache S M C + fresh : Nat + +/-- Ancestors are completed before looking up the current batch. All branches, +clones, and statements share this cache; a hit performs no oracle request. -/ +def allocate [DecidableEq S] [DecidableEq M] (oracle : FullInput S M C → C) + (s : S) : List M → Cache S M C → Allocation S M C + | [], cache => ⟨[], cache, 0⟩ + | m :: p, cache => + let a := allocate oracle s p cache + match a.cache (s, m :: p) with + | some c => ⟨(m, c) :: a.history, a.cache, a.fresh⟩ + | none => + let c := oracle ⟨s, a.history, m⟩ + ⟨(m, c) :: a.history, Function.update a.cache (s, m :: p) (some c), a.fresh + 1⟩ + +def canonicalAnswer (oracle : FullInput S M C → C) (key : S × List M) : Option C := + match key.2 with + | [] => none + | m :: p => some (oracle ⟨key.1, complete oracle key.1 p, m⟩) + +def CacheCorrect (oracle : FullInput S M C → C) (cache : Cache S M C) : Prop := + ∀ key c, cache key = some c → canonicalAnswer oracle key = some c + +theorem empty_cache_correct (oracle : FullInput S M C → C) : + CacheCorrect oracle (fun _ => none) := by + intro key c h + cases h + +theorem allocate_correct [DecidableEq S] [DecidableEq M] (oracle : FullInput S M C → C) + (s : S) (p : List M) (cache : Cache S M C) (correct : CacheCorrect oracle cache) : + (allocate oracle s p cache).history = complete oracle s p ∧ + CacheCorrect oracle (allocate oracle s p cache).cache := by + induction p generalizing cache with + | nil => exact ⟨rfl, correct⟩ + | cons m p ih => + obtain ⟨hh, hc⟩ := ih cache correct + simp only [allocate] + split + next c h => + have he := hc (s, m :: p) c h + simp only [canonicalAnswer, Option.some.injEq] at he + exact ⟨by simp [complete, hh, he], hc⟩ + next h => + constructor + · simp [complete, hh] + · intro key c he + by_cases hk : key = (s, m :: p) + · subst key + simp only [Function.update_self, Option.some.injEq] at he + simp [canonicalAnswer, hh, ← he] + · exact hc key c (by simpa only [Function.update_of_ne hk] using he) + +theorem allocate_fresh_le [DecidableEq S] [DecidableEq M] (oracle : FullInput S M C → C) + (s : S) (p : List M) (cache : Cache S M C) : + (allocate oracle s p cache).fresh ≤ p.length := by + induction p with + | nil => simp [allocate] + | cons m p ih => + simp only [allocate] + split <;> simp only [List.length_cons] <;> omega + +/-- Every ancestor is allocated before its descendant, regardless of request +order. Prefixes are represented backwards, hence these are nonempty suffixes. -/ +def ancestors : List M → List (List M) + | [] => [] + | m :: p => ancestors p ++ [m :: p] + + theorem ancestors_length (p : List M) : (ancestors p).length = p.length := by + induction p with + | nil => rfl + | cons m p ih => simp [ancestors, ih] + +/-- Flattening deliberately overcounts shared ancestors. The final verification +is one additional request, and simulator requests belong in `requests`. -/ +def allocationWork (requests : List (List M)) : Nat := + (requests.map fun p => (ancestors p).length).sum + + theorem allocation_cap (B K : Nat) (requests : List (List M)) (final : List M) + (budget : requests.length ≤ K) (bounded : ∀ p ∈ requests, p.length ≤ B) + (finalBound : final.length ≤ B) : allocationWork (requests ++ [final]) ≤ B * (K + 1) := by + have sumBound : ∀ (rs : List (List M)), (∀ p ∈ rs, p.length ≤ B) → + allocationWork rs ≤ rs.length * B := by + intro rs hr + induction rs with + | nil => simp [allocationWork] + | cons p ps ih => + have hp := hr p (by simp) + have hi := ih (fun q h => hr q (by simp [h])) + simp only [allocationWork, List.map_cons, List.sum_cons, ancestors_length] at * + simp only [List.length_cons] + nlinarith + have hsum := sumBound requests bounded + simp only [allocationWork, List.map_append, List.sum_append, List.map_cons, + List.map_nil, List.sum_cons, List.sum_nil, Nat.add_zero, ancestors_length] at * + nlinarith + +/-- Serve arbitrary branches and statements through one cache. Invalid +coordinates belong to the independent nonprotocol table, not this routine. -/ +def serve [DecidableEq S] [DecidableEq M] (oracle : FullInput S M C → C) : + List (S × List M) → Cache S M C → Cache S M C × Nat + | [], cache => (cache, 0) + | key :: rest, cache => + let a := allocate oracle key.1 key.2 cache + let b := serve oracle rest a.cache + (b.1, a.fresh + b.2) + +theorem serve_cost_le [DecidableEq S] [DecidableEq M] (oracle : FullInput S M C → C) + (requests : List (S × List M)) (cache : Cache S M C) : + (serve oracle requests cache).2 ≤ allocationWork (requests.map Prod.snd) := by + induction requests generalizing cache with + | nil => simp [serve, allocationWork] + | cons key rest ih => + have ha := allocate_fresh_le oracle key.1 key.2 cache + have hb := ih (allocate oracle key.1 key.2 cache).cache + simpa only [serve, allocationWork, List.map_cons, List.sum_cons, ancestors_length] + using Nat.add_le_add ha hb + +theorem serve_cap [DecidableEq S] [DecidableEq M] (oracle : FullInput S M C → C) + (B K : Nat) (requests : List (S × List M)) (final : S × List M) + (cache : Cache S M C) (budget : requests.length ≤ K) + (bounded : ∀ key ∈ requests, key.2.length ≤ B) (finalBound : final.2.length ≤ B) : + (serve oracle (requests ++ [final]) cache).2 ≤ B * (K + 1) := by + apply (serve_cost_le oracle _ cache).trans + simp only [List.map_append, List.map_cons, List.map_nil] + apply allocation_cap B K (requests.map Prod.snd) final.2 + · simpa using budget + · intro p hp + obtain ⟨key, hk, rfl⟩ := List.mem_map.mp hp + exact bounded key hk + · exact finalBound + +section StoppedGame +variable [Fintype C] [Nonempty C] + +/-- Uniform fresh *whole* vector; overlapping slices must not call this twice. -/ +def average (f : C → ℚ) : ℚ := (∑ c, f c) / Fintype.card C + + theorem average_mono {f g : C → ℚ} (h : ∀ c, f c ≤ g c) : average f ≤ average g := by + exact div_le_div_of_nonneg_right (Finset.sum_le_sum fun c _ => h c) (by positivity) + + theorem average_const (a : ℚ) : average (fun _ : C => a) = a := by + have hn : (Fintype.card C : ℚ) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero + simp [average, hn] + +omit [Nonempty C] in + theorem average_add (f g : C → ℚ) : + average (fun c => f c + g c) = average f + average g := by + simp [average, Finset.sum_add_distrib, add_div] + +omit [Nonempty C] in +/-- Exact finite lazy-sampling identity. A fresh oracle coordinate is uniform +even conditional on arbitrary information about every other coordinate. After +fixing an exposed causal history, `key` is fixed and this identity supplies the +fresh-vector distribution used by `risk`. Repeated coordinates instead reuse +their original table entry. -/ +theorem fresh_coordinate {Key : Type*} [Fintype Key] [DecidableEq Key] + (key : Key) (f : ({j : Key // j ≠ key} → C) → C → ℚ) : + average (fun table : Key → C => f (fun j => table j) (table key)) = + average (fun rest : {j : Key // j ≠ key} → C => average (f rest)) := by + let e := Equiv.piSplitAt key (fun _ : Key => C) + have hs : + (∑ table : Key → C, f (fun j => table j) (table key)) = + ∑ pair : C × ({j : Key // j ≠ key} → C), f pair.2 pair.1 := by + exact Fintype.sum_equiv e _ _ (fun _ => rfl) + have hc := Fintype.card_congr e + unfold average + rw [hs, hc, Fintype.card_prod, Fintype.sum_prod_type] + rw [Finset.sum_comm] + simp only [Nat.cast_mul, ← Finset.sum_div] + ring + +/-- Deterministic adversarial control between fresh allocations. State includes +its coins, complete exposed cache, statement, and every branch it has queried. +`active` permits adaptive stopping, but there is still a deterministic cap. -/ +structure Machine (State Challenge : Type*) where + active : State → Bool + next : State → Challenge → State + accepts : State → Bool + escape : State → Challenge → Bool + +variable {State : Type*} + +/-- Actual finite experiment acceptance, including acceptance on early stop. -/ +def win (G : Machine State C) : Nat → State → ℚ + | 0, s => if G.accepts s then 1 else 0 + | n + 1, s => if G.active s then average (fun c => win G n (G.next s c)) + else if G.accepts s then 1 else 0 + +/-- Probability that at least one allocated vector escapes the sparse relation. -/ +def risk (G : Machine State C) : Nat → State → ℚ + | 0, _ => 0 + | n + 1, s => if G.active s then + average (fun c => if G.escape s c then 1 else risk G n (G.next s c)) else 0 + + theorem risk_nonneg (G : Machine State C) (n : Nat) (s : State) : 0 ≤ risk G n s := by + induction n generalizing s with + | zero => rfl + | succ n ih => + simp only [risk] + split + · rw [← average_const (C := C) 0] + apply average_mono + intro c + split + · norm_num + · exact ih _ + · rfl + + theorem win_le_one (G : Machine State C) (n : Nat) (s : State) : win G n s ≤ 1 := by + induction n generalizing s with + | zero => simp only [win]; split <;> norm_num + | succ n ih => + simp only [win] + split + · rw [← average_const (C := C) 1] + exact average_mono fun c => ih _ + · split <;> norm_num + +/-- The RBR premise is local: nonescaping transitions preserve doom, and a +doomed stopped state cannot accept. No whole-FS soundness premise is assumed. -/ + theorem win_le_risk (G : Machine State C) (doomed : State → Prop) + (terminal : ∀ s, doomed s → G.accepts s = false) + (preserve : ∀ s c, doomed s → G.escape s c = false → doomed (G.next s c)) + (n : Nat) (s : State) (initial : doomed s) : win G n s ≤ risk G n s := by + induction n generalizing s with + | zero => simp [win, risk, terminal s initial] + | succ n ih => + simp only [win, risk] + split + · apply average_mono + intro c + cases he : G.escape s c with + | false => simpa [he] using ih _ (preserve s c initial he) + | true => simpa [he] using win_le_one G n (G.next s c) + · simp [terminal s initial] + +/-- Uniform conditional sparsity must hold at *every* admissible exposed +history, including simulator requests and branches not finally submitted. +The same epsilon bounds whole grouped vectors, never individual query slots. -/ + theorem risk_bound (G : Machine State C) (epsilon : ℚ) (nonneg : 0 ≤ epsilon) + (sparse : ∀ s, average (fun c => if G.escape s c then 1 else 0) ≤ epsilon) + (n : Nat) (s : State) : risk G n s ≤ n * epsilon := by + induction n generalizing s with + | zero => simp [risk] + | succ n ih => + simp only [risk] + split + · calc + _ ≤ average (fun c => (if G.escape s c then 1 else 0) + n * epsilon) := by + apply average_mono + intro c + split + · have hn : (0 : ℚ) ≤ n * epsilon := mul_nonneg (by positivity) nonneg + linarith + · simpa using ih (G.next s c) + _ = average (fun c => if G.escape s c then 1 else 0) + n * epsilon := by + rw [average_add, average_const] + _ ≤ epsilon + n * epsilon := by have h := sparse s; linarith + _ = (n + 1 : Nat) * epsilon := by push_cast; ring + · positivity + + theorem ordinary_soundness (G : Machine State C) (doomed : State → Prop) + (terminal : ∀ s, doomed s → G.accepts s = false) + (preserve : ∀ s c, doomed s → G.escape s c = false → doomed (G.next s c)) + (epsilon : ℚ) (nonneg : 0 ≤ epsilon) + (sparse : ∀ s, average (fun c => if G.escape s c then 1 else 0) ≤ epsilon) + (B K : Nat) (s : State) (initial : doomed s) : + win G (B * (K + 1)) s ≤ min 1 ((B * (K + 1) : Nat) * epsilon) := by + exact le_min (win_le_one G _ s) + ((win_le_risk G doomed terminal preserve _ s initial).trans (risk_bound G epsilon nonneg sparse _ s)) + +end StoppedGame + +/-- Finite real/ideal oracle-view experiments. `View` includes everything the +resource-bounded distinguisher observes, not an adversarial acceptance flag. +The concrete mode/simulator instantiation is a separate cryptographic proof. +Q counts all primitive evaluations, not coordinate requests K or allocations N. -/ +structure ModeGame (Coins View : Type*) where + real : Coins → View + ideal : Coins → View + primitiveQueries : Nat + +def distinguishProbability {Coins View : Type*} [Fintype Coins] + (experiment : Coins → View) (distinguisher : View → Bool) : ℚ := by + classical + exact Soundness.uniformProb (Finset.univ.filter fun r => distinguisher (experiment r) = true) + +/-- A standard distinguishing assumption, universally quantified over the +permitted view distinguishers; it contains no PCS relation or FS acceptance. -/ +def ModeSecure {Coins View : Type*} [Fintype Coins] (G : ModeGame Coins View) + (allowed : (View → Bool) → Prop) (loss : ℚ) : Prop := + ∀ D, allowed D → + |distinguishProbability G.real D - distinguishProbability G.ideal D| ≤ loss + +theorem mode_transfer {Coins View : Type*} [Fintype Coins] (G : ModeGame Coins View) + (allowed : (View → Bool) → Prop) (loss : ℚ) (secure : ModeSecure G allowed loss) + (D : View → Bool) (permitted : allowed D) (bound : ℚ) + (ideal : distinguishProbability G.ideal D ≤ bound) : + distinguishProbability G.real D ≤ bound + loss := by + have h := (abs_le.mp (secure D permitted)).2 + linarith + +/-- DMV's advertised compression-model loss; applicability requires the +subtree-free/radical-decodable/message-decodable mode proof, kept separate. -/ +def dmvLoss (Q : Nat) : ℚ := min 1 ((Q.choose 2 : ℚ) / (2 ^ 256 : ℚ)) + +/-! Remaining instantiation obligations (not axioms): + +* Refine #552's byte framing, canonical root halves, coefficient reconstruction, + consumed counts, 24-byte field codec, and maximal squeeze runs to this interface. + Prove injective parsing on admissible histories (modulo explicit statement + digest-binding loss); route all other coordinates to an independent table. +* Refine the executable `allocate` cache and completed-history encoding to the + protocol parser. `allocate_correct`, `full_input_injective`, and + `fresh_coordinate` justify fresh allocations, not rereading unused/padding + bytes as new challenges. Charge padded vector size, root-to-terminal mode calls, + encoding size, and simulator runtime. +* Instantiate `Machine` with the causal PCS adversary and prove local `preserve`, + `terminal`, and whole-batch `sparse` using the parent's grouped RBR theorem. + For variable-length batches, use projections of uniformly sampled capped + block vectors and prove their codec distribution; uniform sampling from a sum + of differently sized batch types would not supply this premise. + A syntactic parser must include rejecting histories; acceptance cannot define + admissibility. Include simulator coordinate requests in K and final verification + in the extra one. Adaptive stopping uses this deterministic cap. +* Discharge Merkle query-table collision/preimage games and auxiliary binding + losses. Supply the real/ideal mode view games and DMV hypotheses, or state the + resulting primitive assumption. No grinding amplification, runtime-source + correspondence, knowledge extraction, or numerical 128-bit claim follows here. +-/ + +end Whir.FiatShamirGame diff --git a/verification/whir/Whir/FieldCardinality.lean b/verification/whir/Whir/FieldCardinality.lean new file mode 100644 index 000000000..166f7e84a --- /dev/null +++ b/verification/whir/Whir/FieldCardinality.lean @@ -0,0 +1,39 @@ +import Whir.Concrete +import Mathlib.Data.Fintype.Card +import Mathlib.Data.Fintype.Prod +import Mathlib.SetTheory.Cardinal.Finite +import Mathlib.Tactic.NormNum + +/-! Cardinalities of the executable carriers, independently of any field laws. -/ +namespace Whir.FieldModel +open Concrete + +/-- The machine word representation is exactly a 64-bit finite ordinal. -/ +def wordEquiv : K ≃ Fin (2^64) where + toFun := UInt64.toFin + invFun := UInt64.ofFin + left_inv := by intro a; rfl + right_inv := by intro a; rfl + +instance : Fintype K := Fintype.ofEquiv (Fin (2^64)) wordEquiv.symm + +/-- The extension carrier has three independent machine-word coordinates. -/ +def extensionEquiv : E ≃ K × K × K where + toFun a := (a.c0, a.c1, a.c2) + invFun a := ⟨a.1, a.2.1, a.2.2⟩ + left_inv := by intro a; cases a; rfl + right_inv := by intro a; rcases a with ⟨a,b,c⟩; rfl + +instance : Fintype E := Fintype.ofEquiv (K × K × K) extensionEquiv.symm + +@[simp] theorem card_K : Fintype.card K = 2^64 := by + rw [Fintype.card_congr wordEquiv, Fintype.card_fin] + +@[simp] theorem card_E : Fintype.card E = 2^192 := by + rw [Fintype.card_congr extensionEquiv, Fintype.card_prod, Fintype.card_prod, card_K] + norm_num + +@[simp] theorem natCard_E : Nat.card E = 2^192 := by + rw [Nat.card_eq_fintype_card, card_E] + +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldConjugates.lean b/verification/whir/Whir/FieldConjugates.lean new file mode 100644 index 000000000..9fab79aa4 --- /dev/null +++ b/verification/whir/Whir/FieldConjugates.lean @@ -0,0 +1,40 @@ +import Whir.FieldTower +import Whir.RingMapInjectivity + +/-! +# The 64 distinct conjugates of the actual binary quotient generator + +The quotient generator determines every binary-algebra endomorphism. Therefore +equality of two Frobenius powers on that generator gives equality of the entire +endomorphisms. Frobenius has order equal to the certified extension degree 64, +so its first 64 powers, and hence these generator conjugates, are distinct. +-/ +namespace Whir.FieldModel + +noncomputable section + +/-- The exact conjugate-distinctness prerequisite of the ring-switching proof, +now discharged for the actual irreducible degree-64 base modulus. -/ +theorem base_conjugates_injective : Function.Injective + (fun k : Fin 64 => (AdjoinRoot.root baseModulus) ^ (2 ^ k.val)) := by + intro i j h + apply Fin.ext + have hhom : (FiniteField.frobeniusAlgHom F₂ BaseQuotient) ^ i.val = + (FiniteField.frobeniusAlgHom F₂ BaseQuotient) ^ j.val := by + apply AdjoinRoot.algHom_ext + simpa only [AlgHom.coe_pow, FiniteField.coe_frobeniusAlgHom, pow_iterate, + F₂, ZMod.card] using h + exact pow_injOn_Iio_orderOf + (by simpa only [FiniteField.orderOf_frobeniusAlgHom, baseQuotient_finrank, + Set.mem_Iio] using i.isLt) + (by simpa only [FiniteField.orderOf_frobeniusAlgHom, baseQuotient_finrank, + Set.mem_Iio] using j.isLt) hhom + +/-- Any exact base-field embedding transports the certified 64 distinct roots. -/ +theorem embedded_base_conjugates_injective {E : Type*} [Field E] + (φ : BaseQuotient →+* E) : Function.Injective + (fun k : Fin 64 => φ (AdjoinRoot.root baseModulus) ^ (2 ^ k.val)) := + RingMapInjectivity.conjugates_map φ _ base_conjugates_injective + +end +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldEmbedding.lean b/verification/whir/Whir/FieldEmbedding.lean new file mode 100644 index 000000000..13bb20abf --- /dev/null +++ b/verification/whir/Whir/FieldEmbedding.lean @@ -0,0 +1,58 @@ +import Whir.FieldTower + +/-! Embedding the certified base quotient into the actual extension carrier. -/ +namespace Whir.FieldModel +open Concrete Polynomial +noncomputable section + +@[simp] theorem toBaseQuotient_baseEquiv_symm (a : BaseQuotient) : + toBaseQuotient (baseEquiv.symm a) = a := baseEquiv.apply_symm_apply a + +@[simp] theorem toExtensionQuotient_ofK (a : K) : + toExtensionQuotient (E.ofK a) = + AdjoinRoot.of extensionModulus (toBaseQuotient a) := by + simp [toExtensionQuotient, extensionPoly, E.ofK] + +/-- The polynomial-base inclusion, expressed on the actual extension words. -/ +def baseEmbedding : BaseQuotient →+* E where + toFun a := E.ofK (baseEquiv.symm a) + map_zero' := by + apply toExtensionQuotient_injective + change toExtensionQuotient (E.ofK (baseEquiv.symm 0)) = toExtensionQuotient E.zero + simp [toExtensionQuotient_ofK] + map_one' := by + apply toExtensionQuotient_injective + change toExtensionQuotient (E.ofK (baseEquiv.symm 1)) = toExtensionQuotient E.one + simp [toExtensionQuotient_ofK] + map_add' a b := by + apply toExtensionQuotient_injective + change toExtensionQuotient (E.ofK (baseEquiv.symm (a+b))) = + toExtensionQuotient (E.add (E.ofK (baseEquiv.symm a)) (E.ofK (baseEquiv.symm b))) + simp + map_mul' a b := by + apply toExtensionQuotient_injective + change toExtensionQuotient (E.ofK (baseEquiv.symm (a*b))) = + toExtensionQuotient (E.mul (E.ofK (baseEquiv.symm a)) (E.ofK (baseEquiv.symm b))) + simp [toExtensionQuotient_mul] + +@[simp] theorem baseEmbedding_word (a : K) : + baseEmbedding (toBaseQuotient a) = E.ofK a := by + change E.ofK (baseEquiv.symm (baseEquiv a)) = E.ofK a + rw [baseEquiv.symm_apply_apply] + +theorem ofK_injective : Function.Injective E.ofK := by + intro a b h + exact congrArg E.c0 h + +@[simp] theorem ofK_one : E.ofK (1 : K) = (1 : E) := rfl +@[simp] theorem ofK_zero : E.ofK (0 : K) = (0 : E) := rfl + +theorem ofK_xor (a b : K) : E.ofK (a ^^^ b) = E.ofK a + E.ofK b := by + simpa only [map_add, baseEmbedding_word] using congrArg baseEmbedding (toBaseQuotient_xor a b) + +theorem ofK_kmul (a b : K) : E.ofK (kmul a b) = E.ofK a * E.ofK b := by + simpa only [map_mul, baseEmbedding_word] using + congrArg baseEmbedding (toBaseQuotient_kmul a b) + +end +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldEquality.lean b/verification/whir/Whir/FieldEquality.lean new file mode 100644 index 000000000..8a53791f5 --- /dev/null +++ b/verification/whir/Whir/FieldEquality.lean @@ -0,0 +1,16 @@ +import Whir.Concrete + +/-! Boolean equality for the concrete three-word extension representation is exact. +This depends only on UInt64 equality, not on any field arithmetic theorem. -/ +namespace Whir.Concrete + +theorem E_beq_iff (a b : E) : (a == b) = true ↔ a = b := by + cases a + cases b + simp [BEq.beq, instBEqE.beq] + +instance : LawfulBEq E where + rfl := (E_beq_iff _ _).mpr rfl + eq_of_beq := (E_beq_iff _ _).mp + +end Whir.Concrete diff --git a/verification/whir/Whir/FieldEquivalence.lean b/verification/whir/Whir/FieldEquivalence.lean new file mode 100644 index 000000000..559da2fdb --- /dev/null +++ b/verification/whir/Whir/FieldEquivalence.lean @@ -0,0 +1,55 @@ +import Whir.FieldInverse +import Whir.FieldConjugates + +/-! Final, assumption-free representation endpoints. The base carrier is kept +separate from `UInt64`'s native modular-integer arithmetic. The extension ring +is exactly the existing three-word `Concrete.E` operations. -/ +namespace Whir.FieldModel +open Concrete Polynomial +noncomputable section + +instance : Module.Finite BaseQuotient ExtensionQuotient := + extensionModulus_monic.finite_adjoinRoot +instance : Finite ExtensionQuotient := Module.finite_of_finite BaseQuotient +instance : Fintype ExtensionQuotient := Fintype.ofFinite _ + +theorem extensionQuotient_finrank : Module.finrank BaseQuotient ExtensionQuotient = 3 := by + rw [(AdjoinRoot.powerBasis' extensionModulus_monic).finrank, AdjoinRoot.powerBasis'_dim] + exact natDegree_eq_of_degree_eq_some extensionModulus_degree + +@[simp] theorem card_ExtensionQuotient : Fintype.card ExtensionQuotient = 2^192 := by + rw [Module.card_eq_pow_finrank (K := BaseQuotient), extensionQuotient_finrank, + card_BaseQuotient] + norm_num + +theorem toExtensionQuotient_bijective : Function.Bijective toExtensionQuotient := + (Fintype.bijective_iff_injective_and_card _).mpr + ⟨toExtensionQuotient_injective, by rw [card_E, card_ExtensionQuotient]⟩ + +/-- The actual extension arithmetic is isomorphic to the specified cubic quotient. +Both quotient irreducibilities were kernel checked before constructing this map. -/ +def extensionRingEquiv : E ≃+* ExtensionQuotient := + RingEquiv.ofBijective extensionRingHom toExtensionQuotient_bijective + +@[simp] theorem extensionRingEquiv_apply (a : E) : + extensionRingEquiv a = toExtensionQuotient a := rfl + +/-- The exact base generator used by the machine polynomial basis. -/ +theorem baseEmbedding_root : baseEmbedding (AdjoinRoot.root baseModulus) = E.ofK 2 := by + rw [← toBaseQuotient_two, baseEmbedding_word] + +/-- The 64 Frobenius conjugates of the actual word `ofK 2` are distinct. -/ +theorem actual_conjugates_injective : Function.Injective + (fun k : Fin 64 => (E.ofK 2) ^ (2 ^ k.val)) := by + simpa only [baseEmbedding_root] using embedded_base_conjugates_injective baseEmbedding + +/-- No field laws for native `UInt64` arithmetic are installed: the explicit +word bijection has precisely the executable operation-preservation contract. -/ +theorem baseEquiv_operations (a b : K) : + baseEquiv (kadd a b) = baseEquiv a + baseEquiv b ∧ + baseEquiv (kmul a b) = baseEquiv a * baseEquiv b ∧ + baseEquiv (kinv a) = (baseEquiv a)⁻¹ := by + exact ⟨toBaseQuotient_xor a b, toBaseQuotient_kmul a b, toBaseQuotient_kinv a⟩ + +end +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldExtension.lean b/verification/whir/Whir/FieldExtension.lean new file mode 100644 index 000000000..fbeb45aa4 --- /dev/null +++ b/verification/whir/Whir/FieldExtension.lean @@ -0,0 +1,188 @@ +import Whir.FieldModel + +/-! The actual three-coordinate multiplication reduces by `X³ + X + 1`. +This representation is a ring bridge, not a claim that the quotient is a field. -/ +namespace Whir.FieldModel +open Concrete Polynomial +noncomputable section + +/-- The exact cubic used by `Concrete.E.mul`. -/ +def extensionModulus : BaseQuotient[X] := X^3 + X + 1 + +abbrev ExtensionQuotient := AdjoinRoot extensionModulus + +def extensionPoly (a : E) : BaseQuotient[X] := + C (toBaseQuotient a.c0) + C (toBaseQuotient a.c1) * X + + C (toBaseQuotient a.c2) * X^2 + +def toExtensionQuotient (a : E) : ExtensionQuotient := + AdjoinRoot.mk extensionModulus (extensionPoly a) + +@[simp] theorem extensionPoly_zero : extensionPoly E.zero = 0 := by + simp [extensionPoly, E.zero] + +@[simp] theorem extensionPoly_one : extensionPoly E.one = 1 := by + simp [extensionPoly, E.one] + +@[simp] theorem extensionPoly_add (a b : E) : + extensionPoly (E.add a b) = extensionPoly a + extensionPoly b := by + simp only [extensionPoly, E.add, toBaseQuotient_xor, map_add] + ring + +@[simp] theorem toExtensionQuotient_zero : toExtensionQuotient E.zero = 0 := by + simp [toExtensionQuotient] + +@[simp] theorem toExtensionQuotient_one : toExtensionQuotient E.one = 1 := by + simp [toExtensionQuotient] + +@[simp] theorem toExtensionQuotient_add (a b : E) : + toExtensionQuotient (E.add a b) = toExtensionQuotient a + toExtensionQuotient b := by + simp [toExtensionQuotient] + +/-- Polynomial reduction witness, retaining the concrete nine `kmul` calls. -/ +theorem extensionPoly_mul (a b : E) : + extensionPoly (E.mul a b) = extensionPoly a * extensionPoly b + + extensionModulus * + (C (toBaseQuotient a.c1 * toBaseQuotient b.c2 + + toBaseQuotient a.c2 * toBaseQuotient b.c1) + + C (toBaseQuotient a.c2 * toBaseQuotient b.c2) * X) := by + simp only [extensionPoly, E.mul, toBaseQuotient_xor, toBaseQuotient_kmul, + map_add, map_mul, extensionModulus] + ring_nf + simp [CharTwo.two_eq_zero] + +/-- Exact operation preservation for the production extension multiplication. -/ +theorem toExtensionQuotient_mul (a b : E) : + toExtensionQuotient (E.mul a b) = toExtensionQuotient a * toExtensionQuotient b := by + simp [toExtensionQuotient, extensionPoly_mul, AdjoinRoot.mk_self] + +theorem extensionModulus_degree : extensionModulus.degree = 3 := by + unfold extensionModulus + compute_degree <;> norm_num + +theorem extensionModulus_monic : extensionModulus.Monic := by + have h : (X + (1 : BaseQuotient[X])).degree < 3 := by compute_degree; norm_num + convert monic_X_pow_add h using 1; simp only [extensionModulus]; ring + +theorem extensionPoly_degree_lt (a : E) : (extensionPoly a).degree < 3 := by + unfold extensionPoly + compute_degree; norm_num + +theorem extensionPoly_injective : Function.Injective extensionPoly := by + intro a b h + have h0 := congrArg (fun p : BaseQuotient[X] => p.coeff 0) h + have h1 := congrArg (fun p : BaseQuotient[X] => p.coeff 1) h + have h2 := congrArg (fun p : BaseQuotient[X] => p.coeff 2) h + simp [extensionPoly, coeff_C_mul, coeff_X, coeff_X_pow] at h0 h1 h2 + have e0 := toBaseQuotient_injective h0 + have e1 := toBaseQuotient_injective h1 + have e2 := toBaseQuotient_injective h2 + cases a; cases b + simp_all + +theorem toExtensionQuotient_injective : Function.Injective toExtensionQuotient := by + intro a b h + apply extensionPoly_injective + apply sub_eq_zero.mp + by_contra hn + have hd := (degree_sub_le (extensionPoly a) (extensionPoly b)).trans_lt + (max_lt (extensionPoly_degree_lt a) (extensionPoly_degree_lt b)) + rw [← extensionModulus_degree] at hd + exact extensionModulus_monic.not_dvd_of_degree_lt hn hd (AdjoinRoot.mk_eq_mk.mp h) + +instance : Nontrivial ExtensionQuotient := by + refine ⟨⟨toExtensionQuotient E.zero, toExtensionQuotient E.one, ?_⟩⟩ + intro h + have := toExtensionQuotient_injective h + exact (by decide : E.zero ≠ E.one) this + +instance : CharP ExtensionQuotient 2 := + charP_of_injective_algebraMap (algebraMap F₂ ExtensionQuotient).injective 2 + +instance : Neg E := ⟨id⟩ + +/-- Ring laws for the existing `E.add` and `E.mul`, obtained from the faithful +polynomial-quotient representation, not asserted as correctness assumptions. -/ +instance : CommRing E where + add := E.add + zero := E.zero + mul := E.mul + one := E.one + neg := id + nsmul := nsmulRec + zsmul := zsmulRec + add_assoc a b c := by + change E.add (E.add a b) c = E.add a (E.add b c) + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_add]; ring + zero_add a := by + change E.add E.zero a = a + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_add, toExtensionQuotient_zero, zero_add] + add_zero a := by + change E.add a E.zero = a + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_add, toExtensionQuotient_zero, add_zero] + add_comm a b := by + change E.add a b = E.add b a + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_add]; ring + neg_add_cancel a := by + change E.add a a = E.zero + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_add, toExtensionQuotient_zero, CharTwo.add_self_eq_zero] + mul_assoc a b c := by + change E.mul (E.mul a b) c = E.mul a (E.mul b c) + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul]; ring + one_mul a := by + change E.mul E.one a = a + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul, toExtensionQuotient_one, one_mul] + mul_one a := by + change E.mul a E.one = a + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul, toExtensionQuotient_one, mul_one] + mul_comm a b := by + change E.mul a b = E.mul b a + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul]; ring + left_distrib a b c := by + change E.mul a (E.add b c) = E.add (E.mul a b) (E.mul a c) + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul, toExtensionQuotient_add]; ring + right_distrib a b c := by + change E.mul (E.add a b) c = E.add (E.mul a c) (E.mul b c) + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul, toExtensionQuotient_add]; ring + zero_mul a := by + change E.mul E.zero a = E.zero + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul, toExtensionQuotient_zero, zero_mul] + mul_zero a := by + change E.mul a E.zero = E.zero + apply toExtensionQuotient_injective + simp only [toExtensionQuotient_mul, toExtensionQuotient_zero, mul_zero] + +instance : Nontrivial E := ⟨⟨E.zero, E.one, by decide⟩⟩ + +def extensionRingHom : E →+* ExtensionQuotient where + toFun := toExtensionQuotient + map_zero' := toExtensionQuotient_zero + map_one' := toExtensionQuotient_one + map_add' := toExtensionQuotient_add + map_mul' := toExtensionQuotient_mul + +instance : CharP E 2 := extensionRingHom.charP toExtensionQuotient_injective 2 + +/-- Definitional compatibility with the executable operations already used by +`Protocol`, including code elaborated before this ring instance existed. -/ +theorem E_add_def (a b : E) : a + b = E.add a b := rfl +theorem E_mul_def (a b : E) : a * b = E.mul a b := rfl +theorem E_zero_def : (0 : E) = E.zero := rfl +theorem E_one_def : (1 : E) = E.one := rfl +theorem E_default_def : (default : E) = E.zero := rfl + + +end +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldFinite.lean b/verification/whir/Whir/FieldFinite.lean new file mode 100644 index 000000000..fcfbbc4f9 --- /dev/null +++ b/verification/whir/Whir/FieldFinite.lean @@ -0,0 +1,31 @@ +import Whir.FieldModel + +/-! Cardinality and surjectivity of the faithful binary-word quotient map. -/ +namespace Whir.FieldModel +open Concrete Polynomial +noncomputable section + +instance : Module.Finite F₂ BaseQuotient := baseModulus_monic.finite_adjoinRoot +instance : Finite BaseQuotient := Module.finite_of_finite F₂ +instance : Fintype BaseQuotient := Fintype.ofFinite _ + +theorem baseQuotient_finrank : Module.finrank F₂ BaseQuotient = 64 := by + rw [(AdjoinRoot.powerBasis' baseModulus_monic).finrank, AdjoinRoot.powerBasis'_dim] + exact natDegree_eq_of_degree_eq_some baseModulus_degree + +@[simp] theorem card_BaseQuotient : Fintype.card BaseQuotient = 2^64 := by + rw [Module.card_eq_pow_finrank (K := F₂), baseQuotient_finrank] + simp [F₂] + +theorem toBaseQuotient_bijective : Function.Bijective toBaseQuotient := + (Fintype.bijective_iff_injective_and_card _).mpr + ⟨toBaseQuotient_injective, by rw [card_K, card_BaseQuotient]⟩ + +/-- Every quotient class has exactly one 64-bit representative. Multiplication +and XOR preservation are `toBaseQuotient_kmul` and `toBaseQuotient_xor`. -/ +def baseEquiv : K ≃ BaseQuotient := Equiv.ofBijective _ toBaseQuotient_bijective + +@[simp] theorem baseEquiv_apply (a : K) : baseEquiv a = toBaseQuotient a := rfl + +end +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldInverse.lean b/verification/whir/Whir/FieldInverse.lean new file mode 100644 index 000000000..9d8fb7472 --- /dev/null +++ b/verification/whir/Whir/FieldInverse.lean @@ -0,0 +1,77 @@ +import Whir.FieldEmbedding + +/-! The fixed 64-step `kpow` loop and the actual `kinv` exponent implement +ordinary exponentiation and inversion in the certified base field. -/ +namespace Whir.FieldModel +open Concrete + +private def powStep (n : Nat) (s : K × K) (i : Nat) : K × K := + (kmul s.1 s.1, if n.testBit i then kmul s.2 s.1 else s.2) + +private theorem kpow_eq_fold (a : K) (n : Nat) : + kpow a n = ((List.range 64).foldl (powStep n) (a,1)).2 := by + unfold kpow + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size] + simp only [Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + ← apply_ite, List.forIn_pure_yield_eq_foldl, pure_bind] + change (List.foldl _ (a,1) (List.range 64)).2 = _ + apply congrArg (fun s : K × K => s.2) + apply congrArg (fun f => List.foldl f (a,1) (List.range 64)) + funext s i + unfold powStep + split_ifs <;> rfl + +private noncomputable def powInvariant (n i : Nat) (s : K × K) : BaseQuotient := + toBaseQuotient s.2 * toBaseQuotient s.1 ^ (n >>> i) + +private theorem powStep_invariant (n i : Nat) (s : K × K) : + powInvariant n (i+1) (powStep n s i) = powInvariant n i s := by + have hn := Nat.bit_testBit_zero_shiftRight_one (n >>> i) + rw [Nat.bit_val, Nat.testBit_shiftRight, Nat.add_zero, ← Nat.shiftRight_add] at hn + rcases s with ⟨x,z⟩ + unfold powInvariant powStep + dsimp only + rw [toBaseQuotient_kmul] + cases h : n.testBit i <;> + simp only [h, Bool.toNat_false, Bool.toNat_true, Bool.false_eq_true, ↓reduceIte, + toBaseQuotient_kmul] at hn ⊢ <;> + rw [← hn] <;> + simp only [pow_add, pow_mul, pow_zero, pow_one, mul_one, pow_two]; ring + +private theorem powFold_invariant (n len start : Nat) (s : K × K) : + powInvariant n (start+len) ((List.range' start len).foldl (powStep n) s) = + powInvariant n start s := by + induction len generalizing start s with + | zero => simp + | succ len ih => + rw [List.range'_succ, List.foldl_cons, + show start+(len+1) = (start+1)+len by omega, ih, powStep_invariant] + +/-- The exponent bound is essential: `kpow` inspects exactly 64 bits. -/ +theorem toBaseQuotient_kpow (a : K) (n : Nat) (hn : n < 2^64) : + toBaseQuotient (kpow a n) = toBaseQuotient a ^ n := by + have h := powFold_invariant n 64 0 (a,1) + have hs : n >>> 64 = 0 := by + rw [Nat.shiftRight_eq_div_pow, Nat.div_eq_of_lt hn] + rw [kpow_eq_fold] + simpa only [powInvariant, Nat.zero_add, ← List.range_eq_range', hs, + Nat.shiftRight_zero, pow_zero, mul_one, toBaseQuotient_one, one_mul] using h + +/-- Exact correctness of the executable inverse, including zero. -/ +theorem toBaseQuotient_kinv (a : K) : + toBaseQuotient (kinv a) = (toBaseQuotient a)⁻¹ := by + rw [kinv, toBaseQuotient_kpow a _ (by decide)] + by_cases ha : toBaseQuotient a = 0 + · simp [ha] + · have hp : toBaseQuotient a ^ (2^64-2) * toBaseQuotient a = 1 := by + rw [← pow_succ, show (2^64-2)+1 = 2^64-1 by decide] + have h := FiniteField.pow_card_sub_one_eq_one (toBaseQuotient a) ha + rw [card_BaseQuotient] at h + exact h + exact eq_inv_of_mul_eq_one_left hp + +theorem ofK_kinv (a : K) : E.ofK (kinv a) = (E.ofK a)⁻¹ := by + simpa only [map_inv₀, baseEmbedding_word] using + congrArg baseEmbedding (toBaseQuotient_kinv a) + +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldIrreducible.lean b/verification/whir/Whir/FieldIrreducible.lean new file mode 100644 index 000000000..8b8004752 --- /dev/null +++ b/verification/whir/Whir/FieldIrreducible.lean @@ -0,0 +1,108 @@ +import Whir.FieldModel + +/-! Kernel-checked certificates for the specified degree-64 binary modulus. +The certificate arithmetic is the actual 64-step `Concrete.kmul`, already +proved to preserve the quotient interpretation in `FieldModel`. -/ +namespace Whir.FieldModel +open Concrete Polynomial +set_option maxRecDepth 100000 + +/-- Repeated squaring using the actual carryless multiplier. -/ +def squareIter : Nat → K → K + | 0, a => a + | n+1, a => squareIter n (kmul a a) + +theorem toBaseQuotient_squareIter (n : Nat) (a : K) : + toBaseQuotient (squareIter n a) = toBaseQuotient a ^ (2^n) := by + induction n generalizing a with + | zero => simp [squareIter] + | succ n ih => + rw [squareIter, ih, toBaseQuotient_kmul, ← pow_two, ← pow_mul] + congr 1 + omega + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem squareIter_32 : squareIter 32 2 = 0x5c62236777028505 := by decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem squareIter_64 : squareIter 64 2 = 2 := by decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 4000000 in +theorem frobenius_bezout : + kmul 0x53cad161bf5a89c7 (0x5c62236777028505 ^^^ 2) = 1 := by decide +kernel + +theorem toBaseQuotient_two : toBaseQuotient 2 = AdjoinRoot.root baseModulus := by + have h := toBaseQuotient_basis 1 (by decide) + rw [show (1 : K) <<< UInt64.ofNat 1 = 2 by decide +kernel] at h + simpa only [pow_one] using h + +theorem baseModulus_dvd_frobenius64 : + baseModulus ∣ (X^(2^64) - X : F₂[X]) := by + apply AdjoinRoot.mk_eq_zero.mp + simp only [map_sub, map_pow, AdjoinRoot.mk_X] + apply sub_eq_zero.mpr + have h := toBaseQuotient_squareIter 64 2 + rw [squareIter_64, toBaseQuotient_two] at h + exact h.symm + +private theorem coprime_of_quotient_inverse (f g h : F₂[X]) + (hi : AdjoinRoot.mk f h * AdjoinRoot.mk f g = 1) : IsCoprime f g := by + have hd : f ∣ h * g - 1 := + AdjoinRoot.mk_eq_zero.mp (by simp only [map_sub, map_mul, map_one, hi, sub_self]) + obtain ⟨q,hq⟩ := hd + refine ⟨-q, h, ?_⟩ + rw [sub_eq_iff_eq_add] at hq + rw [hq, neg_mul, mul_comm q f, ← add_assoc, neg_add_cancel, zero_add] + +theorem baseModulus_coprime_frobenius32 : + IsCoprime baseModulus (X^(2^32) - X : F₂[X]) := by + have hs := toBaseQuotient_squareIter 32 2 + rw [squareIter_32, toBaseQuotient_two] at hs + apply coprime_of_quotient_inverse _ _ (wordPoly 0x53cad161bf5a89c7) + simp only [map_sub, map_pow, AdjoinRoot.mk_X] + change toBaseQuotient 0x53cad161bf5a89c7 * (_ - _) = 1 + rw [← hs, ← toBaseQuotient_two, CharTwo.sub_eq_add, + ← toBaseQuotient_xor, ← toBaseQuotient_kmul, frobenius_bezout, + toBaseQuotient_one] + +/-- The prime-power-degree specialization of Rabin's irreducibility criterion. +The only prime divisor of 64 is 2, hence only the exponent 32 needs a coprimality +check in addition to the exponent-64 Frobenius identity. -/ +theorem irreducible_degree64_of_rabin (f : F₂[X]) (hdeg : f.natDegree = 64) + (h64 : f ∣ X^(2^64) - X) (h32 : IsCoprime f (X^(2^32) - X)) : + Irreducible f := by + obtain ⟨g,hg,hgf⟩ := exists_irreducible_of_natDegree_pos + (show 0 < f.natDegree by omega) + have hcard : Nat.card F₂ = 2 := Nat.card_zmod 2 + have hd : g.natDegree ∣ 64 := + hg.natDegree_dvd_of_dvd_X_pow_card_pow_sub_X + (by rw [hcard]; exact dvd_trans hgf h64) + have hn : ¬g.natDegree ∣ 32 := by + intro hh + have hg32 : g ∣ X^(2^32) - X := by + have ht := hg.natDegree_dvd_iff_dvd_X_pow_card_pow_sub_X.mp hh + rw [hcard] at ht + exact ht + exact hg.not_isUnit (h32.isUnit_of_dvd' hgf hg32) + have hd' : g.natDegree ∣ 2^6 := hd + obtain ⟨k,hk,hgk⟩ := (Nat.dvd_prime_pow Nat.prime_two).mp hd' + have hk6 : k = 6 := by + by_contra h + apply hn + rw [hgk] + exact Nat.pow_dvd_pow 2 (show k ≤ 5 by omega) + have hgdeg : g.natDegree = 64 := by simpa [hk6] using hgk + have hf0 : f ≠ 0 := by intro h; simp [h] at hdeg + exact (associated_of_dvd_of_natDegree_le hgf hf0 (by omega)).irreducible hg + +theorem baseModulus_irreducible : Irreducible baseModulus := + irreducible_degree64_of_rabin baseModulus + (natDegree_eq_of_degree_eq_some baseModulus_degree) + baseModulus_dvd_frobenius64 baseModulus_coprime_frobenius32 + +instance : Fact (Irreducible baseModulus) := ⟨baseModulus_irreducible⟩ + +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldModel.lean b/verification/whir/Whir/FieldModel.lean new file mode 100644 index 000000000..76840aebe --- /dev/null +++ b/verification/whir/Whir/FieldModel.lean @@ -0,0 +1,317 @@ +import Whir.FieldCardinality +import Mathlib + +/-! Polynomial representations of the actual machine words. The coefficient +map uses XOR, not the native modular-integer addition on `UInt64`. Quotients +are kept separate from machine types; no field instance on `UInt64` is used. -/ +namespace Whir.FieldModel +open Concrete Polynomial +open scoped BigOperators + +noncomputable section +abbrev F₂ := ZMod 2 + +/-- Least-significant-bit-first polynomial representation. -/ +def bitPoly {n : Nat} (a : BitVec n) : F₂[X] := + ∑ i ∈ Finset.range n, monomial i (if a.getLsbD i then 1 else 0) + +@[simp] theorem coeff_bitPoly {n : Nat} (a : BitVec n) (i : Nat) : + (bitPoly a).coeff i = if a.getLsbD i then 1 else 0 := by + classical + by_cases hi : i < n + · simp [bitPoly, coeff_monomial, hi] + · simp [bitPoly, coeff_monomial, hi, + BitVec.getLsbD_of_ge a i (by omega : n ≤ i)] + +@[simp] theorem bitPoly_zero (n : Nat) : bitPoly (0 : BitVec n) = 0 := by + ext i + simp + +@[simp] theorem bitPoly_xor {n : Nat} (a b : BitVec n) : + bitPoly (a ^^^ b) = bitPoly a + bitPoly b := by + ext i + simp only [coeff_bitPoly, coeff_add, BitVec.getLsbD_xor] + cases a.getLsbD i <;> cases b.getLsbD i <;> decide + +theorem bitPoly_injective {n : Nat} : Function.Injective (@bitPoly n) := by + intro a b h + apply BitVec.eq_of_getLsbD_eq_iff.mpr + intro i _ + have hc := congrArg (fun p : F₂[X] => p.coeff i) h + simp only [coeff_bitPoly] at hc + cases ha : a.getLsbD i <;> cases hb : b.getLsbD i <;> simp_all + +/-- The polynomial whose residue class represents an actual base-field word. -/ +def wordPoly (a : K) : F₂[X] := bitPoly a.toBitVec + +@[simp] theorem wordPoly_kadd (a b : K) : + wordPoly (kadd a b) = wordPoly a + wordPoly b := + bitPoly_xor _ _ + +@[simp] theorem wordPoly_xor (a b : K) : + wordPoly (a ^^^ b) = wordPoly a + wordPoly b := wordPoly_kadd a b + +@[simp] theorem wordPoly_zero : wordPoly 0 = 0 := bitPoly_zero 64 + +theorem wordPoly_injective : Function.Injective wordPoly := by + intro a b h + exact UInt64.toBitVec_inj.mp (bitPoly_injective h) + +theorem bitPoly_shiftRight_one {n : Nat} (a : BitVec n) : + bitPoly a = C (if a.getLsbD 0 then (1 : F₂) else 0) + X * bitPoly (a >>> 1) := by + ext i + cases i with + | zero => cases h : a.getLsbD 0 <;> simp [h] + | succ i => cases a.getLsbD 0 <;> simp [coeff_one, Nat.add_comm] + +theorem bitPoly_shiftLeft_one {n : Nat} (a : BitVec (n+1)) : + bitPoly (a <<< 1) = + X * bitPoly a + monomial (n+1) (if a.getLsbD n then 1 else 0) := by + ext i + cases i with + | zero => simp [coeff_monomial] + | succ i => + by_cases hi : i < n + · simp [coeff_X_mul, coeff_monomial, show i+1 < n+1 by omega, + show n ≠ i by omega, -BitVec.getLsbD_eq_getElem] + · by_cases he : i = n + · subst i + cases h : a.getLsbD n <;> + norm_num [h, coeff_X_mul, F₂, -BitVec.getLsbD_eq_getElem] + decide + · have hg : n+1 ≤ i := by omega + simp [coeff_X_mul, coeff_monomial, show ¬ i+1 < n+1 by omega, + show n ≠ i by omega, BitVec.getLsbD_of_ge a i hg] + +@[simp] theorem wordPoly_one : wordPoly 1 = 1 := by + ext i + cases i with + | zero => simp [wordPoly] + | succ i => simp [wordPoly, coeff_one, -BitVec.getLsbD_eq_getElem] + +theorem wordPoly_carryMask : wordPoly 27 = X^4 + X^3 + X + 1 := by + ext i + by_cases hi : i < 5 + · interval_cases i <;> + norm_num [wordPoly, coeff_bitPoly, BitVec.getLsbD, coeff_X, coeff_one, + Nat.testBit_succ] + · have hg : (BitVec.ofNat 64 27).getLsbD i = false := by + change Nat.testBit 27 i = false + apply Nat.testBit_lt_two_pow + exact lt_of_lt_of_le (by decide : 27 < 2^5) + (Nat.pow_le_pow_right (by decide) (by omega)) + simp only [wordPoly, UInt64.toBitVec_ofNat, coeff_bitPoly, hg, Bool.false_eq_true, + ↓reduceIte, coeff_add, coeff_X_pow, coeff_X, coeff_one] + simp [show i ≠ 4 by omega, show i ≠ 3 by omega, show 1 ≠ i by omega, + show i ≠ 0 by omega] + +/-- The reduction polynomial specified by the carry mask `27 = 0b11011`. -/ +def baseModulus : F₂[X] := X^64 + X^4 + X^3 + X + 1 + +/-- This is a quotient ring until irreducibility has separately been proved. -/ +abbrev BaseQuotient := AdjoinRoot baseModulus + +def toBaseQuotient (a : K) : BaseQuotient := AdjoinRoot.mk baseModulus (wordPoly a) + +@[simp] theorem toBaseQuotient_xor (a b : K) : + toBaseQuotient (a ^^^ b) = toBaseQuotient a + toBaseQuotient b := by + simp [toBaseQuotient] + +@[simp] theorem toBaseQuotient_zero : toBaseQuotient 0 = 0 := by + simp [toBaseQuotient] + +@[simp] theorem toBaseQuotient_one : toBaseQuotient 1 = 1 := by + simp [toBaseQuotient] + +private theorem word_shiftLeft (a : K) : + (a <<< 1).toBitVec = a.toBitVec <<< (1 : Nat) := rfl + +private theorem word_shiftRight (a : K) : + (a >>> 1).toBitVec = a.toBitVec >>> (1 : Nat) := rfl + +theorem lowBit_eq (a : K) : (a &&& 1 == 1) = a.toBitVec.getLsbD 0 := by + have h : (a &&& 1).toBitVec = + if a.toBitVec.getLsbD 0 then (1 : BitVec 64) else 0 := by + apply BitVec.eq_of_getLsbD_eq_iff.mpr + intro i _ + change (a.toBitVec &&& 1).getLsbD i = _ + by_cases hi : i = 0 + · subst i; cases h : a.toBitVec.getLsbD 0 <;> + simp [h, -BitVec.getLsbD_eq_getElem] + · cases a.toBitVec.getLsbD 0 <;> simp [hi] + apply Bool.eq_iff_iff.mpr + simp only [beq_iff_eq, UInt64.eq_iff_toBitVec_eq, h] + cases a.toBitVec.getLsbD 0 <;> decide + +theorem carryBit_eq (a : K) : (a >>> 63 == 1) = a.toBitVec.getLsbD 63 := by + have h : (a >>> 63).toBitVec = + if a.toBitVec.getLsbD 63 then (1 : BitVec 64) else 0 := by + apply BitVec.eq_of_getLsbD_eq_iff.mpr + intro i _ + change (a.toBitVec >>> (63 : Nat)).getLsbD i = _ + by_cases hi : i = 0 + · subst i; cases h : a.toBitVec.getLsbD 63 <;> + simp [h, -BitVec.getLsbD_eq_getElem] + · have hg : 64 ≤ 63+i := by omega + cases a.toBitVec.getLsbD 63 <;> + simp [hi, BitVec.getLsbD_of_ge a.toBitVec (63+i) hg] + apply Bool.eq_iff_iff.mpr + simp only [beq_iff_eq, UInt64.eq_iff_toBitVec_eq, h] + cases a.toBitVec.getLsbD 63 <;> decide + +/-- The carry/reduction step appearing verbatim in `Concrete.kmul`. -/ +def xtime (a : K) : K := + if a >>> 63 == 1 then (a <<< 1) ^^^ 27 else a <<< 1 + +theorem wordPoly_xtime (a : K) : + wordPoly (xtime a) = X * wordPoly a + + if a.toBitVec.getLsbD 63 then baseModulus else 0 := by + have hs := bitPoly_shiftLeft_one (n := 63) a.toBitVec + change wordPoly (a <<< 1) = + X * wordPoly a + monomial 64 (if a.toBitVec.getLsbD 63 then 1 else 0) at hs + unfold xtime + rw [carryBit_eq] + cases h : a.toBitVec.getLsbD 63 + · simp [h, -BitVec.getLsbD_eq_getElem] at hs ⊢ + exact hs + · simp only [h, ↓reduceIte, wordPoly_xor, wordPoly_carryMask] at hs ⊢ + rw [hs] + simp only [monomial_one_right_eq_X_pow] + unfold baseModulus + ring + +theorem toBaseQuotient_xtime (a : K) : + toBaseQuotient (xtime a) = + AdjoinRoot.root baseModulus * toBaseQuotient a := by + unfold toBaseQuotient + rw [wordPoly_xtime, map_add, map_mul] + cases a.toBitVec.getLsbD 63 <;> simp [AdjoinRoot.mk_self] + +theorem toBaseQuotient_low (a : K) : + toBaseQuotient a = + (if a &&& 1 == 1 then 1 else 0) + + AdjoinRoot.root baseModulus * toBaseQuotient (a >>> 1) := by + have h := congrArg (AdjoinRoot.mk baseModulus) (bitPoly_shiftRight_one a.toBitVec) + rw [lowBit_eq] + cases hb : a.toBitVec.getLsbD 0 <;> + simpa [toBaseQuotient, wordPoly, word_shiftRight, hb, + -BitVec.getLsbD_eq_getElem] using h + +private def mulStep (s : K × K × K) (_ : Nat) : K × K × K := + (xtime s.1, s.2.1 >>> 1, if s.2.1 &&& 1 == 1 then s.2.2 ^^^ s.1 else s.2.2) + +private theorem kmul_eq_fold (a b : K) : + kmul a b = ((List.range 64).foldl mulStep (a,b,0)).2.2 := by + unfold kmul + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size] + simp only [Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range'] + simp only [← apply_ite] + simp only [List.forIn_pure_yield_eq_foldl, pure_bind] + change (List.foldl _ (a,b,0) (List.range 64)).2.2 = _ + apply congrArg (fun s : K × K × K => s.2.2) + apply congrArg (fun f => List.foldl f (a,b,0) (List.range 64)) + funext s i + unfold mulStep xtime + split_ifs <;> rfl + +private def mulInvariant (s : K × K × K) : BaseQuotient := + toBaseQuotient s.2.2 + toBaseQuotient s.1 * toBaseQuotient s.2.1 + +private theorem mulStep_invariant (s : K × K × K) (i : Nat) : + mulInvariant (mulStep s i) = mulInvariant s := by + rcases s with ⟨x,y,z⟩ + have hy := toBaseQuotient_low y + unfold mulInvariant mulStep + dsimp only + rw [toBaseQuotient_xtime] + cases h : (y &&& 1 == 1) <;> + simp only [h, ↓reduceIte, Bool.false_eq_true, toBaseQuotient_xor] at hy ⊢ <;> + rw [hy] <;> ring + +private theorem fold_mulInvariant (xs : List Nat) (s : K × K × K) : + mulInvariant (xs.foldl mulStep s) = mulInvariant s := by + induction xs generalizing s with + | nil => rfl + | cons i xs ih => rw [List.foldl_cons, ih, mulStep_invariant] + +private theorem fold_right (xs : List Nat) (s : K × K × K) : + (xs.foldl mulStep s).2.1.toBitVec = s.2.1.toBitVec >>> xs.length := by + induction xs generalizing s with + | nil => simp + | cons i xs ih => + rw [List.foldl_cons, ih] + simp only [mulStep, word_shiftRight, List.length_cons] + apply BitVec.eq_of_getLsbD_eq_iff.mpr + intro j _ + simp [Nat.add_comm, Nat.add_assoc] + +/-- Exact operation-preserving bridge for all 64 iterations of the executable +carryless multiplier. This theorem does not assume irreducibility or field laws. -/ +theorem toBaseQuotient_kmul (a b : K) : + toBaseQuotient (kmul a b) = toBaseQuotient a * toBaseQuotient b := by + have hi := fold_mulInvariant (List.range 64) (a,b,0) + have hy := fold_right (List.range 64) (a,b,0) + have hz : ((List.range 64).foldl mulStep (a,b,0)).2.1 = 0 := by + apply UInt64.toBitVec_inj.mp + simpa using hy.trans (by simp [BitVec.ushiftRight_eq_zero]) + rw [kmul_eq_fold] + simpa [mulInvariant, hz] using hi + +theorem bitPoly_degree_lt {n : Nat} (a : BitVec n) : (bitPoly a).degree < n := by + apply (degree_lt_iff_coeff_zero _ _).mpr + intro i hi + simp [BitVec.getLsbD_of_ge a i hi] + +theorem baseModulus_degree : baseModulus.degree = 64 := by + unfold baseModulus + compute_degree <;> norm_num [F₂] + +theorem baseModulus_monic : baseModulus.Monic := by + have h : (X^4 + X^3 + X + (1 : F₂[X])).degree < 64 := by + compute_degree; norm_num + convert monic_X_pow_add h using 1; simp only [baseModulus]; ring + +theorem toBaseQuotient_injective : Function.Injective toBaseQuotient := by + intro a b h + apply wordPoly_injective + apply sub_eq_zero.mp + apply Polynomial.eq_zero_of_dvd_of_degree_lt (AdjoinRoot.mk_eq_mk.mp h) + rw [baseModulus_degree] + exact (degree_sub_le _ _).trans_lt + (max_lt (bitPoly_degree_lt a.toBitVec) (bitPoly_degree_lt b.toBitVec)) + +instance : Nontrivial BaseQuotient := by + refine ⟨⟨toBaseQuotient 0, toBaseQuotient 1, ?_⟩⟩ + intro h + have := toBaseQuotient_injective h + exact (by decide : (0 : K) ≠ 1) this + +instance : CharP BaseQuotient 2 := + charP_of_injective_algebraMap (algebraMap F₂ BaseQuotient).injective 2 + +/-- The actual bit basis, before taking the quotient. -/ +theorem wordPoly_basis (i : Nat) (hi : i < 64) : + wordPoly ((1 : K) <<< UInt64.ofNat i) = X^i := by + ext j + simp only [wordPoly, UInt64.toBitVec_shiftLeft, UInt64.toBitVec_ofNat', + UInt64.toBitVec_ofNat, BitVec.shiftLeft_eq', BitVec.toNat_umod, + BitVec.toNat_ofNat] + norm_num only at * + rw [Nat.mod_eq_of_lt (show i < 18446744073709551616 by omega)] + rw [show (64 : BitVec 64).toNat = 64 by decide] + rw [Nat.mod_eq_of_lt hi] + simp only [coeff_bitPoly, BitVec.getLsbD_shiftLeft, BitVec.getLsbD_one, coeff_X_pow] + by_cases hji : j = i + · subst j; simp [hi] + · by_cases hlt : j < i + · simp [hlt, hji] + · have hj : j-i ≠ 0 := by omega + simp [hlt, hj, hji] + +theorem toBaseQuotient_basis (i : Nat) (hi : i < 64) : + toBaseQuotient ((1 : K) <<< UInt64.ofNat i) = AdjoinRoot.root baseModulus ^ i := by + simp [toBaseQuotient, wordPoly_basis i hi] + +end + +end Whir.FieldModel diff --git a/verification/whir/Whir/FieldTower.lean b/verification/whir/Whir/FieldTower.lean new file mode 100644 index 000000000..5524cee32 --- /dev/null +++ b/verification/whir/Whir/FieldTower.lean @@ -0,0 +1,77 @@ +import Whir.FieldIrreducible +import Whir.FieldFinite +import Whir.FieldExtension +import Whir.FieldEquality + +/-! The cubic is irreducible over the certified 64-dimensional binary field. +A cubic root would satisfy `x^8 = x`; combining this with `x^(2^64) = x` +forces `x^2 = x`, contradicting the cubic at both zero and one. -/ +namespace Whir.FieldModel +open Concrete Polynomial +noncomputable section + +private theorem cubic_no_root (x : BaseQuotient) : ¬ extensionModulus.IsRoot x := by + intro hx + have h0 : x^3 + x + 1 = 0 := by + simpa only [IsRoot, extensionModulus, eval_add, eval_pow, eval_X, eval_one] using hx + have h3 : x^3 = x+1 := CharTwo.add_eq_zero.mp (by simpa only [add_assoc] using h0) + have h4 : x^4 = x^2+x := by + calc + x^4 = x^3*x := by ring + _ = (x+1)*x := by rw [h3] + _ = x^2+x := by ring + have h6 : x^6 = x^2+1 := by + calc + x^6 = (x^3)^2 := by ring + _ = (x+1)^2 := by rw [h3] + _ = x^2+1 := by ring_nf; simp [CharTwo.two_eq_zero] + have h8 : x^8 = x := by + calc + x^8 = x^6*x^2 := by ring + _ = (x^2+1)*x^2 := by rw [h6] + _ = x^4+x^2 := by ring + _ = (x^2+x)+x^2 := by rw [h4] + _ = x := by rw [add_right_comm, CharTwo.add_self_eq_zero, zero_add] + have hp : ∀ n : Nat, x^(2^(3*n+1)) = x^2 := by + intro n + induction n with + | zero => norm_num + | succ n ih => + rw [show 3*(n+1)+1 = (3*n+1)+3 by omega, pow_add, + show (2 : Nat)^3 = 8 by decide, mul_comm (2^(3*n+1)) 8, pow_mul, h8, ih] + have hf : x^(2^64) = x := by + have h := FiniteField.pow_card x + rw [card_BaseQuotient] at h + exact h + have hs : x^2 = x := (hp 21).symm.trans hf + have hz : x * (x-1) = 0 := by + rw [mul_sub, ← pow_two, mul_one, hs, sub_self] + rcases mul_eq_zero.mp hz with hz | ho + · subst x; simp at h0 + · have h1 : x = 1 := sub_eq_zero.mp ho + rw [h1] at h0 + simp only [one_pow, CharTwo.add_self_eq_zero, zero_add] at h0 + exact one_ne_zero h0 + +theorem extensionModulus_irreducible : Irreducible extensionModulus := by + apply irreducible_of_degree_le_three_of_not_isRoot + · rw [natDegree_eq_of_degree_eq_some extensionModulus_degree] + decide + · exact cubic_no_root + +instance : Fact (Irreducible extensionModulus) := ⟨extensionModulus_irreducible⟩ + +instance : IsDomain E := toExtensionQuotient_injective.isDomain extensionRingHom + +/-- A field structure extending the already-proved, executable `E` ring. +The inverse is the unique algebraic inverse; no separate executable extension +inverse existed in `Concrete`. -/ +instance : Field E := Fintype.fieldOfDomain E + +theorem E_field_add_def (a b : E) : a + b = E.add a b := rfl +theorem E_field_mul_def (a b : E) : a * b = E.mul a b := rfl +theorem E_field_zero_def : (0 : E) = E.zero := rfl +theorem E_field_one_def : (1 : E) = E.one := rfl + +end +end Whir.FieldModel diff --git a/verification/whir/Whir/FoldSoundness.lean b/verification/whir/Whir/FoldSoundness.lean new file mode 100644 index 000000000..c0abbd04e --- /dev/null +++ b/verification/whir/Whir/FoldSoundness.lean @@ -0,0 +1,89 @@ +import Whir.CandidateFolding +import Whir.VerifierInvariant + +/-! One actual adversarial fold combines the checked same-set MCA provider with +the actual compact-message root bound. Neither is a soundness hypothesis. -/ +namespace Whir.FoldSoundness +open Concrete Protocol CandidateFolding VerifierInvariant + +private theorem probability_mono {Ω : Type*} [Fintype Ω] (a b : Finset Ω) (h : a ⊆ b) : + Soundness.uniformProb a ≤ Soundness.uniformProb b := by + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast Finset.card_le_card h) (by positivity) + +private theorem probability_union {Ω : Type*} [Fintype Ω] [DecidableEq Ω] (a b : Finset Ω) : + Soundness.uniformProb (a ∪ b) ≤ Soundness.uniformProb a + Soundness.uniformProb b := by + unfold Soundness.uniformProb + rw [← add_div] + exact div_le_div_of_nonneg_right (by exact_mod_cast Finset.card_union_le a b) (by positivity) + +open Classical in +private theorem fold_escape_union {F : Type*} [Field F] [Fintype F] [DecidableEq F] + [Inhabited F] [CharP F 2] (old : Finset (Array F)) (following : F → Finset (Array F)) + (state : VerifierState F) (block lanes : Nat) (next : F → Message F) (bad : Finset F) + (shape : ∀ witness ∈ old, witness.size = (lanes * 2) * block) + (weights : ∀ witness ∈ old, state.weight.size = witness.size) + (lifting : ∀ r ∉ bad, ∀ witness ∈ following r, + ∃ previous ∈ old, witness = foldValues previous block r) + (lost : Lost old state) : + Soundness.uniformProb (Finset.univ.filter fun r => + ¬ Lost (following r) (state.fold block r (next r))) ≤ + (old.card : ℚ) * (2 / Fintype.card F) + Soundness.uniformProb bad := by + classical + let collision := roundBad old state block + have subset : (Finset.univ.filter fun r => + ¬ Lost (following r) (state.fold block r (next r))) ⊆ collision ∪ bad := by + intro r hr + by_cases hc : r ∈ collision + · exact Finset.mem_union.mpr (Or.inl hc) + by_cases hb : r ∈ bad + · exact Finset.mem_union.mpr (Or.inr hb) + exact False.elim ((Finset.mem_filter.mp hr).2 + (fold_lost old (following r) state block lanes r (next r) + shape weights (lifting r hb) hc)) + exact ((probability_mono _ _ subset).trans (probability_union collision bad)).trans + (add_le_add (roundBad_probability old state block lost) le_rfl) + +open Classical in +/-- Pending next messages may depend arbitrarily on the sampled fold challenge. +The old oracle and incoming state are fixed first, as required by the causal game. -/ +theorem concrete_fold_escape (top : Bool) (n rate : Nat) (depth : n + rate ≤ 64) + {lanes : Nat} (degree_pos : 1 ≤ 2 ^ n - 1) + (degree_bound : 2 ^ n - 1 ≤ 2 ^ (n + rate) - 2) + (radius : ℝ) (radius_nonneg : 0 ≤ radius) + (johnson : radius < 1 - Real.sqrt (((2 ^ n - 1 : Nat) : ℝ) / 2 ^ (n + rate))) + (oracle : Fin (lanes * 2) → Fin (2 ^ (n + rate)) → E) + (state : VerifierState E) (next : E → Message E) + (weightSize : state.weight.size = (lanes * 2) * 2 ^ n) + (lost : Lost (arrayCandidates top (concreteEncoder n rate) oracle + ⌈((2 ^ (n + rate) : Nat) : ℝ) * (1 - radius)⌉₊) state) : + let threshold := ⌈((2 ^ (n + rate) : Nat) : ℝ) * (1 - radius)⌉₊ + let old := arrayCandidates top (concreteEncoder n rate) oracle threshold + (Soundness.uniformProb (Finset.univ.filter fun r : E => + ¬ Lost (arrayCandidates top (concreteEncoder n rate) (foldOracle oracle r) threshold) + (state.fold (CandidateFolding.foldBlock top (2 ^ n)) r (next r))) : ℝ) ≤ + (old.card : ℝ) * (2 / (Fintype.card E : ℝ)) + + MutualAgreement.johnsonNumerator (2 ^ (n + rate)) (2 ^ n) radius / Fintype.card E := by + classical + dsimp only + let threshold := ⌈((2 ^ (n + rate) : Nat) : ℝ) * (1 - radius)⌉₊ + let old := arrayCandidates top (concreteEncoder n rate) oracle threshold + let following := fun r => arrayCandidates top (concreteEncoder n rate) + (foldOracle oracle r) threshold + obtain ⟨bad, bound, lifting⟩ := concrete_candidate_provider top n rate depth degree_pos + degree_bound radius radius_nonneg johnson oracle + have result := fold_escape_union old following state (CandidateFolding.foldBlock top (2 ^ n)) + (if top then lanes else lanes * 2 ^ n) next bad + (fun witness hw => arrayCandidates_round_shape top (concreteEncoder n rate) + oracle threshold witness hw) + (fun witness hw => weightSize.trans (arrayCandidates_size top + (concreteEncoder n rate) oracle threshold witness hw).symm) + lifting lost + have resultReal : (Soundness.uniformProb (Finset.univ.filter fun r => + ¬ Lost (following r) (state.fold (CandidateFolding.foldBlock top (2 ^ n)) r (next r))) : ℝ) ≤ + (old.card : ℝ) * (2 / Fintype.card E) + (Soundness.uniformProb bad : ℝ) := by + simpa only [Rat.cast_add, Rat.cast_mul, Rat.cast_div, Rat.cast_ofNat, Rat.cast_natCast] using + (Rat.cast_le (K := ℝ)).mpr result + exact resultReal.trans (add_le_add le_rfl bound) + +end Whir.FoldSoundness diff --git a/verification/whir/Whir/GroupedChallenges.lean b/verification/whir/Whir/GroupedChallenges.lean new file mode 100644 index 000000000..cb452a357 --- /dev/null +++ b/verification/whir/Whir/GroupedChallenges.lean @@ -0,0 +1,95 @@ +import Whir.CausalGame + +/-! Numerical error accounting distinguishes an entire query-vector/adjacent-lambda +message from its coordinates. The estimates below are definitions, not assumed +WHIR escape bounds; a PCS theorem must derive every component from its invariant. -/ +namespace Whir.GroupedChallenges +open scoped BigOperators +open Whir.CausalGame Whir.Protocol + +structure LevelEstimate where + listSize : Nat + mcaNumerator : ℚ + agreementFraction : ℚ + deriving Repr + +abbrev Estimates (c : Config) := Fin c.folds.size → LevelEstimate + +def fieldSize : ℚ := 2 ^ (192 : Nat) + +def initialBatch (c : Config) (est : Estimates c) (claims : Nat) : ℚ := + if h : 0 < c.folds.size then + ((claims - 1 : Nat) : ℚ) * (est ⟨0, h⟩).listSize / fieldSize + else 0 + +def foldError (c : Config) (est : Estimates c) (i : Fin c.folds.size) : ℚ := + (2 * (est i).listSize + (est i).mcaNumerator) / fieldSize + +def oodError (c : Config) (est : Estimates c) (i : Fin c.folds.size) : ℚ := + if h : i.val + 1 < c.folds.size then + (oodCount c i : ℚ) * ((est ⟨i.val + 1, h⟩).listSize.choose 2 : ℚ) * + (remaining c i : ℚ) / fieldSize + else 0 + +/-- There is no prover message between these two challenge components. Conditional +query and batching losses add inside a single oracle-query opportunity. -/ +def queryBatchError (c : Config) (est : Estimates c) (i : Fin c.folds.size) : ℚ := + (est i).agreementFraction ^ c.queries[i.val]! + + if h : i.val + 1 < c.folds.size then + ((c.queries[i.val]! + oodCount c i : Nat) : ℚ) * + (est ⟨i.val + 1, h⟩).listSize / fieldSize + else (c.queries[i.val]! : ℚ) / fieldSize + +/-- No grinding multiplier is deducted from the ideal-interactive errors. -/ +def interactiveError (c : Config) (est : Estimates c) (claims : Nat) : ℚ := + initialBatch c est claims + + (∑ i : Fin c.folds.size, + ((c.folds[i.val]! : ℚ) * foldError c est i + oodError c est i + queryBatchError c est i)) + + (c.logN - c.folds.toList.sum : Nat) * (2 / fieldSize) + +/-- The ordinary-soundness ROM budget multiplies the maximum grouped message loss, +not the maximum loss of a coordinate inside a grouped message. -/ +def groupedMaximum (c : Config) (est : Estimates c) (claims : Nat) : ℚ := + max (initialBatch c est claims) (max (2 / fieldSize) + ((List.ofFn fun i : Fin c.folds.size => + max (foldError c est i) (max (oodError c est i) (queryBatchError c est i))).foldl max 0)) + +/-- A conservative resource-bound expression. Primitive-mode, authentication and +other external reductions must be stated as their own games and proved reductions. -/ +def ordinaryError (vectors : Nat) (eta mode binding auxiliary : ℚ) : ℚ := + min 1 ((vectors : ℚ) * eta + mode + binding + auxiliary) + +section Counting +variable {X Y : Type*} [Fintype X] [Fintype Y] [DecidableEq X] [DecidableEq Y] + +/-- Conditional errors remain charged even if the second bad event depends on the +first challenge. No independence of the two bad events is asserted. -/ +theorem grouped_bad_count (badFirst : Finset X) (badSecond : X → Finset Y) + (bound : Nat) (bounded : ∀ x, (badSecond x).card ≤ bound) : + (Finset.univ.filter (fun xy : X × Y => xy.1 ∈ badFirst ∨ xy.2 ∈ badSecond xy.1)).card ≤ + badFirst.card * Fintype.card Y + Fintype.card X * bound := by + classical + let first : Finset (X × Y) := badFirst ×ˢ Finset.univ + let second : Finset (X × Y) := Finset.univ.biUnion fun x => ({x} : Finset X) ×ˢ badSecond x + have subset : (Finset.univ.filter fun xy : X × Y => + xy.1 ∈ badFirst ∨ xy.2 ∈ badSecond xy.1) ⊆ first ∪ second := by + intro xy hxy + rcases (Finset.mem_filter.mp hxy).2 with h | h + · exact Finset.mem_union_left _ (by simp [first, h]) + · apply Finset.mem_union_right + exact Finset.mem_biUnion.mpr ⟨xy.1, Finset.mem_univ _, Finset.mem_product.mpr ⟨Finset.mem_singleton_self _, h⟩⟩ + calc + _ ≤ (first ∪ second).card := Finset.card_le_card subset + _ ≤ first.card + second.card := Finset.card_union_le _ _ + _ ≤ badFirst.card * Fintype.card Y + ∑ x : X, (badSecond x).card := by + simp only [first, Finset.card_product, Finset.card_univ] + apply Nat.add_le_add_left + exact (Finset.card_biUnion_le).trans_eq (by simp) + _ ≤ _ := by + apply Nat.add_le_add_left + have h : (∑ x : X, (badSecond x).card) ≤ ∑ _x : X, bound := + Finset.sum_le_sum fun x _ => bounded x + simpa using h + +end Counting +end Whir.GroupedChallenges diff --git a/verification/whir/Whir/InducedTerminalRefinement.lean b/verification/whir/Whir/InducedTerminalRefinement.lean new file mode 100644 index 000000000..0c5570238 --- /dev/null +++ b/verification/whir/Whir/InducedTerminalRefinement.lean @@ -0,0 +1,254 @@ +import Whir.AdditiveColumn +import Whir.ExecutableOOD + +/-! Exact evaluation of the executable query columns and the source terminal +subspace recurrence. All algebraic operations are the certified machine fields. -/ +namespace Whir.InducedTerminalRefinement +open Concrete ArrayLayout ExecutableOOD AdditiveCode +open scoped BigOperators +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 + +private theorem cubeIndex_last {n : Nat} (u : Cube (n+1)) : + cubeIndex u = cubeIndex (fun i : Fin n => u i.castSucc) + + 2^n * (if u (Fin.last n) then 1 else 0) := by + induction n with + | zero => simp [cubeIndex] + | succ n ih => + rw [cubeIndex, ih (fun i => u i.succ)] + simp only [cubeIndex, pow_succ, Fin.succ_castSucc, Fin.succ_last, Fin.castSucc_zero] + ring_nf + rfl + +private theorem novel_cube (v : Nat → E) (x : E) {n : Nat} (u : Cube n) : + (novel v n (cubeIndex u)).eval x = + ∏ i : Fin n, if u i then (normalized v i.val).eval x else 1 := by + induction n with + | zero => simp [novel] + | succ n ih => + rw [cubeIndex_last, Fin.prod_univ_castSucc] + have hlt := cubeIndex_lt (fun i : Fin n => u i.castSucc) + cases u (Fin.last n) <;> simp [novel, hlt, ih] + +/-- The actual append/scale column kernel, at the actual little-endian cube index. -/ +theorem decode_column (n q : Nat) : + decode n (column n q) = tensorWeight (fun i : Fin n => + E.ofK (normalizedSubspaces n (UInt64.ofNat q))[i.val]!) := by + funext u + rw [decode, concrete_column, getElem!_tab _ _ _ (cubeIndex_lt u), novel_cube] + unfold tensorWeight + apply Finset.prod_congr rfl + intro i _ + dsimp only + rw [show E.ofK (normalizedSubspaces n (UInt64.ofNat q))[i.val]! = + (normalized (bitBasis E.ofK) i.val).eval (E.ofK (UInt64.ofNat q)) from + normalizedSubspaces_map concreteBaseRepresentation n (UInt64.ofNat q) i.val i.isLt] + +/-- Weighted column aggregation commutes with the explicit array/cube decoding. -/ +theorem decode_induced (n : Nat) (queries : Array Nat) (weights : Array E) : + decode n (induced n queries weights) = inducedWeight + (fun i : Fin queries.size => weights[i.val]!) + (fun i : Fin queries.size => fun k : Fin n => + E.ofK (normalizedSubspaces n (UInt64.ofNat queries[i.val]!))[k.val]!) := by + funext u + simp only [decode, induced, QueryRefinement.inducedColumns_get _ _ _ _ (cubeIndex_lt u), + Array.size_map, inducedWeight, batchWeights] + rw [← Fin.sum_univ_eq_sum_range] + apply Finset.sum_congr rfl + intro i _ + rw [getElem!_pos (queries.map (column n)) i.val (by simp), Array.getElem_map, + ← getElem!_pos queries i.val i.isLt] + exact congrArg (weights[i.val]! * ·) (congrFun (decode_column n queries[i.val]!) u) + +private theorem range_mul_fold (n : Nat) (f : Nat → E) (a : E) : + (List.range n).foldl (fun a i => a * f i) a = a * ∏ i : Fin n, f i.val := by + induction n with + | zero => simp + | succ n ih => simp [List.range_succ, ih, Fin.prod_univ_castSucc, mul_assoc] + +private theorem range_add_fold (n : Nat) (f : Nat → E) (a : E) : + (List.range n).foldl (fun a i => a + f i) a = a + ∑ i : Fin n, f i.val := by + induction n with + | zero => simp + | succ n ih => simp [List.range_succ, ih, Fin.sum_univ_castSucc, add_assoc] + +/-- Closed form of the executable loop, including repeated query indices. -/ +theorem inducedAt_eq_sum (n : Nat) (queries : Array Nat) (weights point : Array E) : + inducedAt n queries weights point = ∑ i : Fin queries.size, weights[i.val]! * + ∏ k : Fin n, (1 + point[k.val]! * + (1 + E.ofK (normalizedSubspaces n (UInt64.ofNat queries[i.val]!))[k.val]!)) := by + unfold inducedAt + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + change (List.range queries.size).foldl (fun out i => out + + (List.range n).foldl (fun p k => p * (1 + point[k]! * + (1 + E.ofK (normalizedSubspaces n (UInt64.ofNat queries[i]!))[k]!))) weights[i]!) 0 = _ + simp_rw [range_mul_fold] + rw [range_add_fold, zero_add] + rfl + +/-- Exact executable induced evaluation; no supplied column correctness predicate. -/ +theorem inducedAt_eq_mle (n : Nat) (queries : Array Nat) (weights point : Array E) + (_hw : weights.size = queries.size) (hp : point.size = n) : + inducedAt n queries weights point = Concrete.mle (induced n queries weights) point := by + let r : Fin n → E := fun i => point[i.val]! + have he : point = Array.ofFn r := by + apply Array.ext + · simp [hp] + · intro i hi hj + simp [r, getElem!_pos, hi] + rw [he, mle_eq_cube _ r (QueryRefinement.size_induced _ _ _), decode_induced, + inducedWeight_mle_charTwo, inducedAt_eq_sum] + simp [r, getElem!_pos] + +/-- The source's explicit zero branch, not an assumption about division by zero. -/ +def nativeInverse (sigma : K) : K := if sigma = 0 then 0 else kinv sigma + +/-- `LevelCtx::basis_at`, verify.rs:181–185. -/ +def nativeLinear (n : Nat) (point : Array E) : Array (E × E) := + point.mapIdx fun k p => (p + 1, p * E.ofK (nativeInverse (subspaceRoots n)[k]!)) + +/-- One source iteration. The subspace recurrence takes place before factors +after the first one, and runs in the extension field on `query_point`. -/ +def nativeStep (roots : Array K) (lin : Array (E × E)) (state : E × E) (k : Nat) : + E × E := + let s := if k = 0 then state.1 else + state.1 * state.1 + state.1 * E.ofK roots[k-1]! + (s, state.2 * (lin[k]!.2 * s + lin[k]!.1)) + +/-- Exact source fold. Zip truncation is retained on malformed weight arrays; +valid callers prove matching lengths. Query words use the UInt64 embedding. -/ +def nativeBasisAt (n : Nat) (queries : Array Nat) (weights point : Array E) : E := + let roots := subspaceRoots n + let lin := nativeLinear n point + (List.range (min queries.size weights.size)).foldl (fun acc i => + let product := ((List.range point.size).foldl (nativeStep roots lin) + (E.ofK (UInt64.ofNat queries[i]!), 1)).2 + weights[i]! * product + acc) 0 + +/-- Every sigma actually used by a valid binary-field level is nonzero. -/ +theorem subspaceRoots_ne_zero (n k : Nat) (hn : n ≤ 64) (hk : k < n) : + (subspaceRoots n)[k]! ≠ 0 := by + intro h + have hr := subspaceRoots_map concreteBaseRepresentation n k (by omega) + simp only [concreteBaseRepresentation] at hr + have hz := root_ne_zero (concrete_bitBasis_independent n hn) hk + apply hz + rw [← hr, h] + exact FieldModel.ofK_zero + +theorem nativeInverse_eq_kinv (n k : Nat) (hn : n ≤ 64) (hk : k < n) : + nativeInverse (subspaceRoots n)[k]! = kinv (subspaceRoots n)[k]! := by + simp [nativeInverse, subspaceRoots_ne_zero n k hn hk] + +private theorem nativeLinear_get (n : Nat) (point : Array E) (k : Nat) + (hk : k < point.size) : + (nativeLinear n point)[k]! = + (point[k]! + 1, point[k]! * E.ofK (nativeInverse (subspaceRoots n)[k]!)) := by + simp [nativeLinear, getElem!_pos, hk] + +private noncomputable def evalSubspace (x : E) (k : Nat) : E := + (subspace (bitBasis E.ofK) k).eval x + +private theorem evalSubspace_succ (n k : Nat) (x : E) (hk : k < n) : + evalSubspace x (k+1) = + evalSubspace x k * evalSubspace x k + + evalSubspace x k * E.ofK (subspaceRoots n)[k]! := by + have h := subspaceRoots_map concreteBaseRepresentation n k (by omega) + simp only [concreteBaseRepresentation] at h + simp only [evalSubspace, subspace, Polynomial.eval_mul, Polynomial.eval_add, + Polynomial.eval_C] + rw [h] + ring + +private theorem native_factor (n k : Nat) (x : K) (point : Array E) + (hn : n ≤ 64) (hp : point.size = n) (hk : k < n) : + (nativeLinear n point)[k]!.2 * evalSubspace (E.ofK x) k + + (nativeLinear n point)[k]!.1 = + 1 + point[k]! * (1 + E.ofK (normalizedSubspaces n x)[k]!) := by + rw [nativeLinear_get n point k (by omega), nativeInverse_eq_kinv n k hn hk] + have h := normalizedSubspaces_map concreteBaseRepresentation n x k hk + simp only [concreteBaseRepresentation] at h + rw [h] + simp only [normalized, Polynomial.eval_mul, Polynomial.eval_C, + FieldModel.ofK_kinv] + have hr := subspaceRoots_map concreteBaseRepresentation n k (by omega) + simp only [concreteBaseRepresentation] at hr + rw [hr] + unfold evalSubspace + ring + +private theorem native_loop (n : Nat) (x : K) (point : Array E) + (hn : n ≤ 64) (hp : point.size = n) (k : Nat) (hk : k ≤ n) : + let state := (List.range k).foldl (nativeStep (subspaceRoots n) (nativeLinear n point)) + (E.ofK x, 1) + state.1 = evalSubspace (E.ofK x) (k-1) ∧ + state.2 = ∏ i : Fin k, + (1 + point[i.val]! * (1 + E.ofK (normalizedSubspaces n x)[i.val]!)) := by + induction k with + | zero => simp [evalSubspace, subspace] + | succ k ih => + obtain ⟨hs, hprod⟩ := ih (by omega) + simp only [List.range_succ, List.foldl_append, List.foldl_cons, List.foldl_nil] + have hs' : (if k = 0 then + ((List.range k).foldl (nativeStep (subspaceRoots n) (nativeLinear n point)) + (E.ofK x, 1)).1 + else + ((List.range k).foldl (nativeStep (subspaceRoots n) (nativeLinear n point)) + (E.ofK x, 1)).1 * + ((List.range k).foldl (nativeStep (subspaceRoots n) (nativeLinear n point)) + (E.ofK x, 1)).1 + + ((List.range k).foldl (nativeStep (subspaceRoots n) (nativeLinear n point)) + (E.ofK x, 1)).1 * E.ofK (subspaceRoots n)[k-1]!) = + evalSubspace (E.ofK x) k := by + rw [hs] + by_cases h : k = 0 + · simp [h] + · simp only [h, ↓reduceIte] + rw [← evalSubspace_succ n (k-1) (E.ofK x) (by omega)] + congr 1 + omega + constructor + · simpa only [nativeStep, Nat.add_sub_cancel] using hs' + · simp only [nativeStep, hs', hprod, native_factor n k x point hn hp (by omega)] + rw [Fin.prod_univ_castSucc] + rfl + +/-- The source recurrence and the executable normalized-column formula agree; +the zero-sigma fallback is proved unreachable, not silently equated to inversion. -/ +theorem nativeBasisAt_eq_inducedAt (n : Nat) (queries : Array Nat) + (weights point : Array E) (hn : n ≤ 64) + (hw : weights.size = queries.size) (hp : point.size = n) : + nativeBasisAt n queries weights point = inducedAt n queries weights point := by + unfold nativeBasisAt + simp only [hw, min_self, hp] + have he : ∀ i : Nat, ((List.range n).foldl (nativeStep (subspaceRoots n) (nativeLinear n point)) + (E.ofK (UInt64.ofNat queries[i]!), 1)).2 = + ∏ k : Fin n, (1 + point[k.val]! * + (1 + E.ofK (normalizedSubspaces n (UInt64.ofNat queries[i]!))[k.val]!)) := + fun i => (native_loop n (UInt64.ofNat queries[i]!) point hn hp n le_rfl).2 + simp_rw [he, add_comm (_ * _)] + rw [range_add_fold, zero_add, inducedAt_eq_sum] + +theorem nativeBasisAt_eq_mle (n : Nat) (queries : Array Nat) + (weights point : Array E) (hn : n ≤ 64) + (hw : weights.size = queries.size) (hp : point.size = n) : + nativeBasisAt n queries weights point = Concrete.mle (induced n queries weights) point := + (nativeBasisAt_eq_inducedAt n queries weights point hn hw hp).trans + (inducedAt_eq_mle n queries weights point hw hp) + +/-- Native `query_point` embeds the actual index word without wrap on every +permitted query domain, including the 64-bit endpoint. -/ +theorem queryWord_toNat (depth q : Nat) (hd : depth ≤ 64) (hq : q < 2^depth) : + (UInt64.ofNat q).toNat = q := by + have hq64 : q < 2^64 := + hq.trans_le (Nat.pow_le_pow_right (by decide) hd) + rw [UInt64.toNat_ofNat', Nat.mod_eq_of_lt hq64] + +#print axioms inducedAt_eq_mle +#print axioms subspaceRoots_ne_zero +#print axioms nativeBasisAt_eq_mle +#print axioms queryWord_toNat + +end Whir.InducedTerminalRefinement diff --git a/verification/whir/Whir/InitialBatching.lean b/verification/whir/Whir/InitialBatching.lean new file mode 100644 index 000000000..f475936b0 --- /dev/null +++ b/verification/whir/Whir/InitialBatching.lean @@ -0,0 +1,279 @@ +import Whir.CausalGame +import Whir.ArrayAlgebra +import Whir.FieldEquivalence + +/-! Initial batching of the actual public claims. The imperative accumulator is +refined to a single polynomial whose coefficient at `j` is the executable +dot-product error of claim `j`. Width and literal zero padding are preserved. + +`escape_probability` counts actual false-claim cancellation over all `2^192` +extension elements, including zero. `candidate_escape_probability` takes the +commitment-fixed family before the public claims; no adaptive post-lambda choice +of coefficients is permitted. `lost_preserved` and `lost_escape_probability` +connect this event to the actual initial lost invariant. Empty claim arrays +have no false constituent and hence zero escape probability. -/ +namespace Whir.InitialBatching +open Concrete Protocol CausalGame ArrayAlgebra ArrayLayout Polynomial +open scoped BigOperators + +private def step (lambda : E) (s : Claim × E) (claim : Claim) : Claim × E := + (⟨weightGlue s.1.weight claim.weight s.2, s.1.value + s.2 * claim.value⟩, + s.2 * lambda) + +private def initial (width : Nat) : Claim × E := + (⟨tab width fun _ => 0, 0⟩, 1) + +private theorem batchClaims_fold (width : Nat) (claims : Array Claim) (lambda : E) : + batchClaims width claims lambda = (claims.foldl (step lambda) (initial width)).1 := by + unfold batchClaims + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + rfl + +private theorem array_push_induction {α : Type*} {P : Array α → Prop} + (empty : P #[]) (push : ∀ a x, P a → P (a.push x)) (a : Array α) : P a := by + rcases a with ⟨xs⟩ + induction xs using List.reverseRecOn with + | nil => exact empty + | @append_singleton xs x ih => simpa using push xs.toArray x ih + +/-- The actual imperative accumulator retains its width, without shape assumptions. -/ +private theorem loop_size (width : Nat) (claims : Array Claim) (lambda : E) : + (claims.foldl (step lambda) (initial width)).1.weight.size = width := by + induction claims using array_push_induction with + | empty => simp [initial] + | @push claims claim ih => simp [step, ih] + +@[simp] theorem batchClaims_size (width : Nat) (claims : Array Claim) (lambda : E) : + (batchClaims width claims lambda).weight.size = width := by + rw [batchClaims_fold] + exact loop_size width claims lambda + +/-- Discrepancy of a constituent, using the executable dense dot product. -/ +def claimError (f : Array E) (claim : Claim) : E := dot f claim.weight - claim.value + +private theorem loop_discrepancy (f : Array E) (claims : Array Claim) (lambda : E) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = f.size) : + let out := claims.foldl (step lambda) (initial f.size) + out.2 = lambda ^ claims.size ∧ + claimError f out.1 = ∑ j ∈ Finset.range claims.size, + lambda ^ j * claimError f claims[j]! := by + induction claims using array_push_induction with + | empty => + simp [initial, claimError, dot_eq_sum] + apply Finset.sum_eq_zero + intro j hj + rw [getElem!_tab _ _ _ (Finset.mem_range.mp hj), mul_zero] + | @push claims claim ih => + have oldShape : ∀ j : Fin claims.size, claims[j].weight.size = f.size := by + intro j + have h := shape ⟨j.val, by simp⟩ + change (claims.push claim)[j.val].weight.size = f.size at h + rw [Array.getElem_push_lt j.isLt] at h + exact h + have newShape : claim.weight.size = f.size := by + simpa using shape ⟨claims.size, by simp⟩ + obtain ⟨power, err⟩ := ih oldShape + dsimp only + rw [Array.foldl_push] + simp only [Array.size_push] + refine ⟨?_, ?_⟩ + · simp only [step, power, pow_succ] + · change dot f (weightGlue + (claims.foldl (step lambda) (initial f.size)).1.weight claim.weight + (claims.foldl (step lambda) (initial f.size)).2) - + ((claims.foldl (step lambda) (initial f.size)).1.value + + (claims.foldl (step lambda) (initial f.size)).2 * claim.value) = _ + rw [dot_weightGlue _ _ _ _ (loop_size _ _ _) newShape] + rw [power, Finset.sum_range_succ] + have oldSum : (∑ j ∈ Finset.range claims.size, + lambda ^ j * claimError f (claims.push claim)[j]!) = + ∑ j ∈ Finset.range claims.size, lambda ^ j * claimError f claims[j]! := by + apply Finset.sum_congr rfl + intro j hj + have h := Finset.mem_range.mp hj + rw [getElem!_pos (claims.push claim) j (by simp; omega), + getElem!_pos claims j h, Array.getElem_push_lt h] + rw [oldSum] + rw [getElem!_pos (claims.push claim) claims.size (by simp), Array.getElem_push_eq] + dsimp [claimError] at err ⊢ + rw [← err] + ring + +/-- One polynomial, with no hidden lambda dependence in any coefficient. -/ +noncomputable def errorPolynomial (f : Array E) (claims : Array Claim) : E[X] := + ∑ j ∈ Finset.range claims.size, monomial j (claimError f claims[j]!) + +theorem errorPolynomial_eval (f : Array E) (claims : Array Claim) (lambda : E) : + (errorPolynomial f claims).eval lambda = + ∑ j ∈ Finset.range claims.size, lambda ^ j * claimError f claims[j]! := by + simp [errorPolynomial, eval_finsetSum, mul_comm] + +/-- Exact actual-loop discrepancy, including lambda zero and empty claim arrays. -/ +theorem batchClaims_discrepancy (f : Array E) (claims : Array Claim) (lambda : E) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = f.size) : + dot f (batchClaims f.size claims lambda).weight - + (batchClaims f.size claims lambda).value = + (errorPolynomial f claims).eval lambda := by + rw [batchClaims_fold, errorPolynomial_eval] + exact (loop_discrepancy f claims lambda shape).2 + +theorem errorPolynomial_coeff (f : Array E) (claims : Array Claim) (j : Nat) + (hj : j < claims.size) : + (errorPolynomial f claims).coeff j = claimError f claims[j]! := by + simp only [errorPolynomial, finsetSum_coeff, coeff_monomial] + rw [Finset.sum_eq_single j] + · simp + · intro b _ hne + simp [hne] + · simp [hj] + +theorem errorPolynomial_degree (f : Array E) (claims : Array Claim) : + (errorPolynomial f claims).natDegree ≤ claims.size - 1 := by + apply natDegree_sum_le_of_forall_le + intro j hj + exact (natDegree_monomial_le _).trans (by have := Finset.mem_range.mp hj; omega) + +theorem errorPolynomial_ne_zero (f : Array E) (claims : Array Claim) + (bad : ∃ j : Fin claims.size, dot f claims[j].weight ≠ claims[j].value) : + errorPolynomial f claims ≠ 0 := by + obtain ⟨j, hj⟩ := bad + intro h + have hc := errorPolynomial_coeff f claims j j.isLt + rw [h] at hc + exact hj (sub_eq_zero.mp (by simpa [claimError, getElem!_pos] using hc.symm)) + +/-- Padding remains literal zero, even for malformed weight lengths. -/ +theorem batchClaims_zero_tail (width live : Nat) (claims : Array Claim) (lambda : E) + (tail : ∀ j : Fin claims.size, ∀ i, live ≤ i → i < width → + claims[j].weight[i]! = 0) : + ∀ i, live ≤ i → i < width → (batchClaims width claims lambda).weight[i]! = 0 := by + rw [batchClaims_fold] + induction claims using array_push_induction with + | empty => + intro i _ hi + simp [initial, getElem!_tab _ _ _ hi] + | @push claims claim ih => + have oldTail : ∀ j : Fin claims.size, ∀ i, live ≤ i → i < width → + claims[j].weight[i]! = 0 := by + intro j i hl hi + have h := tail ⟨j.val, by simp⟩ i hl hi + change (claims.push claim)[j.val].weight[i]! = 0 at h + rwa [Array.getElem_push_lt j.isLt] at h + intro i hl hi + have last : claim.weight[i]! = 0 := by + simpa using tail ⟨claims.size, by simp⟩ i hl hi + rw [Array.foldl_push] + change (weightGlue _ claim.weight _)[i]! = 0 + rw [weightGlue, getElem!_tab _ _ _ (by rw [loop_size]; exact hi)] + rw [ih oldTail i hl hi, last, mul_zero, add_zero] + +/-- A false public claim is a property of the fixed pre-lambda statement. -/ +def Violated (f : Array E) (claims : Array Claim) : Prop := + ∃ j : Fin claims.size, dot f claims[j].weight ≠ claims[j].value + +/-- Exactly the initial false-claim escape event, not an arbitrary polynomial root event. -/ +noncomputable def escape (f : Array E) (claims : Array Claim) : Finset E := by + classical + exact Finset.univ.filter fun lambda => Violated f claims ∧ + dot f (batchClaims f.size claims lambda).weight = + (batchClaims f.size claims lambda).value + +theorem escape_probability (f : Array E) (claims : Array Claim) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = f.size) : + Soundness.uniformProb (escape f claims) ≤ ((claims.size - 1 : Nat) : ℚ) / 2^192 := by + classical + by_cases bad : Violated f claims + · have event : escape f claims = Finset.univ.filter fun lambda => + (errorPolynomial f claims).eval lambda = 0 := by + ext lambda + simp only [escape, Finset.mem_filter, Finset.mem_univ, true_and, bad] + rw [← batchClaims_discrepancy f claims lambda shape, sub_eq_zero] + rw [event] + simpa only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] using + Soundness.root_error (errorPolynomial f claims) + (errorPolynomial_ne_zero f claims bad) (claims.size - 1) + (errorPolynomial_degree f claims) + · have event : escape f claims = ∅ := by simp [escape, bad] + rw [event] + simp [Soundness.uniformProb] + positivity + +/-- The candidate set is fixed before the public claims, hence before lambda. +Claims need not be true for every candidate, and the empty array has zero risk. -/ +noncomputable def candidateEscape (candidates : Finset (Array E)) (claims : Array Claim) : + Finset E := by + classical + exact candidates.biUnion fun f => escape f claims + +theorem candidate_escape_probability (candidates : Finset (Array E)) + (claims : Array Claim) + (shape : ∀ f ∈ candidates, ∀ j : Fin claims.size, claims[j].weight.size = f.size) : + Soundness.uniformProb (candidateEscape candidates claims) ≤ + (candidates.card : ℚ) * (claims.size - 1 : Nat) / 2^192 := by + classical + have events : candidateEscape candidates claims = + Finset.univ.biUnion (fun f : candidates => escape f.val claims) := by + ext lambda + simp [candidateEscape] + rw [events] + calc + _ ≤ ∑ f : candidates, Soundness.uniformProb (escape f.val claims) := + Soundness.union_bound _ + _ ≤ ∑ _f : candidates, ((claims.size - 1 : Nat) : ℚ) / 2^192 := + Finset.sum_le_sum fun f _ => escape_probability f.val claims (shape f.val f.property) + _ = _ := by simp [mul_div_assoc] + +/-- Lost means that no commitment-fixed candidate satisfies every public claim. -/ +def Lost (candidates : Finset (Array E)) (claims : Array Claim) : Prop := + ∀ f ∈ candidates, Violated f claims + +def BatchedLost (width : Nat) (candidates : Finset (Array E)) + (claims : Array Claim) (lambda : E) : Prop := + ∀ f ∈ candidates, dot f (batchClaims width claims lambda).weight ≠ + (batchClaims width claims lambda).value + +/-- Outside the counted escape event, the actual initial batching preserves lostness. -/ +theorem lost_preserved (width : Nat) (candidates : Finset (Array E)) + (claims : Array Claim) (lambda : E) + (sizes : ∀ f ∈ candidates, f.size = width) + (lost : Lost candidates claims) + (outside : lambda ∉ candidateEscape candidates claims) : + BatchedLost width candidates claims lambda := by + classical + intro f hf eq + apply outside + apply Finset.mem_biUnion.mpr + refine ⟨f, hf, ?_⟩ + simp only [escape, Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨lost f hf, by simpa only [sizes f hf] using eq⟩ + +noncomputable def lostEscape (width : Nat) (candidates : Finset (Array E)) + (claims : Array Claim) : Finset E := by + classical + exact Finset.univ.filter fun lambda => + Lost candidates claims ∧ ¬ BatchedLost width candidates claims lambda + +/-- Exact finite probability of losing the actual initial lost invariant. -/ +theorem lost_escape_probability (width : Nat) (candidates : Finset (Array E)) + (claims : Array Claim) + (sizes : ∀ f ∈ candidates, f.size = width) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = width) : + Soundness.uniformProb (lostEscape width candidates claims) ≤ + (candidates.card : ℚ) * (claims.size - 1 : Nat) / 2^192 := by + classical + have sub : lostEscape width candidates claims ⊆ candidateEscape candidates claims := by + simp only [Finset.subset_iff, lostEscape, Finset.mem_filter, + Finset.mem_univ, true_and] + intro lambda h + obtain ⟨lost, fails⟩ := h + by_contra outside + exact fails (lost_preserved width candidates claims lambda sizes lost outside) + calc + _ ≤ Soundness.uniformProb (candidateEscape candidates claims) := by + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right + (by exact_mod_cast Finset.card_le_card sub) (by positivity) + _ ≤ _ := candidate_escape_probability candidates claims + (by intro f hf j; rw [sizes f hf]; exact shape j) + +end Whir.InitialBatching diff --git a/verification/whir/Whir/InitialCandidates.lean b/verification/whir/Whir/InitialCandidates.lean new file mode 100644 index 000000000..acd6281d7 --- /dev/null +++ b/verification/whir/Whir/InitialCandidates.lean @@ -0,0 +1,206 @@ +import Whir.BaseCandidateDescent +import Whir.ConcreteCandidates + +/-! The initial list is fixed by the pruned base commitment. Its live leaf lanes +are reversed to coefficient order; missing lanes are zero. Checked base-field +interpolation forces every extension candidate to reconstruct a literal witness. + +`witnesses` is the deterministic live-c0 image of `extensionCandidates`, before +either claims or an opening strategy is supplied. Supported production profiles +give the actual novel-encoder list cap `2^32` and sufficient matching points for +base descent. `production_candidate_violates_claim` transfers a false statement +about this fixed K list to every E candidate for initial batching. + +The total oracle also assigns a list to malformed roots; no root-shape premise +is needed for interpolation. `fullRow_reverse` identifies valid occupied leaves +with the verifier's reversal. Rejection of malformed roots remains the actual +verifier's separate shape check. -/ +namespace Whir.InitialCandidates +open Concrete CandidateFolding Protocol + +/-- Complete ascending row oracle, before any opening or challenge is chosen. -/ +def fullRow (c : Config) (lanes : ℕ) (root : CausalGame.BaseOracle) : + Fin (2^c.folds[0]!) → Fin (2^(c.logN-c.folds[0]!+c.rates[0]!)) → K := + fun lane q => if lane.val < lanes then (root[q.val]!)[lanes-1-lane.val]! else 0 + +/-- A well-shaped occupied leaf is reversed exactly as in the verifier's base +query reduction, with zero entries for the pruned lanes. -/ +theorem fullRow_reverse (c : Config) (lanes : ℕ) (root : CausalGame.BaseOracle) + (q : Fin (2^(c.logN-c.folds[0]!+c.rates[0]!))) + (shape : root[q.val]!.size = lanes) (lane : Fin (2^c.folds[0]!)) : + fullRow c lanes root lane q = + if lane.val < lanes then (root[q.val]!.reverse)[lane.val]! else 0 := by + by_cases h : lane.val < lanes + · have hr : lane.val < root[q.val]!.size := by omega + have hs : lanes-1-lane.val < root[q.val]!.size := by omega + simp only [fullRow, h, ↓reduceIte, + getElem!_pos (root[q.val]!) (lanes-1-lane.val) hs, + getElem!_pos (root[q.val]!.reverse) lane.val (by simpa using hr), + Array.getElem_reverse, shape] + · simp [fullRow, h] + +/-- The initial extension list uses the actual dense novel-basis encoder. -/ +noncomputable def extensionCandidates (c : Config) (lanes : ℕ) + (root : CausalGame.BaseOracle) : Finset (Array E) := + arrayCandidates true (concreteEncoder (c.logN-c.folds[0]!) c.rates[0]!) + (fun lane q => E.ofK (fullRow c lanes root lane q)) (ParameterBounds.threshold c 0) + +/-- Deterministic projection of live coefficients; no decoding choice is made. -/ +def project (c : Config) (lanes : ℕ) (a : Array E) : CausalGame.Witness c lanes := + fun i => a[i.val]!.c0 + +/-- Commitment-only candidate list, independent of public claims and strategy. -/ +noncomputable def witnesses (c : Config) (lanes : ℕ) (root : CausalGame.BaseOracle) : + Finset (CausalGame.Witness c lanes) := by + classical + exact (extensionCandidates c lanes root).image (project c lanes) + +theorem witnesses_card_le (c : Config) (lanes : ℕ) (root : CausalGame.BaseOracle) : + (witnesses c lanes root).card ≤ (extensionCandidates c lanes root).card := by + classical + exact Finset.card_image_le + +private noncomputable def baseRepresentation : AdditiveCode.BaseRepresentation FieldModel.BaseQuotient where + map := FieldModel.toBaseQuotient + one := FieldModel.toBaseQuotient_one + add := FieldModel.toBaseQuotient_xor + mul := FieldModel.toBaseQuotient_kmul + inv := FieldModel.toBaseQuotient_kinv + +/-- The actual machine basis and domain meet the interpolation prerequisites. -/ +theorem coefficient_restriction (c : Config) (lanes : ℕ) (root : CausalGame.BaseOracle) + (depth : c.logN-c.folds[0]!+c.rates[0]! ≤ 64) + (threshold : 2^(c.logN-c.folds[0]!)-1 < ParameterBounds.threshold c 0) + (a : Array E) (ha : a ∈ extensionCandidates c lanes root) : + ∃ words : Fin (2^c.folds[0]!) → Fin (2^(c.logN-c.folds[0]!)) → K, + (∀ l j, E.ofK (words l j) = unpack true (2^c.folds[0]!) + (2^(c.logN-c.folds[0]!)) a l j) ∧ + (∀ l, lanes ≤ l.val → ∀ j, words l j = 0) := by + classical + obtain ⟨_, s, hs, hmatch⟩ := (arrayCandidates_mem_iff _ _ _ _ _).mp ha + simp only [← Nat.not_lt] + apply BaseCandidateDescent.actual_word_candidates_restrict + (fun j => (1 : K) <<< UInt64.ofNat j) (c.logN-c.folds[0]!) + (AdditiveCode.bitBasis_independent baseRepresentation + FieldModel.toBaseQuotient_injective _ (by omega)) + s (fun q => UInt64.ofNat q.val) ?_ + (fullRow c lanes root) {l | l.val < lanes} ?_ _ + (ParameterBounds.threshold c 0) threshold hs hmatch + · intro i hi j hj heq + apply Fin.ext + apply AdditiveCode.evaluationPoint_injective AdditiveCode.concreteBaseRepresentation + FieldModel.ofK_injective + (i.isLt.trans_le (Nat.pow_le_pow_right (by decide) depth)) + (j.isLt.trans_le (Nat.pow_le_pow_right (by decide) depth)) + exact congrArg E.ofK heq + · intro l hl i hi + change ¬ l.val < lanes at hl + simp [fullRow, hl] + +/-- Every initial extension candidate is exactly the zero-padded literal live +base witness obtained by its c0 projection. There is no descent assumption. -/ +theorem reconstruction (c : Config) (lanes : ℕ) (root : CausalGame.BaseOracle) + (fold_bound : c.folds[0]! ≤ c.logN) + (_lane_bound : lanes ≤ 2^c.folds[0]!) + (depth : c.logN-c.folds[0]!+c.rates[0]! ≤ 64) + (threshold : 2^(c.logN-c.folds[0]!)-1 < ParameterBounds.threshold c 0) + (a : Array E) (ha : a ∈ extensionCandidates c lanes root) : + a = CausalGame.paddedWitness c lanes (project c lanes a) := by + obtain ⟨words, hwords, hzero⟩ := coefficient_restriction c lanes root depth threshold a ha + have hsize := arrayCandidates_size true + (concreteEncoder (c.logN-c.folds[0]!) c.rates[0]!) + (fun lane q => E.ofK (fullRow c lanes root lane q)) (ParameterBounds.threshold c 0) a ha + have hwidth : 2^c.folds[0]! * 2^(c.logN-c.folds[0]!) = 2^c.logN := by + rw [← Nat.pow_add, Nat.add_sub_of_le fold_bound] + have hpos : 0 < 2^(c.logN-c.folds[0]!) := Nat.pow_pos (by decide) + apply Array.ext + · simpa [CausalGame.paddedWitness, tab, hwidth] using hsize + · intro i hi hi' + let l : Fin (2^c.folds[0]!) := ⟨i / 2^(c.logN-c.folds[0]!), + (Nat.div_lt_iff_lt_mul hpos).mpr (by simpa [hsize, Nat.mul_comm] using hi)⟩ + let j : Fin (2^(c.logN-c.folds[0]!)) := ⟨i % 2^(c.logN-c.folds[0]!), Nat.mod_lt _ hpos⟩ + have hind : j.val + 2^(c.logN-c.folds[0]!) * l.val = i := by + exact Nat.mod_add_div i (2^(c.logN-c.folds[0]!)) + have hw : E.ofK (words l j) = a[i]! := by + simpa [unpack, topIndex, hind] using hwords l j + have hw' : E.ofK (words l j) = a[i] := by simpa only [getElem!_pos a i hi] using hw + by_cases hlive : i < lanes * 2^(c.logN-c.folds[0]!) + · simp [CausalGame.paddedWitness, tab, hlive, project, + getElem!_pos a i hi, ← hw', E.ofK] + · have hl : lanes ≤ l.val := by + dsimp [l] + exact (Nat.le_div_iff_mul_le hpos).mpr (by omega) + have hz : a[i]! = E.ofK 0 := by rw [← hw, hzero l hl j] + simpa [CausalGame.paddedWitness, tab, hlive, getElem!_pos a i hi] using hz + +/-- A false public multi-claim statement leaves no original E candidate satisfying +all claims, the exact premise needed for the first powers batch. -/ +theorem candidate_violates_claim (c : Config) (lanes : ℕ) (root : CausalGame.BaseOracle) + (fold_bound : c.folds[0]! ≤ c.logN) (lane_bound : lanes ≤ 2^c.folds[0]!) + (depth : c.logN-c.folds[0]!+c.rates[0]! ≤ 64) + (threshold : 2^(c.logN-c.folds[0]!)-1 < ParameterBounds.threshold c 0) + (claims : Array CausalGame.Claim) + (hfalse : ¬ ∃ w ∈ witnesses c lanes root, ∀ claim ∈ claims.toList, + dot (CausalGame.paddedWitness c lanes w) claim.weight = claim.value) + (a : Array E) (ha : a ∈ extensionCandidates c lanes root) : + ∃ claim ∈ claims.toList, dot a claim.weight ≠ claim.value := by + classical + by_contra h + push Not at h + apply hfalse + refine ⟨project c lanes a, Finset.mem_image.mpr ⟨a, ha, rfl⟩, ?_⟩ + intro claim hc + rw [← reconstruction c lanes root fold_bound lane_bound depth threshold a ha] + exact h claim hc + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Initial indexing and interpolation arithmetic for the supported production +profiles, checked on the actual configuration generator. -/ +theorem production_initial_facts : ∀ p : ParameterBounds.Profile, + let c := ParameterBounds.config p + CausalGame.remaining c 0 = c.logN-c.folds[0]! ∧ + c.folds[0]! ≤ c.logN ∧ + c.logN-c.folds[0]!+c.rates[0]! ≤ 64 ∧ + 2^(c.logN-c.folds[0]!)-1 < ParameterBounds.threshold c 0 := by + decide +kernel + +set_option maxHeartbeats 0 in +theorem production_extension_card (p : ParameterBounds.Profile) (lanes : ℕ) + (root : CausalGame.BaseOracle) : + (extensionCandidates (ParameterBounds.config p) lanes root).card ≤ 2^32 := by + have h := ConcreteCandidates.production_arrayCandidates_card true p + ⟨0, (ParameterBounds.production_config_valid p).2.1⟩ + (lanes := 2^(ParameterBounds.config p).folds[0]!) + unfold ParameterBounds.length at h + dsimp only at h + rw [(production_initial_facts p).1] at h + exact h (fun lane q => E.ofK (fullRow (ParameterBounds.config p) lanes root lane q)) + +theorem production_witnesses_card (p : ParameterBounds.Profile) (lanes : ℕ) + (root : CausalGame.BaseOracle) : + (witnesses (ParameterBounds.config p) lanes root).card ≤ 2^32 := + (witnesses_card_le _ _ _).trans (production_extension_card p lanes root) + +theorem production_reconstruction (p : ParameterBounds.Profile) (lanes : ℕ) + (root : CausalGame.BaseOracle) + (lane_bound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (a : Array E) (ha : a ∈ extensionCandidates (ParameterBounds.config p) lanes root) : + a = CausalGame.paddedWitness (ParameterBounds.config p) lanes + (project (ParameterBounds.config p) lanes a) := + reconstruction _ lanes root (production_initial_facts p).2.1 lane_bound + (production_initial_facts p).2.2.1 (production_initial_facts p).2.2.2 a ha + +theorem production_candidate_violates_claim (p : ParameterBounds.Profile) (lanes : ℕ) + (root : CausalGame.BaseOracle) + (lane_bound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (claims : Array CausalGame.Claim) + (hfalse : ¬ ∃ w ∈ witnesses (ParameterBounds.config p) lanes root, + ∀ claim ∈ claims.toList, dot (CausalGame.paddedWitness (ParameterBounds.config p) + lanes w) claim.weight = claim.value) + (a : Array E) (ha : a ∈ extensionCandidates (ParameterBounds.config p) lanes root) : + ∃ claim ∈ claims.toList, dot a claim.weight ≠ claim.value := + candidate_violates_claim _ lanes root (production_initial_facts p).2.1 lane_bound + (production_initial_facts p).2.2.1 (production_initial_facts p).2.2.2 claims hfalse a ha + +end Whir.InitialCandidates diff --git a/verification/whir/Whir/InitialSoundness.lean b/verification/whir/Whir/InitialSoundness.lean new file mode 100644 index 000000000..754d8a29b --- /dev/null +++ b/verification/whir/Whir/InitialSoundness.lean @@ -0,0 +1,72 @@ +import Whir.InitialCandidates +import Whir.InitialBatching +import Whir.VerifierInvariant + +/-! The commitment-only base-field list and the actual public-claim batching +establish the incoming lost invariant without selecting a list after challenges. -/ +namespace Whir.InitialSoundness +open Concrete Protocol CausalGame InitialCandidates + +/-- Every extension candidate has exactly the verifier's padded input width. -/ +theorem candidate_size (p : ParameterBounds.Profile) (lanes : Nat) (root : BaseOracle) + (lane_bound : lanes ≤ 2 ^ (ParameterBounds.config p).folds[0]!) + (a : Array E) (ha : a ∈ extensionCandidates (ParameterBounds.config p) lanes root) : + a.size = 2 ^ (ParameterBounds.config p).logN := by + rw [production_reconstruction p lanes root lane_bound a ha] + simp [paddedWitness, tab] + +/-- Quantifiers over the commitment-fixed literal K witnesses imply the exact +finite indexed claim predicate used by the actual batching proof. -/ +theorem initial_lost (p : ParameterBounds.Profile) (lanes : Nat) (root : BaseOracle) + (lane_bound : lanes ≤ 2 ^ (ParameterBounds.config p).folds[0]!) (claims : Array Claim) + (hfalse : ¬ ∃ w ∈ witnesses (ParameterBounds.config p) lanes root, + ∀ claim ∈ claims.toList, + dot (paddedWitness (ParameterBounds.config p) lanes w) claim.weight = claim.value) : + InitialBatching.Lost (extensionCandidates (ParameterBounds.config p) lanes root) claims := by + intro a ha + obtain ⟨claim, hc, hneq⟩ := production_candidate_violates_claim p lanes root + lane_bound claims hfalse a ha + obtain ⟨j, hj⟩ := List.mem_iff_get.mp hc + let index : Fin claims.size := ⟨j.val, by simp⟩ + have selected : claims[index] = claim := by simpa [index, List.get_eq_getElem] using hj + exact ⟨index, by simpa only [selected] using hneq⟩ + +/-- This is the actual initialized verifier's state. The adversarial intro can +be chosen after lambda and is deliberately unrestricted. -/ +theorem batching_preserves_lost (p : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (lane_bound : lanes ≤ 2 ^ (ParameterBounds.config p).folds[0]!) + (claims : Array Claim) + (hfalse : ¬ ∃ w ∈ witnesses (ParameterBounds.config p) lanes root, + ∀ claim ∈ claims.toList, + dot (paddedWitness (ParameterBounds.config p) lanes w) claim.weight = claim.value) + (lambda : E) (intro : Message E) + (outside : lambda ∉ InitialBatching.candidateEscape + (extensionCandidates (ParameterBounds.config p) lanes root) claims) : + VerifierInvariant.Lost (extensionCandidates (ParameterBounds.config p) lanes root) + ⟨(batchClaims (2 ^ (ParameterBounds.config p).logN) claims lambda).weight, + (batchClaims (2 ^ (ParameterBounds.config p).logN) claims lambda).value, intro⟩ := + InitialBatching.lost_preserved _ _ claims lambda (candidate_size p lanes root lane_bound) + (initial_lost p lanes root lane_bound claims hfalse) outside + +/-- Exact production list cap and exact 192-bit field cardinality bound the +initial event, retaining the public claim count instead of postulating a cap. -/ +theorem initial_escape_probability (p : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (lane_bound : lanes ≤ 2 ^ (ParameterBounds.config p).folds[0]!) + (claims : Array Claim) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config p).logN) : + Soundness.uniformProb (InitialBatching.candidateEscape + (extensionCandidates (ParameterBounds.config p) lanes root) claims) ≤ + ((claims.size - 1 : Nat) : ℚ) / 2 ^ 160 := by + have bounded := InitialBatching.candidate_escape_probability + (extensionCandidates (ParameterBounds.config p) lanes root) claims + (fun a ha j => (shape j).trans (candidate_size p lanes root lane_bound a ha).symm) + have card : ((extensionCandidates (ParameterBounds.config p) lanes root).card : ℚ) ≤ 2 ^ 32 := by + exact_mod_cast production_extension_card p lanes root + calc + _ ≤ ((extensionCandidates (ParameterBounds.config p) lanes root).card : ℚ) * + (claims.size - 1 : Nat) / 2 ^ 192 := bounded + _ ≤ (2 ^ 32 : ℚ) * (claims.size - 1 : Nat) / 2 ^ 192 := + div_le_div_of_nonneg_right (mul_le_mul_of_nonneg_right card (by positivity)) (by positivity) + _ = _ := by ring + +end Whir.InitialSoundness diff --git a/verification/whir/Whir/InitialTerminalRefinement.lean b/verification/whir/Whir/InitialTerminalRefinement.lean new file mode 100644 index 000000000..b03361fed --- /dev/null +++ b/verification/whir/Whir/InitialTerminalRefinement.lean @@ -0,0 +1,65 @@ +import Whir.QueryRefinement +import Whir.SuccinctPointWeight + +namespace Whir.InitialTerminalRefinement +open Concrete ArrayLayout ArrayAlgebra ExecutableOOD SuccinctPointWeight +open scoped BigOperators +variable {R : Type*} [CommRing R] [CharP R 2] [Inhabited R] + +/-- Disintegration in the actual little-endian array layout. -/ +theorem mle_append (a : Array R) (low high : Array R) + (ha : a.size = 2 ^ (low.size + high.size)) : + Concrete.mle a (low ++ high) = + Concrete.mle (tab (2 ^ low.size) fun row => + Concrete.mle (tab (2 ^ high.size) fun lane => a[lane * 2 ^ low.size + row]!) high) low := by + let x : Fin low.size → R := fun i => low[i] + let y : Fin high.size → R := fun i => high[i] + have hx : Array.ofFn x = low := by ext i hi hj <;> simp [x] + have hy : Array.ofFn y = high := by ext i hi hj <;> simp [y] + have hxy : Array.ofFn (Fin.addCases x y) = low ++ high := by + change Array.ofFn (Fin.append x y) = low ++ high + apply Array.toList_inj.mp + simpa only [Array.toList_ofFn, List.ofFn_fin_append, Array.toList_append] using + congrArg₂ (fun a b : Array R => a.toList ++ b.toList) hx hy + rw [← hxy, mle_eq_cube a _ ha] + have hlow := mle_eq_cube + (tab (2 ^ low.size) fun row => + Concrete.mle (tab (2 ^ high.size) fun lane => a[lane * 2 ^ low.size + row]!) high) x (by simp) + rw [hx] at hlow + rw [hlow] + simp only [Whir.mle, innerProduct, decode] + rw [← Equiv.sum_comp (cubeAppendEquiv low.size high.size)] + simp only [Fintype.sum_prod_type, cubeAppendEquiv, Equiv.coe_fn_mk, + eqWeight_append, cubeIndex_append] + apply Finset.sum_congr rfl + intro u _ + rw [getElem!_tab _ _ _ (cubeIndex_lt u)] + have hhigh := mle_eq_cube + (tab (2 ^ high.size) fun lane => a[lane * 2 ^ low.size + cubeIndex u]!) y (by simp) + rw [hy] at hhigh + rw [hhigh] + simp only [Whir.mle, innerProduct, decode, Finset.mul_sum] + apply Finset.sum_congr rfl + intro v _ + rw [getElem!_tab _ _ _ (cubeIndex_lt v)] + simp only [Nat.mul_comm, Nat.add_comm] + ring + +/-- L0 folds the top variables first, while every later context remains in +unrotated low-variable order. -/ +theorem mle_foldLane_initial (a initial low : Array R) + (ha : a.size = 2 ^ (low.size + initial.size)) : + Concrete.mle (initial.foldl (fun b r => foldLane b (2 ^ low.size) r) a) low = + Concrete.mle a (low ++ initial) := by + rw [QueryRefinement.foldLane_blocks a initial (2 ^ low.size) + (by rw [ha, pow_add, Nat.mul_comm])] + exact (mle_append a low initial ha).symm + +omit [CommRing R] [CharP R 2] [Inhabited R] in +theorem rotate_initial (initial low : Array R) : + rotatePoint initial.size (initial ++ low) = low ++ initial := by + apply Array.toList_inj.mp + rw [rotatePoint_terminalPoint _ _ (by simp)] + simpa using Layout.terminalPoint_order initial.toList low.toList + +end Whir.InitialTerminalRefinement diff --git a/verification/whir/Whir/InteractiveSoundness.lean b/verification/whir/Whir/InteractiveSoundness.lean new file mode 100644 index 000000000..78b9828bf --- /dev/null +++ b/verification/whir/Whir/InteractiveSoundness.lean @@ -0,0 +1,271 @@ +import Whir.CausalBadEvents +import Whir.AcceptedShapes + +/-! End-to-end list-loss propagation for the actual causal WHIR verifier. +The initial candidate list is chosen from the commitment before public claims, +and each charged event is one of the concretely proved prefix events. -/ +namespace Whir.InteractiveSoundness +open Concrete Protocol CausalGame CausalExecution ExecutionShapes ParameterBounds VerifierInvariant + +/-- The fixed base-field witness list initializes the actual pending-state invariant. -/ +theorem initial_lost (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (hfalse : ¬ ∃ w ∈ InitialCandidates.witnesses (config p) lanes root, + ∀ claim ∈ claims.toList, dot (paddedWitness (config p) lanes w) claim.weight = claim.value) + (outside : ¬ CausalInitial.Event (Input p lanes root claims) tape) : + Lost (foldCandidates (Input p lanes root claims) strategy tape 0 0) + (levelAt (Input p lanes root claims) strategy tape 0).state := by + have valid := AcceptedShapes.accepted_oracle p lanes root claims strategy tape accepted + ⟨0, (production_config_valid p).2.1⟩ + have rootValid : oracleValid (liftRoot root) (length (config p) 0) lanes = true := by + simpa [initial] using valid + rw [AcceptedShapes.initial_candidates p lanes root claims strategy tape rootValid] + exact InitialSoundness.batching_preserves_lost p lanes root + (AcceptedShapes.accepted_lane_bound _ _ _ accepted) claims hfalse tape.1 + (proof (Input p lanes root claims) strategy tape).initial outside + +/-- Avoiding every concrete fold restoration preserves loss throughout the whole actual fold block. -/ +theorem folds_preserve_lost (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) (i : Fin (config p).folds.size) + (incoming : Lost (foldCandidates (Input p lanes root claims) strategy tape i 0) + (levelAt (Input p lanes root claims) strategy tape i).state) + (outside : ∀ j : Fin (config p).folds[i.val]!, + ¬ CausalFolds.Event (Input p lanes root claims) strategy i j tape) : + Lost (foldCandidates (Input p lanes root claims) strategy tape i (config p).folds[i.val]!) + (foldAt (Input p lanes root claims) strategy tape i (config p).folds[i.val]!).state := by + have each (j : Nat) (hj : j ≤ (config p).folds[i.val]!) : + Lost (foldCandidates (Input p lanes root claims) strategy tape i j) + (foldAt (Input p lanes root claims) strategy tape i j).state := by + induction j with + | zero => exact incoming + | succ j ih => + apply Classical.byContradiction + intro restored + have index : j < (config p).folds[i.val]! := by omega + apply outside ⟨j, index⟩ + refine ⟨?_, ih (by omega), restored⟩ + rw [(foldAt_shape p lanes root claims strategy tape i j index.le).2] + simp only [dimension, Nat.pow_add, Nat.mul_comm] + exact each _ le_rfl + +/-- The actual authentication and boundary guards turn absence of the grouped query event into loss of the next list. -/ +theorem query_preserves_lost (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (i : Fin (config p).folds.size) + (incoming : Lost (foldCandidates (Input p lanes root claims) strategy tape i (config p).folds[i.val]!) + (foldAt (Input p lanes root claims) strategy tape i (config p).folds[i.val]!).state) + (oodOutside : ∀ j : Fin (oodCount (config p) i), + ¬ CausalBoundary.OodEvent (Input p lanes root claims) strategy i j tape) + (queryOutside : ¬ CausalBoundary.QueryEvent (Input p lanes root claims) strategy i tape) : + Lost (followingCandidates (Input p lanes root claims) strategy tape i) + (levelAt (Input p lanes root claims) strategy tape (i.val + 1)).state := by + classical + apply Classical.byContradiction + intro restored + have dims := foldAt_shape p lanes root claims strategy tape i (config p).folds[i.val]! le_rfl + simp only [Nat.sub_self, Nat.add_zero] at dims + have close := AcceptedShapes.closeLost_of_terminal_lost p lanes root claims strategy tape accepted i incoming + have checked := accepted_level (Input p lanes root claims) strategy tape accepted i i.isLt + have result := OperationalRefinement.verifyLevel_success _ _ _ i _ _ checked + dsimp only at result + have endEq := foldAt_end (Input p lanes root claims) strategy tape i i.isLt + dsimp only [block] at endEq + rw [← endEq] at result + rw [dims.1, foldAt_oracle] at result + obtain ⟨_, oodLength, qs, sampled, rows, auth, _⟩ := result + apply queryOutside + dsimp only [CausalBoundary.QueryEvent, CausalBoundary.boundary] + rw [sampled] + refine ⟨dims.1, dims.2, close, ?_, rows, + (OperationalRefinement.authentication_ok_iff _ _ _).mpr auth, restored⟩ + split_ifs with hasNext + · have positive := ((CausalBoundary.production_boundary_facts p i).2.2 hasNext).2 + let j : Fin (oodCount (config p) i) := ⟨0, positive⟩ + have separated := oodOutside j + unfold CausalBoundary.OodEvent at separated + have count := (TapeValidity.level_shapes (config p) tape i i.isLt).2.1 + exact ⟨0, by omega, not_not.mp separated⟩ + · have boundaryGuard := boundary_shape (config p) (challenges (config p) tape) + (proof (Input p lanes root claims) strategy tape) i _ _ checked + dsimp only at boundaryGuard + rw [← foldAt_end (Input p lanes root claims) strategy tape i i.isLt, dims.1] at boundaryGuard + have finalShape : (proof (Input p lanes root claims) strategy tape).levels[i.val]!.nextOracle = none ∧ + (proof (Input p lanes root claims) strategy tape).residual.size = 2 ^ remaining (config p) i := by + simpa only [hasNext, ↓reduceIte] using boundaryGuard + exact finalShape.2 + +/-- Every accepted opening contradicting the commitment-time list encounters an actual bad challenge prefix. -/ +theorem accepted_false_cover (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (hfalse : ¬ ∃ w ∈ InitialCandidates.witnesses (config p) lanes root, + ∀ claim ∈ claims.toList, dot (paddedWitness (config p) lanes w) claim.weight = claim.value) : + ∃ q, CausalBadEvents.Bad (Input p lanes root claims) strategy q tape := by + classical + apply Classical.byContradiction + intro noBad + have safe (q) : ¬ CausalBadEvents.Bad (Input p lanes root claims) strategy q tape := + fun h => noBad ⟨q, h⟩ + have initialLoss := initial_lost p lanes root claims strategy tape accepted hfalse (safe .initial) + have entering (i : Nat) (hi : i < (config p).folds.size) : + Lost (foldCandidates (Input p lanes root claims) strategy tape i 0) + (levelAt (Input p lanes root claims) strategy tape i).state := by + induction i with + | zero => exact initialLoss + | succ i ih => + have previous : i < (config p).folds.size := by omega + let index : Fin (config p).folds.size := ⟨i, previous⟩ + have folded := folds_preserve_lost p lanes root claims strategy tape index (ih previous) + (fun j => safe (.fold index j)) + have queried := query_preserves_lost p lanes root claims strategy tape accepted index folded + (fun j => safe (.ood index j)) (safe (.query index)) + rw [following_eq_next _ _ _ i hi] at queried + exact queried + have positive := (production_config_valid p).2.1 + let last : Fin (config p).folds.size := ⟨(config p).folds.size - 1, by omega⟩ + have lastEnd : last.val + 1 = (config p).folds.size := by dsimp [last]; omega + have noNext : ¬ last.val + 1 < (config p).folds.size := by omega + have folded := folds_preserve_lost p lanes root claims strategy tape last (entering last last.isLt) + (fun j => safe (.fold last j)) + have queried := query_preserves_lost p lanes root claims strategy tape accepted last folded + (fun j => safe (.ood last j)) (safe (.query last)) + have beforeState := (accepted_execution (Input p lanes root claims) strategy tape accepted).2.2 + have incoming : dot (proof (Input p lanes root claims) strategy tape).residual + (CausalTerminal.before (Input p lanes root claims) strategy tape).weight ≠ + (CausalTerminal.before (Input p lanes root claims) strategy tape).claim := by + have member : (proof (Input p lanes root claims) strategy tape).residual ∈ + followingCandidates (Input p lanes root claims) strategy tape last := by + simp only [followingCandidates, noNext, ↓reduceIte, Finset.mem_singleton] + have lost := queried _ member + simpa only [lastEnd, beforeState] using lost + have checked := accepted_level (Input p lanes root claims) strategy tape accepted last last.isLt + have terminalShape := boundary_shape (config p) (challenges (config p) tape) + (proof (Input p lanes root claims) strategy tape) last _ _ checked + dsimp only at terminalShape + rw [← foldAt_end (Input p lanes root claims) strategy tape last last.isLt] at terminalShape + have dims := (foldAt_shape p lanes root claims strategy tape last (config p).folds[last.val]! le_rfl).1 + simp only [Nat.sub_self, Nat.add_zero] at dims + rw [dims] at terminalShape + have shapeLast : (proof (Input p lanes root claims) strategy tape).residual.size = + 2 ^ remaining (config p) last := by + have pair : (proof (Input p lanes root claims) strategy tape).levels[last.val]!.nextOracle = none ∧ + (proof (Input p lanes root claims) strategy tape).residual.size = 2 ^ remaining (config p) last := by + simpa only [noNext, ↓reduceIte] using terminalShape + exact pair.2 + have remainingLast : remaining (config p) last = (config p).logN - (config p).folds.toList.sum := by + unfold remaining + rw [lastEnd, ← Array.length_toList, List.take_length] + rw [remainingLast] at shapeLast + have weight := (levelAt_shape p lanes root claims strategy tape (config p).folds.size le_rfl).2 + rw [beforeState] at weight + simp only [before] at weight + have takeAll : (config p).folds.toList.take (config p).folds.size = (config p).folds.toList := by + rw [← Array.length_toList, List.take_length] + rw [takeAll] at weight + have weightShape : (CausalTerminal.before (Input p lanes root claims) strategy tape).weight.size = + (proof (Input p lanes root claims) strategy tape).residual.size := weight.trans shapeLast.symm + obtain ⟨j, escaped⟩ := CausalTerminal.event_has_collision (Input p lanes root claims) strategy tape + ⟨accepted, shapeLast, weightShape, incoming⟩ + exact safe (.tail j) escaped + +/-- Public claim shape is checked before any causal proof response is considered. -/ +theorem accepted_claim_shapes (input : Public) (strategy : Strategy) (tape : Tape input.config) + (accepted : experiment input strategy tape = true) : + ∀ j : Fin input.claims.size, input.claims[j].weight.size = 2 ^ input.config.logN := by + intro j + have all := (CausalRefinement.experiment_iff input strategy tape).mp accepted |>.1 + rw [Array.all_eq_true] at all + have valid := all j.val j.isLt + simp only [shapeValid, Bool.and_eq_true, decide_eq_true_eq, beq_iff_eq] at valid + exact valid.1.2 + +/-- The concrete conservative ledger is nonnegative, including rejected public inputs. -/ +theorem error_nonneg (c : Config) (claims : Nat) : + 0 ≤ GroupedChallenges.interactiveError c (estimates c) claims := by + unfold GroupedChallenges.interactiveError + refine add_nonneg (add_nonneg ?_ (Finset.sum_nonneg fun i _ => ?_)) ?_ + · simp only [GroupedChallenges.initialBatch, estimates, GroupedChallenges.fieldSize] + split_ifs <;> positivity + · have field : (0 : ℚ) ≤ GroupedChallenges.fieldSize := by norm_num [GroupedChallenges.fieldSize] + have fold : 0 ≤ GroupedChallenges.foldError c (estimates c) i := by + norm_num [GroupedChallenges.foldError, estimates, GroupedChallenges.fieldSize] + have ood : 0 ≤ GroupedChallenges.oodError c (estimates c) i := by + unfold GroupedChallenges.oodError + split_ifs + · exact div_nonneg (mul_nonneg (mul_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _)) + (Nat.cast_nonneg _)) field + · exact le_rfl + have fraction : 0 ≤ (estimates c i).agreementFraction := by + dsimp only [estimates, alpha, upper] + apply mul_nonneg (by norm_num) (div_nonneg ?_ (by positivity)) + split_ifs <;> norm_num + have query : 0 ≤ GroupedChallenges.queryBatchError c (estimates c) i := by + unfold GroupedChallenges.queryBatchError + apply add_nonneg (pow_nonneg fraction _) + split_ifs + · exact div_nonneg (mul_nonneg (Nat.cast_nonneg _) (Nat.cast_nonneg _)) field + · exact div_nonneg (Nat.cast_nonneg _) field + exact add_nonneg (add_nonneg (mul_nonneg (Nat.cast_nonneg _) fold) ood) query + · dsimp only [GroupedChallenges.fieldSize] + positivity + +private theorem filtered_mono {Ω : Type*} [Fintype Ω] (P Q : Ω → Prop) + [DecidablePred P] [DecidablePred Q] (h : ∀ ω, P ω → Q ω) : + Soundness.uniformProb (Finset.univ.filter P) ≤ Soundness.uniformProb (Finset.univ.filter Q) := by + have sub : Finset.univ.filter P ⊆ Finset.univ.filter Q := by + intro ω hω + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h ω (Finset.mem_filter.mp hω).2⟩ + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast Finset.card_le_card sub) (by positivity) + +private theorem impossible_event {Ω : Type*} [Fintype Ω] (P : Ω → Prop) + [DecidablePred P] (h : ∀ ω, ¬ P ω) : + Soundness.uniformProb (Finset.univ.filter P) = 0 := by + rw [Finset.filter_eq_empty_iff.mpr (fun ω _ => h ω)] + simp [Soundness.uniformProb] + +open Classical + +/-- Concrete probability bound for arbitrary public claims and arbitrary causal proof strategies. -/ +theorem opening_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) : + Soundness.uniformProb (Finset.univ.filter fun tape : Tape (config p) => + experiment (Input p lanes root claims) strategy tape = true ∧ + ¬ ∃ w ∈ InitialCandidates.witnesses (config p) lanes root, + ∀ claim ∈ claims.toList, dot (paddedWitness (config p) lanes w) claim.weight = claim.value) ≤ + GroupedChallenges.interactiveError (config p) (estimates (config p)) claims.size := by + by_cases possible : ∃ tape, experiment (Input p lanes root claims) strategy tape = true + · obtain ⟨tape, accepted⟩ := possible + apply le_trans (filtered_mono _ _ fun t h => + accepted_false_cover p lanes root claims strategy t h.1 h.2) + exact CausalBadEvents.bad_probability p lanes root claims strategy + (AcceptedShapes.accepted_lane_bound _ _ _ accepted) + (accepted_claim_shapes _ _ _ accepted) + · rw [impossible_event _ (fun tape h => possible ⟨tape, h.1⟩)] + exact error_nonneg _ _ + +/-- Full ideal-interactive adaptive list binding for every production size/rate profile. +The witness list is fixed before claims and strategy, and the quantified experiment +is the actual causal verifier, not a replacement arithmetic acceptance predicate. -/ +theorem adaptive_list_binding (p : Profile) : + AdaptiveListBinding (config p) (2 ^ 32) + (GroupedChallenges.interactiveError (config p) (estimates (config p))) := by + intro lanes root + exact ⟨InitialCandidates.witnesses (config p) lanes root, + InitialCandidates.production_witnesses_card p lanes root, + fun claims strategy => opening_probability p lanes root claims strategy⟩ + +/-- An unground bound. This does not claim a grinding amplifier or 128-bit security. -/ +theorem production_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (claim_cap : claims.size ≤ 2 ^ 64) : + Soundness.uniformProb (Finset.univ.filter fun tape : Tape (config p) => + experiment (Input p lanes root claims) strategy tape = true ∧ + ¬ ∃ w ∈ InitialCandidates.witnesses (config p) lanes root, + ∀ claim ∈ claims.toList, dot (paddedWitness (config p) lanes w) claim.weight = claim.value) ≤ + (1 / 2 ^ 73 : ℚ) := + (opening_probability p lanes root claims strategy).trans + (production_interactive p claims.size claim_cap) + +end Whir.InteractiveSoundness diff --git a/verification/whir/Whir/JohnsonListNumerics.lean b/verification/whir/Whir/JohnsonListNumerics.lean new file mode 100644 index 000000000..ace9e0347 --- /dev/null +++ b/verification/whir/Whir/JohnsonListNumerics.lean @@ -0,0 +1,54 @@ +import Whir.CodingBounds + +/-! Rational Johnson list-size estimates. Production profiles discharge the +rate, slack, and threshold premises; no target list bound is assumed. -/ +namespace Whir.JohnsonListNumerics + +/-- The relaxed second-moment denominator is positive, and its corresponding +list-size estimate is at most `2^32`, at the minimum admitted rate and slack. -/ +theorem johnson_bound_le_two_pow32 (N d t : ℕ) (hN : 0 < N) + (rho alpha : ℚ) (hrho : rho = (d : ℚ) / N) + (hrate : (1 / 2^26 : ℚ) ≤ rho) (halpha : 0 ≤ alpha) + (hgap : rho / 64 ≤ alpha^2 - rho) + (hthreshold : (N : ℚ) * alpha ≤ t) : + (N : ℚ) * d < (t : ℚ)^2 ∧ + ((N : ℚ) * (N - (d : ℚ))) / ((t : ℚ)^2 - N * d) ≤ 2^32 := by + have hNpos : (0 : ℚ) < N := by exact_mod_cast hN + have hNzero : (N : ℚ) ≠ 0 := ne_of_gt hNpos + have hr : rho * N = (d : ℚ) := (eq_div_iff hNzero).mp hrho + have hsquare : ((N : ℚ) * alpha)^2 ≤ (t : ℚ)^2 := + pow_le_pow_left₀ (mul_nonneg hNpos.le halpha) hthreshold 2 + have hgapLow : (1 / 2^32 : ℚ) ≤ alpha^2 - rho := by + norm_num at hrate ⊢ + linarith + have hscale := mul_le_mul_of_nonneg_left hgapLow (sq_nonneg (N : ℚ)) + have hdenLow : (N : ℚ)^2 / 2^32 ≤ (t : ℚ)^2 - N * d := by + have hrN : (N : ℚ) * d = rho * N^2 := by rw [← hr]; ring + rw [hrN] + nlinarith only [hsquare, hscale] + have hden : 0 < (t : ℚ)^2 - N * d := + lt_of_lt_of_le (div_pos (sq_pos_of_pos hNpos) (by norm_num)) hdenLow + refine ⟨sub_pos.mp hden, (div_le_iff₀ hden).mpr ?_⟩ + have hdnonneg : (0 : ℚ) ≤ (N : ℚ) * d := by positivity + nlinarith + +/-- Instantiates the proved interleaved RS Johnson bound. All lanes share the +same evaluation domain; there is no extra row-count factor. -/ +theorem interleaved_candidates_card_le_two_pow32 + {F : Type*} [Field F] [DecidableEq F] [Fintype F] {lanes k : ℕ} + (domain : Finset F) (oracle : ↥domain → Fin lanes → F) (t : ℕ) + (hN : 0 < domain.card) (hk : 0 < k) (hd : k - 1 ≤ domain.card) + (rho alpha : ℚ) (hrho : rho = ((k - 1 : ℕ) : ℚ) / domain.card) + (hrate : (1 / 2^26 : ℚ) ≤ rho) (halpha : 0 ≤ alpha) + (hgap : rho / 64 ≤ alpha^2 - rho) + (hthreshold : (domain.card : ℚ) * alpha ≤ t) : + (CodingBounds.candidates + (fun v : Fin lanes → Fin k → F => fun x : ↥domain => + CodingBounds.interleavedEncode v x) oracle t).card ≤ 2^32 := by + have hnum := johnson_bound_le_two_pow32 domain.card (k-1) t hN + rho alpha hrho hrate halpha hgap hthreshold + have hlist := CodingBounds.interleaved_candidates_card domain oracle t hk hd hnum.1 + have hfinal := hlist.trans hnum.2 + exact_mod_cast hfinal + +end Whir.JohnsonListNumerics diff --git a/verification/whir/Whir/JohnsonMCA.lean b/verification/whir/Whir/JohnsonMCA.lean new file mode 100644 index 000000000..45c6137ab --- /dev/null +++ b/verification/whir/Whir/JohnsonMCA.lean @@ -0,0 +1,159 @@ +module + +public import Whir.MutualAgreement +public import ArkLib.Data.CodingTheory.ReedSolomon.MutualCorrelatedAgreement.Johnson.Agreement + +/-! +The BCHKS25 same-agreement-set bound, using the pinned ArkLib construction +of the symbolic interpolation certificate, not a certificate hypothesis. +The affine-line provider is transported to the actual (1-z,z) fold over +an arbitrary field. Finite-field probability uses the project's exact +uniform probability. No field characteristic restriction is introduced. +-/ +@[expose] public section + +namespace Whir.MutualAgreement + +open Polynomial ReedSolomon ReedSolomon.HiddenDerivative +open scoped BigOperators + +variable {F : Type*} [Field F] + +open Classical in +/-- An exact correlated pair for the affine line gives actual input codewords +on the identical witness set for the binary fold. -/ +theorem not_bad_of_exact_pair {n dimension a : ℕ} + (domain : Fin n ↪ F) (U : Fin 2 → Fin n → F) (z : F) + (hexact : ∀ P : F[X], P.degree < dimension → + a ≤ (polynomialAgreementSet domain + (fun i => U 0 i + z * (U 1 i - U 0 i)) P).card → + HasExactCorrelatedPair domain (U 0) (fun i => U 1 i - U 0 i) + (RingHom.id F) dimension z P) : + ¬ Bad foldGenerator (rsCode domain dimension) a U z := by + classical + rintro ⟨T, hT, hfold, j, hj⟩ + obtain ⟨c, hc, hcT⟩ := (mem_projectedCode (rsCode domain dimension) T + (fun i => ∑ j, foldGenerator z j * U j i)).mp hfold + obtain ⟨P, hP, hPc⟩ := (mem_rsCode domain dimension c).mp hc + have hPT : ∀ i ∈ T, P.eval (domain i) = U 0 i + z * (U 1 i - U 0 i) := by + intro i hi + rw [hPc i, hcT i hi] + simp only [foldGenerator, Fin.sum_univ_two, Matrix.cons_val_zero, Matrix.cons_val_one] + ring + have hcount : a ≤ (polynomialAgreementSet domain + (fun i => U 0 i + z * (U 1 i - U 0 i)) P).card := + hT.trans (Finset.card_le_card fun i hi => (mem_polynomialAgreementSet _ _ _ _).mpr (hPT i hi)) + obtain ⟨pair, hp₀, hp₁, -, hset⟩ := hexact P hP hcount + have hpair : ∀ i ∈ T, + pair.1.eval (domain i) = U 0 i ∧ pair.2.eval (domain i) = U 1 i - U 0 i := by + intro i hi + have hmem : i ∈ polynomialAgreementSet + (domain.trans ⟨RingHom.id F, (RingHom.id F).injective⟩) + (fun i => (RingHom.id F) (U 0 i) + z * (RingHom.id F) (U 1 i - U 0 i)) P := by + simpa using hPT i hi + rw [hset] at hmem + exact (mem_commonPolynomialAgreementSet _ _ _ _ _ _).mp hmem + apply hj + fin_cases j + · apply (mem_projectedCode _ T (U 0)).mpr + refine ⟨fun i => pair.1.eval (domain i), (mem_rsCode _ _ _).mpr ⟨pair.1, hp₀, fun _ => rfl⟩, + fun i hi => (hpair i hi).1⟩ + · apply (mem_projectedCode _ T (U 1)).mpr + refine ⟨fun i => (pair.1 + pair.2).eval (domain i), + (mem_rsCode _ _ _).mpr ⟨pair.1 + pair.2, + (degree_add_le _ _).trans_lt (max_lt hp₀ hp₁), fun _ => rfl⟩, ?_⟩ + intro i hi + simp only [eval_add, (hpair i hi).1, (hpair i hi).2] + ring + +/-- The denominator written as a real three-halves power is exactly the +BCHKS25 expression, with multiplicity denominator equal to the full slack. -/ +theorem johnsonNumerator_eq_bchks (n dimension : ℕ) (radius : ℝ) : + johnsonNumerator n dimension radius = + let rate : ℝ := (dimension - 1 : ℕ) / n + let m : ℕ := max ⌈Real.sqrt rate / (1 - Real.sqrt rate - radius)⌉₊ 3 + let t : ℝ := m + 1 / 2 + ((2 * t ^ 5 + 3 * t * radius * rate) / (3 * rate ^ (3 / 2 : ℝ))) * n + + t / Real.sqrt rate := by + have h := johnson_sqrt_cube_eq_rpow_three_halves n (dimension - 1) + dsimp [johnsonRhoMinus] at h + simp only [johnsonNumerator, h] + +open Classical in +/-- The exact BCHKS25 numerator bounds same-set scalar fold failures. ArkLib +constructs the interpolation certificate internally and proves the numerical +comparison to this numerator. The degree ratio is D/n, dimension is D+1. -/ +theorem johnson_bad_count {n D : ℕ} (domain : Fin n ↪ F) + (hD : 1 ≤ D) (hDn : D ≤ n - 2) (radius : ℝ) (hradius : 0 ≤ radius) + (hJohnson : radius < 1 - Real.sqrt ((D : ℝ) / n)) + (U : Fin 2 → Fin n → F) [Fintype F] : + ((Finset.univ.filter + (Bad foldGenerator (rsCode domain (D + 1)) ⌈(n : ℝ) * (1 - radius)⌉₊ U)).card : ℝ) ≤ + johnsonNumerator n (D + 1) radius := by + let eta := 1 - Real.sqrt ((D : ℝ) / n) - radius + have heta : 0 < eta := by dsimp [eta]; linarith + have ha : johnsonAgreement n D eta = 1 - radius := by + unfold johnsonAgreement johnsonRhoMinus eta + ring + have hthreshold : johnsonAgreement n D eta * n ≤ ⌈(n : ℝ) * (1 - radius)⌉₊ := by + rw [ha, mul_comm] + exact Nat.le_ceil _ + have hAn : ⌈(n : ℝ) * (1 - radius)⌉₊ ≤ n := by + apply Nat.ceil_le.mpr + nlinarith [Nat.cast_nonneg n (α := ℝ)] + obtain ⟨ex, hcard, hgood⟩ := exists_johnson_line_exactCorrelatedPair domain + (U 0) (fun i => U 1 i - U 0 i) hD hDn heta hthreshold hAn + have hsubset : Finset.univ.filter + (Bad foldGenerator (rsCode domain (D + 1)) ⌈(n : ℝ) * (1 - radius)⌉₊ U) ⊆ ex := by + intro z hz + by_contra hzx + exact not_bad_of_exact_pair domain U z (hgood z hzx) (Finset.mem_filter.mp hz).2 + have hcompare := johnsonExceptionCount_le_comparisonEstimate hD hDn heta + (by rw [ha]; linarith) hthreshold + have hnum : johnsonComparisonEstimate n D eta = johnsonNumerator n (D + 1) radius := by + unfold johnsonComparisonEstimate johnsonComparisonShift johnsonComparisonMultiplicity + johnsonGamma johnsonNumerator + rw [ha] + simp only [Nat.add_sub_cancel, johnsonRhoMinus, eta] + congr 2 + ring + exact (Nat.cast_le.mpr (Finset.card_le_card hsubset)).trans + (hcard.trans (hcompare.trans_eq hnum)) + +open Classical in +/-- Arbitrary row interleaving has the identical BCHKS25 bound, not a +row-count multiple. All rows share the agreement set in RowBad. -/ +theorem johnson_row_bad_count {n D : ℕ} {R : Type*} [Fintype F] [Fintype R] + (domain : Fin n ↪ F) (hD : 1 ≤ D) (hDn : D ≤ n - 2) + (radius : ℝ) (hradius : 0 ≤ radius) + (hJohnson : radius < 1 - Real.sqrt ((D : ℝ) / n)) + (U : Fin 2 → R → Fin n → F) : + ((Finset.univ.filter + (RowBad foldGenerator (rsCode domain (D + 1)) ⌈(n : ℝ) * (1 - radius)⌉₊ U)).card : ℝ) ≤ + johnsonNumerator n (D + 1) radius := by + let s := Finset.univ.filter + (RowBad foldGenerator (rsCode domain (D + 1)) ⌈(n : ℝ) * (1 - radius)⌉₊ U) + obtain ⟨V, hV⟩ := row_bad_transfer foldGenerator (rsCode domain (D + 1)) + ⌈(n : ℝ) * (1 - radius)⌉₊ U s (Finset.card_le_univ s) + (fun x hx => (Finset.mem_filter.mp hx).2) + apply le_trans _ (johnson_bad_count domain hD hDn radius hradius hJohnson V) + exact_mod_cast Finset.card_le_card (show s ⊆ Finset.univ.filter + (Bad foldGenerator (rsCode domain (D + 1)) ⌈(n : ℝ) * (1 - radius)⌉₊ V) from + fun x hx => Finset.mem_filter.mpr ⟨Finset.mem_univ _, hV x hx⟩) + +open Classical in +/-- Exact uniform probability for the scalar and arbitrary-row same-set event. -/ +theorem johnson_row_bad_probability {n D : ℕ} {R : Type*} [Fintype F] [Fintype R] + (domain : Fin n ↪ F) (hD : 1 ≤ D) (hDn : D ≤ n - 2) + (radius : ℝ) (hradius : 0 ≤ radius) + (hJohnson : radius < 1 - Real.sqrt ((D : ℝ) / n)) + (U : Fin 2 → R → Fin n → F) : + (Soundness.uniformProb (Finset.univ.filter + (RowBad foldGenerator (rsCode domain (D + 1)) ⌈(n : ℝ) * (1 - radius)⌉₊ U)) : ℝ) ≤ + johnsonNumerator n (D + 1) radius / Fintype.card F := by + unfold Soundness.uniformProb + push_cast + exact div_le_div_of_nonneg_right + (johnson_row_bad_count domain hD hDn radius hradius hJohnson U) (by positivity) + +end Whir.MutualAgreement diff --git a/verification/whir/Whir/JohnsonNumerics.lean b/verification/whir/Whir/JohnsonNumerics.lean new file mode 100644 index 000000000..7fea853e3 --- /dev/null +++ b/verification/whir/Whir/JohnsonNumerics.lean @@ -0,0 +1,77 @@ +import Whir.MutualAgreement + +/-! Analytic bounds for the exact BCHKS25 numerator. The hypotheses are rate, +length, agreement, and Johnson-gap facts, not an assumed security-bit bound. -/ +namespace Whir.MutualAgreement + +/-- The profile's relative Johnson gap bounds the exact list-theorem multiplicity. +The denominator is the full slack, not twice the slack. -/ +theorem johnson_multiplicity_le_128 (rate alpha : ℝ) (halpha : 0 < alpha) + (hgap : Real.sqrt rate ≤ (128 / 129 : ℝ) * alpha) : + max ⌈Real.sqrt rate / (1 - Real.sqrt rate - (1 - alpha))⌉₊ 3 ≤ 128 := by + have hslack : 0 < 1 - Real.sqrt rate - (1 - alpha) := by nlinarith + apply max_le _ (by norm_num) + apply Nat.ceil_le.mpr + apply (div_le_iff₀ hslack).mpr + norm_num only [Nat.cast_ofNat] + nlinarith + +/-- A rate of at least 2^-26 gives a square-root rate of at least 2^-13. -/ +theorem sqrt_rate_lower (rate : ℝ) (hlower : 1 / (2 : ℝ) ^ 26 ≤ rate) : + 1 / (2 : ℝ) ^ 13 ≤ Real.sqrt rate := by + apply Real.le_sqrt_of_sq_le + norm_num at hlower ⊢ + exact hlower + +/-- A uniform analytic cap, derived solely from the production profile facts. +This does not assume the numerator bound or any claimed security-bit total. -/ +theorem johnsonNumerator_le_two_pow_108 (N dimension : ℕ) (alpha : ℝ) + (hrate_pos : 0 < ((dimension - 1 : ℕ) : ℝ) / N) + (hrate_lower : 1 / (2 : ℝ) ^ 26 ≤ ((dimension - 1 : ℕ) : ℝ) / N) + (hrate_upper : ((dimension - 1 : ℕ) : ℝ) / N ≤ 1) + (hN : N ≤ 2 ^ 26) (halpha : 0 < alpha) (halpha_lt : alpha < 1) + (hgap : Real.sqrt (((dimension - 1 : ℕ) : ℝ) / N) ≤ + (128 / 129 : ℝ) * alpha) : + johnsonNumerator N dimension (1 - alpha) ≤ (2 : ℝ) ^ 108 := by + let rate : ℝ := ((dimension - 1 : ℕ) : ℝ) / N + let x := Real.sqrt rate + let m : ℕ := max ⌈x / (1 - x - (1 - alpha))⌉₊ 3 + let t : ℝ := m + 1 / 2 + have hm : m ≤ 128 := johnson_multiplicity_le_128 rate alpha halpha hgap + have ht_nonneg : 0 ≤ t := by dsimp [t]; positivity + have ht_lt : t < 256 := by + have hmR : (m : ℝ) ≤ 128 := by exact_mod_cast hm + dsimp [t] + linarith + have ht : t ≤ 256 := ht_lt.le + have hx : 1 / (2 : ℝ) ^ 13 ≤ x := sqrt_rate_lower rate hrate_lower + have hx_pos : 0 < x := (by norm_num : (0 : ℝ) < 1 / 2 ^ 13).trans_le hx + have hrate_nonneg : 0 ≤ rate := hrate_pos.le + have hradius_nonneg : 0 ≤ 1 - alpha := by linarith + have hradius_le : 1 - alpha ≤ 1 := by linarith + have ht5 : t ^ 5 ≤ (256 : ℝ) ^ 5 := by gcongr + have hsmall : 3 * t * (1 - alpha) * rate ≤ (3 : ℝ) * 256 * 1 * 1 := by + gcongr + have hnum : 2 * t ^ 5 + 3 * t * (1 - alpha) * rate ≤ (2 : ℝ) ^ 42 := by + nlinarith [ht5, hsmall] + have hcube : (1 / (2 : ℝ) ^ 13) ^ 3 ≤ x ^ 3 := by gcongr + have hratio : (2 * t ^ 5 + 3 * t * (1 - alpha) * rate) / (3 * x ^ 3) ≤ + (2 : ℝ) ^ 81 := by + apply (div_le_iff₀ (by positivity : (0 : ℝ) < 3 * x ^ 3)).mpr + nlinarith [hcube] + have hNR : (N : ℝ) ≤ (2 : ℝ) ^ 26 := by exact_mod_cast hN + have hmain : ((2 * t ^ 5 + 3 * t * (1 - alpha) * rate) / (3 * x ^ 3)) * N ≤ + (2 : ℝ) ^ 107 := by + calc + _ ≤ (2 : ℝ) ^ 81 * (2 : ℝ) ^ 26 := + mul_le_mul hratio hNR (Nat.cast_nonneg _) (by positivity) + _ = _ := by norm_num + have htail : t / x ≤ (2 : ℝ) ^ 21 := by + apply (div_le_iff₀ hx_pos).mpr + nlinarith [hx] + change ((2 * t ^ 5 + 3 * t * (1 - alpha) * rate) / (3 * x ^ 3)) * N + t / x ≤ _ + calc + _ ≤ (2 : ℝ) ^ 107 + (2 : ℝ) ^ 21 := add_le_add hmain htail + _ ≤ (2 : ℝ) ^ 108 := by norm_num + +end Whir.MutualAgreement diff --git a/verification/whir/Whir/LevelBoundary.lean b/verification/whir/Whir/LevelBoundary.lean new file mode 100644 index 000000000..e71d03dca --- /dev/null +++ b/verification/whir/Whir/LevelBoundary.lean @@ -0,0 +1,137 @@ +import Whir.FieldTower +import Whir.ExecutableOOD +import Whir.SamplingProbability +import Whir.VerifierInvariant +import Whir.CandidateFolding + +/-! At the level boundary the OOD response selects at most one new candidate +before the entire query-vector/adjacent-lambda message. This is the reason the +query error has no candidate-list factor. -/ +namespace Whir.LevelBoundary +open Concrete Protocol + +abbrev QueryTape (depth count : Nat) := + Fin ((count + 192 / depth - 1) / (192 / depth)) → E + +noncomputable def agreeingColumns (n rate : Nat) (witness : Array E) + (oldWord : Fin (2 ^ (n + rate)) → E) : Finset (Fin (2 ^ (n + rate))) := by + classical + exact Finset.univ.filter fun q => (encode n rate witness)[q.val]! = oldWord q + +/-- A single-row post-fold oracle's list violates the residual claim. -/ +def CloseLost (n rate threshold : Nat) (oldWord : Fin (2 ^ (n + rate)) → E) + (state : VerifierState E) : Prop := + ∀ witness : Array E, witness.size = 2 ^ n → + threshold ≤ (agreeingColumns n rate witness oldWord).card → + dot witness state.weight ≠ state.claim + +/-- The actual one-lane candidate list gives the close invariant directly. -/ +theorem closeLost_of_lost (top : Bool) (n rate threshold : Nat) + (oldWord : Fin (2 ^ (n + rate)) → E) (state : VerifierState E) + (lost : VerifierInvariant.Lost + (CandidateFolding.arrayCandidates top (CandidateFolding.concreteEncoder n rate) + (fun _ : Fin 1 => oldWord) threshold) state) : + CloseLost n rate threshold oldWord state := by + intro witness shape agreement + apply lost witness + exact (CandidateFolding.concrete_oneLane_mem_iff top n rate threshold oldWord witness).mpr + ⟨shape, agreement⟩ + +def Separated (candidates : Finset (Array E)) (point : Array E) : Prop := + ∀ left ∈ candidates, ∀ right ∈ candidates, + Concrete.mle left point = Concrete.mle right point → left = right + +/-- A candidate survives every residual, OOD and sampled-column claim. The rows +here are determined by the old oracle, not by a post-lambda response. -/ +noncomputable def queryEscape (n rate count : Nat) + (oldWord : Fin (2 ^ (n + rate)) → E) (state : VerifierState E) + (candidates : Finset (Array E)) (point : Array E) (answer : E) : + Finset (QueryTape (n + rate) count) := by + classical + exact Finset.univ.filter fun tape => ∃ witness ∈ candidates, + Concrete.mle witness point = answer ∧ dot witness state.weight = state.claim ∧ + SamplingProbability.allQueriesHit (n + rate) count + (agreeingColumns n rate witness oldWord) tape + +open Classical in +/-- The OOD-separation event is bounded for the actual array MLE. -/ +theorem separation_probability (n : Nat) (candidates : Finset (Array E)) + (sizes : ∀ witness ∈ candidates, witness.size = 2 ^ n) : + Soundness.uniformProb (Finset.univ.filter fun point : Fin n → E => + ¬ Separated candidates (Array.ofFn point)) ≤ + (candidates.card.choose 2 : ℚ) * ((n : ℚ) / Fintype.card E) := by + classical + have event : (Finset.univ.filter fun point : Fin n → E => + ¬ Separated candidates (Array.ofFn point)) = + (Finset.univ.filter fun point : Fin n → E => + ∃ left ∈ candidates, ∃ right ∈ candidates, left ≠ right ∧ + Concrete.mle left (Array.ofFn point) = Concrete.mle right (Array.ofFn point)) := by + ext point + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · intro h + by_contra hn + apply h + intro left hl right hr heq + by_contra hne + exact hn ⟨left, hl, right, hr, hne, heq⟩ + · rintro ⟨left, hl, right, hr, hne, heq⟩ hsep + exact hne (hsep left hl right hr heq) + rw [event] + exact ExecutableOOD.candidate_separation candidates sizes + +/-- Exact actual sampler bound at a separated OOD boundary. All inputs outside +`tape` are fixed before queries; no iid sampling or list-union assumption is used. -/ +theorem query_escape_probability (n rate count threshold : Nat) + (oldWord : Fin (2 ^ (n + rate)) → E) (state : VerifierState E) + (candidates : Finset (Array E)) (point : Array E) (answer : E) + (alpha : ℚ) (alpha_nonneg : 0 ≤ alpha) + (threshold_eq : threshold = ⌈(2 ^ (n + rate) : ℚ) * alpha⌉₊) + (depth_pos : 0 < n + rate) (depth_bound : n + rate ≤ 64) + (sizes : ∀ witness ∈ candidates, witness.size = 2 ^ n) + (lost : CloseLost n rate threshold oldWord state) + (separated : Separated candidates point) : + Soundness.uniformProb (queryEscape n rate count oldWord state candidates point answer) ≤ + alpha ^ count := by + classical + by_cases existsCandidate : ∃ witness ∈ candidates, + Concrete.mle witness point = answer ∧ dot witness state.weight = state.claim + · obtain ⟨witness, hw, hpoint, hclaim⟩ := existsCandidate + have unique : ∀ other ∈ candidates, Concrete.mle other point = answer → other = witness := by + intro other ho hp + exact separated other ho witness hw (hp.trans hpoint.symm) + have small : (agreeingColumns n rate witness oldWord).card < threshold := by + apply Nat.lt_of_not_ge + intro close + exact lost witness (sizes witness hw) close hclaim + have density : ((agreeingColumns n rate witness oldWord).card : ℚ) / + (2 ^ (n + rate) : ℚ) ≤ alpha := by + apply (div_le_iff₀ (by positivity : (0 : ℚ) < 2 ^ (n + rate))).mpr + rw [threshold_eq] at small + have h := Nat.lt_ceil.mp small + nlinarith + have event : queryEscape n rate count oldWord state candidates point answer = + Finset.univ.filter (SamplingProbability.allQueriesHit (n + rate) count + (agreeingColumns n rate witness oldWord)) := by + ext tape + simp only [queryEscape, Finset.mem_filter, Finset.mem_univ, true_and] + constructor + · rintro ⟨other, ho, hp, _, hits⟩ + simpa only [unique other ho hp] using hits + · intro hits + exact ⟨witness, hw, hpoint, hclaim, hits⟩ + rw [event] + have sampled := SamplingProbability.actual_query_bound_rat + (n + rate) count depth_pos depth_bound (agreeingColumns n rate witness oldWord) + simp only [Nat.cast_pow, Nat.cast_ofNat] at sampled + exact sampled.trans (pow_le_pow_left₀ (by positivity) density count) + · have empty : queryEscape n rate count oldWord state candidates point answer = ∅ := by + apply Finset.eq_empty_iff_forall_notMem.mpr + intro tape h + obtain ⟨witness, hw, hp, hc, _⟩ := (Finset.mem_filter.mp h).2 + exact existsCandidate ⟨witness, hw, hp, hc⟩ + rw [empty] + simp only [Soundness.uniformProb, Finset.card_empty, Nat.cast_zero, zero_div] + exact pow_nonneg alpha_nonneg count + +end Whir.LevelBoundary diff --git a/verification/whir/Whir/MerkleBinding.lean b/verification/whir/Whir/MerkleBinding.lean new file mode 100644 index 000000000..ea7a238b8 --- /dev/null +++ b/verification/whir/Whir/MerkleBinding.lean @@ -0,0 +1,344 @@ +import Whir.Soundness + +/-! Commitment-time query-table extraction, not an assumption that an arbitrary +root has a known full tree. `Bytes` is the actual hash-input type: leaves and +pairs need not be domain separated. The two codec injectivity obligations are +separate from cryptographic security. The Rust octopus decoder must still be +shown to produce the authenticated paths modeled here. -/ +namespace Whir.MerkleBinding + +variable {Row Digest Bytes : Type*} + +structure Hashing (Row Digest Bytes : Type*) where + hash : Bytes → Digest + leaf : Row → Bytes + pair : Digest × Digest → Bytes + leaf_injective : Function.Injective leaf + pair_injective : Function.Injective pair + +inductive Opening (Row Digest : Type*) : List Bool → Type _ where + | leaf (row : Row) : Opening Row Digest [] + | node (right : Bool) (sibling : Digest) {address : List Bool} + (child : Opening Row Digest address) : Opening Row Digest (right :: address) + +namespace Opening + +def row {q : List Bool} : Opening Row Digest q → Row + | .leaf r => r + | .node _ _ p => p.row + +def digest (H : Hashing Row Digest Bytes) {q : List Bool} : Opening Row Digest q → Digest + | .leaf r => H.hash (H.leaf r) + | .node b s p => H.hash (H.pair (if b then (s, p.digest H) else (p.digest H, s))) + +def inputs [DecidableEq Bytes] (H : Hashing Row Digest Bytes) {q : List Bool} : + Opening Row Digest q → Finset Bytes + | .leaf r => {H.leaf r} + | .node b s p => insert (H.pair (if b then (s, p.digest H) else (p.digest H, s))) (p.inputs H) + +end Opening + +/-- Semantic pruned multiproof: opaque sibling subtrees have only a digest, not +a fictitious known preimage. Shared internal nodes are represented once. Rust's +flat sorted-unique octopus still needs a decoding refinement to this datatype. -/ +inductive Pruned (Stored Digest : Type*) where + | hidden (digest : Digest) + | leaf (stored : Stored) + | branch (left right : Pruned Stored Digest) + +namespace Pruned +variable {Stored : Type*} + +def digest (H : Hashing Row Digest Bytes) (image : Stored → Row) : + Pruned Stored Digest → Digest + | .hidden d => d + | .leaf r => H.hash (H.leaf (image r)) + | .branch l r => H.hash (H.pair (l.digest H image, r.digest H image)) + +/-- The returned opening contains the full leaf image. Prefix restoration +therefore occurs before hashing, and every duplicate query follows the same +shared tree rather than consuming another sibling from the transport. -/ +def openPath (H : Hashing Row Digest Bytes) (image : Stored → Row) : + (tree : Pruned Stored Digest) → (q : List Bool) → Option (Opening Row Digest q) + | .hidden _, _ => none + | .leaf r, [] => some (.leaf (image r)) + | .leaf _, _ :: _ => none + | .branch _ _, [] => none + | .branch l r, false :: q => + (l.openPath H image q).map (fun p => .node false (r.digest H image) p) + | .branch l r, true :: q => + (r.openPath H image q).map (fun p => .node true (l.digest H image) p) + +theorem openPath_authenticated (H : Hashing Row Digest Bytes) (image : Stored → Row) + (tree : Pruned Stored Digest) (q : List Bool) (p : Opening Row Digest q) + (opened : tree.openPath H image q = some p) : p.digest H = tree.digest H image := by + induction tree generalizing q with + | hidden d => simp [openPath] at opened + | leaf r => + cases q with + | nil => + simp only [openPath, Option.some.injEq] at opened + subst p + rfl + | cons b q => simp [openPath] at opened + | branch l r ihl ihr => + cases q with + | nil => simp [openPath] at opened + | cons b q => + cases b + · simp only [openPath, Option.map_eq_some_iff] at opened + obtain ⟨child, hc, he⟩ := opened + subst p + simp [Opening.digest, digest, ihl q child hc] + · simp only [openPath, Option.map_eq_some_iff] at opened + obtain ⟨child, hc, he⟩ := opened + subst p + simp [Opening.digest, digest, ihr q child hc] + +end Pruned + +/-- A real collision witness among inputs actually present in the table. -/ +def Collision (H : Hashing Row Digest Bytes) (table : Finset Bytes) : Prop := + ∃ x ∈ table, ∃ y ∈ table, x ≠ y ∧ H.hash x = H.hash y + +/-- Targets fixed at commitment: the root and the children of recorded pair +preimages. Pair-codec injectivity ensures there are at most `2 * table.card + 1` +such targets. No claim of a known full tree is made. -/ +def Target (H : Hashing Row Digest Bytes) (table : Finset Bytes) (root d : Digest) : Prop := + d = root ∨ ∃ l r, H.pair (l, r) ∈ table ∧ (d = l ∨ d = r) + +/-- A fresh query hitting a commitment-fixed target. This is a preimage game, +not collision resistance. Its ROM bound must charge the target count and all +post-commitment primitive queries, including verification. -/ +def FreshHit (H : Hashing Row Digest Bytes) (table : Finset Bytes) (root : Digest) + (queries : Finset Bytes) : Prop := + ∃ x ∈ queries, x ∉ table ∧ Target H table root (H.hash x) + +variable [DecidableEq Bytes] + + theorem recorded_unique (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (safe : ¬ Collision H table) {q : List Bool} (a b : Opening Row Digest q) + (ha : a.inputs H ⊆ table) (hb : b.inputs H ⊆ table) + (same : a.digest H = b.digest H) : a.row = b.row := by + have inj : ∀ x ∈ table, ∀ y ∈ table, H.hash x = H.hash y → x = y := by + intro x hx y hy he + by_contra hn + exact safe ⟨x, hx, y, hy, hn, he⟩ + induction a with + | leaf r => + cases b with + | leaf s => + change r = s + apply H.leaf_injective + exact inj _ (ha (by simp [Opening.inputs])) _ (hb (by simp [Opening.inputs])) same + | node d s a ih => + cases b with + | node _ t b => + have hp := H.pair_injective (inj _ (ha (by simp [Opening.inputs])) + _ (hb (by simp [Opening.inputs])) same) + apply ih b + · intro x hx; exact ha (by simp [Opening.inputs, hx]) + · intro x hx; exact hb (by simp [Opening.inputs, hx]) + · cases d + · exact congrArg Prod.fst hp + · exact congrArg Prod.snd hp + + theorem recorded_or_fresh (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (root : Digest) {q : List Bool} (p : Opening Row Digest q) + (target : Target H table root (p.digest H)) : + p.inputs H ⊆ table ∨ FreshHit H table root (p.inputs H) := by + induction p with + | leaf r => + by_cases h : H.leaf r ∈ table + · left; simpa [Opening.inputs] using h + · right; exact ⟨H.leaf r, by simp [Opening.inputs], h, target⟩ + | node b s p ih => + let x := H.pair (if b then (s, p.digest H) else (p.digest H, s)) + by_cases hx : x ∈ table + · have childTarget : Target H table root (p.digest H) := by + right + cases b + · exact ⟨p.digest H, s, hx, Or.inl rfl⟩ + · exact ⟨s, p.digest H, hx, Or.inr rfl⟩ + rcases ih childTarget with hc | ⟨y, hy, hn, ht⟩ + · left; simpa [Opening.inputs, x] using Finset.insert_subset hx hc + · right; exact ⟨y, by simp [Opening.inputs, hy], hn, ht⟩ + · right; exact ⟨x, by simp [Opening.inputs, x], hx, target⟩ + +/-- The extractor sees only the commitment-time table, root, and address. It +chooses a fully recorded path if one exists, otherwise a fixed default row. +This is a mathematical extraction game; computational search cost is not hidden +in a claimed polynomial-time extraction theorem. -/ +noncomputable def idealRow (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (root : Digest) (fallback : Row) (q : List Bool) : Row := by + classical + exact if h : ∃ p : Opening Row Digest q, p.inputs H ⊆ table ∧ p.digest H = root + then h.choose.row else fallback + + theorem opening_to_ideal (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (root : Digest) (fallback : Row) {q : List Bool} (p : Opening Row Digest q) + (accepted : p.digest H = root) : + p.row = idealRow H table root fallback q ∨ Collision H table ∨ + FreshHit H table root (p.inputs H) := by + classical + by_cases hc : Collision H table + · exact Or.inr (Or.inl hc) + rcases recorded_or_fresh H table root p (Or.inl accepted) with hp | hf + · left + have hex : ∃ a : Opening Row Digest q, a.inputs H ⊆ table ∧ a.digest H = root := ⟨p, hp, accepted⟩ + simp only [idealRow, dite_eq_left hex] + exact recorded_unique H table hc p hex.choose hp hex.choose_spec.1 + (accepted.trans hex.choose_spec.2.symm) + · exact Or.inr (Or.inr hf) + +/-- The same commitment-fixed oracle explains an entire batch, including +duplicate addresses. The reduction does not select a different oracle per row. -/ +theorem batch_to_ideal (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (root : Digest) (fallback : Row) {I : Type*} (address : I → List Bool) + (paths : ∀ i, Opening Row Digest (address i)) + (accepted : ∀ i, (paths i).digest H = root) : + (∀ i, (paths i).row = idealRow H table root fallback (address i)) ∨ + Collision H table ∨ ∃ i, FreshHit H table root ((paths i).inputs H) := by + classical + by_cases hc : Collision H table + · exact Or.inr (Or.inl hc) + by_cases hf : ∃ i, FreshHit H table root ((paths i).inputs H) + · exact Or.inr (Or.inr hf) + left + intro i + rcases opening_to_ideal H table root fallback (paths i) (accepted i) with h | h | h + · exact h + · exact (hc h).elim + · exact (hf ⟨i, h⟩).elim + +/-- Decode pair inputs in the *commitment-time* table. This definition does not +enumerate or assume a full Merkle tree. -/ +noncomputable def children (H : Hashing Row Digest Bytes) (x : Bytes) : Finset Digest := by + classical + exact if h : ∃ pair, H.pair pair = x then {h.choose.1, h.choose.2} else ∅ + +noncomputable def targets (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (root : Digest) : Finset Digest := by + classical + exact insert root (table.biUnion (children H)) + +omit [DecidableEq Bytes] in +theorem target_mem (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (root d : Digest) : Target H table root d ↔ d ∈ targets H table root := by + classical + simp only [Target, targets, Finset.mem_insert, Finset.mem_biUnion] + constructor + · rintro (h | ⟨l, r, hp, hd⟩) + · exact Or.inl h + · right + refine ⟨H.pair (l, r), hp, ?_⟩ + have hex : ∃ pair, H.pair pair = H.pair (l, r) := ⟨(l, r), rfl⟩ + have he := H.pair_injective hex.choose_spec + simpa [children, dite_eq_left hex, he] using hd + · rintro (h | ⟨x, hx, hd⟩) + · exact Or.inl h + · right + unfold children at hd + split at hd + next h => + refine ⟨h.choose.1, h.choose.2, ?_, ?_⟩ + · simpa only [h.choose_spec] using hx + · simpa using hd + next h => simp at hd + +omit [DecidableEq Bytes] in +theorem targets_card (H : Hashing Row Digest Bytes) (table : Finset Bytes) + (root : Digest) : (targets H table root).card ≤ 2 * table.card + 1 := by + classical + have hc : ∀ x, (children H x).card ≤ 2 := by + intro x + unfold children + split + · exact Finset.card_le_two + · simp + calc + _ ≤ (table.biUnion (children H)).card + 1 := Finset.card_insert_le _ _ + _ ≤ (∑ x ∈ table, (children H x).card) + 1 := + Nat.add_le_add_right Finset.card_biUnion_le 1 + _ ≤ (∑ _x ∈ table, 2) + 1 := Nat.add_le_add_right (Finset.sum_le_sum fun x _ => hc x) 1 + _ = _ := by simp [Nat.mul_comm] + +omit [DecidableEq Bytes] in +/-- Conditional on an exposed commitment-time table, a fresh random-oracle +answer is uniform. This is the single-query multi-target preimage loss; a +resource-capped adaptive game accumulates it, not a collision-only assumption. -/ +theorem fresh_target_probability [Fintype Digest] (H : Hashing Row Digest Bytes) + (table : Finset Bytes) (root : Digest) : + Soundness.uniformProb (targets H table root) ≤ + (2 * table.card + 1 : Nat) / (Fintype.card Digest : ℚ) := by + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast targets_card H table root) (by positivity) + +/-- Leading absent lanes belong to the hashed image, not to the stored row. -/ +def leafImage {Word : Type*} (zero : Word) (leafWords : Nat) (stored : List Word) : List Word := + List.replicate (leafWords - stored.length) zero ++ stored + + theorem leafImage_length {Word : Type*} (zero : Word) (n : Nat) (r : List Word) + (fits : r.length ≤ n) : (leafImage zero n r).length = n := by + simp [leafImage]; omega + + theorem leafImage_injective {Word : Type*} (zero : Word) (n width : Nat) + {a b : List Word} (ha : a.length = width) (hb : b.length = width) + (same : leafImage zero n a = leafImage zero n b) : a = b := by + simp only [leafImage, ha, hb] at same + exact List.append_cancel_left same + +/-- Sorted-unique transport is only an optimization. Refan-out reads one fixed +entry at each occurrence and therefore preserves multiplicity and query order. -/ +def refan {Address Value : Type*} (rows : Address → Value) (queries : List Address) : List Value := + queries.map rows + + theorem refan_ideal {Address Value : Type*} (rows ideal : Address → Value) + (queries : List Address) (auth : ∀ q ∈ queries, rows q = ideal q) : + refan rows queries = refan ideal queries := by + exact List.map_congr_left auth + + theorem refan_repeat {Address Value : Type*} (rows : Address → Value) (q : Address) : + refan rows [q, q] = [rows q, rows q] := rfl + +/-- End-to-end semantic pruned-opening reduction, with the zero prefix inside +the hashed image. `I` indexes occurrences, not distinct addresses, so repeated +queries share the same commitment-fixed ideal answer. There is no assumption +that opaque sibling digests possess known preimages. -/ +theorem padded_pruned_batch_to_ideal {Word I : Type*} + (H : Hashing (List Word) Digest Bytes) (zero : Word) (leafWords : Nat) + (table : Finset Bytes) (root : Digest) (fallback : List Word) + (tree : Pruned (List Word) Digest) (address : I → List Bool) + (paths : ∀ i, Opening (List Word) Digest (address i)) + (opened : ∀ i, tree.openPath H (leafImage zero leafWords) (address i) = some (paths i)) + (accepted : tree.digest H (leafImage zero leafWords) = root) : + (∀ i, (paths i).row = idealRow H table root fallback (address i)) ∨ + Collision H table ∨ ∃ i, FreshHit H table root ((paths i).inputs H) := by + apply batch_to_ideal H table root fallback address paths + intro i + exact (Pruned.openPath_authenticated H (leafImage zero leafWords) tree + (address i) (paths i) (opened i)).trans accepted + +/-! Security and refinement obligations: + +The commitment-time table must record all primitive inputs exposed before the +commitment is fixed. The global real hash has no assumed injectivity. Failure is +an actual table collision or a fresh targeted preimage, with at most +`2 * table.card + 1` targets. In a lazy ROM, charge every later primitive call, +including honest verification; `fresh_target_probability` is the conditional +single-call bound. Concrete collision/preimage security is a separate game. + +The ideal oracle is commitment-fixed, even for a malicious root with no known +full preimage. It uses arbitrary defaults only where the recorded table contains +no authenticated path; accessing such a default with a different accepted leaf +forces one of the explicit bad games. Efficient extraction requires efficient +leaf/pair decoding and bounded table/path resources. + +The flat Rust octopus parser (width/range checks, exact sibling consumption, +sorted-unique reconstruction, and little-endian leaf/pair codecs) must be refined +to `Pruned`; this module does not claim that a handwritten tree model establishes +source correspondence. `leafImage` and `refan` fix the semantic padding and +duplicate-query conventions at that boundary. +-/ + +end Whir.MerkleBinding diff --git a/verification/whir/Whir/MerkleLevels.lean b/verification/whir/Whir/MerkleLevels.lean new file mode 100644 index 000000000..f094147f2 --- /dev/null +++ b/verification/whir/Whir/MerkleLevels.lean @@ -0,0 +1,611 @@ +import Mathlib.Tactic + +/-! The sorted level walk in `fiat_shamir/src/merkle.rs:186-206`. +No sorting or additional acceptance guard is performed by this walk. -/ +namespace Whir.MerkleLevels + +abbrev Level (D : Type*) := List (Nat × D) + +def Sorted {D : Type*} (nodes : Level D) : Prop := + nodes.Pairwise (fun a b => a.1 < b.1) + +def lookup {D : Type*} (index : Nat) : Level D → Option D + | [] => none + | (i, d) :: nodes => if index = i then some d else lookup index nodes + +def right (index : Nat) : Bool := index % 2 == 1 + +def sibling (index : Nat) : Nat := if index % 2 = 0 then index + 1 else index - 1 + +def orient {D : Type*} (index : Nat) (current sibling : D) : D × D := + if index % 2 = 0 then (current, sibling) else (sibling, current) + +def emit {D : Type*} (pair : D × D → D) (index : Nat) (left right : D) + (result : Option (Level D × Level D × List D)) : + Option (Level D × Level D × List D) := + result.map fun (parents, known, rest) => + ((index / 2, pair (left, right)) :: parents, + (2 * (index / 2), left) :: (2 * (index / 2) + 1, right) :: known, rest) + +def foldLevel {D : Type*} (pair : D × D → D) : + Level D → List D → Option (Level D × Level D × List D) + | [], supplied => some ([], [], supplied) + | (i, d) :: nodes, supplied => + if i % 2 = 0 then + match nodes with + | (j, e) :: tail => + if j = i + 1 then emit pair i d e (foldLevel pair tail supplied) + else match supplied with + | [] => none + | s :: ss => emit pair i d s (foldLevel pair ((j, e) :: tail) ss) + | [] => match supplied with + | [] => none + | s :: ss => emit pair i d s (foldLevel pair [] ss) + else match supplied with + | [] => none + | s :: ss => emit pair i s d (foldLevel pair nodes ss) +termination_by nodes => nodes.length + +variable {D : Type*} + +theorem lookup_mem {i : Nat} {d : D} {nodes : Level D} + (h : lookup i nodes = some d) : (i, d) ∈ nodes := by + induction nodes with + | nil => simp [lookup] at h + | cons x xs ih => + rcases x with ⟨j, e⟩ + by_cases hij : i = j + · simp [lookup, hij] at h + simp [hij, h] + · simp [lookup, hij] at h + exact List.mem_cons_of_mem _ (ih h) + +theorem lookup_of_mem {i : Nat} {d : D} {nodes : Level D} + (sorted : Sorted nodes) (h : (i, d) ∈ nodes) : lookup i nodes = some d := by + induction nodes with + | nil => simp at h + | cons x xs ih => + rcases x with ⟨j, e⟩ + rcases List.pairwise_cons.mp sorted with ⟨before, tail⟩ + rcases List.mem_cons.mp h with he | hm + · cases he + simp [lookup] + · have hj : j < i := before _ hm + simp [lookup, show i ≠ j by omega, ih tail hm] + +theorem lookup_map {E : Type*} (f : D → E) (i : Nat) (nodes : Level D) : + lookup i (nodes.map fun x => (x.1, f x.2)) = (lookup i nodes).map f := by + induction nodes with + | nil => rfl + | cons x xs ih => rcases x with ⟨j, d⟩; simp [lookup, ih]; split <;> rfl + +/-- An exact trace of successful loop iterations; even unpaired nodes retain +the Rust next-node guard rather than accepting an arbitrary hidden sibling. -/ +inductive Folded (pair : D × D → D) : + Level D → List D → Level D → Level D → List D → Prop + | nil (supplied) : Folded pair [] supplied [] [] supplied + | paired (i : Nat) (d e : D) (nodes supplied parents known rest) + (even : i % 2 = 0) + (tail : Folded pair nodes supplied parents known rest) : + Folded pair ((i,d) :: (i+1,e) :: nodes) supplied + ((i/2, pair (d,e)) :: parents) ((i,d) :: (i+1,e) :: known) rest + | even (i : Nat) (d s : D) (nodes supplied parents known rest) + (even : i % 2 = 0) + (unpaired : nodes.head?.map Prod.fst ≠ some (i+1)) + (tail : Folded pair nodes supplied parents known rest) : + Folded pair ((i,d) :: nodes) (s :: supplied) + ((i/2, pair (d,s)) :: parents) ((i,d) :: (i+1,s) :: known) rest + | odd (i : Nat) (d s : D) (nodes supplied parents known rest) + (odd : i % 2 ≠ 0) + (tail : Folded pair nodes supplied parents known rest) : + Folded pair ((i,d) :: nodes) (s :: supplied) + ((i/2, pair (s,d)) :: parents) ((i-1,s) :: (i,d) :: known) rest + +theorem foldLevel_spec (pair : D × D → D) (nodes : Level D) (supplied : List D) + {parents known : Level D} {rest : List D} + (run : foldLevel pair nodes supplied = some (parents, known, rest)) : + Folded pair nodes supplied parents known rest := by + induction nodes using (measure List.length).wf.induction generalizing supplied parents known rest with + | _ nodes ih => + cases nodes with + | nil => + simp only [foldLevel, Option.some.injEq, Prod.mk.injEq] at run + rcases run with ⟨rfl, rfl, rfl⟩ + exact .nil supplied + | cons x nodes => + rcases x with ⟨i,d⟩ + by_cases he : i % 2 = 0 + · have hn : 2 * (i / 2) = i := by omega + cases nodes with + | nil => + cases supplied with + | nil => simp [foldLevel, he] at run + | cons s supplied => + rw [foldLevel] at run + simp only [he, ↓reduceIte, emit, hn, Option.map_eq_some_iff] at run + rcases run with ⟨⟨p,k,r⟩, hr, hout⟩ + cases hout + exact .even i d s [] supplied p k r he (by simp) + (ih [] (by change 0 < 1; omega) supplied hr) + | cons y nodes => + rcases y with ⟨j,e⟩ + by_cases hj : j = i+1 + · subst j + rw [foldLevel.eq_def] at run + simp only [he, ↓reduceIte, emit, hn, Option.map_eq_some_iff] at run + rcases run with ⟨⟨p,k,r⟩, hr, hout⟩ + cases hout + exact .paired i d e nodes supplied p k r he + (ih nodes (by change nodes.length < nodes.length + 2; omega) supplied hr) + · cases supplied with + | nil => simp [foldLevel, he, hj] at run + | cons s supplied => + rw [foldLevel] at run + simp only [he, hj, ↓reduceIte, emit, hn, + Option.map_eq_some_iff] at run + rcases run with ⟨⟨p,k,r⟩, hr, hout⟩ + cases hout + exact .even i d s ((j,e)::nodes) supplied p k r he (by simpa using hj) + (ih ((j,e)::nodes) (by change nodes.length + 1 < nodes.length + 2; omega) supplied hr) + · have hn : 2 * (i / 2) = i-1 := by omega + have hn' : i - 1 + 1 = i := by omega + cases supplied with + | nil => rw [foldLevel.eq_def] at run; simp [he] at run + | cons s supplied => + rw [foldLevel.eq_def] at run + simp only [he, ↓reduceIte, emit, hn', hn, + Option.map_eq_some_iff] at run + rcases run with ⟨⟨p,k,r⟩, hr, hout⟩ + cases hout + exact .odd i d s nodes supplied p k r he + (ih nodes (by change nodes.length < nodes.length + 1; omega) supplied hr) + +namespace Folded + +variable {pair : D × D → D} {nodes parents known : Level D} {supplied rest : List D} + +theorem parent_source (h : Folded pair nodes supplied parents known rest) : + ∀ p ∈ parents, ∃ x ∈ nodes, p.1 = x.1 / 2 := by + induction h with + | nil => simp + | paired i d e nodes supplied parents known rest he h ih => + intro p hp + rcases List.mem_cons.mp hp with rfl | hp + · exact ⟨(i,d), by simp, rfl⟩ + · obtain ⟨x,hx,eq⟩ := ih p hp + exact ⟨x, by simp [hx], eq⟩ + | even i d s nodes supplied parents known rest he hu h ih => + intro p hp + rcases List.mem_cons.mp hp with rfl | hp + · exact ⟨(i,d), by simp, rfl⟩ + · obtain ⟨x,hx,eq⟩ := ih p hp + exact ⟨x, by simp [hx], eq⟩ + | odd i d s nodes supplied parents known rest ho h ih => + intro p hp + rcases List.mem_cons.mp hp with rfl | hp + · exact ⟨(i,d), by simp, rfl⟩ + · obtain ⟨x,hx,eq⟩ := ih p hp + exact ⟨x, by simp [hx], eq⟩ + +theorem known_source (h : Folded pair nodes supplied parents known rest) : + ∀ k ∈ known, ∃ x ∈ nodes, k.1 / 2 = x.1 / 2 := by + induction h with + | nil => simp + | paired i d e nodes supplied parents known rest he h ih => + intro k hk + rcases List.mem_cons.mp hk with rfl | hk + · exact ⟨(i,d), by simp, rfl⟩ + rcases List.mem_cons.mp hk with rfl | hk + · exact ⟨(i+1,e), by simp, rfl⟩ + obtain ⟨x,hx,eq⟩ := ih k hk + exact ⟨x, by simp [hx], eq⟩ + | even i d s nodes supplied parents known rest he hu h ih => + intro k hk + rcases List.mem_cons.mp hk with rfl | hk + · exact ⟨(i,d), by simp, rfl⟩ + rcases List.mem_cons.mp hk with rfl | hk + · exact ⟨(i,d), by simp, by dsimp; omega⟩ + obtain ⟨x,hx,eq⟩ := ih k hk + exact ⟨x, by simp [hx], eq⟩ + | odd i d s nodes supplied parents known rest ho h ih => + intro k hk + rcases List.mem_cons.mp hk with rfl | hk + · exact ⟨(i,d), by simp, by dsimp; omega⟩ + rcases List.mem_cons.mp hk with rfl | hk + · exact ⟨(i,d), by simp, rfl⟩ + obtain ⟨x,hx,eq⟩ := ih k hk + exact ⟨x, by simp [hx], eq⟩ + +theorem range (h : Folded pair nodes supplied parents known rest) {bound : Nat} + (bounded : ∀ x ∈ nodes, x.1 < bound) : + ∀ p ∈ parents, p.1 < (bound + 1) / 2 := by + intro p hp + obtain ⟨x,hx,hp⟩ := h.parent_source p hp + have := bounded x hx + omega + +theorem nonempty (h : Folded pair nodes supplied parents known rest) + (hne : nodes ≠ []) : parents ≠ [] := by + cases h <;> simp_all + +/-- The suffix is literal, not merely a multiset: every unpaired iteration +consumes precisely the next supplied digest, and paired iterations consume none. -/ +theorem accounting (h : Folded pair nodes supplied parents known rest) : + ∃ consumed, supplied = consumed ++ rest ∧ + consumed.length + nodes.length = 2 * parents.length ∧ + known.length = 2 * parents.length := by + induction h with + | nil supplied => exact ⟨[], by simp⟩ + | paired i d e nodes supplied parents known rest he h ih => + obtain ⟨used,hs,hn,hk⟩ := ih + refine ⟨used, hs, ?_, ?_⟩ <;> simp only [List.length_cons] <;> omega + | even i d s nodes supplied parents known rest he hu h ih => + obtain ⟨used,hs,hn,hk⟩ := ih + refine ⟨s::used, by simp [hs], ?_, ?_⟩ <;> + simp only [List.length_cons] <;> omega + | odd i d s nodes supplied parents known rest ho h ih => + obtain ⟨used,hs,hn,hk⟩ := ih + refine ⟨s::used, by simp [hs], ?_, ?_⟩ <;> + simp only [List.length_cons] <;> omega + +private theorem extend_sorted (h : Folded pair nodes supplied parents known rest) + (sp : Sorted parents) (sk : Sorted known) (i : Nat) (p left right : D) + (separated : ∀ x ∈ nodes, i / 2 < x.1 / 2) : + Sorted ((i/2,p)::parents) ∧ + Sorted ((2*(i/2),left)::(2*(i/2)+1,right)::known) := by + constructor + · apply List.pairwise_cons.mpr + refine ⟨?_, sp⟩ + intro y hy + obtain ⟨x,hx,eq⟩ := h.parent_source y hy + have := separated x hx + dsimp + omega + · apply List.pairwise_cons.mpr + refine ⟨?_, List.pairwise_cons.mpr ⟨?_,sk⟩⟩ + · intro y hy + rcases List.mem_cons.mp hy with rfl | hy + · dsimp; omega + · obtain ⟨x,hx,eq⟩ := h.known_source y hy + have := separated x hx + dsimp + omega + · intro y hy + obtain ⟨x,hx,eq⟩ := h.known_source y hy + have := separated x hx + dsimp + omega + +private theorem unpaired_separation (i : Nat) (d : D) (nodes : Level D) + (sorted : Sorted ((i,d)::nodes)) + (unpaired : nodes.head?.map Prod.fst ≠ some (i+1)) : + ∀ x ∈ nodes, i + 1 < x.1 := by + cases nodes with + | nil => simp + | cons y ys => + rcases List.pairwise_cons.mp sorted with ⟨before, tail⟩ + have hi : i < y.1 := before y (by simp) + have hn : y.1 ≠ i+1 := by simpa using unpaired + intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · omega + · have := (List.pairwise_cons.mp tail).1 x hx + omega + +theorem sorted (h : Folded pair nodes supplied parents known rest) + (input : Sorted nodes) : Sorted parents ∧ Sorted known := by + induction h with + | nil => simp [Sorted] + | paired i d e nodes supplied parents known rest he h ih => + have ht := (List.pairwise_cons.mp (List.pairwise_cons.mp input).2) + obtain ⟨sp,sk⟩ := ih ht.2 + have hs : ∀ x ∈ nodes, i/2 < x.1/2 := by + intro x hx + have := ht.1 x hx + dsimp at this + omega + have hn : 2*(i/2) = i := by omega + simpa [hn] using h.extend_sorted sp sk i (pair (d,e)) d e hs + | even i d s nodes supplied parents known rest he hu h ih => + obtain ⟨sp,sk⟩ := ih (List.pairwise_cons.mp input).2 + have hs : ∀ x ∈ nodes, i/2 < x.1/2 := by + intro x hx + have := unpaired_separation i d nodes input hu x hx + omega + have hn : 2*(i/2) = i := by omega + simpa [hn] using h.extend_sorted sp sk i (pair (d,s)) d s hs + | odd i d s nodes supplied parents known rest ho h ih => + obtain ⟨sp,sk⟩ := ih (List.pairwise_cons.mp input).2 + have hs : ∀ x ∈ nodes, i/2 < x.1/2 := by + intro x hx + have := (List.pairwise_cons.mp input).1 x hx + dsimp at this + omega + have hn : 2*(i/2) = i-1 := by omega + have hn' : i-1+1 = i := by omega + simpa [hn, hn'] using h.extend_sorted sp sk i (pair (s,d)) s d hs + +theorem preserved (h : Folded pair nodes supplied parents known rest) : + ∀ x ∈ nodes, x ∈ known := by + induction h with + | nil => simp + | paired i d e nodes supplied parents known rest he h ih => + intro x hx + simp only [List.mem_cons] at hx ⊢ + rcases hx with rfl | rfl | hx + · exact Or.inl rfl + · exact Or.inr (Or.inl rfl) + · exact Or.inr (Or.inr (ih x hx)) + | even i d s nodes supplied parents known rest he hu h ih => + intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · simp + · exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ (ih x hx)) + | odd i d s nodes supplied parents known rest ho h ih => + intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · simp + · exact List.mem_cons_of_mem _ (List.mem_cons_of_mem _ (ih x hx)) + +theorem edge (h : Folded pair nodes supplied parents known rest) : + ∀ i d, (i,d) ∈ nodes → ∃ s, + (sibling i,s) ∈ known ∧ (i/2,pair (orient i d s)) ∈ parents := by + induction h with + | nil => simp + | paired j a b nodes supplied parents known rest he h ih => + intro i d hm + rcases List.mem_cons.mp hm with hh | hm + · cases hh + exact ⟨b, by simp [sibling, he], by simp [orient, he]⟩ + rcases List.mem_cons.mp hm with hh | hm + · cases hh + have ho : (j+1)%2 ≠ 0 := by omega + have hp : (j+1)/2 = j/2 := by omega + exact ⟨a, by simp [sibling, ho], by simp [orient, ho, hp]⟩ + obtain ⟨s,hs,hp⟩ := ih i d hm + exact ⟨s, by simp [hs], by simp [hp]⟩ + | even j a b nodes supplied parents known rest he hu h ih => + intro i d hm + rcases List.mem_cons.mp hm with hh | hm + · cases hh + exact ⟨b, by simp [sibling, he], by simp [orient, he]⟩ + obtain ⟨s,hs,hp⟩ := ih i d hm + exact ⟨s, by simp [hs], by simp [hp]⟩ + | odd j a b nodes supplied parents known rest ho h ih => + intro i d hm + rcases List.mem_cons.mp hm with hh | hm + · cases hh + exact ⟨b, by simp [sibling, ho], by simp [orient, ho]⟩ + obtain ⟨s,hs,hp⟩ := ih i d hm + exact ⟨s, by simp [hs], by simp [hp]⟩ + +end Folded + +/-- Consumer-facing facts about the *actual* successful level walk. -/ +structure Invariant (pair : D × D → D) (nodes : Level D) (supplied : List D) + (parents known : Level D) (rest : List D) : Prop where + parents_sorted : Sorted parents + known_sorted : Sorted known + preserved : ∀ {i d}, lookup i nodes = some d → lookup i known = some d + edge : ∀ {i d}, lookup i nodes = some d → ∃ s, + lookup (sibling i) known = some s ∧ + lookup (i/2) parents = some (pair (orient i d s)) + range : ∀ {bound}, (∀ x ∈ nodes, x.1 < bound) → + ∀ p ∈ parents, p.1 < (bound + 1) / 2 + nonempty : nodes ≠ [] → parents ≠ [] + accounting : ∃ consumed, supplied = consumed ++ rest ∧ + consumed.length + nodes.length = 2 * parents.length ∧ + known.length = 2 * parents.length + +theorem foldLevel_invariant (pair : D × D → D) + {nodes : Level D} {supplied : List D} {parents known : Level D} {rest : List D} + (sorted : Sorted nodes) + (folded : foldLevel pair nodes supplied = some (parents,known,rest)) : + Invariant pair nodes supplied parents known rest := by + have h := foldLevel_spec pair nodes supplied folded + obtain ⟨hp,hk⟩ := h.sorted sorted + refine ⟨hp,hk,?_,?_,h.range,h.nonempty,h.accounting⟩ + · intro i d hi + exact lookup_of_mem hk (h.preserved _ (lookup_mem hi)) + · intro i d hi + obtain ⟨s,hs,he⟩ := h.edge i d (lookup_mem hi) + exact ⟨s,lookup_of_mem hk hs,lookup_of_mem hp he⟩ + +theorem Sorted.keys_nodup {nodes : Level D} (h : Sorted nodes) : + (nodes.map Prod.fst).Nodup := by + apply List.pairwise_map.mpr + exact h.imp (fun hlt => Nat.ne_of_lt hlt) + +theorem Folded.remainder {pair : D × D → D} {nodes parents known : Level D} + {supplied rest : List D} (h : Folded pair nodes supplied parents known rest) : + rest = supplied.drop (2 * parents.length - nodes.length) := by + obtain ⟨used,hs,hn,hk⟩ := h.accounting + have hc : 2 * parents.length - nodes.length = used.length := by omega + simp [hs, hc] + +/-- Midpoint binary search on the half-open interval `[lo,hi)`. The result is +a position, as for Rust `binary_search_by_key(...).ok()`, not a digest. -/ +def binarySearchAux (index : Nat) (nodes : Level D) (lo hi : Nat) : Option Nat := + if lo < hi then + let mid := (lo + hi) / 2 + match nodes[mid]? with + | none => none + | some node => + if node.1 < index then binarySearchAux index nodes (mid+1) hi + else if index < node.1 then binarySearchAux index nodes lo mid + else some mid + else none +termination_by hi - lo +decreasing_by all_goals omega + +def binarySearch (index : Nat) (nodes : Level D) : Option Nat := + binarySearchAux index nodes 0 nodes.length + +def binaryLookup (index : Nat) (nodes : Level D) : Option D := + (binarySearch index nodes).bind fun pos => nodes[pos]?.map Prod.snd + +theorem binarySearchAux_sound (index : Nat) (nodes : Level D) (lo hi pos : Nat) + (found : binarySearchAux index nodes lo hi = some pos) : + ∃ d, nodes[pos]? = some (index,d) := by + rw [binarySearchAux.eq_def] at found + split at found + · rename_i interval + dsimp only at found + split at found + · contradiction + · rename_i node atMid + split at found + · exact binarySearchAux_sound index nodes ((lo+hi)/2+1) hi pos found + · rename_i notLess + split at found + · exact binarySearchAux_sound index nodes lo ((lo+hi)/2) pos found + · rename_i notGreater + have hk : node.1 = index := by omega + have hp : (lo+hi)/2 = pos := Option.some.inj found + refine ⟨node.2, ?_⟩ + have hn : node = (index,node.2) := Prod.ext hk rfl + rw [hp] at atMid + exact atMid.trans (congrArg some hn) + · contradiction +termination_by hi - lo +decreasing_by all_goals omega + +theorem Sorted.get_key_lt {nodes : Level D} (sorted : Sorted nodes) + {a b : Nat} {x y : Nat × D} (ha : nodes[a]? = some x) + (hb : nodes[b]? = some y) (hab : a < b) : x.1 < y.1 := by + obtain ⟨ha',hxa⟩ := List.getElem?_eq_some_iff.mp ha + obtain ⟨hb',hyb⟩ := List.getElem?_eq_some_iff.mp hb + have h := List.pairwise_iff_getElem.mp sorted a b ha' hb' hab + simpa [hxa,hyb] using h + +theorem binarySearchAux_complete (index : Nat) (nodes : Level D) (lo hi pos : Nat) + (sorted : Sorted nodes) (bounded : hi ≤ nodes.length) + (inside : lo ≤ pos ∧ pos < hi) {d : D} + (atPos : nodes[pos]? = some (index,d)) : + binarySearchAux index nodes lo hi = some pos := by + have interval : lo < hi := by omega + have midBound : (lo+hi)/2 < nodes.length := by omega + have atMid : nodes[(lo+hi)/2]? = some nodes[(lo+hi)/2] := List.getElem?_eq_getElem midBound + rw [binarySearchAux.eq_def] + simp only [interval, ↓reduceIte, atMid] + split + · rename_i less + have hp : (lo+hi)/2 < pos := by + by_contra bad + have hp : pos ≤ (lo+hi)/2 := by omega + rcases Nat.lt_or_eq_of_le hp with hp | hp + · have := sorted.get_key_lt atPos atMid hp + omega + · have eq : (index,d) = nodes[(lo+hi)/2] := by + rw [hp, atMid] at atPos + exact (Option.some.inj atPos).symm + have := congrArg Prod.fst eq + omega + exact binarySearchAux_complete index nodes ((lo+hi)/2+1) hi pos + sorted bounded ⟨by omega,inside.2⟩ atPos + · rename_i notLess + split + · rename_i greater + have hp : pos < (lo+hi)/2 := by + by_contra bad + have hp : (lo+hi)/2 ≤ pos := by omega + rcases Nat.lt_or_eq_of_le hp with hp | hp + · have := sorted.get_key_lt atMid atPos hp + omega + · have eq : nodes[(lo+hi)/2] = (index,d) := by + rw [← hp, atMid] at atPos + exact Option.some.inj atPos + have := congrArg Prod.fst eq + omega + exact binarySearchAux_complete index nodes lo ((lo+hi)/2) pos + sorted (by omega) ⟨inside.1,hp⟩ atPos + · rename_i notGreater + have hp : (lo+hi)/2 = pos := by + rcases Nat.lt_trichotomy ((lo+hi)/2) pos with hp | hp | hp + · have := sorted.get_key_lt atMid atPos hp + omega + · exact hp + · have := sorted.get_key_lt atPos atMid hp + omega + exact congrArg some hp +termination_by hi - lo +decreasing_by all_goals omega + +theorem binarySearch_some_iff {index pos : Nat} {nodes : Level D} + (sorted : Sorted nodes) : + binarySearch index nodes = some pos ↔ ∃ d, nodes[pos]? = some (index,d) := by + constructor + · exact binarySearchAux_sound index nodes 0 nodes.length pos + · rintro ⟨d,hd⟩ + have hp := (List.getElem?_eq_some_iff.mp hd).1 + exact binarySearchAux_complete index nodes 0 nodes.length pos sorted (by omega) + ⟨by omega,hp⟩ hd + +/-- Exact observable result of binary-searching a sorted unique known level +and reading the digest at the returned position. -/ +theorem binaryLookup_eq_lookup (index : Nat) (nodes : Level D) (sorted : Sorted nodes) : + binaryLookup index nodes = lookup index nodes := by + unfold binaryLookup + cases hs : binarySearch index nodes with + | none => + simp only [Option.bind_none] + cases hl : lookup index nodes with + | none => rfl + | some d => + obtain ⟨pos,hp⟩ := List.mem_iff_getElem?.mp (lookup_mem hl) + have := (binarySearch_some_iff sorted).mpr ⟨d,hp⟩ + rw [hs] at this + contradiction + | some pos => + obtain ⟨d,hd⟩ := (binarySearch_some_iff sorted).mp hs + simp only [Option.bind_some, hd, Option.map_some] + exact (lookup_of_mem sorted (List.mem_iff_getElem?.mpr ⟨pos,hd⟩)).symm + +theorem Folded.run {pair : D × D → D} {nodes parents known : Level D} + {supplied rest : List D} (h : Folded pair nodes supplied parents known rest) : + foldLevel pair nodes supplied = some (parents,known,rest) := by + induction h with + | nil => rw [foldLevel.eq_def] + | paired i d e nodes supplied parents known rest he h ih => + have hn : 2*(i/2) = i := by omega + rw [foldLevel.eq_def] + simp [he, ih, emit, hn] + | even i d s nodes supplied parents known rest he hu h ih => + have hn : 2*(i/2) = i := by omega + rw [foldLevel.eq_def] + cases nodes with + | nil => simpa [he, emit, hn] using congrArg (emit pair i d s) ih + | cons x xs => + rcases x with ⟨j,e⟩ + have hj : j ≠ i+1 := by simpa using hu + simp [he, hj, ih, emit, hn] + | odd i d s nodes supplied parents known rest ho h ih => + have hn : 2*(i/2) = i-1 := by omega + have hn' : i-1+1 = i := by omega + rw [foldLevel.eq_def] + simp [ho, ih, emit, hn, hn'] + +/-- Number of stored digests demanded by precisely the same paired-node guard. +It depends only on indices, never on the hash function or digest values. -/ +def requiredSiblings : Level D → Nat + | [] => 0 + | (i,_) :: nodes => + if i % 2 = 0 then + match nodes with + | [] => 1 + | (j,e) :: tail => + if j = i+1 then requiredSiblings tail + else 1 + requiredSiblings ((j,e)::tail) + else 1 + requiredSiblings nodes + +theorem requiredSiblings_odd (i : Nat) (d : D) (nodes : Level D) (odd : i % 2 ≠ 0) : + requiredSiblings ((i,d)::nodes) = 1 + requiredSiblings nodes := by + rw [requiredSiblings.eq_def] + simp [odd] + +theorem foldLevel_none_iff (pair : D × D → D) (nodes : Level D) (supplied : List D) : + foldLevel pair nodes supplied = none ↔ supplied.length < requiredSiblings nodes := by + fun_induction foldLevel pair nodes supplied <;> + simp_all [requiredSiblings_odd, requiredSiblings, emit, Option.map_eq_none_iff] <;> omega + +end Whir.MerkleLevels diff --git a/verification/whir/Whir/MerkleTransport.lean b/verification/whir/Whir/MerkleTransport.lean new file mode 100644 index 000000000..1555d4935 --- /dev/null +++ b/verification/whir/Whir/MerkleTransport.lean @@ -0,0 +1,1147 @@ +import Whir.ByteCodec +import Whir.MerkleBinding +import Whir.MerkleLevels +import Mathlib.Data.Nat.Bitwise + +/-! Baseline `fiat_shamir/src/merkle.rs:164-236` transport at +`69f5499304a6957f6780c8998999d783bae13302`. The Merkle file is byte-identical +in conditional #552 (`ff6a275304a3b577118b066ddcff83bfafa5998d`); this module +makes no claim about either transcript's Fiat–Shamir mode. + +The hash primitive is an explicit executable parameter. Leaves are untagged +little-endian words and pairs are precisely 64 bytes. The source's flat +bottom-up loop is `MerkleLevels.foldLevel`; reconstruction and refanout use +verified binary searches. `open_acceptance_iff` proves reconstruction adds no +rejection, and `open_refines` authenticates each occurrence's exact padded row +at fixed depth. `open_batch_to_ideal` instantiates commitment-time extraction +without assuming a full preimage tree, decoder correctness, or hash injectivity. -/ +namespace Whir.MerkleTransport +open Concrete FiatShamirGame MerkleBinding + +abbrev Primitive := List Byte → Digest32 + +def hashing (hash : Primitive) : Hashing (List K) Digest32 (List Byte) where + hash := hash + leaf := ByteCodec.wordsBytes + pair := fun p => List.ofFn (ByteCodec.pairBytes p) + leaf_injective := ByteCodec.wordsBytes_injective + pair_injective := fun _ _ h => ByteCodec.pairBytes_injective (List.ofFn_injective h) + +abbrev right := MerkleLevels.right +abbrev sibling := MerkleLevels.sibling +abbrev orient := @MerkleLevels.orient +/-- Raw paths list siblings from the leaf upward, unlike the root-first address +index on `MerkleBinding.Opening`. -/ +def addressAbove (index : Nat) : Nat → List Bool → List Bool + | 0, below => below + | n + 1, below => addressAbove (index / 2) n (right index :: below) + +theorem addressAbove_length (index n : Nat) (below : List Bool) : + (addressAbove index n below).length = n + below.length := by + induction n generalizing index below with + | zero => simp [addressAbove] + | succ n ih => simp [addressAbove, ih]; omega + +def wrap {Row D : Type} (index : Nat) : (siblings : List D) → + {below : List Bool} → Opening Row D below → + Opening Row D (addressAbove index siblings.length below) + | [], _, p => p + | s :: ss, _, p => wrap (index / 2) ss (.node (right index) s p) + +def climb {D : Type} (pair : D × D → D) (index : Nat) (current : D) : List D → D + | [] => current + | s :: ss => climb pair (index / 2) (pair (orient index current s)) ss + +theorem wrap_digest {Row D Bytes : Type} (H : Hashing Row D Bytes) + (index : Nat) (siblings : List D) {below : List Bool} (p : Opening Row D below) : + (wrap index siblings p).digest H = + climb (fun pair => H.hash (H.pair pair)) index (p.digest H) siblings := by + induction siblings generalizing index below with + | nil => rfl + | cons s ss ih => + have h := ih (index / 2) (.node (right index) s p) + change (wrap (index / 2) ss (.node (right index) s p)).digest H = climb _ (index / 2) _ ss + rw [h] + congr 2 + simp only [Opening.digest, orient, MerkleLevels.orient, right, MerkleLevels.right] + by_cases he : index % 2 = 0 + · simp [he] + · have ho : index % 2 = 1 := by omega + simp [ho] + +theorem wrap_row {Row D : Type} (index : Nat) (siblings : List D) + {below : List Bool} (p : Opening Row D below) : (wrap index siblings p).row = p.row := by + induction siblings generalizing index below with + | nil => rfl + | cons s ss ih => exact ih (index / 2) (.node (right index) s p) + +structure RawPath where + leafIndex : Nat + leafData : List K + path : List Digest32 + +def RawPath.opening (p : RawPath) : + Opening (List K) Digest32 (addressAbove p.leafIndex p.path.length []) := + wrap p.leafIndex p.path (.leaf p.leafData) + +def RawPath.root (hash : Primitive) (p : RawPath) : Digest32 := + climb (fun pair => hash (List.ofFn (ByteCodec.pairBytes pair))) p.leafIndex + (hash (ByteCodec.wordsBytes p.leafData)) p.path + +theorem RawPath.opening_digest (hash : Primitive) (p : RawPath) : + p.opening.digest (hashing hash) = p.root hash := + wrap_digest (hashing hash) p.leafIndex p.path (.leaf p.leafData) + +theorem RawPath.opening_row (p : RawPath) : p.opening.row = p.leafData := + wrap_row p.leafIndex p.path (.leaf p.leafData) + +open MerkleLevels + +def collect {A B : Type} (f : A → Option B) : List A → Option (List B) + | [] => some [] + | x :: xs => do + let y ← f x + let ys ← collect f xs + return y :: ys + +theorem collect_spec {A B : Type} (f : A → Option B) (xs : List A) (ys : List B) : + collect f xs = some ys ↔ List.Forall₂ (fun x y => f x = some y) xs ys := by + induction xs generalizing ys with + | nil => simp [collect] + | cons x xs ih => + cases ys with + | nil => simp [collect, Option.bind_eq_some_iff] + | cons y ys => simp [collect, Option.bind_eq_some_iff, ih, List.forall₂_cons] + +def runLevels {D : Type} (pair : D × D → D) : + Nat → Level D → List D → Option (Level D × List (Level D) × List D) + | 0, nodes, supplied => some (nodes, [], supplied) + | n + 1, nodes, supplied => do + let (parents, known, rest) ← foldLevel pair nodes supplied + let (final, levels, remainder) ← runLevels pair n parents rest + return (final, known :: levels, remainder) + +def reconstruct {D : Type} (index : Nat) : List (Level D) → Option (List D) + | [] => some [] + | level :: levels => do + let s ← binaryLookup (sibling index) level + let ss ← reconstruct (index / 2) levels + return s :: ss + +theorem reconstruct_length {D : Type} (index : Nat) (levels : List (Level D)) + (siblings : List D) (h : reconstruct index levels = some siblings) : + siblings.length = levels.length := by + induction levels generalizing index siblings with + | nil => simp [reconstruct] at h; subst siblings; rfl + | cons l ls ih => + simp [reconstruct, Option.bind_eq_some_iff] at h + obtain ⟨s, hs, ss, hss, he⟩ := h + cases he + simp [ih _ _ hss] + +theorem runLevels_length {D : Type} (pair : D × D → D) (n : Nat) + (nodes : Level D) (supplied : List D) (final : Level D) + (levels : List (Level D)) (rest : List D) + (h : runLevels pair n nodes supplied = some (final, levels, rest)) : + levels.length = n := by + induction n generalizing nodes supplied final levels rest with + | zero => simp [runLevels] at h; rcases h with ⟨rfl,rfl,rfl⟩; rfl + | succ n ih => + simp [runLevels, Option.bind_eq_some_iff] at h + obtain ⟨parents, known, remain, hf, ls, hr, rfl⟩ := h + simp [ih _ _ _ _ _ hr] + +def sortedUnique (queries : List Nat) : List Nat := queries.toFinset.sort (· ≤ ·) + +theorem sortedUnique_strict (queries : List Nat) : + (sortedUnique queries).Pairwise (· < ·) := + (Finset.sortedLT_sort queries.toFinset).pairwise + +structure PrunedMerklePaths where + leafData : List (List K) + siblingHashes : List Digest32 + +def leafTable (queries : List Nat) (rows : List (List K)) : Level (List K) := + (sortedUnique queries).zip rows + +def leafNodes (hash : Primitive) (leafWords : Nat) (table : Level (List K)) : + Level Digest32 := + table.map fun (i, row) => (i, hash (ByteCodec.wordsBytes (leafImage 0 leafWords row))) + +def distinctPaths (leafWords : Nat) (levels : List (Level Digest32)) + (table : Level (List K)) : Option (Level RawPath) := + collect (fun (i, row) => do + let path ← reconstruct i levels + return (i, ⟨i, leafImage 0 leafWords row, path⟩)) table + +/-- Actual octopus transport: sorted unique leaves, bottom-up adjacent pairing, +one sibling only for a missing child, exact exhaustion and root comparison, +then known-level path lookup followed by original-order refanout. -/ +def PrunedMerklePaths.open (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) : Option (List RawPath) := do + if numLeaves = 0 ∨ 2 ^ numLeaves.log2 ≠ numLeaves ∨ queries = [] then none + else if (sortedUnique queries).length ≠ proof.leafData.length ∨ rowWords > leafWords then none + else if ¬ ∀ row ∈ proof.leafData, row.length = rowWords then none + else if ∃ q ∈ queries, numLeaves ≤ q then none + else do + let table := leafTable queries proof.leafData + let nodes := leafNodes hash leafWords table + let (final, levels, rest) ← runLevels + (fun p => hash (List.ofFn (ByteCodec.pairBytes p))) numLeaves.log2 nodes proof.siblingHashes + if rest ≠ [] then none + else do + let (_, computed) ← final.head? + if computed ≠ root then none + else do + let distinct ← distinctPaths leafWords levels table + collect (fun q => binaryLookup q distinct) queries + +theorem collect_mem {A B : Type} (f : A → Option B) (xs : List A) (ys : List B) + (h : collect f xs = some ys) {y : B} (hy : y ∈ ys) : + ∃ x ∈ xs, f x = some y := by + have hr := (collect_spec f xs ys).mp h + clear h + induction hr with + | nil => simp at hy + | @cons x y xs ys hxy hrest ih => + simp only [List.mem_cons] at hy + rcases hy with rfl | hy + · exact ⟨x, by simp, hxy⟩ + · obtain ⟨z, hz, hf⟩ := ih hy + exact ⟨z, by simp [hz], hf⟩ + +theorem leafTable_sorted (queries : List Nat) (rows : List (List K)) + (count : (sortedUnique queries).length = rows.length) : + Sorted (leafTable queries rows) := by + have he : (leafTable queries rows).map Prod.fst = sortedUnique queries := by + simp [leafTable, List.map_fst_zip, count] + have hp := sortedUnique_strict queries + rw [← he, List.pairwise_map] at hp + exact hp + +theorem leafNodes_sorted (hash : Primitive) (leafWords : Nat) (table : Level (List K)) + (hs : Sorted table) : Sorted (leafNodes hash leafWords table) := by + simpa [Sorted, leafNodes, List.pairwise_map] using hs + +theorem leafTable_mem {queries : List Nat} {rows : List (List K)} + {q : Nat} {row : List K} (h : (q,row) ∈ leafTable queries rows) : + q ∈ queries ∧ row ∈ rows := by + have hp := List.of_mem_zip h + simpa [sortedUnique] using hp + +structure OpenConditions (proof : PrunedMerklePaths) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : Prop where + positive : numLeaves ≠ 0 + power : 2 ^ numLeaves.log2 = numLeaves + queries_nonempty : queries ≠ [] + count : (sortedUnique queries).length = proof.leafData.length + fits : rowWords ≤ leafWords + widths : ∀ row ∈ proof.leafData, row.length = rowWords + range : ∀ q ∈ queries, q < numLeaves + +theorem open_spec (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) : + proof.open hash root numLeaves queries rowWords leafWords = some output ↔ + OpenConditions proof numLeaves queries rowWords leafWords ∧ + ∃ final levels index distinct, + runLevels (fun p => hash (List.ofFn (ByteCodec.pairBytes p))) + numLeaves.log2 (leafNodes hash leafWords (leafTable queries proof.leafData)) + proof.siblingHashes = some (final, levels, []) ∧ + final.head? = some (index, root) ∧ + distinctPaths leafWords levels (leafTable queries proof.leafData) = some distinct ∧ + collect (fun q => binaryLookup q distinct) queries = some output := by + simp only [PrunedMerklePaths.open] + simp [Option.bind_eq_some_iff] + constructor + · rintro ⟨⟨h0, hp, hq⟩, ⟨hc, hf⟩, hw, hr, h⟩ + exact ⟨⟨h0, hp, hq, hc, hf, hw, hr⟩, h⟩ + · rintro ⟨h, rest⟩ + exact ⟨⟨h.positive, h.power, h.queries_nonempty⟩, ⟨h.count, h.fits⟩, + h.widths, h.range, rest⟩ + +theorem runLevels_range {D : Type} (pair : D × D → D) (n bound : Nat) + (nodes : Level D) (supplied : List D) (final : Level D) + (levels : List (Level D)) (rest : List D) + (h : runLevels pair n nodes supplied = some (final, levels, rest)) + (bounded : ∀ x ∈ nodes, x.1 < 2 ^ n * bound) : + ∀ x ∈ final, x.1 < bound := by + induction n generalizing nodes supplied final levels rest with + | zero => + simp [runLevels] at h + rcases h with ⟨rfl,rfl,rfl⟩ + simpa using bounded + | succ n ih => + simp [runLevels, Option.bind_eq_some_iff] at h + obtain ⟨parents, known, remain, hf, ls, hr, rfl⟩ := h + apply ih _ _ _ _ _ hr + intro p hp + obtain ⟨x, hx, he⟩ := (foldLevel_spec pair nodes supplied hf).parent_source p hp + have hb := bounded x hx + rw [pow_succ, Nat.mul_right_comm, Nat.mul_comm _ 2] at hb + rw [he] + omega + +theorem runLevels_nonempty {D : Type} (pair : D × D → D) (n : Nat) + (nodes : Level D) (supplied : List D) (final : Level D) + (levels : List (Level D)) (rest : List D) + (h : runLevels pair n nodes supplied = some (final, levels, rest)) + (nonempty : nodes ≠ []) : final ≠ [] := by + induction n generalizing nodes supplied final levels rest with + | zero => + simp [runLevels] at h + rcases h with ⟨rfl,rfl,rfl⟩ + exact nonempty + | succ n ih => + simp [runLevels, Option.bind_eq_some_iff] at h + obtain ⟨parents, known, remain, hf, ls, hr, rfl⟩ := h + exact ih _ _ _ _ _ hr ((foldLevel_spec pair nodes supplied hf).nonempty nonempty) + +theorem runLevels_sorted {D : Type} (pair : D × D → D) (n : Nat) + (nodes : Level D) (supplied : List D) (final : Level D) + (levels : List (Level D)) (rest : List D) + (h : runLevels pair n nodes supplied = some (final, levels, rest)) + (sorted : Sorted nodes) : Sorted final ∧ ∀ level ∈ levels, Sorted level := by + induction n generalizing nodes supplied final levels rest with + | zero => + simp [runLevels] at h + rcases h with ⟨rfl,rfl,rfl⟩ + exact ⟨sorted, by simp⟩ + | succ n ih => + simp [runLevels, Option.bind_eq_some_iff] at h + obtain ⟨parents, known, remain, hf, ls, hr, rfl⟩ := h + have hfacts := foldLevel_invariant pair sorted hf + obtain ⟨hs, hl⟩ := ih _ _ _ _ _ hr hfacts.parents_sorted + exact ⟨hs, by simpa using And.intro hfacts.known_sorted hl⟩ + +/-- Every initial node has the exact known-table siblings, and their bottom-up +fold is a node of the final level. This also proves reconstruction cannot fail. -/ +theorem runLevels_path {D : Type} (pair : D × D → D) (n : Nat) + (nodes : Level D) (supplied : List D) (final : Level D) + (levels : List (Level D)) (rest : List D) + (h : runLevels pair n nodes supplied = some (final, levels, rest)) + (sorted : Sorted nodes) (index : Nat) (digest : D) + (start : lookup index nodes = some digest) : + ∃ path lastIndex, reconstruct index levels = some path ∧ + lookup lastIndex final = some (climb pair index digest path) := by + induction n generalizing nodes supplied final levels rest index digest with + | zero => + simp [runLevels] at h + rcases h with ⟨rfl,rfl,rfl⟩ + exact ⟨[], index, rfl, start⟩ + | succ n ih => + simp [runLevels, Option.bind_eq_some_iff] at h + obtain ⟨parents, known, remain, hf, ls, hr, rfl⟩ := h + have hfacts := foldLevel_invariant pair sorted hf + obtain ⟨s, hs, hp⟩ := hfacts.edge start + obtain ⟨path, last, hpath, hlast⟩ := + ih _ _ _ _ _ hr hfacts.parents_sorted (index / 2) _ hp + exact ⟨s :: path, last, by + simp [reconstruct, binaryLookup_eq_lookup _ _ hfacts.known_sorted, hs, hpath], hlast⟩ + +theorem sorted_singleton_of_range {D : Type} (nodes : Level D) + (sorted : Sorted nodes) (bounded : ∀ x ∈ nodes, x.1 < 1) + (nonempty : nodes ≠ []) : ∃ digest, nodes = [(0, digest)] := by + cases nodes with + | nil => contradiction + | cons x xs => + have hx := bounded x (by simp) + have hx0 : x.1 = 0 := by omega + cases xs with + | nil => exact ⟨x.2, by cases x; simp_all⟩ + | cons y ys => + have hy := bounded y (by simp) + have hxy := (List.pairwise_cons.mp sorted).1 y (by simp) + omega + +theorem root_level (hash : Primitive) (proof : PrunedMerklePaths) + (numLeaves : Nat) (queries : List Nat) (rowWords leafWords : Nat) + (conditions : OpenConditions proof numLeaves queries rowWords leafWords) + (final : Level Digest32) (levels : List (Level Digest32)) (rest : List Digest32) + (run : runLevels (fun p => hash (List.ofFn (ByteCodec.pairBytes p))) + numLeaves.log2 (leafNodes hash leafWords (leafTable queries proof.leafData)) + proof.siblingHashes = some (final, levels, rest)) + (index : Nat) (root : Digest32) (head : final.head? = some (index, root)) : + final = [(0,root)] ∧ ∀ level ∈ levels, Sorted level := by + have hs := leafNodes_sorted hash leafWords _ (leafTable_sorted _ _ conditions.count) + obtain ⟨hf, hl⟩ := runLevels_sorted _ _ _ _ _ _ _ run hs + have hb : ∀ x ∈ final, x.1 < 1 := by + apply runLevels_range _ _ 1 _ _ _ _ _ run + intro x hx + obtain ⟨⟨q,row⟩, hmem, rfl⟩ := List.mem_map.mp hx + have hq := conditions.range q (leafTable_mem hmem).1 + simpa [conditions.power] using hq + have hn : final ≠ [] := by intro he; simp [he] at head + obtain ⟨digest, he⟩ := sorted_singleton_of_range final hf hb hn + subst final + simp only [List.head?_cons, Option.some.injEq, Prod.mk.injEq] at head + exact ⟨by rw [head.2], hl⟩ + +theorem leafNodes_lookup (hash : Primitive) (leafWords : Nat) (table : Level (List K)) + (index : Nat) (row : List K) (h : lookup index table = some row) : + lookup index (leafNodes hash leafWords table) = + some (hash (ByteCodec.wordsBytes (leafImage 0 leafWords row))) := by + change lookup index (table.map (fun x => + (x.1, hash (ByteCodec.wordsBytes (leafImage 0 leafWords x.2))))) = _ + rw [lookup_map (fun row => hash (ByteCodec.wordsBytes (leafImage 0 leafWords row))) index table, h] + rfl + +theorem distinctPaths_mem (leafWords : Nat) (levels : List (Level Digest32)) + (table : Level (List K)) (distinct : Level RawPath) + (decoded : distinctPaths leafWords levels table = some distinct) + (index : Nat) (p : RawPath) (member : (index,p) ∈ distinct) : + ∃ row, (index,row) ∈ table ∧ p.leafIndex = index ∧ + p.leafData = leafImage 0 leafWords row ∧ reconstruct index levels = some p.path := by + obtain ⟨⟨i,row⟩, hm, he⟩ := collect_mem _ table distinct decoded member + simp [Option.bind_eq_some_iff] at he + obtain ⟨path, hpath, hi, hp⟩ := he + subst index + subst p + exact ⟨row, hm, rfl, rfl, hpath⟩ + +theorem collect_map {A B C : Type} (f : A → Option B) (g : A → C) (k : B → C) + (xs : List A) (ys : List B) (h : collect f xs = some ys) + (preserves : ∀ x y, f x = some y → g x = k y) : xs.map g = ys.map k := by + have hr := (collect_spec _ _ _).mp h + clear h + induction hr with + | nil => rfl + | cons hxy _ ih => simp [preserves _ _ hxy, ih] + +theorem distinctPaths_keys (leafWords : Nat) (levels : List (Level Digest32)) + (table : Level (List K)) (distinct : Level RawPath) + (decoded : distinctPaths leafWords levels table = some distinct) : + distinct.map Prod.fst = table.map Prod.fst := by + symm + apply collect_map _ Prod.fst Prod.fst _ _ decoded + intro x y h + simp [Option.bind_eq_some_iff] at h + obtain ⟨path, hp, he⟩ := h + exact congrArg Prod.fst he + +theorem distinctPaths_sorted (leafWords : Nat) (levels : List (Level Digest32)) + (table : Level (List K)) (distinct : Level RawPath) + (decoded : distinctPaths leafWords levels table = some distinct) + (sorted : Sorted table) : Sorted distinct := by + have hk := distinctPaths_keys leafWords levels table distinct decoded + change distinct.Pairwise (fun x y => x.1 < y.1) + rw [← List.pairwise_map] + rw [hk, List.pairwise_map] + exact sorted + +/-- Occurrence-indexed refinement: returned order and duplicates are unchanged; +the row is precisely the row at this sorted-unique slot, with the announced +zero prefix; every raw path has the fixed tree height and hashes to the root. -/ +def Refines (hash : Primitive) (proof : PrunedMerklePaths) (root : Digest32) + (numLeaves : Nat) (queries : List Nat) (rowWords leafWords : Nat) + (index : Nat) (p : RawPath) : Prop := + ∃ row, lookup index (leafTable queries proof.leafData) = some row ∧ + row.length = rowWords ∧ p.leafIndex = index ∧ + p.leafData = leafImage 0 leafWords row ∧ p.leafData.length = leafWords ∧ + p.path.length = numLeaves.log2 ∧ p.root hash = root + +theorem open_refines (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries rowWords leafWords = some output) : + List.Forall₂ (Refines hash proof root numLeaves queries rowWords leafWords) queries output := by + obtain ⟨conditions, final, levels, index, distinct, run, head, hd, hout⟩ := + (open_spec hash proof root numLeaves queries rowWords leafWords output).mp accepted + obtain ⟨hroot, hlevels⟩ := root_level hash proof _ _ _ _ conditions _ _ _ run index root head + have ht := leafTable_sorted queries proof.leafData conditions.count + have hn := leafNodes_sorted hash leafWords _ ht + apply ((collect_spec _ _ _).mp hout).imp + intro q p hp + rw [binaryLookup_eq_lookup _ _ (distinctPaths_sorted _ _ _ _ hd ht)] at hp + obtain ⟨row, hm, hindex, hdata, hpath⟩ := + distinctPaths_mem leafWords levels _ distinct hd q p (lookup_mem hp) + have hrow := lookup_of_mem ht hm + have hwidth := conditions.widths row (leafTable_mem hm).2 + have hlength := (reconstruct_length q levels p.path hpath).trans + (runLevels_length _ _ _ _ _ _ _ run) + obtain ⟨path, last, hrec, hlast⟩ := runLevels_path _ _ _ _ _ _ _ run hn q _ + (leafNodes_lookup hash leafWords _ q row hrow) + have hsame : path = p.path := Option.some.inj (hrec.symm.trans hpath) + rw [hsame, hroot] at hlast + simp only [lookup] at hlast + split at hlast + · have ha := Option.some.inj hlast + refine ⟨row, hrow, hwidth, hindex, hdata, ?_, hlength, ?_⟩ + · rw [hdata]; exact leafImage_length 0 leafWords row (hwidth ▸ conditions.fits) + · simpa [RawPath.root, hindex, hdata] using ha.symm + · contradiction + +theorem leafTable_nonempty (queries : List Nat) (rows : List (List K)) + (nonempty : queries ≠ []) (count : (sortedUnique queries).length = rows.length) : + leafTable queries rows ≠ [] := by + have hsort : sortedUnique queries ≠ [] := by + intro h + have hlen := congrArg List.length h + simp [sortedUnique] at hlen + exact nonempty hlen + intro h + rcases List.zip_eq_nil_iff.mp h with he | he + · exact hsort he + · have : (sortedUnique queries).length = 0 := by simpa [he] using count + exact hsort (List.length_eq_zero_iff.mp this) + +/-- The root-level nonemptiness/index fact is derived before accessing the head; +the optional head access in `open` adds no acceptance restriction. -/ +theorem levels_singleton (hash : Primitive) (proof : PrunedMerklePaths) + (numLeaves : Nat) (queries : List Nat) (rowWords leafWords : Nat) + (conditions : OpenConditions proof numLeaves queries rowWords leafWords) + (final : Level Digest32) (levels : List (Level Digest32)) (rest : List Digest32) + (run : runLevels (fun p => hash (List.ofFn (ByteCodec.pairBytes p))) + numLeaves.log2 (leafNodes hash leafWords (leafTable queries proof.leafData)) + proof.siblingHashes = some (final, levels, rest)) : + ∃ root, final = [(0,root)] := by + have hs := leafNodes_sorted hash leafWords _ (leafTable_sorted _ _ conditions.count) + have hn : leafNodes hash leafWords (leafTable queries proof.leafData) ≠ [] := by + simpa [leafNodes] using + leafTable_nonempty queries proof.leafData conditions.queries_nonempty conditions.count + have hf := runLevels_nonempty _ _ _ _ _ _ _ run hn + apply sorted_singleton_of_range final (runLevels_sorted _ _ _ _ _ _ _ run hs).1 _ hf + apply runLevels_range _ _ 1 _ _ _ _ _ run + intro x hx + obtain ⟨⟨q,row⟩, hmem, rfl⟩ := List.mem_map.mp hx + simpa [conditions.power] using conditions.range q (leafTable_mem hmem).1 + +/-- Exact Rust raw sibling coordinate: level `j`, index `(leaf >> j) ^ 1`. +`sibling` is parity arithmetic for xor-one and division by `2^j` is right shift. -/ +theorem reconstruct_get {D : Type} (index : Nat) (levels : List (Level D)) + (siblings : List D) (h : reconstruct index levels = some siblings) (j : Nat) : + siblings[j]? = (levels[j]?).bind + (fun level => binaryLookup (sibling (index / 2 ^ j)) level) := by + induction levels generalizing index siblings j with + | nil => simp [reconstruct] at h; subst siblings; simp + | cons l ls ih => + simp [reconstruct, Option.bind_eq_some_iff] at h + obtain ⟨s, hs, ss, hss, rfl⟩ := h + cases j with + | zero => simpa using hs.symm + | succ j => + have he := ih (index / 2) ss hss j + simpa [Nat.div_div_eq_div_mul, pow_succ, Nat.mul_comm] using he + +theorem collect_total {A B : Type} (f : A → Option B) (xs : List A) + (total : ∀ x ∈ xs, ∃ y, f x = some y) : ∃ ys, collect f xs = some ys := by + induction xs with + | nil => exact ⟨[],rfl⟩ + | cons x xs ih => + obtain ⟨y,hy⟩ := total x (by simp) + obtain ⟨ys,hys⟩ := ih (fun z hz => total z (by simp [hz])) + exact ⟨y::ys, by simp [collect,hy,hys]⟩ + +/-- Once the baseline guards, exact sibling exhaustion, and root test pass, +known-level reconstruction and duplicate refanout cannot reject. There is no +extra independent-path verification or stricter acceptance set. -/ +theorem open_complete (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) + (conditions : OpenConditions proof numLeaves queries rowWords leafWords) + (final : Level Digest32) (levels : List (Level Digest32)) + (run : runLevels (fun p => hash (List.ofFn (ByteCodec.pairBytes p))) + numLeaves.log2 (leafNodes hash leafWords (leafTable queries proof.leafData)) + proof.siblingHashes = some (final, levels, [])) + (index : Nat) (head : final.head? = some (index,root)) : + ∃ output, proof.open hash root numLeaves queries rowWords leafWords = some output := by + have ht := leafTable_sorted queries proof.leafData conditions.count + have hn := leafNodes_sorted hash leafWords _ ht + have total : ∀ x ∈ leafTable queries proof.leafData, ∃ path, + reconstruct x.1 levels = some path := by + intro x hx + obtain ⟨path,last,hp,hl⟩ := runLevels_path _ _ _ _ _ _ _ run hn x.1 _ + (leafNodes_lookup hash leafWords _ x.1 x.2 (lookup_of_mem ht hx)) + exact ⟨path,hp⟩ + have hd : ∃ distinct, + distinctPaths leafWords levels (leafTable queries proof.leafData) = some distinct := by + apply collect_total + intro x hx + obtain ⟨path,hp⟩ := total x hx + exact ⟨(x.1,⟨x.1,leafImage 0 leafWords x.2,path⟩), by simp [hp]⟩ + obtain ⟨distinct,hd⟩ := hd + have hs := distinctPaths_sorted _ _ _ _ hd ht + have hk := distinctPaths_keys _ _ _ _ hd + have hkeys : distinct.map Prod.fst = sortedUnique queries := by + rw [hk] + exact List.map_fst_zip (Nat.le_of_eq conditions.count) + obtain ⟨output,hout⟩ := collect_total (fun q => binaryLookup q distinct) queries (by + intro q hq + have hmem : q ∈ distinct.map Prod.fst := by simpa [hkeys, sortedUnique] using hq + obtain ⟨⟨i,p⟩,hm,he⟩ := List.mem_map.mp hmem + dsimp at he + subst i + exact ⟨p, (binaryLookup_eq_lookup _ _ hs).trans (lookup_of_mem hs hm)⟩) + refine ⟨output, (open_spec _ _ _ _ _ _ _ _).mpr ?_⟩ + exact ⟨conditions,final,levels,index,distinct,run,head,hd,hout⟩ + +theorem open_acceptance_iff (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) : + (∃ output, proof.open hash root numLeaves queries rowWords leafWords = some output) ↔ + OpenConditions proof numLeaves queries rowWords leafWords ∧ + ∃ final levels index, + runLevels (fun p => hash (List.ofFn (ByteCodec.pairBytes p))) + numLeaves.log2 (leafNodes hash leafWords (leafTable queries proof.leafData)) + proof.siblingHashes = some (final, levels, []) ∧ + final.head? = some (index,root) := by + constructor + · rintro ⟨output,accepted⟩ + obtain ⟨conditions,final,levels,index,distinct,run,head,hd,hout⟩ := + (open_spec _ _ _ _ _ _ _ _).mp accepted + exact ⟨conditions,final,levels,index,run,head⟩ + · rintro ⟨conditions,final,levels,index,run,head⟩ + exact open_complete _ _ _ _ _ _ _ conditions final levels run index head + +theorem forall₂_mem_right {A B : Type} {R : A → B → Prop} {xs : List A} {ys : List B} + (h : List.Forall₂ R xs ys) {y : B} (hy : y ∈ ys) : ∃ x ∈ xs, R x y := by + induction h with + | nil => simp at hy + | @cons x y xs ys hxy hrest ih => + rcases List.mem_cons.mp hy with rfl | hy + · exact ⟨x,by simp,hxy⟩ + · obtain ⟨z,hz,hr⟩ := ih hy + exact ⟨z,by simp [hz],hr⟩ + +/-- Commitment-time extraction for the executable flat decoder. The ideal +oracle depends only on the commitment-time hash-input table and root, not the +later query batch. A failure is an actual collision or fresh targeted preimage. +No semantic-decoder or codec bridge is assumed. -/ +theorem open_batch_to_ideal (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries rowWords leafWords = some output) + (table : Finset (List Byte)) (fallback : List K) : + (∀ p ∈ output, p.leafData = idealRow (hashing hash) table root fallback + (addressAbove p.leafIndex numLeaves.log2 [])) ∨ + Collision (hashing hash) table ∨ + ∃ p ∈ output, FreshHit (hashing hash) table root (p.opening.inputs (hashing hash)) := by + classical + have refined := open_refines _ _ _ _ _ _ _ _ accepted + have auth : ∀ p ∈ output, p.path.length = numLeaves.log2 ∧ p.root hash = root := by + intro p hp + obtain ⟨q,hq,row,hr,hw,hi,hd,hl,hdepth,hroot⟩ := forall₂_mem_right refined hp + exact ⟨hdepth,hroot⟩ + let I := {p : RawPath // p ∈ output} + have batch := batch_to_ideal (hashing hash) table root fallback + (fun p : I => addressAbove p.val.leafIndex p.val.path.length []) + (fun p => p.val.opening) + (fun p => (p.val.opening_digest hash).trans (auth p.val p.property).2) + rcases batch with hi | hc | hf + · left + intro p hp + have he := hi ⟨p,hp⟩ + simpa only [RawPath.opening_row, (auth p hp).1] using he + · exact Or.inr (Or.inl hc) + · obtain ⟨p,hp⟩ := hf + exact Or.inr (Or.inr ⟨p.val,p.property,hp⟩) + +theorem power_guard_iff (n : Nat) : + (n ≠ 0 ∧ 2 ^ n.log2 = n) ↔ n.isPowerOfTwo := by + constructor + · intro h; exact ⟨n.log2,h.2.symm⟩ + · rintro ⟨k,rfl⟩ + simp + +theorem sibling_eq_xor (index : Nat) : sibling index = index ^^^ 1 := by + by_cases he : index % 2 = 0 + · simp [sibling, MerkleLevels.sibling, he, Nat.xor_one_of_even (Nat.even_iff.mpr he)] + · have ho : Odd index := Nat.odd_iff.mpr (by omega) + simp [sibling, MerkleLevels.sibling, he, Nat.xor_one_of_odd ho] + +theorem reconstruct_rust_coordinate {D : Type} (index : Nat) (levels : List (Level D)) + (siblings : List D) (h : reconstruct index levels = some siblings) (j : Nat) : + siblings[j]? = (levels[j]?).bind + (fun level => binaryLookup ((index >>> j) ^^^ 1) level) := by + simpa [Nat.shiftRight_eq_div_pow, sibling_eq_xor] using reconstruct_get index levels siblings h j + +/-- The range guard is exactly Rust's sorted-last check, not a stricter test. -/ +theorem range_guard_iff (queries : List Nat) (n : Nat) : + (∀ q ∈ queries, q < n) ↔ ∀ q ∈ (sortedUnique queries).getLast?, q < n := by + constructor + · intro h q hq + exact h q (by simpa [sortedUnique] using List.mem_of_mem_getLast? hq) + · intro h q hq + have hm : q ∈ sortedUnique queries := by simpa [sortedUnique] using hq + have le := (Finset.pairwise_sort queries.toFinset (· ≤ ·)).rel_getLast hm + exact lt_of_le_of_lt le (h _ (List.getLast_mem_getLast? (List.ne_nil_of_mem hm))) + +/-- The returned list follows one sorted-unique lookup table. Equal queries +therefore return literally the same raw path, not just equal authenticated rows. -/ +theorem open_refanout (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries rowWords leafWords = some output) : + ∃ distinct : Level RawPath, Sorted distinct ∧ + distinct.map Prod.fst = sortedUnique queries ∧ + List.Forall₂ (fun q p => binaryLookup q distinct = some p) queries output := by + obtain ⟨conditions,final,levels,index,distinct,run,head,hd,hout⟩ := + (open_spec _ _ _ _ _ _ _ _).mp accepted + refine ⟨distinct,distinctPaths_sorted _ _ _ _ hd (leafTable_sorted _ _ conditions.count), ?_, + (collect_spec _ _ _).mp hout⟩ + rw [distinctPaths_keys _ _ _ _ hd] + exact List.map_fst_zip (Nat.le_of_eq conditions.count) + +theorem open_repeated_query (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries rowWords leafWords = some output) + (i j : Nat) (hi : i < queries.length) (hj : j < queries.length) + (hi' : i < output.length) (hj' : j < output.length) + (same : queries[i] = queries[j]) : output[i] = output[j] := by + obtain ⟨distinct,hs,hkeys,hr⟩ := open_refanout _ _ _ _ _ _ _ _ accepted + have a := hr.get hi hi' + have b := hr.get hj hj' + simp only [List.get_eq_getElem] at a b + rw [same] at a + exact Option.some.inj (a.symm.trans b) + +def RawPath.fixedOpening (p : RawPath) (height : Nat) (depth : p.path.length = height) : + Opening (List K) Digest32 (addressAbove p.leafIndex height []) := + depth ▸ p.opening + +theorem RawPath.fixedOpening_row (p : RawPath) (height : Nat) + (depth : p.path.length = height) : (p.fixedOpening height depth).row = p.leafData := by + subst height + exact p.opening_row + +theorem RawPath.fixedOpening_digest (hash : Primitive) (p : RawPath) (height : Nat) + (depth : p.path.length = height) : + (p.fixedOpening height depth).digest (hashing hash) = p.root hash := by + subst height + exact p.opening_digest hash + +/-- Successful flat decoding supplies the semantic `Opening` itself, at exactly +the commitment's fixed depth. This is a checked output of the parser, not an +assumed correctness bridge. -/ +theorem open_authenticated (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries rowWords leafWords = some output) : + ∀ p ∈ output, ∃ path : Opening (List K) Digest32 + (addressAbove p.leafIndex numLeaves.log2 []), + path.row = p.leafData ∧ path.digest (hashing hash) = root := by + intro p hp + obtain ⟨q,hq,row,hr,hw,hi,hd,hl,hdepth,hroot⟩ := + forall₂_mem_right (open_refines _ _ _ _ _ _ _ _ accepted) hp + exact ⟨p.fixedOpening _ hdepth, p.fixedOpening_row _ hdepth, + (p.fixedOpening_digest hash _ hdepth).trans hroot⟩ + +namespace Commitments + +/-- The exposed primitive-input table is captured on the root's first +registration. Repeated roots never replace this snapshot with a later table. -/ +structure Snapshot where + table : Finset (List Byte) + fallback : List K + +abbrev Registry := List (Digest32 × Snapshot) + +def lookup (root : Digest32) : Registry → Option Snapshot + | [] => none + | (r,s) :: rest => if root = r then some s else lookup root rest + +def register (registry : Registry) (root : Digest32) (snapshot : Snapshot) : Registry := + match lookup root registry with + | some _ => registry + | none => (root,snapshot) :: registry + +def registerMany (registry : Registry) (announcements : Registry) : Registry := + announcements.foldl (fun registry entry => register registry entry.1 entry.2) registry + +theorem register_first (registry : Registry) (root : Digest32) (snapshot : Snapshot) + (fresh : lookup root registry = none) : + lookup root (register registry root snapshot) = some snapshot := by + simp [register, fresh, lookup] + +theorem register_repeat (registry : Registry) (root : Digest32) (old new : Snapshot) + (known : lookup root registry = some old) : register registry root new = registry := by + simp [register,known] + +/-- Any already registered root keeps the exact original table and fallback, +including when the same root is seen from another cloned transcript. -/ +theorem register_preserves (registry : Registry) (root other : Digest32) + (snapshot proposed : Snapshot) (known : lookup root registry = some snapshot) : + lookup root (register registry other proposed) = some snapshot := by + unfold register + cases h : lookup other registry with + | some s => exact known + | none => + have ne : root ≠ other := by intro he; subst other; simp [known] at h + simp [lookup,ne,known] + +theorem registerMany_preserves (registry announcements : Registry) (root : Digest32) + (snapshot : Snapshot) (known : lookup root registry = some snapshot) : + lookup root (registerMany registry announcements) = some snapshot := by + induction announcements generalizing registry with + | nil => exact known + | cons entry rest ih => + exact ih _ (register_preserves registry root entry.1 snapshot entry.2 known) + +/-- One immutable oracle indexed by the whole root-first address. Depth is +part of the address: untagged leaf/pair hashing does not justify identifying +different-depth openings of the same digest. -/ +noncomputable def oracle (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (address : List Bool) : List K := + idealRow (hashing hash) snapshot.table root snapshot.fallback address + +noncomputable def row (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index : Nat) : List K := oracle hash snapshot root (addressAbove index height []) + +/-- Total shape-normalized *ideal* row, not an additional verifier check. +An inadmissibly sized extracted row receives the fixed zero default. An +accepted opening has the announced width, so its row is never changed here +outside the explicit collision/fresh-hit games. Initial rows stay RAW: the +protocol's first-level fold, not this registry, performs the lane reversal. -/ +noncomputable def baseRow (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index width : Nat) : List K := + let raw := row hash snapshot root height index + if raw.length = width then raw else List.replicate width 0 + +theorem baseRow_length (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index width : Nat) : (baseRow hash snapshot root height index width).length = width := by + dsimp only [baseRow] + split <;> simp_all + +noncomputable def intermediateRow (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index width : Nat) : List E := + (ByteCodec.wordsToFields (baseRow hash snapshot root height index (3 * width))).getD + (List.replicate width E.zero) + +theorem intermediateRow_decoded (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index width : Nat) : + ByteCodec.wordsToFields (baseRow hash snapshot root height index (3 * width)) = + some (intermediateRow hash snapshot root height index width) ∧ + (intermediateRow hash snapshot root height index width).length = width := by + obtain ⟨fields,hf,hlen⟩ := ByteCodec.wordsToFields_total + (baseRow hash snapshot root height index (3 * width)) width + (baseRow_length hash snapshot root height index (3 * width)) + simp [intermediateRow,hf,hlen] + +noncomputable def baseOracle (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) : Array (Array K) := + Array.ofFn (fun q : Fin numRows => (baseRow hash snapshot root height q.val width).toArray) + +noncomputable def intermediateOracle (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) : Array (Array E) := + Array.ofFn (fun q : Fin numRows => (intermediateRow hash snapshot root height q.val width).toArray) + +theorem baseOracle_size (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) : (baseOracle hash snapshot root height numRows width).size = numRows := by + simp [baseOracle] + +theorem intermediateOracle_size (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) : + (intermediateOracle hash snapshot root height numRows width).size = numRows := by + simp [intermediateOracle] + +theorem baseOracle_get (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width index : Nat) (bound : index < numRows) : + (baseOracle hash snapshot root height numRows width)[index]! = + (baseRow hash snapshot root height index width).toArray := by + simp [baseOracle, bound] + +theorem intermediateOracle_get (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width index : Nat) (bound : index < numRows) : + (intermediateOracle hash snapshot root height numRows width)[index]! = + (intermediateRow hash snapshot root height index width).toArray := by + simp [intermediateOracle, bound] + +theorem baseOracle_row_size (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width index : Nat) (bound : index < numRows) : + ((baseOracle hash snapshot root height numRows width)[index]!).size = width := by + rw [baseOracle_get _ _ _ _ _ _ _ bound] + simpa using baseRow_length hash snapshot root height index width + +theorem intermediateOracle_row_size (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width index : Nat) (bound : index < numRows) : + ((intermediateOracle hash snapshot root height numRows width)[index]!).size = width := by + rw [intermediateOracle_get _ _ _ _ _ _ _ bound] + simpa using (intermediateRow_decoded hash snapshot root height index width).2 + +def OpenBad (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (output : List RawPath) : Prop := + Collision (hashing hash) snapshot.table ∨ + ∃ p ∈ output, FreshHit (hashing hash) snapshot.table root (p.opening.inputs (hashing hash)) + +/-- Later accepted actual flat openings are bound to the frozen snapshot. +The registry may have grown arbitrarily; no equality between independently +extracted full oracles or later exposed tables is assumed. -/ +theorem open_frozen (hash : Primitive) (registry announcements : Registry) + (root : Digest32) (snapshot : Snapshot) + (committed : lookup root registry = some snapshot) + (proof : PrunedMerklePaths) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries rowWords leafWords = some output) : + lookup root (registerMany registry announcements) = some snapshot ∧ + ((∀ p ∈ output, p.leafData = row hash snapshot root numLeaves.log2 p.leafIndex) ∨ + OpenBad hash snapshot root output) := by + refine ⟨registerMany_preserves registry announcements root snapshot committed, ?_⟩ + exact open_batch_to_ideal hash proof root numLeaves queries rowWords leafWords output + accepted snapshot.table snapshot.fallback + +/-- All later batches (including transcript clones) use the SAME frozen +commitment-time oracle. A failure is a collision in that snapshot or a fresh +query hitting one of its fixed root/child targets. -/ +theorem batches_frozen {I : Type} (hash : Primitive) (registry : Registry) + (announcements : I → Registry) (root : Digest32) (snapshot : Snapshot) + (committed : lookup root registry = some snapshot) + (proof : I → PrunedMerklePaths) (numLeaves : I → Nat) (queries : I → List Nat) + (rowWords leafWords : I → Nat) (output : I → List RawPath) + (accepted : ∀ i, (proof i).open hash root (numLeaves i) (queries i) + (rowWords i) (leafWords i) = some (output i)) : + (∀ i, lookup root (registerMany registry (announcements i)) = some snapshot) ∧ + ((∀ i, ∀ p ∈ output i, + p.leafData = row hash snapshot root (numLeaves i).log2 p.leafIndex) ∨ + Collision (hashing hash) snapshot.table ∨ + ∃ i, ∃ p ∈ output i, + FreshHit (hashing hash) snapshot.table root (p.opening.inputs (hashing hash))) := by + classical + refine ⟨fun i => registerMany_preserves registry _ root snapshot committed, ?_⟩ + by_cases hc : Collision (hashing hash) snapshot.table + · exact Or.inr (Or.inl hc) + by_cases hf : ∃ i, ∃ p ∈ output i, + FreshHit (hashing hash) snapshot.table root (p.opening.inputs (hashing hash)) + · exact Or.inr (Or.inr hf) + left + intro i + have h := (open_frozen hash registry (announcements i) root snapshot committed + (proof i) (numLeaves i) (queries i) (rowWords i) (leafWords i) (output i) (accepted i)).2 + rcases h with hi | hi | hi + · exact hi + · exact (hc hi).elim + · obtain ⟨p,hp,hfresh⟩ := hi + exact (hf ⟨i,p,hp,hfresh⟩).elim + +theorem open_base_rows (hash : Primitive) (snapshot : Snapshot) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries rowWords leafWords = some output) : + List.Forall₂ (fun q p => p.leafData.toArray = + (baseOracle hash snapshot root numLeaves.log2 numLeaves leafWords)[q]!) queries output ∨ + OpenBad hash snapshot root output := by + have refined := open_refines _ _ _ _ _ _ _ _ accepted + have conditions := ((open_spec _ _ _ _ _ _ _ _).mp accepted).1 + rcases open_batch_to_ideal hash proof root numLeaves queries rowWords leafWords output + accepted snapshot.table snapshot.fallback with good | bad + · left + apply List.forall₂_of_length_eq_of_get refined.length_eq + intro i hi ho + obtain ⟨stored,hs,hw,hindex,hdata,hlen,hdepth,hroot⟩ := refined.get hi ho + have hq := conditions.range (queries.get ⟨i,hi⟩) (List.get_mem _ _) + have hraw := good (output.get ⟨i,ho⟩) (List.get_mem _ _) + rw [baseOracle_get _ _ _ _ _ _ _ hq] + congr 1 + rw [← hindex] + dsimp only [baseRow] + change (output.get ⟨i,ho⟩).leafData = row hash snapshot root _ _ at hraw + rw [← hraw, ite_eq_left hlen] + · exact Or.inr bad + +/-- The source's `chunks(3)` conversion is total on accepted intermediate +rows and agrees with the shape-total frozen E oracle, in original query order. -/ +theorem open_intermediate_rows (hash : Primitive) (snapshot : Snapshot) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (width : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries (3 * width) (3 * width) = some output) : + List.Forall₂ (fun q p => ByteCodec.wordsToFields p.leafData = + some ((intermediateOracle hash snapshot root numLeaves.log2 numLeaves width)[q]!).toList) + queries output ∨ OpenBad hash snapshot root output := by + have conditions := ((open_spec _ _ _ _ _ _ _ _).mp accepted).1 + rcases open_base_rows hash snapshot proof root numLeaves queries (3*width) (3*width) + output accepted with good | bad + · left + apply List.forall₂_of_length_eq_of_get good.length_eq + intro i hi ho + have hq := conditions.range (queries.get ⟨i,hi⟩) (List.get_mem _ _) + have hb := good.get hi ho + rw [baseOracle_get _ _ _ _ _ _ _ hq] at hb + have hw := congrArg Array.toList hb + change (output.get ⟨i,ho⟩).leafData = + baseRow hash snapshot root numLeaves.log2 (queries.get ⟨i,hi⟩) (3*width) at hw + rw [hw, intermediateOracle_get _ _ _ _ _ _ _ hq] + simpa using (intermediateRow_decoded hash snapshot root numLeaves.log2 + (queries.get ⟨i,hi⟩) width).1 + · exact Or.inr bad + +/-- Extraction locality is unconditional, including for a collisionful table: +it compares the entire recorded-path predicate, rather than assuming that +classical choice selected the same path because an opening was unique. -/ +theorem opening_locality (hash other : Primitive) (table : Finset (List Byte)) + (agree : ∀ x ∈ table, hash x = other x) {address : List Bool} + (path : Opening (List K) Digest32 address) + (recorded : path.inputs (hashing hash) ⊆ table) : + path.inputs (hashing hash) = path.inputs (hashing other) ∧ + path.digest (hashing hash) = path.digest (hashing other) := by + induction path with + | leaf words => + refine ⟨rfl, ?_⟩ + exact agree (ByteCodec.wordsBytes words) (recorded (by simp [Opening.inputs,hashing])) + | node direction sibling child ih => + have childRecorded : child.inputs (hashing hash) ⊆ table := by + intro x hx + exact recorded (Finset.mem_insert_of_mem hx) + obtain ⟨hi,hd⟩ := ih childRecorded + have hp : (hashing hash).pair + (if direction then (sibling,child.digest (hashing hash)) + else (child.digest (hashing hash),sibling)) ∈ table := + recorded (Finset.mem_insert_self _ _) + constructor + · simp only [Opening.inputs,hi,hd] + rfl + · simp only [Opening.digest] + rw [← hd] + exact agree _ hp + +theorem recorded_predicate_locality (hash other : Primitive) (table : Finset (List Byte)) + (root : Digest32) (address : List Bool) + (agree : ∀ x ∈ table, hash x = other x) : + (fun path : Opening (List K) Digest32 address => + path.inputs (hashing hash) ⊆ table ∧ path.digest (hashing hash) = root) = + (fun path : Opening (List K) Digest32 address => + path.inputs (hashing other) ⊆ table ∧ path.digest (hashing other) = root) := by + funext path + apply propext + constructor + · rintro ⟨recorded,accepted⟩ + obtain ⟨hi,hd⟩ := opening_locality hash other table agree path recorded + exact ⟨hi ▸ recorded, hd ▸ accepted⟩ + · rintro ⟨recorded,accepted⟩ + obtain ⟨hi,hd⟩ := opening_locality other hash table + (fun x hx => (agree x hx).symm) path recorded + exact ⟨hi ▸ recorded, hd ▸ accepted⟩ + +theorem idealRow_locality (hash other : Primitive) (table : Finset (List Byte)) + (root : Digest32) (fallback : List K) (address : List Bool) + (agree : ∀ x ∈ table, hash x = other x) : + idealRow (hashing hash) table root fallback address = + idealRow (hashing other) table root fallback address := by + classical + let select (predicate : Opening (List K) Digest32 address → Prop) : List K := + if h : ∃ path, predicate path then h.choose.row else fallback + change select _ = select _ + apply congrArg select + exact recorded_predicate_locality hash other table root address agree + +theorem oracle_locality (hash other : Primitive) (snapshot : Snapshot) (root : Digest32) + (agree : ∀ x ∈ snapshot.table, hash x = other x) : + oracle hash snapshot root = oracle other snapshot root := by + funext address + exact idealRow_locality hash other snapshot.table root snapshot.fallback address agree + +theorem baseOracle_locality (hash other : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) (agree : ∀ x ∈ snapshot.table, hash x = other x) : + baseOracle hash snapshot root height numRows width = + baseOracle other snapshot root height numRows width := by + simp only [baseOracle,baseRow,row,oracle_locality hash other snapshot root agree] + rfl + +theorem intermediateOracle_locality (hash other : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) (agree : ∀ x ∈ snapshot.table, hash x = other x) : + intermediateOracle hash snapshot root height numRows width = + intermediateOracle other snapshot root height numRows width := by + simp only [intermediateOracle,intermediateRow,baseRow,row, + oracle_locality hash other snapshot root agree] + rfl + +/-- Finite primitive queries and their already exposed answers. This is data +in the causal interpreter state, not a function closing over future answers. -/ +abbrev Records := List (List Byte × Digest32) + +def recordLookup (input : List Byte) : Records → Option Digest32 + | [] => none + | (x,d) :: rest => if input = x then some d else recordLookup input rest + +def recordDomain (records : Records) : Finset (List Byte) := + (records.map Prod.fst).toFinset + +/-- A total *extraction view*, not a cryptographic hash implementation. +Unrecorded inputs receive a fixed public answer; locality proves that answer +cannot affect extraction from a covered snapshot. -/ +def recordedHash (records : Records) (absent : Digest32) : Primitive := + fun input => (recordLookup input records).getD absent + +def Authentic (hash : Primitive) (records : Records) : Prop := + ∀ input digest, (input,digest) ∈ records → hash input = digest + +theorem recordLookup_mem (records : Records) (input : List Byte) (digest : Digest32) + (found : recordLookup input records = some digest) : (input,digest) ∈ records := by + induction records with + | nil => simp [recordLookup] at found + | cons entry rest ih => + rcases entry with ⟨x,d⟩ + by_cases he : input = x + · simp [recordLookup,he] at found + simp [he,found] + · simp [recordLookup,he] at found + exact List.mem_cons_of_mem _ (ih found) + +theorem recordLookup_exists (records : Records) (input : List Byte) + (member : input ∈ recordDomain records) : ∃ digest, recordLookup input records = some digest := by + induction records with + | nil => simp [recordDomain] at member + | cons entry rest ih => + rcases entry with ⟨x,d⟩ + by_cases he : input = x + · exact ⟨d,by simp [recordLookup,he]⟩ + · have hm : input ∈ recordDomain rest := by + simpa [recordDomain,he] using member + obtain ⟨digest,hd⟩ := ih hm + exact ⟨digest,by simp [recordLookup,he,hd]⟩ + +theorem recordedHash_agrees (hash : Primitive) (records : Records) (absent : Digest32) + (authentic : Authentic hash records) : + ∀ input ∈ recordDomain records, hash input = recordedHash records absent input := by + intro input member + obtain ⟨digest,hd⟩ := recordLookup_exists records input member + have ha := authentic input digest (recordLookup_mem records input digest hd) + simpa [recordedHash,hd] using ha + +theorem recordedHash_agrees_on_snapshot (hash : Primitive) (records : Records) + (absent : Digest32) (snapshot : Snapshot) (authentic : Authentic hash records) + (covered : snapshot.table ⊆ recordDomain records) : + ∀ input ∈ snapshot.table, hash input = recordedHash records absent input := + fun input hi => recordedHash_agrees hash records absent authentic input (covered hi) + +/-- The full-primitive oracle equals extraction through only finite exposed +records. Neither absence of collisions nor an assumed codec/decoder bridge is +needed; later primitive answers are absent from the right-hand definition. -/ +theorem oracle_eq_recorded (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (records : Records) (absent : Digest32) (authentic : Authentic hash records) + (covered : snapshot.table ⊆ recordDomain records) : + oracle hash snapshot root = oracle (recordedHash records absent) snapshot root := + oracle_locality hash _ snapshot root + (recordedHash_agrees_on_snapshot hash records absent snapshot authentic covered) + +theorem baseOracle_eq_recorded (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) (records : Records) (absent : Digest32) + (authentic : Authentic hash records) (covered : snapshot.table ⊆ recordDomain records) : + baseOracle hash snapshot root height numRows width = + baseOracle (recordedHash records absent) snapshot root height numRows width := + baseOracle_locality hash _ snapshot root height numRows width + (recordedHash_agrees_on_snapshot hash records absent snapshot authentic covered) + +theorem intermediateOracle_eq_recorded (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) (records : Records) (absent : Digest32) + (authentic : Authentic hash records) (covered : snapshot.table ⊆ recordDomain records) : + intermediateOracle hash snapshot root height numRows width = + intermediateOracle (recordedHash records absent) snapshot root height numRows width := + intermediateOracle_locality hash _ snapshot root height numRows width + (recordedHash_agrees_on_snapshot hash records absent snapshot authentic covered) + +/-- Changing the fixed answer outside the exposed finite table has no effect +on the extractor. This includes changing every as-yet-unqueried hash value. -/ +theorem recorded_oracle_absent_irrelevant (snapshot : Snapshot) (root : Digest32) + (records : Records) (absent otherAbsent : Digest32) + (covered : snapshot.table ⊆ recordDomain records) : + oracle (recordedHash records absent) snapshot root = + oracle (recordedHash records otherAbsent) snapshot root := by + apply oracle_locality + intro input hi + obtain ⟨digest,hd⟩ := recordLookup_exists records input (covered hi) + simp [recordedHash,hd] + +end Commitments + +end Whir.MerkleTransport diff --git a/verification/whir/Whir/MutualAgreement.lean b/verification/whir/Whir/MutualAgreement.lean new file mode 100644 index 000000000..369d0dff2 --- /dev/null +++ b/verification/whir/Whir/MutualAgreement.lean @@ -0,0 +1,376 @@ +module + +public import Whir.Soundness +public import Mathlib.FieldTheory.Finiteness +public import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas +public import Mathlib.LinearAlgebra.Finsupp.LinearCombination +public import Mathlib.Analysis.SpecialFunctions.Pow.Real +public import Mathlib.RingTheory.Polynomial.Basic +public import Mathlib.Algebra.Field.ZMod +public import Mathlib.Algebra.Polynomial.OfFn + +/-! +Same-set mutual correlated agreement and row-interleaving transfer. +The finite-subspace counting argument and projection proof adapt ArkLib commit +35ddcaa83f683011f944f58904be779495a5709a, files +ToMathlib/LinearAlgebra/Submodule/Union.lean and +Data/CodingTheory/InterleavedCode/{Projection,ExactAgreement}.lean +(Apache-2.0, copyright 2026 ArkLib Contributors, author Quang Dao). +No Reed-Solomon Johnson exceptional-set estimate is assumed or proved here. +-/ +@[expose] public section + +namespace Whir.MutualAgreement + +open scoped BigOperators +open Polynomial + +/-- The sharp finite-field avoidance bound includes equality with the field size. -/ +theorem exists_avoiding_submodules {I F V : Type*} [Field F] [Fintype F] + [AddCommGroup V] [Module F V] [FiniteDimensional F V] + (s : Finset I) (p : I → Submodule F V) + (hp : ∀ i ∈ s, p i ≠ ⊤) (hs : s.card ≤ Fintype.card F) : + ∃ v : V, ∀ i ∈ s, v ∉ p i := by + classical + rcases subsingleton_or_nontrivial V with hV | hV + · exact ⟨0, fun i hi => (hp i hi (Subsingleton.elim _ _)).elim⟩ + let b := Module.finBasis F V + let _ : Finite V := + Finite.of_equiv (Fin (Module.finrank F V) → F) b.equivFun.toEquiv.symm + let _ := Fintype.ofFinite V + let q := Fintype.card F + let d := Module.finrank F V + let nonzero (i : I) := Finset.univ.filter fun x : V => x ∈ p i ∧ x ≠ 0 + let covered := insert (0 : V) (s.biUnion nonzero) + have hq : 1 < q := Fintype.one_lt_card + have hd : 0 < d := Module.finrank_pos + have hnonzero (i : I) (hi : i ∈ s) : + (nonzero i).card ≤ q ^ (d - 1) - 1 := by + let all := Finset.univ.filter fun x : V => x ∈ p i + have hzero : (0 : V) ∈ all := by simp [all] + have heq : nonzero i = all.erase 0 := by + ext x + simp [nonzero, all, and_comm] + rw [heq, Finset.card_erase_of_mem hzero] + have hcard : all.card = Fintype.card (p i) := by + symm + exact Fintype.card_ofFinset all (by simp [all]) + have hpow : Fintype.card (p i) = q ^ Module.finrank F (p i) := by + simpa [q] using (Module.card_eq_pow_finrank (K := F) (V := p i)) + rw [hcard, hpow] + exact Nat.sub_le_sub_right + (Nat.pow_le_pow_right (Nat.zero_lt_of_lt hq) + (Nat.le_sub_one_of_lt (Submodule.finrank_lt (hp i hi)))) 1 + have hcovered : covered.card < Fintype.card V := by + have hbiUnion : (s.biUnion nonzero).card ≤ s.card * (q ^ (d - 1) - 1) := by + calc + _ ≤ ∑ i ∈ s, (nonzero i).card := Finset.card_biUnion_le + _ ≤ ∑ _i ∈ s, (q ^ (d - 1) - 1) := + Finset.sum_le_sum fun i hi => hnonzero i hi + _ = _ := by simp + have hmul : s.card * (q ^ (d - 1) - 1) ≤ q * (q ^ (d - 1) - 1) := + Nat.mul_le_mul_right _ hs + have hpow : q ^ d = q * q ^ (d - 1) := by + conv_lhs => rw [← Nat.succ_pred_eq_of_pos hd] + simp [pow_succ, Nat.mul_comm] + have hcard : Fintype.card V = q ^ d := by + simpa [q, d] using (Module.card_eq_pow_finrank (K := F) (V := V)) + rw [hcard, hpow] + calc + covered.card ≤ (s.biUnion nonzero).card + 1 := Finset.card_insert_le _ _ + _ ≤ s.card * (q ^ (d - 1) - 1) + 1 := Nat.add_le_add_right hbiUnion 1 + _ ≤ q * (q ^ (d - 1) - 1) + 1 := Nat.add_le_add_right hmul 1 + _ < q * q ^ (d - 1) := by + have hpos : 0 < q ^ (d - 1) := pow_pos (Nat.zero_lt_of_lt hq) _ + have hqmul : q ≤ q * q ^ (d - 1) := by + simpa using Nat.mul_le_mul_left q hpos + rw [Nat.mul_sub_left_distrib] + simp only [mul_one] + omega + obtain ⟨x, -, hx⟩ := Finset.exists_mem_notMem_of_card_lt_card + (s := covered) (t := Finset.univ) (by simpa using hcovered) + refine ⟨x, fun i hi hxi => hx ?_⟩ + by_cases hx0 : x = 0 + · simp [covered, hx0] + · exact Finset.mem_insert.mpr (Or.inr + (Finset.mem_biUnion.mpr ⟨i, hi, by simp [nonzero, hxi, hx0]⟩)) + +variable {F I J R S : Type*} [Field F] + +/-- Restricting actual codewords to a fixed agreement set gives a linear code. -/ +def projectedCode (C : Submodule F (I → F)) (T : Finset I) : Submodule F (T → F) := + C.map ({ toFun := fun w i => w i + map_add' := by intros; rfl + map_smul' := by intros; rfl } : (I → F) →ₗ[F] (T → F)) + +/-- Membership means extension to a codeword on this very set, not another set. -/ +theorem mem_projectedCode (C : Submodule F (I → F)) (T : Finset I) (w : I → F) : + (fun i : T => w i) ∈ projectedCode C T ↔ + ∃ c ∈ C, ∀ i ∈ T, c i = w i := by + change (∃ c, c ∈ C ∧ (fun i : T => c i) = fun i : T => w i) ↔ _ + constructor + · rintro ⟨c, hc, heq⟩ + exact ⟨c, hc, fun i hi => congrFun heq ⟨i, hi⟩⟩ + · rintro ⟨c, hc, heq⟩ + exact ⟨c, hc, funext fun i => heq i i.2⟩ + +/-- Same-set MCA for an arbitrary coefficient generator and integer threshold. -/ +def Bad [Fintype J] (G : S → J → F) (C : Submodule F (I → F)) + (a : ℕ) (U : J → I → F) (x : S) : Prop := + ∃ T : Finset I, a ≤ T.card ∧ + (fun i : T => ∑ j, G x j * U j i) ∈ projectedCode C T ∧ + ∃ j, (fun i : T => U j i) ∉ projectedCode C T + +/-- All rows use one agreement set; a different set for each row is not MCA. -/ +def RowBad [Fintype J] (G : S → J → F) (C : Submodule F (I → F)) + (a : ℕ) (U : J → R → I → F) (x : S) : Prop := + ∃ T : Finset I, a ≤ T.card ∧ + (∀ r, (fun i : T => ∑ j, G x j * U j r i) ∈ projectedCode C T) ∧ + ∃ j r, (fun i : T => U j r i) ∉ projectedCode C T + +/-- Row combinations are linear in their coefficient functional. -/ +noncomputable def rowMap [Fintype R] (U : R → I → F) (T : Finset I) : + (R → F) →ₗ[F] (T → F) := + Fintype.linearCombination F (fun r i => U r i) + +/-- Functionals which hide all input failures on the selected agreement set. -/ +noncomputable def goodFunctionals [Fintype R] (C : Submodule F (I → F)) + (U : J → R → I → F) (T : Finset I) : Submodule F (R → F) := + ⨅ j, (projectedCode C T).comap (rowMap (U j) T) + +theorem mem_goodFunctionals [Fintype R] (C : Submodule F (I → F)) + (U : J → R → I → F) (T : Finset I) (l : R → F) : + l ∈ goodFunctionals C U T ↔ + ∀ j, (fun i : T => ∑ r, l r * U j r i) ∈ projectedCode C T := by + simp only [goodFunctionals, Submodule.mem_iInf, Submodule.mem_comap, + rowMap, Fintype.linearCombination_apply] + have heq (j : J) : (∑ r, l r • fun i : T => U j r i) = + (fun i : T => ∑ r, l r * U j r i) := by + funext i + simp + simp only [heq] + +/-- A failed row makes the submodule of hiding functionals proper. -/ +theorem goodFunctionals_ne_top [Fintype R] (C : Submodule F (I → F)) + (U : J → R → I → F) (T : Finset I) + (h : ∃ j r, (fun i : T => U j r i) ∉ projectedCode C T) : + goodFunctionals C U T ≠ ⊤ := by + classical + rintro htop + obtain ⟨j, r, hr⟩ := h + have hmem : Pi.single r (1 : F) ∈ goodFunctionals C U T := htop ▸ Submodule.mem_top + simp only [goodFunctionals, Submodule.mem_iInf, Submodule.mem_comap, rowMap, + Fintype.linearCombination_apply_single, one_smul] at hmem + exact hr (hmem j) + +/-- A single row functional preserves every bad seed, with no row-count loss. -/ +theorem row_bad_transfer [Fintype F] [Fintype J] [Fintype R] + (G : S → J → F) (C : Submodule F (I → F)) (a : ℕ) + (U : J → R → I → F) (s : Finset S) (hs : s.card ≤ Fintype.card F) + (hbad : ∀ x ∈ s, RowBad G C a U x) : + ∃ V : J → I → F, ∀ x ∈ s, Bad G C a V x := by + classical + choose! T hT using hbad + obtain ⟨l, hl⟩ := exists_avoiding_submodules s (fun x => goodFunctionals C U (T x)) + (fun x hx => goodFunctionals_ne_top C U (T x) (hT x hx).2.2) hs + refine ⟨fun j i => ∑ r, l r * U j r i, fun x hx => ⟨T x, (hT x hx).1, ?_, ?_⟩⟩ + · have hm := (projectedCode C (T x)).sum_mem + (fun r (_ : r ∈ Finset.univ) => + (projectedCode C (T x)).smul_mem (l r) ((hT x hx).2.1 r)) + convert hm using 1 + funext i + simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j _ + apply Finset.sum_congr rfl + intro r _ + ring + · exact not_forall.mp fun hall => hl x hx ((mem_goodFunctionals C U (T x) l).mpr hall) + +open Classical in +/-- A proved scalar bound transfers to arbitrarily many rows without a union bound. -/ +theorem row_bad_probability_le [Fintype F] [Fintype J] [Fintype R] [Fintype S] + (G : S → J → F) (C : Submodule F (I → F)) (a : ℕ) (error : ℚ) + (hS : Fintype.card S ≤ Fintype.card F) + (hscalar : ∀ V : J → I → F, + Soundness.uniformProb (Finset.univ.filter (Bad G C a V)) ≤ error) + (U : J → R → I → F) : + Soundness.uniformProb (Finset.univ.filter (RowBad G C a U)) ≤ error := by + classical + let s := Finset.univ.filter (RowBad G C a U) + obtain ⟨V, hV⟩ := row_bad_transfer G C a U s ((Finset.card_le_univ s).trans hS) + (fun x hx => (Finset.mem_filter.mp hx).2) + apply le_trans _ (hscalar V) + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_le_card (show s ⊆ Finset.univ.filter (Bad G C a V) from + fun x hx => Finset.mem_filter.mpr ⟨Finset.mem_univ _, hV x hx⟩) + +/-- The actual binary fold coefficients, without a characteristic assumption. -/ +def foldGenerator (z : F) : Fin 2 → F := ![1 - z, z] + +/-- The integer event is exactly the real-radius event, including the same set. -/ +theorem bad_iff_radius [Fintype I] [Fintype J] (G : S → J → F) + (C : Submodule F (I → F)) (radius : ℝ) (U : J → I → F) (x : S) : + Bad G C ⌈(Fintype.card I : ℝ) * (1 - radius)⌉₊ U x ↔ + ∃ T : Finset I, (Fintype.card I : ℝ) * (1 - radius) ≤ T.card ∧ + (∃ c ∈ C, ∀ i ∈ T, c i = ∑ j, G x j * U j i) ∧ + ∃ j, ¬ ∃ c ∈ C, ∀ i ∈ T, c i = U j i := by + unfold Bad + apply exists_congr + intro T + rw [Nat.ceil_le, mem_projectedCode C T (fun i => ∑ j, G x j * U j i)] + simp only [mem_projectedCode] + +/-- Outside the same-set row MCA event, every folded candidate lifts on its +original agreement set. Linearity suffices; no distance or uniqueness premise +is required, because the lifted codewords can be corrected outside the set. -/ +theorem fold_candidate_lifts (C : Submodule F (I → F)) (a : ℕ) + (U₀ U₁ V : R → I → F) (z : F) + (hV : ∀ r, V r ∈ C) (T : Finset I) (hT : a ≤ T.card) + (hagree : ∀ r i, i ∈ T → V r i = (1 - z) * U₀ r i + z * U₁ r i) + (hgood : ¬ RowBad foldGenerator C a ![U₀, U₁] z) : + ∃ P₀ P₁ : R → I → F, + (∀ r, P₀ r ∈ C ∧ P₁ r ∈ C) ∧ + (∀ r i, i ∈ T → P₀ r i = U₀ r i ∧ P₁ r i = U₁ r i) ∧ + ∀ r i, V r i = (1 - z) * P₀ r i + z * P₁ r i := by + classical + have hcomb : ∀ r, (fun i : T => + ∑ j, foldGenerator z j * (![U₀, U₁] j) r i) ∈ projectedCode C T := by + intro r + apply (mem_projectedCode C T (fun i => ∑ j, foldGenerator z j * (![U₀, U₁] j) r i)).mpr + refine ⟨V r, hV r, ?_⟩ + intro i hi + simpa [foldGenerator, Fin.sum_univ_two] using hagree r i hi + have hrows : ∀ j : Fin 2, ∀ r, + (fun i : T => (![U₀, U₁] j) r i) ∈ projectedCode C T := by + by_contra! hn + exact hgood ⟨T, hT, hcomb, hn⟩ + have h₀ : ∀ r, ∃ p ∈ C, ∀ i ∈ T, p i = U₀ r i := + fun r => (mem_projectedCode C T _).mp (hrows 0 r) + have h₁ : ∀ r, ∃ p ∈ C, ∀ i ∈ T, p i = U₁ r i := + fun r => (mem_projectedCode C T _).mp (hrows 1 r) + choose p₀ hp₀ heq₀ using h₀ + choose p₁ hp₁ heq₁ using h₁ + let b : R → I → F := fun r => p₁ r - p₀ r + let P₀ : R → I → F := fun r => V r - z • b r + let P₁ : R → I → F := fun r => P₀ r + b r + have hb : ∀ r, b r ∈ C := fun r => C.sub_mem (hp₁ r) (hp₀ r) + have hP₀ : ∀ r, P₀ r ∈ C := fun r => C.sub_mem (hV r) (C.smul_mem z (hb r)) + refine ⟨P₀, P₁, fun r => ⟨hP₀ r, C.add_mem (hP₀ r) (hb r)⟩, ?_, ?_⟩ + · intro r i hi + dsimp [P₀, P₁, b] + rw [hagree r i hi, heq₀ r i hi, heq₁ r i hi] + constructor <;> ring + · intro r i + dsimp [P₀, P₁, b] + ring + +/-- Reed-Solomon words are evaluations of polynomials of degree below dimension. +Injectivity of the domain is needed for distance estimates, not for linearity. -/ +noncomputable def rsCode (domain : I → F) (dimension : ℕ) : Submodule F (I → F) := + (Polynomial.degreeLT F dimension).map + ({ toFun := fun p i => p.eval (domain i) + map_add' := by intros; ext; simp + map_smul' := by intros; ext; simp } : F[X] →ₗ[F] (I → F)) + +theorem mem_rsCode (domain : I → F) (dimension : ℕ) (w : I → F) : + w ∈ rsCode domain dimension ↔ + ∃ p : F[X], p.degree < dimension ∧ ∀ i, p.eval (domain i) = w i := by + change (∃ p, p ∈ Polynomial.degreeLT F dimension ∧ + (fun i => p.eval (domain i)) = w) ↔ _ + simp only [Polynomial.mem_degreeLT, funext_iff] + +open Classical in +/-- This is the same coefficient-table encoding used by CodingBounds, not +a separate polynomial-code model. It includes zero-dimensional tables. -/ +theorem mem_rsCode_iff_coefficients (domain : I → F) (dimension : ℕ) (w : I → F) : + w ∈ rsCode domain dimension ↔ + ∃ v : Fin dimension → F, ∀ i, (Polynomial.ofFn dimension v).eval (domain i) = w i := by + rw [mem_rsCode] + constructor + · rintro ⟨p, hp, hword⟩ + let v : Fin dimension → F := fun j => p.coeff j + have heq : Polynomial.ofFn dimension v = p := by + ext j + by_cases hj : j < dimension + · simp [Polynomial.ofFn_coeff_eq_val_of_lt v hj, v] + · have hge : dimension ≤ j := Nat.le_of_not_gt hj + rw [Polynomial.ofFn_coeff_eq_zero_of_ge v hge] + exact (Polynomial.coeff_eq_zero_of_degree_lt + (hp.trans_le (by exact_mod_cast hge))).symm + exact ⟨v, fun i => by rw [heq]; exact hword i⟩ + · rintro ⟨v, hword⟩ + exact ⟨Polynomial.ofFn dimension v, Polynomial.ofFn_degree_lt v, hword⟩ + +local instance : Fact (Nat.Prime 5) := ⟨by decide⟩ + +/-- An explicit positive-degree RS example separating ordinary correlated +agreement from same-set MCA. Over F₅ on {0,1,2}, both rows (0,0,1) and +(0,0,-1) agree with the zero linear polynomial on {0,1}. At fold challenge +3 their fold is zero everywhere, but neither row is a linear codeword on +the full set. Thus ordinary correlated agreement cannot replace the MCA +event, even when an ordinary common agreement set already exists. -/ +theorem ordinary_agreement_does_not_rule_out_mca : + let C := rsCode (fun i : Fin 3 => (i.val : ZMod 5)) 2 + let u : Fin 3 → ZMod 5 := ![0, 0, 1] + (∃ T : Finset (Fin 3), 2 ≤ T.card ∧ + (fun i : T => u i) ∈ projectedCode C T ∧ + (fun i : T => -u i) ∈ projectedCode C T) ∧ + Bad foldGenerator C 2 ![u, -u] 3 := by + classical + dsimp only + let C := rsCode (fun i : Fin 3 => (i.val : ZMod 5)) 2 + let u : Fin 3 → ZMod 5 := ![0, 0, 1] + have hnot : u ∉ C := by + intro hu + obtain ⟨p, hp, heval⟩ := (mem_rsCode _ _ _).mp hu + have hp0 : p.eval 0 = 0 := by simpa [u] using heval 0 + have hp1 : p.eval 1 = 0 := by simpa [u] using heval 1 + have hp2 : p.eval 2 = 1 := by simpa [u] using heval 2 + have hpne : p ≠ 0 := by intro hz; simp [hz] at hp2 + have hdegree : p.natDegree ≤ 1 := by + have hlt : p.natDegree < 2 := (Polynomial.natDegree_lt_iff_degree_lt hpne).mpr hp + omega + have hcount := Soundness.evaluation_agreement ({0, 1} : Finset (ZMod 5)) + p 0 hpne 1 hdegree (by simp) + norm_num [Finset.filter_insert, Finset.filter_singleton, hp0, hp1] at hcount + constructor + · refine ⟨{0, 1}, by decide, ?_, ?_⟩ + · apply (mem_projectedCode C _ u).mpr + refine ⟨0, C.zero_mem, ?_⟩ + intro i hi + simp only [Finset.mem_insert, Finset.mem_singleton] at hi + rcases hi with rfl | rfl <;> rfl + · apply (mem_projectedCode C _ (-u)).mpr + refine ⟨0, C.zero_mem, ?_⟩ + intro i hi + simp only [Finset.mem_insert, Finset.mem_singleton] at hi + rcases hi with rfl | rfl <;> simp [u] + · refine ⟨Finset.univ, by decide, ?_, 0, ?_⟩ + · have hz : (fun i : (Finset.univ : Finset (Fin 3)) => + ∑ j, foldGenerator (3 : ZMod 5) j * (![u, -u] j) i) = 0 := by + funext i + fin_cases i <;> norm_num [foldGenerator, Fin.sum_univ_two, u] + decide + rw [hz] + exact (projectedCode C _).zero_mem + · intro hm + obtain ⟨c, hc, heq⟩ := (mem_projectedCode C Finset.univ u).mp hm + apply hnot + have hcu : c = u := funext fun i => heq i (Finset.mem_univ _) + rwa [← hcu] + +/-- BCHKS25 Theorem 4.6 uses degree ratio, not message dimension divided by +length. This is the claimed numerator only, not an exceptional-set bound. +The meaningful theorem needs positive rate and positive Johnson slack. -/ +noncomputable def johnsonNumerator (length dimension : ℕ) (radius : ℝ) : ℝ := + let rate : ℝ := (dimension - 1 : ℕ) / length + let slack := 1 - Real.sqrt rate - radius + let m : ℕ := max ⌈Real.sqrt rate / slack⌉₊ 3 + let t : ℝ := m + 1 / 2 + ((2 * t ^ 5 + 3 * t * radius * rate) / (3 * Real.sqrt rate ^ 3)) * length + + t / Real.sqrt rate + +end Whir.MutualAgreement diff --git a/verification/whir/Whir/OODBounds.lean b/verification/whir/Whir/OODBounds.lean new file mode 100644 index 000000000..0f3f49d5c --- /dev/null +++ b/verification/whir/Whir/OODBounds.lean @@ -0,0 +1,217 @@ +import Whir.Algebra +import Whir.Soundness +import Whir.CodingBounds +import Mathlib.Algebra.MvPolynomial.SchwartzZippel +import Mathlib.Algebra.MvPolynomial.CommRing +import Mathlib.Data.Finset.Powerset + +/-! OOD separation for the existing `Whir.mle`, over a supplied finite field. +Candidate sets are fixed inputs, not functions of the sampled evaluation point. -/ +namespace Whir.OODBounds +open scoped BigOperators Classical +open MvPolynomial +variable {F : Type*} [Field F] + +/-- The existing multilinear extension evaluated symbolically. -/ +noncomputable def mlePolynomial {n : ℕ} (f : Cube n → F) : MvPolynomial (Fin n) F := + mle (fun u => C (f u)) X + +theorem eval_mlePolynomial {n : ℕ} (f : Cube n → F) (r : Fin n → F) : + eval r (mlePolynomial f) = mle f r := by + classical + simp [mlePolynomial, mle, innerProduct, eqWeight, map_sum, map_prod, apply_ite] + +theorem mlePolynomial_degree {n : ℕ} (f : Cube n → F) : + (mlePolynomial f).totalDegree ≤ n := by + classical + unfold mlePolynomial mle innerProduct + apply (totalDegree_finsetSum _ _).trans + apply Finset.sup_le + intro u _ + apply (totalDegree_mul _ _).trans + simp only [totalDegree_C, add_zero] + apply (totalDegree_finsetProd _ _).trans + calc + _ ≤ ∑ _i : Fin n, 1 := by + apply Finset.sum_le_sum + intro i _ + by_cases h : u i + · simp [h] + · simp only [h, Bool.false_eq_true, ↓reduceIte] + exact (totalDegree_sub _ _).trans (by simp) + _ = n := by simp + +theorem mlePolynomial_injective (n : ℕ) : + Function.Injective (mlePolynomial (F := F) (n := n)) := by + intro f g h + funext u + have he := congrArg (eval (fun i => if u i then 1 else 0)) h + simpa only [eval_mlePolynomial, mle_boolean] using he + +variable [Fintype F] [DecidableEq F] + +/-- Schwartz-Zippel for actual multilinear evaluations, including zero variables. -/ +theorem mle_collision_probability {n : ℕ} (f g : Cube n → F) (hne : f ≠ g) : + Soundness.uniformProb (Finset.univ.filter fun r => mle f r = mle g r) ≤ + (n : ℚ) / Fintype.card F := by + classical + have hp : mlePolynomial f - mlePolynomial g ≠ 0 := + sub_ne_zero.mpr (fun h => hne (mlePolynomial_injective n h)) + have hd : (mlePolynomial f - mlePolynomial g).totalDegree ≤ n := + (totalDegree_sub _ _).trans (max_le (mlePolynomial_degree f) (mlePolynomial_degree g)) + have hs := schwartz_zippel_totalDegree hp (Finset.univ : Finset F) + simp [eval_sub, eval_mlePolynomial, sub_eq_zero] at hs + have hs' : + ((Finset.univ.filter fun r => mle f r = mle g r).card : ℚ) / + (Fintype.card F : ℚ)^n ≤ + ((mlePolynomial f - mlePolynomial g).totalDegree : ℚ) / Fintype.card F := by + exact_mod_cast hs + unfold Soundness.uniformProb + simpa [Fintype.card_fun] using hs'.trans + (div_le_div_of_nonneg_right (by exact_mod_cast hd) (by positivity)) + +/-- Exact integer Schwartz-Zippel count, without division or a nonzero-dimension +side condition. -/ +theorem mle_collision_count {n : ℕ} (f g : Cube n → F) (hne : f ≠ g) : + (Finset.univ.filter fun r => mle f r = mle g r).card * Fintype.card F ≤ + n * Fintype.card (Fin n → F) := by + have h := mle_collision_probability f g hne + unfold Soundness.uniformProb at h + have hq : (0 : ℚ) < Fintype.card F := by exact_mod_cast Fintype.card_pos + have hr : (0 : ℚ) < Fintype.card (Fin n → F) := by exact_mod_cast Fintype.card_pos + exact_mod_cast (div_le_div_iff₀ hr hq).mp h + +/-- A fixed finite candidate list fails OOD separation with probability at most +`choose L 2 * n / |F|`; unordered pairs are charged once, not twice. -/ +theorem candidate_separation {n : ℕ} (list : Finset (Cube n → F)) : + Soundness.uniformProb (Finset.univ.filter fun r => + ∃ f ∈ list, ∃ g ∈ list, f ≠ g ∧ mle f r = mle g r) ≤ + (list.card.choose 2 : ℚ) * ((n : ℚ) / Fintype.card F) := by + classical + let events : ↥(list.powersetCard 2) → Finset (Fin n → F) := fun p => + Finset.univ.filter fun r => + ∃ f ∈ p.val, ∃ g ∈ p.val, f ≠ g ∧ mle f r = mle g r + have cover : (Finset.univ.filter fun r => + ∃ f ∈ list, ∃ g ∈ list, f ≠ g ∧ mle f r = mle g r) ⊆ + Finset.univ.biUnion events := by + intro r hr + obtain ⟨f, hf, g, hg, hne, he⟩ := (Finset.mem_filter.mp hr).2 + have hp : ({f, g} : Finset (Cube n → F)) ∈ list.powersetCard 2 := + Finset.mem_powersetCard.mpr ⟨by + intro a ha + rcases Finset.mem_insert.mp ha with rfl | ha + · exact hf + · exact (Finset.mem_singleton.mp ha) ▸ hg, + Finset.card_pair hne⟩ + exact Finset.mem_biUnion.mpr ⟨⟨{f, g}, hp⟩, Finset.mem_univ _, + Finset.mem_filter.mpr ⟨Finset.mem_univ _, f, by simp, g, by simp, hne, he⟩⟩ + have each (p : ↥(list.powersetCard 2)) : + Soundness.uniformProb (events p) ≤ (n : ℚ) / Fintype.card F := by + obtain ⟨f, g, hne, hp⟩ := + Finset.card_eq_two.mp (Finset.mem_powersetCard.mp p.property).2 + have he : events p = Finset.univ.filter (fun r => mle f r = mle g r) := by + ext r + simp only [events, hp, Finset.mem_filter, Finset.mem_univ, true_and, + Finset.mem_insert, Finset.mem_singleton] + constructor + · rintro ⟨a, ha, b, hb, hab, he⟩ + rcases ha with rfl | rfl <;> rcases hb with rfl | rfl <;> simp_all [eq_comm] + · intro h + exact ⟨f, Or.inl rfl, g, Or.inr rfl, hne, h⟩ + rw [he] + exact mle_collision_probability f g hne + calc + _ ≤ Soundness.uniformProb (Finset.univ.biUnion events) := by + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast Finset.card_le_card cover) + (by positivity) + _ ≤ ∑ p, Soundness.uniformProb (events p) := Soundness.union_bound events + _ ≤ ∑ _p : ↥(list.powersetCard 2), (n : ℚ) / Fintype.card F := + Finset.sum_le_sum fun p _ => each p + _ = _ := by simp [Finset.card_powersetCard] + +/-- Coefficient-table decoding preserves the candidate count when injective. -/ +theorem decoded_candidate_separation {M : Type*} {n : ℕ} (list : Finset M) + (decode : M → Cube n → F) (hinj : Function.Injective decode) : + Soundness.uniformProb (Finset.univ.filter fun r => + ∃ f ∈ list, ∃ g ∈ list, f ≠ g ∧ mle (decode f) r = mle (decode g) r) ≤ + (list.card.choose 2 : ℚ) * ((n : ℚ) / Fintype.card F) := by + classical + have h := candidate_separation (list.image decode) + have he : (Finset.univ.filter fun r => + ∃ f ∈ list.image decode, ∃ g ∈ list.image decode, + f ≠ g ∧ mle f r = mle g r) = + (Finset.univ.filter fun r => + ∃ f ∈ list, ∃ g ∈ list, f ≠ g ∧ mle (decode f) r = mle (decode g) r) := by + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_image] + constructor + · rintro ⟨_, ⟨f, hf, rfl⟩, _, ⟨g, hg, rfl⟩, hne, he⟩ + exact ⟨f, hf, g, hg, fun h => hne (congrArg decode h), he⟩ + · rintro ⟨f, hf, g, hg, hne, he⟩ + exact ⟨decode f, ⟨f, hf, rfl⟩, decode g, ⟨g, hg, rfl⟩, + fun h => hne (hinj h), he⟩ + rw [he, Finset.card_image_of_injective _ hinj] at h + exact h + +/-- A single commitment-fixed candidate construction simultaneously provides the +Johnson list bound and OOD separation. Neither strategies nor challenge tapes +are arguments to the candidate construction. -/ +theorem committed_candidates_bounds {M X A : Type*} [Fintype M] [Fintype X] + {n : ℕ} (encode : M → X → A) (oracle : X → A) (t d : ℕ) + (decode : M → Cube n → F) (hinj : Function.Injective decode) + (hd : d ≤ Fintype.card X) + (pairwise : ∀ i j, i ≠ j → + CodingBounds.agreement (encode i) (encode j) ≤ d) + (threshold : (Fintype.card X : ℚ) * d < (t : ℚ)^2) : + let list := CodingBounds.candidates encode oracle t + (list.card : ℚ) ≤ (Fintype.card X * (Fintype.card X - (d : ℚ))) / + ((t : ℚ)^2 - Fintype.card X * d) ∧ + Soundness.uniformProb (Finset.univ.filter fun r => + ∃ f ∈ list, ∃ g ∈ list, f ≠ g ∧ mle (decode f) r = mle (decode g) r) ≤ + (list.card.choose 2 : ℚ) * ((n : ℚ) / Fintype.card F) := by + classical + exact ⟨CodingBounds.candidates_card encode oracle t d hd pairwise threshold, + decoded_candidate_separation _ decode hinj⟩ + +/-- Reindex the actual coefficient table as a Boolean-cube message. The supplied +equivalence records the layout, rather than assuming decoding injective. -/ +def decodeCoefficients {n lanes k : ℕ} (index : Cube n ≃ (Fin lanes × Fin k)) + (v : Fin lanes → Fin k → F) : Cube n → F := + fun u => v (index u).1 (index u).2 + +omit [Field F] [Fintype F] [DecidableEq F] in +theorem decodeCoefficients_injective {n lanes k : ℕ} + (index : Cube n ≃ (Fin lanes × Fin k)) : + Function.Injective (decodeCoefficients (F := F) index) := by + intro u v h + funext j i + have he := congrFun h (index.symm (j, i)) + simpa [decodeCoefficients] using he + +/-- RS/interleaved PCS coding and OOD endpoint: both bounds follow from the +encoder, root bound, and existing MLE definitions. There are no incidence, +list-size, decoding-injectivity, or OOD hypotheses. -/ +theorem interleaved_committed_bounds {n lanes k : ℕ} + (index : Cube n ≃ (Fin lanes × Fin k)) + (domain : Finset F) (oracle : ↥domain → Fin lanes → F) (t : ℕ) + (hk : 0 < k) (hd : k - 1 ≤ domain.card) + (threshold : (domain.card : ℚ) * (k - 1 : ℕ) < (t : ℚ)^2) : + let list := CodingBounds.candidates + (fun v : Fin lanes → Fin k → F => + fun x : ↥domain => CodingBounds.interleavedEncode v x) oracle t + (list.card : ℚ) ≤ (domain.card * (domain.card - (k - 1 : ℕ) : ℚ)) / + ((t : ℚ)^2 - domain.card * (k - 1 : ℕ)) ∧ + Soundness.uniformProb (Finset.univ.filter fun r => + ∃ f ∈ list, ∃ g ∈ list, f ≠ g ∧ + mle (decodeCoefficients index f) r = mle (decodeCoefficients index g) r) ≤ + (list.card.choose 2 : ℚ) * ((n : ℚ) / Fintype.card F) := by + simpa using committed_candidates_bounds + (fun v : Fin lanes → Fin k → F => + fun x : ↥domain => CodingBounds.interleavedEncode v x) + oracle t (k - 1) (decodeCoefficients index) (decodeCoefficients_injective index) + (by simpa using hd) + (fun u v hne => CodingBounds.interleaved_domain_agreement domain u v hne hk) + (by simpa using threshold) + +end Whir.OODBounds diff --git a/verification/whir/Whir/OperationalRefinement.lean b/verification/whir/Whir/OperationalRefinement.lean new file mode 100644 index 000000000..6cb5d63a2 --- /dev/null +++ b/verification/whir/Whir/OperationalRefinement.lean @@ -0,0 +1,278 @@ +import Whir.ReplayRefinement + +/-! Operational refinement of the untrusted verifier. These are the kernels called +by `Protocol.verify`, not a second verifier or an honest transcript relation. +No field laws for `Concrete.E` are assumed. Ring interpretation of these very +fold/batch operations is provided separately by `ReplayRefinement`; transporting +it to the concrete field remains the field bridge's responsibility. -/ +namespace Whir.OperationalRefinement +open Concrete Protocol + +private theorem except_pure {S : Type*} (s : S) : + (pure s : Except String S) = .ok s := rfl + +private theorem except_bind_ok {S T : Type u} (s : S) (f : S → Except String T) : + (Except.ok s >>= f) = f s := rfl + +private theorem except_bind_error {S T : Type u} (e : String) (f : S → Except String T) : + (Except.error e >>= f) = .error e := rfl + +private theorem except_throw {S : Type*} (e : String) : + (throw e : Except String S) = .error e := rfl + +attribute [local simp] except_pure except_bind_ok except_bind_error except_throw + +/-- Indexed recursion has precisely the left-to-right list-fold meaning. -/ +theorem runSteps_eq_foldl {S : Type*} (step : Nat → S → S) + (count start : Nat) (s : S) : + runSteps step count start s = + (List.range' start count).foldl (fun s i => step i s) s := by + induction count generalizing start s with + | zero => simp [runSteps] + | succ count ih => simp [runSteps, List.range'_succ, ih] + +/-- Checked recursion has the same short-circuit/error order as monadic fold. -/ +theorem runChecked_eq_foldlM {S : Type*} (step : Nat → S → Except String S) + (count start : Nat) (s : S) : + runChecked step count start s = + (List.range' start count).foldlM (fun s i => step i s) s := by + induction count generalizing start s with + | zero => simp [runChecked] + | succ count ih => simp [runChecked, List.range'_succ, ih] + +/-- An invariant may depend on the exact next challenge index. Messages are +unrestricted; callers can use a lost-invariant or bad-event-conditioned predicate. -/ +theorem runSteps_invariant {S : Type*} (step : Nat → S → S) + (P : Nat → S → Prop) (count start : Nat) (s : S) + (initial : P start s) + (preserve : ∀ i t, start ≤ i → i < start + count → P i t → P (i+1) (step i t)) : + P (start + count) (runSteps step count start s) := by + induction count generalizing start s with + | zero => simpa [runSteps] using initial + | succ count ih => + simp only [runSteps] + have first := preserve start s (by omega) (by omega) initial + have rest := ih (start+1) (step start s) first (by + intro i t lo hi h + exact preserve i t (by omega) (by omega) h) + simpa [Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using rest + +/-- Successful checked execution preserves any index-dependent invariant for +which each successful actual transition has the required implication. -/ +theorem runChecked_invariant {S : Type*} (step : Nat → S → Except String S) + (P : Nat → S → Prop) (count start : Nat) (s finish : S) + (initial : P start s) + (preserve : ∀ i t u, start ≤ i → i < start + count → + P i t → step i t = .ok u → P (i+1) u) + (success : runChecked step count start s = .ok finish) : + P (start + count) finish := by + induction count generalizing start s with + | zero => + simp only [runChecked, Except.ok.injEq] at success + subst finish + simpa using initial + | succ count ih => + cases h : step start s with + | error e => simp [runChecked, h] at success + | ok next => + have first := preserve start s next (by omega) (by omega) initial h + have rest := ih (start+1) next first (by + intro i t u lo hi ht hu + exact preserve i t u (by omega) (by omega) ht hu) + (by simpa [runChecked, h] using success) + simpa [Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using rest + +/-- Successful checked executions expose every actual intermediate transition. -/ +inductive CheckedTrace {S : Type*} (step : Nat → S → Except String S) : + Nat → Nat → S → S → Prop + | done (start : Nat) (s : S) : CheckedTrace step 0 start s s + | next {count start : Nat} {s t finish : S} + (transition : step start s = .ok t) + (rest : CheckedTrace step count (start+1) t finish) : + CheckedTrace step (count+1) start s finish + +theorem runChecked_ok_iff_trace {S : Type*} (step : Nat → S → Except String S) + (count start : Nat) (s finish : S) : + runChecked step count start s = .ok finish ↔ + CheckedTrace step count start s finish := by + induction count generalizing start s with + | zero => + constructor + · intro h + simp only [runChecked, Except.ok.injEq] at h + subst finish + exact .done _ _ + · intro h + cases h + rfl + | succ count ih => + constructor + · intro h + cases hs : step start s with + | error e => simp [runChecked, hs] at h + | ok t => exact .next hs ((ih _ _).mp (by simpa [runChecked, hs] using h)) + · intro h + cases h with + | next transition rest => simpa [runChecked, transition] using (ih _ _).mpr rest + +/-- Exact concrete Boolean check, with no use of `CommRing E` or a field axiom. -/ +theorem checkClosing_ok_iff (ch : Challenges) (proof : Opening) (s : VerifierState E) : + checkClosing ch proof s = .ok () ↔ + s.checkTerminal (Concrete.mle proof.residual ch.tail) = true := by + cases h : s.checkTerminal (Concrete.mle proof.residual ch.tail) <;> simp [checkClosing, h] + +/-- Acceptance of arbitrary untrusted messages entails a successful trace of the +actual checked levels and the actual residual-MLE terminal comparison. -/ +theorem verify_ok_iff (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (b : Array E) (target : E) (proof : Opening) : + verify c ch lanes root b target proof = .ok () ↔ + ∃ initial finish, + initializeVerifier c ch lanes root b target proof = .ok initial ∧ + CheckedTrace (verifyLevel c ch proof) c.folds.size 0 initial finish ∧ + (closeTail ch proof finish.state).checkTerminal (Concrete.mle proof.residual ch.tail) = true := by + simp only [verify, replayLevels, ← runChecked_ok_iff_trace] + cases hi : initializeVerifier c ch lanes root b target proof with + | error e => simp + | ok initial => + cases hf : runChecked (verifyLevel c ch proof) c.folds.size 0 initial with + | error e => simp [hf] + | ok finish => simp [hf, checkClosing_ok_iff] + +/-- A false terminal comparison rejects through `verify` itself, not through a +standalone mathematical checker. Earlier failures remain their own errors. -/ +theorem verify_terminal_rejection (c : Config) (ch : Challenges) (lanes : Nat) + (root : Oracle) (b : Array E) (target : E) (proof : Opening) + (initial finish : CheckedState) + (hi : initializeVerifier c ch lanes root b target proof = .ok initial) + (hf : replayLevels c ch proof initial = .ok finish) + (bad : (closeTail ch proof finish.state).checkTerminal + (Concrete.mle proof.residual ch.tail) = false) : + verify c ch lanes root b target proof = .error "terminal mismatch" := by + simp [verify, hi, hf, checkClosing, bad] + +/-- The outer invariant rule applies directly to actual accepted openings. -/ +theorem accepted_levels_invariant (c : Config) (ch : Challenges) (lanes : Nat) + (root : Oracle) (b : Array E) (target : E) (proof : Opening) + (P : Nat → CheckedState → Prop) + (initial : ∀ s, initializeVerifier c ch lanes root b target proof = .ok s → P 0 s) + (preserve : ∀ i s t, i < c.folds.size → P i s → + verifyLevel c ch proof i s = .ok t → P (i+1) t) + (accepted : verify c ch lanes root b target proof = .ok ()) : + ∃ finish, P c.folds.size finish ∧ + (closeTail ch proof finish.state).checkTerminal (Concrete.mle proof.residual ch.tail) = true := by + obtain ⟨s, t, hi, trace, terminal⟩ := (verify_ok_iff c ch lanes root b target proof).mp accepted + refine ⟨t, ?_, terminal⟩ + simpa only [Nat.zero_add] using runChecked_invariant (verifyLevel c ch proof) P c.folds.size 0 s t (initial s hi) + (by intro i s t _ hi hs ht; exact preserve i s t (by omega) hs ht) + ((runChecked_ok_iff_trace _ _ _ _ _).mpr trace) + +/-- Fold-block induction uses the supplied next messages, never reconstructed +honest intros. The predicate can track both the remaining dimension and state. -/ +theorem foldBlock_invariant (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (P : Nat → CheckedState → Prop) (s : CheckedState) (initial : P 0 s) + (preserve : ∀ j t, j < cs.folds.size → P j t → P (j+1) (foldStep block cs p j t)) : + P cs.folds.size (foldBlock block cs p s) := by + simpa only [foldBlock, Nat.zero_add] using + runSteps_invariant (foldStep block cs p) P cs.folds.size 0 s initial + (by intro j t _ hi h; exact preserve j t (by omega) h) + +/-- OOD induction retains the precise running power of lambda in the state. -/ +theorem oodBatch_invariant (cs : LevelChallenges) (p : LevelProof) + (P : Nat → VerifierState E × E → Prop) (s : VerifierState E) + (initial : P 0 (s, E.one)) + (preserve : ∀ j t, j < p.oods.size → P j t → P (j+1) (oodStep cs p j t)) : + P p.oods.size (oodBatch cs p s) := by + simpa only [oodBatch, Nat.zero_add] using + runSteps_invariant (oodStep cs p) P p.oods.size 0 (s, E.one) initial + (by intro j t _ hi h; exact preserve j t (by omega) h) + +/-- Closing induction includes the final fold that deliberately retains the +unused pending message instead of reading an absent tail message. -/ +theorem closeTail_invariant (ch : Challenges) (proof : Opening) + (P : Nat → VerifierState E → Prop) (s : VerifierState E) (initial : P 0 s) + (preserve : ∀ j t, j < ch.tail.size → P j t → P (j+1) (tailStep ch proof j t)) : + P ch.tail.size (closeTail ch proof s) := by + simpa only [closeTail, Nat.zero_add] using + runSteps_invariant (tailStep ch proof) P ch.tail.size 0 s initial + (by intro j t _ hi h; exact preserve j t (by omega) h) + +/-- Checked unit loops accept exactly when every indexed check accepts. -/ +theorem runChecked_unit_ok_iff (step : Nat → Unit → Except String Unit) + (count start : Nat) : + runChecked step count start () = .ok () ↔ + ∀ j, start ≤ j → j < start + count → step j () = .ok () := by + induction count generalizing start with + | zero => + simp only [runChecked, Nat.add_zero, true_iff] + intro j lo hi + omega + | succ count ih => + cases h : step start () with + | error e => + simp only [runChecked, h, except_bind_error, reduceCtorEq, false_iff] + intro all + have := all start (by omega) (by omega) + simp [h] at this + | ok u => + cases u + simp only [runChecked, h, except_bind_ok, ih] + constructor + · intro all j lo hi + by_cases hj : j = start + · simpa [hj] using h + · exact all j (by omega) (by omega) + · intro all j lo hi + exact all j (by omega) (by omega) + +/-- Successful authentication entails the exact comparison used by the actual +verifier for every sampled row, including duplicate samples. -/ +theorem authentication_ok_iff (oracle : Oracle) (qs : Array Nat) (p : LevelProof) : + runChecked (authenticateRow oracle qs p) qs.size 0 () = .ok () ↔ + ∀ j, j < qs.size → (p.rows[j]! != oracle[qs[j]!]!) = false := by + rw [runChecked_unit_ok_iff] + simp only [Nat.zero_add, Nat.zero_le, forall_const] + apply forall_congr' + intro j + apply imp_congr_right + intro _ + cases h : (p.rows[j]! != oracle[qs[j]!]!) <;> simp [authenticateRow, h] + +private theorem bind_ok_iff {S T : Type u} (x : Except String S) + (f : S → Except String T) (t : T) : + (x >>= f) = .ok t ↔ ∃ s, x = .ok s ∧ f s = .ok t := by + cases x <;> simp + +/-- A successful actual level exposes authenticated queries and its exact +post-batching state. The fold messages and OOD/query intros remain unrestricted. -/ +theorem verifyLevel_success (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (s finish : CheckedState) + (success : verifyLevel c ch proof i s = .ok finish) : + let cs := ch.levels[i]! + let p := proof.levels[i]! + let folded := foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) cs p s + p.afterFold.size = cs.folds.size ∧ p.oods.size = cs.oodPoints.size ∧ + ∃ qs, deriveQueries (folded.n+c.rates[i]!) c.queries[i]! cs.querySqueezes = some qs ∧ + p.rows.size = qs.size ∧ + (∀ j, j < qs.size → (p.rows[j]! != folded.oracle[qs[j]!]!) = false) ∧ + finish = ⟨folded.n, queryBatch folded.n i cs p qs (oodBatch cs p folded.state), + p.nextOracle.getD #[]⟩ := by + dsimp + unfold verifyLevel at success + simp only [except_throw, except_bind_error, except_pure] at success + generalize hf : foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! s = folded at success ⊢ + cases hn : proof.levels[i]!.nextOracle <;> + cases hq : deriveQueries (folded.n+c.rates[i]!) c.queries[i]! + ch.levels[i]!.querySqueezes + all_goals + simp only [hn, hq, Option.elim, except_pure, except_bind_ok, + except_bind_error] at success + split_ifs at success <;> simp_all [bind_ok_iff] + all_goals + obtain ⟨⟨u, authenticated⟩, _⟩ := success + cases u + have auth := (authentication_ok_iff _ _ _).mp authenticated + intro j hj + simpa [*] using auth j hj + +end Whir.OperationalRefinement diff --git a/verification/whir/Whir/OracleReplay.lean b/verification/whir/Whir/OracleReplay.lean new file mode 100644 index 000000000..23e91a29a --- /dev/null +++ b/verification/whir/Whir/OracleReplay.lean @@ -0,0 +1,239 @@ +import Whir.InitialCandidates +import Whir.OperationalRefinement +import Whir.TerminalRefinement + +/-! Commitment-only oracle replay. Leaves are arbitrary: only their accepted +physical lengths are used. Initial leaves reverse their live prefix and pad +absent lanes with literal zeros; extension leaves retain their ordinary order. -/ +namespace Whir.OracleReplay +open Concrete Protocol ArrayLayout CandidateFolding + +/-- Ascending, full-width row; pruning never reverses the absent zero tail. -/ +def ascendingRow (base : Bool) (k : Nat) (raw : Array E) : Array E := + tab (2^k) fun lane => + if lane < raw.size then (if base then raw.reverse else raw)[lane]! else 0 + +@[simp] theorem ascendingRow_size (base : Bool) (k : Nat) (raw : Array E) : + (ascendingRow base k raw).size = 2^k := by simp [ascendingRow] + +/-- Actual challenge prefix, in chronological order, on an arbitrary row. -/ +def rowAt (folds : Array E) (a : Array E) (j : Nat) : Array E := + (List.range j).foldl (fun a i => foldLow a folds[i]!) a + +@[simp] theorem rowAt_zero (folds a : Array E) : rowAt folds a 0 = a := rfl + +@[simp] theorem rowAt_succ (folds a : Array E) (j : Nat) : + rowAt folds a (j+1) = foldLow (rowAt folds a j) folds[j]! := by + simp [rowAt, List.range_succ, List.foldl_append] + +theorem rowAt_size (folds a : Array E) (k j : Nat) + (shape : a.size = 2^k) (hj : j ≤ k) : + (rowAt folds a j).size = 2^(k-j) := by + induction j with + | zero => simpa using shape + | succ j ih => + rw [rowAt_succ, size_foldLow, ih (by omega)] + rw [show k-j = (k-(j+1))+1 by omega, pow_succ, + Nat.mul_div_left _ (by decide : 0 < 2)] + +/-- The matrix at round j; its Fin index states the exact remaining lane count. -/ +def oracleAt (base : Bool) (k : Nat) (root : Oracle) (folds : Array E) + (j : Nat) {N : Nat} : Fin (2^(k-j)) → Fin N → E := + fun lane q => (rowAt folds (ascendingRow base k root[q.val]!) j)[lane.val]! + +/-- Reindex the old matrix to adjacent pairs, without changing physical indices. -/ +def pairedOracle (base : Bool) (k : Nat) (root : Oracle) (folds : Array E) + (j : Nat) (hj : j < k) {N : Nat} : Fin (2^(k-(j+1))*2) → Fin N → E := + fun lane => oracleAt base k root folds j + ⟨lane.val, by + have h : 2^(k-j) = 2^(k-(j+1))*2 := by + rw [show k-j = (k-(j+1))+1 by omega, pow_succ] + omega⟩ + +/-- Exact actual-array recurrence, not an honest-codeword assumption. -/ +theorem oracleAt_succ (base : Bool) (k : Nat) (root : Oracle) (folds : Array E) + (j : Nat) (hj : j < k) {N : Nat} : + oracleAt base k root folds (j+1) (N := N) = + foldOracle (pairedOracle base k root folds j hj) folds[j]! := by + funext lane q + have hs := rowAt_size folds (ascendingRow base k root[q.val]!) k j + (ascendingRow_size _ _ _) (by omega) + have hp : 2^(k-j) = 2^(k-(j+1))*2 := by + rw [show k-j = (k-(j+1))+1 by omega, pow_succ] + have hl : lane.val < (rowAt folds (ascendingRow base k root[q.val]!) j).size / 2 := by + rw [hs, hp, Nat.mul_div_left _ (by decide : 0 < 2)] + exact lane.isLt + simp [oracleAt, rowAt_succ, foldLow, tab, getElem!_pos, hl, + foldOracle, pairedOracle, evenLane, oddLane, foldPair] + linear_combination folds[j]! * + CharTwo.add_self_eq_zero (rowAt folds (ascendingRow base k root[q.val]!) j)[2*lane.val]! + +theorem rowAt_terminal (folds a : Array E) (shape : a.size = 2^folds.size) : + rowAt folds a folds.size = #[dot a (eqTable folds)] := by + have mapped : (List.range folds.size).map (fun i => folds[i]!) = folds.toList := by + apply List.ext_getElem + · simp + · intro i hi hi' + simp only [List.getElem_map, List.getElem_range, Array.getElem_toList] + simp only [getElem!_pos folds i (by simpa using hi')] + rw [rowAt, ← List.foldl_map, mapped, Array.foldl_toList] + exact TerminalRefinement.foldLow_terminal a folds shape + +/-- Padding has no effect on the verifier's truncated dot product. -/ +theorem ascendingRow_dot (base : Bool) (k : Nat) (raw b : Array E) + (live : raw.size ≤ 2^k) (width : 2^k ≤ b.size) : + dot (ascendingRow base k raw) b = dot (if base then raw.reverse else raw) b := by + let f := fun lane => if lane < raw.size then + (if base then raw.reverse else raw)[lane]! else (0 : E) + have h := QueryRefinement.dot_tab_zero_tail (2^k) raw.size f b live width + (by intro i hi _; simp [f, Nat.not_lt.mpr hi]) + have he : tab raw.size f = (if base then raw.reverse else raw) := by + apply Array.ext + · cases base <;> simp + · intro i hi hi' + have hi0 : i < raw.size := by simpa using hi + cases base <;> simp [tab, f, hi0, getElem!_pos] + exact h.trans (congrArg (fun a => dot a b) he) + +/-- Literal expression shared with enforced and queryError. -/ +def postfoldWord (base : Bool) (root : Oracle) (folds : Array E) (q : Nat) : E := + dot (if base then root[q]!.reverse else root[q]!) (eqTable folds) + +/-- Every one-lane oracle entry is exactly the actual enforced scalar. -/ +theorem oracleAt_terminal (base : Bool) (root : Oracle) (folds : Array E) + {N : Nat} (q : Fin N) (live : root[q.val]!.size ≤ 2^folds.size) + (lane : Fin (2^(folds.size-folds.size))) : + oracleAt base folds.size root folds folds.size lane q = + postfoldWord base root folds q.val := by + have hl : lane.val = 0 := by simpa using lane.isLt + simp only [oracleAt, rowAt_terminal folds _ (ascendingRow_size _ _ _), hl] + simpa [postfoldWord] using ascendingRow_dot base folds.size root[q.val]! (eqTable folds) live + (by simp [TerminalRefinement.size_eqTable]) + +/-- Ordinary next-root leaves are already full ascending rows. -/ +theorem ascendingRow_extension (k : Nat) (raw : Array E) (shape : raw.size = 2^k) : + ascendingRow false k raw = raw := by + apply Array.ext + · simp [shape] + · intro i hi hi' + simp [ascendingRow, tab, hi', getElem!_pos] + +/-- Every candidate has the physical size used by the actual fold ladder. -/ +theorem candidate_size (base : Bool) (k n rate j threshold : Nat) + (root : Oracle) (folds : Array E) (a : Array E) + (ha : a ∈ arrayCandidates base (concreteEncoder n rate) + (oracleAt base k root folds j) threshold) : + a.size = 2^(n+(k-j)) := by + rw [arrayCandidates_size _ _ _ _ _ ha, ← Nat.pow_add, Nat.add_comm] + +/-- Exact paired shape for VerifierState.fold, in either physical layout. -/ +theorem candidate_round_shape (base : Bool) (k n rate j threshold : Nat) + (root : Oracle) (folds : Array E) (hj : j < k) (a : Array E) + (ha : a ∈ arrayCandidates base (concreteEncoder n rate) + (pairedOracle base k root folds j hj) threshold) : + a.size = ((if base then 2^(k-(j+1)) else 2^(k-(j+1))*2^n)*2) * + CandidateFolding.foldBlock base (2^n) := + arrayCandidates_round_shape _ _ _ _ _ ha + +/-- The accepted Boolean shape guard supplies each individual leaf's size. -/ +theorem oracleValid_row (root : Oracle) (rows width : Nat) + (valid : oracleValid root rows width = true) (q : Nat) (hq : q < rows) : + root[q]!.size = width := by + simp only [oracleValid, Bool.and_eq_true, beq_iff_eq, Array.all_eq_true] at valid + have hq' : q < root.size := by omega + simpa [getElem!_pos root q hq'] using valid.2 q hq' + +/-- Entrywise bridge from the commitment-only K list, including pruned lanes. -/ +theorem initial_fullRow (c : Config) (lanes : Nat) (root : CausalGame.BaseOracle) + (folds : Array E) (q : Fin (2^(c.logN-c.folds[0]!+c.rates[0]!))) + (hq : q.val < root.size) (shape : root[q.val]!.size = lanes) + (lane : Fin (2^c.folds[0]!)) : + oracleAt true c.folds[0]! (CausalGame.liftRoot root) folds 0 lane q = + E.ofK (InitialCandidates.fullRow c lanes root lane q) := by + have lift : (CausalGame.liftRoot root)[q.val]! = root[q.val]!.map E.ofK := by + simp [CausalGame.liftRoot, getElem!_pos, hq] + rw [InitialCandidates.fullRow_reverse c lanes root q shape lane] + simp only [oracleAt, rowAt_zero, ascendingRow, lift] + have hl : lane.val < 2^c.folds[0]! := lane.isLt + by_cases live : lane.val < lanes + · simp [tab, getElem!_pos, hl, shape, live, ← Array.map_reverse] + · simp [tab, getElem!_pos, hl, shape, live] + +/-- An accepted ordinary next commitment enters the next ladder in row order. -/ +theorem extension_root (k rows : Nat) (root : Oracle) (folds : Array E) + (valid : oracleValid root rows (2^k) = true) + (q : Fin rows) (lane : Fin (2^k)) : + oracleAt false k root folds 0 lane q = (root[q.val]!)[lane.val]! := by + simp only [oracleAt, rowAt_zero] + rw [ascendingRow_extension k _ (oracleValid_row root rows (2^k) valid q.val q.isLt)] + +/-- Authentication suffices for enforced, even when the query vector repeats +indices and the prover chose its rows after seeing the whole vector. -/ +theorem enforced_authenticated (base : Bool) (root : Oracle) (folds weights : Array E) + (qs : Array Nat) (rows : Array (Array E)) + (length : rows.size = qs.size) + (auth : ∀ j, j < qs.size → rows[j]! = root[qs[j]!]!) : + enforced rows folds weights base = + (tab qs.size fun j => weights[j]! * postfoldWord base root folds qs[j]!).foldl + (· + ·) 0 := by + dsimp only [enforced, postfoldWord] + apply congrArg (fun a : Array E => a.foldl (· + ·) 0) + apply Array.ext + · simp [length] + · intro j hj hj' + have h : j < qs.size := by simpa using hj' + simp only [tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + rw [auth j h] + +/-- The matrix dimensions coincide with the verifier's actual remaining n. -/ +theorem foldBlock_dimensions (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : CheckedState) (n k : Nat) (start : s.n = n+k) + (folds : cs.folds.size = k) : + (Protocol.foldBlock block cs p s).n = n := by + have h := OperationalRefinement.foldBlock_invariant block cs p + (fun j t => t.n = n+k-j) s (by simpa using start) + (by intro j t hj ht; simp only [foldStep, ht]; omega) + simpa [folds] using h + +/-- Reindexing the lane type changes neither physical arrays nor membership. -/ +theorem arrayCandidates_cast {lanes lanes' width N : Nat} (h : lanes' = lanes) + (base : Bool) (enc : (Fin width → E) →ₗ[E] (Fin N → E)) + (oracle : Fin lanes → Fin N → E) (threshold : Nat) : + arrayCandidates base enc (fun lane : Fin lanes' => oracle (Fin.cast h lane)) threshold = + arrayCandidates base enc oracle threshold := by + subst lanes' + rfl + +/-- The old list in the adjacent-pair recurrence is the same commitment-fixed +list as at the preceding prefix, not a separately selected candidate set. -/ +theorem paired_candidates (base : Bool) (k n rate j threshold : Nat) + (root : Oracle) (folds : Array E) (hj : j < k) : + arrayCandidates base (concreteEncoder n rate) + (pairedOracle base k root folds j hj) threshold = + arrayCandidates base (concreteEncoder n rate) + (oracleAt base k root folds j) threshold := by + have h : 2^(k-(j+1))*2 = 2^(k-j) := by + rw [show k-j = (k-(j+1))+1 by omega, pow_succ] + exact arrayCandidates_cast h base (concreteEncoder n rate) + (oracleAt base k root folds j) threshold + +/-- Actual verifier prefix dimensions, independently of every message, claim +and oracle value. This matches candidate_size at the same prefix. -/ +theorem foldBlock_prefix_shape (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : CheckedState) (n k j : Nat) (hj : j ≤ k) + (start : s.n = n+k) (weight : s.state.weight.size = 2^(n+k)) : + let t := runSteps (foldStep block cs p) j 0 s + t.n = n+(k-j) ∧ t.state.weight.size = 2^(n+(k-j)) := by + have h := OperationalRefinement.runSteps_invariant (foldStep block cs p) + (fun i t => t.n = n+(k-i) ∧ t.state.weight.size = 2^(n+(k-i))) + j 0 s (by simpa using And.intro start weight) ?_ + · simpa using h + · intro i t _ hi ht + have hi' : i < k := by omega + have hexp : n+(k-i) = (n+(k-(i+1)))+1 := by omega + constructor + · simp only [foldStep, ht.1]; omega + · simp only [foldStep, VerifierState.fold, ReplayRefinement.foldValues_eq_lane, + size_foldLane, ht.2, hexp, pow_succ, Nat.mul_div_left _ (by decide : 0 < 2)] + +end Whir.OracleReplay diff --git a/verification/whir/Whir/ParameterBounds.lean b/verification/whir/Whir/ParameterBounds.lean new file mode 100644 index 000000000..6f12e9fc2 --- /dev/null +++ b/verification/whir/Whir/ParameterBounds.lean @@ -0,0 +1,273 @@ +import Whir.GroupedChallenges +import Whir.CodingBounds +import Whir.FieldCardinality +import Whir.JohnsonListNumerics +import Whir.JohnsonNumerics + +/-! Exact, unground production-profile accounting. These deliberately conservative +bounds do not assert the source tests' floating-point 128-bit target. All 56 +profiles are read from `Protocol.productionConfig`; no table is copied here. + +The exact rational envelope gives query miss probability at most 2^-80, a +Johnson list cap 2^32, and the exact BCHKS25 numerator cap 2^108. The actual +`GroupedChallenges` ledger then gives grouped-message loss at most 2^-79 and +interactive loss at most 2^-73 for at most 2^64 initial claims. Ring switching, +authentication, Fiat–Shamir, and proof of work are not included in these totals. -/ +namespace Whir.ParameterBounds +open Whir.Protocol Whir.CausalGame Whir.GroupedChallenges +open scoped BigOperators + +/-- All 56 supported production configurations, without a copied source table. -/ +abbrev Profile := Fin 14 × Fin 4 + +def config (p : Profile) : Config := + (productionConfig (p.1.val + 15) (p.2.val + 1)).getD default + +/-- Rational upper envelope of the square root of the nominal rate. -/ +def upper (r : Nat) : ℚ := + (if r % 2 = 0 then 1 else 3 / 4) / 2 ^ (r / 2) + +def alpha (r : Nat) : ℚ := (129 / 128) * upper r + +def dimension (c : Config) (i : Nat) : Nat := 2 ^ remaining c i + +def length (c : Config) (i : Nat) : Nat := 2 ^ (remaining c i + c.rates[i]!) + +def rho (c : Config) (i : Nat) : ℚ := + (dimension c i - 1 : Nat) / (length c i : ℚ) + +/-- Arithmetic certificate; every conjunct is checked on the actual integer ladder. -/ +def LevelFacts (c : Config) (i : Nat) : Prop := + 0 < dimension c i - 1 ∧ dimension c i - 1 < length c i ∧ + length c i ≤ 2^26 ∧ (1 / 2^26 : ℚ) ≤ rho c i ∧ + rho c i ≤ (upper c.rates[i]!)^2 ∧ + 0 < upper c.rates[i]! ∧ 0 < alpha c.rates[i]! ∧ alpha c.rates[i]! < 1 ∧ + rho c i / 64 ≤ (alpha c.rates[i]!)^2 - rho c i ∧ + (alpha c.rates[i]!) ^ c.queries[i]! ≤ (1 / 2^80 : ℚ) + +instance (c : Config) (i : Nat) : Decidable (LevelFacts c i) := + inferInstanceAs (Decidable (_ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _)) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Kernel computation, not native evaluation or the floating-point source test. -/ +theorem production_level_facts : + ∀ p : Profile, ∀ i : Fin (config p).folds.size, LevelFacts (config p) i := by + decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_config_valid : ∀ p : Profile, + (config p).valid = true ∧ 0 < (config p).folds.size ∧ + (config p).folds.size ≤ 6 ∧ + (productionConfig (p.1.val + 15) (p.2.val + 1)).isSome = true := by + decide +kernel + +/-- Conservatively relaxed analytic estimates, attached to the actual rate array. -/ +def estimates (c : Config) : Estimates c := fun i => + ⟨2^32, 2^108, alpha c.rates[i.val]!⟩ + +/-- The challenge field cardinality is exact, not a security assumption. -/ +theorem field_cardinality : (Fintype.card Concrete.E : ℚ) = fieldSize := by + rw [FieldModel.card_E] + norm_num [fieldSize] + +/-- The initial powers-batch loss remains explicit in the number of claims. -/ +theorem initialBatch_le_claims (c : Config) (claims : Nat) : + initialBatch c (estimates c) claims ≤ (claims : ℚ) / 2^160 := by + unfold initialBatch + split_ifs + · simp only [estimates, fieldSize] + calc + _ ≤ (claims : ℚ) * (2^32 : Nat) / (2:ℚ)^192 := by + apply div_le_div_of_nonneg_right _ (by positivity) + apply mul_le_mul_of_nonneg_right _ (by positivity) + exact_mod_cast Nat.sub_le claims 1 + _ = _ := by norm_num; ring + · positivity + +theorem initialBatch_le (c : Config) (claims : Nat) (hclaims : claims ≤ 2^64) : + initialBatch c (estimates c) claims ≤ (1 / 2^96 : ℚ) := by + calc + _ ≤ (claims : ℚ) / 2^160 := initialBatch_le_claims c claims + _ ≤ (2^64 : ℚ) / 2^160 := by + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast hclaims + _ = _ := by norm_num + +def LevelLedgerFacts (c : Config) (i : Fin c.folds.size) : Prop := + foldError c (estimates c) i ≤ (1 / 2^83 : ℚ) ∧ + oodError c (estimates c) i ≤ (1 / 2^123 : ℚ) ∧ + queryBatchError c (estimates c) i ≤ (1 / 2^79 : ℚ) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_level_ledger : + ∀ p : Profile, ∀ i : Fin (config p).folds.size, LevelLedgerFacts (config p) i := by + unfold LevelLedgerFacts oodError + simp only [estimates, Nat.choose_two_right] + decide +kernel + +theorem initialBatch_mono (c : Config) {a b : Nat} (h : a ≤ b) : + initialBatch c (estimates c) a ≤ initialBatch c (estimates c) b := by + unfold initialBatch + split_ifs + · apply div_le_div_of_nonneg_right _ (by norm_num [fieldSize]) + apply mul_le_mul_of_nonneg_right _ (by norm_num [estimates]) + exact_mod_cast Nat.sub_le_sub_right h 1 + · exact le_rfl + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Whole interactive and grouped-message ledgers, before ring switching and +without subtracting any grinding budget. -/ +theorem production_ledger_at_claim_cap : ∀ p : Profile, + interactiveError (config p) (estimates (config p)) (2^64) ≤ (1 / 2^73 : ℚ) ∧ + groupedMaximum (config p) (estimates (config p)) (2^64) ≤ (1 / 2^79 : ℚ) := by + unfold interactiveError groupedMaximum oodError + simp only [estimates, Nat.choose_two_right] + decide +kernel + +theorem production_interactive (p : Profile) (claims : Nat) (hclaims : claims ≤ 2^64) : + interactiveError (config p) (estimates (config p)) claims ≤ (1 / 2^73 : ℚ) := by + apply le_trans _ (production_ledger_at_claim_cap p).1 + unfold interactiveError + exact add_le_add (add_le_add (initialBatch_mono _ hclaims) le_rfl) le_rfl + +theorem production_grouped (p : Profile) (claims : Nat) (hclaims : claims ≤ 2^64) : + groupedMaximum (config p) (estimates (config p)) claims ≤ (1 / 2^79 : ℚ) := by + apply le_trans _ (production_ledger_at_claim_cap p).2 + unfold groupedMaximum + exact max_le_max (initialBatch_mono _ hclaims) le_rfl + +/-- Each supplied in-range size/rate is represented in the finite family. -/ +theorem supported_config {logN rate : Nat} (hn : 15 ≤ logN ∧ logN ≤ 28) + (hr : 1 ≤ rate ∧ rate ≤ 4) : + ∃ p : Profile, p.1.val + 15 = logN ∧ p.2.val + 1 = rate ∧ + productionConfig logN rate = some (config p) := by + let p : Profile := (⟨logN - 15, by omega⟩, ⟨rate - 1, by omega⟩) + have hp : p.1.val + 15 = logN := by dsimp [p]; omega + have hq : p.2.val + 1 = rate := by dsimp [p]; omega + refine ⟨p, hp, hq, ?_⟩ + have h := (production_config_valid p).2.2.2 + rw [hp, hq] at h + cases hc : productionConfig logN rate with + | none => simp [hc] at h + | some c => simp [config, hp, hq, hc] + +/-- Rational envelope transfer: positive Johnson slack with multiplicity budget 128. -/ +theorem production_sqrt_envelope (p : Profile) (i : Fin (config p).folds.size) : + 0 < (rho (config p) i : ℝ) ∧ + (1 / 2^26 : ℝ) ≤ (rho (config p) i : ℝ) ∧ + (rho (config p) i : ℝ) < 1 ∧ + 0 < (alpha (config p).rates[i.val]! : ℝ) ∧ + (alpha (config p).rates[i.val]! : ℝ) < 1 ∧ + Real.sqrt (rho (config p) i : ℝ) ≤ + (128 / 129 : ℝ) * (alpha (config p).rates[i.val]! : ℝ) := by + obtain ⟨hd, hdn, hn, hr, hu, hup, ha, ha1, hgap, hq⟩ := production_level_facts p i + have hr' : (1 / 2^26 : ℝ) ≤ (rho (config p) i : ℝ) := by + simpa only [Rat.cast_div, Rat.cast_one, Rat.cast_pow, Rat.cast_ofNat] using + (Rat.cast_le (K := ℝ)).mpr hr + have hrp : 0 < (rho (config p) i : ℝ) := lt_of_lt_of_le (by norm_num) hr' + have hu' : (rho (config p) i : ℝ) ≤ (upper (config p).rates[i.val]! : ℝ)^2 := by + exact_mod_cast hu + have hup' : 0 < (upper (config p).rates[i.val]! : ℝ) := by exact_mod_cast hup + have ha' : 0 < (alpha (config p).rates[i.val]! : ℝ) := by exact_mod_cast ha + have ha1' : (alpha (config p).rates[i.val]! : ℝ) < 1 := by exact_mod_cast ha1 + have hscale : (alpha (config p).rates[i.val]! : ℝ) = + (129 / 128 : ℝ) * (upper (config p).rates[i.val]! : ℝ) := by + simp [alpha] + have hs : Real.sqrt (rho (config p) i : ℝ) ≤ + (upper (config p).rates[i.val]! : ℝ) := by + nlinarith [Real.sq_sqrt hrp.le, Real.sqrt_nonneg (rho (config p) i : ℝ)] + refine ⟨hrp, hr', ?_, ha', ha1', ?_⟩ + · nlinarith + · nlinarith + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- The adjacent powers-batch charge is inside, not outside, its grouped query +message. Subtracting the query miss term isolates the actual ledger summand. -/ +theorem production_adjacent_batch : ∀ p : Profile, ∀ i : Fin (config p).folds.size, + 0 ≤ queryBatchError (config p) (estimates (config p)) i - + (alpha (config p).rates[i.val]!) ^ (config p).queries[i.val]! ∧ + queryBatchError (config p) (estimates (config p)) i - + (alpha (config p).rates[i.val]!) ^ (config p).queries[i.val]! ≤ + (1 / 2^152 : ℚ) := by + decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_tail : ∀ p : Profile, + ((config p).logN - (config p).folds.toList.sum : Nat) * + (2 / fieldSize) ≤ (1 / 2^188 : ℚ) := by + decide +kernel + +def threshold (c : Config) (i : Nat) : Nat := + ⌈(length c i : ℚ) * alpha c.rates[i]!⌉₊ + +/-- Actual interleaved candidate lists on every production-sized domain obey the +relaxed list cap. The only domain premise identifies the encoder's block length. -/ +theorem production_candidates_card + {F : Type*} [Field F] [DecidableEq F] [Fintype F] {lanes : Nat} + (p : Profile) (i : Fin (config p).folds.size) + (domain : Finset F) (hdom : domain.card = length (config p) i) + (oracle : ↥domain → Fin lanes → F) : + (CodingBounds.candidates + (fun v : Fin lanes → Fin (dimension (config p) i) → F => + fun x : ↥domain => CodingBounds.interleavedEncode v x) + oracle (threshold (config p) i)).card ≤ 2^32 := by + obtain ⟨hd, hdn, hn, hr, hu, hup, ha, ha1, hgap, hq⟩ := production_level_facts p i + apply JohnsonListNumerics.interleaved_candidates_card_le_two_pow32 domain oracle + (threshold (config p) i) (by omega) (by omega) (by omega) + (rho (config p) i) (alpha (config p).rates[i.val]!) + · simp [rho, hdom] + · exact hr + · exact ha.le + · exact hgap + · rw [hdom] + exact Nat.le_ceil _ + +@[simp] theorem rho_cast (c : Config) (i : Nat) : + (rho c i : ℝ) = ((dimension c i - 1 : Nat) : ℝ) / length c i := by + simp [rho] + +def radius (c : Config) (i : Nat) : ℝ := 1 - (alpha c.rates[i]! : ℝ) + +/-- Positive radius strictly below the reduced-rate Johnson radius. -/ +theorem production_radius (p : Profile) (i : Fin (config p).folds.size) : + 0 < radius (config p) i ∧ + radius (config p) i < 1 - Real.sqrt (rho (config p) i : ℝ) := by + obtain ⟨hr, hrl, hru, ha, ha1, hgap⟩ := production_sqrt_envelope p i + unfold radius + constructor <;> nlinarith + +theorem production_multiplicity (p : Profile) (i : Fin (config p).folds.size) : + max ⌈Real.sqrt (rho (config p) i : ℝ) / + (1 - Real.sqrt (rho (config p) i : ℝ) - radius (config p) i)⌉₊ 3 ≤ 128 := by + obtain ⟨hr, hrl, hru, ha, ha1, hgap⟩ := production_sqrt_envelope p i + exact MutualAgreement.johnson_multiplicity_le_128 _ _ ha hgap + +/-- Instantiation of the exact, square-root/ceiling BCHKS25 expression. -/ +theorem production_johnsonNumerator (p : Profile) (i : Fin (config p).folds.size) : + MutualAgreement.johnsonNumerator (length (config p) i) (dimension (config p) i) + (radius (config p) i) ≤ (2 : ℝ)^108 := by + obtain ⟨hr, hrl, hru, ha, ha1, hgap⟩ := production_sqrt_envelope p i + simp only [rho_cast] at hr hrl hru hgap + exact MutualAgreement.johnsonNumerator_le_two_pow_108 _ _ _ hr hrl hru.le + (production_level_facts p i).2.2.1 ha ha1 hgap + +/-- The ledger result stated directly for the actual production constructor, +with only supported input ranges and the caller's claim-count limit. -/ +theorem supported_ledger {logN rate : Nat} {c : Config} + (hn : 15 ≤ logN ∧ logN ≤ 28) (hr : 1 ≤ rate ∧ rate ≤ 4) + (hc : productionConfig logN rate = some c) (claims : Nat) + (hclaims : claims ≤ 2^64) : + interactiveError c (estimates c) claims ≤ (1 / 2^73 : ℚ) ∧ + groupedMaximum c (estimates c) claims ≤ (1 / 2^79 : ℚ) := by + obtain ⟨p, hp, hq, hconfig⟩ := supported_config hn hr + have h : c = config p := Option.some.inj (hc.symm.trans hconfig) + subst c + exact ⟨production_interactive p claims hclaims, production_grouped p claims hclaims⟩ + +end Whir.ParameterBounds diff --git a/verification/whir/Whir/ProductionTransitions.lean b/verification/whir/Whir/ProductionTransitions.lean new file mode 100644 index 000000000..36ed7941d --- /dev/null +++ b/verification/whir/Whir/ProductionTransitions.lean @@ -0,0 +1,81 @@ +import Whir.FoldSoundness +import Whir.InitialSoundness +import Whir.ConcreteCandidates + +/-! Production numerical envelopes are applied to actual transition events, +not used as hypotheses standing in for the MCA or candidate-list theorem. -/ +namespace Whir.ProductionTransitions +open Concrete Protocol CausalGame CandidateFolding VerifierInvariant +open ParameterBounds GroupedChallenges + +/-- The rational threshold in the candidate list is exactly the real threshold +in the checked MCA provider. -/ +theorem threshold_real (c : Config) (i : Nat) : + threshold c i = ⌈(length c i : ℝ) * (1 - radius c i)⌉₊ := by + apply eq_of_forall_ge_iff + intro bound + simp only [threshold, Nat.ceil_le, radius, sub_sub_cancel] + constructor <;> intro h <;> exact_mod_cast h + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- These are the actual dimensions required by the MCA theorem, evaluated from +the production constructor, not an independently copied parameter table. -/ +theorem production_fold_facts : ∀ p : Profile, ∀ i : Fin (config p).folds.size, + remaining (config p) i + (config p).rates[i.val]! ≤ 64 ∧ + 1 ≤ dimension (config p) i - 1 ∧ + dimension (config p) i - 1 ≤ length (config p) i - 2 := by + decide +kernel + +open Classical in +/-- A fresh fold challenge loses the actual candidate invariant with at most the +production ledger's fold error. Every list/MCA/field prerequisite is discharged. -/ +theorem production_fold_escape (top : Bool) (p : Profile) (i : Fin (config p).folds.size) + {lanes : Nat} (oracle : Fin (lanes * 2) → + Fin (2 ^ (remaining (config p) i + (config p).rates[i.val]!)) → E) + (state : VerifierState E) (next : E → Message E) + (weightSize : state.weight.size = (lanes * 2) * dimension (config p) i) + (lost : Lost (arrayCandidates top + (concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) oracle + (threshold (config p) i)) state) : + Soundness.uniformProb (Finset.univ.filter fun r : E => + ¬ Lost (arrayCandidates top + (concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) + (foldOracle oracle r) (threshold (config p) i)) + (state.fold (CandidateFolding.foldBlock top (dimension (config p) i)) r (next r))) ≤ + foldError (config p) (estimates (config p)) i := by + classical + obtain ⟨depth, degree_pos, degree_bound⟩ := production_fold_facts p i + have johnson := (production_radius p i).2 + simp only [rho_cast, dimension, length, Nat.cast_pow, Nat.cast_ofNat] at johnson + have incoming : Lost (arrayCandidates top + (concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) oracle + ⌈((length (config p) i : Nat) : ℝ) * (1 - radius (config p) i)⌉₊) state := by + rw [← threshold_real] + exact lost + have result := FoldSoundness.concrete_fold_escape top (remaining (config p) i) + (config p).rates[i.val]! depth degree_pos degree_bound (radius (config p) i) + (production_radius p i).1.le johnson oracle state next weightSize incoming + dsimp only at result + have hthreshold := threshold_real (config p) i + dsimp only [length] at hthreshold + rw [← hthreshold] at result + have card : ((arrayCandidates top + (concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) oracle + (threshold (config p) i)).card : ℝ) ≤ 2 ^ 32 := by + exact_mod_cast ConcreteCandidates.production_arrayCandidates_card top p i oracle + have numerator := production_johnsonNumerator p i + have relaxed := result.trans (add_le_add + (mul_le_mul_of_nonneg_right card (by positivity)) + (div_le_div_of_nonneg_right numerator (by positivity))) + simp only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at relaxed + have rhs : (2 ^ 32 : ℝ) * (2 / 2 ^ 192) + 2 ^ 108 / 2 ^ 192 = + (2 * 2 ^ 32 + 2 ^ 108) / 2 ^ 192 := by ring + rw [rhs] at relaxed + change _ ≤ (2 * (2 ^ 32 : ℚ) + 2 ^ 108) / 2 ^ 192 + apply (Rat.cast_le (K := ℝ)).mp + simp only [Rat.cast_div, Rat.cast_add, Rat.cast_mul, Rat.cast_pow, Rat.cast_ofNat, dimension] + convert relaxed using 1 + congr 2 + +end Whir.ProductionTransitions diff --git a/verification/whir/Whir/Protocol.lean b/verification/whir/Whir/Protocol.lean index ac763bd54..94d14c2c6 100644 --- a/verification/whir/Whir/Protocol.lean +++ b/verification/whir/Whir/Protocol.lean @@ -161,9 +161,10 @@ def VerifierState.checkTerminal {R : Type u} [Mul R] [BEq R] [Inhabited R] (state : VerifierState R) (value : R) : Bool := state.claim == value * state.weight[0]! -def enforced (rows : Array (Array E)) (rs weights : Array E) (base : Bool) : E := +def enforced {R : Type u} [Zero R] [One R] [Add R] [Mul R] [Inhabited R] + (rows : Array (Array R)) (rs weights : Array R) (base : Bool) : R := let eq := eqTable rs - (tab rows.size fun i => weights[i]! * dot (if base then rows[i]!.reverse else rows[i]!) eq).foldl (· + ·) E.zero + (tab rows.size fun i => weights[i]! * dot (if base then rows[i]!.reverse else rows[i]!) eq).foldl (· + ·) 0 def shapeValid (c : Config) (lanes : Nat) (b : Array E) : Bool := c.valid && lanes > 0 && lanes ≤ 2^c.folds[0]! && b.size == 2^c.logN && @@ -225,47 +226,109 @@ def prove (c : Config) (ch : Challenges) (witness : Array K) (bInitial : Array E if j+1 < ch.tail.size then tailMessages := tailMessages.push (roundMessage f b) return (root, ⟨initial, levels, residual, tailMessages⟩) -/-- Untrusted opening verifier. No access to the original witness or prover state. -The dense weight is retained for clarity; production evaluates it succinctly. -/ -def verify (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) - (bInitial : Array E) (target : E) (proof : Opening) : Except String Unit := do +/-- Allocation-free indexed replay; indices increase from `start`. -/ +def runSteps {S : Type u} (step : Nat → S → S) : Nat → Nat → S → S + | 0, _, s => s + | count+1, start, s => runSteps step count (start+1) (step start s) + +/-- Checked replay stops at the first error, without executing later transitions. -/ +def runChecked {S : Type u} (step : Nat → S → Except String S) : + Nat → Nat → S → Except String S + | 0, _, s => .ok s + | count+1, start, s => do + let next ← step start s + runChecked step count (start+1) next + +structure CheckedState where + n : Nat + state : VerifierState E + oracle : Oracle + deriving Repr, Inhabited + +/-- One transmitted fold message, without any honesty requirement. -/ +def foldStep (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (j : Nat) (s : CheckedState) : CheckedState := + { s with n := s.n-1, state := s.state.fold block cs.folds[j]! p.afterFold[j]! } + +def foldBlock (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : CheckedState) : CheckedState := + runSteps (foldStep block cs p) cs.folds.size 0 s + +/-- The scalar is carried explicitly: the first OOD has coefficient lambda. -/ +def oodStep (cs : LevelChallenges) (p : LevelProof) + (j : Nat) (s : VerifierState E × E) : VerifierState E × E := + let scalar := s.2 * cs.lambda + let ood := p.oods[j]! + (s.1.batch (eqTable cs.oodPoints[j]!) ood.value scalar ood.intro, scalar) + +def oodBatch (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) : + VerifierState E × E := + runSteps (oodStep cs p) p.oods.size 0 (s, E.one) + +def queryBatch (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : VerifierState E × E) : VerifierState E := + let ws := powers cs.lambda qs.size + s.1.batch (induced n qs ws) (enforced p.rows cs.folds ws (i == 0)) + (s.2 * cs.lambda) p.intro + +def authenticateRow (oracle : Oracle) (qs : Array Nat) (p : LevelProof) + (j : Nat) (_ : Unit) : Except String Unit := do + if p.rows[j]! != oracle[qs[j]!]! then throw "authentication" + +/-- One actual checked level. All length and authentication checks precede batching; +the commitment/final-length check precedes query derivation, as in the wire schedule. -/ +def verifyLevel (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (s : CheckedState) : Except String CheckedState := do + let cs := ch.levels[i]! + let p := proof.levels[i]! + if p.afterFold.size != cs.folds.size || p.oods.size != cs.oodPoints.size then + throw "round/OOD length" + let s := foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) cs p s + if i+1 < c.folds.size then + let next ← p.nextOracle.elim (throw "missing commitment") pure + if !oracleValid next (2^(s.n-c.folds[i+1]!+c.rates[i+1]!)) (2^c.folds[i+1]!) then + throw "commitment shape" + else + if p.nextOracle.isSome || proof.residual.size != 2^s.n then throw "final length" + let qs ← (deriveQueries (s.n+c.rates[i]!) c.queries[i]! cs.querySqueezes).elim + (throw "query challenges") pure + if p.rows.size != qs.size then throw "query length" + let _ ← runChecked (authenticateRow s.oracle qs p) qs.size 0 () + let batched := queryBatch s.n i cs p qs (oodBatch cs p s.state) + return ⟨s.n, batched, p.nextOracle.getD #[]⟩ + +def initializeVerifier (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (bInitial : Array E) (target : E) (proof : Opening) : Except String CheckedState := do if !ch.valid c || !shapeValid c lanes bInitial then throw "configuration/challenges/weight" - let block := 2^(c.logN-c.folds[0]!) if !oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes then throw "root shape" - if proof.levels.size != c.folds.size || proof.tailMessages.size+1 != ch.tail.size then throw "proof length" - let mut n := c.logN - let mut state : VerifierState E := ⟨bInitial, target, proof.initial⟩ - let mut oracle := root - for i in [:c.folds.size] do - let cs := ch.levels[i]! - let p := proof.levels[i]! - if p.afterFold.size != cs.folds.size || p.oods.size != cs.oodPoints.size then throw "round/OOD length" - for j in [:cs.folds.size] do - state := state.fold (if i == 0 then block else 1) cs.folds[j]! p.afterFold[j]! - n := n-1 - if i+1 < c.folds.size then - let next ← p.nextOracle.elim (throw "missing commitment") pure - if !oracleValid next (2^(n-c.folds[i+1]!+c.rates[i+1]!)) (2^c.folds[i+1]!) then throw "commitment shape" - else - if p.nextOracle.isSome || proof.residual.size != 2^n then throw "final length" - let qs ← (deriveQueries (n+c.rates[i]!) c.queries[i]! cs.querySqueezes).elim (throw "query challenges") pure - if p.rows.size != qs.size then throw "query length" - for j in [:qs.size] do - if p.rows[j]! != oracle[qs[j]!]! then throw "authentication" - let ws := powers cs.lambda qs.size - let sum := enforced p.rows cs.folds ws (i == 0) - let mut scalar := E.one - for j in [:p.oods.size] do - scalar := scalar*cs.lambda - let ood := p.oods[j]! - state := state.batch (eqTable cs.oodPoints[j]!) ood.value scalar ood.intro - scalar := scalar*cs.lambda - state := state.batch (induced n qs ws) sum scalar p.intro - oracle := p.nextOracle.getD #[] - for j in [:ch.tail.size] do - let next := if j+1 < ch.tail.size then proof.tailMessages[j]! else state.message - state := state.fold 1 ch.tail[j]! next - if !state.checkTerminal (mle proof.residual ch.tail) then throw "terminal mismatch" + if proof.levels.size != c.folds.size || proof.tailMessages.size+1 != ch.tail.size then + throw "proof length" + return ⟨c.logN, ⟨bInitial, target, proof.initial⟩, root⟩ + +def replayLevels (c : Config) (ch : Challenges) (proof : Opening) + (s : CheckedState) : Except String CheckedState := + runChecked (verifyLevel c ch proof) c.folds.size 0 s + +def tailStep (ch : Challenges) (proof : Opening) (j : Nat) + (s : VerifierState E) : VerifierState E := + let next := if j+1 < ch.tail.size then proof.tailMessages[j]! else s.message + s.fold 1 ch.tail[j]! next + +def closeTail (ch : Challenges) (proof : Opening) (s : VerifierState E) : + VerifierState E := + runSteps (tailStep ch proof) ch.tail.size 0 s + +def checkClosing (ch : Challenges) (proof : Opening) (s : VerifierState E) : + Except String Unit := do + if !s.checkTerminal (mle proof.residual ch.tail) then throw "terminal mismatch" return () +/-- Untrusted opening verifier. The shared transitions consume arbitrary messages; +no access to a witness, honest-message constructor, or prover state is needed. -/ +def verify (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (bInitial : Array E) (target : E) (proof : Opening) : Except String Unit := do + let initial ← initializeVerifier c ch lanes root bInitial target proof + let final ← replayLevels c ch proof initial + checkClosing ch proof (closeTail ch proof final.state) + end Whir.Protocol diff --git a/verification/whir/Whir/PrunedMerkleProgram.lean b/verification/whir/Whir/PrunedMerkleProgram.lean new file mode 100644 index 000000000..2dbfe55fc --- /dev/null +++ b/verification/whir/Whir/PrunedMerkleProgram.lean @@ -0,0 +1,655 @@ +import Whir.PublicMerkleProgram +import Whir.MerkleTransport + +/-! Physical baseline octopus verification. Whole-hash requests below lower to +ordinary BLAKE2s compression requests, not a second hash oracle. Leaf rows are +checked/hashed one at a time; parent hashes precede the next adjacent group. +Rejected continuations therefore retain every primitive call already made. +No independent-path rehashing is performed. -/ +namespace Whir.PrunedMerkleProgram +open FiatShamirGame Concrete MerkleBinding MerkleLevels +open DuplexModeGame MerkleTransport + +/-- An internal syntax for sequencing whole-hash computations. Its only +interpreter into the physical game is `lower`, which expands every chunk. -/ +inductive HashProgram (R : Type) where + | done (result : R) + | hash (bytes : List Byte) (next : Digest32 → HashProgram R) + +namespace HashProgram +variable {R S : Type} + +def bind : HashProgram R → (R → HashProgram S) → HashProgram S + | .done r, next => next r + | .hash bytes next, after => .hash bytes (fun d => bind (next d) after) + +def map (f : R → S) (p : HashProgram R) : HashProgram S := bind p (.done ∘ f) + +def lower : HashProgram R → Program R + | .done r => .done r + | .hash bytes next => WHIRModeFinal.bind (PublicMerkleProgram.hash bytes) + (fun d => lower (next d)) + +def eval (H : Primitive) : HashProgram R → R + | .done r => r + | .hash bytes next => eval H (next (H bytes)) + +theorem eval_bind (H : Primitive) (p : HashProgram R) (next : R → HashProgram S) : + eval H (bind p next) = eval H (next (eval H p)) := by + induction p with + | done => rfl + | hash bytes next ih => exact ih (H bytes) + +theorem eval_map (H : Primitive) (f : R → S) (p : HashProgram R) : + eval H (map f p) = f (eval H p) := eval_bind H p _ + +theorem lower_real (C : PrimitiveOracle) (iv : Digest32) (p : HashProgram R) : + (runReal C iv (lower p)).view.result = eval (PublicMerkleLog.hash C) p := by + induction p with + | done => rfl + | hash bytes next ih => + rw [lower, PublicMerkleProgram.hash_bind_real_result] + exact ih _ + +/-- Exact chronological replay through arbitrary observed replies. -/ +def replay : HashProgram R → List Observation → Option (R × List Observation) + | .done r, trace => some (r,trace) + | .hash bytes next, trace => do + let (digest,rest) ← PublicMerkleProgram.replay bytes trace + replay (next digest) rest + +theorem lower_replay (p : HashProgram R) (trace : List Observation) (result : R) + (run : PublicMerkleProgram.Runs (lower p) trace result) (suffix : List Observation) : + replay p (trace ++ suffix) = some (result,suffix) := by + induction p generalizing trace result with + | done r => cases run; rfl + | hash bytes next ih => + obtain ⟨before,digest,after,he,hb,ha⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp run + subst trace + simp only [replay,List.append_assoc,PublicMerkleProgram.hash_replay hb] + exact ih digest after result ha + +/-- Whole-hash provenance is a chronological segmentation of the public +primitive trace, not a first/last-answer map or a consistency premise. -/ +inductive PublicRun : HashProgram R → List Observation → R → Prop where + | done (r : R) : PublicRun (.done r) [] r + | hash {bytes : List Byte} {next : Digest32 → HashProgram R} + {before after : List Observation} {digest : Digest32} {result : R} : + PublicMerkleProgram.Runs (PublicMerkleProgram.hash bytes) before digest → + PublicRun (next digest) after result → + PublicRun (.hash bytes next) (before ++ after) result + +theorem lower_runs_iff (p : HashProgram R) (trace : List Observation) (result : R) : + PublicMerkleProgram.Runs (lower p) trace result ↔ PublicRun p trace result := by + induction p generalizing trace result with + | done r => + constructor + · intro h; cases h; exact .done r + · intro h; cases h; exact .done r + | hash bytes next ih => + constructor + · intro h + obtain ⟨before,digest,after,he,hb,ha⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp h + subst trace + exact .hash hb ((ih digest after result).mp ha) + · intro h + cases h with + | hash hb ha => + exact (PublicMerkleProgram.Runs.bind_iff _ _).mpr + ⟨_,_,_,rfl,hb,(ih _ _ _).mpr ha⟩ + +theorem PublicRun.verification {p : HashProgram R} {trace : List Observation} {result : R} + (h : PublicRun p trace result) : + ∀ o ∈ trace, ∃ n, o.query = .primitive .verification n := by + induction h with + | done => simp + | hash hb _ ih => + intro o ho + rcases List.mem_append.mp ho with ho | ho + · exact (PublicMerkleProgram.hash_trace hb).2 o ho + · exact ih o ho + +/-- Real execution's whole-hash requests, in order, including rejecting prefixes. -/ +def calls (H : Primitive) : HashProgram R → List (List Byte) + | .done _ => [] + | .hash bytes next => bytes :: calls H (next (H bytes)) + +theorem bind_real_observations (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (next : R → Program S) : + (runReal C iv (WHIRModeFinal.bind p next)).view.observations = + (runReal C iv p).view.observations ++ + (runReal C iv (next (runReal C iv p).view.result)).view.observations := by + induction p with + | done => rfl + | ask q cont ih => + simpa only [WHIRModeFinal.bind,runReal,prepend,List.cons_append] using + congrArg (List.cons (⟨q,realAnswer C iv q⟩ : Observation)) (ih (realAnswer C iv q)) + +theorem real_observations (C : PrimitiveOracle) (iv : Digest32) (p : HashProgram R) : + (runReal C iv (lower p)).view.observations = + (calls (PublicMerkleLog.hash C) p).flatMap (fun bytes => + (PublicMerkleLog.plan C bytes).map (fun e => (⟨.primitive .verification e.1,e.2⟩ : Observation))) := by + induction p with + | done => rfl + | hash bytes next ih => + rw [lower, bind_real_observations, PublicMerkleProgram.hash_real_observations, + PublicMerkleProgram.hash_real_result, ih] + rfl + +/-- A compositional all-reply cost/return invariant. The postcondition is +proved by the program, never supplied as a decoder-correctness hypothesis. -/ +def Certified (budget : Nat) (post : R → Prop) : HashProgram R → Prop + | .done r => post r + | .hash bytes next => + (PublicMerkleLog.chunks bytes).length ≤ budget ∧ + ∀ d, Certified (budget - (PublicMerkleLog.chunks bytes).length) post (next d) + +theorem Certified.mono {p : HashProgram R} {a b : Nat} {P Q : R → Prop} + (h : Certified a P p) (budget : a ≤ b) (post : ∀ r, P r → Q r) : Certified b Q p := by + induction p generalizing a b with + | done r => exact post r h + | hash bytes next ih => + exact ⟨h.1.trans budget,fun d => ih d (h.2 d) (Nat.sub_le_sub_right budget _)⟩ + +theorem Certified.bind {p : HashProgram R} {next : R → HashProgram S} {a b : Nat} + {P : R → Prop} {Q : S → Prop} (before : Certified a P p) + (after : ∀ r, P r → Certified b Q (next r)) : Certified (a+b) Q (bind p next) := by + induction p generalizing a with + | done r => exact (after r before).mono (by omega) (fun _ h => h) + | hash bytes cont ih => + refine ⟨by have := before.1; omega,fun d => ?_⟩ + have h := ih d (before.2 d) + have he : a+b-(PublicMerkleLog.chunks bytes).length = + (a-(PublicMerkleLog.chunks bytes).length)+b := by have := before.1; omega + simpa only [he] using h + +theorem Certified.counts {p : HashProgram R} {budget : Nat} {post : R → Prop} + (h : Certified budget post p) : Counts budget (lower p) := by + induction p generalizing budget with + | done => trivial + | hash bytes next ih => + have hh := PublicMerkleProgram.hash_bind_counted bytes (fun d => lower (next d)) + (budget-(PublicMerkleLog.chunks bytes).length) (fun d => ih d (h.2 d)) + exact WHIRModeFinal.counts_mono hh (by have := h.1; omega) + +end HashProgram + +abbrev LevelResult := Option (Level Digest32 × Level Digest32 × List Digest32) +abbrev LevelsResult := Option (Level Digest32 × List (Level Digest32) × List Digest32) + +def pairBytes (left right : Digest32) : List Byte := List.ofFn (ByteCodec.pairBytes (left,right)) + +theorem pair_cost (left right : Digest32) : (PublicMerkleLog.chunks (pairBytes left right)).length = 1 := by + rw [PublicMerkleLog.chunks] + simp [pairBytes] + +def leafHashes (rowWords leafWords : Nat) : List (List K) → HashProgram (Option (List Digest32)) + | [] => .done (some []) + | row :: rows => + if row.length = rowWords then + .hash (ByteCodec.wordsBytes (leafImage 0 leafWords row)) fun digest => + (leafHashes rowWords leafWords rows).map (Option.map (digest :: ·)) + else .done none + +/-- Hash this adjacent group BEFORE executing the remaining groups. -/ +def emit (index : Nat) (left right : Digest32) (tail : HashProgram LevelResult) : HashProgram LevelResult := + .hash (pairBytes left right) fun digest => tail.map (Option.map fun (parents,known,rest) => + ((index/2,digest)::parents,(2*(index/2),left)::(2*(index/2)+1,right)::known,rest)) + +def foldLevel : Level Digest32 → List Digest32 → HashProgram LevelResult + | [], supplied => .done (some ([],[],supplied)) + | (i,d) :: nodes, supplied => + if i % 2 = 0 then + match nodes with + | (j,e) :: tail => + if j = i+1 then emit i d e (foldLevel tail supplied) + else match supplied with + | [] => .done none + | s::ss => emit i d s (foldLevel ((j,e)::tail) ss) + | [] => match supplied with + | [] => .done none + | s::ss => emit i d s (foldLevel [] ss) + else match supplied with + | [] => .done none + | s::ss => emit i s d (foldLevel nodes ss) +termination_by nodes => nodes.length + +def levels : Nat → Level Digest32 → List Digest32 → HashProgram LevelsResult + | 0, nodes, supplied => .done (some (nodes,[],supplied)) + | n+1, nodes, supplied => (foldLevel nodes supplied).bind fun result => + match result with + | none => .done none + | some (parents,known,rest) => (levels n parents rest).map (Option.map fun (final,ls,tail) => + (final,known::ls,tail)) + +def finish (root : Digest32) (queries : List Nat) (leafWords : Nat) + (table : Level (List K)) (result : LevelsResult) : Option (List RawPath) := do + let (final,known,rest) ← result + if rest ≠ [] then none + else do + let (_,computed) ← final.head? + if computed ≠ root then none + else do + let distinct ← distinctPaths leafWords known table + collect (fun q => MerkleLevels.binaryLookup q distinct) queries + +/-- Source order differs from the pure model's equivalent early guards: +`leaf_hashes` may emit a valid prefix before a wrong-width row, and every leaf +is hashed before the sorted-last out-of-range test. -/ +def plan (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : HashProgram (Option (List RawPath)) := + if numLeaves = 0 ∨ 2 ^ numLeaves.log2 ≠ numLeaves ∨ queries = [] then .done none + else if (sortedUnique queries).length ≠ proof.leafData.length ∨ rowWords > leafWords then .done none + else (leafHashes rowWords leafWords proof.leafData).bind fun hashes => + match hashes with + | none => .done none + | some hashes => + if ∃ q ∈ queries, numLeaves ≤ q then .done none + else (levels numLeaves.log2 ((sortedUnique queries).zip hashes) proof.siblingHashes).map + (finish root queries leafWords (leafTable queries proof.leafData)) + +def verify (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : Program (Option (List RawPath)) := + (plan proof root numLeaves queries rowWords leafWords).lower + +theorem leafHashes_eval (H : Primitive) (rowWords leafWords : Nat) (rows : List (List K)) : + (leafHashes rowWords leafWords rows).eval H = + if ∀ row ∈ rows, row.length = rowWords then + some (rows.map fun row => H (ByteCodec.wordsBytes (leafImage 0 leafWords row))) else none := by + induction rows with + | nil => simp [leafHashes,HashProgram.eval] + | cons row rows ih => + by_cases hw : row.length = rowWords + · simp [leafHashes,hw,HashProgram.eval,HashProgram.eval_map,ih] + · simp [leafHashes,hw,HashProgram.eval] + +theorem emit_eval (H : Primitive) (i : Nat) (left right : Digest32) (tail : HashProgram LevelResult) : + (emit i left right tail).eval H = + MerkleLevels.emit (fun p => H (List.ofFn (ByteCodec.pairBytes p))) i left right (tail.eval H) := by + simp [emit,HashProgram.eval,HashProgram.eval_map,MerkleLevels.emit,pairBytes] + +theorem foldLevel_eval (H : Primitive) (nodes : Level Digest32) (supplied : List Digest32) : + (foldLevel nodes supplied).eval H = + MerkleLevels.foldLevel (fun p => H (List.ofFn (ByteCodec.pairBytes p))) nodes supplied := by + induction nodes using (measure List.length).wf.induction generalizing supplied with + | _ nodes ih => + cases nodes with + | nil => simp [foldLevel,MerkleLevels.foldLevel,HashProgram.eval] + | cons x nodes => + rcases x with ⟨i,d⟩ + rw [foldLevel.eq_def,MerkleLevels.foldLevel.eq_def] + dsimp only + split + · cases nodes with + | nil => cases supplied <;> simp [HashProgram.eval,emit_eval, + ih [] (by change 0 < 1; omega)] + | cons y tail => + rcases y with ⟨j,e⟩ + dsimp only + split + · rw [emit_eval,ih tail (by change tail.length < tail.length+1+1; omega)] + · cases supplied with + | nil => rfl + | cons s ss => + rw [emit_eval,ih ((j,e)::tail) (by change tail.length+1 < tail.length+1+1; omega)] + · cases supplied with + | nil => rfl + | cons s ss => rw [emit_eval,ih nodes (by change nodes.length < nodes.length+1; omega)] + +theorem levels_eval (H : Primitive) (n : Nat) (nodes : Level Digest32) (supplied : List Digest32) : + (levels n nodes supplied).eval H = + runLevels (fun p => H (List.ofFn (ByteCodec.pairBytes p))) n nodes supplied := by + induction n generalizing nodes supplied with + | zero => rfl + | succ n ih => + simp only [levels,HashProgram.eval_bind,foldLevel_eval,runLevels] + cases hf : MerkleLevels.foldLevel (fun p => H (List.ofFn (ByteCodec.pairBytes p))) nodes supplied with + | none => rfl + | some triple => + rcases triple with ⟨parents,known,rest⟩ + simp [HashProgram.eval_map,ih,Option.map_eq_bind] + +theorem zip_hashes (H : Primitive) (leafWords : Nat) (indices : List Nat) (rows : List (List K)) : + indices.zip (rows.map fun row => H (ByteCodec.wordsBytes (leafImage 0 leafWords row))) = + leafNodes H leafWords (indices.zip rows) := by + induction indices generalizing rows with + | nil => simp [leafNodes] + | cons i indices ih => + cases rows with + | nil => simp [leafNodes] + | cons row rows => + simpa [leafNodes] using congrArg (List.cons (i,H (ByteCodec.wordsBytes (leafImage 0 leafWords row)))) + (ih rows) + +theorem plan_eval (H : Primitive) (proof : PrunedMerklePaths) (root : Digest32) + (numLeaves : Nat) (queries : List Nat) (rowWords leafWords : Nat) : + (plan proof root numLeaves queries rowWords leafWords).eval H = + proof.open H root numLeaves queries rowWords leafWords := by + by_cases hs : numLeaves = 0 ∨ 2 ^ numLeaves.log2 ≠ numLeaves ∨ queries = [] + · simp [plan,PrunedMerklePaths.open,hs,HashProgram.eval] + by_cases hc : (sortedUnique queries).length ≠ proof.leafData.length ∨ rowWords > leafWords + · simp [plan,PrunedMerklePaths.open,hs,hc,HashProgram.eval] + simp only [plan,PrunedMerklePaths.open,ite_eq_right hs,ite_eq_right hc,HashProgram.eval_bind,leafHashes_eval] + by_cases hw : ∀ row ∈ proof.leafData, row.length = rowWords + · simp only [ite_eq_left hw,ite_eq_right (not_not_intro hw)] + by_cases hr : ∃ q ∈ queries, numLeaves ≤ q + · simp only [ite_eq_left hr,HashProgram.eval] + · simp only [ite_eq_right hr,HashProgram.eval_map,levels_eval,zip_hashes] + rfl + · simp only [ite_eq_right hw,ite_eq_left hw,HashProgram.eval] + +theorem verify_real_result (C : PrimitiveOracle) (iv : Digest32) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : + (runReal C iv (verify proof root numLeaves queries rowWords leafWords)).view.result = + proof.open (PublicMerkleLog.hash C) root numLeaves queries rowWords leafWords := by + rw [verify,HashProgram.lower_real,plan_eval] + +theorem verify_replay (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (trace suffix : List Observation) + (result : Option (List RawPath)) + (run : PublicMerkleProgram.Runs (verify proof root numLeaves queries rowWords leafWords) trace result) : + (plan proof root numLeaves queries rowWords leafWords).replay (trace ++ suffix) = some (result,suffix) := + HashProgram.lower_replay _ trace result run suffix + +theorem verify_real_observations (C : PrimitiveOracle) (iv : Digest32) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : + (runReal C iv (verify proof root numLeaves queries rowWords leafWords)).view.observations = + ((plan proof root numLeaves queries rowWords leafWords).calls (PublicMerkleLog.hash C)).flatMap + (fun bytes => (PublicMerkleLog.plan C bytes).map + (fun e => (⟨.primitive .verification e.1,e.2⟩ : Observation))) := + HashProgram.real_observations C iv _ + +theorem HashProgram.Certified.map {R S : Type} {p : HashProgram R} {budget : Nat} + {P : R → Prop} {Q : S → Prop} (h : HashProgram.Certified budget P p) + (f : R → S) (post : ∀ r, P r → Q (f r)) : + HashProgram.Certified budget Q (p.map f) := by + have hb := h.bind (b := 0) (next := fun r => .done (f r)) + (fun r hr => show HashProgram.Certified 0 Q (.done (f r)) from post r hr) + simpa only [Nat.add_zero,HashProgram.map,Function.comp_def] using hb + +def leafBudget (leafWords : Nat) (rows : List (List K)) : Nat := + (rows.map fun row => (PublicMerkleLog.chunks (ByteCodec.wordsBytes (leafImage 0 leafWords row))).length).sum + +def Sized {A B : Type} (bound : Nat) (result : Option (List A × B)) : Prop := + ∀ value, result = some value → value.1.length ≤ bound + +theorem Sized.mono {A B : Type} {a b : Nat} {result : Option (List A × B)} + (h : Sized a result) (bound : a ≤ b) : Sized b result := + fun value hv => (h value hv).trans bound + +theorem leafHashes_certified (rowWords leafWords : Nat) (rows : List (List K)) : + HashProgram.Certified (leafBudget leafWords rows) + (fun result => ∀ hashes, result = some hashes → hashes.length = rows.length) + (leafHashes rowWords leafWords rows) := by + induction rows with + | nil => simp [leafBudget,leafHashes,HashProgram.Certified] + | cons row rows ih => + by_cases hw : row.length = rowWords + · simp only [leafHashes,hw,↓reduceIte,HashProgram.Certified,leafBudget,List.map_cons,List.sum_cons] + refine ⟨by omega,fun digest => ?_⟩ + have h := ih.map (Q := fun result => ∀ hashes, result = some hashes → hashes.length = (row::rows).length) + (Option.map (digest :: ·)) (by + intro result hr hashes he + cases result with + | none => simp at he + | some tail => + simp only [Option.map_some,Option.some.injEq] at he + subst hashes + simp [hr tail rfl]) + simpa [leafBudget] using h + · simp [leafHashes,hw,HashProgram.Certified] + +theorem emit_certified (i : Nat) (left right : Digest32) + (tail : HashProgram LevelResult) (budget bound : Nat) + (h : HashProgram.Certified budget (Sized bound) tail) : + HashProgram.Certified (budget+1) (Sized (bound+1)) (emit i left right tail) := by + simp only [emit,HashProgram.Certified,pair_cost] + refine ⟨by omega,fun digest => ?_⟩ + have hm := h.map (Q := Sized (bound+1)) (Option.map fun (parents,known,rest) => + ((i/2,digest)::parents,(2*(i/2),left)::(2*(i/2)+1,right)::known,rest)) (by + intro result hr value he + cases result with + | none => simp at he + | some triple => + rcases triple with ⟨parents,known,rest⟩ + simp only [Option.map_some,Option.some.injEq] at he + subst value + have hb := hr (parents,known,rest) rfl + change parents.length ≤ bound at hb + simp only [List.length_cons] + omega) + simpa using hm + +theorem foldLevel_certified (nodes : Level Digest32) (supplied : List Digest32) : + HashProgram.Certified nodes.length (Sized nodes.length) (foldLevel nodes supplied) := by + induction nodes using (measure List.length).wf.induction generalizing supplied with + | _ nodes ih => + cases nodes with + | nil => simp [foldLevel,HashProgram.Certified,Sized] + | cons x nodes => + rcases x with ⟨i,d⟩ + rw [foldLevel.eq_def] + dsimp only + split + · cases nodes with + | nil => + cases supplied with + | nil => simp [HashProgram.Certified,Sized] + | cons s ss => exact emit_certified i d s _ 0 0 (ih [] (by change 0<1; omega) ss) + | cons y tail => + rcases y with ⟨j,e⟩ + dsimp only + split + · have h := emit_certified i d e _ tail.length tail.length + (ih tail (by change tail.length < tail.length+1+1; omega) supplied) + exact h.mono (by simp) (fun _ hr => hr.mono (by simp)) + · cases supplied with + | nil => simp [HashProgram.Certified,Sized] + | cons s ss => + exact emit_certified i d s _ _ _ + (ih ((j,e)::tail) (by change tail.length+1 < tail.length+1+1; omega) ss) + · cases supplied with + | nil => simp [HashProgram.Certified,Sized] + | cons s ss => + exact emit_certified i s d _ _ _ (ih nodes (by change nodes.length < nodes.length+1; omega) ss) + +theorem levels_certified (n : Nat) (nodes : Level Digest32) (supplied : List Digest32) : + HashProgram.Certified (n * nodes.length) (Sized nodes.length) (levels n nodes supplied) := by + induction n generalizing nodes supplied with + | zero => simp [levels,HashProgram.Certified,Sized] + | succ n ih => + rw [levels,Nat.succ_mul,Nat.add_comm] + apply (foldLevel_certified nodes supplied).bind (b := n*nodes.length) + intro result hr + cases result with + | none => simp [HashProgram.Certified,Sized] + | some triple => + rcases triple with ⟨parents,known,rest⟩ + have hp := hr (parents,known,rest) rfl + have hm := (ih parents rest).map (Q := Sized nodes.length) + (Option.map fun (final,ls,tail) => (final,known::ls,tail)) (by + intro result hs value he + cases result with + | none => simp at he + | some v => + simp only [Option.map_some,Option.some.injEq] at he + subst value + exact (hs v rfl).trans hp) + exact hm.mono (Nat.mul_le_mul_left n hp) (fun _ hs => hs) + +/-- Full uncached cost: every declared leaf image's chunk count plus at most +one 64-byte parent compression per active node per level. This bound covers +every reply and rejected continuation, not merely successful paths. -/ +def budget (proof : PrunedMerklePaths) (numLeaves leafWords : Nat) : Nat := + leafBudget leafWords proof.leafData + numLeaves.log2 * proof.leafData.length + +theorem plan_certified (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : + HashProgram.Certified (budget proof numLeaves leafWords) (fun _ => True) + (plan proof root numLeaves queries rowWords leafWords) := by + unfold plan budget + split + · trivial + · split + · trivial + · apply (leafHashes_certified rowWords leafWords proof.leafData).bind + (b := numLeaves.log2 * proof.leafData.length) + intro hashes hh + cases hashes with + | none => trivial + | some hashes => + dsimp only + split + · trivial + · have hlen := hh hashes rfl + have h := (levels_certified numLeaves.log2 ((sortedUnique queries).zip hashes) + proof.siblingHashes).map (Q := fun _ => True) + (finish root queries leafWords (leafTable queries proof.leafData)) + (fun _ _ => True.intro) + exact h.mono (Nat.mul_le_mul_left numLeaves.log2 + (by simpa only [List.length_zip,hlen] using Nat.min_le_right (sortedUnique queries).length proof.leafData.length)) + (fun _ _ => True.intro) + +theorem verify_counted (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : + Counts (budget proof numLeaves leafWords) (verify proof root numLeaves queries rowWords leafWords) := + (plan_certified proof root numLeaves queries rowWords leafWords).counts + +theorem verify_ideal_replay {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (verify proof root numLeaves queries rowWords leafWords)) + (suffix : List Observation) : + (plan proof root numLeaves queries rowWords leafWords).replay + ((runIdeal sim ro iv state _ remaining cap counted).view.observations ++ suffix) = + some ((runIdeal sim ro iv state _ remaining cap counted).view.result,suffix) := + verify_replay proof root numLeaves queries rowWords leafWords _ suffix _ + (PublicMerkleProgram.runIdeal_runs sim ro iv state _ remaining cap counted) + +theorem verify_public_run (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (trace : List Observation) + (result : Option (List RawPath)) + (run : PublicMerkleProgram.Runs (verify proof root numLeaves queries rowWords leafWords) trace result) : + HashProgram.PublicRun (plan proof root numLeaves queries rowWords leafWords) trace result := + (HashProgram.lower_runs_iff _ trace result).mp run + +theorem verify_verification_queries (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (trace : List Observation) + (result : Option (List RawPath)) + (run : PublicMerkleProgram.Runs (verify proof root numLeaves queries rowWords leafWords) trace result) : + ∀ o ∈ trace, ∃ node, o.query = .primitive .verification node := + (verify_public_run proof root numLeaves queries rowWords leafWords trace result run).verification + +theorem chunks_length_congr (a b : List Byte) (same : a.length = b.length) : + (PublicMerkleLog.chunks a).length = (PublicMerkleLog.chunks b).length := by + induction a using (measure List.length).wf.induction generalizing b with + | _ a ih => + conv_lhs => rw [PublicMerkleLog.chunks] + conv_rhs => rw [PublicMerkleLog.chunks] + by_cases small : a.length ≤ 64 + · simp only [ite_eq_left small,ite_eq_left (show b.length ≤ 64 by omega),List.length_cons,List.length_nil] + · simp only [ite_eq_right small,ite_eq_right (show ¬ b.length ≤ 64 by omega),List.length_cons] + rw [ih (a.drop 64) (by change (a.drop 64).length < a.length; simp; omega) + (b.drop 64) (by simp [List.length_drop,same])] + +theorem wordsBytes_length (words : List K) : (ByteCodec.wordsBytes words).length = words.length * 8 := by + induction words with + | nil => rfl + | cons word words ih => + simp only [ByteCodec.wordsBytes,List.flatMap_cons,List.length_append,List.length_ofFn] + change 8 + (ByteCodec.wordsBytes words).length = (words.length+1)*8 + rw [ih] + omega + +def leafChunkCost (leafWords : Nat) : Nat := + (PublicMerkleLog.chunks (List.replicate (8*leafWords) (0 : Byte))).length + +theorem leaf_chunk_cost (leafWords : Nat) (row : List K) (fits : row.length ≤ leafWords) : + (PublicMerkleLog.chunks (ByteCodec.wordsBytes (leafImage 0 leafWords row))).length = leafChunkCost leafWords := by + apply chunks_length_congr + rw [wordsBytes_length,leafImage_length 0 leafWords row fits,List.length_replicate] + omega + +theorem leafHashes_certified_uniform (rowWords leafWords : Nat) (rows : List (List K)) + (fits : rowWords ≤ leafWords) : + HashProgram.Certified (rows.length * leafChunkCost leafWords) + (fun result => ∀ hashes, result = some hashes → hashes.length = rows.length) + (leafHashes rowWords leafWords rows) := by + induction rows with + | nil => simp [leafHashes,HashProgram.Certified] + | cons row rows ih => + by_cases hw : row.length = rowWords + · simp only [leafHashes,hw,↓reduceIte,HashProgram.Certified, + leaf_chunk_cost leafWords row (by omega),List.length_cons,Nat.add_mul,Nat.one_mul] + refine ⟨by omega,fun digest => ?_⟩ + have h := ih.map (Q := fun result => ∀ hashes, result = some hashes → hashes.length = (row::rows).length) + (Option.map (digest :: ·)) (by + intro result hr hashes he + cases result with + | none => simp at he + | some tail => + simp only [Option.map_some,Option.some.injEq] at he + subst hashes + simp [hr tail rfl]) + simpa only [Nat.add_sub_cancel,List.length_cons] using h + · simp [leafHashes,hw,HashProgram.Certified] + +/-- Public geometry only: adversarial row count, row widths and sibling count +cannot inflate this all-reply cap because their guards precede offending work. -/ +def uniformBudget (numLeaves : Nat) (queries : List Nat) (leafWords : Nat) : Nat := + (leafChunkCost leafWords + numLeaves.log2) * queries.length + +theorem plan_certified_uniform (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : + HashProgram.Certified (uniformBudget numLeaves queries leafWords) (fun _ => True) + (plan proof root numLeaves queries rowWords leafWords) := by + unfold plan + split + · trivial + · split + · trivial + · rename_i hs hc + have fits : rowWords ≤ leafWords := by omega + have count : proof.leafData.length ≤ queries.length := by + have he : proof.leafData.length = (sortedUnique queries).length := by omega + rw [he] + simpa [sortedUnique] using queries.toFinset_card_le + have h : HashProgram.Certified + (proof.leafData.length * leafChunkCost leafWords + numLeaves.log2 * proof.leafData.length) + (fun _ => True) + ((leafHashes rowWords leafWords proof.leafData).bind fun hashes => + match hashes with + | none => .done none + | some hashes => + if ∃ q ∈ queries, numLeaves ≤ q then .done none + else (levels numLeaves.log2 ((sortedUnique queries).zip hashes) proof.siblingHashes).map + (finish root queries leafWords (leafTable queries proof.leafData))) := by + apply (leafHashes_certified_uniform rowWords leafWords proof.leafData fits).bind + (b := numLeaves.log2 * proof.leafData.length) + intro hashes hh + cases hashes with + | none => trivial + | some hashes => + dsimp only + split + · trivial + · have hlen := hh hashes rfl + have h := (levels_certified numLeaves.log2 ((sortedUnique queries).zip hashes) + proof.siblingHashes).map (Q := fun _ => True) + (finish root queries leafWords (leafTable queries proof.leafData)) (fun _ _ => True.intro) + exact h.mono (Nat.mul_le_mul_left numLeaves.log2 + (by simpa only [List.length_zip,hlen] using Nat.min_le_right (sortedUnique queries).length proof.leafData.length)) + (fun _ _ => True.intro) + apply h.mono ?_ (fun _ _ => True.intro) + unfold uniformBudget + nlinarith [Nat.mul_le_mul_left (leafChunkCost leafWords + numLeaves.log2) count] + +theorem verify_counted_uniform (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) : + Counts (uniformBudget numLeaves queries leafWords) (verify proof root numLeaves queries rowWords leafWords) := + (plan_certified_uniform proof root numLeaves queries rowWords leafWords).counts + +end Whir.PrunedMerkleProgram diff --git a/verification/whir/Whir/PublicMerkleBinding.lean b/verification/whir/Whir/PublicMerkleBinding.lean new file mode 100644 index 000000000..5dbd866a1 --- /dev/null +++ b/verification/whir/Whir/PublicMerkleBinding.lean @@ -0,0 +1,277 @@ +import Whir.PublicMerkleLog + +/-! Pointwise Merkle binding through the shared ordinary compression oracle. +The frozen table is the saturated domain reconstructed from the frozen public +log. No independent random whole-hash output or probability bound is assumed. -/ +namespace Whir.PublicMerkleBinding +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicMerkleLog MerkleTransport MerkleTransport.Commitments + + theorem records_origin {log : PublicLog} {bytes : List Byte} {d : Digest32} + (hm : (bytes,d) ∈ records log) : + ∃ n, (n,d) ∈ log ∧ parse log n d = some bytes := by + obtain ⟨⟨n,e⟩,hn,hp⟩ := List.mem_filterMap.mp hm + cases he : parse log n e with + | none => simp [he] at hp + | some bs => + simp only [he,Option.map_some,Option.some.injEq,Prod.mk.injEq] at hp + rcases hp with ⟨rfl,rfl⟩ + exact ⟨n,hn,he⟩ + + theorem run_plan_present (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (bs : List (List Byte)) (cv : Digest32) (count : Nat) + (d : Digest32) (done : run (PublicMerkleLog.lookup log) cv count bs = some d) : + ∀ e ∈ planFrom C cv count bs, e ∈ log := by + induction bs generalizing cv count with + | nil => simp [run] at done + | cons b rest ih => + cases rest with + | nil => + intro e he + have he' : e = (node cv count b true,C (node cv count b true)) := + List.mem_singleton.mp he + have hm := PublicMerkleLog.lookup_mem done + rw [he',auth _ _ hm] + exact hm + | cons next rest => + simp only [run,Option.bind_eq_bind] at done + cases hq : PublicMerkleLog.lookup log (node cv count b false) with + | none => simp [hq] at done + | some value => + simp only [hq,Option.bind_some] at done + have hm := PublicMerkleLog.lookup_mem hq + have hv := auth _ _ hm + intro e he + simp only [planFrom,hv,List.mem_cons] at he + rcases he with he | he + · simpa only [he] using hm + · exact ih value (count+b.length) done e he + + theorem parse_plan_present (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (n : Node) (d : Digest32) (bytes : List Byte) + (parsed : parse log n d = some bytes) : ∀ e ∈ plan C bytes, e ∈ log := by + unfold parse at parsed + split at parsed + · simp at parsed + · cases hr : recover log (log.length+1) + (n.tweak.toNat-finalLength n.tweak.toNat) n.cv with + | none => simp [hr] at parsed + | some pre => + simp only [hr,Option.bind_eq_bind,Option.bind_some] at parsed + split at parsed + next replay => + cases Option.some.inj parsed + exact run_plan_present C log auth _ _ _ _ replay + next => simp at parsed + + theorem record_length_bound {log : PublicLog} {bytes : List Byte} {d : Digest32} + (hm : (bytes,d) ∈ records log) : bytes.length < 2^64 := by + obtain ⟨n,_,hp⟩ := records_origin hm + rw [parse_byte_count hp] + exact n.tweak.toNat_lt + + theorem records_persist_or_collision (C : PrimitiveOracle) (oldLog newLog : PublicLog) + (oldAuth : AuthenticLog C oldLog) (newAuth : AuthenticLog C newLog) + (extension : ∀ e ∈ oldLog, e ∈ newLog) (bytes : List Byte) (d : Digest32) + (hm : (bytes,d) ∈ records oldLog) : + (bytes,d) ∈ records newLog ∨ OutputCollision newLog := by + obtain ⟨n,_,hp⟩ := records_origin hm + have present := parse_plan_present C oldLog oldAuth n d bytes hp + have hd := records_authentic C oldLog oldAuth bytes d hm + simpa only [hd] using plan_complete_or_public_collision C newLog newAuth bytes + (record_length_bound hm) (fun e he => extension e (present e he)) + + theorem records_persist (C : PrimitiveOracle) (oldLog newLog : PublicLog) + (oldAuth : AuthenticLog C oldLog) (newAuth : AuthenticLog C newLog) + (extension : ∀ e ∈ oldLog, e ∈ newLog) (noCollision : ¬ OutputCollision newLog) : + ∀ e ∈ records oldLog, e ∈ records newLog := by + rintro ⟨bytes,d⟩ hm + exact (records_persist_or_collision C oldLog newLog oldAuth newAuth extension bytes d hm).resolve_right noCollision + +/-- First-answer retention may change order and remove duplicates, but its +frozen domain must be saturated. Merely a subset is insufficient for FreshHit. -/ + theorem retained_domain_eq (retained current : Records) + (covered : ∀ e ∈ retained, e ∈ current) + (saturated : ∀ bytes d, (bytes,d) ∈ current → ∃ first, (bytes,first) ∈ retained) : + recordDomain retained = recordDomain current := by + apply Finset.Subset.antisymm + · intro bytes hb + obtain ⟨⟨x,d⟩,hm,he⟩ := List.mem_map.mp (List.mem_toFinset.mp hb) + dsimp only at he; subst x + exact List.mem_toFinset.mpr (List.mem_map.mpr ⟨(bytes,d),covered _ hm,rfl⟩) + · intro bytes hb + obtain ⟨⟨x,d⟩,hm,he⟩ := List.mem_map.mp (List.mem_toFinset.mp hb) + dsimp only at he; subst x + obtain ⟨first,hfirst⟩ := saturated bytes d hm + exact List.mem_toFinset.mpr (List.mem_map.mpr ⟨(bytes,first),hfirst,rfl⟩) + + theorem reconstructed_collision (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) + (collision : MerkleBinding.Collision (hashing (hash C)) (recordDomain (records log))) : + OutputCollision log := by + obtain ⟨x,hx,y,hy,hne,he⟩ := collision + obtain ⟨dx,hdx⟩ := recordLookup_exists (records log) x hx + obtain ⟨dy,hdy⟩ := recordLookup_exists (records log) y hy + have hxmem := recordLookup_mem _ _ _ hdx + have hymem := recordLookup_mem _ _ _ hdy + have hax := records_authentic C log auth x dx hxmem + have hay := records_authentic C log auth y dy hymem + have hd : dx = dy := hax.symm.trans (he.trans hay) + rw [← hd] at hymem + obtain ⟨nx,hnx,hpx⟩ := records_origin hxmem + obtain ⟨ny,hny,hpy⟩ := records_origin hymem + refine ⟨nx,ny,dx,hnx,hny,?_⟩ + intro hn + subst ny + exact hne (Option.some.inj (hpx.symm.trans hpy)) + +/-- The selected Merkle target is exactly the frozen root or a child of a +recorded pair input. The compression cut additionally permits an old CV. -/ +def PrimitiveFreshHit (C : PrimitiveOracle) (oldLog : PublicLog) (root : Digest32) + (queries : Finset (List Byte)) : Prop := + ∃ bytes ∈ queries, + MerkleBinding.Target (hashing (hash C)) (recordDomain (records oldLog)) root (hash C bytes) ∧ + FreshTarget C oldLog (hash C bytes) (plan C bytes) + + theorem freshHit_primitive (C : PrimitiveOracle) (oldLog : PublicLog) + (auth : AuthenticLog C oldLog) (root : Digest32) (queries : Finset (List Byte)) + (bounds : ∀ bytes ∈ queries, bytes.length < 2^64) + (hit : MerkleBinding.FreshHit (hashing (hash C)) + (recordDomain (records oldLog)) root queries) : + OutputCollision oldLog ∨ PrimitiveFreshHit C oldLog root queries := by + obtain ⟨bytes,hq,absent,target⟩ := hit + have notRecorded : (bytes,hash C bytes) ∉ records oldLog := by + intro hm + exact absent (List.mem_toFinset.mpr (List.mem_map.mpr ⟨(bytes,hash C bytes),hm,rfl⟩)) + rcases frozen_target_alternative C oldLog auth bytes (hash C bytes) (bounds bytes hq) rfl with + recorded | collision | fresh + · exact False.elim (notRecorded recorded) + · exact Or.inl collision + · exact Or.inr ⟨bytes,hq,target,fresh⟩ + +def OpenPrimitiveBad (C : PrimitiveOracle) (oldLog : PublicLog) (root : Digest32) + (output : List RawPath) : Prop := + OutputCollision oldLog ∨ + ∃ p ∈ output, PrimitiveFreshHit C oldLog root (p.opening.inputs (hashing (hash C))) + + theorem openBad_primitive (C : PrimitiveOracle) (oldLog : PublicLog) + (auth : AuthenticLog C oldLog) (snapshot : Snapshot) + (saturated : snapshot.table = recordDomain (records oldLog)) (root : Digest32) + (output : List RawPath) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) + (bad : OpenBad (hash C) snapshot root output) : + OpenPrimitiveBad C oldLog root output := by + rcases bad with collision | ⟨p,hp,fresh⟩ + · exact Or.inl (reconstructed_collision C oldLog auth (by simpa only [saturated] using collision)) + · rcases freshHit_primitive C oldLog auth root _ (bounds p hp) + (by simpa only [saturated] using fresh) with collision | hit + · exact Or.inl collision + · exact Or.inr ⟨p,hp,hit⟩ + +/-- Actual accepted pruned openings agree pointwise with the first frozen +oracle, or expose only ordinary shared-compression witnesses. No PCS cover +or probabilistic reduction is hidden in this transport theorem. -/ + theorem open_frozen_public (C : PrimitiveOracle) (oldLog : PublicLog) + (auth : AuthenticLog C oldLog) (registry announcements : Registry) + (root : Digest32) (snapshot : Snapshot) + (saturated : snapshot.table = recordDomain (records oldLog)) + (committed : Commitments.lookup root registry = some snapshot) + (proof : PrunedMerklePaths) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) + (accepted : proof.open (hash C) root numLeaves queries rowWords leafWords = some output) : + Commitments.lookup root (registerMany registry announcements) = some snapshot ∧ + ((∀ p ∈ output, p.leafData = row (hash C) snapshot root numLeaves.log2 p.leafIndex) ∨ + OpenPrimitiveBad C oldLog root output) := by + obtain ⟨stable,good | bad⟩ := open_frozen (hash C) registry announcements root snapshot committed + proof numLeaves queries rowWords leafWords output accepted + · exact ⟨stable,Or.inl good⟩ + · exact ⟨stable,Or.inr (openBad_primitive C oldLog auth snapshot saturated root output bounds bad)⟩ + +/-- Cumulative first records remain covered even when they were discovered +at different earlier public snapshots. Authenticity of those snapshots is +inherited from the actual current log, not supplied as a hash event. -/ + theorem historical_records_covered (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (noCollision : ¬ OutputCollision log) + (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicLog, + (∀ q ∈ earlier, q ∈ log) ∧ e ∈ records earlier) : + ∀ e ∈ retained, e ∈ records log := by + intro e he + obtain ⟨earlier,extension,hm⟩ := history e he + have earlierAuth : AuthenticLog C earlier := fun n d hn => auth n d (extension _ hn) + exact records_persist C earlier log earlierAuth auth extension noCollision e hm + + theorem historical_domain_eq (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (noCollision : ¬ OutputCollision log) + (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicLog, + (∀ q ∈ earlier, q ∈ log) ∧ e ∈ records earlier) + (saturated : ∀ bytes d, (bytes,d) ∈ records log → ∃ first, (bytes,first) ∈ retained) : + recordDomain retained = recordDomain (records log) := + retained_domain_eq retained (records log) + (historical_records_covered C log auth noCollision retained history) saturated + +/-- Cumulative storage version. The interpreter supplies only provenance of +retained entries and saturation after its public observation; any failure of +collision-free persistence is returned as an observed primitive collision. -/ + theorem open_frozen_retained (C : PrimitiveOracle) (oldLog : PublicLog) + (auth : AuthenticLog C oldLog) (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicLog, + (∀ q ∈ earlier, q ∈ oldLog) ∧ e ∈ records earlier) + (saturated : ∀ bytes d, (bytes,d) ∈ records oldLog → ∃ first, (bytes,first) ∈ retained) + (registry announcements : Registry) (root : Digest32) (snapshot : Snapshot) + (table : snapshot.table = recordDomain retained) + (committed : Commitments.lookup root registry = some snapshot) + (proof : PrunedMerklePaths) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) (output : List RawPath) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) + (accepted : proof.open (hash C) root numLeaves queries rowWords leafWords = some output) : + Commitments.lookup root (registerMany registry announcements) = some snapshot ∧ + ((∀ p ∈ output, p.leafData = row (hash C) snapshot root numLeaves.log2 p.leafIndex) ∨ + OpenPrimitiveBad C oldLog root output) := by + classical + by_cases collision : OutputCollision oldLog + · exact ⟨registerMany_preserves registry announcements root snapshot committed, + Or.inr (Or.inl collision)⟩ + · have domains := historical_domain_eq C oldLog auth collision retained history saturated + exact open_frozen_public C oldLog auth registry announcements root snapshot + (table.trans domains) committed proof numLeaves queries rowWords leafWords output bounds accepted + +/-- Reusable executable scenario: a real accepted pruned opening whose leaf +hash completes only after the frozen final compression record was public. -/ +def smoke : IO Unit := do + let leftWords : List Concrete.K := (List.range 9).map UInt64.ofNat + let rightWords : List Concrete.K := (List.range 9).map fun n => UInt64.ofNat (n+9) + let leftBytes := ByteCodec.wordsBytes leftWords + let rightBytes := ByteCodec.wordsBytes rightWords + let left := hashBlake2s leftBytes + let right := hashBlake2s rightBytes + let pairBytes := List.ofFn (ByteCodec.pairBytes (left,right)) + let root := hashBlake2s pairBytes + let proof : PrunedMerklePaths := ⟨[leftWords],[right]⟩ + match proof.open hashBlake2s root 2 [0,0] 9 9 with + | none => throw (IO.userError "actual two-leaf pruned opening was rejected") + | some output => + unless output.map RawPath.leafData == [leftWords,leftWords] do + throw (IO.userError "pruned opening did not preserve duplicate query rows") + match plan blake2sOracle leftBytes with + | [(first,a),(last,b)] => + let oldLog := (last,b) :: (plan blake2sOracle rightBytes ++ plan blake2sOracle pairBytes) + let oldRecords := records oldLog + unless recordLookup leftBytes oldRecords == none do + throw (IO.userError "frozen table incorrectly contains incomplete leaf hash") + unless recordLookup pairBytes oldRecords == some root do + throw (IO.userError "frozen table lost the recorded pair target") + unless PublicMerkleLog.lookup oldLog first == none && a == last.cv do + throw (IO.userError "fresh leaf precursor does not hit old public CV") + let (_,newRecords) := observe oldLog first a + unless recordLookup leftBytes newRecords == some left do + throw (IO.userError "late predecessor did not reconstruct accepted leaf") + for (bytes,d) in oldRecords do + unless recordLookup bytes newRecords == some d do + throw (IO.userError "old reconstructed hash record failed to persist") + | _ => throw (IO.userError "72-byte Merkle leaf did not use two compression nodes") + IO.println "Accepted pruned opening: duplicate rows, frozen pair-child target, late leaf precursor, and record persistence OK" + +end Whir.PublicMerkleBinding diff --git a/verification/whir/Whir/PublicMerkleLog.lean b/verification/whir/Whir/PublicMerkleLog.lean new file mode 100644 index 000000000..e77c6c610 --- /dev/null +++ b/verification/whir/Whir/PublicMerkleLog.lean @@ -0,0 +1,871 @@ +import Whir.DuplexModeGame +import Whir.MerkleTransport + +/-! Ordinary BLAKE2s provenance recovered exclusively from public compression +records. No hidden oracle table or caller-declared hash event is consulted. +The resource bound and the 56-bit domain separation bound are distinct. -/ +namespace Whir.PublicMerkleLog +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open MerkleTransport.Commitments + +abbrev PublicLog := List (Node × Digest32) + +instance : DecidableEq Node := fun a b => + if h : a.cv = b.cv ∧ a.block = b.block ∧ a.tweak = b.tweak ∧ a.last = b.last then + isTrue (by cases a; cases b; simp_all) + else isFalse (by intro e; exact h (by simp [e])) + +def AuthenticLog (C : PrimitiveOracle) (log : PublicLog) : Prop := + ∀ n d, (n,d) ∈ log → C n = d + +/-- The first public answer is retained even for an inconsistent repeated query. -/ +def lookup (log : PublicLog) (n : Node) : Option Digest32 := + match log with + | [] => none + | (m,d) :: rest => if n = m then some d else lookup rest n + +def insert (log : PublicLog) (n : Node) (d : Digest32) : PublicLog := + if (lookup log n).isSome then log else log ++ [(n,d)] + +/-- One final chunk, including the empty chunk for an empty input. -/ +def chunks (bytes : List Byte) : List (List Byte) := + if bytes.length ≤ 64 then [bytes] + else bytes.take 64 :: chunks (bytes.drop 64) +termination_by bytes.length + decreasing_by simp; omega + +/-- Concrete ordinary nodes; counters count real bytes, not padded bytes. -/ +def node (cv : Digest32) (count : Nat) (bytes : List Byte) (last : Bool) : Node := + ⟨cv, padded bytes.toArray, UInt64.ofNat (count + bytes.length), last⟩ + +/-- A public-query interpreter. Its optional oracle makes absence explicit. -/ +def run (query : Node → Option Digest32) (cv : Digest32) (count : Nat) : + List (List Byte) → Option Digest32 + | [] => none + | [b] => query (node cv count b true) + | b :: next :: rest => do + let d ← query (node cv count b false) + run query d (count + b.length) (next :: rest) + +def hash (C : PrimitiveOracle) (bytes : List Byte) : Digest32 := + (run (fun n => some (C n)) DuplexCompression.parameterIV 0 (chunks bytes)).getD + DuplexCompression.parameterIV + +def hashBlake2s : List Byte → Digest32 := hash blake2sOracle + +/-- The exact public compression plan of the ordinary computation. -/ +def planFrom (C : PrimitiveOracle) (cv : Digest32) (count : Nat) : + List (List Byte) → PublicLog + | [] => [] + | [b] => let n := node cv count b true; [(n,C n)] + | b :: next :: rest => + let n := node cv count b false + (n,C n) :: planFrom C (C n) (count + b.length) (next :: rest) + +def plan (C : PrimitiveOracle) (bytes : List Byte) : PublicLog := + planFrom C DuplexCompression.parameterIV 0 (chunks bytes) + +/-- Only a full output-CV match and the exact ordinary counter are accepted. -/ +def predecessor (log : PublicLog) (count : Nat) (cv : Digest32) : Option Node := + match log with + | [] => none + | (n,d) :: rest => + if d = cv ∧ n.tweak.toNat = count ∧ n.last = false then some n + else predecessor rest count cv + +/-- Fuel prevents a malicious huge counter from allocating or scanning huge +amounts of data. Every successful link contributes exactly 64 bytes. -/ +def recover (log : PublicLog) : Nat → Nat → Digest32 → Option (List Byte) + | 0, _, _ => none + | fuel + 1, count, cv => + if count = 0 then + if cv = DuplexCompression.parameterIV then some [] else none + else if count % 64 = 0 then do + let n ← predecessor log count cv + let prior ← recover log fuel (count - 64) n.cv + return prior ++ List.ofFn n.block + else none + +def finalLength (count : Nat) : Nat := + if count = 0 then 0 else (count - 1) % 64 + 1 + +/-- Reconstruct then replay against the *public* answers. Replay checks all +padding, chaining, counters, and final flags without evaluating private C. -/ +def parse (log : PublicLog) (n : Node) (answer : Digest32) : Option (List Byte) := do + if n.last != true then none else do + let size := finalLength n.tweak.toNat + let prior ← recover log (log.length + 1) (n.tweak.toNat - size) n.cv + let bytes := prior ++ (List.ofFn n.block).take size + if run (lookup log) DuplexCompression.parameterIV 0 (chunks bytes) = some answer + then some bytes else none + +/-- Completed records discovered by this public observation. Scanning all +finals also handles a final query appearing before its predecessor queries. -/ +def records (log : PublicLog) : Records := + log.filterMap fun (n,d) => (parse log n d).map fun bytes => (bytes,d) + +def observe (log : PublicLog) (n : Node) (answer : Digest32) : PublicLog × Records := + let updated := insert log n answer + (updated, records updated) + + theorem lookup_mem {log : PublicLog} {n : Node} {d : Digest32} + (h : lookup log n = some d) : (n,d) ∈ log := by + induction log with + | nil => simp [lookup] at h + | cons entry rest ih => + rcases entry with ⟨m,e⟩ + by_cases he : n = m + · simp [lookup,he] at h + simp [he,h] + · simp [lookup,he] at h + exact List.mem_cons_of_mem _ (ih h) + + theorem run_authentic (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (bs : List (List Byte)) (cv : Digest32) (count : Nat) + (d : Digest32) (h : run (lookup log) cv count bs = some d) : + run (fun n => some (C n)) cv count bs = some d := by + induction bs generalizing cv count with + | nil => simp [run] at h + | cons b rest ih => + cases rest with + | nil => + simp only [run] at h ⊢ + rw [auth _ _ (lookup_mem h)] + | cons next rest => + simp only [run, Option.bind_eq_bind] at h ⊢ + cases he : lookup log (node cv count b false) with + | none => simp [he] at h + | some e => + have hc := auth _ _ (lookup_mem he) + simp only [he, Option.bind_some] at h + simp only [hc, Option.bind_some] + exact ih e (count + b.length) h + + theorem parse_authentic (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (n : Node) (d : Digest32) (bytes : List Byte) + (h : parse log n d = some bytes) : hash C bytes = d := by + unfold parse at h + split at h + · simp at h + · cases hr : recover log (log.length + 1) + (n.tweak.toNat - finalLength n.tweak.toNat) n.cv with + | none => simp [hr] at h + | some prior => + simp only [hr, Option.bind_eq_bind, Option.bind_some] at h + split at h + next he => + have hb := Option.some.inj h + subst bytes + have hh := run_authentic C log auth _ _ _ _ he + exact congrArg (fun x => x.getD DuplexCompression.parameterIV) hh + next => simp at h + + theorem records_authentic (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) : Authentic (hash C) (records log) := by + intro bytes d hm + obtain ⟨⟨n,e⟩, _, he⟩ := List.mem_filterMap.mp hm + cases hp : parse log n e with + | none => simp [hp] at he + | some bs => + simp only [hp, Option.map_some, Option.some.injEq, Prod.mk.injEq] at he + rcases he with ⟨rfl,rfl⟩ + exact parse_authentic C log auth n e bs hp + + theorem insert_authentic (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (n : Node) : + AuthenticLog C (insert log n (C n)) := by + intro m d hm + unfold insert at hm + split at hm + · exact auth m d hm + · simp only [List.mem_append, List.mem_singleton] at hm + rcases hm with hm | hm + · exact auth m d hm + · cases hm; rfl + + theorem observe_authentic (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (n : Node) : + Authentic (hash C) (observe log n (C n)).2 := + records_authentic C _ (insert_authentic C log auth n) + +/-- A literal ordinary primitive collision, not a cryptographic assumption. -/ +def Collision (C : PrimitiveOracle) : Prop := + ∃ a b : Node, a ≠ b ∧ C a = C b + +def OutputCollision (log : PublicLog) : Prop := + ∃ a b d, (a,d) ∈ log ∧ (b,d) ∈ log ∧ a ≠ b + +theorem outputCollision_primitive (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (h : OutputCollision log) : Collision C := by + obtain ⟨a,b,d,ha,hb,hne⟩ := h + exact ⟨a,b,hne,(auth a d ha).trans (auth b d hb).symm⟩ + +theorem predecessor_spec {log : PublicLog} {count : Nat} {cv : Digest32} {n : Node} + (h : predecessor log count cv = some n) : + (n,cv) ∈ log ∧ n.tweak.toNat = count ∧ n.last = false := by + induction log with + | nil => simp [predecessor] at h + | cons entry rest ih => + rcases entry with ⟨m,d⟩ + simp only [predecessor] at h + split at h + next he => + cases Option.some.inj h + exact ⟨by simp [he.1],he.2⟩ + next => + obtain ⟨hm,ht,hl⟩ := ih h + exact ⟨List.mem_cons_of_mem _ hm,ht,hl⟩ + +theorem predecessor_exists {log : PublicLog} {count : Nat} {cv : Digest32} {n : Node} + (hm : (n,cv) ∈ log) (ht : n.tweak.toNat = count) (hl : n.last = false) : + ∃ m, predecessor log count cv = some m := by + induction log with + | nil => simp at hm + | cons entry rest ih => + rcases entry with ⟨m,d⟩ + by_cases he : d = cv ∧ m.tweak.toNat = count ∧ m.last = false + · exact ⟨m,by rw [predecessor,ite_eq_left he]⟩ + · have hm' : (n,cv) ∈ rest := by + rcases List.mem_cons.mp hm with eq | mem + · cases eq + exact False.elim (he ⟨rfl,ht,hl⟩) + · exact mem + obtain ⟨p,hp⟩ := ih hm' + exact ⟨p,by simp only [predecessor,he,↓reduceIte,hp]⟩ + +/-- A finite, full-CV-linked ordinary prefix trace, made solely of actual +public records. Its index is the number of nonfinal compression queries. +Counters are natural byte counts, so wrapped counter traces are excluded. -/ +inductive Prefix (log : PublicLog) : Nat → Nat → Digest32 → List Byte → Prop + | seed : Prefix log 0 0 DuplexCompression.parameterIV [] + | step {k count cv bytes} (n : Node) : + Prefix log k (count - 64) n.cv bytes → + 0 < count → count % 64 = 0 → + n.tweak.toNat = count → n.last = false → (n,cv) ∈ log → + Prefix log (k+1) count cv (bytes ++ List.ofFn n.block) + +theorem recover_complete_or_collision {log : PublicLog} {k count : Nat} + {cv : Digest32} {bytes : List Byte} (trace : Prefix log k count cv bytes) + (fuel : Nat) (enough : k < fuel) : + recover log fuel count cv = some bytes ∨ OutputCollision log := by + induction trace generalizing fuel with + | seed => + cases fuel with + | zero => omega + | succ fuel => exact Or.inl (by simp only [recover,↓reduceIte]) + | @step k count cv bytes n prior pos multiple ht hl hm ih => + obtain ⟨m,hfind⟩ := predecessor_exists hm ht hl + obtain ⟨hmem,_,_⟩ := predecessor_spec hfind + by_cases he : m = n + · subst m + cases fuel with + | zero => omega + | succ fuel => + rcases ih fuel (by omega) with hr | hc + · left + simp only [recover,show count ≠ 0 by omega,multiple,↓reduceIte, + hfind,Option.bind_eq_bind,Option.bind_some,hr,Option.pure_def] + · exact Or.inr hc + · exact Or.inr ⟨m,n,cv,hmem,hm,he⟩ + +theorem prefix_length {log : PublicLog} {k count : Nat} {cv : Digest32} + {bytes : List Byte} (trace : Prefix log k count cv bytes) : + bytes.length = 64*k ∧ count = 64*k := by + induction trace with + | seed => simp + | @step k count cv bytes n prior pos multiple ht hl hm ih => + have hc : 64 ≤ count := Nat.le_of_dvd pos (Nat.dvd_of_mod_eq_zero multiple) + simp only [List.length_append,List.length_ofFn] + constructor <;> omega + +/-- A completed ordinary computation in the public query interpreter. +`Prefix` records all actual predecessor inputs and answers; `replayed` +records the final public compression answer as well. These are trace facts, +not self-reported high-level hash events. -/ +structure Completed (log : PublicLog) (n : Node) (answer : Digest32) + (bytes : List Byte) where + member : (n,answer) ∈ log + finalFlag : n.last = true + depth : Nat + prior : List Byte + trace : Prefix log depth (n.tweak.toNat - finalLength n.tweak.toNat) n.cv prior + message : bytes = prior ++ (List.ofFn n.block).take (finalLength n.tweak.toNat) + replayed : run (lookup log) DuplexCompression.parameterIV 0 (chunks bytes) = some answer + +theorem parse_complete_or_collision {log : PublicLog} {n : Node} {answer : Digest32} + {bytes : List Byte} (trace : Completed log n answer bytes) + (enough : trace.depth ≤ log.length) : + parse log n answer = some bytes ∨ OutputCollision log := by + rcases recover_complete_or_collision trace.trace (log.length + 1) (by omega) with hr | hc + · left + simp only [parse,trace.finalFlag,show (true != true) = false from rfl, + Bool.false_eq_true,↓reduceIte,hr,Option.bind_eq_bind,Option.bind_some] + rw [← trace.message] + simp only [trace.replayed,↓reduceIte] + · exact Or.inr hc + +theorem parse_complete_or_primitive_collision (C : PrimitiveOracle) + {log : PublicLog} (auth : AuthenticLog C log) {n : Node} {answer : Digest32} + {bytes : List Byte} (trace : Completed log n answer bytes) + (enough : trace.depth ≤ log.length) : + parse log n answer = some bytes ∨ Collision C := + (parse_complete_or_collision trace enough).imp id (outputCollision_primitive C log auth) + +theorem parse_complete {log : PublicLog} (noCollision : ¬ OutputCollision log) + {n : Node} {answer : Digest32} {bytes : List Byte} + (trace : Completed log n answer bytes) (enough : trace.depth ≤ log.length) : + parse log n answer = some bytes := + (parse_complete_or_collision trace enough).resolve_right noCollision + +theorem records_complete {log : PublicLog} (noCollision : ¬ OutputCollision log) + {n : Node} {answer : Digest32} {bytes : List Byte} + (trace : Completed log n answer bytes) (enough : trace.depth ≤ log.length) : + (bytes,answer) ∈ records log := by + apply List.mem_filterMap.mpr + exact ⟨(n,answer),trace.member,by + simp only [parse_complete noCollision trace enough,Option.map_some]⟩ + +theorem lookup_exists {log : PublicLog} {n : Node} {d : Digest32} + (hm : (n,d) ∈ log) : ∃ e, lookup log n = some e := by + induction log with + | nil => simp at hm + | cons entry rest ih => + rcases entry with ⟨m,e⟩ + by_cases he : n = m + · exact ⟨e,by simp only [lookup,he,↓reduceIte]⟩ + · have ht : (n,d) ∈ rest := by + simpa only [List.mem_cons,Prod.mk.injEq,he,false_and,false_or] using hm + obtain ⟨v,hv⟩ := ih ht + exact ⟨v,by simp only [lookup,he,↓reduceIte,hv]⟩ + +theorem lookup_authentic_member (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) {n : Node} {d : Digest32} (hm : (n,d) ∈ log) : + lookup log n = some (C n) := by + obtain ⟨e,he⟩ := lookup_exists hm + rw [he,auth n e (lookup_mem he)] + +theorem run_plan (C : PrimitiveOracle) (log : PublicLog) (auth : AuthenticLog C log) + (bs : List (List Byte)) (cv : Digest32) (count : Nat) + (present : ∀ e ∈ planFrom C cv count bs, e ∈ log) : + run (lookup log) cv count bs = run (fun n => some (C n)) cv count bs := by + induction bs generalizing cv count with + | nil => rfl + | cons b rest ih => + cases rest with + | nil => + exact lookup_authentic_member C log auth + (present (node cv count b true,C (node cv count b true)) (by simp only [planFrom,List.mem_singleton])) + | cons next rest => + have hm := present _ (List.mem_cons_self : + (node cv count b false,C (node cv count b false)) ∈ + planFrom C cv count (b :: next :: rest)) + simp only [run,lookup_authentic_member C log auth hm, + Option.bind_eq_bind,Option.bind_some] + apply ih + intro e he + exact present e (List.mem_cons_of_mem _ he) + +theorem run_nonempty (C : PrimitiveOracle) (bs : List (List Byte)) + (hne : bs ≠ []) (cv : Digest32) (count : Nat) : + ∃ d, run (fun n => some (C n)) cv count bs = some d := by + induction bs generalizing cv count with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => exact ⟨_,rfl⟩ + | cons next rest => + simpa only [run,Option.bind_eq_bind,Option.bind_some] using + ih (by simp) (C (node cv count b false)) (count + b.length) + +theorem chunks_nonempty (bytes : List Byte) : chunks bytes ≠ [] := by + rw [chunks] + split <;> simp + +theorem hash_replay (C : PrimitiveOracle) (log : PublicLog) (auth : AuthenticLog C log) + (bytes : List Byte) (present : ∀ e ∈ plan C bytes, e ∈ log) : + run (lookup log) DuplexCompression.parameterIV 0 (chunks bytes) = some (hash C bytes) := by + rw [run_plan C log auth _ _ _ present] + obtain ⟨d,hd⟩ := run_nonempty C (chunks bytes) (chunks_nonempty bytes) + DuplexCompression.parameterIV 0 + unfold hash + rw [hd] + rfl + +theorem padded_take (bytes : List Byte) (h : bytes.length ≤ 64) : + (List.ofFn (padded bytes.toArray)).take bytes.length = bytes := by + apply List.ext_getElem + · simp only [List.length_take,List.length_ofFn,Nat.min_eq_left h] + · intro i hi hj + simp only [List.getElem_take,List.getElem_ofFn,padded] + simp [List.getElem_toArray,show i < bytes.length from hj] + +theorem padded_full (bytes : List Byte) (h : bytes.length = 64) : + List.ofFn (padded bytes.toArray) = bytes := by + have hp := padded_take bytes (by omega) + simpa only [h,List.take_of_length_le (by simp : (List.ofFn (padded bytes.toArray)).length ≤ 64)] using hp + +theorem finalLength_bounds (n : Nat) : finalLength n ≤ 64 ∧ finalLength n ≤ n := by + unfold finalLength + split <;> omega + +theorem finalLength_block (k r : Nat) (hr : r ≤ 64) (positive : 0 < r ∨ k = 0) : + finalLength (64*k+r) = r := by + unfold finalLength + have hm : (64*k+r-1) % 64 = (r-1) % 64 := by omega + split <;> omega + +theorem recover_bound {log : PublicLog} {fuel count : Nat} {cv : Digest32} + {bytes : List Byte} (h : recover log fuel count cv = some bytes) : + bytes.length ≤ 64 * fuel := by + induction fuel generalizing count cv bytes with + | zero => simp [recover] at h + | succ fuel ih => + simp only [recover] at h + split at h + · split at h + · cases Option.some.inj h; simp + · simp at h + · split at h + · cases hp : predecessor log count cv with + | none => simp [hp] at h + | some n => + simp only [hp,Option.bind_eq_bind,Option.bind_some] at h + cases hr : recover log fuel (count-64) n.cv with + | none => simp [hr] at h + | some bs => + simp only [hr,Option.bind_some,Option.pure_def,Option.some.injEq] at h + subst bytes + have hh := ih hr + simp only [List.length_append,List.length_ofFn] + omega + · simp at h + +theorem parse_resource_bound {log : PublicLog} {n : Node} {d : Digest32} + {bytes : List Byte} (h : parse log n d = some bytes) : + bytes.length ≤ 64 * (log.length + 2) := by + unfold parse at h + split at h + · simp at h + · cases hr : recover log (log.length+1) (n.tweak.toNat-finalLength n.tweak.toNat) n.cv with + | none => simp [hr] at h + | some bs => + simp only [hr,Option.bind_eq_bind,Option.bind_some] at h + split at h + · cases Option.some.inj h + have hb := recover_bound hr + have hl := (finalLength_bounds n.tweak.toNat).1 + simp only [List.length_append,List.length_take,List.length_ofFn] + omega + · simp at h + +/-- This is a conditional #552 tag separation statement, not a statement +about baseline interactive code or a cryptographic collision probability. -/ +theorem ordinary_tag_zero (cv : Digest32) (count : Nat) (bytes : List Byte) (last : Bool) + (bound : count + bytes.length < 2^56) : tag (node cv count bytes last) = 0 := by + have h64 : count + bytes.length < 2^64 := by omega + simp only [tag,node,UInt64.toNat_ofNat',Nat.mod_eq_of_lt h64] + exact Nat.div_eq_of_lt bound + +theorem ordinary_ne_duplex (cv : Digest32) (count : Nat) (bytes : List Byte) + (last : Bool) (bound : count + bytes.length < 2^56) (mode : Node) + (modeTag : 1 ≤ tag mode) : node cv count bytes last ≠ mode := by + intro he + have hz := ordinary_tag_zero cv count bytes last bound + rw [he] at hz + omega + +theorem insert_preserves_first (log : PublicLog) (n : Node) (d first : Digest32) + (h : lookup log n = some first) : insert log n d = log := by + simp only [insert,h,Option.isSome_some,↓reduceIte] + +/-- Every real plan has a reverse-linked trace; no reverse trace is assumed +by the end-to-end completeness theorem below. -/ +theorem plan_shape (C : PrimitiveOracle) (log : PublicLog) (bytes : List Byte) + (cv : Digest32) (k : Nat) (prior : List Byte) + (prefixTrace : Prefix log k (64*k) cv prior) + (bound : 64*k + bytes.length < 2^64) + (positive : 0 < bytes.length ∨ k = 0) + (present : ∀ e ∈ planFrom C cv (64*k) (chunks bytes), e ∈ log) : + ∃ n d depth pre, (n,d) ∈ log ∧ n.last = true ∧ + Prefix log depth (n.tweak.toNat - finalLength n.tweak.toNat) n.cv pre ∧ + prior ++ bytes = pre ++ (List.ofFn n.block).take (finalLength n.tweak.toNat) ∧ + run (fun n => some (C n)) cv (64*k) (chunks bytes) = some d := by + by_cases short : bytes.length ≤ 64 + · let n := node cv (64*k) bytes true + have ht : n.tweak.toNat = 64*k + bytes.length := by + simp only [n,node,UInt64.toNat_ofNat',Nat.mod_eq_of_lt bound] + have hf : finalLength n.tweak.toNat = bytes.length := by + rw [ht]; exact finalLength_block k bytes.length short positive + have hc : n.tweak.toNat - finalLength n.tweak.toNat = 64*k := by + rw [hf,ht]; omega + refine ⟨n,C n,k,prior,?_,rfl,?_,?_,?_⟩ + · apply present + simp only [chunks,short,↓reduceIte,planFrom,List.mem_singleton] + rfl + · rw [hc]; exact prefixTrace + · rw [hf] + exact congrArg (prior ++ ·) (padded_take bytes short).symm + · simp only [chunks,short,↓reduceIte,run] + rfl + · have full : (bytes.take 64).length = 64 := by simp only [List.length_take]; omega + let n := node cv (64*k) (bytes.take 64) false + have ht : n.tweak.toNat = 64*(k+1) := by + have hb : 64*k + (bytes.take 64).length < 2^64 := by omega + simp only [n,node,UInt64.toNat_ofNat',full] + omega + have hm : (n,C n) ∈ log := by + apply present + rw [chunks,ite_eq_right short] + have hne := chunks_nonempty (bytes.drop 64) + cases he : chunks (bytes.drop 64) with + | nil => contradiction + | cons next rest => exact List.mem_cons_self + have hp : Prefix log (k+1) (64*(k+1)) (C n) (prior ++ bytes.take 64) := by + have hstep := Prefix.step n (count := 64*(k+1)) + (by simpa only [show 64*(k+1)-64 = 64*k by omega,n,node] using prefixTrace) + (by omega) (by omega) ht rfl hm + simpa only [n,node,padded_full (bytes.take 64) full] using hstep + have present' : ∀ e ∈ planFrom C (C n) (64*(k+1)) (chunks (bytes.drop 64)), e ∈ log := by + intro e he + apply present + rw [chunks,ite_eq_right short] + cases hbs : chunks (bytes.drop 64) with + | nil => simp only [hbs,planFrom,List.not_mem_nil] at he + | cons next rest => + simp only [planFrom] + apply List.mem_cons_of_mem + simpa only [hbs,show 64*k+(bytes.take 64).length = 64*(k+1) by omega] using he + obtain ⟨last,d,depth,pre,hmLast,hflag,htrace,hmessage,hrun⟩ := + plan_shape C log (bytes.drop 64) (C n) (k+1) (prior ++ bytes.take 64) hp + (by simp only [List.length_drop]; omega) + (Or.inl (by simp only [List.length_drop]; omega)) present' + refine ⟨last,d,depth,pre,hmLast,hflag,htrace,?_,?_⟩ + · simpa only [List.append_assoc,List.take_append_drop] using hmessage + · rw [chunks,ite_eq_right short] + cases hbs : chunks (bytes.drop 64) with + | nil => exact False.elim (chunks_nonempty (bytes.drop 64) hbs) + | cons next rest => + simp only [run,Option.bind_eq_bind,Option.bind_some] + simpa only [hbs,show 64*k+(bytes.take 64).length = 64*(k+1) by omega] using hrun +termination_by bytes.length +decreasing_by simp only [List.length_drop]; omega + +theorem plan_completed (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (bytes : List Byte) (bound : bytes.length < 2^64) + (present : ∀ e ∈ plan C bytes, e ∈ log) : + ∃ n, Nonempty (Completed log n (hash C bytes) bytes) := by + obtain ⟨n,d,depth,pre,hm,hflag,ht,he,hr⟩ := + plan_shape C log bytes DuplexCompression.parameterIV 0 [] Prefix.seed + (by simpa using bound) (Or.inr rfl) present + have hd : hash C bytes = d := by + exact congrArg (fun x => x.getD DuplexCompression.parameterIV) hr + refine ⟨n,⟨?_⟩⟩ + exact ⟨by simpa only [hd] using hm,hflag,depth,pre,ht, + by simpa only [List.nil_append] using he,hash_replay C log auth bytes present⟩ + +theorem prefix_counter_present {log : PublicLog} {k count : Nat} + {cv : Digest32} {bytes : List Byte} (trace : Prefix log k count cv bytes) + (i : Nat) (hi : i < k) : + ∃ n d, (n,d) ∈ log ∧ n.tweak.toNat = 64*(i+1) := by + induction trace with + | seed => omega + | @step k count cv bytes n prior pos multiple ht hl hm ih => + by_cases he : i = k + · subst i + have hc := (prefix_length (Prefix.step n prior pos multiple ht hl hm)).2 + exact ⟨n,cv,hm,ht.trans hc⟩ + · exact ih (by omega) + +theorem prefix_depth_bound {log : PublicLog} {k count : Nat} + {cv : Digest32} {bytes : List Byte} (trace : Prefix log k count cv bytes) : + k ≤ log.length := by + let counters := log.map fun e => e.1.tweak.toNat / 64 - 1 + have hsub : Finset.range k ⊆ counters.toFinset := by + intro i hi + obtain ⟨n,d,hm,ht⟩ := prefix_counter_present trace i (Finset.mem_range.mp hi) + apply List.mem_toFinset.mpr + apply List.mem_map.mpr + exact ⟨(n,d),hm,by dsimp; rw [ht]; omega⟩ + have hcard := (Finset.card_le_card hsub).trans counters.toFinset_card_le + simpa only [Finset.card_range,counters,List.length_map] using hcard + +/-- End-to-end completeness for arbitrary-length ordinary hashing: the only +alternative is two *distinct actual compression inputs* sharing a public +answer. The real-byte bound rules out UInt64 counter wraparound. -/ +theorem plan_complete_or_collision (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (bytes : List Byte) (bound : bytes.length < 2^64) + (present : ∀ e ∈ plan C bytes, e ∈ log) : + (bytes,hash C bytes) ∈ records log ∨ Collision C := by + obtain ⟨n,⟨trace⟩⟩ := plan_completed C log auth bytes bound present + rcases parse_complete_or_collision trace (prefix_depth_bound trace.trace) with hp | hc + · left + exact List.mem_filterMap.mpr ⟨(n,hash C bytes),trace.member,by + simp only [hp,Option.map_some]⟩ + · exact Or.inr (outputCollision_primitive C log auth hc) + +theorem plan_complete (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (noCollision : ¬ OutputCollision log) + (bytes : List Byte) (bound : bytes.length < 2^64) + (present : ∀ e ∈ plan C bytes, e ∈ log) : + (bytes,hash C bytes) ∈ records log := by + obtain ⟨n,⟨trace⟩⟩ := plan_completed C log auth bytes bound present + exact records_complete noCollision trace (prefix_depth_bound trace.trace) + +theorem recover_byte_count {log : PublicLog} {fuel count : Nat} {cv : Digest32} + {bytes : List Byte} (h : recover log fuel count cv = some bytes) : + bytes.length = count := by + induction fuel generalizing count cv bytes with + | zero => simp [recover] at h + | succ fuel ih => + simp only [recover] at h + split at h + next hz => + split at h + · cases Option.some.inj h; simpa only [List.length_nil] using hz.symm + · simp at h + next hn => + split at h + next hm => + cases hp : predecessor log count cv with + | none => simp [hp] at h + | some n => + simp only [hp,Option.bind_eq_bind,Option.bind_some] at h + cases hr : recover log fuel (count-64) n.cv with + | none => simp [hr] at h + | some bs => + simp only [hr,Option.bind_some,Option.pure_def,Option.some.injEq] at h + subst bytes + have hh := ih hr + have hc : 64 ≤ count := Nat.le_of_dvd (by omega) (Nat.dvd_of_mod_eq_zero hm) + simp only [List.length_append,List.length_ofFn] + omega + next => simp at h + +theorem parse_byte_count {log : PublicLog} {n : Node} {d : Digest32} + {bytes : List Byte} (h : parse log n d = some bytes) : + bytes.length = n.tweak.toNat := by + unfold parse at h + split at h + · simp at h + · cases hr : recover log (log.length+1) (n.tweak.toNat-finalLength n.tweak.toNat) n.cv with + | none => simp [hr] at h + | some bs => + simp only [hr,Option.bind_eq_bind,Option.bind_some] at h + split at h + · cases Option.some.inj h + have hb := recover_byte_count hr + have hl := finalLength_bounds n.tweak.toNat + simp only [List.length_append,List.length_take,List.length_ofFn] + omega + · simp at h + +theorem chunks_flatten (bytes : List Byte) : (chunks bytes).flatten = bytes := by + rw [chunks] + split + · simp only [List.flatten_cons,List.flatten_nil,List.append_nil] + · rw [List.flatten_cons,chunks_flatten,List.take_append_drop] +termination_by bytes.length +decreasing_by simp only [List.length_drop]; omega + +theorem planFrom_tag_zero (C : PrimitiveOracle) (cv : Digest32) (count : Nat) + (bs : List (List Byte)) (bound : count + bs.flatten.length < 2^56) + (n : Node) (d : Digest32) (hm : (n,d) ∈ planFrom C cv count bs) : + tag n = 0 := by + induction bs generalizing cv count with + | nil => simp only [planFrom,List.not_mem_nil] at hm + | cons b rest ih => + cases rest with + | nil => + simp only [planFrom,List.mem_singleton,Prod.mk.injEq] at hm + rw [hm.1] + apply ordinary_tag_zero + simpa only [List.flatten_cons,List.flatten_nil,List.append_nil] using bound + | cons next rest => + simp only [planFrom,List.mem_cons,Prod.mk.injEq] at hm + have hb : count + b.length + (next :: rest).flatten.length < 2^56 := by + simpa only [List.flatten_cons,List.length_append,Nat.add_assoc] using bound + rcases hm with ⟨he,_⟩ | hm + · rw [he] + apply ordinary_tag_zero + omega + · exact ih (C (node cv count b false)) (count + b.length) hb hm + +theorem plan_tag_zero (C : PrimitiveOracle) (bytes : List Byte) + (bound : bytes.length < 2^56) (n : Node) (d : Digest32) + (hm : (n,d) ∈ plan C bytes) : tag n = 0 := + planFrom_tag_zero C DuplexCompression.parameterIV 0 (chunks bytes) + (by simpa only [chunks_flatten,Nat.zero_add] using bound) n d hm + +/-- RFC-style sequential-byte KATs, independently evaluated with Python's +standard hashlib BLAKE2s. Leaf bytes are 00..17; the Merkle pair hashes the +two 24-byte leaves 00..17 and 18..2f and concatenates their full digests. -/ +def knownAnswerVectors : List (Nat × String) := [ + (0, "69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9"), + (1, "e34d74dbaf4ff4c6abd871cc220451d2ea2648846c7757fbaac82fe51ad64bea"), + (64, "56f34e8b96557e90c1f24b52d0c89d51086acf1b00f634cf1dde9233b8eaaa3e"), + (65, "1b53ee94aaf34e4b159d48de352c7f0661d0a40edff95a0b1639b4090e974472"), + (128, "1fa877de67259d19863a2a34bcc6962a2b25fcbf5cbecd7ede8f1fa36688a796"), + (129, "5bd169e67c82c2c2e98ef7008bdf261f2ddf30b1c00f9e7f275bb3e8a28dc9a2")] + +def sequentialBytes (start count : Nat) : List Byte := + (List.range count).map fun i => ⟨(start+i)%256,Nat.mod_lt _ (by decide)⟩ + +/-- Executable smoke, deliberately separate from checked theorem evidence. -/ +def smoke : IO Unit := do + for (size,expected) in knownAnswerVectors do + let bytes := sequentialBytes 0 size + let digest := hashBlake2s bytes + let actual := DuplexCompression.hex (List.ofFn digest) + unless actual == expected do + throw (IO.userError s!"BLAKE2s KAT {size}: {actual} != {expected}") + let trace := plan blake2sOracle bytes + let mut log : PublicLog := [] + -- Final-first exposes why completion must also run on predecessor arrival. + for (n,d) in trace.reverse do + log := (observe log n d).1 + unless (recordLookup bytes (records log)) == some digest do + throw (IO.userError s!"public reconstruction failed at {size}") + IO.println s!"BLAKE2s-{size}: {actual}; final-first public replay OK" + let left := hashBlake2s (sequentialBytes 0 24) + let right := hashBlake2s (sequentialBytes 24 24) + let pairBytes := List.ofFn left ++ List.ofFn right + let pair := hashBlake2s pairBytes + unless DuplexCompression.hex (List.ofFn left) == + "b2c2420f05f9abe36315919336b37e4e0fa33ff7e76a492767006fdb5d935462" do + throw (IO.userError "Merkle leaf KAT failed") + unless DuplexCompression.hex (List.ofFn pair) == + "7d89d5eaf3414032e779649edf3b3c60d7b34401a49bea6ae2826b065c95e914" do + throw (IO.userError "Merkle pair KAT failed") + unless recordLookup pairBytes (records (plan blake2sOracle pairBytes)) == some pair do + throw (IO.userError "Merkle pair public reconstruction failed") + let bytes := sequentialBytes 0 129 + let trace := plan blake2sOracle bytes + match trace.reverse with + | [] => throw (IO.userError "missing concrete plan") + | (n,d) :: _ => + unless records [(n,d)] == [] do + throw (IO.userError "incomplete prefix was accepted") + let wrong : Digest32 := fun _ => 0 + unless lookup (insert [(n,d)] n wrong) n == some d do + throw (IO.userError "first public answer was overwritten") + IO.println "Merkle leaf/pair, missing-prefix rejection, first-answer retention: OK" + +/-- Targets known at a frozen snapshot: a registered digest or the complete +CV field of a public compression input. In particular, a final digest that +was public before its predecessors is not treated as a fresh hash output. -/ +def SnapshotTarget (oldLog : PublicLog) (target output : Digest32) : Prop := + output = target ∨ ∃ n answer, (n,answer) ∈ oldLog ∧ output = n.cv + +def FreshTarget (C : PrimitiveOracle) (oldLog : PublicLog) + (target : Digest32) (trace : PublicLog) : Prop := + ∃ n, (n,C n) ∈ trace ∧ + (∀ answer, (n,answer) ∉ oldLog) ∧ SnapshotTarget oldLog target (C n) + +theorem planFrom_head (C : PrimitiveOracle) (cv : Digest32) (count : Nat) + (bs : List (List Byte)) (hne : bs ≠ []) : + ∃ n d, (n,d) ∈ planFrom C cv count bs ∧ n.cv = cv := by + cases bs with + | nil => contradiction + | cons b rest => + cases rest with + | nil => exact ⟨node cv count b true,_,List.mem_cons_self,rfl⟩ + | cons next rest => exact ⟨node cv count b false,_,List.mem_cons_self,rfl⟩ + +/-- Root-first cut through an actual forward plan. The last absent node +either produces the final target or links into an already public CV. -/ +theorem planFrom_frozen_cut (C : PrimitiveOracle) (oldLog : PublicLog) + (auth : AuthenticLog C oldLog) (bs : List (List Byte)) + (cv : Digest32) (count : Nat) (target : Digest32) + (finished : run (fun n => some (C n)) cv count bs = some target) : + (∀ e ∈ planFrom C cv count bs, e ∈ oldLog) ∨ + FreshTarget C oldLog target (planFrom C cv count bs) := by + induction bs generalizing cv count with + | nil => simp [run] at finished + | cons b rest ih => + cases rest with + | nil => + let n := node cv count b true + have hout : C n = target := Option.some.inj finished + by_cases seen : ∃ answer, (n,answer) ∈ oldLog + · obtain ⟨answer,ha⟩ := seen + left + intro e he + have he' : e = (n,C n) := List.mem_singleton.mp he + rw [he',auth n answer ha] + exact ha + · right + exact ⟨n,List.mem_cons_self,fun answer ha => seen ⟨answer,ha⟩,Or.inl hout⟩ + | cons next rest => + let n := node cv count b false + have hr : run (fun n => some (C n)) (C n) (count+b.length) (next::rest) = + some target := finished + rcases ih (C n) (count+b.length) hr with tailPresent | tailFresh + · by_cases seen : ∃ answer, (n,answer) ∈ oldLog + · obtain ⟨answer,ha⟩ := seen + left + intro e he + rcases List.mem_cons.mp he with he | he + · rw [he,auth n answer ha] + exact ha + · exact tailPresent e he + · right + obtain ⟨nextNode,d,hm,hcv⟩ := planFrom_head C (C n) (count+b.length) + (next::rest) (by simp) + exact ⟨n,List.mem_cons_self,fun answer ha => seen ⟨answer,ha⟩, + Or.inr ⟨nextNode,d,tailPresent _ hm,hcv.symm⟩⟩ + · right + obtain ⟨missing,hm,ha,ht⟩ := tailFresh + exact ⟨missing,List.mem_cons_of_mem _ hm,ha,ht⟩ + +theorem plan_complete_or_public_collision (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (bytes : List Byte) (bound : bytes.length < 2^64) + (present : ∀ e ∈ plan C bytes, e ∈ log) : + (bytes,hash C bytes) ∈ records log ∨ OutputCollision log := by + obtain ⟨n,⟨trace⟩⟩ := plan_completed C log auth bytes bound present + rcases parse_complete_or_collision trace (prefix_depth_bound trace.trace) with hp | hc + · left + exact List.mem_filterMap.mpr ⟨(n,hash C bytes),trace.member,by + simp only [hp,Option.map_some]⟩ + · exact Or.inr hc + +/-- Preserve the public witnesses when translating an output-log collision +to an ordinary primitive collision. No global injectivity is assumed. -/ +theorem observedCollision_primitive (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (h : OutputCollision log) : + ∃ a b d, (a,d) ∈ log ∧ (b,d) ∈ log ∧ a ≠ b ∧ C a = C b := by + obtain ⟨a,b,d,ha,hb,hne⟩ := h + exact ⟨a,b,d,ha,hb,hne,(auth a d ha).trans (auth b d hb).symm⟩ + +/-- Exact shared-C alternative at an arbitrary frozen public snapshot. +There is no independent fresh-whole-hash assumption. The absent input is +an actual node of the ordinary plan, and its output targets only the fixed +digest or a CV already recorded in `oldLog`. -/ +theorem frozen_target_alternative (C : PrimitiveOracle) (oldLog : PublicLog) + (auth : AuthenticLog C oldLog) (bytes : List Byte) (target : Digest32) + (bound : bytes.length < 2^64) (hits : hash C bytes = target) : + (bytes,target) ∈ records oldLog ∨ OutputCollision oldLog ∨ + FreshTarget C oldLog target (plan C bytes) := by + obtain ⟨d,hd⟩ := run_nonempty C (chunks bytes) (chunks_nonempty bytes) + DuplexCompression.parameterIV 0 + have he : d = target := by + have hh : hash C bytes = d := + congrArg (fun x => x.getD DuplexCompression.parameterIV) hd + exact hh.symm.trans hits + rcases planFrom_frozen_cut C oldLog auth (chunks bytes) + DuplexCompression.parameterIV 0 target (by simpa only [he] using hd) with present | fresh + · rcases plan_complete_or_public_collision C oldLog auth bytes bound present with recorded | collision + · exact Or.inl (by simpa only [hits] using recorded) + · exact Or.inr (Or.inl collision) + · exact Or.inr (Or.inr fresh) + +theorem frozen_target_fresh (C : PrimitiveOracle) (oldLog : PublicLog) + (auth : AuthenticLog C oldLog) (noCollision : ¬ OutputCollision oldLog) + (bytes : List Byte) (target : Digest32) (bound : bytes.length < 2^64) + (hits : hash C bytes = target) (absent : (bytes,target) ∉ records oldLog) : + FreshTarget C oldLog target (plan C bytes) := by + rcases frozen_target_alternative C oldLog auth bytes target bound hits with h | h | h + · exact False.elim (absent h) + · exact False.elim (noCollision h) + · exact h + +end Whir.PublicMerkleLog diff --git a/verification/whir/Whir/PublicMerkleProgram.lean b/verification/whir/Whir/PublicMerkleProgram.lean new file mode 100644 index 000000000..a28085c63 --- /dev/null +++ b/verification/whir/Whir/PublicMerkleProgram.lean @@ -0,0 +1,288 @@ +import Whir.PublicMerkleLog +import Whir.WHIRModeFinal + +/-! Ordinary Merkle hashing as actual public compression requests. Every chunk +is a verification-purpose primitive call. Ordered replay consumes the observed +answers, including arbitrary stateful simulator replies; it never evaluates a +hidden total hash or assumes repeated replies are consistent. -/ +namespace Whir.PublicMerkleProgram +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame + +variable {R S : Type} + +/-- Operational mode-program executions, with the complete public query/reply +trace. No reference oracle occurs in the relation. -/ +inductive Runs : Program R → List Observation → R → Prop where + | done (r : R) : Runs (.done r) [] r + | ask {q : Query} {next : Digest32 → Program R} {trace : List Observation} {r : R} + (answer : Digest32) : Runs (next answer) trace r → Runs (.ask q next) (⟨q,answer⟩ :: trace) r + +theorem runReal_runs (C : PrimitiveOracle) (iv : Digest32) (p : Program R) : + Runs p (runReal C iv p).view.observations (runReal C iv p).view.result := by + induction p with + | done r => exact .done r + | ask q next ih => exact .ask (realAnswer C iv q) (ih (realAnswer C iv q)) + +theorem runIdeal_runs {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + Runs p (runIdeal sim ro iv state p remaining cap counted).view.observations + (runIdeal sim ro iv state p remaining cap counted).view.result := by + induction p generalizing state remaining with + | done r => exact .done r + | ask q next ih => + cases q with + | primitive purpose input => + exact .ask (runRO ro (sim.answer state input)).1.2 + (ih _ (runRO ro (sim.answer state input)).1.1 (remaining-1) (by omega) (counted.2 _)) + | construction q valid => + exact .ask (ro (constructionKey Q iv q (counted.1.trans cap))) + (ih _ state (remaining-pathCost q) (by omega) (counted.2 _)) + +theorem Runs.bind_iff (p : Program R) (next : R → Program S) {trace : List Observation} {result : S} : + Runs (WHIRModeFinal.bind p next) trace result ↔ + ∃ before value after, trace = before ++ after ∧ Runs p before value ∧ Runs (next value) after result := by + induction p generalizing trace result with + | done r => + constructor + · intro h + exact ⟨[],r,trace,rfl,.done r,h⟩ + · rintro ⟨before,value,after,he,hp,hn⟩ + cases hp + simpa only [List.nil_append] using he ▸ hn + | ask q cont ih => + constructor + · intro h + cases h with + | ask answer h => + obtain ⟨before,value,after,he,hp,hn⟩ := (ih answer).mp h + exact ⟨⟨q,answer⟩ :: before,value,after,by simp [he],.ask answer hp,hn⟩ + · rintro ⟨before,value,after,he,hp,hn⟩ + cases hp with + | ask answer hp => + subst trace + exact .ask answer ((ih answer).mpr ⟨_,value,after,rfl,hp,hn⟩) + +theorem Runs.result_unique {p : Program R} {trace : List Observation} {a b : R} + (ha : Runs p trace a) (hb : Runs p trace b) : a = b := by + induction ha with + | done r => cases hb; rfl + | ask answer h ih => cases hb with | ask _ h' => exact ih h' + +/-- The impossible empty chunk-list branch is discharged by a proof, not a +fallback digest. Empty input itself has one final empty chunk. -/ +def hashFrom (cv : Digest32) (count : Nat) : (bs : List (List Byte)) → bs ≠ [] → Program Digest32 + | [], h => False.elim (h rfl) + | [b], _ => .ask (.primitive .verification (PublicMerkleLog.node cv count b true)) Program.done + | b :: next :: rest, _ => + .ask (.primitive .verification (PublicMerkleLog.node cv count b false)) fun answer => + hashFrom answer (count+b.length) (next :: rest) (by simp) + +/-- Close each 256-bit reply over stored bytes before it becomes another CV; +do not retain a function that recomputes the whole preceding hash chain. -/ +private def withStoredDigest {T : Type} (d : Digest32) (next : Digest32 → T) : T := + let bytes := Array.ofFn d + next (fun i => bytes[i.val]'(by simp only [bytes, Array.size_ofFn]; exact i.isLt)) + +private theorem withStoredDigest_eq {T : Type} (d : Digest32) (next : Digest32 → T) : + withStoredDigest d next = next d := by + simp [withStoredDigest] + +private def hashFromStored (cv : Digest32) (count : Nat) : + (bs : List (List Byte)) → bs ≠ [] → Program Digest32 + | [], h => False.elim (h rfl) + | [b], _ => .ask (.primitive .verification (PublicMerkleLog.node cv count b true)) + (fun answer => withStoredDigest answer Program.done) + | b :: next :: rest, _ => + .ask (.primitive .verification (PublicMerkleLog.node cv count b false)) fun answer => + withStoredDigest answer (fun cv => hashFromStored cv (count+b.length) (next :: rest) (by simp)) + +@[csimp] theorem hashFrom_stored : hashFrom = hashFromStored := by + funext cv count bs hne + induction bs generalizing cv count with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => simp only [hashFrom, hashFromStored, withStoredDigest_eq] + | cons next rest => + simp only [hashFrom, hashFromStored, withStoredDigest_eq, ih] + +def hash (bytes : List Byte) : Program Digest32 := + hashFrom DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) (PublicMerkleLog.chunks_nonempty bytes) + +theorem hashFrom_counted (cv : Digest32) (count : Nat) (bs : List (List Byte)) (hne : bs ≠ []) : + Counts bs.length (hashFrom cv count bs hne) := by + induction bs generalizing cv count with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => simp [hashFrom, Counts, Query.cost] + | cons next rest => + simp only [hashFrom, Counts, Query.cost, List.length_cons] + refine ⟨by omega, fun answer => ?_⟩ + simpa using ih answer (count+b.length) (by simp) + +theorem hash_counted (bytes : List Byte) : Counts (PublicMerkleLog.chunks bytes).length (hash bytes) := + hashFrom_counted _ _ _ _ + +theorem hash_bind_counted (bytes : List Byte) (next : Digest32 → Program R) (budget : Nat) + (after : ∀ d, Counts budget (next d)) : + Counts ((PublicMerkleLog.chunks bytes).length+budget) (WHIRModeFinal.bind (hash bytes) next) := + WHIRModeFinal.bind_counted _ _ _ _ (hash_counted bytes) after + +theorem hashFrom_real_run (C : PrimitiveOracle) (iv cv : Digest32) (count : Nat) + (bs : List (List Byte)) (hne : bs ≠ []) : + PublicMerkleLog.run (fun n => some (C n)) cv count bs = + some (runReal C iv (hashFrom cv count bs hne)).view.result := by + induction bs generalizing cv count with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => rfl + | cons next rest => + simpa only [PublicMerkleLog.run, Option.bind_eq_bind, Option.bind_some, + hashFrom, runReal, prepend, realAnswer] using ih (C (PublicMerkleLog.node cv count b false)) (count+b.length) (by simp) + +theorem hash_real_result (C : PrimitiveOracle) (iv : Digest32) (bytes : List Byte) : + (runReal C iv (hash bytes)).view.result = PublicMerkleLog.hash C bytes := by + unfold PublicMerkleLog.hash + rw [hashFrom_real_run C iv _ _ _ (PublicMerkleLog.chunks_nonempty bytes)] + rfl + +/-- The pure hash API uses the existing ordinary fold with eagerly stored +replies. Unlike evaluating a mode Program, this allocates no public trace. -/ +private def storedQuery (C : PrimitiveOracle) (n : Node) : Option Digest32 := + withStoredDigest (C n) Option.some + +private theorem storedQuery_eq (C : PrimitiveOracle) : + storedQuery C = (fun n => some (C n)) := by + funext n + exact withStoredDigest_eq _ _ + +def hashStored (C : PrimitiveOracle) (bytes : List Byte) : Digest32 := + let result := PublicMerkleLog.run (storedQuery C) DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) + result.get (by + dsimp only [result] + rw [storedQuery_eq] + obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) + (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 + rw [hd] + rfl) + +@[csimp] theorem ordinaryHash_stored : PublicMerkleLog.hash = hashStored := by + funext C bytes + obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) + (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 + simp only [PublicMerkleLog.hash, hashStored, storedQuery_eq, hd] + rfl + +def hashBlake2sStored : List Byte → Digest32 := hashStored blake2sOracle + +/-- Rewrite the imported wrapper as well: its previously compiled body must +not retain the old unstored fold. Neither implementation calls itself. -/ +@[csimp] theorem ordinaryBlake2s_stored : + PublicMerkleLog.hashBlake2s = hashBlake2sStored := by + exact congrFun ordinaryHash_stored blake2sOracle + +theorem hash_bind_real_result (C : PrimitiveOracle) (iv : Digest32) (bytes : List Byte) + (next : Digest32 → Program R) : + (runReal C iv (WHIRModeFinal.bind (hash bytes) next)).view.result = + (runReal C iv (next (PublicMerkleLog.hash C bytes))).view.result := by + rw [WHIRModeFinal.bind_real_result, hash_real_result] + +theorem hashFrom_real_observations (C : PrimitiveOracle) (iv cv : Digest32) (count : Nat) + (bs : List (List Byte)) (hne : bs ≠ []) : + (runReal C iv (hashFrom cv count bs hne)).view.observations = + (PublicMerkleLog.planFrom C cv count bs).map (fun e => ⟨.primitive .verification e.1,e.2⟩) := by + induction bs generalizing cv count with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => rfl + | cons next rest => + simpa only [hashFrom, runReal, prepend, realAnswer, PublicMerkleLog.planFrom, List.map_cons] using + congrArg (List.cons (⟨.primitive .verification (PublicMerkleLog.node cv count b false), + C (PublicMerkleLog.node cv count b false)⟩ : Observation)) + (ih (C (PublicMerkleLog.node cv count b false)) (count+b.length) (by simp)) + +theorem hash_real_observations (C : PrimitiveOracle) (iv : Digest32) (bytes : List Byte) : + (runReal C iv (hash bytes)).view.observations = + (PublicMerkleLog.plan C bytes).map (fun e => ⟨.primitive .verification e.1,e.2⟩) := + hashFrom_real_observations _ _ _ _ _ _ + +/-- Consume a literal public verification query, rejecting a missing record, +wrong purpose, wrong node, or construction observation. -/ +def readObservation (n : Node) : List Observation → Option (Digest32 × List Observation) + | ⟨.primitive .verification actual,answer⟩ :: rest => if actual = n then some (answer,rest) else none + | _ => none + +def replayFrom (cv : Digest32) (count : Nat) : List (List Byte) → List Observation → + Option (Digest32 × List Observation) + | [], _ => none + | [b], trace => readObservation (PublicMerkleLog.node cv count b true) trace + | b :: next :: rest, trace => do + let (answer,remaining) ← readObservation (PublicMerkleLog.node cv count b false) trace + replayFrom answer (count+b.length) (next :: rest) remaining + +def replay (bytes : List Byte) : List Observation → Option (Digest32 × List Observation) := + replayFrom DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) + +theorem hashFrom_replay {cv : Digest32} {count : Nat} {bs : List (List Byte)} {hne : bs ≠ []} + {trace : List Observation} {digest : Digest32} (run : Runs (hashFrom cv count bs hne) trace digest) + (suffix : List Observation) : replayFrom cv count bs (trace ++ suffix) = some (digest,suffix) := by + induction bs generalizing cv count trace digest with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => + cases run with + | ask answer h => + cases h + simp [replayFrom, readObservation] + | cons next rest => + cases run with + | ask answer h => + simpa only [replayFrom, List.cons_append, readObservation, ↓reduceIte, + Option.bind_eq_bind, Option.bind_some] using ih h + +theorem hash_replay {bytes : List Byte} {trace : List Observation} {digest : Digest32} + (run : Runs (hash bytes) trace digest) (suffix : List Observation) : + replay bytes (trace ++ suffix) = some (digest,suffix) := hashFrom_replay run suffix + +theorem hash_ideal_replay {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (bytes : List Byte) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining (hash bytes)) + (suffix : List Observation) : + replay bytes ((runIdeal sim ro iv state (hash bytes) remaining cap counted).view.observations ++ suffix) = + some ((runIdeal sim ro iv state (hash bytes) remaining cap counted).view.result,suffix) := + hash_replay (runIdeal_runs sim ro iv state _ remaining cap counted) suffix + +theorem hashFrom_trace {cv : Digest32} {count : Nat} {bs : List (List Byte)} {hne : bs ≠ []} + {trace : List Observation} {digest : Digest32} (run : Runs (hashFrom cv count bs hne) trace digest) : + trace.length = bs.length ∧ ∀ o ∈ trace, ∃ n, o.query = .primitive .verification n := by + induction bs generalizing cv count trace digest with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => + cases run with + | ask answer h => + cases h + simp + | cons next rest => + cases run with + | ask answer h => + obtain ⟨length,purpose⟩ := ih h + constructor + · simp [length] + · intro o ho + rcases List.mem_cons.mp ho with rfl | hm + · exact ⟨_,rfl⟩ + · exact purpose o hm + +theorem hash_trace {bytes : List Byte} {trace : List Observation} {digest : Digest32} + (run : Runs (hash bytes) trace digest) : + trace.length = (PublicMerkleLog.chunks bytes).length ∧ + ∀ o ∈ trace, ∃ n, o.query = .primitive .verification n := hashFrom_trace run + +end Whir.PublicMerkleProgram diff --git a/verification/whir/Whir/QueryBatchSoundness.lean b/verification/whir/Whir/QueryBatchSoundness.lean new file mode 100644 index 000000000..1f91b7110 --- /dev/null +++ b/verification/whir/Whir/QueryBatchSoundness.lean @@ -0,0 +1,240 @@ +import Whir.LevelBoundary +import Whir.BatchingRefinement +import Whir.RingMapBatching + +/-! A query vector and its adjacent batching scalar form one challenge message. +Authentication, not restrictions on the prover's adaptive response, fixes rows. -/ +namespace Whir.QueryBatchSoundness +open Concrete Protocol LevelBoundary BatchingRefinement +open scoped BigOperators + +set_option maxRecDepth 2048 +set_option maxHeartbeats 800000 +open Classical + +/-- Immutable scalar oracle after the preceding fold challenges. -/ +def oldWord (n rate : Nat) (root : Oracle) (base : Bool) (folds : Array E) + (q : Fin (2 ^ (n + rate))) : E := + dot (if base then root[q.val]!.reverse else root[q.val]!) (eqTable folds) + +/-- The actual sampler's output, retaining repeated indices and their order. -/ +def queries (depth count : Nat) (tape : QueryTape depth count) : Array Nat := + tab count fun j => SamplingProbability.concretePlace count depth j + (Layout.rawQuery depth (fun k => (Array.ofFn tape)[k]!.toNat) j) + +@[simp] theorem queries_size (depth count : Nat) (tape : QueryTape depth count) : + (queries depth count tape).size = count := ArrayLayout.size_tab _ _ + +theorem queries_actual (depth count : Nat) (tape : QueryTape depth count) + (hd : 0 < depth) (hb : depth ≤ 64) : + deriveQueries depth count (Array.ofFn tape) = some (queries depth count tape) := + SamplingProbability.deriveQueries_eq depth count hd hb tape + +theorem queries_bound (depth count : Nat) (tape : QueryTape depth count) + (j : Nat) (hj : j < count) : (queries depth count tape)[j]! < 2 ^ depth := by + rw [queries, ArrayLayout.getElem!_tab _ _ _ hj, + SamplingProbability.concretePlace_eq count depth ⟨j, hj⟩] + exact Layout.placeQuery_bound _ _ + +noncomputable def polynomial (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) + (tape : QueryTape (n + rate) count) (f : Array E) : Polynomial E := + errorPolynomial f n i cs + {p with rows := (queries (n + rate) count tape).map (fun q => root[q]!)} + (queries (n + rate) count tape) s + +/-- Acceptance guards remain inside the event: malformed responses are rejected, +not ruled out globally. Both response functions see the whole query tape and lambda. -/ +def Restores (n rate count i : Nat) (root : Oracle) (cs : LevelChallenges) + (p : LevelProof) (s : VerifierState E) (candidates : Finset (Array E)) + (rowsAt : QueryTape (n + rate) count → E → Oracle) + (introAt : QueryTape (n + rate) count → E → Message E) + (draw : QueryTape (n + rate) count × E) : Prop := + let qs := queries (n + rate) count draw.1 + let proof := {p with rows := rowsAt draw.1 draw.2, intro := introAt draw.1 draw.2} + let challenges := {cs with querySqueezes := Array.ofFn draw.1, lambda := draw.2} + proof.rows.size = qs.size ∧ + runChecked (authenticateRow root qs proof) qs.size 0 () = .ok () ∧ + ¬ VerifierInvariant.Lost candidates + (queryBatch n i challenges proof qs (oodBatch challenges proof s)) + +private theorem zero_hits (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) + (tape : QueryTape (n + rate) count) (f : Array E) + (hd : 0 < n + rate) (hb : n + rate ≤ 64) + (hz : polynomial n rate count i root cs p s tape f = 0) : + dot f s.weight = s.claim ∧ + (∀ j < p.oods.size, Concrete.mle f cs.oodPoints[j]! = p.oods[j]!.value) ∧ + SamplingProbability.allQueriesHit (n + rate) count + (agreeingColumns n rate f (oldWord n rate root (i == 0) cs.folds)) tape := by + have hc := congrArg (fun x : Polynomial E => x.coeff 0) hz + have residual : dot f s.weight = s.claim := by + simpa [polynomial, errorPolynomial, batchPolynomial_coeff_zero, discrepancy, + sub_eq_zero] using hc + refine ⟨residual, ?_, queries (n + rate) count tape, + queries_actual _ _ _ hd hb, ?_⟩ + · intro j hj + have hc := congrArg (fun x : Polynomial E => x.coeff (j+1)) hz + simpa only [polynomial, errorPolynomial, batchPolynomial_coeff_ood _ _ _ _ _ _ hj, + Polynomial.coeff_zero, oodError, Concrete.mle, sub_eq_zero] using hc + · intro j + have hc := congrArg (fun x : Polynomial E => x.coeff (p.oods.size+1+j.val)) hz + have hj : j.val < (queries (n + rate) count tape).size := by + rw [queries_size] + exact j.isLt + have he : queryError f n cs + {p with rows := (queries (n + rate) count tape).map (fun q => root[q]!)} + (queries (n + rate) count tape) (i == 0) j.val = 0 := by + simpa only [polynomial, errorPolynomial, + batchPolynomial_coeff_query _ _ _ _ _ _ hj, Polynomial.coeff_zero] using hc + classical + apply Finset.mem_image.mpr + refine ⟨⟨_, queries_bound _ _ _ _ j.isLt⟩, ?_, rfl⟩ + apply Finset.mem_filter.mpr + refine ⟨Finset.mem_univ _, ?_⟩ + change (encode n rate f)[(queries (n + rate) count tape)[j.val]!]! = _ + rw [encode, ArrayLayout.getElem!_tab _ _ _ (queries_bound _ _ _ _ j.isLt)] + simpa [queryError, oldWord, getElem!_pos, hj, sub_eq_zero] using he + +private theorem roots_cover_probability {F I : Type*} [Field F] [Fintype F] + [DecidableEq F] [Fintype I] (P : F → Prop) (errors : I → Polynomial F) (d : Nat) + (nonzero : ∀ f, errors f ≠ 0) (degree : ∀ f, (errors f).natDegree ≤ d) + (cover : ∀ r, P r → ∃ f, (errors f).eval r = 0) : + Soundness.uniformProb (Finset.univ.filter P) ≤ + (Fintype.card I : ℚ) * ((d : ℚ) / Fintype.card F) := by + classical + have subset : (Finset.univ.filter P) ⊆ + Finset.univ.biUnion (fun f => Finset.univ.filter fun r => (errors f).eval r = 0) := by + intro r hr + obtain ⟨f, hf⟩ := cover r (Finset.mem_filter.mp hr).2 + exact Finset.mem_biUnion.mpr + ⟨f, Finset.mem_univ _, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hf⟩⟩ + exact (div_le_div_of_nonneg_right + (by exact_mod_cast Finset.card_le_card subset) (by positivity)).trans + (Soundness.list_root_error errors d nonzero degree) + +private theorem fiber_bound (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) + (candidates : Finset (Array E)) + (rowsAt : QueryTape (n + rate) count → E → Oracle) + (introAt : QueryTape (n + rate) count → E → Message E) + (sizes : ∀ f ∈ candidates, f.size = 2 ^ n) + (weight : s.weight.size = 2 ^ n) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = 2 ^ n) + (tape : QueryTape (n + rate) count) + (nonzero : ∀ f ∈ candidates, polynomial n rate count i root cs p s tape f ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun r : E => + Restores n rate count i root cs p s candidates rowsAt introAt (tape, r)) ≤ + (candidates.card : ℚ) * ((p.oods.size + count : Nat) / (2 ^ 192 : ℚ)) := by + classical + have cover (r : E) + (hr : Restores n rate count i root cs p s candidates rowsAt introAt (tape, r)) : + ∃ f : candidates, (polynomial n rate count i root cs p s tape f.val).eval r = 0 := by + obtain ⟨rows, auth, lost⟩ := hr + simp only [VerifierInvariant.Lost, not_forall, not_not] at lost + obtain ⟨f, hf, truth⟩ := lost + refine ⟨⟨f, hf⟩, ?_⟩ + have identity := authenticated_batch_vary_lambda f n i cs p + (queries (n + rate) count tape) root s (rowsAt tape) (introAt tape) + (sizes f hf) (weight.trans (sizes f hf).symm) + (by intro j hj; exact (oods j hj).trans (sizes f hf).symm) r rows + ((OperationalRefinement.authentication_ok_iff _ _ _).mp auth) + change (errorPolynomial f n i cs + {p with rows := (queries (n + rate) count tape).map (fun q => root[q]!)} + (queries (n + rate) count tape) s).eval r = 0 + rw [← identity] + exact sub_eq_zero.mpr truth + have bound := roots_cover_probability + (fun r => Restores n rate count i root cs p s candidates rowsAt introAt (tape, r)) + (fun f : candidates => polynomial n rate count i root cs p s tape f.val) + (p.oods.size + count) (fun f => nonzero f.val f.property) + (by + intro f + simpa [polynomial] using errorPolynomial_degree f.val n i cs + {p with rows := (queries (n + rate) count tape).map (fun q => root[q]!)} + (queries (n + rate) count tape) s) cover + simpa only [Fintype.card_coe, FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] using bound + +/-- Actual grouped Lost transition at a separated earlier OOD point. No sampler, +root-count, or batching-correctness assertion is supplied as a premise. -/ +theorem grouped_transition (n rate count i threshold : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) + (candidates : Finset (Array E)) + (rowsAt : QueryTape (n + rate) count → E → Oracle) + (introAt : QueryTape (n + rate) count → E → Message E) + (alpha : ℚ) (ha : 0 ≤ alpha) + (ht : threshold = ⌈(2 ^ (n + rate) : ℚ) * alpha⌉₊) + (hd : 0 < n + rate) (hb : n + rate ≤ 64) + (sizes : ∀ f ∈ candidates, f.size = 2 ^ n) + (weight : s.weight.size = 2 ^ n) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = 2 ^ n) + (lost : CloseLost n rate threshold (oldWord n rate root (i == 0) cs.folds) s) + (j : Nat) (hj : j < p.oods.size) + (separated : Separated candidates cs.oodPoints[j]!) : + Soundness.uniformProb (Finset.univ.filter + (Restores n rate count i root cs p s candidates rowsAt introAt)) ≤ + alpha ^ count + (candidates.card : ℚ) * + ((p.oods.size + count : Nat) / (2 ^ 192 : ℚ)) := by + classical + let escape := queryEscape n rate count (oldWord n rate root (i == 0) cs.folds) + s candidates cs.oodPoints[j]! p.oods[j]!.value + apply RingMapBatching.conditional_error (fun tape => tape ∈ escape) _ _ _ (by positivity) + · simpa only [Finset.filter_mem_eq_inter, Finset.univ_inter] using + query_escape_probability n rate count threshold _ s candidates _ _ alpha ha ht hd hb + sizes lost separated + · intro tape outside + apply fiber_bound n rate count i root cs p s candidates rowsAt introAt sizes weight oods tape + intro f hf hz + obtain ⟨residual, ood, hits⟩ := zero_hits n rate count i root cs p s tape f hd hb hz + apply outside + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, f, hf, ood j hj, residual, hits⟩ + +/-- Final-level query escape for the already fixed residual. There is no OOD +message or auxiliary separation point in this event. -/ +theorem final_transition (n rate count i threshold : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) (f : Array E) + (rowsAt : QueryTape (n + rate) count → E → Oracle) + (introAt : QueryTape (n + rate) count → E → Message E) + (alpha : ℚ) (ha : 0 ≤ alpha) + (ht : threshold = ⌈(2 ^ (n + rate) : ℚ) * alpha⌉₊) + (hd : 0 < n + rate) (hb : n + rate ≤ 64) + (shape : f.size = 2 ^ n) (weight : s.weight.size = 2 ^ n) + (zeroOOD : p.oods.size = 0) + (lost : CloseLost n rate threshold (oldWord n rate root (i == 0) cs.folds) s) : + Soundness.uniformProb (Finset.univ.filter + (Restores n rate count i root cs p s {f} rowsAt introAt)) ≤ + alpha ^ count + (count : ℚ) / 2 ^ 192 := by + classical + let agree := agreeingColumns n rate f (oldWord n rate root (i == 0) cs.folds) + let escape : QueryTape (n + rate) count → Prop := fun tape => + dot f s.weight = s.claim ∧ SamplingProbability.allQueriesHit (n + rate) count agree tape + have escape_bound : Soundness.uniformProb (Finset.univ.filter escape) ≤ alpha ^ count := by + by_cases truth : dot f s.weight = s.claim + · have small : agree.card < threshold := by + apply Nat.lt_of_not_ge + intro close + exact lost f shape close truth + have density : (agree.card : ℚ) / (2 ^ (n + rate) : ℚ) ≤ alpha := by + apply (div_le_iff₀ (by positivity : (0 : ℚ) < 2 ^ (n + rate))).mpr + rw [ht] at small + have h := Nat.lt_ceil.mp small + nlinarith + have bound := SamplingProbability.actual_query_bound_rat (n + rate) count hd hb agree + simp only [Nat.cast_pow, Nat.cast_ofNat] at bound + simpa only [escape, truth, true_and] using + bound.trans (pow_le_pow_left₀ (by positivity) density count) + · simp only [escape, truth, false_and, Finset.filter_false, Soundness.uniformProb, + Finset.card_empty, Nat.cast_zero, zero_div] + exact pow_nonneg ha count + apply RingMapBatching.conditional_error escape _ _ _ (by positivity) escape_bound + intro tape outside + have bound := fiber_bound n rate count i root cs p s {f} rowsAt introAt + (by simpa using shape) weight (by simp [zeroOOD]) tape (by + intro g hg hz + have hgf : g = f := Finset.mem_singleton.mp hg + subst g + obtain ⟨residual, _, hits⟩ := zero_hits n rate count i root cs p s tape f hd hb hz + exact outside ⟨residual, hits⟩) + simpa [zeroOOD] using bound + +end Whir.QueryBatchSoundness diff --git a/verification/whir/Whir/QueryRefinement.lean b/verification/whir/Whir/QueryRefinement.lean new file mode 100644 index 000000000..187d619d6 --- /dev/null +++ b/verification/whir/Whir/QueryRefinement.lean @@ -0,0 +1,779 @@ +import Whir.ArrayAlgebra +import Whir.TerminalRefinement +import Whir.FieldExtension + +/-! Authenticated query rows refine the shared executable column kernel. + +`enforced_eq_foldLow` and `enforced_eq_foldLane` prove bilinear interchange +against the actual repeated folds, including the pruned L0 zero-padded layout. +The concrete encoder row formulas and every column dimension are proved here. + +`enforced_encodeExt` and `enforced_encodeBase` are unconditional identities +between the actual encoded/authenticated rows, actual folds, +`Protocol.enforced`, and `Concrete.induced`, under only shape/query bounds. +The ring laws come from the checked operation-compatible `FieldExtension` +instance. The reusable `Representation` transport also describes precisely +which arithmetic properties these identities use. Honest-query identities +alone do not establish PCS soundness. -/ +namespace Whir.QueryRefinement +open Concrete Protocol ArrayLayout ArrayAlgebra +open scoped BigOperators + +variable {R : Type*} [CommRing R] [Inhabited R] + +omit [Inhabited R] in + theorem tab_sum (n : Nat) (f : Nat → R) : + (tab n f).foldl (· + ·) 0 = ∑ i ∈ Finset.range n, f i := by + rw [← Array.foldl_toList, toList_tab, ← List.sum_eq_foldl, + ← List.sum_toFinset _ List.nodup_range] + congr 1 + ext i + simp + +@[simp] theorem size_inducedColumns (width : Nat) (cols : Array (Array R)) + (weights : Array R) : (inducedColumns width cols weights).size = width := by + simp [inducedColumns] + + theorem inducedColumns_get (width : Nat) (cols : Array (Array R)) + (weights : Array R) (j : Nat) (hj : j < width) : + (inducedColumns width cols weights)[j]! = + ∑ i ∈ Finset.range cols.size, weights[i]! * (cols[i]!)[j]! := by + simp only [inducedColumns, getElem!_tab _ _ _ hj, tab_sum] + +/-- Bilinear interchange for the actual weighted-column kernel. -/ + theorem dot_inducedColumns (f : Array R) (cols : Array (Array R)) (weights : Array R) + (shape : ∀ i < cols.size, cols[i]!.size = f.size) : + dot f (inducedColumns f.size cols weights) = + ∑ i ∈ Finset.range cols.size, weights[i]! * dot f cols[i]! := by + simp only [dot_eq_sum, size_inducedColumns, min_self] + have hget : ∀ j ∈ Finset.range f.size, + (inducedColumns f.size cols weights)[j]! = + ∑ i ∈ Finset.range cols.size, weights[i]! * (cols[i]!)[j]! := + fun j hj => inducedColumns_get _ _ _ _ (Finset.mem_range.mp hj) + simp only [Finset.sum_congr rfl (fun j hj => congrArg (f[j]! * ·) (hget j hj))] + simp_rw [Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro i hi + rw [shape i (Finset.mem_range.mp hi), min_self] + apply Finset.sum_congr rfl + intro j hj + ring + + theorem dot_tab_left (n : Nat) (f : Nat → R) (b : Array R) (h : n ≤ b.size) : + dot (tab n f) b = ∑ i ∈ Finset.range n, f i * b[i]! := by + simp only [dot_eq_sum, size_tab, Nat.min_eq_left h] + apply Finset.sum_congr rfl + intro i hi + rw [getElem!_tab _ _ _ (Finset.mem_range.mp hi)] + +/-- Swapping the lane and column sums, with all accesses in bounds. -/ + theorem dot_row_interchange (width lanes : Nat) (coeff : Nat → Nat → R) + (col eq : Array R) (hc : col.size = width) (he : lanes ≤ eq.size) : + dot (tab lanes fun lane => dot (tab width (coeff lane)) col) eq = + dot (tab width fun j => dot (tab lanes fun lane => coeff lane j) eq) col := by + simp only [dot_tab_left lanes _ eq he, + dot_tab_left width _ col (Nat.le_of_eq hc.symm)] + simp_rw [Finset.sum_mul] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro j hj + apply Finset.sum_congr rfl + intro lane hl + ring + +/-- The actual verifier's enforced scalar is the dot against its induced +query weights. `rows` are authenticated encoded rows, not a supplied scalar +correctness identity. L0 reversal and later low-lane order share this theorem. -/ + theorem enforced_eq_dot_inducedColumns + (width lanes : Nat) (coeff : Nat → Nat → R) + (cols rows : Array (Array R)) (rs weights : Array R) (base : Bool) + (count : rows.size = cols.size) + (columnShape : ∀ i < cols.size, cols[i]!.size = width) + (laneShape : lanes ≤ (eqTable rs).size) + (honest : ∀ i < rows.size, + (if base then rows[i]!.reverse else rows[i]!) = + tab lanes fun lane => dot (tab width (coeff lane)) cols[i]!) : + enforced rows rs weights base = + dot (tab width fun j => dot (tab lanes fun lane => coeff lane j) (eqTable rs)) + (inducedColumns width cols weights) := by + rw [enforced, tab_sum] + have hf : (tab width fun j => dot (tab lanes fun lane => coeff lane j) + (eqTable rs)).size = width := size_tab _ _ + have hd := dot_inducedColumns + (tab width fun j => dot (tab lanes fun lane => coeff lane j) (eqTable rs)) + cols weights (by simpa only [hf] using columnShape) + simp only [hf] at hd + rw [hd] + rw [count] + apply Finset.sum_congr rfl + intro i hi + rw [honest i (by simpa [count] using Finset.mem_range.mp hi)] + rw [dot_row_interchange width lanes coeff _ _ + (columnShape i (Finset.mem_range.mp hi)) laneShape] + +/-- Exact later-level encoder row: low coordinates select the lane. -/ +theorem encodeExt_row (message : Array E) (logN foldK rate q : Nat) + (hq : q < 2 ^ (logN - foldK + rate)) : + (encodeExt message logN foldK rate)[q]! = + tab (2 ^ foldK) fun lane => + dot (tab (2 ^ (logN - foldK)) fun j => message[j * 2 ^ foldK + lane]!) + (column (logN - foldK) q) := by + unfold encodeExt + rw [getElem!_tab _ _ _ hq] + apply Array.ext + · simp + · intro lane hl hr + simp only [size_tab] at hl + simp [tab, encode, getElem!_pos, hl, hq] + +/-- Exact L0 encoder row after undoing the transmitted descending lane order. -/ +theorem encodeBase_row (message : Array K) (logN initialK rate q : Nat) + (hq : q < 2 ^ (logN - initialK + rate)) : + ((encodeBase message logN initialK rate)[q]!).reverse = + tab (message.size / 2 ^ (logN - initialK)) fun lane => + dot (tab (2 ^ (logN - initialK)) fun j => + E.ofK message[lane * 2 ^ (logN - initialK) + j]!) + (column (logN - initialK) q) := by + unfold encodeBase + rw [getElem!_tab _ _ _ hq] + apply Array.ext + · simp + · intro i hi hj + simp only [Array.size_reverse, size_tab] at hi + have hi' : message.size / 2 ^ (logN - initialK) - 1 - + (message.size / 2 ^ (logN - initialK) - 1 - i) = i := by omega + simp [Array.getElem_reverse, tab, encode, getElem!_pos, hi', hi, hq] + +/-- A contiguous low-lane slice commutes with one actual adjacent fold. -/ +theorem foldLow_slice (a : Array R) (width lanes row : Nat) (r : R) + (ha : a.size = width * (lanes * 2)) (hr : row < width) : + (tab lanes fun lane => (foldLow a r)[row * lanes + lane]!) = + foldLow (tab (lanes * 2) fun lane => a[row * (lanes * 2) + lane]!) r := by + have half : a.size / 2 = width * lanes := by + rw [ha, ← Nat.mul_assoc, Nat.mul_div_left _ (by decide : 0 < 2)] + unfold foldLow + simp only [size_tab, Nat.mul_div_left _ (by decide : 0 < 2)] + apply Array.ext + · simp + · intro lane hl hr' + have hl' : lane < lanes := by simpa using hl + have hidx : row * lanes + lane < a.size / 2 := by + rw [half] + exact Layout.stackIndex_bound hr hl' + have h0 : 2 * lane < lanes * 2 := by omega + have h1 : 2 * lane + 1 < lanes * 2 := by omega + simp only [tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + change (tab (a.size / 2) fun i => foldPair a[2*i]! a[2*i+1]! r)[row * lanes + lane]! = + foldPair + ((tab (lanes * 2) fun i => a[row * (lanes * 2) + i]!)[2*lane]!) + ((tab (lanes * 2) fun i => a[row * (lanes * 2) + i]!)[2*lane+1]!) r + rw [getElem!_tab _ _ _ hidx, getElem!_tab _ _ _ h0, getElem!_tab _ _ _ h1] + rw [show 2 * (row * lanes + lane) = row * (lanes * 2) + 2 * lane by ring] + rw [show row * (lanes * 2) + 2 * lane + 1 = + row * (lanes * 2) + (2 * lane + 1) by omega] + +private theorem foldLow_blocks_list (point : List R) (a : Array R) (width : Nat) + (ha : a.size = width * 2 ^ point.length) : + point.foldl foldLow a = + tab width fun row => + Concrete.mle (tab (2 ^ point.length) fun lane => a[row * 2 ^ point.length + lane]!) + point.toArray := by + induction point generalizing a with + | nil => + apply Array.ext + · simpa using ha + · intro i hi hi' + have hia : i < a.size := hi + simp [tab, Concrete.mle, dot_eq_sum, + TerminalRefinement.eqTable_empty, getElem!_pos, hia] + | cons r point ih => + have hs : a.size = width * (2 ^ point.length * 2) := by + simpa only [List.length_cons, pow_succ] using ha + rw [List.foldl_cons, ih (foldLow a r) (by + simp only [size_foldLow, hs, ← Nat.mul_assoc, + Nat.mul_div_left _ (by decide : 0 < 2)])] + apply Array.ext + · simp + · intro row hr hr' + have hrw : row < width := by simpa using hr + simp only [tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + change Concrete.mle + (tab (2 ^ point.length) fun lane => (foldLow a r)[row * 2 ^ point.length + lane]!) + point.toArray = + Concrete.mle + (tab (2 ^ (r :: point).length) fun lane => a[row * 2 ^ (r :: point).length + lane]!) + (r :: point).toArray + rw [foldLow_slice a width (2 ^ point.length) row r hs hrw] + have hc := TerminalRefinement.mle_cons + (tab (2 ^ (r :: point).length) fun lane => a[row * 2 ^ (r :: point).length + lane]!) + point.toArray r (by simp) + have harr : (r :: point).toArray = #[r] ++ point.toArray := by simp + rw [harr] + simpa only [List.length_cons, pow_succ] using hc.symm + +/-- Actual repeated low-lane folds, not a replacement mathematical evaluator. -/ +theorem foldLow_blocks (a point : Array R) (width : Nat) + (ha : a.size = width * 2 ^ point.size) : + point.foldl foldLow a = + tab width fun row => + dot (tab (2 ^ point.size) fun lane => a[row * 2 ^ point.size + lane]!) + (eqTable point) := by + rw [← Array.foldl_toList] + simpa only [Array.length_toList, Array.toArray_toList, Concrete.mle] using + foldLow_blocks_list point.toList a width (by simpa using ha) + +/-- Gathering one column commutes with the actual top-lane fold. -/ +theorem foldLane_slice (a : Array R) (width lanes row : Nat) (r : R) + (ha : a.size = (lanes * 2) * width) (hr : row < width) : + (tab lanes fun lane => (foldLane a width r)[lane * width + row]!) = + foldLow (tab (lanes * 2) fun lane => a[lane * width + row]!) r := by + have half : a.size / 2 = lanes * width := by + rw [ha, Nat.mul_right_comm, Nat.mul_div_left _ (by decide : 0 < 2)] + unfold foldLane foldLow + simp only [size_tab, Nat.mul_div_left _ (by decide : 0 < 2)] + apply Array.ext + · simp + · intro lane hl hr' + have hl' : lane < lanes := by simpa using hl + have hidx : lane * width + row < a.size / 2 := by + rw [half] + exact Layout.stackIndex_bound hl' hr + have h0 : 2 * lane < lanes * 2 := by omega + have h1 : 2 * lane + 1 < lanes * 2 := by omega + simp only [tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + change (tab (a.size / 2) fun i => + foldPair a[(i / width) * (2 * width) + i % width]! + a[(i / width) * (2 * width) + i % width + width]! r)[lane * width + row]! = + foldPair ((tab (lanes * 2) fun i => a[i * width + row]!)[2*lane]!) + ((tab (lanes * 2) fun i => a[i * width + row]!)[2*lane+1]!) r + rw [getElem!_tab _ _ _ hidx, getElem!_tab _ _ _ h0, getElem!_tab _ _ _ h1] + rw [foldLane_offset hr] + simp only [Layout.stackIndex] + rw [show 2 * lane * width + row + width = (2 * lane + 1) * width + row by ring] + +private theorem foldLane_blocks_list (point : List R) (a : Array R) (width : Nat) + (ha : a.size = 2 ^ point.length * width) : + point.foldl (fun a r => foldLane a width r) a = + tab width fun row => + Concrete.mle (tab (2 ^ point.length) fun lane => a[lane * width + row]!) + point.toArray := by + induction point generalizing a with + | nil => + apply Array.ext + · simpa using ha + · intro i hi hi' + have hia : i < a.size := hi + simp [tab, Concrete.mle, dot_eq_sum, + TerminalRefinement.eqTable_empty, getElem!_pos, hia] + | cons r point ih => + have hs : a.size = (2 ^ point.length * 2) * width := by + simpa only [List.length_cons, pow_succ] using ha + rw [List.foldl_cons, ih (foldLane a width r) (by + simp only [size_foldLane, hs] + rw [Nat.mul_right_comm, Nat.mul_div_left _ (by decide : 0 < 2)])] + apply Array.ext + · simp + · intro row hr hr' + have hrw : row < width := by simpa using hr + simp only [tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + change Concrete.mle + (tab (2 ^ point.length) fun lane => (foldLane a width r)[lane * width + row]!) + point.toArray = + Concrete.mle + (tab (2 ^ (r :: point).length) fun lane => a[lane * width + row]!) + (r :: point).toArray + rw [foldLane_slice a width (2 ^ point.length) row r hs hrw] + have hc := TerminalRefinement.mle_cons + (tab (2 ^ (r :: point).length) fun lane => a[lane * width + row]!) + point.toArray r (by simp) + have harr : (r :: point).toArray = #[r] ++ point.toArray := by simp + rw [harr] + simpa only [List.length_cons, pow_succ] using hc.symm + +/-- Actual repeated L0 top-lane folds in the unchanged executable layout. -/ +theorem foldLane_blocks (a point : Array R) (width : Nat) + (ha : a.size = 2 ^ point.size * width) : + point.foldl (fun a r => foldLane a width r) a = + tab width fun row => + dot (tab (2 ^ point.size) fun lane => a[lane * width + row]!) + (eqTable point) := by + rw [← Array.foldl_toList] + simpa only [Array.length_toList, Array.toArray_toList, Concrete.mle] using + foldLane_blocks_list point.toList a width (by simpa using ha) + +/-- Later authenticated rows imply the exact executable query update on the +folded witness; there is no scalar-correctness premise. -/ +theorem enforced_eq_foldLow + (a : Array R) (width : Nat) (cols rows : Array (Array R)) (rs weights : Array R) + (shape : a.size = width * 2 ^ rs.size) + (count : rows.size = cols.size) + (columnShape : ∀ i < cols.size, cols[i]!.size = width) + (honest : ∀ i < rows.size, rows[i]! = + tab (2 ^ rs.size) fun lane => + dot (tab width fun j => a[j * 2 ^ rs.size + lane]!) cols[i]!) : + enforced rows rs weights false = + dot (rs.foldl foldLow a) (inducedColumns width cols weights) := by + rw [foldLow_blocks a rs width shape] + exact enforced_eq_dot_inducedColumns width (2 ^ rs.size) + (fun lane j => a[j * 2 ^ rs.size + lane]!) cols rows rs weights false + count columnShape (by simp [TerminalRefinement.size_eqTable]) (by simpa using honest) + +theorem dot_tab_zero_tail (full live : Nat) (f : Nat → R) (b : Array R) + (hl : live ≤ full) (hb : full ≤ b.size) + (hz : ∀ i, live ≤ i → i < full → f i = 0) : + dot (tab full f) b = dot (tab live f) b := by + rw [dot_tab_left full f b hb, dot_tab_left live f b (hl.trans hb)] + symm + apply Finset.sum_subset (Finset.range_mono hl) + intro i hi hn + rw [hz i (by simpa using hn) (Finset.mem_range.mp hi), zero_mul] + +/-- L0 permits a pruned occupied prefix. The actual witness is zero padded; +authenticated descending rows are reversed by `enforced`, not by an oracle +correctness assumption. -/ +theorem enforced_eq_foldLane + (a : Array R) (width live : Nat) (cols rows : Array (Array R)) (rs weights : Array R) + (shape : a.size = 2 ^ rs.size * width) + (count : rows.size = cols.size) + (columnShape : ∀ i < cols.size, cols[i]!.size = width) + (liveBound : live ≤ 2 ^ rs.size) + (zeroTail : ∀ lane, live ≤ lane → lane < 2 ^ rs.size → + ∀ j < width, a[lane * width + j]! = 0) + (honest : ∀ i < rows.size, (rows[i]!).reverse = + tab live fun lane => dot (tab width fun j => a[lane * width + j]!) cols[i]!) : + enforced rows rs weights true = + dot (rs.foldl (fun a r => foldLane a width r) a) (inducedColumns width cols weights) := by + rw [foldLane_blocks a rs width shape] + have htab : + (tab width fun j => dot (tab (2 ^ rs.size) fun lane => a[lane * width + j]!) + (eqTable rs)) = + (tab width fun j => dot (tab live fun lane => a[lane * width + j]!) + (eqTable rs)) := by + apply Array.ext + · simp + · intro j hj hj' + have hjw : j < width := by simpa using hj + simp only [tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + exact dot_tab_zero_tail _ _ _ _ liveBound + (by simp [TerminalRefinement.size_eqTable]) + (fun lane hl hf => zeroTail lane hl hf j hjw) + rw [htab] + exact enforced_eq_dot_inducedColumns width live + (fun lane j => a[lane * width + j]!) cols rows rs weights true + count columnShape (by simpa [TerminalRefinement.size_eqTable] using liveBound) + (by simpa using honest) + +private theorem normalized_loop_size (xs : List Nat) (roots : Array K) + (state : Array K × K) : + (xs.foldl (fun state i => + (state.1.push (kmul state.2 (kinv roots[i]!)), + kmul state.2 (state.2 ^^^ roots[i]!))) state).1.size = + state.1.size + xs.length := by + induction xs generalizing state with + | nil => simp + | cons i xs ih => + simp only [List.foldl_cons, ih, Array.size_push, List.length_cons] + omega + +/-- Dimensions of the actual normalized-subspace loop need no field laws. -/ +@[simp] theorem size_normalizedSubspaces (n : Nat) (x : K) : + (normalizedSubspaces n x).size = n := by + unfold normalizedSubspaces + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size] + simp only [Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + change ((List.range n).foldl (fun state i => + (state.1.push (kmul state.2 (kinv (subspaceRoots n)[i]!)), + kmul state.2 (state.2 ^^^ (subspaceRoots n)[i]!))) (#[], x)).1.size = n + rw [normalized_loop_size] + simp + +private theorem column_loop_size (xs : List K) (a : Array E) : + (xs.foldl (fun out s => out ++ out.map (fun x => x.scale s)) a).size = + a.size * 2 ^ xs.length := by + induction xs generalizing a with + | nil => simp + | cons x xs ih => + simp only [List.foldl_cons, ih, Array.size_append, Array.size_map, List.length_cons, + pow_succ] + ring + +/-- Exact column dimension, independent of the unproved machine field laws. -/ +@[simp] theorem size_column (n q : Nat) : (column n q).size = 2 ^ n := by + unfold column + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + change ((normalizedSubspaces n (UInt64.ofNat q)).foldl + (fun out s => out ++ out.map (fun x => x.scale s)) #[E.one]).size = _ + rw [← Array.foldl_toList, column_loop_size] + simp + +@[simp] theorem size_induced (n : Nat) (queries : Array Nat) (weights : Array E) : + (induced n queries weights).size = 2 ^ n := by + simp [induced, inducedColumns] + +@[simp] theorem size_encodeBase (message : Array K) (logN initialK rate : Nat) : + (encodeBase message logN initialK rate).size = 2 ^ (logN - initialK + rate) := by + simp [encodeBase] + +@[simp] theorem size_encodeExt (message : Array E) (logN foldK rate : Nat) : + (encodeExt message logN foldK rate).size = 2 ^ (logN - foldK + rate) := by + simp [encodeExt] + +/-- An algebraic interpretation of the *actual* machine operations. Providing +this structure is the separate machine-field obligation, not a query identity. +Default preservation also makes transport valid for malformed array accesses. -/ +structure Representation (R : Type*) [CommRing R] [Inhabited R] where + map : E → R + injective : Function.Injective map + zero : map (0 : E) = 0 + one : map (1 : E) = 1 + add : ∀ a b, map (a + b) = map a + map b + mul : ∀ a b, map (a * b) = map a * map b + default : map (default : E) = (default : R) + +namespace Representation +variable (ρ : Representation R) + +private theorem map_tab {A B : Type*} (f : A → B) (n : Nat) (g : Nat → A) : + (tab n g).map f = tab n (fun i => f (g i)) := by + simp [tab, Array.map_map, Function.comp_def] + +private theorem map_get {A B : Type*} [Inhabited A] [Inhabited B] + (f : A → B) (hd : f Inhabited.default = Inhabited.default) (a : Array A) (i : Nat) : + (a.map f)[i]! = f a[i]! := by + by_cases hi : i < a.size + · simp [getElem!_pos, hi] + · simp [getElem!_neg, hi, hd] + +private theorem map_add_fold (a : Array E) (init : E) : + ρ.map (a.foldl (· + ·) init) = (a.map ρ.map).foldl (· + ·) (ρ.map init) := by + rw [← Array.foldl_toList, ← Array.foldl_toList, Array.toList_map, List.foldl_map] + generalize a.toList = xs + induction xs generalizing init with + | nil => rfl + | cons x xs ih => + simp only [List.foldl_cons, ih] + congr 1 + exact ρ.add init x + +/-- Transport of the shared dot kernel, including truncation. -/ +theorem map_dot (a b : Array E) : + ρ.map (dot a b) = dot (a.map ρ.map) (b.map ρ.map) := by + unfold dot + rw [map_add_fold, ρ.zero, map_tab] + simp only [Array.size_map] + apply congrArg (fun g : Nat → R => (tab (min a.size b.size) g).foldl (· + ·) 0) + funext i + rw [map_get ρ.map ρ.default, map_get ρ.map ρ.default] + exact ρ.mul _ _ + +private theorem map_table_loop (xs : List E) (a : Array E) : + (xs.foldl (fun out r => out.map (fun x => x * (1 + r)) ++ out.map (fun x => x * r)) a).map ρ.map = + (xs.map ρ.map).foldl + (fun out r => out.map (fun x => x * (1 + r)) ++ out.map (fun x => x * r)) + (a.map ρ.map) := by + induction xs generalizing a with + | nil => rfl + | cons r xs ih => + simp only [List.foldl_cons, List.map_cons, ih] + congr 1 + simp only [Array.map_append, Array.map_map, Function.comp_def] + congr 1 <;> congr 1 <;> funext x + · exact (ρ.mul x (1 + r)).trans + (congrArg (ρ.map x * ·) ((ρ.add 1 r).trans (by rw [ρ.one]))) + · exact ρ.mul x r + +theorem map_eqTable (point : Array E) : + (eqTable point).map ρ.map = eqTable (point.map ρ.map) := by + unfold eqTable + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + rw [← Array.foldl_toList, ← Array.foldl_toList, Array.toList_map] + change (point.toList.foldl + (fun out r => out.map (fun x => x * (1 + r)) ++ out.map (fun x => x * r)) #[1]).map ρ.map = + (point.toList.map ρ.map).foldl + (fun out r => out.map (fun x => x * (1 + r)) ++ out.map (fun x => x * r)) #[1] + rw [map_table_loop] + simp only [Array.map_singleton, ρ.one] + +theorem map_foldPair (a b r : E) : + ρ.map (foldPair a b r) = foldPair (ρ.map a) (ρ.map b) (ρ.map r) := by + unfold foldPair + exact (ρ.add a (r * (a + b))).trans (by + rw [ρ.mul, ρ.add]) + +theorem map_foldLow (a : Array E) (r : E) : + (foldLow a r).map ρ.map = foldLow (a.map ρ.map) (ρ.map r) := by + unfold foldLow + rw [map_tab] + simp only [Array.size_map] + congr 1 + funext i + rw [map_foldPair, map_get ρ.map ρ.default, map_get ρ.map ρ.default] + +theorem map_foldLane (a : Array E) (width : Nat) (r : E) : + (foldLane a width r).map ρ.map = foldLane (a.map ρ.map) width (ρ.map r) := by + unfold foldLane + rw [map_tab] + simp only [Array.size_map] + congr 1 + funext i + rw [map_foldPair, map_get ρ.map ρ.default, map_get ρ.map ρ.default] + +theorem map_inducedColumns (width : Nat) (cols : Array (Array E)) (weights : Array E) : + (inducedColumns width cols weights).map ρ.map = + inducedColumns width (cols.map (Array.map ρ.map)) (weights.map ρ.map) := by + unfold inducedColumns + rw [map_tab] + simp only [Array.size_map] + congr 1 + funext j + rw [map_add_fold, ρ.zero, map_tab] + apply congrArg (fun g : Nat → R => (tab cols.size g).foldl (· + ·) 0) + funext i + rw [map_get ρ.map ρ.default, map_get (Array.map ρ.map) + (by change (#[] : Array E).map ρ.map = #[]; simp), + map_get ρ.map ρ.default] + exact ρ.mul _ _ + +theorem map_enforced (rows : Array (Array E)) (rs weights : Array E) (base : Bool) : + ρ.map (enforced rows rs weights base) = + enforced (rows.map (Array.map ρ.map)) (rs.map ρ.map) (weights.map ρ.map) base := by + unfold enforced + rw [map_add_fold, ρ.zero, map_tab] + simp only [Array.size_map] + apply congrArg (fun g : Nat → R => (tab rows.size g).foldl (· + ·) 0) + funext i + rw [map_get ρ.map ρ.default] + rw [ρ.mul, map_dot, map_eqTable, map_get (Array.map ρ.map) + (by change (#[] : Array E).map ρ.map = #[]; simp)] + congr 2 + cases base <;> simp [Array.map_reverse] + +private theorem map_get_row (rows : Array (Array E)) (i : Nat) : + (rows.map (Array.map ρ.map))[i]! = (rows[i]!).map ρ.map := + map_get _ (by change (#[] : Array E).map ρ.map = #[]; simp) _ _ + +private theorem map_steps (xs : List E) (a : Array E) + (step : Array E → E → Array E) (stepR : Array R → R → Array R) + (hstep : ∀ a r, (step a r).map ρ.map = stepR (a.map ρ.map) (ρ.map r)) : + (xs.foldl step a).map ρ.map = + (xs.map ρ.map).foldl stepR (a.map ρ.map) := by + induction xs generalizing a with + | nil => rfl + | cons r xs ih => simp only [List.foldl_cons, List.map_cons, ih, hstep] + +theorem map_foldLow_many (a rs : Array E) : + (rs.foldl foldLow a).map ρ.map = + (rs.map ρ.map).foldl foldLow (a.map ρ.map) := by + rw [← Array.foldl_toList, ← Array.foldl_toList, Array.toList_map] + exact map_steps ρ _ _ _ _ (map_foldLow ρ) + +theorem map_foldLane_many (a rs : Array E) (width : Nat) : + (rs.foldl (fun a r => foldLane a width r) a).map ρ.map = + (rs.map ρ.map).foldl (fun a r => foldLane a width r) (a.map ρ.map) := by + rw [← Array.foldl_toList, ← Array.foldl_toList, Array.toList_map] + exact map_steps ρ _ _ _ _ (fun a r => map_foldLane ρ a width r) + +include ρ in +/-- The concrete low-lane query identity, conditional only on an algebraic +interpretation of the real machine operations and honest encoded rows. -/ +theorem enforced_eq_foldLow + (a : Array E) (width : Nat) (cols rows : Array (Array E)) (rs weights : Array E) + (shape : a.size = width * 2 ^ rs.size) + (count : rows.size = cols.size) + (columnShape : ∀ i < cols.size, cols[i]!.size = width) + (honest : ∀ i < rows.size, rows[i]! = + tab (2 ^ rs.size) fun lane => + dot (tab width fun j => a[j * 2 ^ rs.size + lane]!) cols[i]!) : + enforced rows rs weights false = + dot (rs.foldl foldLow a) (inducedColumns width cols weights) := by + apply ρ.injective + rw [map_enforced, map_dot, map_foldLow_many, map_inducedColumns] + apply Whir.QueryRefinement.enforced_eq_foldLow + · simpa using shape + · simpa using count + · intro i hi + rw [map_get_row, Array.size_map] + exact columnShape i (by simpa using hi) + · intro i hi + have hi' : i < rows.size := by simpa using hi + rw [map_get_row, honest i hi', map_tab, map_get_row] + simp only [Array.size_map] + congr 1 + funext lane + rw [map_dot, map_tab] + congr 2 + funext j + exact (map_get ρ.map ρ.default a _).symm + +include ρ in +/-- The concrete L0 identity, with the actual reverse and actual top-lane +folds. Only zero padding, encoded-row formulas and representation laws enter. -/ +theorem enforced_eq_foldLane + (a : Array E) (width live : Nat) (cols rows : Array (Array E)) (rs weights : Array E) + (shape : a.size = 2 ^ rs.size * width) + (count : rows.size = cols.size) + (columnShape : ∀ i < cols.size, cols[i]!.size = width) + (liveBound : live ≤ 2 ^ rs.size) + (zeroTail : ∀ lane, live ≤ lane → lane < 2 ^ rs.size → + ∀ j < width, a[lane * width + j]! = 0) + (honest : ∀ i < rows.size, (rows[i]!).reverse = + tab live fun lane => dot (tab width fun j => a[lane * width + j]!) cols[i]!) : + enforced rows rs weights true = + dot (rs.foldl (fun a r => foldLane a width r) a) (inducedColumns width cols weights) := by + apply ρ.injective + rw [map_enforced, map_dot, map_foldLane_many, map_inducedColumns] + apply Whir.QueryRefinement.enforced_eq_foldLane _ _ live + · simpa using shape + · simpa using count + · intro i hi + rw [map_get_row, Array.size_map] + exact columnShape i (by simpa using hi) + · simpa using liveBound + · intro lane hl hf j hj + rw [map_get ρ.map ρ.default, zeroTail lane hl (by simpa using hf) j hj, ρ.zero] + · intro i hi + have hi' : i < rows.size := by simpa using hi + rw [map_get_row, ← Array.map_reverse, honest i hi', map_tab, map_get_row] + congr 1 + funext lane + rw [map_dot, map_tab] + congr 2 + funext j + exact (map_get ρ.map ρ.default a _).symm + +private theorem get_map_valid {A B : Type*} [Inhabited A] [Inhabited B] + (f : A → B) (a : Array A) (i : Nat) (hi : i < a.size) : + (a.map f)[i]! = f a[i]! := by + simp [getElem!_pos, hi] + +include ρ in +/-- Direct actual later-level encoder/query/fold correspondence. The only +algebraic dependency is `ρ`; rows and columns are the executable definitions, +not supplied evaluations or oracle-correctness identities. -/ +theorem enforced_encodeExt (a : Array E) (logN foldK rate : Nat) + (queries : Array Nat) (rs weights : Array E) + (folds : rs.size = foldK) + (shape : a.size = 2 ^ (logN - foldK) * 2 ^ foldK) + (queryBound : ∀ i < queries.size, queries[i]! < 2 ^ (logN - foldK + rate)) : + enforced (queries.map fun q => (encodeExt a logN foldK rate)[q]!) rs weights false = + dot (rs.foldl foldLow a) (induced (logN - foldK) queries weights) := by + apply enforced_eq_foldLow ρ a (2 ^ (logN - foldK)) (queries.map (column (logN - foldK))) + · simpa only [folds] using shape + · simp + · intro i hi + rw [get_map_valid _ _ _ (by simpa using hi)] + exact size_column _ _ + · intro i hi + have hiq : i < queries.size := by simpa using hi + rw [get_map_valid _ _ _ hiq, encodeExt_row _ _ _ _ _ (queryBound i hiq)] + simp only [folds] + rw [get_map_valid _ _ _ hiq] + +include ρ in +/-- Direct actual L0 encoder/query/fold correspondence, including a pruned +occupied prefix and the prover's exact `getD 0` padding construction. -/ +theorem enforced_encodeBase (message : Array K) (logN initialK rate : Nat) + (queries : Array Nat) (rs weights : Array E) + (folds : rs.size = initialK) (foldBound : initialK ≤ logN) + (shape : message.size = + (message.size / 2 ^ (logN - initialK)) * 2 ^ (logN - initialK)) + (liveBound : message.size / 2 ^ (logN - initialK) ≤ 2 ^ initialK) + (queryBound : ∀ i < queries.size, + queries[i]! < 2 ^ (logN - initialK + rate)) : + let padded := tab (2 ^ logN) fun i => E.ofK (message[i]?.getD 0) + enforced (queries.map fun q => (encodeBase message logN initialK rate)[q]!) rs weights true = + dot (rs.foldl (fun a r => foldLane a (2 ^ (logN - initialK)) r) padded) + (induced (logN - initialK) queries weights) := by + dsimp only + let padded := tab (2 ^ logN) fun i => E.ofK (message[i]?.getD 0) + have hp : 2 ^ logN = 2 ^ initialK * 2 ^ (logN - initialK) := by + rw [← pow_add] + congr 1 + omega + have hg (i : Nat) (hi : i < 2 ^ logN) : + padded[i]! = E.ofK message[i]! := by + rw [getElem!_tab _ _ _ hi] + by_cases him : i < message.size + · simp [getElem?_pos, getElem!_pos, him] + · simp only [getElem?_neg message i him, Option.getD_none, getElem!_neg message i him] + rfl + apply enforced_eq_foldLane ρ padded (2 ^ (logN - initialK)) + (message.size / 2 ^ (logN - initialK)) (queries.map (column (logN - initialK))) + · simpa only [padded, size_tab, folds] using hp + · simp + · intro i hi + rw [get_map_valid _ _ _ (by simpa using hi)] + exact size_column _ _ + · simpa only [folds] using liveBound + · intro lane hl hf j hj + have hidx : lane * 2 ^ (logN - initialK) + j < 2 ^ logN := by + rw [hp] + exact Layout.stackIndex_bound (by simpa only [folds] using hf) hj + rw [getElem!_tab _ _ _ hidx] + have hn : ¬lane * 2 ^ (logN - initialK) + j < message.size := by + have hm := Nat.mul_le_mul_right (2 ^ (logN - initialK)) hl + omega + simp only [getElem?_neg message (lane * 2 ^ (logN - initialK) + j) hn, Option.getD_none] + rfl + · intro i hi + have hiq : i < queries.size := by simpa using hi + rw [get_map_valid _ _ _ hiq, encodeBase_row _ _ _ _ _ (queryBound i hiq), + get_map_valid _ _ _ hiq] + apply Array.ext + · simp + · intro lane hl hr + have hll : lane < message.size / 2 ^ (logN - initialK) := by simpa using hl + simp only [tab, Array.getElem_map, List.getElem_toArray, List.getElem_range] + apply congrArg (fun coeff => dot coeff (column (logN - initialK) queries[i]!)) + apply Array.ext + · simp + · intro j hj hj' + have hjw : j < 2 ^ (logN - initialK) := by simpa using hj + simp only [Array.getElem_map, List.getElem_toArray, List.getElem_range] + exact (hg _ (by rw [hp]; exact Layout.stackIndex_bound (hll.trans_le liveBound) hjw)).symm + +end Representation + +/-- The operation-compatible ring laws proved in `FieldExtension` discharge +the algebraic interpretation boundary without assuming a query identity. -/ +def concreteRepresentation : Representation E where + map := id + injective := Function.injective_id + zero := rfl + one := rfl + add _ _ := rfl + mul _ _ := rfl + default := rfl + +/-- Actual later-level query correspondence with no remaining algebraic +premise: the columns and encoded rows are the executable definitions. -/ +theorem enforced_encodeExt (a : Array E) (logN foldK rate : Nat) + (queries : Array Nat) (rs weights : Array E) + (folds : rs.size = foldK) + (shape : a.size = 2 ^ (logN - foldK) * 2 ^ foldK) + (queryBound : ∀ i < queries.size, queries[i]! < 2 ^ (logN - foldK + rate)) : + enforced (queries.map fun q => (encodeExt a logN foldK rate)[q]!) rs weights false = + dot (rs.foldl foldLow a) (induced (logN - foldK) queries weights) := + Representation.enforced_encodeExt concreteRepresentation a logN foldK rate + queries rs weights folds shape queryBound + +/-- Actual initial query correspondence, including pruned reversed rows and +the exact padded witness construction, with all ring laws discharged. -/ +theorem enforced_encodeBase (message : Array K) (logN initialK rate : Nat) + (queries : Array Nat) (rs weights : Array E) + (folds : rs.size = initialK) (foldBound : initialK ≤ logN) + (shape : message.size = + (message.size / 2 ^ (logN - initialK)) * 2 ^ (logN - initialK)) + (liveBound : message.size / 2 ^ (logN - initialK) ≤ 2 ^ initialK) + (queryBound : ∀ i < queries.size, + queries[i]! < 2 ^ (logN - initialK + rate)) : + let padded := tab (2 ^ logN) fun i => E.ofK (message[i]?.getD 0) + enforced (queries.map fun q => (encodeBase message logN initialK rate)[q]!) rs weights true = + dot (rs.foldl (fun a r => foldLane a (2 ^ (logN - initialK)) r) padded) + (induced (logN - initialK) queries weights) := + Representation.enforced_encodeBase concreteRepresentation message logN initialK rate + queries rs weights folds foldBound shape liveBound queryBound + +end Whir.QueryRefinement diff --git a/verification/whir/Whir/RawOracleCoupling.lean b/verification/whir/Whir/RawOracleCoupling.lean new file mode 100644 index 000000000..f88a159f5 --- /dev/null +++ b/verification/whir/Whir/RawOracleCoupling.lean @@ -0,0 +1,471 @@ +import Whir.TypedOracleCompiler + +/-! Exact finite-table coupling for causal, globally memoized oracle programs. -/ +namespace Whir.RawOracleCoupling +open TypedOracleCompiler TypedFiatShamirGame +open FiatShamirGame (average) +open scoped BigOperators + +universe u v w + + theorem average_equiv {X Y : Type*} [Fintype X] [Fintype Y] + (e : X ≃ Y) (f : Y → ℚ) : average (fun x => f (e x)) = average f := by + unfold average + rw [Fintype.sum_equiv e _ _ (fun _ => rfl), Fintype.card_congr e] + + theorem average_comm {X Y : Type*} [Fintype X] [Fintype Y] + (f : X → Y → ℚ) : + average (fun x => average (f x)) = average (fun y => average (fun x => f x y)) := by + unfold average + simp only [← Finset.sum_div] + rw [Finset.sum_comm] + ring + +section Memo +variable {Key : Type u} {Answer : Key → Type v} {R : Type w} +variable [DecidableEq Key] + +def overlay (cache : Cache Key Answer) (table : (k : Key) → Answer k) : + (k : Key) → Answer k := fun k => (cache k).getD (table k) + +omit [DecidableEq Key] in +@[simp] theorem overlay_empty (table : (k : Key) → Answer k) : + overlay (fun _ => none) table = table := rfl + + theorem overlay_put (cache : Cache Key Answer) (table : (k : Key) → Answer k) + (k : Key) (a : Answer k) : + overlay (put cache k a) table = Function.update (overlay cache table) k a := by + funext j + by_cases h : j = k + · subst j; simp [overlay] + · simp [overlay, put_other, h] + +/-- The cache is private interpreter state. Continuations receive exactly their +requested answer, including every bit of a requested padded block. -/ +def memo {n} : Sampling Key Answer R n → Cache Key Answer → + Sampling Key Answer (R × Cache Key Answer) n + | .ret r, cache => .ret (r, cache) + | .draw k next, cache => + match cache k with + | some a => Sampling.pad (Nat.le_succ _) (memo (next a) cache) + | none => .draw k (fun a => memo (next a) (put cache k a)) + +theorem overlay_put_miss (cache : Cache Key Answer) (table : (k : Key) → Answer k) + (k : Key) (miss : cache k = none) : + overlay (put cache k (table k)) table = overlay cache table := by + funext j + by_cases h : j = k + · subst j; simp [overlay, miss] + · simp [overlay, put_other, h] + +theorem memo_eval_first {n} (p : Sampling Key Answer R n) (cache : Cache Key Answer) + (table : (k : Key) → Answer k) : + (Sampling.eval table (memo p cache)).1 = Sampling.eval (overlay cache table) p := by + induction p generalizing cache with + | ret r => rfl + | draw k next ih => + cases hit : cache k with + | some a => simp [memo, hit, ih, Sampling.eval, overlay] + | none => + simp only [memo, hit, Sampling.eval, ih, overlay_put_miss cache table k hit] + simp [overlay, hit] + +theorem memo_eval_consistent {n} (p : Sampling Key Answer R n) + (cache : Cache Key Answer) (table : (k : Key) → Answer k) + (consistent : ∀ k a, cache k = some a → table k = a) : + ∀ k a, (Sampling.eval table (memo p cache)).2 k = some a → table k = a := by + induction p generalizing cache with + | ret r => exact consistent + | draw k next ih => + cases hit : cache k with + | some a => + simpa only [memo, hit, Sampling.eval_pad] using ih a cache consistent + | none => + simp only [memo, hit, Sampling.eval] + apply ih (table k) + intro j a ha + by_cases h : j = k + · subst j; simpa only [put_self, Option.some.injEq] using ha + · exact consistent j a (by simpa only [put_other _ _ _ _ h] using ha) + +variable [Fintype Key] [∀ k, Fintype (Answer k)] [∀ k, Nonempty (Answer k)] + + theorem average_update (k : Key) (f : ((j : Key) → Answer j) → ℚ) : + average f = average (fun a : Answer k => + average (fun table : (j : Key) → Answer j => f (Function.update table k a))) := by + classical + let e := Equiv.piSplitAt k Answer + have split (g : ((j : Key) → Answer j) → ℚ) : + average g = average (fun rest : (j : {j : Key // j ≠ k}) → Answer j => + average (fun a : Answer k => g (e.symm (a, rest)))) := by + have h := TypedFiatShamirGame.fresh_coordinate k + (fun rest a => g (e.symm (a, rest))) + change average (fun table => g (e.symm (e table))) = _ at h + simpa only [e.symm_apply_apply] using h + rw [split f] + rw [average_comm] + apply congrArg average + funext a + rw [split] + apply congrArg average + funext rest + have hu (b : Answer k) : Function.update (e.symm (b, rest)) k a = e.symm (a, rest) := by + apply e.injective + apply Prod.ext + · simp [e] + · funext j; simp [e, j.property] + simp only [hu] + exact (FiatShamirGame.average_const _).symm + + + theorem overlay_average (cache : Cache Key Answer) (k : Key) (miss : cache k = none) + (f : ((j : Key) → Answer j) → ℚ) : + average (fun table => f (overlay cache table)) = + average (fun a : Answer k => average (fun table => f (overlay (put cache k a) table))) := by + rw [average_update k] + apply congrArg average + funext a + apply congrArg average + funext table + congr 1 + rw [overlay_put] + funext j + by_cases h : j = k + · subst j; simp [overlay, miss] + · simp [overlay, Function.update_of_ne h] + +/-- Exact equality for EVERY payoff, for arbitrary adaptive requests and repeats. +The total table appears only in the reference integral, never in a continuation. -/ +theorem table_eq_memo {n} (program : Sampling Key Answer R n) + (cache : Cache Key Answer) (payoff : R → ℚ) : + average (fun table => payoff (Sampling.eval (overlay cache table) program)) = + Sampling.expectation (fun result => payoff result.1) (memo program cache) := by + induction program generalizing cache with + | ret r => simp [memo, Sampling.eval, Sampling.expectation, FiatShamirGame.average_const] + | draw k next ih => + cases hit : cache k with + | some a => + simp only [memo, hit, Sampling.expectation_pad] + rw [← ih a cache] + apply congrArg average + funext table + simp [Sampling.eval, overlay, hit] + | none => + simp only [memo, hit, Sampling.expectation] + trans average (fun a : Answer k => average (fun table => + payoff (Sampling.eval (overlay (put cache k a) table) (.draw k next)))) + · exact overlay_average cache k hit (fun oracle => payoff (Sampling.eval oracle (.draw k next))) + apply congrArg average + funext a + rw [← ih a (put cache k a)] + apply congrArg average + funext table + simp [Sampling.eval, overlay] + + theorem empty_table_eq_memo {n} (program : Sampling Key Answer R n) (payoff : R → ℚ) : + average (fun table => payoff (Sampling.eval table program)) = + Sampling.expectation (fun result => payoff result.1) (memo program (fun _ => none)) := + table_eq_memo program (fun _ => none) payoff + + +/-- The final verifier may inspect the actually completed private cache. This +strengthened coupling retains that cache in the result, without exposing it to +any adversarial continuation. -/ +theorem table_eq_memo_full {n} (program : Sampling Key Answer R n) + (cache : Cache Key Answer) (payoff : R × Cache Key Answer → ℚ) : + average (fun table => + payoff (Sampling.eval (overlay cache table) (memo program cache))) = + Sampling.expectation payoff (memo program cache) := by + induction program generalizing cache with + | ret r => simp [memo, Sampling.eval, Sampling.expectation, FiatShamirGame.average_const] + | draw k next ih => + cases hit : cache k with + | some a => + simpa only [memo, hit, Sampling.eval_pad, Sampling.expectation_pad] using ih a cache + | none => + trans average (fun a : Answer k => average (fun table => + payoff (Sampling.eval (overlay (put cache k a) table) (memo (.draw k next) cache)))) + · exact overlay_average cache k hit + (fun oracle => payoff (Sampling.eval oracle (memo (.draw k next) cache))) + simp only [memo, hit, Sampling.expectation] + apply congrArg average + funext a + rw [← ih a (put cache k a)] + apply congrArg average + funext table + simp [Sampling.eval, overlay] +end Memo + +/-- A completed operational trace determines the executable evaluation when +the evaluator agrees with its actual allocated answers. No unseen answer is +consulted by this reconstruction. -/ +theorem execute_eq_of_runs {Key : Type u} {Answer : Key → Type v} {R : Type w} + (oracle : (key : Key) → Answer key) {n} {p : Sampling Key Answer R n} + {trace result} (run : Sampling.Runs p trace result) + (answers : ∀ entry ∈ trace, oracle entry.1 = entry.2) : + Sampling.execute oracle p = (result,trace) := by + induction run with + | ret => rfl + | draw a run ih => + have first := answers _ List.mem_cons_self + have rest := ih (fun entry member => answers entry (List.mem_cons_of_mem _ member)) + simp only [Sampling.execute, first, rest] + +/-- A concrete recognizer partitions all raw keys. Its laws are codec laws, +not distribution assumptions. Off-image keys are retained, not rejected. -/ +structure Partition (Raw Packet : Type u) (Block : Packet → Type u) where + encode : Sigma Block → Raw + recognize : Raw → Option (Sigma Block) + recognize_encode : ∀ c, recognize (encode c) = some c + encode_recognize : ∀ raw c, recognize raw = some c → encode c = raw + +namespace Partition +variable {Raw Packet D : Type u} {Block : Packet → Type u} +variable (part : Partition Raw Packet Block) + +abbrev Garbage := {raw : Raw // part.recognize raw = none} +abbrev Key := Sum Packet part.Garbage +abbrev Answer : part.Key → Type u + | .inl p => Block p → D + | .inr _ => D + +def join (table : (k : part.Key) → part.Answer (D := D) k) (raw : Raw) : D := + match h : part.recognize raw with + | some c => table (.inl c.1) c.2 + | none => table (.inr ⟨raw,h⟩) + +def split (table : Raw → D) : (k : part.Key) → part.Answer (D := D) k + | .inl p => fun b => table (part.encode ⟨p,b⟩) + | .inr g => table g.val + +theorem join_split (table : Raw → D) : part.join (part.split table) = table := by + funext raw + unfold join + split + · rename_i c h + exact congrArg table (part.encode_recognize raw c h) + · rfl + +theorem split_join (table : (k : part.Key) → part.Answer (D := D) k) : + part.split (part.join table) = table := by + funext k + cases k with + | inl p => + funext b + simp only [split] + unfold join + split + · rename_i c hc + have he : c = ⟨p,b⟩ := Option.some.inj (hc.symm.trans (part.recognize_encode _)) + subst c + rfl + · rename_i hc + rw [part.recognize_encode] at hc + contradiction + | inr g => + simp only [split] + unfold join + split + · rename_i c hc + rw [g.property] at hc + contradiction + · rfl + +def tableEquiv : (Raw → D) ≃ ((k : part.Key) → part.Answer (D := D) k) where + toFun := part.split + invFun := part.join + left_inv := part.join_split + right_inv := part.split_join + +/-- Proactive ancestor reads do not release their packets to the adversary. +They are memoized with every other request by the single outer interpreter. -/ +def warm : (ancestors : List Packet) → + Sampling part.Key (part.Answer (D := D)) Unit ancestors.length + | [] => .ret () + | p :: ps => .draw (.inl p) (fun _ => warm ps) + +@[simp] theorem eval_warm (table : (k : part.Key) → part.Answer (D := D) k) + (ancestors : List Packet) : Sampling.eval table (part.warm ancestors) = () := by + induction ancestors with + | nil => rfl + | cons p ps ih => exact ih + +/-- Earlier caller-output coordinates are ordinary off-image raw groups. They +are completed privately before any WHIR packet at the corresponding entry. -/ +def warmCaller : (calls : List part.Garbage) → + Sampling part.Key (part.Answer (D := D)) Unit calls.length + | [] => .ret () + | raw :: rest => .draw (.inr raw) (fun _ => warmCaller rest) + +@[simp] theorem eval_warmCaller (table : (k : part.Key) → part.Answer (D := D) k) + (calls : List part.Garbage) : Sampling.eval table (part.warmCaller calls) = () := by + induction calls with + | nil => rfl + | cons raw rest ih => exact ih + +/-- An explicit bounded prefix schedule; the concrete recognizer supplies its +strict ancestors, in oldest-first order, and the uniform syntactic depth cap. -/ +structure Schedule (Packet : Type u) (B : Nat) where + positive : 0 < B + ancestors : Packet → List Packet + bounded : ∀ p, (ancestors p).length + 1 ≤ B + +structure CallerPlan (Packet Garbage : Type u) (C : Nat) where + calls : Packet → List Garbage + bounded : ∀ p, (calls p).length ≤ C + +/-- Caller outputs, strict WHIR ancestors, then the entire current packet. +All three stages are processed by the same outer memoizing interpreter. -/ +def completePacket {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (packet : Packet) : + Sampling part.Key (part.Answer (D := D)) (Block packet → D) (B+C) := + Sampling.pad (by have := schedule.bounded packet; have := caller.bounded packet; omega) + (Sampling.bind (part.warmCaller (caller.calls packet)) (fun _ => + Sampling.bind (part.warm (schedule.ancestors packet)) (fun _ => + Sampling.draw (.inl packet) (fun answer => Sampling.ret (n := 0) answer)))) + +@[simp] theorem eval_completePacket {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) + (table : (k : part.Key) → part.Answer (D := D) k) (packet : Packet) : + Sampling.eval table (part.completePacket schedule caller packet) = table (.inl packet) := by + simp [completePacket, Sampling.eval] + +def request {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (raw : Raw) : + Sampling part.Key (part.Answer (D := D)) D (B+C) := + match h : part.recognize raw with + | some c => Sampling.pad (by omega) + (Sampling.bind (part.completePacket schedule caller c.1) + (fun packet => Sampling.ret (n := 0) (packet c.2))) + | none => Sampling.pad (by have := schedule.positive; omega) + (Sampling.draw (.inr ⟨raw,h⟩) (fun answer => Sampling.ret (n := 0) answer)) + +theorem eval_request {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) + (table : (k : part.Key) → part.Answer (D := D) k) (raw : Raw) : + Sampling.eval table (part.request schedule caller raw) = part.join table raw := by + unfold request join + split <;> simp [Sampling.eval] + +/-- All raw requests, including simulator-generated requests, use this same +syntax and counter. Padding can select subsequent inputs. Caller completion +and final WHIR completion are included even when no raw query precedes them. -/ +def program {R : Type u} {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (final : R → Option Packet) : + {n : Nat} → Sampling Raw (fun _ => D) R n → + Sampling part.Key (part.Answer (D := D)) R ((B+C)*n+(B+C)) + | _, .ret r => + match final r with + | none => .ret r + | some packet => Sampling.pad (by omega) + (Sampling.bind (part.completePacket schedule caller packet) + (fun _ => Sampling.ret (n := 0) r)) + | n+1, .draw raw next => Sampling.pad (by simp only [Nat.mul_add, Nat.mul_one]; omega) + (Sampling.bind (part.request schedule caller raw) + (fun answer => program schedule caller final (next answer))) + +theorem eval_program {R : Type u} {B C n} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (final : R → Option Packet) + (table : (k : part.Key) → part.Answer (D := D) k) + (p : Sampling Raw (fun _ => D) R n) : + Sampling.eval table (part.program schedule caller final p) = + Sampling.eval (part.join table) p := by + induction p with + | ret r => + simp only [program] + split <;> simp [Sampling.eval] + | draw raw next ih => simp [program, eval_request, Sampling.eval, ih] + +variable [DecidableEq Packet] [DecidableEq Raw] +variable [Fintype Raw] [Fintype Packet] [∀ p, Fintype (Block p)] +variable [Fintype D] [Nonempty D] + +instance : Fintype part.Garbage := inferInstanceAs (Fintype {raw // part.recognize raw = none}) +noncomputable instance (k : part.Key) : Fintype (part.Answer (D := D) k) := by + classical + cases k <;> simp only [Answer] <;> infer_instance +instance (k : part.Key) : Nonempty (part.Answer (D := D) k) := by + cases k <;> simp only [Answer] <;> infer_instance + +/-- Exact raw finite-table to lazy whole-packet/garbage distribution equality. +Neither arbitrary full-input injection nor an equal-distribution premise occurs. -/ +theorem raw_table_eq_packets {R : Type u} {B C n} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (final : R → Option Packet) + (p : Sampling Raw (fun _ => D) R n) (payoff : R → ℚ) : + average (fun table : Raw → D => payoff (Sampling.eval table p)) = + Sampling.expectation (fun result => payoff result.1) + (memo (part.program schedule caller final p) (fun _ => none)) := by + rw [← empty_table_eq_memo] + simp only [eval_program] + have h := average_equiv part.tableEquiv + (fun table => payoff (Sampling.eval (part.join table) p)) + simpa only [tableEquiv, Equiv.coe_fn_mk, join_split] using h + +omit [Fintype Raw] [Fintype Packet] [∀ p, Fintype (Block p)] [Fintype D] [Nonempty D] in +theorem all_branch_cap {R : Type u} {B C n} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (final : R → Option Packet) + (p : Sampling Raw (fun _ => D) R n) {trace result} + (run : Sampling.Runs + (memo (part.program schedule caller final p) (fun _ => none)) trace result) : + trace.length ≤ (B+C)*(n+1) := by simpa [Nat.mul_add] using run.length_le + +end Partition + +section Relabel +variable {Key : Type u} {Answer : Key → Type v} +variable {Target : Type u} {Fiber : Target → Type v} +variable [DecidableEq Key] + +/-- A label is computed from already allocated private state. The equivalence +changes only representation of the selected fiber; it does not identify +arbitrary full inputs with raw keys. -/ +structure Labeling (Key : Type u) (Answer : Key → Type v) + (Target : Type u) (Fiber : Target → Type v) where + key : Cache Key Answer → Key → Target + answer : ∀ cache k, Fiber (key cache k) ≃ Answer k + +def relabelMemo (labels : Labeling Key Answer Target Fiber) {R : Type w} {n} : + Sampling Key Answer R n → Cache Key Answer → + Sampling Target Fiber (R × Cache Key Answer) n + | .ret r, cache => .ret (r,cache) + | .draw k next, cache => + match cache k with + | some a => Sampling.pad (Nat.le_succ _) (relabelMemo labels (next a) cache) + | none => .draw (labels.key cache k) (fun fresh => + let a := labels.answer cache k fresh + relabelMemo labels (next a) (put cache k a)) + +variable [∀ k, Fintype (Answer k)] [∀ k, Nonempty (Answer k)] +variable [∀ k, Fintype (Fiber k)] [∀ k, Nonempty (Fiber k)] + +omit [∀ k, Nonempty (Answer k)] [∀ k, Nonempty (Fiber k)] in +/-- Distribution-preserving canonical relabeling is operational and local to +each miss. It requires no full-key injection and no preexisting cache invariant. -/ +theorem relabelMemo_expectation (labels : Labeling Key Answer Target Fiber) + {R : Type w} {n} (p : Sampling Key Answer R n) (cache : Cache Key Answer) + (payoff : R × Cache Key Answer → ℚ) : + Sampling.expectation payoff (relabelMemo labels p cache) = + Sampling.expectation payoff (memo p cache) := by + induction p generalizing cache with + | ret r => rfl + | draw k next ih => + cases hit : cache k with + | some a => simpa only [relabelMemo, memo, hit, Sampling.expectation_pad] using ih a cache + | none => + simp only [relabelMemo, memo, hit, Sampling.expectation, ih] + exact average_equiv (labels.answer cache k) + (fun a => Sampling.expectation payoff (memo (next a) (put cache k a))) + +variable [Fintype Key] + +omit [∀ k, Nonempty (Fiber k)] in +theorem table_eq_relabelMemo (labels : Labeling Key Answer Target Fiber) + {R : Type w} {n} (p : Sampling Key Answer R n) (payoff : R → ℚ) : + average (fun table => payoff (Sampling.eval table p)) = + Sampling.expectation (fun result => payoff result.1) + (relabelMemo labels p (fun _ => none)) := by + rw [relabelMemo_expectation] + exact empty_table_eq_memo p payoff + +end Relabel +end Whir.RawOracleCoupling diff --git a/verification/whir/Whir/RawOracleProvenance.lean b/verification/whir/Whir/RawOracleProvenance.lean new file mode 100644 index 000000000..9322e83af --- /dev/null +++ b/verification/whir/Whir/RawOracleProvenance.lean @@ -0,0 +1,728 @@ +import Whir.RawOracleCoupling +import Whir.RawWHIRKeys + +/-! Operational provenance for canonical cache-derived allocation labels. -/ +namespace Whir.RawOracleCoupling +open TypedOracleCompiler TypedFiatShamirGame + +universe u v w +section Dependencies +variable {Key : Type u} {Answer : Key → Type u} [DecidableEq Key] +variable (deps : Key → List Key) + +abbrev Growth (before after : Cache Key Answer) : Prop := + ∀ k a, before k = some a → after k = some a + +def Ready (cache : Cache Key Answer) (k : Key) : Prop := + ∀ j ∈ deps k, ∃ a, cache j = some a + +def dependencyHistory (cache : Cache Key Answer) (k : Key) : List (Sigma Answer) := + (deps k).filterMap (fun j => (cache j).map (Sigma.mk j)) + +abbrev Annotated := Key × List (Sigma Answer) +abbrev AnnotatedAnswer (k : Annotated (Answer := Answer)) := Answer k.1 + +def dependencyLabels : Labeling Key Answer (Annotated (Answer := Answer)) AnnotatedAnswer where + key cache k := (k, dependencyHistory deps cache k) + answer _ _ := Equiv.refl _ + +omit [DecidableEq Key] in + theorem growth_refl (cache : Cache Key Answer) : Growth cache cache := fun _ _ h => h +omit [DecidableEq Key] in + theorem growth_trans {a b c : Cache Key Answer} (ab : Growth a b) (bc : Growth b c) : + Growth a c := fun k x h => bc k x (ab k x h) + + theorem growth_put (cache : Cache Key Answer) (k : Key) (a : Answer k) + (miss : cache k = none) : Growth cache (put cache k a) := by + intro j b hit + by_cases h : j = k + · subst j; rw [miss] at hit; contradiction + · simpa only [put_other _ _ _ _ h] using hit + +omit [DecidableEq Key] in + theorem Ready.mono {cache next : Cache Key Answer} {k} + (ready : Ready deps cache k) (growth : Growth cache next) : Ready deps next k := by + intro j hj + obtain ⟨a,ha⟩ := ready j hj + exact ⟨a,growth j a ha⟩ + +omit [DecidableEq Key] in + theorem dependencyHistory_mono {cache next : Cache Key Answer} {k} + (ready : Ready deps cache k) (growth : Growth cache next) : + dependencyHistory deps cache k = dependencyHistory deps next k := by + apply List.filterMap_congr + intro j hj + obtain ⟨a,ha⟩ := ready j hj + rw [ha, growth j a ha] + + def Recorded (cache : Cache Key Answer) + (trace : List (Sigma (AnnotatedAnswer (Answer := Answer)))) : Prop := + ∀ k a, cache k = some a → Ready deps cache k ∧ + (⟨(k, dependencyHistory deps cache k),a⟩ : Sigma AnnotatedAnswer) ∈ trace + +omit [DecidableEq Key] in + theorem recorded_empty : Recorded deps (fun _ => none : Cache Key Answer) [] := by + intro k a h; cases h + +omit [DecidableEq Key] in + theorem Recorded.mono_trace {cache : Cache Key Answer} {trace more} + (recorded : Recorded deps cache trace) (subset : ∀ x ∈ trace, x ∈ more) : + Recorded deps cache more := by + intro k a hit + obtain ⟨hr,ht⟩ := recorded k a hit + exact ⟨hr,subset _ ht⟩ + + theorem Recorded.insert {cache : Cache Key Answer} {trace k} + (recorded : Recorded deps cache trace) (ready : Ready deps cache k) + (miss : cache k = none) (a : Answer k) : + Recorded deps (put cache k a) + (trace ++ [⟨(k,dependencyHistory deps cache k),a⟩]) := by + have growth := growth_put cache k a miss + intro j b hit + by_cases h : j = k + · subst j + simp only [put_self, Option.some.injEq] at hit + subst b + exact ⟨ready.mono deps growth, by rw [← dependencyHistory_mono deps ready growth]; simp⟩ + · rw [put_other _ _ _ _ h] at hit + obtain ⟨hr,ht⟩ := recorded j b hit + exact ⟨hr.mono deps growth, by + rw [← dependencyHistory_mono deps hr growth] + exact List.mem_append_left _ ht⟩ + +/-- This is a recursively checkable safety predicate on a concrete interpreter, +not an oracle-distribution or cache-correctness assumption. -/ +def Safe {R : Type w} (post : R × Cache Key Answer → Prop) {n} : + Sampling Key Answer R n → Cache Key Answer → Prop + | .ret r, cache => post (r,cache) + | .draw k next, cache => + match cache k with + | some a => Safe post (next a) cache + | none => Ready deps cache k ∧ ∀ a, Safe post (next a) (put cache k a) + + theorem Safe.mono {R : Type w} {P Q : R × Cache Key Answer → Prop} {n} + {p : Sampling Key Answer R n} {cache} (safe : Safe deps P p cache) + (imp : ∀ result, P result → Q result) : Safe deps Q p cache := by + induction p generalizing cache with + | ret => exact imp _ safe + | draw k next ih => + cases hit : cache k with + | some a => + simp only [Safe, hit] at safe ⊢ + exact ih a safe + | none => + simp only [Safe, hit] at safe ⊢ + exact ⟨safe.1,fun a => ih a (safe.2 a)⟩ + +theorem Safe.eval {R : Type w} {P : R × Cache Key Answer → Prop} {n} + {p : Sampling Key Answer R n} {cache} (safe : Safe deps P p cache) + (table : (k : Key) → Answer k) : + P (Sampling.eval table (memo p cache)) := by + induction p generalizing cache with + | ret => exact safe + | draw k next ih => + cases hit : cache k with + | some a => + simp only [memo, hit, Sampling.eval_pad] + exact ih a (by simpa only [Safe, hit] using safe) + | none => + simp only [memo, hit, Sampling.eval] + have hs : Ready deps cache k ∧ ∀ a, Safe deps P (next a) (put cache k a) := by + simpa only [Safe, hit] using safe + exact ih (table k) (hs.2 (table k)) + + theorem safe_pad {R : Type w} (P : R × Cache Key Answer → Prop) {n m} + (h : n ≤ m) (p : Sampling Key Answer R n) (cache : Cache Key Answer) : + Safe deps P (Sampling.pad h p) cache ↔ Safe deps P p cache := by + induction p generalizing m cache with + | ret => simp only [Sampling.pad, Safe] + | draw k next ih => + cases m with + | zero => omega + | succ m => + simp only [Sampling.pad, Safe] + split <;> simp only [ih] + + theorem safe_bind {R T : Type*} (P : T × Cache Key Answer → Prop) {n m} + (p : Sampling Key Answer R n) (f : R → Sampling Key Answer T m) + (cache : Cache Key Answer) : + Safe deps P (Sampling.bind p f) cache ↔ + Safe deps (fun result => Safe deps P (f result.1) result.2) p cache := by + induction p generalizing cache with + | ret => simp only [Sampling.bind, safe_pad, Safe] + | draw k next ih => + simp only [Sampling.bind, safe_pad, Safe] + split <;> simp only [ih] + + theorem safe_runs {R : Type w} {P : R × Cache Key Answer → Prop} {n} + (p : Sampling Key Answer R n) (cache : Cache Key Answer) {before trace result} + (recorded : Recorded deps cache before) (safe : Safe deps P p cache) + (run : Sampling.Runs (relabelMemo (dependencyLabels deps) p cache) trace result) : + P result ∧ Growth cache result.2 ∧ Recorded deps result.2 (before ++ trace) := by + induction p generalizing cache before trace result with + | ret r => + cases run + exact ⟨safe, growth_refl cache, by simpa using recorded⟩ + | draw k next ih => + cases hit : cache k with + | some a => + simp only [relabelMemo, hit, Sampling.runs_pad] at run + exact ih a cache recorded (by simpa only [Safe,hit] using safe) run + | none => + simp only [relabelMemo, hit] at run + cases run with + | draw a run => + have hs : Ready deps cache k ∧ ∀ a, Safe deps P (next a) (put cache k a) := by + simpa only [Safe, hit] using safe + have hr := ih a (put cache k a) (recorded.insert deps hs.1 hit a) (hs.2 a) run + exact ⟨hr.1, growth_trans (growth_put cache k a hit) hr.2.1, + by simpa only [List.append_assoc, List.singleton_append, dependencyLabels] using hr.2.2⟩ + + +/-- Every actual allocated answer survives in the final global cache. This +direction complements `Recorded`, which locates cached entries in the trace. -/ +theorem dependencyMemo_runs_cache {R : Type w} {n} (p : Sampling Key Answer R n) + (cache : Cache Key Answer) {trace result} + (run : Sampling.Runs (relabelMemo (dependencyLabels deps) p cache) trace result) : + Growth cache result.2 ∧ ∀ entry ∈ trace, result.2 entry.1.1 = some entry.2 := by + induction p generalizing cache trace result with + | ret r => + cases run + exact ⟨growth_refl cache, by intro entry member; cases member⟩ + | draw k next ih => + cases hit : cache k with + | some a => + simp only [relabelMemo, hit, Sampling.runs_pad] at run + exact ih a cache run + | none => + simp only [relabelMemo, hit] at run + cases run with + | draw a run => + have rest := ih a (put cache k a) run + refine ⟨growth_trans (growth_put cache k a hit) rest.1,?_⟩ + intro entry member + rcases List.mem_cons.mp member with equal | member + · subst entry + exact rest.1 k a (put_self _ _ _) + · exact rest.2 entry member + +/-- A private annotation is fixed when its dependencies are already cached. +No later allocation or final-state reconstruction can change that annotation. -/ +theorem safe_runs_history {R : Type w} {P : R × Cache Key Answer → Prop} {n} + (p : Sampling Key Answer R n) (cache : Cache Key Answer) {trace result} + (safe : Safe deps P p cache) + (run : Sampling.Runs (relabelMemo (dependencyLabels deps) p cache) trace result) : + ∀ entry ∈ trace, entry.1.2 = dependencyHistory deps result.2 entry.1.1 := by + induction p generalizing cache trace result with + | ret r => + cases run + intro entry member + cases member + | draw k next ih => + cases hit : cache k with + | some a => + simp only [relabelMemo, hit, Sampling.runs_pad] at run + exact ih a cache (by simpa only [Safe,hit] using safe) run + | none => + simp only [relabelMemo, hit] at run + cases run with + | draw a run => + have hs : Ready deps cache k ∧ ∀ a, Safe deps P (next a) (put cache k a) := by + simpa only [Safe,hit] using safe + have growth := (dependencyMemo_runs_cache deps (next a) (put cache k a) run).1 + intro entry member + rcases List.mem_cons.mp member with equal | member + · subst entry + exact dependencyHistory_mono deps hs.1 (growth_trans (growth_put cache k a hit) growth) + · exact ih a (put cache k a) (hs.2 a) run entry member + +end Dependencies + +namespace Partition +variable {Raw Packet D : Type u} {Block : Packet → Type u} +variable (part : Partition Raw Packet Block) +variable [DecidableEq Packet] [DecidableEq Raw] + +def dependencies {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) : part.Key → List part.Key + | .inl p => (caller.calls p).map Sum.inr ++ (schedule.ancestors p).map Sum.inl + | .inr _ => [] + +def CachedKeys (cache : Cache part.Key (part.Answer (D := D))) (xs : List Packet) : Prop := + ∀ p ∈ xs, ∃ a, cache (.inl p) = some a + +def CachedCallers (cache : Cache part.Key (part.Answer (D := D))) + (calls : List part.Garbage) : Prop := + ∀ raw ∈ calls, ∃ answer, cache (.inr raw) = some answer + +def Ordered {B} (schedule : Schedule Packet B) (prior xs : List Packet) : Prop := + ∀ before p after, xs = before ++ p :: after → + ∀ a ∈ schedule.ancestors p, a ∈ prior ++ before + +theorem safe_warm {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (prior xs : List Packet) + (cache : Cache part.Key (part.Answer (D := D))) + (known : part.CachedKeys cache prior) (ordered : Ordered schedule prior xs) + (callerKnown : ∀ p ∈ xs, part.CachedCallers cache (caller.calls p)) : + Safe (part.dependencies schedule caller) + (fun result => Growth cache result.2 ∧ part.CachedKeys result.2 (prior ++ xs)) + (part.warm xs) cache := by + induction xs generalizing prior cache with + | nil => exact ⟨growth_refl cache, by simpa using known⟩ + | cons p ps ih => + have ready : Ready (part.dependencies schedule caller) cache (.inl p) := by + intro j hj + rcases List.mem_append.mp hj with hj | hj + · obtain ⟨raw,member,rfl⟩ := List.mem_map.mp hj + exact callerKnown p List.mem_cons_self raw member + · obtain ⟨a,ha,rfl⟩ := List.mem_map.mp hj + exact known a (by simpa using ordered [] p ps rfl a ha) + have ordered' : Ordered schedule (prior ++ [p]) ps := by + intro before q after he a ha + have hm := ordered (p::before) q after (by simp [he]) a ha + simpa only [List.append_assoc, List.singleton_append] using hm + simp only [warm, Safe] + cases hit : cache (.inl p) with + | some a => + have known' : part.CachedKeys cache (prior ++ [p]) := by + intro q hq + rcases List.mem_append.mp hq with hq | hq + · exact known q hq + · simp only [List.mem_singleton] at hq; subst q; exact ⟨a,hit⟩ + exact (ih (prior ++ [p]) cache known' ordered' + (fun q hq => callerKnown q (List.mem_cons_of_mem _ hq))).mono _ (fun result h => + ⟨h.1,by simpa only [List.append_assoc, List.singleton_append] using h.2⟩) + | none => + refine ⟨ready,fun a => ?_⟩ + have growth := growth_put cache (.inl p) a hit + have known' : part.CachedKeys (put cache (.inl p) a) (prior ++ [p]) := by + intro q hq + rcases List.mem_append.mp hq with hq | hq + · obtain ⟨b,hb⟩ := known q hq; exact ⟨b,growth _ _ hb⟩ + · simp only [List.mem_singleton] at hq; subst q; exact ⟨a,put_self _ _ _⟩ + have nextCaller : ∀ q ∈ ps, part.CachedCallers (put cache (.inl p) a) (caller.calls q) := by + intro q hq raw member + obtain ⟨b,hb⟩ := callerKnown q (List.mem_cons_of_mem _ hq) raw member + exact ⟨b,growth _ _ hb⟩ + exact (ih (prior ++ [p]) _ known' ordered' nextCaller).mono _ (fun result h => + ⟨growth_trans growth h.1,by simpa only [List.append_assoc, List.singleton_append] using h.2⟩) + + +theorem safe_warmCaller {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) (calls : List part.Garbage) + (cache : Cache part.Key (part.Answer (D := D))) : + Safe (part.dependencies schedule caller) + (fun result => Growth cache result.2 ∧ part.CachedCallers result.2 calls) + (part.warmCaller calls) cache := by + induction calls generalizing cache with + | nil => exact ⟨growth_refl cache,by intro raw member; cases member⟩ + | cons raw rest ih => + simp only [warmCaller, Safe] + cases hit : cache (.inr raw) with + | some a => + apply (ih cache).mono + intro result h + refine ⟨h.1,?_⟩ + intro key member + rcases List.mem_cons.mp member with rfl | member + · exact ⟨a,h.1 _ _ hit⟩ + · exact h.2 key member + | none => + refine ⟨?_,fun a => ?_⟩ + · intro key member; cases member + · apply (ih (put cache (.inr raw) a)).mono + intro result h + refine ⟨growth_trans (growth_put cache (.inr raw) a hit) h.1,?_⟩ + intro key member + rcases List.mem_cons.mp member with rfl | member + · exact ⟨a,h.1 _ _ (put_self _ _ _)⟩ + · exact h.2 key member + +theorem safe_completePacket {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) + (ordered : ∀ p, Ordered schedule [] (schedule.ancestors p)) + (coherent : ∀ p a, a ∈ schedule.ancestors p → caller.calls a = caller.calls p) + (packet : Packet) (cache : Cache part.Key (part.Answer (D := D))) : + Safe (part.dependencies schedule caller) + (fun result => part.CachedKeys result.2 (schedule.ancestors packet ++ [packet]) ∧ + part.CachedCallers result.2 (caller.calls packet)) + (part.completePacket schedule caller packet) cache := by + rw [completePacket, safe_pad, safe_bind] + apply (part.safe_warmCaller schedule caller (caller.calls packet) cache).mono + intro first hf + rw [safe_bind] + have callerKnown : ∀ ancestor ∈ schedule.ancestors packet, + part.CachedCallers first.2 (caller.calls ancestor) := by + intro ancestor member + rw [coherent packet ancestor member] + exact hf.2 + apply (part.safe_warm schedule caller [] (schedule.ancestors packet) first.2 + (by intro p hp; cases hp) (ordered packet) callerKnown).mono + intro past hp + have ready : Ready (part.dependencies schedule caller) past.2 (.inl packet) := by + intro key member + rcases List.mem_append.mp member with member | member + · obtain ⟨raw,hm,rfl⟩ := List.mem_map.mp member + obtain ⟨a,ha⟩ := hf.2 raw hm + exact ⟨a,hp.1 _ _ ha⟩ + · obtain ⟨ancestor,hm,rfl⟩ := List.mem_map.mp member + exact hp.2 ancestor (by simpa using hm) + have done (nextCache : Cache part.Key (part.Answer (D := D))) + (growth : Growth past.2 nextCache) (a : part.Answer (D := D) (.inl packet)) + (hit : nextCache (.inl packet) = some a) : + part.CachedKeys nextCache (schedule.ancestors packet ++ [packet]) ∧ + part.CachedCallers nextCache (caller.calls packet) := by + constructor + · intro key member + rcases List.mem_append.mp member with member | member + · obtain ⟨b,hb⟩ := hp.2 key (by simpa using member) + exact ⟨b,growth _ _ hb⟩ + · simp only [List.mem_singleton] at member + subst key + exact ⟨a,hit⟩ + · intro key member + obtain ⟨b,hb⟩ := hf.2 key member + exact ⟨b,growth _ _ (hp.1 _ _ hb)⟩ + simp only [Safe] + cases hit : past.2 (.inl packet) with + | some a => exact done past.2 (growth_refl _) a hit + | none => + exact ⟨ready,fun a => done _ (growth_put _ _ a hit) a (put_self _ _ _)⟩ + +theorem safe_request {B C} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) + (ordered : ∀ p, Ordered schedule [] (schedule.ancestors p)) + (coherent : ∀ p a, a ∈ schedule.ancestors p → caller.calls a = caller.calls p) + (raw : Raw) (cache : Cache part.Key (part.Answer (D := D))) : + Safe (part.dependencies schedule caller) (fun _ => True) (part.request schedule caller raw) cache := by + unfold request + split + · rename_i c recognized + rw [safe_pad, safe_bind] + exact (part.safe_completePacket schedule caller ordered coherent c.1 cache).mono _ + (fun _ _ => True.intro) + · rw [safe_pad] + simp only [Safe] + split + · trivial + · refine ⟨?_,fun _ => True.intro⟩ + intro j hj + cases hj + +def finishPackets {B} (schedule : Schedule Packet B) : Option Packet → List Packet + | none => [] + | some p => schedule.ancestors p ++ [p] + +def finishCallers {C} (caller : CallerPlan Packet part.Garbage C) : Option Packet → List part.Garbage + | none => [] + | some p => caller.calls p + +theorem safe_program {R : Type u} {B C n} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) + (ordered : ∀ p, Ordered schedule [] (schedule.ancestors p)) + (coherent : ∀ p a, a ∈ schedule.ancestors p → caller.calls a = caller.calls p) + (final : R → Option Packet) + (p : Sampling Raw (fun _ => D) R n) (cache : Cache part.Key (part.Answer (D := D))) : + Safe (part.dependencies schedule caller) (fun result => + part.CachedKeys result.2 (finishPackets schedule (final result.1)) ∧ + part.CachedCallers result.2 (part.finishCallers caller (final result.1))) + (part.program schedule caller final p) cache := by + induction p generalizing cache with + | ret r => + simp only [program] + split + · rename_i selected + simp only [Safe, selected, finishPackets, finishCallers] + constructor <;> intro key member <;> cases member + · rename_i packet selected + rw [safe_pad, safe_bind] + apply (part.safe_completePacket schedule caller ordered coherent packet cache).mono + intro result h + simpa only [Safe, selected, finishPackets, finishCallers] using h + | draw raw next ih => + simp only [program, safe_pad, safe_bind] + exact (part.safe_request schedule caller ordered coherent raw cache).mono _ (fun result _ => ih _ _) + +/-- Caller prewarming and all WHIR ancestor readiness are proved by the +interpreter; no initial correctness or completion certificate is supplied. -/ +theorem program_recorded {R : Type u} {B C n} (schedule : Schedule Packet B) + (caller : CallerPlan Packet part.Garbage C) + (ordered : ∀ p, Ordered schedule [] (schedule.ancestors p)) + (coherent : ∀ p a, a ∈ schedule.ancestors p → caller.calls a = caller.calls p) + (final : R → Option Packet) (p : Sampling Raw (fun _ => D) R n) {trace result} + (run : Sampling.Runs + (relabelMemo (dependencyLabels (part.dependencies schedule caller)) + (part.program schedule caller final p) (fun _ => none)) trace result) : + (part.CachedKeys result.2 (finishPackets schedule (final result.1)) ∧ + part.CachedCallers result.2 (part.finishCallers caller (final result.1))) ∧ + Recorded (part.dependencies schedule caller) result.2 trace := by + have h := safe_runs (part.dependencies schedule caller) _ _ (recorded_empty _) + (part.safe_program schedule caller ordered coherent final p _) run + exact ⟨h.1,by simpa using h.2.2⟩ + +omit [DecidableEq Packet] in +theorem ordered_of_get {B} (schedule : Schedule Packet B) (xs : List Packet) + (chain : ∀ i (hi : i < xs.length), schedule.ancestors (xs[i]'hi) = xs.take i) : + Ordered schedule [] xs := by + intro before p after he a ha + have hi : before.length < xs.length := by simp [he] + have hp : (xs[before.length]'hi) = p := by simp [he] + have h := chain before.length hi + rw [hp] at h + have ht : xs.take before.length = before := by simp [he] + simpa only [List.nil_append, h, ht] using ha +end Partition + +namespace Concrete +open RawWHIRKeys DuplexModeGame +open FiatShamirGame (Digest32 average) + +abbrev partition (ctx : Context) (Q : Nat) : + Partition (RawKey Q) (Packet ctx Q) (fun p => Fin (blocks ctx p.val)) where + encode := encode ctx Q + recognize := recognize ctx Q + recognize_encode := recognize_encode ctx Q + encode_recognize := encode_recognize ctx Q + +def schedule (ctx : Context) (Q : Nat) : Partition.Schedule (Packet ctx Q) maxDepth where + positive := maxDepth_positive + ancestors := ancestors ctx Q + bounded := ancestors_maxDepth ctx Q + +def callerPlan (ctx : Context) (Q : Nat) : + Partition.CallerPlan (Packet ctx Q) (partition ctx Q).Garbage ctx.callerOutputCap where + calls := callerGroups ctx Q + bounded := callerGroups_bound ctx Q + +theorem caller_coherent (ctx : Context) (Q : Nat) (p a : Packet ctx Q) + (member : a ∈ (schedule ctx Q).ancestors p) : + (callerPlan ctx Q).calls a = (callerPlan ctx Q).calls p := + callerGroups_ancestor ctx Q p a member + +/-- Public worst-case charge includes all hidden caller-output blocks. -/ +abbrev allocationBudget (ctx : Context) : Nat := maxDepth + ctx.callerOutputCap + +def dependencyKeys (ctx : Context) (Q : Nat) : + (partition ctx Q).Key → List (partition ctx Q).Key := + (partition ctx Q).dependencies (schedule ctx Q) (callerPlan ctx Q) + +theorem schedule_ordered (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + Partition.Ordered (schedule ctx Q) [] ((schedule ctx Q).ancestors p) := + Partition.ordered_of_get _ _ (ancestors_ancestors ctx Q p) + +def completion (ctx : Context) (Q : Nat) (p : Packet ctx Q) : List (Packet ctx Q) := + ancestors ctx Q p ++ [p] + +theorem completion_bound (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + (completion ctx Q p).length ≤ maxDepth := by + simpa only [completion, List.length_append, List.length_singleton] using ancestors_maxDepth ctx Q p + +theorem completion_ordered (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + Partition.Ordered (schedule ctx Q) [] (completion ctx Q p) := + Partition.ordered_of_get _ _ (completion_ancestors ctx Q p) + +def terminalCompletion (ctx : Context) (Q : Nat) : Option (Packet ctx Q) → List (Packet ctx Q) + | none => [] + | some p => completion ctx Q p + +theorem finishPackets_eq (ctx : Context) (Q : Nat) (p : Option (Packet ctx Q)) : + Partition.finishPackets (schedule ctx Q) p = terminalCompletion ctx Q p := by + cases p <;> rfl + +theorem terminalCompletion_bound (ctx : Context) (Q : Nat) (p : Option (Packet ctx Q)) : + (terminalCompletion ctx Q p).length ≤ maxDepth := by + cases p with + | none => exact Nat.zero_le _ + | some p => exact completion_bound ctx Q p + +theorem terminalCompletion_ordered (ctx : Context) (Q : Nat) (p : Option (Packet ctx Q)) : + Partition.Ordered (schedule ctx Q) [] (terminalCompletion ctx Q p) := by + cases p with + | none => + intro before p after he + have := congrArg List.length he + simp [terminalCompletion] at this + | some p => exact completion_ordered ctx Q p + +abbrev GroupKey (ctx : Context) (Q : Nat) := (partition ctx Q).Key +abbrev GroupAnswer (ctx : Context) (Q : Nat) := (partition ctx Q).Answer (D := Digest32) +abbrev AllocationKey (ctx : Context) (Q : Nat) := Annotated (Answer := GroupAnswer ctx Q) +abbrev AllocationAnswer (ctx : Context) (Q : Nat) := + AnnotatedAnswer (Answer := GroupAnswer ctx Q) + +private instance packetDecidableEq (ctx : Context) (Q : Nat) : DecidableEq (Packet ctx Q) := + inferInstance +private instance rawKeyDecidableEq (Q : Nat) : DecidableEq (RawKey Q) := inferInstance + + +/-- One executable global-cache interpreter for every raw request source, +including simulator and auxiliary raw queries. Only returned raw blocks flow +into the original adversary continuation. -/ +def compile (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) : + Sampling (AllocationKey ctx Q) (AllocationAnswer ctx Q) + (R × Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) (allocationBudget ctx*K+allocationBudget ctx) := + relabelMemo (dependencyLabels (dependencyKeys ctx Q)) + ((partition ctx Q).program (schedule ctx Q) (callerPlan ctx Q) final p) (fun _ => none) + +/-- Reference execution with a uniformly selected raw table. The table is +private to the evaluator; the original strategy still sees only raw replies. -/ +def tableExecution (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + (table : RawKey Q → Digest32) : R × Cache (GroupKey ctx Q) (GroupAnswer ctx Q) := + Sampling.eval ((partition ctx Q).split table) + (memo ((partition ctx Q).program (schedule ctx Q) (callerPlan ctx Q) final p) (fun _ => none)) + +theorem tableExecution_result (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + (table : RawKey Q → Digest32) : + (tableExecution ctx Q final p table).1 = Sampling.eval table p := by + simp only [tableExecution, memo_eval_first, overlay_empty, Partition.eval_program, + Partition.join_split] + +/-- Final completion caches every requested ancestor in the concrete table +execution, including packets not previously observed by the adversary. -/ +theorem tableExecution_cached (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + (table : RawKey Q → Digest32) : + (partition ctx Q).CachedKeys (tableExecution ctx Q final p table).2 + (terminalCompletion ctx Q (final (tableExecution ctx Q final p table).1)) := by + have h := (Safe.eval (dependencyKeys ctx Q) + ((partition ctx Q).safe_program (schedule ctx Q) (callerPlan ctx Q) (schedule_ordered ctx Q) + (caller_coherent ctx Q) final p (fun _ => none)) ((partition ctx Q).split table)).1 + simpa only [finishPackets_eq, tableExecution] using h + +theorem tableExecution_cache (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + (table : RawKey Q → Digest32) (key : GroupKey ctx Q) (a : GroupAnswer ctx Q key) + (hit : (tableExecution ctx Q final p table).2 key = some a) : + (partition ctx Q).split table key = a := + memo_eval_consistent _ (fun _ => none) _ (by intro _ _ h; cases h) key a hit + +/-- Every byte, including unused payload padding, in a completed packet is +the value at its exact concrete raw block coordinate. -/ +theorem tableExecution_block (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + (table : RawKey Q → Digest32) (packet : Packet ctx Q) + (a : Fin (blocks ctx packet.val) → Digest32) + (hit : (tableExecution ctx Q final p table).2 (.inl packet) = some a) + (block : Fin (blocks ctx packet.val)) : + a block = table (encode ctx Q ⟨packet,block⟩) := + (congrFun (tableExecution_cache ctx Q final p table (.inl packet) a hit) block).symm + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ + +/-- The concrete partition/ancestor coupling has no codec, freshness, +cache-correctness, or equal-distribution premise. The catalog is an immutable +input fixed before the experiment, never a function of the sampled table. -/ +theorem distribution (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + (payoff : R → ℚ) : + average (fun table : RawKey Q → Digest32 => payoff (Sampling.eval table p)) = + Sampling.expectation (fun result => payoff result.1) (compile ctx Q final p) := by + unfold compile + rw [relabelMemo_expectation] + exact (partition ctx Q).raw_table_eq_packets (schedule ctx Q) _ _ p payoff + +/-- Every payoff of both the adversary result and the actual final completed +cache is preserved. Final verification therefore need not trust a claimed +history carried in the adversary's return value. -/ +theorem distribution_full (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + (payoff : R × Cache (GroupKey ctx Q) (GroupAnswer ctx Q) → ℚ) : + average (fun table : RawKey Q → Digest32 => payoff (tableExecution ctx Q final p table)) = + Sampling.expectation payoff (compile ctx Q final p) := by + unfold compile tableExecution + rw [relabelMemo_expectation] + calc + _ = average (fun table => payoff (Sampling.eval table + (memo ((partition ctx Q).program (schedule ctx Q) + (callerPlan ctx Q) final p) (fun _ => none)))) := + average_equiv (partition ctx Q).tableEquiv _ + _ = _ := table_eq_memo_full _ (fun _ => none) payoff + +theorem recorded (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + {trace result} (run : Sampling.Runs (compile ctx Q final p) trace result) : + (partition ctx Q).CachedKeys result.2 (terminalCompletion ctx Q (final result.1)) ∧ + Recorded (dependencyKeys ctx Q) result.2 trace := by + have h := (partition ctx Q).program_recorded (schedule ctx Q) (callerPlan ctx Q) + (schedule_ordered ctx Q) (caller_coherent ctx Q) final p run + exact ⟨by simpa only [finishPackets_eq] using h.1.1,h.2⟩ + +theorem compile_trace_cached (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + {trace result} (run : Sampling.Runs (compile ctx Q final p) trace result) : + ∀ allocation ∈ trace, result.2 allocation.1.1 = some allocation.2 := + (dependencyMemo_runs_cache (dependencyKeys ctx Q) _ _ run).2 + +theorem compile_trace_history (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + {trace result} (run : Sampling.Runs (compile ctx Q final p) trace result) : + ∀ allocation ∈ trace, + allocation.1.2 = dependencyHistory (dependencyKeys ctx Q) result.2 allocation.1.1 := + safe_runs_history (dependencyKeys ctx Q) _ _ + ((partition ctx Q).safe_program (schedule ctx Q) (callerPlan ctx Q) (schedule_ordered ctx Q) + (caller_coherent ctx Q) final p (fun _ => none)) run + +/-- Every prior caller-output block is already present in the current WHIR +allocation's private annotation, with exactly its immutable raw-cache value. -/ +theorem compile_caller_history (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + {trace result} (run : Sampling.Runs (compile ctx Q final p) trace result) + (allocation : Sigma (AllocationAnswer ctx Q)) (member : allocation ∈ trace) + (packet : Packet ctx Q) (key : allocation.1.1 = .inl packet) + (raw : (partition ctx Q).Garbage) (caller : raw ∈ callerGroups ctx Q packet) : + ∃ answer, (⟨.inr raw,answer⟩ : Sigma (GroupAnswer ctx Q)) ∈ allocation.1.2 ∧ + result.2 (.inr raw) = some answer := by + have dependency : (.inr raw : GroupKey ctx Q) ∈ dependencyKeys ctx Q allocation.1.1 := by + rw [key] + exact List.mem_append_left _ (List.mem_map.mpr ⟨raw,caller,rfl⟩) + have ready := ((recorded ctx Q final p run).2 allocation.1.1 allocation.2 + (compile_trace_cached ctx Q final p run allocation member)).1 + obtain ⟨answer,hit⟩ := ready _ dependency + refine ⟨answer,?_,hit⟩ + rw [compile_trace_history ctx Q final p run allocation member] + exact List.mem_filterMap.mpr ⟨.inr raw,dependency,by rw [hit]; rfl⟩ + +/-- A deterministic total evaluator for replaying an already completed cache. +The zero value is irrelevant on every actual draw, as proved by persistence. -/ +def cacheOracle (ctx : Context) (Q : Nat) + (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (key : AllocationKey ctx Q) : AllocationAnswer ctx Q key := + match key with + | (.inl packet,_) => (cache (.inl packet)).getD (fun _ _ => 0) + | (.inr garbage,_) => (cache (.inr garbage)).getD (fun _ => 0) + +theorem cacheOracle_hit (ctx : Context) (Q : Nat) + (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (key : AllocationKey ctx Q) (answer : AllocationAnswer ctx Q key) + (hit : cache key.1 = some answer) : + cacheOracle ctx Q cache key = answer := by + rcases key with ⟨key,history⟩ + cases key <;> simp_all [cacheOracle] + +/-- Reconstruction recovers the exact original allocation trace and result. +It cannot choose a new label from final state: it reruns the original causal +program using only its immutable previously allocated answers. -/ +theorem compile_reconstruct (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + {trace result} (run : Sampling.Runs (compile ctx Q final p) trace result) : + Sampling.execute (cacheOracle ctx Q result.2) (compile ctx Q final p) = (result,trace) := by + apply execute_eq_of_runs _ run + intro allocation member + exact cacheOracle_hit ctx Q result.2 allocation.1 allocation.2 + (compile_trace_cached ctx Q final p run allocation member) + +/-- Ancestor allocation, garbage, repeated blocks, early stops, and final +completion all share this worst-case bound on every operational branch. -/ +theorem cap (ctx : Context) (Q : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (p : Sampling (RawKey Q) (fun _ => Digest32) R K) + {trace result} (run : Sampling.Runs (compile ctx Q final p) trace result) : + trace.length ≤ allocationBudget ctx*(K+1) := by + simpa only [Nat.mul_add, Nat.mul_one] using run.length_le + +end Concrete +end Whir.RawOracleCoupling diff --git a/verification/whir/Whir/RawWHIRKeys.lean b/verification/whir/Whir/RawWHIRKeys.lean new file mode 100644 index 000000000..d5e4b4667 --- /dev/null +++ b/verification/whir/Whir/RawWHIRKeys.lean @@ -0,0 +1,564 @@ +import Whir.DuplexModeGame +import Whir.WHIRCallerOutputs + +/-! Executable partition of the actual bounded message/template oracle. A packet +is identified by its seed statement, actual caller-entry frames, and pending +history. The public frame boundary count and prior-output cap are fixed in the +context; caller clones with different bytes keep distinct cache identities. +Ancestor answers are completed by the shared cache, never injected into syntax. -/ +namespace Whir.RawWHIRKeys +open FiatShamirGame DuplexFraming DuplexModeGame WHIRHistory WHIRHistoryKey + +inductive Mode where + | standalone | stack + deriving DecidableEq + +structure Context where + mode : Mode + iv : Digest32 + domain : Digest32 + catalog : Digest32 → Option ParameterBounds.Profile + entryLength : Digest32 → Nat + callerOutputCap : Nat + + +def width (mode : Mode) (p : ParameterBounds.Profile) : Nat → Nat := + match mode with + | .standalone => standaloneWidth (ParameterBounds.config p) + | .stack => stackWidth (ParameterBounds.config p) + +theorem width_positive (mode : Mode) (p : ParameterBounds.Profile) (n : Nat) : + 0 < width mode p n := by + cases mode + · exact standaloneWidth_positive p n + · exact stackWidth_positive p n + +theorem width_bounded (mode : Mode) (p : ParameterBounds.Profile) (n : Nat) : + width mode p n < 2^49 := by + cases mode + · exact standaloneWidth_bounded p n + · exact stackWidth_bounded p n + +structure PacketData where + statement : Digest32 + profile : ParameterBounds.Profile + messages : List Pending + entryFrames : List Frame + deriving DecidableEq + +def entry (ctx : Context) (p : PacketData) : FramedHistory := + ⟨ctx.domain, p.statement, p.entryFrames⟩ + +def blocks (ctx : Context) (p : PacketData) : Nat := + (width ctx.mode p.profile (p.messages.length-1) + 31) / 32 + +def coordinate (ctx : Context) (p : PacketData) (block : Nat) : FiatShamirGame.Coordinate := + ⟨⟨ctx.domain,p.statement, + p.entryFrames ++ canonicalFrames (width ctx.mode p.profile) p.messages⟩,.output block⟩ + +theorem pathCost_block (ctx : Context) (p : PacketData) (block : Nat) : + pathCost (coordinate ctx p block) = pathCost (coordinate ctx p 0) := by + simp [coordinate, pathCost, DuplexEncoding.plan] + +/-- The full uncached path includes the caller frames, not only the WHIR +suffix. Initial packets therefore do not silently reset primitive accounting. -/ +theorem pathCost_prefix (ctx : Context) (p : PacketData) (block : Nat) : + pathCost (coordinate ctx p block) = + (p.entryFrames.flatMap DuplexEncoding.framePlan).length + + ((canonicalFrames (width ctx.mode p.profile) p.messages).flatMap DuplexEncoding.framePlan).length + 2 := by + simp [coordinate, pathCost, DuplexEncoding.plan, List.flatMap_append, Nat.add_assoc] + +/-- Empty entry framing is only a mathematical submode. Actual live callers +must supply their normalized prior frames instead of claiming this premise. -/ +theorem coordinate_empty (ctx : Context) (p : PacketData) (block : Nat) + (normal : Normal p.messages) (empty : p.entryFrames = []) : + coordinate ctx p block = + outputKey (width ctx.mode p.profile) ctx.domain p.statement p.messages block := by + simp only [coordinate, empty, List.nil_append, outputKey, + before_history _ (width_positive ctx.mode _) _ _ normal] + +/-- Exact equality to the physical continuation's normalized framed key. -/ +theorem coordinate_eq_outputKeyFrom (ctx : Context) (p : PacketData) (block : Nat) + (normal : Normal p.messages) : + coordinate ctx p block = + WHIRCallerPrefix.outputKeyFrom (width ctx.mode p.profile) (entry ctx p) p.messages block := by + simp only [WHIRCallerPrefix.outputKeyFrom, + WHIRCallerPrefix.before_historyFrom _ (width_positive ctx.mode _) _ normal] + rfl + +/-- The entry framing check is discharged from the source transition relation, +including the live caller's active run. No decoder-validity premise is needed. -/ +theorem entryValid_of_reachable (ctx : Context) (p : PacketData) + (compress : DuplexRefinement.Compression) (m : DuplexRefinement.Model) (s : DuplexRefinement.State) + (reachable : DuplexRefinement.Reachable compress ctx.iv ctx.domain p.statement m s) + (aligned : entry ctx p = (DuplexRefinement.closeRun m).history) : + ∀ f ∈ p.entryFrames, DuplexEncoding.FrameValid f := by + have frames := congrArg FramedHistory.frames aligned + change p.entryFrames = (DuplexRefinement.closeRun m).history.frames at frames + rw [frames] + exact WHIRCallerPrefix.reachable_entry_frameValid _ _ _ _ reachable + +def ValidPacket (ctx : Context) (Q : Nat) (p : PacketData) : Prop := + ctx.catalog p.statement = some p.profile ∧ p.messages ≠ [] ∧ + scheduledAdmissible (ParameterBounds.config p.profile) p.messages = true ∧ + pathCost (coordinate ctx p 0) ≤ Q ∧ + (∀ f ∈ p.entryFrames, DuplexEncoding.FrameValid f) ∧ + p.entryFrames.length = ctx.entryLength p.statement ∧ + WHIRCallerOutputs.callerOutputCount p.entryFrames ≤ ctx.callerOutputCap + +instance (ctx : Context) (Q : Nat) (p : PacketData) : Decidable (ValidPacket ctx Q p) := + inferInstanceAs (Decidable (_ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _)) + +abbrev Packet (ctx : Context) (Q : Nat) := {p : PacketData // ValidPacket ctx Q p} +abbrev Position (ctx : Context) (Q : Nat) := (p : Packet ctx Q) × Fin (blocks ctx p.val) + +theorem packet_pathBound (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + pathCost (coordinate ctx p.val 0) ≤ Q := p.property.2.2.2.1 + +theorem packet_entryValid (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + ∀ f ∈ p.val.entryFrames, DuplexEncoding.FrameValid f := p.property.2.2.2.2.1 + +theorem packet_entryLength (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + p.val.entryFrames.length = ctx.entryLength p.val.statement := p.property.2.2.2.2.2.1 + +theorem packet_callerOutputBound (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + WHIRCallerOutputs.callerOutputCount p.val.entryFrames ≤ ctx.callerOutputCap := + p.property.2.2.2.2.2.2 + +def encode (ctx : Context) (Q : Nat) (pos : Position ctx Q) : RawKey Q := + constructionKey Q ctx.iv (coordinate ctx pos.1.val pos.2.val) + (by rw [pathCost_block]; exact packet_pathBound ctx Q pos.1) + +theorem coordinate_admissible (ctx : Context) (Q : Nat) (pos : Position ctx Q) : + DuplexEncoding.Admissible (coordinate ctx pos.1.val pos.2.val) := by + have normal := scheduled_normal _ _ pos.1.property.2.1 pos.1.property.2.2.1 + rw [coordinate_eq_outputKeyFrom ctx pos.1.val pos.2.val normal] + exact WHIRCallerPrefix.outputKeyFrom_admissible (ParameterBounds.config pos.1.val.profile) + _ (width_positive ctx.mode _) (width_bounded ctx.mode _) (entry ctx pos.1.val) + (packet_entryValid ctx Q pos.1) _ _ pos.1.property.2.1 pos.1.property.2.2.1 pos.2.isLt + +def parseCoordinate (ctx : Context) (q : FiatShamirGame.Coordinate) : Option (PacketData × Nat) := do + let profile ← ctx.catalog q.history.statement + let steps ← parseSteps (q.history.frames.drop (ctx.entryLength q.history.statement)) + match q.terminal with + | .output block => pure (⟨q.history.statement, profile, steps.reverse ++ [initialPending], + q.history.frames.take (ctx.entryLength q.history.statement)⟩, block) + | _ => none + +def candidate (ctx : Context) {Q : Nat} (raw : RawKey Q) : Option (PacketData × Nat) := do + let q ← DuplexEncoding.decode (extractedPlan (expandKey raw)) + parseCoordinate ctx q + +/-- The final exact reconstruction check also checks the fixed IV, the domain, +caller-entry frames, final flags, CV holes, lengths, and every other raw bit. -/ +def recognize (ctx : Context) (Q : Nat) (raw : RawKey Q) : Option (Position ctx Q) := + match candidate ctx raw with + | none => none + | some (p,block) => + if hp : ValidPacket ctx Q p then + if hb : block < blocks ctx p then + let pos : Position ctx Q := ⟨⟨p,hp⟩,⟨block,hb⟩⟩ + if encode ctx Q pos = raw then some pos else none + else none + else none + +theorem extractedPlan_modeKey (iv : Digest32) (q : FiatShamirGame.Coordinate) : + extractedPlan (modeKey iv q) = DuplexEncoding.plan q := by + unfold modeKey keyFromPlan extractedPlan + have step : ∀ p : List DuplexEncoding.Instruction, + ((p.map (fun i => (if DuplexEncoding.readRole i.2 = 1 then some iv else none,i.1))).zip + (p.map (fun i => (i.2,true)))).map (fun p => (p.1.2,p.2.1)) = p := by + intro p + induction p with + | nil => rfl + | cons i p ih => simp [ih] + rw [step, List.reverse_reverse] + +theorem parseCoordinate_coordinate (ctx : Context) (Q : Nat) (pos : Position ctx Q) : + parseCoordinate ctx (coordinate ctx pos.1.val pos.2.val) = some (pos.1.val,pos.2.val) := by + have hn := scheduled_normal (ParameterBounds.config pos.1.val.profile) pos.1.val.messages + pos.1.property.2.1 pos.1.property.2.2.1 + simp only [coordinate, parseCoordinate, pos.1.property.1, ← packet_entryLength ctx Q pos.1, + List.drop_left, List.take_left, canonicalFrames, steps_roundtrip, List.map_reverse, annotated_erases] + change some ((⟨pos.1.val.statement, pos.1.val.profile, + pos.1.val.messages.dropLast.reverse.reverse ++ [initialPending],pos.1.val.entryFrames⟩ : PacketData), pos.2.val) = _ + rw [List.reverse_reverse, hn.restore] + +theorem candidate_encode (ctx : Context) (Q : Nat) (pos : Position ctx Q) : + candidate ctx (encode ctx Q pos) = some (pos.1.val,pos.2.val) := by + simp only [candidate, encode, expand_constructionKey, extractedPlan_modeKey, + DuplexEncoding.decode_plan _ (coordinate_admissible ctx Q pos)] + exact parseCoordinate_coordinate ctx Q pos + +@[simp] theorem recognize_encode (ctx : Context) (Q : Nat) (pos : Position ctx Q) : + recognize ctx Q (encode ctx Q pos) = some pos := by + rw [recognize, candidate_encode] + simp only [pos.1.property, pos.2.isLt, dite_true] + rfl + +theorem encode_recognize (ctx : Context) (Q : Nat) (raw : RawKey Q) (pos : Position ctx Q) + (h : recognize ctx Q raw = some pos) : encode ctx Q pos = raw := by + unfold recognize at h + split at h + · contradiction + · split at h + · split at h + · dsimp only at h + split at h + · cases Option.some.inj h + assumption + · contradiction + · contradiction + · contradiction + +theorem recognize_iff (ctx : Context) (Q : Nat) (raw : RawKey Q) (pos : Position ctx Q) : + recognize ctx Q raw = some pos ↔ encode ctx Q pos = raw := by + constructor + · exact encode_recognize ctx Q raw pos + · rintro rfl + exact recognize_encode ctx Q pos + +theorem encode_injective (ctx : Context) (Q : Nat) : Function.Injective (encode ctx Q) := by + intro a b h + have he := congrArg (recognize ctx Q) h + simpa only [recognize_encode, Option.some.injEq] using he + +def Garbage (ctx : Context) (Q : Nat) (raw : RawKey Q) : Prop := recognize ctx Q raw = none + +instance (ctx : Context) (Q : Nat) (raw : RawKey Q) : Decidable (Garbage ctx Q raw) := + inferInstanceAs (Decidable (_ = _)) + +theorem garbage_iff (ctx : Context) (Q : Nat) (raw : RawKey Q) : + Garbage ctx Q raw ↔ ∀ pos, encode ctx Q pos ≠ raw := by + constructor + · intro h pos he + have hr := (recognize_iff ctx Q raw pos).mpr he + rw [h] at hr + contradiction + · intro h + unfold Garbage + cases hr : recognize ctx Q raw with + | none => rfl + | some pos => exact False.elim (h pos (encode_recognize ctx Q raw pos hr)) + +/-- All caller output coordinates before the public WHIR entry boundary lie +outside the packet partition, regardless of their observed digest values. -/ +theorem short_history_garbage (ctx : Context) (Q : Nat) (q : FiatShamirGame.Coordinate) + (valid : DuplexEncoding.Admissible q) (bounded : pathCost q ≤ Q) + (short : q.history.frames.length < ctx.entryLength q.history.statement) : + Garbage ctx Q (constructionKey Q ctx.iv q bounded) := by + apply (garbage_iff ctx Q _).mpr + intro pos same + have rawSame := congrArg expandKey same + simp only [encode, expand_constructionKey] at rawSame + have equal := modeKey_injective ctx.iv (coordinate_admissible ctx Q pos) valid rawSame + have hs := congrArg (fun c : FiatShamirGame.Coordinate => c.history.statement) equal + have hl := congrArg (fun c : FiatShamirGame.Coordinate => c.history.frames.length) equal + change pos.1.val.statement = q.history.statement at hs + change (pos.1.val.entryFrames ++ + canonicalFrames (width ctx.mode pos.1.val.profile) pos.1.val.messages).length = q.history.frames.length at hl + rw [List.length_append, packet_entryLength ctx Q pos.1, hs] at hl + omega + +theorem callerOutput_admissible (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (q : FiatShamirGame.Coordinate) (hq : q ∈ WHIRCallerOutputs.callerOutputs (entry ctx p.val)) : + DuplexEncoding.Admissible q := + WHIRCallerOutputs.callerOutputs_admissible _ (packet_entryValid ctx Q p) q hq + +theorem callerOutput_pathBound (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (q : FiatShamirGame.Coordinate) (hq : q ∈ WHIRCallerOutputs.callerOutputs (entry ctx p.val)) : + pathCost q ≤ Q := + (WHIRCallerOutputs.callerOutputs_extended_pathCost_le (entry ctx p.val) q hq + (canonicalFrames (width ctx.mode p.val.profile) p.val.messages) (.output 0)).trans + (packet_pathBound ctx Q p) + +/-- A source-enumerated earlier caller output is a literal shared raw-oracle +coordinate, not an independently resampled reply or an arbitrary table lookup. -/ +def callerOutputKey (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (q : FiatShamirGame.Coordinate) (hq : q ∈ WHIRCallerOutputs.callerOutputs (entry ctx p.val)) : + {raw : RawKey Q // Garbage ctx Q raw} := + ⟨constructionKey Q ctx.iv q (callerOutput_pathBound ctx Q p q hq), + short_history_garbage ctx Q q (callerOutput_admissible ctx Q p q hq) + (callerOutput_pathBound ctx Q p q hq) (by + have h := WHIRCallerOutputs.callerOutputs_strict_prefix (entry ctx p.val) q hq + have hs : q.history.statement = p.val.statement := h.2.1 + have hl : q.history.frames.length < p.val.entryFrames.length := h.2.2.1 + rw [packet_entryLength ctx Q p] at hl + simpa only [hs] using hl)⟩ + +/-- Chronological strict caller prefixes, with all consumed output blocks and +their complete 32-byte answers. Warm these through the same garbage cache. -/ +def callerGroups (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + List {raw : RawKey Q // Garbage ctx Q raw} := + (WHIRCallerOutputs.callerOutputs (entry ctx p.val)).attach.map + (fun q => callerOutputKey ctx Q p q.val q.property) + +theorem callerGroups_length (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + (callerGroups ctx Q p).length = WHIRCallerOutputs.callerOutputCount p.val.entryFrames := by + simp [callerGroups, WHIRCallerOutputs.callerOutputs_length, entry] + +theorem callerGroups_bound (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + (callerGroups ctx Q p).length ≤ ctx.callerOutputCap := by + rw [callerGroups_length] + exact packet_callerOutputBound ctx Q p + +/-- Packet blocks are jointly injective, hence distinct packets have disjoint +raw coordinates and all remaining keys belong to the garbage complement. -/ +theorem packet_blocks_disjoint (ctx : Context) (Q : Nat) (a b : Packet ctx Q) + (i : Fin (blocks ctx a.val)) (j : Fin (blocks ctx b.val)) + (h : encode ctx Q ⟨a,i⟩ = encode ctx Q ⟨b,j⟩) : a = b := + congrArg Sigma.fst (encode_injective ctx Q h) + +/-- Different actual caller clones never share any packet block, even if their +seed statement, public boundary count, and entire WHIR suffix are identical. -/ +theorem clone_blocks_disjoint (ctx : Context) (Q : Nat) (a b : Packet ctx Q) + (different : a.val.entryFrames ≠ b.val.entryFrames) + (i : Fin (blocks ctx a.val)) (j : Fin (blocks ctx b.val)) : + encode ctx Q ⟨a,i⟩ ≠ encode ctx Q ⟨b,j⟩ := by + intro same + exact different (congrArg (fun p : Packet ctx Q => p.val.entryFrames) + (packet_blocks_disjoint ctx Q a b i j same)) + +theorem packet_depth (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + p.val.messages.length ≤ depth (ParameterBounds.config p.val.profile) := + scheduledAdmissible_depth _ _ p.property.2.2.1 + +theorem blocks_positive (ctx : Context) (p : PacketData) : 0 < blocks ctx p := by + have h := width_positive ctx.mode p.profile (p.messages.length-1) + unfold blocks + omega + +instance (ctx : Context) (Q : Nat) (p : Packet ctx Q) : Nonempty (Fin (blocks ctx p.val)) := + ⟨⟨0,blocks_positive ctx p.val⟩⟩ + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective + +instance (ctx : Context) (Q : Nat) : Finite (Position ctx Q) := + Finite.of_injective (encode ctx Q) (encode_injective ctx Q) + +instance (ctx : Context) (Q : Nat) : Finite (Packet ctx Q) := + Finite.of_injective + (fun p : Packet ctx Q => (⟨p,⟨0,blocks_positive ctx p.val⟩⟩ : Position ctx Q)) + (fun _ _ h => congrArg Sigma.fst h) + +noncomputable instance (ctx : Context) (Q : Nat) : Fintype (Packet ctx Q) := Fintype.ofFinite _ + +/-- Profiles are recovered from the one immutable statement catalog, not +independent tags that could split a single physical oracle coordinate. -/ +theorem packet_ext (ctx : Context) (Q : Nat) (a b : Packet ctx Q) + (hs : a.val.statement = b.val.statement) (hm : a.val.messages = b.val.messages) + (he : a.val.entryFrames = b.val.entryFrames) : a = b := by + have hp : a.val.profile = b.val.profile := by + have ha := a.property.1 + rw [hs, b.property.1] at ha + exact (Option.some.inj ha).symm + apply Subtype.ext + rcases a with ⟨⟨sa,pa,ma,ea⟩,ha⟩ + rcases b with ⟨⟨sb,pb,mb,eb⟩,hb⟩ + simp only at hs hm hp he + cases hs + cases hm + cases hp + cases he + rfl + +/-- Every actual scheduled block satisfying the raw mode path bound enters +the partition with precisely its statement, prefix, and block number. -/ +theorem recognize_scheduled (ctx : Context) (Q : Nat) (p : PacketData) + (catalogued : ctx.catalog p.statement = some p.profile) + (nonempty : p.messages ≠ []) + (scheduled : scheduledAdmissible (ParameterBounds.config p.profile) p.messages = true) + (entryValid : ∀ f ∈ p.entryFrames, DuplexEncoding.FrameValid f) + (entryLength : p.entryFrames.length = ctx.entryLength p.statement) + (callerBound : WHIRCallerOutputs.callerOutputCount p.entryFrames ≤ ctx.callerOutputCap) + (block : Nat) (inRange : block < blocks ctx p) + (bounded : pathCost (coordinate ctx p block) ≤ Q) : + recognize ctx Q (constructionKey Q ctx.iv (coordinate ctx p block) bounded) = + some ⟨⟨p,⟨catalogued,nonempty,scheduled, + (by simpa only [pathCost_block] using bounded),entryValid,entryLength,callerBound⟩⟩,⟨block,inRange⟩⟩ := by + let pos : Position ctx Q := ⟨⟨p,⟨catalogued,nonempty,scheduled, + (by simpa only [pathCost_block] using bounded),entryValid,entryLength,callerBound⟩⟩,⟨block,inRange⟩⟩ + change recognize ctx Q (encode ctx Q pos) = some pos + exact recognize_encode ctx Q pos + +theorem recognized_syntax (ctx : Context) (Q : Nat) (raw : RawKey Q) (pos : Position ctx Q) + (recognized : recognize ctx Q raw = some pos) : + expandKey raw = modeKey ctx.iv (coordinate ctx pos.1.val pos.2.val) := by + rw [← encode_recognize ctx Q raw pos recognized] + exact expand_constructionKey _ _ _ _ + +/-- Removing newest messages removes final framed runs, never increases the +uncached public-compression path cost. -/ +theorem canonicalCost_drop_le (w : Nat → Nat) (messages : List Pending) (n : Nat) : + ((canonicalFrames w (messages.drop n)).flatMap DuplexEncoding.framePlan).length ≤ + ((canonicalFrames w messages).flatMap DuplexEncoding.framePlan).length := by + induction n generalizing messages with + | zero => simp + | succ n ih => + cases messages with + | nil => simp + | cons m messages => + rw [List.drop_succ_cons] + apply (ih messages).trans + cases messages with + | nil => simp [canonicalFrames, annotated, encodeSteps] + | cons m' rest => + rw [canonicalFrames_cons w m (m' :: rest) (by simp), + List.flatMap_append, List.length_append] + omega + +theorem packet_drop_valid (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (n : Nat) (nonempty : p.val.messages.drop n ≠ []) : + ValidPacket ctx Q {p.val with messages := p.val.messages.drop n} := by + have hs := scheduledAdmissible_drop _ _ n p.property.2.2.1 + refine ⟨p.property.1,nonempty,hs,?_,packet_entryValid ctx Q p,packet_entryLength ctx Q p, + packet_callerOutputBound ctx Q p⟩ + apply le_trans (b := pathCost (coordinate ctx p.val 0)) _ (packet_pathBound ctx Q p) + have hc := canonicalCost_drop_le (width ctx.mode p.val.profile) p.val.messages n + simp only [coordinate, pathCost, DuplexEncoding.plan, + List.flatMap_append, List.length_cons, List.length_append] + omega + +def dropPacket (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (n : Nat) (nonempty : p.val.messages.drop n ≠ []) : Packet ctx Q := + ⟨{p.val with messages := p.val.messages.drop n},packet_drop_valid ctx Q p n nonempty⟩ + +theorem callerGroups_dropPacket (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (n : Nat) (nonempty : p.val.messages.drop n ≠ []) : + callerGroups ctx Q (dropPacket ctx Q p n nonempty) = callerGroups ctx Q p := rfl + +/-- Oldest first, exactly the strict suffixes needed by canonical completion. +No ancestor reply is selected or encoded by this list of syntax addresses. -/ +def ancestors (ctx : Context) (Q : Nat) (p : Packet ctx Q) : List (Packet ctx Q) := + List.ofFn fun i : Fin (p.val.messages.length-1) => + dropPacket ctx Q p (p.val.messages.length-1-i.val) + (by + intro he + have hl := congrArg List.length he + simp only [List.length_drop, List.length_nil] at hl + have hi := i.isLt + omega) + +theorem callerGroups_ancestor (ctx : Context) (Q : Nat) (p a : Packet ctx Q) + (ha : a ∈ ancestors ctx Q p) : callerGroups ctx Q a = callerGroups ctx Q p := by + obtain ⟨i,rfl⟩ := List.mem_ofFn.mp ha + exact callerGroups_dropPacket ctx Q p _ _ + +theorem ancestors_length (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + (ancestors ctx Q p).length = p.val.messages.length-1 := by + simp [ancestors] + +theorem ancestors_get (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (i : Fin (p.val.messages.length-1)) : + ((ancestors ctx Q p)[i.val]'(by rw [ancestors_length]; exact i.isLt)).val.statement = p.val.statement ∧ + ((ancestors ctx Q p)[i.val]'(by rw [ancestors_length]; exact i.isLt)).val.messages = + p.val.messages.drop (p.val.messages.length-1-i.val) := by + simp [ancestors, dropPacket] + +theorem ancestors_get_entryFrames (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (i : Fin (p.val.messages.length-1)) : + ((ancestors ctx Q p)[i.val]'(by rw [ancestors_length]; exact i.isLt)).val.entryFrames = + p.val.entryFrames := by + simp [ancestors, dropPacket] + +theorem ancestors_depth (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + (ancestors ctx Q p).length + 1 ≤ depth (ParameterBounds.config p.val.profile) := by + have h := packet_depth ctx Q p + have hn := List.length_pos_iff.mpr p.property.2.1 + rw [ancestors_length] + omega + +/-- Every ancestor's own completion chain is exactly the already visited +prefix of the oldest-first chain. This is the cache provenance ordering law. -/ +theorem ancestors_ancestors (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (i : Nat) (hi : i < (ancestors ctx Q p).length) : + ancestors ctx Q ((ancestors ctx Q p)[i]'hi) = (ancestors ctx Q p).take i := by + have hi' : i < p.val.messages.length-1 := by simpa only [ancestors_length] using hi + have ha := ancestors_get ctx Q p ⟨i,hi'⟩ + dsimp only at ha + apply List.ext_getElem + · rw [ancestors_length, ha.2, List.length_drop, List.length_take, ancestors_length] + omega + · intro j hj hk + have hj' : j < i := lt_of_lt_of_le hk (List.length_take_le _ _) + have hjs : j < ((ancestors ctx Q p)[i]'hi).val.messages.length-1 := by + simpa only [ancestors_length] using hj + have inner := ancestors_get ctx Q ((ancestors ctx Q p)[i]'hi) ⟨j,hjs⟩ + have outer := ancestors_get ctx Q p ⟨j,lt_trans hj' hi'⟩ + dsimp only at inner outer + apply packet_ext ctx Q + · rw [List.getElem_take] + exact inner.1.trans (ha.1.trans outer.1.symm) + · rw [List.getElem_take, inner.2, outer.2, ha.2, List.drop_drop, List.length_drop] + congr 1 + omega + · simp [ancestors, dropPacket] + +/-- One closed allocation-depth bound for every profile in the immutable +catalog, covering rejecting as well as accepting scheduled branches. -/ +def maxDepth : Nat := + Finset.univ.sup (fun p : ParameterBounds.Profile => depth (ParameterBounds.config p)) + +theorem profile_depth_le (p : ParameterBounds.Profile) : + depth (ParameterBounds.config p) ≤ maxDepth := + Finset.le_sup (f := fun p : ParameterBounds.Profile => depth (ParameterBounds.config p)) + (Finset.mem_univ p) + +theorem maxDepth_positive : 0 < maxDepth := + lt_of_lt_of_le (by decide : 0 < depth (ParameterBounds.config (0,0))) (profile_depth_le (0,0)) + +theorem ancestors_maxDepth (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + (ancestors ctx Q p).length + 1 ≤ maxDepth := + (ancestors_depth ctx Q p).trans (profile_depth_le p.val.profile) + +theorem completion_ancestors (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (i : Nat) (hi : i < (ancestors ctx Q p ++ [p]).length) : + ancestors ctx Q ((ancestors ctx Q p ++ [p])[i]'hi) = + (ancestors ctx Q p ++ [p]).take i := by + by_cases hlt : i < (ancestors ctx Q p).length + · rw [List.getElem_append_left hlt, + List.take_append_of_le_length (Nat.le_of_lt hlt)] + exact ancestors_ancestors ctx Q p i hlt + · have he : i = (ancestors ctx Q p).length := by + simp only [List.length_append, List.length_singleton] at hi + omega + subst i + simp + +theorem ancestors_drop_one (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (nonempty : p.val.messages.drop 1 ≠ []) : + ancestors ctx Q p = + ancestors ctx Q (dropPacket ctx Q p 1 nonempty) ++ [dropPacket ctx Q p 1 nonempty] := by + have hl : 1 < p.val.messages.length := by + have h := List.length_pos_iff.mpr nonempty + simp only [List.length_drop] at h + omega + have hi : p.val.messages.length-2 < (ancestors ctx Q p).length := by + rw [ancestors_length] + omega + have hg := ancestors_get ctx Q p ⟨p.val.messages.length-2, by omega⟩ + dsimp only at hg + have last : (ancestors ctx Q p)[p.val.messages.length-2]'hi = dropPacket ctx Q p 1 nonempty := by + apply packet_ext ctx Q + · exact hg.1 + · rw [hg.2] + change p.val.messages.drop (p.val.messages.length-1-(p.val.messages.length-2)) = + p.val.messages.drop 1 + congr 1 + omega + · simp [ancestors, dropPacket] + have hp := ancestors_ancestors ctx Q p (p.val.messages.length-2) hi + rw [last] at hp + rw [hp, ← last, List.take_concat_get'] + have he : p.val.messages.length-2+1 = (ancestors ctx Q p).length := by + rw [ancestors_length] + omega + rw [he, List.take_length] + +theorem ancestors_singleton (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (single : p.val.messages.length = 1) : ancestors ctx Q p = [] := by + apply List.length_eq_zero_iff.mp + rw [ancestors_length, single] + +end Whir.RawWHIRKeys diff --git a/verification/whir/Whir/RingMapBatching.lean b/verification/whir/Whir/RingMapBatching.lean new file mode 100644 index 000000000..fbb1900bb --- /dev/null +++ b/verification/whir/Whir/RingMapBatching.lean @@ -0,0 +1,188 @@ +import Whir.RingMapSoundness + +/-! +# Gamma batching before the six-stage ring map + +The error matrix, sent slices, and candidate list are fixed outside both random +challenges. Gamma powers stay inside the additive ring map, as in Annex A. +-/ +namespace Whir.RingMapBatching + +open scoped BigOperators + +variable {E : Type*} [Field E] + +/-- Gamma batches claims before the ring map is applied to each binary slice. -/ +def batchErrors {m : ℕ} (γ : E) (δ : Fin m → Fin 64 → E) : Fin 64 → E := + fun i => ∑ j, γ ^ j.val * δ j i + +variable [Fintype E] [DecidableEq E] + +/-- A genuinely wrong family cannot vanish under gamma batching except at roots +of a nonzero degree-at-most-`m-1` polynomial from one of its erroneous slices. -/ +theorem batch_zero_probability {m : ℕ} (δ : Fin m → Fin 64 → E) (hne : δ ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun γ : E => batchErrors γ δ = 0) ≤ + ((m - 1 : ℕ) : ℚ) / Fintype.card E := by + classical + have hex : ∃ j i, δ j i ≠ 0 := by + contrapose! hne + ext j i + exact hne j i + obtain ⟨j, i, hji⟩ := hex + let p : Polynomial E := ∑ j : Fin m, Polynomial.monomial j.val (δ j i) + have hp : p ≠ 0 := by + intro hp + have hc := congrArg (fun q : Polynomial E => q.coeff j.val) hp + exact hji (by simpa [p, Polynomial.coeff_monomial, ← Fin.ext_iff] using hc) + have hd : p.natDegree ≤ m - 1 := by + apply Polynomial.natDegree_sum_le_of_forall_le + intro k _ + exact (Polynomial.natDegree_monomial_le _).trans (by omega) + have hs : (Finset.univ.filter fun γ : E => batchErrors γ δ = 0) ⊆ + Finset.univ.filter fun γ : E => p.eval γ = 0 := by + intro γ hγ + apply Finset.mem_filter.mpr + refine ⟨Finset.mem_univ _, ?_⟩ + have hi := congrFun (Finset.mem_filter.mp hγ).2 i + simpa [batchErrors, p, Polynomial.eval_finsetSum, Polynomial.eval_monomial, + mul_comm] using hi + exact (show Soundness.uniformProb (Finset.univ.filter fun γ : E => batchErrors γ δ = 0) ≤ + Soundness.uniformProb (Finset.univ.filter fun γ : E => p.eval γ = 0) from + div_le_div_of_nonneg_right (by exact_mod_cast Finset.card_le_card hs) (by positivity)).trans + (Soundness.root_error p hp (m - 1) hd) + +/-- Exact averaging over the independent gamma and map-challenge coordinates. -/ +theorem uniform_product {A B : Type*} [Fintype A] [Fintype B] + (P : A × B → Prop) [DecidablePred P] : + Soundness.uniformProb (Finset.univ.filter P) = + (∑ a : A, Soundness.uniformProb (Finset.univ.filter fun b : B => P (a, b))) / + Fintype.card A := by + classical + simp only [Soundness.uniformProb, Finset.card_filter, Fintype.card_prod, + Fintype.sum_prod_type, Nat.cast_sum, Nat.cast_ite, Nat.cast_one, Nat.cast_zero, + Nat.cast_mul, ← Finset.sum_div] + ring + +/-- Fiber bounds compose with an exceptional gamma event, without requiring +independence of the acceptance predicate itself. -/ +theorem conditional_error {A B : Type*} [Fintype A] [Fintype B] + [Nonempty A] [Nonempty B] (bad : A → Prop) [DecidablePred bad] + (P : A × B → Prop) [DecidablePred P] (a b : ℚ) (hb : 0 ≤ b) + (hbad : Soundness.uniformProb (Finset.univ.filter bad) ≤ a) + (hgood : ∀ x, ¬ bad x → + Soundness.uniformProb (Finset.univ.filter fun y : B => P (x, y)) ≤ b) : + Soundness.uniformProb (Finset.univ.filter P) ≤ a + b := by + classical + have hf (x : A) : + Soundness.uniformProb (Finset.univ.filter fun y : B => P (x, y)) ≤ + (if bad x then 1 else 0) + b := by + by_cases hx : bad x + · have hle : Soundness.uniformProb (Finset.univ.filter fun y : B => P (x, y)) ≤ 1 := by + unfold Soundness.uniformProb + apply (div_le_one (by positivity)).mpr + exact_mod_cast Finset.card_le_univ _ + simpa [hx] using hle.trans (le_add_of_nonneg_right hb) + · simpa [hx] using hgood x hx + rw [uniform_product] + calc + _ ≤ (∑ x : A, ((if bad x then 1 else 0 : ℚ) + b)) / Fintype.card A := + div_le_div_of_nonneg_right (Finset.sum_le_sum fun x _ => hf x) (by positivity) + _ = Soundness.uniformProb (Finset.univ.filter bad) + b := by + simp only [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, + nsmul_eq_mul, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] + rw [add_div, mul_div_cancel_left₀ _ (by positivity)] + _ ≤ a + b := by linarith + +variable [CharP E 2] + +/-- The two independently sampled challenges bound the actual batched map error. -/ +theorem batched_map_error_probability {m : ℕ} (x : E) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (δ : Fin m → Fin 64 → E) (hne : δ ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun r : E × (Fin 6 → E) => + (∑ i : Fin 64, x ^ i.val * RingSwitch.composedMap r.2 (batchErrors r.1 δ i)) = 0) ≤ + ((m - 1 : ℕ) : ℚ) / Fintype.card E + (2 : ℚ)^32 / Fintype.card E := by + apply conditional_error (fun γ : E => batchErrors γ δ = 0) _ _ _ (by positivity) + (batch_zero_probability δ hne) + intro γ hγ + exact RingMapSoundness.map_error_probability x conjugates (batchErrors γ δ) hγ + +/-- Collision probability for the actual family targets, derived from unequal +slice matrices rather than an assumed nonzero target discrepancy. -/ +theorem family_error_probability {m : ℕ} (x : E) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (sent honest : Fin m → Fin 64 → E) (hne : sent ≠ honest) : + Soundness.uniformProb (Finset.univ.filter fun r : E × (Fin 6 → E) => + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) sent = + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) honest) ≤ + ((m - 1 : ℕ) : ℚ) / Fintype.card E + (2 : ℚ)^32 / Fintype.card E := by + convert batched_map_error_probability x conjugates (sent - honest) + (sub_ne_zero.mpr hne) using 1 + congr 1 + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rw [← sub_eq_zero, RingMapSoundness.family_target_discrepancy] + rfl + +/-- The honest comparison is the packed opening target from `honest_family`, +including arbitrary point weights, not a fresh target-error assumption. -/ +theorem honest_family_error_probability {m : ℕ} {U : Type*} [Fintype U] (x : E) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (bits : Fin m → Fin 64 → U → Bool) (weights : Fin m → U → E) + (sent : Fin m → Fin 64 → E) + (hne : sent ≠ fun j => RingSwitch.slice (weights j) (bits j)) : + Soundness.uniformProb (Finset.univ.filter fun r : E × (Fin 6 → E) => + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) sent = + ∑ j : Fin m, ∑ u : U, RingSwitch.composedMap r.2 (r.1 ^ j.val * weights j u) * + RingSwitch.packed (fun i : Fin 64 => x ^ i.val) (bits j) u) ≤ + ((m - 1 : ℕ) : ℚ) / Fintype.card E + (2 : ℚ)^32 / Fintype.card E := by + simpa only [RingSwitch.honest_family] using + family_error_probability x conjugates sent (fun j => RingSwitch.slice (weights j) (bits j)) hne + +/-- The candidate list and sent matrix are fixed before gamma and all six map +challenges. Candidates already equal to the sent matrix cause no false-claim event. -/ +theorem family_fixed_list {m : ℕ} (x : E) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (sent : Fin m → Fin 64 → E) (candidates : Finset (Fin m → Fin 64 → E)) : + Soundness.uniformProb (Finset.univ.filter fun r : E × (Fin 6 → E) => + ∃ honest ∈ candidates, sent ≠ honest ∧ + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) sent = + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) honest) ≤ + (candidates.card : ℚ) * + (((m - 1 : ℕ) : ℚ) / Fintype.card E + (2 : ℚ)^32 / Fintype.card E) := by + classical + let events : ↥candidates → Finset (E × (Fin 6 → E)) := fun honest => + Finset.univ.filter fun r => sent ≠ honest.val ∧ + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) sent = + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) honest.val + have he : (Finset.univ.filter fun r : E × (Fin 6 → E) => + ∃ honest ∈ candidates, sent ≠ honest ∧ + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) sent = + RingSwitch.familyTarget (RingSwitch.composedMap r.2) (fun i : Fin 64 => x ^ i.val) + (fun j : Fin m => r.1 ^ j.val) honest) = Finset.univ.biUnion events := by + ext r + simp [events, and_left_comm] + rw [he] + calc + _ ≤ ∑ honest, Soundness.uniformProb (events honest) := Soundness.union_bound events + _ ≤ ∑ _honest : ↥candidates, + (((m - 1 : ℕ) : ℚ) / Fintype.card E + (2 : ℚ)^32 / Fintype.card E) := by + apply Finset.sum_le_sum + intro honest _ + by_cases hne : sent = honest.val + · simp [events, hne, Soundness.uniformProb] + positivity + · simpa only [events, hne, ne_eq, not_false_eq_true, true_and] using + family_error_probability x conjugates sent honest.val hne + _ = _ := by simp; ring + +end Whir.RingMapBatching diff --git a/verification/whir/Whir/RingMapBatchingConcrete.lean b/verification/whir/Whir/RingMapBatchingConcrete.lean new file mode 100644 index 000000000..159939173 --- /dev/null +++ b/verification/whir/Whir/RingMapBatchingConcrete.lean @@ -0,0 +1,72 @@ +import Whir.RingMapBatching +import Whir.FieldEquivalence + +/-! +# Gamma and ring-map soundness for the actual three-word extension field + +All field laws, cardinality, and 64-conjugate distinctness are proved for the +executable representation. The sent slices and candidate list are fixed before +the independent gamma and six map challenges; no numerical security-level claim +beyond the explicit rational error bounds is made. +-/ +namespace Whir.RingMapBatchingConcrete + +open scoped BigOperators Classical +open Concrete + +/-- Gamma batching alone, for actual extension elements. -/ +theorem batch_zero_probability {m : ℕ} (δ : Fin m → Fin 64 → E) (hne : δ ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun γ : E => + RingMapBatching.batchErrors γ δ = 0) ≤ ((m - 1 : ℕ) : ℚ) / (2 : ℚ)^192 := by + have h := RingMapBatching.batch_zero_probability δ hne + norm_num only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at h ⊢ + exact h + +/-- Actual unequal slice families have gamma loss plus the `2^-160` map loss. -/ +theorem family_error_probability {m : ℕ} (sent honest : Fin m → Fin 64 → E) + (hne : sent ≠ honest) : + Soundness.uniformProb (Finset.univ.filter fun r : E × (Fin 6 → E) => + RingSwitch.familyTarget (RingSwitch.composedMap r.2) + (fun i : Fin 64 => (E.ofK 2) ^ i.val) (fun j : Fin m => r.1 ^ j.val) sent = + RingSwitch.familyTarget (RingSwitch.composedMap r.2) + (fun i : Fin 64 => (E.ofK 2) ^ i.val) (fun j : Fin m => r.1 ^ j.val) honest) ≤ + ((m - 1 : ℕ) : ℚ) / (2 : ℚ)^192 + 1 / (2 : ℚ)^160 := by + have h := RingMapBatching.family_error_probability (E.ofK 2) + FieldModel.actual_conjugates_injective sent honest hne + norm_num only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at h ⊢ + exact h + +/-- The comparison target is the actual honest packed-family opening expression, +with each gamma scale inside the map, for arbitrary honest bit slices and weights. -/ +theorem honest_family_error_probability {m : ℕ} {U : Type*} [Fintype U] + (bits : Fin m → Fin 64 → U → Bool) (weights : Fin m → U → E) + (sent : Fin m → Fin 64 → E) + (hne : sent ≠ fun j => RingSwitch.slice (weights j) (bits j)) : + Soundness.uniformProb (Finset.univ.filter fun r : E × (Fin 6 → E) => + RingSwitch.familyTarget (RingSwitch.composedMap r.2) + (fun i : Fin 64 => (E.ofK 2) ^ i.val) (fun j : Fin m => r.1 ^ j.val) sent = + ∑ j : Fin m, ∑ u : U, RingSwitch.composedMap r.2 (r.1 ^ j.val * weights j u) * + RingSwitch.packed (fun i : Fin 64 => (E.ofK 2) ^ i.val) (bits j) u) ≤ + ((m - 1 : ℕ) : ℚ) / (2 : ℚ)^192 + 1 / (2 : ℚ)^160 := by + have h := RingMapBatching.honest_family_error_probability (E.ofK 2) + FieldModel.actual_conjugates_injective bits weights sent hne + norm_num only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at h ⊢ + exact h + +/-- The candidate list is an input independent of both challenge draws. -/ +theorem family_fixed_list {m : ℕ} (sent : Fin m → Fin 64 → E) + (candidates : Finset (Fin m → Fin 64 → E)) : + Soundness.uniformProb (Finset.univ.filter fun r : E × (Fin 6 → E) => + ∃ honest ∈ candidates, sent ≠ honest ∧ + RingSwitch.familyTarget (RingSwitch.composedMap r.2) + (fun i : Fin 64 => (E.ofK 2) ^ i.val) (fun j : Fin m => r.1 ^ j.val) sent = + RingSwitch.familyTarget (RingSwitch.composedMap r.2) + (fun i : Fin 64 => (E.ofK 2) ^ i.val) (fun j : Fin m => r.1 ^ j.val) honest) ≤ + (candidates.card : ℚ) * + (((m - 1 : ℕ) : ℚ) / (2 : ℚ)^192 + 1 / (2 : ℚ)^160) := by + have h := RingMapBatching.family_fixed_list (E.ofK 2) + FieldModel.actual_conjugates_injective sent candidates + norm_num only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at h ⊢ + exact h + +end Whir.RingMapBatchingConcrete diff --git a/verification/whir/Whir/RingMapConcrete.lean b/verification/whir/Whir/RingMapConcrete.lean new file mode 100644 index 000000000..be168aaa5 --- /dev/null +++ b/verification/whir/Whir/RingMapConcrete.lean @@ -0,0 +1,38 @@ +import Whir.RingMapSoundness +import Whir.FieldEquivalence + +/-! Assumption-free field/basis instantiation of the six-stage map bound for the +actual three-word extension representation. Errors remain fixed before sampling. -/ +namespace Whir.RingMapConcrete +open scoped BigOperators Classical +open Concrete + +/-- Nonzero actual 64-slice errors produce a nonzero challenge polynomial. -/ +theorem discrepancy_ne_zero (errors : Fin 64 → E) (hne : errors ≠ 0) : + RingMapSoundness.discrepancyPolynomial (fun i => (E.ofK 2) ^ i.val) errors ≠ 0 := + RingMapSoundness.discrepancy_ne_zero (E.ofK 2) + FieldModel.actual_conjugates_injective errors hne + +/-- The actual extension has `2^192` elements; six independent uniform +challenges therefore lose at most `2^-160` against a fixed false slice table. -/ +theorem map_error_probability (errors : Fin 64 → E) (hne : errors ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun f : Fin 6 → E => + (∑ i : Fin 64, (E.ofK 2) ^ i.val * RingSwitch.composedMap f (errors i)) = 0) ≤ + 1 / (2:ℚ)^160 := by + have h := RingMapSoundness.map_error_probability (E.ofK 2) + FieldModel.actual_conjugates_injective errors hne + norm_num only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at h ⊢ + exact h + +/-- The concrete fixed-list bound has no field-law or conjugacy hypotheses. -/ +theorem map_error_fixed_list (errors : Finset (Fin 64 → E)) + (nonzero : ∀ e ∈ errors, e ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun f : Fin 6 → E => + ∃ e ∈ errors, (∑ i : Fin 64, (E.ofK 2) ^ i.val * RingSwitch.composedMap f (e i)) = 0) ≤ + (errors.card : ℚ) * (1 / (2:ℚ)^160) := by + have h := RingMapSoundness.map_error_fixed_list (E.ofK 2) + FieldModel.actual_conjugates_injective errors nonzero + norm_num only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at h ⊢ + exact h + +end Whir.RingMapConcrete diff --git a/verification/whir/Whir/RingMapInjectivity.lean b/verification/whir/Whir/RingMapInjectivity.lean new file mode 100644 index 000000000..1e6ed1fac --- /dev/null +++ b/verification/whir/Whir/RingMapInjectivity.lean @@ -0,0 +1,89 @@ +import Whir.RingSwitch +import Mathlib.Algebra.Polynomial.Roots +import Mathlib.Algebra.Polynomial.BigOperators + +/-! +# Frobenius pairing injectivity + +A direct root-count version of Annex A's transpose argument. Raising the `k`th +zero pairing to `2^(n-k)` makes every error coefficient acquire the same power +`2^n`. The resulting degree-at-most-`n` polynomial has the `n+1` distinct +Frobenius conjugates of `x` as roots. This works over the extension field itself, +so coefficients need not lie in the binary base field or its degree-64 extension; +in particular no cubic-coordinate independence assumption is necessary. +-/ +namespace Whir.RingMapInjectivity + +open scoped BigOperators + +variable {E : Type*} [Field E] [CharP E 2] + +/-- The coefficient of the `k`th Frobenius term in an erroneous ring-switch target. -/ +def pairing {n : ℕ} (x : E) (δ : Fin (n + 1) → E) (k : Fin (n + 1)) : E := + ∑ i, x ^ i.val * δ i ^ (2 ^ k.val) + +/-- Distinct conjugates suffice even when the errors lie in an arbitrary extension. -/ +theorem eq_zero_of_pairings_eq_zero {n : ℕ} (x : E) + (conjugates : Function.Injective (fun k : Fin (n + 1) => x ^ (2 ^ k.val))) + (δ : Fin (n + 1) → E) (h : ∀ k, pairing x δ k = 0) : δ = 0 := by + classical + let p : Polynomial E := ∑ i : Fin (n + 1), + Polynomial.monomial i.val (δ i ^ (2 ^ n)) + have heval (k : Fin (n + 1)) : p.eval (x ^ (2 ^ k.val)) = 0 := by + let r : Fin (n + 1) := ⟨n - k.val, by omega⟩ + have hr : r.val + k.val = n := by dsimp [r]; omega + have hp := congrArg (fun a : E => a ^ (2 ^ k.val)) (h r) + rw [zero_pow (by positivity)] at hp + simp only [pairing, sum_pow_char_pow, mul_pow, ← pow_mul, + ← Nat.pow_add, hr] at hp + simpa only [p, Polynomial.eval_finsetSum, Polynomial.eval_monomial, + ← pow_mul, Nat.mul_comm, mul_comm] using hp + have hdegree : p.natDegree ≤ n := by + apply Polynomial.natDegree_sum_le_of_forall_le + intro i _ + exact (Polynomial.natDegree_monomial_le _).trans (by omega) + have hp : p = 0 := Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero + p conjugates heval (by simpa using Nat.lt_succ_of_le hdegree) + funext i + have hc := congrArg (fun q : Polynomial E => q.coeff i.val) hp + simpa [p, Polynomial.coeff_monomial, ← Fin.ext_iff] using hc + +/-- The whole Frobenius pairing map is injective, not merely nonzero on errors. -/ +theorem pairing_injective {n : ℕ} (x : E) + (conjugates : Function.Injective (fun k : Fin (n + 1) => x ^ (2 ^ k.val))) : + Function.Injective (pairing (n := n) x) := by + intro δ ε heq + have hz : δ - ε = 0 := eq_zero_of_pairings_eq_zero x conjugates (δ - ε) (by + intro k + have hk := congrFun heq k + simpa only [pairing, Pi.sub_apply, sub_pow_char_pow, mul_sub, + Finset.sum_sub_distrib, sub_eq_zero] using hk) + exact sub_eq_zero.mp hz + +/-- The 64-term endpoint consumed by the actual six-stage map discrepancy proof. -/ +theorem exists_nonzero_pairing (x : E) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (δ : Fin 64 → E) (hne : δ ≠ 0) : + ∃ k : Fin 64, (∑ i : Fin 64, x ^ i.val * δ i ^ (2 ^ k.val)) ≠ 0 := by + by_contra! h + exact hne (eq_zero_of_pairings_eq_zero (n := 63) x conjugates δ h) + +omit [CharP E 2] in +/-- Field embeddings preserve the exact conjugate-distinctness prerequisite. -/ +theorem conjugates_map {K : Type*} [Field K] {n : ℕ} (φ : K →+* E) (x : K) + (conjugates : Function.Injective (fun k : Fin (n + 1) => x ^ (2 ^ k.val))) : + Function.Injective (fun k : Fin (n + 1) => φ x ^ (2 ^ k.val)) := by + intro k l h + apply conjugates + apply φ.injective + simpa only [map_pow] using h + +/-- Base-field powers are embedded before multiplying arbitrary extension-field errors. -/ +theorem exists_nonzero_pairing_over_base {K : Type*} [Field K] (φ : K →+* E) (x : K) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (δ : Fin 64 → E) (hne : δ ≠ 0) : + ∃ k : Fin 64, (∑ i : Fin 64, φ (x ^ i.val) * δ i ^ (2 ^ k.val)) ≠ 0 := by + simpa only [map_pow] using + exists_nonzero_pairing (φ x) (conjugates_map (n := 63) φ x conjugates) δ hne + +end Whir.RingMapInjectivity diff --git a/verification/whir/Whir/RingMapSoundness.lean b/verification/whir/Whir/RingMapSoundness.lean new file mode 100644 index 000000000..187ce6902 --- /dev/null +++ b/verification/whir/Whir/RingMapSoundness.lean @@ -0,0 +1,310 @@ +import Whir.RingSwitch +import Whir.OODBounds +import Whir.RingMapInjectivity + +/-! Six-stage ring-map expansion and its challenge-polynomial bounds. + +The enumeration is generated by `RingSwitch.composedMap`'s actual stage order. +Kernel-checked finite certificates identify its 64 distinct monomials with the +Annex A coefficient formula and certify their exact maximum degree. + +Nonvanishing uses a stronger direct Frobenius/Vandermonde argument from +`RingMapInjectivity`: raising the kth zero pairing to `2^(63-k)` produces one +degree-at-most-63 polynomial over the extension field with 64 distinct roots. +Consequently the Annex's cubic-basis split is unnecessary as a prerequisite. +Concrete instantiation still requires exact characteristic-two field operations, +the base-field embedding, 64 distinct conjugates of the represented base +generator, and (for the numeric 192-bit bound) the extension's cardinality. +Neither discrepancy nonvanishing nor any probability bound is assumed. -/ +namespace Whir.RingMapSoundness +open scoped BigOperators +open MvPolynomial + +abbrev Term := (Fin 6 → ℕ) × ℕ + +def nextTerm (p : Fin 6) (t : Term) : Term := + (fun i => (if i = p then 1 else 0) + 2 ^ (2 ^ (5 - p.val)) * t.1 i, + 2 ^ (5 - p.val) + t.2) + +def nextTerms (p : Fin 6) (ts : List Term) : List Term := + ts ++ ts.map (nextTerm p) + +def terms : List Term := + (List.finRange 6).foldl (fun ts p => nextTerms p ts) [(fun _ => 0, 0)] + +noncomputable def exponent (t : Term) : Fin 6 →₀ ℕ := + Finsupp.equivFunOnFinite.symm t.1 + +variable {E : Type*} [CommRing E] [CharP E 2] + +noncomputable def termPolynomial (a : E) (t : Term) : MvPolynomial (Fin 6) E := + monomial (exponent t) (a ^ (2 ^ t.2)) + +noncomputable def termsPolynomial (a : E) (ts : List Term) : MvPolynomial (Fin 6) E := + (ts.map (termPolynomial a)).sum + +theorem exponent_next (p : Fin 6) (t : Term) : + exponent (nextTerm p t) = Finsupp.single p 1 + + 2 ^ (2 ^ (5 - p.val)) • exponent t := by + classical + ext i + simp [exponent, nextTerm, Finsupp.single_apply, eq_comm] + +omit [CharP E 2] in +theorem termPolynomial_next (a : E) (p : Fin 6) (t : Term) : + termPolynomial a (nextTerm p t) = + X p * termPolynomial a t ^ (2 ^ (2 ^ (5 - p.val))) := by + rw [termPolynomial, exponent_next] + simp only [termPolynomial, X, monomial_pow, monomial_mul_monomial, one_mul] + congr 1 + simp [nextTerm, pow_mul, Nat.pow_add, Nat.mul_comm] + +theorem stage_termsPolynomial (a : E) (p : Fin 6) (ts : List Term) : + RingSwitch.stage (X p) (2 ^ (5 - p.val)) (termsPolynomial a ts) = + termsPolynomial a (nextTerms p ts) := by + simp only [RingSwitch.stage, AddMonoidHom.coe_mk, ZeroHom.coe_mk, + termsPolynomial, nextTerms, List.map_append, List.sum_append, + list_sum_pow_char_pow, List.map_map] + congr 1 + induction ts with + | nil => simp + | cons t ts ih => + simp only [List.map_cons, List.sum_cons, mul_add, Function.comp_apply, + ← termPolynomial_next, ih] + +theorem fold_apply (ps : List (Fin 6)) (φ : E →+ E) (f : Fin 6 → E) (a : E) : + (ps.foldl (fun φ p => (RingSwitch.stage (f p) (2 ^ (5 - p.val))).comp φ) φ) a = + ps.foldl (fun b p => RingSwitch.stage (f p) (2 ^ (5 - p.val)) b) (φ a) := by + induction ps generalizing φ with + | nil => rfl + | cons p ps ih => + simpa only [List.foldl_cons, AddMonoidHom.comp_apply] using + (ih ((RingSwitch.stage (f p) (2 ^ (5 - p.val))).comp φ)) + +theorem fold_expansion (a : E) (ps : List (Fin 6)) (ts : List Term) : + (ps.foldl (fun φ p => (RingSwitch.stage (X p) (2 ^ (5 - p.val))).comp φ) + (AddMonoidHom.id _)) (termsPolynomial a ts) = + termsPolynomial a (ps.foldl (fun ts p => nextTerms p ts) ts) := by + rw [fold_apply] + simp only [AddMonoidHom.id_apply] + induction ps generalizing ts with + | nil => rfl + | cons p ps ih => + simpa only [List.foldl_cons, stage_termsPolynomial] using ih (nextTerms p ts) + + +/-- The list is generated by the actual stage order, not by an independent +coefficient sampler. All combinatorial checks below reduce in the kernel. -/ +theorem terms_length : terms.length = 64 := by decide + +theorem terms_exponents_distinct : (terms.map Prod.fst).Nodup := by decide + +theorem terms_shifts : ∀ k : Fin 64, ∃ t ∈ terms, t.2 = k.val := by decide + +theorem terms_shift_range : ∀ t ∈ terms, t.2 < 64 := by decide + +/-- Annex A's closed coefficient formula, certified for every generated term. -/ +theorem terms_closed_formula : ∀ t ∈ terms, ∀ p : Fin 6, + t.1 p = if t.2 / 2 ^ (5 - p.val) % 2 = 1 + then 2 ^ (t.2 % 2 ^ (5 - p.val)) else 0 := by decide + +theorem terms_max_degree : ∃ t ∈ terms, t.2 = 63 ∧ + (∑ p : Fin 6, t.1 p) = 2^31 + 2^15 + 2^7 + 2^3 + 2 + 1 := by decide + +theorem terms_degree : ∀ t ∈ terms, + (∑ p : Fin 6, t.1 p) ≤ 2^31 + 2^15 + 2^7 + 2^3 + 2 + 1 := by decide + +theorem degree_budget : 2^31 + 2^15 + 2^7 + 2^3 + 2 + 1 < (2:ℕ)^32 := by norm_num + +theorem composedMap_symbolic (a : E) : + RingSwitch.composedMap (fun p => (X p : MvPolynomial (Fin 6) E)) (C a) = + termsPolynomial a terms := by + have h := fold_expansion a (List.finRange 6) [(fun _ => 0, 0)] + have h0 : termsPolynomial a [(fun _ => 0, 0)] = C a := by + have hz : exponent ((fun _ => 0), 0) = 0 := by ext p; simp [exponent] + simp [termsPolynomial, termPolynomial, hz] + rw [h0] at h + exact h + +theorem eval_composedMap (a : E) (f : Fin 6 → E) : + eval f (RingSwitch.composedMap (fun p => (X p : MvPolynomial (Fin 6) E)) (C a)) = + RingSwitch.composedMap f a := by + simp only [RingSwitch.composedMap, fold_apply, AddMonoidHom.id_apply] + generalize List.finRange 6 = ps + have h (ps : List (Fin 6)) (b : MvPolynomial (Fin 6) E) : + eval f (ps.foldl (fun b p => RingSwitch.stage (X p) (2 ^ (5 - p.val)) b) b) = + ps.foldl (fun b p => RingSwitch.stage (f p) (2 ^ (5 - p.val)) b) (eval f b) := by + induction ps generalizing b with + | nil => rfl + | cons p ps ih => + simp only [List.foldl_cons, ih] + congr 1 + simp [RingSwitch.stage] + simpa using h ps (C a) + +theorem terms_nodup : terms.Nodup := List.Nodup.of_map _ terms_exponents_distinct + +theorem exponent_injective_on (s : Term) (hs : s ∈ terms) (t : Term) (ht : t ∈ terms) + (h : exponent s = exponent t) : s = t := by + apply (List.nodup_map_iff_inj_on terms_nodup).mp terms_exponents_distinct s hs t ht + exact Finsupp.equivFunOnFinite.symm.injective h + +omit [CharP E 2] in +theorem termsPolynomial_sum (a : E) : + termsPolynomial a terms = ∑ t ∈ terms.toFinset, termPolynomial a t := by + classical + exact (List.sum_toFinset _ terms_nodup).symm + +/-- The actual implementation is a sum of 64 distinct challenge monomials, +with the Frobenius index and each challenge exponent given above. -/ +theorem composedMap_expansion (a : E) (f : Fin 6 → E) : + RingSwitch.composedMap f a = + ∑ t ∈ terms.toFinset, (a ^ (2 ^ t.2)) * ∏ p : Fin 6, f p ^ t.1 p := by + rw [← eval_composedMap, composedMap_symbolic, termsPolynomial_sum, map_sum] + apply Finset.sum_congr rfl + intro t _ + simp [termPolynomial, eval_monomial, exponent, Finsupp.prod_fintype] + +omit [CharP E 2] in +theorem coeff_termsPolynomial (a : E) (t : Term) (ht : t ∈ terms) : + (termsPolynomial a terms).coeff (exponent t) = a ^ (2 ^ t.2) := by + classical + rw [termsPolynomial_sum, coeff_sum] + rw [Finset.sum_eq_single t] + · simp [termPolynomial] + · intro s hs hne + simp only [termPolynomial, coeff_monomial] + split_ifs with h + · exact (hne (exponent_injective_on s (List.mem_toFinset.mp hs) t ht h)).elim + · rfl + · simp [ht] + +omit [CharP E 2] in +theorem termsPolynomial_degree (a : E) : + (termsPolynomial a terms).totalDegree ≤ 2^31 + 2^15 + 2^7 + 2^3 + 2 + 1 := by + classical + rw [termsPolynomial_sum] + apply (totalDegree_finsetSum _ _).trans + apply Finset.sup_le + intro t ht + apply (totalDegree_monomial_le (exponent t) (a ^ (2 ^ t.2))).trans + rw [Finsupp.sum_fintype _ _ (fun _ => rfl)] + exact terms_degree t (List.mem_toFinset.mp ht) + +/-- Fixed slice errors give an actual six-challenge polynomial. -/ +noncomputable def discrepancyPolynomial (basis errors : Fin 64 → E) : + MvPolynomial (Fin 6) E := + ∑ i, C (basis i) * termsPolynomial (errors i) terms + +theorem discrepancy_eval (basis errors : Fin 64 → E) (f : Fin 6 → E) : + eval f (discrepancyPolynomial basis errors) = + ∑ i, basis i * RingSwitch.composedMap f (errors i) := by + simp only [discrepancyPolynomial, map_sum, map_mul, eval_C, + ← composedMap_symbolic, eval_composedMap] + +omit [CharP E 2] in +theorem discrepancy_coeff (basis errors : Fin 64 → E) (t : Term) (ht : t ∈ terms) : + (discrepancyPolynomial basis errors).coeff (exponent t) = + ∑ i, basis i * errors i ^ (2 ^ t.2) := by + simp only [discrepancyPolynomial, coeff_sum, coeff_C_mul, coeff_termsPolynomial _ t ht] + +omit [CharP E 2] in +theorem discrepancy_degree (basis errors : Fin 64 → E) : + (discrepancyPolynomial basis errors).totalDegree ≤ 2^31 + 2^15 + 2^7 + 2^3 + 2 + 1 := by + apply (totalDegree_finsetSum _ _).trans + apply Finset.sup_le + intro i _ + exact (totalDegree_mul _ _).trans (by simpa using termsPolynomial_degree (errors i)) + +/-- The dishonest-minus-honest family target is precisely the discrepancy +tested below. In particular each batching scale remains inside the map. -/ +theorem family_target_discrepancy {J : Type*} [Fintype J] + (f : Fin 6 → E) (basis : Fin 64 → E) (scales : J → E) + (sent honest : J → Fin 64 → E) : + RingSwitch.familyTarget (RingSwitch.composedMap f) basis scales sent - + RingSwitch.familyTarget (RingSwitch.composedMap f) basis scales honest = + ∑ i, basis i * RingSwitch.composedMap f + (∑ j, scales j * (sent j i - honest j i)) := by + simp only [RingSwitch.familyTarget, mul_sub, Finset.sum_sub_distrib, map_sub] + +section Field +variable {F : Type*} [Field F] [CharP F 2] + +/-- Distinct base-field conjugates, rather than an assumed nonzero discrepancy, +force a nonzero coefficient in the actual six-stage challenge polynomial. -/ +theorem discrepancy_ne_zero (x : F) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (errors : Fin 64 → F) (hne : errors ≠ 0) : + discrepancyPolynomial (fun i => x ^ i.val) errors ≠ 0 := by + obtain ⟨k, hk⟩ := RingMapInjectivity.exists_nonzero_pairing x conjugates errors hne + obtain ⟨t, ht, htk⟩ := terms_shifts k + intro h + have hc := congrArg (fun p : MvPolynomial (Fin 6) F => p.coeff (exponent t)) h + simp only [discrepancy_coeff _ _ t ht, htk] at hc + exact hk hc + +variable [Fintype F] [DecidableEq F] + +/-- Six independent uniform challenges: soundness follows from the actual map, +its 64 distinct monomials, conjugate injectivity, and Schwartz--Zippel. -/ +theorem map_error_probability (x : F) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (errors : Fin 64 → F) (hne : errors ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun f : Fin 6 → F => + (∑ i : Fin 64, x ^ i.val * RingSwitch.composedMap f (errors i)) = 0) ≤ + ((2:ℚ)^32) / Fintype.card F := by + classical + have hp := discrepancy_ne_zero x conjugates errors hne + have hs := schwartz_zippel_totalDegree hp (Finset.univ : Finset F) + simp [discrepancy_eval] at hs + have hs' : + ((Finset.univ.filter fun f : Fin 6 → F => + (∑ i : Fin 64, x ^ i.val * RingSwitch.composedMap f (errors i)) = 0).card : ℚ) / + (Fintype.card F : ℚ)^6 ≤ + ((discrepancyPolynomial (fun i => x ^ i.val) errors).totalDegree : ℚ) / + Fintype.card F := by exact_mod_cast hs + have hd : (discrepancyPolynomial (fun i => x ^ i.val) errors).totalDegree ≤ (2:ℕ)^32 := + (discrepancy_degree _ _).trans degree_budget.le + unfold Soundness.uniformProb + simpa [Fintype.card_fun] using hs'.trans + (div_le_div_of_nonneg_right (by exact_mod_cast hd) (by positivity)) + +/-- The base/extension bridge needs an exact ring embedding and distinct base +conjugates; it does not need a new map-correctness or cubic-independence axiom. -/ +theorem map_error_probability_over_base {K : Type*} [Field K] + (φ : K →+* F) (x : K) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (errors : Fin 64 → F) (hne : errors ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun f : Fin 6 → F => + (∑ i : Fin 64, φ (x ^ i.val) * RingSwitch.composedMap f (errors i)) = 0) ≤ + ((2:ℚ)^32) / Fintype.card F := by + simpa only [map_pow] using + map_error_probability (φ x) (RingMapInjectivity.conjugates_map φ x conjugates) errors hne + +/-- The error list is a fixed input, not a function of the six challenges. +This is the union bound used after commitment-fixed list decoding. -/ +theorem map_error_fixed_list (x : F) + (conjugates : Function.Injective (fun k : Fin 64 => x ^ (2 ^ k.val))) + (errors : Finset (Fin 64 → F)) (nonzero : ∀ e ∈ errors, e ≠ 0) : + Soundness.uniformProb (Finset.univ.filter fun f : Fin 6 → F => + ∃ e ∈ errors, (∑ i : Fin 64, x ^ i.val * RingSwitch.composedMap f (e i)) = 0) ≤ + (errors.card : ℚ) * (((2:ℚ)^32) / Fintype.card F) := by + classical + let events : ↥errors → Finset (Fin 6 → F) := fun e => + Finset.univ.filter fun f => (∑ i : Fin 64, x ^ i.val * + RingSwitch.composedMap f (e.val i)) = 0 + have he : (Finset.univ.filter fun f : Fin 6 → F => + ∃ e ∈ errors, (∑ i : Fin 64, x ^ i.val * RingSwitch.composedMap f (e i)) = 0) = + Finset.univ.biUnion events := by + ext f + simp [events] + rw [he] + calc + _ ≤ ∑ e, Soundness.uniformProb (events e) := Soundness.union_bound events + _ ≤ ∑ _e : ↥errors, (((2:ℚ)^32) / Fintype.card F) := + Finset.sum_le_sum fun e _ => map_error_probability x conjugates e.val (nonzero e.val e.property) + _ = _ := by simp + +end Field + +end Whir.RingMapSoundness diff --git a/verification/whir/Whir/RingPCSGame.lean b/verification/whir/Whir/RingPCSGame.lean new file mode 100644 index 000000000..66d27dac8 --- /dev/null +++ b/verification/whir/Whir/RingPCSGame.lean @@ -0,0 +1,333 @@ +import Whir.InteractiveSoundness +import Whir.RingMapBatchingConcrete +import Whir.ByteCodec + +/-! Ordinary interactive ring-family openings. The commitment determines the K candidate list before the caller supplies any statements. Caller binding of the slice tables, points and values is an external context boundary, not a transcript guarantee. Gamma and six map draws precede the actual WHIR initial lambda. + +The executable transformation is the flattened, statement-checked semantics of `stack_open.rs` and `ring_switch.rs`: region order then claim order, gamma scales inside the six-stage additive map, family at lambda power zero, and points at succeeding powers. Source statement rejection can only restrict the accepted event bounded here. Dense transparent weights are passed to the actual causal WHIR experiment, not to a replacement dot-product acceptance predicate. + +The checked word-polynomial embedding proves the bridge from literal padded K witnesses to binary slices. The end-to-end loss is `2^32 * ((m-1)/2^192 + 2^-160)` plus the actual WHIR interactive ledger. `InitialEvent` instead groups all eight initial scalars for the eventual ROM adapter. No grinding amplification, unique binding, caller transcript binding, or Fiat-Shamir conclusion is asserted here. -/ +namespace Whir.RingPCSGame +open Concrete Protocol CausalGame ParameterBounds +open scoped BigOperators +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 + +abbrev Prefix := E × (Fin 6 → E) + +/-- The source squares exactly shift times, rather than evaluating a unary power. -/ +def squareIter (x : E) : Nat → E + | 0 => x + | n + 1 => let y := squareIter x n; y * y + +theorem squareIter_eq (x : E) (n : Nat) : squareIter x n = x ^ (2 ^ n) := by + induction n with + | zero => simp [squareIter] + | succ n ih => simp [squareIter, ih, pow_succ, pow_mul] + +def mapStage (f : E) (shift : Nat) : E →+ E where + toFun x := x + f * squareIter x shift + map_zero' := by simp [squareIter_eq] + map_add' a b := by + simp only [squareIter_eq, add_pow_char_pow, mul_add] + abel + +theorem mapStage_eq (f : E) (shift : Nat) : mapStage f shift = RingSwitch.stage f shift := by + ext x + exact congrArg (fun y => x + f * y) (squareIter_eq x shift) + +def executableMap (challenges : Fin 6 → E) : E →+ E := + (List.finRange 6).foldl + (fun φ p => (mapStage (challenges p) (2 ^ (5 - p.val))).comp φ) + (AddMonoidHom.id E) + +@[simp] theorem executableMap_eq (challenges : Fin 6 → E) : + executableMap challenges = RingSwitch.composedMap challenges := by + simp only [executableMap, mapStage_eq, RingSwitch.composedMap] + +def basis (i : Fin 64) : E := (E.ofK 2) ^ i.val + +def wordBit (a : K) (i : Fin 64) : Bool := a.toBitVec.getLsbD i.val + +/-- The literal machine word is its binary polynomial, not an assumed encoding. -/ +theorem word_packed (a : K) : + E.ofK a = ∑ i : Fin 64, RingSwitch.bit (wordBit a i) * basis i := by + rw [← FieldModel.baseEmbedding_word] + unfold FieldModel.toBaseQuotient FieldModel.wordPoly FieldModel.bitPoly + rw [map_sum, map_sum, ← Fin.sum_univ_eq_sum_range] + apply Finset.sum_congr rfl + intro i _ + rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_mul, map_pow, map_pow] + change FieldModel.baseEmbedding (AdjoinRoot.mk FieldModel.baseModulus + (Polynomial.C (if a.toBitVec.getLsbD i.val then 1 else 0))) * + FieldModel.baseEmbedding (AdjoinRoot.root FieldModel.baseModulus) ^ i.val = _ + rw [FieldModel.baseEmbedding_root] + cases h : a.toBitVec.getLsbD i.val <;> + simp only [wordBit, RingSwitch.bit, basis, h, Bool.false_eq_true, ↓reduceIte, + map_zero, map_one, zero_mul, one_mul] + +/-- The byte codec reconstructs precisely the word used by the slice bridge. -/ +theorem decoded_word_packed (bytes : Fin 8 → FiatShamirGame.Byte) : + E.ofK (ByteCodec.decodeK bytes) = + ∑ i : Fin 64, RingSwitch.bit (wordBit (ByteCodec.decodeK bytes) i) * basis i := + word_packed _ + +/-- A flattened ring claim, in region order then claim order as in Rust. -/ +structure FamilyClaim where + offset : Nat + point : Array E + slices : Fin 64 → E + +/-- Both source point forms, with their exact stack placement. -/ +inductive PointClaim where + | point (offset : Nat) (point : Array E) (value : E) + | strided (offset slot strideLog : Nat) (point : Array E) (value : E) + +def eqWeight (point : Array E) (u : Nat) : E := + ∏ i : Fin point.size, if u.testBit i.val then point[i] else 1 + point[i] + +def regionWeight (offset : Nat) (point : Array E) (v : Nat) : E := + if offset ≤ v ∧ v < offset + 2 ^ point.size then eqWeight point (v - offset) else 0 + +def pointWeight : PointClaim → Nat → E + | .point offset point _, v => regionWeight offset point v + | .strided offset slot strideLog point _, v => + if offset + slot ≤ v ∧ v < offset + 2 ^ (strideLog + point.size) ∧ + (v - offset) % 2 ^ strideLog = slot then + eqWeight point ((v - offset) / 2 ^ strideLog) else 0 + +def pointValue : PointClaim → E + | .point _ _ value => value + | .strided _ _ _ _ value => value + +def publicPoint (width : Nat) (claim : PointClaim) : Claim := + ⟨tab width (pointWeight claim), pointValue claim⟩ + +def familyTarget {m : Nat} (sent : Fin m → Fin 64 → E) (r : Prefix) : E := + RingSwitch.familyTarget (executableMap r.2) basis (fun j => r.1 ^ j.val) sent + +/-- Each gamma power stays inside the additive, generally non-E-linear map. -/ +def transparentWeight {m : Nat} (family : Fin m → FamilyClaim) (r : Prefix) (v : Nat) : E := + ∑ j, executableMap r.2 (r.1 ^ j.val * regionWeight (family j).offset (family j).point v) + +def familyPublic {m : Nat} (width : Nat) (family : Fin m → FamilyClaim) (r : Prefix) : Claim := + ⟨tab width (transparentWeight family r), familyTarget (fun j => (family j).slices) r⟩ + +/-- Family first, then point claims. Actual batchClaims therefore uses lambda^0 +for the family and lambda^(i+1) for point i, including the empty family. -/ +def transformedClaims {m : Nat} (width : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (r : Prefix) : Array Claim := + #[familyPublic width family r] ++ points.map (publicPoint width) + +@[simp] theorem transformedClaims_size {m : Nat} (width : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (r : Prefix) : + (transformedClaims width family points r).size = 1 + points.size := by + simp [transformedClaims] + +def paddedWord (c : Config) (lanes : Nat) (w : Witness c lanes) (v : Nat) : K := + (Array.ofFn w)[v]?.getD 0 + +def honestSlices {m : Nat} (c : Config) (lanes : Nat) (family : Fin m → FamilyClaim) + (w : Witness c lanes) : Fin m → Fin 64 → E := fun j => + RingSwitch.slice (fun v : Fin (2 ^ c.logN) => regionWeight (family j).offset (family j).point v.val) + (fun i v => wordBit (paddedWord c lanes w v.val) i) + +/-- Honesty is stated about the original slices and every original point value. -/ +def Honest {m : Nat} (c : Config) (lanes : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (w : Witness c lanes) : Prop := + (fun j => (family j).slices) = honestSlices c lanes family w ∧ + ∀ point ∈ points.toList, + dot (paddedWitness c lanes w) (publicPoint (2 ^ c.logN) point).weight = pointValue point + +theorem dot_family {m : Nat} (c : Config) (lanes : Nat) (family : Fin m → FamilyClaim) + (w : Witness c lanes) (r : Prefix) : + dot (paddedWitness c lanes w) (familyPublic (2 ^ c.logN) family r).weight = + familyTarget (honestSlices c lanes family w) r := by + unfold familyTarget honestSlices + rw [RingSwitch.honest_family] + simp only [RingSwitch.packed, ← word_packed] + rw [ArrayAlgebra.dot_eq_sum] + simp only [paddedWitness, familyPublic, ArrayLayout.size_tab, min_self] + rw [← Fin.sum_univ_eq_sum_range, Finset.sum_comm] + apply Finset.sum_congr rfl + intro v _ + simp only [ArrayLayout.getElem!_tab _ _ _ v.isLt, transparentWeight, Finset.mul_sum] + apply Finset.sum_congr rfl + intro j _ + exact mul_comm _ _ + +/-- The actual batching polynomial assigns the family its constant term. -/ +theorem initial_polynomial_constant {m : Nat} (c : Config) (lanes : Nat) + (family : Fin m → FamilyClaim) (points : Array PointClaim) + (w : Witness c lanes) (r : Prefix) : + (InitialBatching.errorPolynomial (paddedWitness c lanes w) + (transformedClaims (2 ^ c.logN) family points r)).coeff 0 = + familyTarget (honestSlices c lanes family w) r - + familyTarget (fun j => (family j).slices) r := by + rw [InitialBatching.errorPolynomial_coeff _ _ 0 (by simp)] + simp [InitialBatching.claimError, transformedClaims, familyPublic] + exact dot_family c lanes family w r + +/-- Original point i occupies exactly lambda^(i+1), not lambda^i. -/ +theorem initial_polynomial_point {m : Nat} (width : Nat) + (family : Fin m → FamilyClaim) (points : Array PointClaim) (f : Array E) + (r : Prefix) (i : Fin points.size) : + (InitialBatching.errorPolynomial f (transformedClaims width family points r)).coeff (i.val + 1) = + dot f (publicPoint width points[i]).weight - pointValue points[i] := by + rw [InitialBatching.errorPolynomial_coeff _ _ _ (by simp; omega)] + rw [getElem!_pos _ _ (by simp; omega)] + unfold transformedClaims + rw [Array.getElem_append_right (by simp)] + simp [InitialBatching.claimError, publicPoint] + +open Classical + +/-- The only ring escape charged: unequal fixed slice tables collide under the +sampled actual family map. The image list is derived from the commitment K list. -/ +def Escape {m : Nat} (c : Config) (lanes : Nat) (root : BaseOracle) + (family : Fin m → FamilyClaim) (r : Prefix) : Prop := + ∃ w ∈ InitialCandidates.witnesses c lanes root, + (fun j => (family j).slices) ≠ honestSlices c lanes family w ∧ + familyTarget (fun j => (family j).slices) r = familyTarget (honestSlices c lanes family w) r + +/-- A false original statement is either a real fixed-list ring escape or a +false transformed public opening. No target-error premise is supplied. -/ +theorem false_or_escape {m : Nat} (c : Config) (lanes : Nat) (root : BaseOracle) + (family : Fin m → FamilyClaim) (points : Array PointClaim) (r : Prefix) + (hfalse : ¬ ∃ w ∈ InitialCandidates.witnesses c lanes root, Honest c lanes family points w) + (outside : ¬ Escape c lanes root family r) : + ¬ ∃ w ∈ InitialCandidates.witnesses c lanes root, + ∀ claim ∈ (transformedClaims (2 ^ c.logN) family points r).toList, + dot (paddedWitness c lanes w) claim.weight = claim.value := by + rintro ⟨w, hw, claims⟩ + have hf := claims (familyPublic (2 ^ c.logN) family r) (by simp [transformedClaims]) + rw [dot_family] at hf + have hs : (fun j => (family j).slices) = honestSlices c lanes family w := by + by_contra ne + exact outside ⟨w, hw, ne, hf.symm⟩ + apply hfalse + refine ⟨w, hw, hs, ?_⟩ + intro point hp + apply claims (publicPoint (2 ^ c.logN) point) + simp only [transformedClaims, Array.toList_append, Array.toList_map, + List.mem_append, List.mem_map] + exact Or.inr ⟨point, hp, rfl⟩ + +theorem escape_probability {m : Nat} (p : Profile) (lanes : Nat) (root : BaseOracle) + (family : Fin m → FamilyClaim) : + Soundness.uniformProb (Finset.univ.filter (Escape (config p) lanes root family)) ≤ + (2 ^ 32 : ℚ) * (((m - 1 : Nat) : ℚ) / 2 ^ 192 + 1 / 2 ^ 160) := by + let candidates := (InitialCandidates.witnesses (config p) lanes root).image + (honestSlices (config p) lanes family) + have h := RingMapBatchingConcrete.family_fixed_list (fun j => (family j).slices) candidates + have heq : (Finset.univ.filter (Escape (config p) lanes root family)) = + (Finset.univ.filter fun r : Prefix => ∃ honest ∈ candidates, + (fun j => (family j).slices) ≠ honest ∧ + familyTarget (fun j => (family j).slices) r = familyTarget honest r) := by + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Escape, candidates, Finset.mem_image] + constructor + · rintro ⟨w, hw, ne, he⟩ + exact ⟨_, ⟨w, hw, rfl⟩, ne, he⟩ + · rintro ⟨_, ⟨w, hw, rfl⟩, ne, he⟩ + exact ⟨w, hw, ne, he⟩ + rw [heq] + simp only [familyTarget, executableMap_eq] + apply h.trans + apply mul_le_mul_of_nonneg_right _ (by positivity) + exact_mod_cast (Finset.card_image_le.trans (InitialCandidates.production_witnesses_card p lanes root)) + +/-- Executable experiment: expose gamma and six map scalars, then run the actual +causal WHIR verifier, whose first draw is lambda. The strategy may depend on the +whole ring prefix but never on a future WHIR challenge. -/ +def experiment {m : Nat} (p : Profile) (lanes : Nat) (root : BaseOracle) + (family : Fin m → FamilyClaim) (points : Array PointClaim) + (strategy : Prefix → Strategy) (randomness : Prefix × Tape (config p)) : Bool := + CausalGame.experiment (ExecutionShapes.Input p lanes root + (transformedClaims (2 ^ (config p).logN) family points randomness.1)) + (strategy randomness.1) randomness.2 + +private theorem probability_mono {Ω : Type*} [Fintype Ω] (P Q : Ω → Prop) + [DecidablePred P] [DecidablePred Q] (h : ∀ ω, P ω → Q ω) : + Soundness.uniformProb (Finset.univ.filter P) ≤ + Soundness.uniformProb (Finset.univ.filter Q) := by + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_le_card (show Finset.univ.filter P ⊆ Finset.univ.filter Q from + fun ω hω => Finset.mem_filter.mpr ⟨Finset.mem_univ _, h ω (Finset.mem_filter.mp hω).2⟩) + +/-- Ordinary interactive ring plus actual PCS accepted-false bound, with no +independence restriction on the post-prefix causal strategy. -/ +theorem opening_probability {m : Nat} (p : Profile) (lanes : Nat) (root : BaseOracle) + (family : Fin m → FamilyClaim) (points : Array PointClaim) (strategy : Prefix → Strategy) : + Soundness.uniformProb (Finset.univ.filter fun randomness : Prefix × Tape (config p) => + experiment p lanes root family points strategy randomness = true ∧ + ¬ ∃ w ∈ InitialCandidates.witnesses (config p) lanes root, + Honest (config p) lanes family points w) ≤ + (2 ^ 32 : ℚ) * (((m - 1 : Nat) : ℚ) / 2 ^ 192 + 1 / 2 ^ 160) + + GroupedChallenges.interactiveError (config p) (estimates (config p)) (1 + points.size) := by + classical + simp only [experiment] + apply RingMapBatching.conditional_error (Escape (config p) lanes root family) _ _ _ + (InteractiveSoundness.error_nonneg _ _) (escape_probability p lanes root family) + intro r outside + have h := InteractiveSoundness.opening_probability p lanes root + (transformedClaims (2 ^ (config p).logN) family points r) (strategy r) + rw [transformedClaims_size] at h + apply (probability_mono _ _ ?_).trans h + intro t ht + exact ⟨ht.1, false_or_escape (config p) lanes root family points r ht.2 outside⟩ + +/-- The list quantifier is outside every family, point and adaptive strategy. -/ +theorem adaptive_list_binding (p : Profile) (lanes : Nat) (root : BaseOracle) : + ∃ candidates : Finset (Witness (config p) lanes), candidates.card ≤ 2 ^ 32 ∧ + ∀ (m : Nat) (family : Fin m → FamilyClaim) (points : Array PointClaim) (strategy : Prefix → Strategy), + Soundness.uniformProb (Finset.univ.filter fun randomness : Prefix × Tape (config p) => + experiment p lanes root family points strategy randomness = true ∧ + ¬ ∃ w ∈ candidates, Honest (config p) lanes family points w) ≤ + (2 ^ 32 : ℚ) * (((m - 1 : Nat) : ℚ) / 2 ^ 192 + 1 / 2 ^ 160) + + GroupedChallenges.interactiveError (config p) (estimates (config p)) (1 + points.size) := + ⟨InitialCandidates.witnesses (config p) lanes root, + InitialCandidates.production_witnesses_card p lanes root, + fun _ family points strategy => opening_probability p lanes root family points strategy⟩ + +theorem transformedClaims_shapes {m : Nat} (width : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (r : Prefix) + (j : Fin (transformedClaims width family points r).size) : + (transformedClaims width family points r)[j].weight.size = width := by + have all : ∀ claim ∈ (transformedClaims width family points r).toList, + claim.weight.size = width := by + intro claim hc + simp only [transformedClaims, Array.toList_append, Array.toList_map, + List.mem_append, List.mem_map] at hc + rcases hc with hc | ⟨point, _, rfl⟩ + · have eq : claim = familyPublic width family r := by simpa using hc + simp [eq, familyPublic, ArrayLayout.size_tab] + · simp [publicPoint, ArrayLayout.size_tab] + exact all _ (by simp) + +/-- One uninterrupted source squeeze run is gamma, six map draws, then lambda. +This is the grouped bad relation for the eventual ROM adapter, not eight +independently selectable random-oracle opportunities. -/ +def InitialEvent {m : Nat} (p : Profile) (lanes : Nat) (root : BaseOracle) + (family : Fin m → FamilyClaim) (points : Array PointClaim) (r : Prefix × E) : Prop := + Escape (config p) lanes root family r.1 ∨ + r.2 ∈ InitialBatching.candidateEscape (InitialCandidates.extensionCandidates (config p) lanes root) + (transformedClaims (2 ^ (config p).logN) family points r.1) + +theorem initial_event_probability {m : Nat} (p : Profile) (lanes : Nat) (root : BaseOracle) + (lane_bound : lanes ≤ 2 ^ (config p).folds[0]!) + (family : Fin m → FamilyClaim) (points : Array PointClaim) : + Soundness.uniformProb (Finset.univ.filter (InitialEvent p lanes root family points)) ≤ + (2 ^ 32 : ℚ) * (((m - 1 : Nat) : ℚ) / 2 ^ 192 + 1 / 2 ^ 160) + + (points.size : ℚ) / 2 ^ 160 := by + apply RingMapBatching.conditional_error (Escape (config p) lanes root family) _ _ _ + (by positivity) (escape_probability p lanes root family) + intro r outside + have h := InitialSoundness.initial_escape_probability p lanes root lane_bound + (transformedClaims (2 ^ (config p).logN) family points r) + (transformedClaims_shapes _ _ _ _) + simpa only [InitialEvent, outside, false_or, Finset.filter_mem_eq_inter, + Finset.univ_inter, transformedClaims_size, Nat.add_sub_cancel_left] using h + +end Whir.RingPCSGame diff --git a/verification/whir/Whir/SamplingProbability.lean b/verification/whir/Whir/SamplingProbability.lean new file mode 100644 index 000000000..531469bfe --- /dev/null +++ b/verification/whir/Whir/SamplingProbability.lean @@ -0,0 +1,351 @@ +import Whir.Layout +import Whir.QuerySoundness +import Whir.Concrete +import Whir.FieldCardinality +import Mathlib.Algebra.BigOperators.Fin +import Whir.SamplingRefinement +import Whir.StratifiedDensity +import Whir.Soundness + +/-! Counting the actual 192-bit squeeze extractor, including discarded bits. -/ +namespace Whir.SamplingProbability +open Concrete FieldModel +open scoped BigOperators + +/-- Representation equivalence in the same little-endian order as `E.toNat`. -/ +def squeezeEquiv : E ≃ Fin (2^192) := + extensionEquiv.trans ((Equiv.prodCongr wordEquiv + (Equiv.prodCongr wordEquiv wordEquiv)).trans + ((Equiv.prodComm _ _).trans + ((Equiv.prodCongr ((Equiv.prodComm _ _).trans finProdFinEquiv) (Equiv.refl _)).trans + (finProdFinEquiv.trans (finCongr (by norm_num)))))) + +@[simp] theorem squeezeEquiv_val (a : E) : (squeezeEquiv a).val = a.toNat := by + change a.c0.toNat + 2^64 * (a.c1.toNat + 2^64 * a.c2.toNat) = + a.c0.toNat + 2^64 * a.c1.toNat + 2^128 * a.c2.toNat + ring + +/-- Exact uniform 192-bit integer law: every word has exactly one preimage. -/ +theorem toNat_fiber (n : Fin (2^192)) : + Fintype.card {a : E // a.toNat = n.val} = 1 := by + classical + have he : {a : E // a.toNat = n.val} ≃ Unit := + { toFun := fun _ => () + invFun := fun _ => ⟨squeezeEquiv.symm n, by simp [← squeezeEquiv_val]⟩ + left_inv := by + intro a + apply Subtype.ext + apply squeezeEquiv.injective + apply Fin.ext + simpa only [Equiv.apply_symm_apply, squeezeEquiv_val] using a.property.symm + right_inv := by intro a; cases a; rfl } + exact (Fintype.card_congr he).trans (by simp) + +/-- Split one squeeze into all full chunks and its unused high-bit tail. -/ +def chunkEquiv (depth : Nat) : + E ≃ Fin (2 ^ (192 % depth)) × (Fin (192 / depth) → Fin (2 ^ depth)) := + squeezeEquiv.trans ((finCongr (by + rw [← pow_mul, ← pow_add, Nat.mod_add_div])).trans + (finProdFinEquiv.symm.trans + (Equiv.prodCongr (Equiv.refl _) finFunctionFinEquiv.symm))) + +theorem chunkEquiv_val (depth : Nat) (a : E) (j : Fin (192 / depth)) : + ((chunkEquiv depth a).2 j).val = + a.toNat / 2 ^ (j.val * depth) % 2 ^ depth := by + change ((squeezeEquiv a).val % (2 ^ depth) ^ (192 / depth)) / + (2 ^ depth) ^ j.val % 2 ^ depth = _ + rw [squeezeEquiv_val] + have hpow : (2 ^ depth) ^ (192 / depth) = + (2 ^ depth) ^ j.val * (2 ^ depth) ^ (192 / depth - j.val) := by + rw [← pow_add, Nat.add_sub_of_le (Nat.le_of_lt j.isLt)] + rw [hpow, Nat.mod_mul_right_div_self, Nat.mod_mod_of_dvd] + · rw [← pow_mul, Nat.mul_comm depth j.val] + · exact dvd_pow_self _ (by omega) + +/-- Discarding the tail gives constant fibers, hence independent uniform chunks. -/ +theorem chunk_fiber (depth : Nat) (chunks : Fin (192 / depth) → Fin (2 ^ depth)) : + Fintype.card {a : E // (chunkEquiv depth a).2 = chunks} = 2 ^ (192 % depth) := by + classical + let e : {a : E // (chunkEquiv depth a).2 = chunks} ≃ Fin (2 ^ (192 % depth)) := + { toFun := fun a => (chunkEquiv depth a.val).1 + invFun := fun tail => ⟨(chunkEquiv depth).symm (tail, chunks), by simp⟩ + left_inv := by + intro a + apply Subtype.ext + apply (chunkEquiv depth).injective + simp only [Equiv.apply_symm_apply] + exact Prod.ext rfl a.property.symm + right_inv := by intro tail; simp } + exact (Fintype.card_congr e).trans (Fintype.card_fin _) + +/-- All squeeze tails and all full chunks are independent coordinates. -/ +def tapeEquiv (depth squeezes : Nat) : + (Fin squeezes → E) ≃ + (Fin squeezes → Fin (2 ^ (192 % depth))) × + (Fin (squeezes * (192 / depth)) → Fin (2 ^ depth)) := + (Equiv.arrowCongr (Equiv.refl _) (chunkEquiv depth)).trans + ((Equiv.arrowProdEquivProdArrow _ _ _).trans + (Equiv.prodCongr (Equiv.refl _) + ((Equiv.curry _ _ _).symm.trans + (Equiv.arrowCongr finProdFinEquiv (Equiv.refl _))))) + +theorem tapeEquiv_val (depth squeezes : Nat) (t : Fin squeezes → E) + (i : Fin (squeezes * (192 / depth))) : + ((tapeEquiv depth squeezes t).2 i).val = + (t (finProdFinEquiv.symm i).1).toNat / + 2 ^ ((i.val % (192 / depth)) * depth) % 2 ^ depth := by + exact chunkEquiv_val depth _ _ + +/-- Split off a prefix without dropping the unused final-squeeze chunks. -/ +def prefixEquiv {A : Type*} (total count : Nat) (h : count ≤ total) : + (Fin total → A) ≃ (Fin count → A) × (Fin (total - count) → A) := + (Equiv.arrowCongr (finCongr (Nat.add_sub_of_le h).symm) (Equiv.refl _)).trans + ((Equiv.arrowCongr finSumFinEquiv.symm (Equiv.refl _)).trans + (Equiv.sumArrowEquivProdArrow _ _ _)) + +@[simp] theorem prefixEquiv_apply {A : Type*} (total count : Nat) (h : count ≤ total) + (f : Fin total → A) (i : Fin count) : + (prefixEquiv total count h f).1 i = f ⟨i.val, lt_of_lt_of_le i.isLt h⟩ := rfl + +/-- Noise includes high-bit tails of every squeeze and unused chunks of the last one. -/ +abbrev Noise (depth squeezes count : Nat) := + (Fin squeezes → Fin (2 ^ (192 % depth))) × + (Fin (squeezes * (192 / depth) - count) → Fin (2 ^ depth)) + +def queryEquiv (depth squeezes count : Nat) (h : count ≤ squeezes * (192 / depth)) : + (Fin squeezes → E) ≃ Noise depth squeezes count × (Fin count → Fin (2 ^ depth)) := + (tapeEquiv depth squeezes).trans + ((Equiv.prodCongr (Equiv.refl _) (prefixEquiv _ count h)).trans + ((Equiv.prodCongr (Equiv.refl _) (Equiv.prodComm _ _)).trans + (Equiv.prodAssoc _ _ _).symm)) + +theorem queryEquiv_val (depth squeezes count : Nat) (h : count ≤ squeezes * (192 / depth)) + (t : Fin squeezes → E) (i : Fin count) : + ((queryEquiv depth squeezes count h t).2 i).val = + (t (finProdFinEquiv.symm ⟨i.val, lt_of_lt_of_le i.isLt h⟩).1).toNat / + 2 ^ ((i.val % (192 / depth)) * depth) % 2 ^ depth := + tapeEquiv_val depth squeezes t _ + +/-- Counting a coordinate event under an explicit decomposition, not an independence axiom. -/ +def coordinateEventEquiv {A N I B : Type*} (e : A ≃ N × (I → B)) + (P : I → B → Prop) : + {a : A // ∀ i, P i ((e a).2 i)} ≃ N × (∀ i, {b : B // P i b}) where + toFun a := ((e a.val).1, fun i => ⟨(e a.val).2 i, a.property i⟩) + invFun x := ⟨e.symm (x.1, fun i => (x.2 i).val), by + simpa using fun i => (x.2 i).property⟩ + left_inv a := by + apply Subtype.ext + exact e.symm_apply_apply a.val + right_inv x := by + cases x + simp + +theorem coordinateEvent_card {A N I B : Type*} + [Fintype A] [Fintype N] [Fintype I] [Fintype B] + (e : A ≃ N × (I → B)) (P : I → B → Prop) [∀ i, DecidablePred (P i)] + [DecidablePred (fun a => ∀ i, P i ((e a).2 i))] : + Fintype.card {a : A // ∀ i, P i ((e a).2 i)} = + Fintype.card N * ∏ i, Fintype.card {b : B // P i b} := by + classical + rw [Fintype.card_congr (coordinateEventEquiv e P), Fintype.card_prod, Fintype.card_pi] + +/-- A finite uniform probability, stated as a cardinality ratio. -/ +noncomputable def probability {A : Type*} [Fintype A] (P : A → Prop) : ℝ := + letI := Classical.decPred P + (Fintype.card {a : A // P a} : ℝ) / Fintype.card A + +theorem probability_equiv {A B : Type*} [Fintype A] [Fintype B] + (e : A ≃ B) (P : B → Prop) : + probability (fun a => P (e a)) = probability P := by + classical + unfold probability + rw [Fintype.card_congr (Equiv.subtypeEquivOfSubtype e), Fintype.card_congr e] + +/-- Every event on the actual integer representation has its uniform 192-bit probability. -/ +theorem toNat_uniform (P : Nat → Prop) : + probability (fun a : E => P a.toNat) = + probability (fun n : Fin (2 ^ 192) => P n.val) := by + simpa only [squeezeEquiv_val] using + probability_equiv squeezeEquiv (fun n => P n.val) + +theorem coordinateEvent_probability {A N I B : Type*} + [Fintype A] [Fintype N] [Fintype I] [Fintype B] [Nonempty N] + (e : A ≃ N × (I → B)) (P : I → B → Prop) : + probability (fun a => ∀ i, P i ((e a).2 i)) = + ∏ i, probability (P i) := by + classical + unfold probability + rw [coordinateEvent_card, Fintype.card_congr e, Fintype.card_prod, Fintype.card_fun] + simp only [Nat.cast_mul, Nat.cast_prod, Nat.cast_pow] + rw [mul_div_mul_left _ _ (by exact_mod_cast Fintype.card_ne_zero)] + rw [Finset.prod_div_distrib] + simp + +instance noiseNonempty (depth squeezes count : Nat) : Nonempty (Noise depth squeezes count) := + ⟨(fun _ => ⟨0, by positivity⟩, fun _ => ⟨0, by positivity⟩)⟩ + +/-- Exact product law for the prefix of actual nonoverlapping raw chunks. -/ +theorem rawChunks_probability (depth squeezes count : Nat) + (h : count ≤ squeezes * (192 / depth)) (P : Fin count → Fin (2 ^ depth) → Prop) : + probability (fun t : Fin squeezes → E => + ∀ i, P i ((queryEquiv depth squeezes count h t).2 i)) = + ∏ i, probability (P i) := + coordinateEvent_probability (queryEquiv depth squeezes count h) P + +/-- The concrete allocation always has enough full chunks, including count zero. -/ +theorem squeezeCount_capacity (depth count : Nat) (hd : 0 < depth) (hmax : depth ≤ 192) : + count ≤ ((count + 192 / depth - 1) / (192 / depth)) * (192 / depth) := by + have hp := Layout.query_chunks_positive hd hmax + have hm := Nat.mod_lt (count + 192 / depth - 1) hp + have he := Nat.mod_add_div (count + 192 / depth - 1) (192 / depth) + rw [Nat.mul_comm] at he + omega + +/-- This is exactly `Layout.rawQuery` on the actual supplied squeeze array. -/ +theorem queryEquiv_rawQuery (depth squeezes count : Nat) + (h : count ≤ squeezes * (192 / depth)) (t : Fin squeezes → E) (i : Fin count) : + ((queryEquiv depth squeezes count h t).2 i).val = + Layout.rawQuery depth (fun j => (Array.ofFn t)[j]!.toNat) i.val := by + rw [queryEquiv_val] + have hi : i.val / (192 / depth) < squeezes := + (finProdFinEquiv.symm (⟨i.val, lt_of_lt_of_le i.isLt h⟩ : + Fin (squeezes * (192 / depth)))).1.isLt + simp only [Layout.rawQuery, getElem!_pos, Array.size_ofFn, hi, + Array.getElem_ofFn, finProdFinEquiv] + rfl + +/-- Uniformity/independence stated directly in terms of the production raw extractor. +The predicates may be chosen from the history before the query batch, but do not depend on it. -/ +theorem actualRaw_probability (depth count : Nat) (hd : 0 < depth) (hmax : depth ≤ 192) + (P : Fin count → Nat → Prop) : + probability (fun t : Fin ((count + 192 / depth - 1) / (192 / depth)) → E => + ∀ i : Fin count, P i (Layout.rawQuery depth (fun j => (Array.ofFn t)[j]!.toNat) i.val)) = + ∏ i, probability (fun raw : Fin (2 ^ depth) => P i raw.val) := by + have h := rawChunks_probability depth _ count (squeezeCount_capacity depth count hd hmax) + (fun i raw => P i raw.val) + simpa only [queryEquiv_rawQuery] using h + +/-- The concrete top-bit replacement, before identifying its cosets with `Layout`. -/ +def concretePlace (count depth i raw : Nat) : Nat := + let s := (Concrete.strata count depth)[i]! + raw % 2 ^ (depth - s.1) + s.2 * 2 ^ (depth - s.1) + +theorem deriveQueries_eq (depth count : Nat) (hd : 0 < depth) (hmax : depth ≤ 64) + (t : Fin ((count + 192 / depth - 1) / (192 / depth)) → E) : + Concrete.deriveQueries depth count (Array.ofFn t) = + some (Concrete.tab count fun i => concretePlace count depth i + (Layout.rawQuery depth (fun j => (Array.ofFn t)[j]!.toNat) i)) := by + simp [Concrete.deriveQueries, concretePlace, Layout.rawQuery, + Nat.ne_of_gt hd, Nat.not_lt.mpr hmax] + +/-- Exact joint law of the executable sampler, retaining order and repeated indices. +No iid-query or independence premise is supplied: this follows from the squeeze bijection. -/ +theorem deriveQueries_probability (depth count : Nat) (hd : 0 < depth) (hmax : depth ≤ 64) + (P : Fin count → Nat → Prop) : + probability (fun t : Fin ((count + 192 / depth - 1) / (192 / depth)) → E => + ∃ qs, Concrete.deriveQueries depth count (Array.ofFn t) = some qs ∧ + ∀ i : Fin count, P i qs[i.val]!) = + ∏ i, probability (fun raw : Fin (2 ^ depth) => + P i (concretePlace count depth i.val raw.val)) := by + have h := actualRaw_probability depth count hd (by omega) + (fun i raw => P i (concretePlace count depth i.val raw)) + convert h using 1 + congr 1 + funext t + rw [deriveQueries_eq depth count hd hmax] + simp [Concrete.tab, getElem!_pos] + +/-- The symbolic stratum at an actual query position. -/ +def queryStratum (count depth : Nat) (i : Fin count) : Layout.Stratum depth := + (Layout.strataBits (count.log2 + 1) count depth)[i.val]'(by + rw [Layout.strataBits_length _ _ _ Nat.lt_log2_self] + exact i.isLt) + +theorem concretePlace_eq (count depth : Nat) (i : Fin count) (raw : Nat) : + concretePlace count depth i.val raw = Layout.placeQuery (queryStratum count depth i) raw := by + rw [concretePlace, SamplingRefinement.strata_getElem! count depth i.val i.isLt] + rfl + +private theorem mem_nat_image {depth : Nat} (A : Finset (Fin (2 ^ depth))) + (a : Fin (2 ^ depth)) : a.val ∈ A.image Fin.val ↔ a ∈ A := by + classical + constructor + · intro h + obtain ⟨b, hb, he⟩ := Finset.mem_image.mp h + have : b = a := Fin.ext he + simpa [this] using hb + · intro h + exact Finset.mem_image.mpr ⟨a, h, rfl⟩ + +theorem queryStratum_product (count depth : Nat) (f : Layout.Stratum depth → ℝ) : + (∏ i : Fin count, f (queryStratum count depth i)) = + ((Layout.strataBits (count.log2 + 1) count depth).map f).prod := by + rw [← Fin.prod_ofFn] + congr 1 + apply List.ext_getElem + · simp [Layout.strataBits_length _ _ _ Nat.lt_log2_self] + · intro i hi hj + simp [queryStratum] + +/-- Agreement is fixed before the query message. Queries are not deduplicated. -/ +def allQueriesHit (depth count : Nat) (A : Finset (Fin (2 ^ depth))) + (t : Fin ((count + 192 / depth - 1) / (192 / depth)) → E) : Prop := + ∃ qs, Concrete.deriveQueries depth count (Array.ofFn t) = some qs ∧ + ∀ i : Fin count, qs[i.val]! ∈ A.image Fin.val + +/-- Exact product of the actual coset-hit densities, for the actual sampler. -/ +theorem actual_coset_product (depth count : Nat) (hd : 0 < depth) (hmax : depth ≤ 64) + (A : Finset (Fin (2 ^ depth))) : + probability (allQueriesHit depth count A) = + ((Layout.strataBits (count.log2 + 1) count depth).map + (StratifiedDensity.density A)).prod := by + classical + unfold allQueriesHit + rw [deriveQueries_probability depth count hd hmax] + rw [← queryStratum_product] + apply Finset.prod_congr rfl + intro i _ + have hp : (fun raw : Fin (2 ^ depth) => + concretePlace count depth i.val raw.val ∈ A.image Fin.val) = + (fun raw => StratifiedDensity.placed (queryStratum count depth i) raw ∈ A) := by + funext raw + apply propext + rw [concretePlace_eq] + exact mem_nat_image A (StratifiedDensity.placed (queryStratum count depth i) raw) + rw [hp] + simp only [probability, Fintype.card_fin] + convert StratifiedDensity.raw_probability_eq_density A (queryStratum count depth i) using 1 + congr 2 + exact congrArg (fun inst : Fintype {raw : Fin (2 ^ depth) // + StratifiedDensity.placed (queryStratum count depth i) raw ∈ A} => + @Fintype.card _ inst) (Subsingleton.elim _ _) + +/-- The query error bound, including count zero, repeated full-domain cosets, +unused high bits, and a partially consumed final squeeze. -/ +theorem actual_query_bound (depth count : Nat) (hd : 0 < depth) (hmax : depth ≤ 64) + (A : Finset (Fin (2 ^ depth))) : + probability (allQueriesHit depth count A) ≤ + StratifiedDensity.globalDensity A ^ count := by + rw [actual_coset_product depth count hd hmax A] + exact StratifiedDensity.strataBits_product_le _ _ _ A Nat.lt_log2_self + +/-- Compatibility with the rational finite-probability interface of the security game. -/ +theorem probability_eq_uniformProb {Ω : Type*} [Fintype Ω] (P : Ω → Prop) + [DecidablePred P] : + probability P = (Soundness.uniformProb (Finset.univ.filter P) : ℝ) := by + classical + simp [probability, Soundness.uniformProb, Fintype.card_subtype] + +theorem actual_query_bound_rat (depth count : Nat) (hd : 0 < depth) (hmax : depth ≤ 64) + (A : Finset (Fin (2 ^ depth))) : + letI := Classical.decPred (allQueriesHit depth count A) + Soundness.uniformProb (Finset.univ.filter (allQueriesHit depth count A)) ≤ + ((A.card : ℚ) / (2 ^ depth : ℕ)) ^ count := by + classical + have h := actual_query_bound depth count hd hmax A + rw [probability_eq_uniformProb] at h + unfold StratifiedDensity.globalDensity at h + apply (Rat.cast_le (K := ℝ)).mp + simpa only [Rat.cast_pow, Rat.cast_div, Rat.cast_natCast] using h + +end Whir.SamplingProbability diff --git a/verification/whir/Whir/SamplingRefinement.lean b/verification/whir/Whir/SamplingRefinement.lean new file mode 100644 index 000000000..75053b2c1 --- /dev/null +++ b/verification/whir/Whir/SamplingRefinement.lean @@ -0,0 +1,161 @@ +import Whir.ArrayLayout + +/-! Exact refinement of the mutable sampler, including zero counts and repeated cosets. +The representation map discards only the symbolic stratum's bound proofs. -/ +namespace Whir.SamplingRefinement +open Concrete ArrayLayout + +def stratumPair {depth : Nat} (s : Layout.Stratum depth) : Nat × Nat := + (s.bits, s.index) + +private def bitStrata (width count depth : Nat) : List (Layout.Stratum depth) := + ((List.range width).reverse).flatMap fun g => + if count.testBit g then Layout.stratumGroup depth g else [] + +private theorem bitStrata_mod (width count depth : Nat) : + bitStrata width (count % 2 ^ width) depth = bitStrata width count depth := by + unfold bitStrata + apply congrArg List.flatten + apply List.map_congr_left + intro g hg + have hg' : g < width := List.mem_range.mp (List.mem_reverse.mp hg) + simp [Nat.testBit_mod_two_pow, hg'] + +private theorem bitStrata_eq (width count depth : Nat) (hc : count < 2 ^ width) : + bitStrata width count depth = Layout.strataBits width count depth := by + induction width generalizing count with + | zero => simp [bitStrata, Layout.strataBits] + | succ width ih => + have hp : 0 < 2 ^ width := by positivity + have hbound : count < 2 ^ width * 2 := by simpa [pow_succ] using hc + have hbit : count.testBit width = decide (2 ^ width ≤ count) := by + rw [Nat.testBit_eq_decide_div_mod_eq] + apply decide_eq_decide.mpr + have hdiv : count / 2 ^ width < 2 := + (Nat.div_lt_iff_lt_mul hp).mpr (by omega) + rw [Nat.mod_eq_of_lt hdiv] + constructor + · intro h + have hm := Nat.div_mul_le_self count (2 ^ width) + simpa [h] using hm + · intro h + have := (Nat.le_div_iff_mul_le hp).mpr (show 1 * 2 ^ width ≤ count by simpa using h) + omega + simp only [bitStrata, List.range_succ, List.reverse_append, List.reverse_singleton, + List.singleton_append, List.flatMap_cons, hbit, decide_eq_true_eq, Layout.strataBits] + change (if 2 ^ width ≤ count then Layout.stratumGroup depth width else []) ++ + bitStrata width count depth = _ + by_cases h : 2 ^ width ≤ count + · have hm : count % 2 ^ width = count - 2 ^ width := by + have hdiv : count / 2 ^ width = 1 := by + apply Nat.le_antisymm + · have := (Nat.div_lt_iff_lt_mul hp).mpr (show count < 2 * 2 ^ width by omega); omega + · exact (Nat.le_div_iff_mul_le hp).mpr (by simpa using h) + have := Nat.mod_add_div count (2 ^ width) + rw [hdiv, Nat.mul_one] at this + omega + rw [ite_eq_left h, ite_eq_left h, ← bitStrata_mod width count depth, hm, + ih _ (by omega)] + · simp only [ite_eq_right h, List.nil_append] + exact ih _ (by omega) + +private theorem groups_fold (gs : List Nat) (count depth : Nat) + (out : Array (Nat × Nat)) : + (gs.foldl (fun out g => if count.testBit g then + (List.range (2 ^ g)).foldl (fun out j => out.push (min g depth, j % 2 ^ min g depth)) out + else out) out).toList = out.toList ++ + (gs.flatMap fun g => if count.testBit g then Layout.stratumGroup depth g else []).map + stratumPair := by + induction gs generalizing out with + | nil => simp + | cons g gs ih => + simp only [List.foldl_cons, List.flatMap_cons, List.map_append] + rw [ih] + cases count.testBit g <;> + simp [Layout.stratumGroup, Layout.stratumAt, stratumPair, + List.map_map, List.append_assoc] + +/-- The executable high-to-low bit loop is exactly the bound-carrying specification. -/ +theorem strata_toList (count depth : Nat) : + (Concrete.strata count depth).toList = + (Layout.strataBits (count.log2 + 1) count depth).map stratumPair := by + unfold Concrete.strata + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size] + simp only [Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + simp only [← apply_ite (fun a : Array (Nat × Nat) => + (pure (.yield a) : Id (ForInStep (Array (Nat × Nat)))))] + simp only [List.forIn_pure_yield_eq_foldl] + change (List.foldl _ #[] (List.range (count.log2 + 1)).reverse).toList = _ + rw [groups_fold] + simp only [List.nil_append] + rw [← bitStrata, bitStrata_eq _ _ _ Nat.lt_log2_self] + +theorem strata_eq (count depth : Nat) : + Concrete.strata count depth = + ((Layout.strataBits (count.log2 + 1) count depth).map stratumPair).toArray := by + apply Array.toList_inj.mp + simpa using strata_toList count depth + +@[simp] theorem strata_size (count depth : Nat) : + (Concrete.strata count depth).size = count := by + have h := congrArg List.length (strata_toList count depth) + simpa [Layout.strataBits_length _ _ _ Nat.lt_log2_self] using h + +/-- Default-valued machine indexing agrees with the bounded symbolic stratum. -/ +theorem strata_getElem! (count depth i : Nat) (hi : i < count) : + (Concrete.strata count depth)[i]! = + stratumPair ((Layout.strataBits (count.log2 + 1) count depth)[i]'(by + rw [Layout.strataBits_length _ _ _ Nat.lt_log2_self]; exact hi)) := by + rw [strata_eq] + simp [getElem!_pos, Layout.strataBits_length _ _ _ Nat.lt_log2_self, hi] + +/-- The exact production squeeze count makes every raw-word lookup in bounds. -/ +theorem squeeze_index_lt {depth count : Nat} (hpos : 1 ≤ depth) (hmax : depth ≤ 64) + (squeezes : Array E) + (hs : squeezes.size = (count + 192 / depth - 1) / (192 / depth)) + (i : Nat) (hi : i < count) : + i / (192 / depth) < squeezes.size := by + have hp : 0 < 192 / depth := Layout.query_chunks_positive hpos (by omega) + rw [hs] + have hle : i / (192 / depth) * (192 / depth) ≤ i := Nat.div_mul_le_self _ _ + apply (Nat.lt_div_iff_mul_lt hp).mpr + omega + +/-- Raw extraction is the symbolic chunk extractor applied to the supplied E words. -/ +theorem rawQuery_eq (depth : Nat) (squeezes : Array E) (i : Nat) : + (squeezes[i / (192 / depth)]!.toNat / 2 ^ ((i % (192 / depth)) * depth)) % + 2 ^ depth = + Layout.rawQuery depth (fun j => squeezes[j]!.toNat) i := rfl + +/-- Exact successful sampler identity, preserving order and all duplicate queries. +No condition limits `count` to the domain size. -/ +theorem deriveQueries_eq (depth count : Nat) (squeezes : Array E) + (hpos : 1 ≤ depth) (hmax : depth ≤ 64) + (hs : squeezes.size = (count + 192 / depth - 1) / (192 / depth)) : + Concrete.deriveQueries depth count squeezes = + some ((Layout.sampleQueries (count.log2 + 1) count depth + (fun i => squeezes[i]!.toNat)).toArray) := by + have hz : depth ≠ 0 := by omega + have hn : ¬64 < depth := by omega + simp [Concrete.deriveQueries, hz, hn, hs] + apply Array.toList_inj.mp + apply List.ext_getElem + · simp [Layout.sampleQueries_length _ _ _ _ Nat.lt_log2_self] + · intro i hi hj + have hic : i < count := by simpa using hi + simp only [toList_tab, List.getElem_map, List.getElem_range] + rw [strata_getElem! count depth i hic, Layout.sampleQueries_order] + rfl + +/-- List-facing endpoint for the probability model. -/ +theorem deriveQueries_toList (depth count : Nat) (squeezes : Array E) + (hpos : 1 ≤ depth) (hmax : depth ≤ 64) + (hs : squeezes.size = (count + 192 / depth - 1) / (192 / depth)) : + (Concrete.deriveQueries depth count squeezes).map Array.toList = + some (Layout.sampleQueries (count.log2 + 1) count depth + (fun i => squeezes[i]!.toNat)) := by + rw [deriveQueries_eq depth count squeezes hpos hmax hs] + simp + +end Whir.SamplingRefinement diff --git a/verification/whir/Whir/Soundness.lean b/verification/whir/Whir/Soundness.lean index cfb5510f3..879550b6b 100644 --- a/verification/whir/Whir/Soundness.lean +++ b/verification/whir/Whir/Soundness.lean @@ -1,6 +1,10 @@ -import Mathlib.Algebra.Polynomial.Roots -import Mathlib.Data.Fintype.BigOperators -import Mathlib.Tactic +module + +public import Mathlib.Algebra.Polynomial.Roots +public import Mathlib.Data.Fintype.BigOperators +public import Mathlib.Tactic + +@[expose] public section namespace Whir.Soundness diff --git a/verification/whir/Whir/StackWHIRCodec.lean b/verification/whir/Whir/StackWHIRCodec.lean new file mode 100644 index 000000000..578f95568 --- /dev/null +++ b/verification/whir/Whir/StackWHIRCodec.lean @@ -0,0 +1,188 @@ +import Whir.StackWHIRROM +import Whir.WHIRROM + +/-! Exact packet decoding for the stacked alphabet. The first allocation is +192 contiguous bytes, or six independent 32-byte blocks, in gamma, map, lambda +order. Later vectors reuse the checked WHIR whole-block padding projection. -/ +namespace Whir.StackWHIRCodec +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame (Byte Digest32 Scalar24 average) +open WHIRFiatShamir (scalarCodec codec) +set_option maxRecDepth 10000 +set_option maxHeartbeats 800000 + +abbrev InitialBytes := (Scalar24 × (Fin 6 → Scalar24)) × Scalar24 + +def prependScalar (n : Nat) : (Scalar24 × (Fin n → Scalar24)) ≃ (Fin (n+1) → Scalar24) where + toFun p := Fin.cases p.1 p.2 + invFun f := (f 0,fun i => f i.succ) + left_inv p := by + apply Prod.ext + · rfl + · funext i; rfl + right_inv f := by + funext i + refine Fin.cases ?_ (fun j => ?_) i <;> rfl + +/-- Gamma occupies slot zero, the six map draws slots one through six, and +lambda slot seven. No response boundary is inserted between these scalars. -/ +def initialVector : InitialBytes ≃ (Fin 8 → Scalar24) := + (Equiv.prodCongr (prependScalar 6) (Equiv.refl Scalar24)).trans (WHIRROM.appendScalar 7) + +def initialCodec : InitialBytes ≃ (RingPCSGame.Prefix × E) := + Equiv.prodCongr (Equiv.prodCongr scalarCodec (Equiv.piCongrRight (fun _ => scalarCodec))) scalarCodec + +def initialPacked : InitialBytes ≃ (Fin 192 → Byte) := + initialVector.trans ((Equiv.curry (Fin 8) (Fin 24) Byte).symm.trans + (Equiv.arrowCongr finProdFinEquiv (Equiv.refl Byte))) + +/-- The actual first packet is bijective, with no padding or discarded bits. -/ +def initialBlocks : (Fin 6 → Digest32) ≃ (RingPCSGame.Prefix × E) := + ((WHIRROM.blockBytes 6).trans initialPacked.symm).trans initialCodec + +def initialSlices (bytes : List Byte) : InitialBytes := + ((fun j => bytes[j.val]!,fun i j => bytes[24*(i.val+1)+j.val]!), + fun j => bytes[168+j.val]!) + +private theorem byte_at {n : Nat} (bytes : Fin n → Byte) (i : Nat) (hi : i < n) : + (List.ofFn bytes)[i]! = bytes ⟨i,hi⟩ := by + rw [getElem!_pos _ _ (by simpa using hi)] + exact List.getElem_ofFn _ + +theorem initialSlices_packed (bytes : Fin 192 → Byte) : + initialSlices (List.ofFn bytes) = initialPacked.symm bytes := by + apply Prod.ext + · apply Prod.ext + · funext j + change (List.ofFn bytes)[j.val]! = bytes ⟨j.val,by omega⟩ + exact byte_at bytes j.val (by omega) + · funext i j + have h : 24*(i.val+1)+j.val < 192 := by omega + change (List.ofFn bytes)[24*(i.val+1)+j.val]! = bytes ⟨j.val+24*(i.val+1),by omega⟩ + rw [byte_at bytes _ h] + congr 1 + apply Fin.ext + dsimp only + omega + · funext j + have h : 168+j.val < 192 := by omega + change (List.ofFn bytes)[168+j.val]! = bytes ⟨j.val+168,by omega⟩ + rw [byte_at bytes _ h] + congr 1 + apply Fin.ext + dsimp only + omega + +/-- Direct decoder of the actual contiguous output stream. -/ +def decodeBytes {c : Config} (q : Coordinate c) (bytes : List Byte) : StackWHIRReplay.Sample q := + match q with + | .initial => initialCodec (initialSlices bytes) + | .fold i j => codec (.fold i j) (WHIRROM.slices (.fold i j) bytes) + | .ood i j => codec (.ood i j) (WHIRROM.slices (.ood i j) bytes) + | .query i => codec (.query i) (WHIRROM.slices (.query i) bytes) + | .tail j => codec (.tail j) (WHIRROM.slices (.tail j) bytes) + +def outputBlocks {c : Config} : Coordinate c → Nat + | .initial => 6 + | q => WHIRROM.outputBlocks q + +theorem outputBlocks_eq {c : Config} (q : Coordinate c) : + outputBlocks q = (WHIRHistory.stackScalarCount q * 24 + 31) / 32 := by + cases q with + | initial => norm_num [outputBlocks,WHIRHistory.stackScalarCount] + | fold i j => rfl + | ood i j => rfl + | query i => rfl + | tail j => rfl + +theorem payload_le_outputBlocks {c : Config} (q : Coordinate c) : + WHIRHistory.stackScalarCount q * 24 ≤ outputBlocks q * 32 := by + rw [outputBlocks_eq] + omega + +/-- Each packet is a vector of independently sampled full 32-byte blocks. The +initial packet has exactly six blocks; later partial final blocks are ignored. -/ +def blockDecode {c : Config} (q : Coordinate c) + (raw : Fin (outputBlocks q) → Digest32) : StackWHIRReplay.Sample q := + match q with + | .initial => initialBlocks raw + | .fold i j => WHIRROM.blockDecode (.fold i j) raw + | .ood i j => WHIRROM.blockDecode (.ood i j) raw + | .query i => WHIRROM.blockDecode (.query i) raw + | .tail j => WHIRROM.blockDecode (.tail j) raw + +/-- Packet decoding agrees byte-for-byte with the direct stream decoder. -/ +theorem blockDecode_eq_bytes {c : Config} (q : Coordinate c) + (raw : Fin (outputBlocks q) → Digest32) : + blockDecode q raw = decodeBytes q (List.ofFn (fun i : Fin (WHIRHistory.stackScalarCount q * 24) => + WHIRROM.blockBytes (outputBlocks q) raw + ⟨i.val,lt_of_lt_of_le i.isLt (payload_le_outputBlocks q)⟩)) := by + cases q with + | initial => + simp only [blockDecode,decodeBytes,outputBlocks,WHIRHistory.stackScalarCount, + initialBlocks] + rw [initialSlices_packed] + apply congrArg initialCodec + apply congrArg initialPacked.symm + funext i + rfl + | fold i j => + simp only [blockDecode,decodeBytes,outputBlocks,WHIRHistory.stackScalarCount,WHIRROM.blockDecode, + WHIRHistory.scalarCount] + apply congrArg (codec (.fold i j)) + apply congrArg (WHIRROM.slices (.fold i j)) + apply congrArg List.ofFn + funext k + rfl + | ood i j => + simp only [blockDecode,decodeBytes,outputBlocks,WHIRHistory.stackScalarCount,WHIRROM.blockDecode, + WHIRHistory.scalarCount] + apply congrArg (codec (.ood i j)) + apply congrArg (WHIRROM.slices (.ood i j)) + apply congrArg List.ofFn + funext k + rfl + | query i => + simp only [blockDecode,decodeBytes,outputBlocks,WHIRHistory.stackScalarCount,WHIRROM.blockDecode, + WHIRHistory.scalarCount] + apply congrArg (codec (.query i)) + apply congrArg (WHIRROM.slices (.query i)) + apply congrArg List.ofFn + funext k + rfl + | tail j => + simp only [blockDecode,decodeBytes,outputBlocks,WHIRHistory.stackScalarCount,WHIRROM.blockDecode, + WHIRHistory.scalarCount] + apply congrArg (codec (.tail j)) + apply congrArg (WHIRROM.slices (.tail j)) + apply congrArg List.ofFn + funext k + rfl + +/-- Exact every-payoff distribution. The initial proof is a concrete bijection; +all later phases inherit the already checked independent-padding projection. -/ +theorem block_average {c : Config} (q : Coordinate c) (f : StackWHIRReplay.Sample q → ℚ) : + average (fun raw : Fin (outputBlocks q) → Digest32 => f (blockDecode q raw)) = average f := by + cases q with + | initial => + change average (fun raw : Fin 6 → Digest32 => f (initialBlocks raw)) = average f + unfold average + rw [Fintype.sum_equiv initialBlocks _ f (fun _ => rfl),Fintype.card_congr initialBlocks] + | fold i j => exact WHIRROM.block_average (.fold i j) f + | ood i j => exact WHIRROM.block_average (.ood i j) f + | query i => exact WHIRROM.block_average (.query i) f + | tail j => exact WHIRROM.block_average (.tail j) f + +open Classical +/-- The concrete raw-packet sparse event uses the full stacked theorem, never +the standalone initial-E bound. -/ +theorem key_block_sparse (p : Profile) (cap : Nat) (catalog : StackWHIRReplay.Catalog p cap) + (roots : StackWHIRReplay.Roots) (key : StackWHIRReplay.Key p) : + average (fun raw : Fin (outputBlocks (StackWHIRReplay.query p (key.statement,key.messages))) → Digest32 => + if StackWHIRROM.keyBad p cap catalog roots key + (blockDecode (StackWHIRReplay.query p (key.statement,key.messages)) raw) then 1 else 0) ≤ + WHIRFiatShamir.stackEta p cap := by + exact (block_average _ (fun x => if StackWHIRROM.keyBad p cap catalog roots key x then 1 else 0)).trans_le + (StackWHIRROM.key_sparse p cap catalog roots key) + +end Whir.StackWHIRCodec diff --git a/verification/whir/Whir/StackWHIRROM.lean b/verification/whir/Whir/StackWHIRROM.lean new file mode 100644 index 000000000..bcdf5c7d7 --- /dev/null +++ b/verification/whir/Whir/StackWHIRROM.lean @@ -0,0 +1,222 @@ +import Whir.StackWHIRReplay + +/-! Checked ordinary-ROM list binding for actual stacked openings. The initial +allocation is the full gamma, six-map, lambda vector. The commitment-time K +list concerns original family slices and points, not an assumed transformed +statement. The physical compression-mode transfer is deliberately separate. -/ +namespace Whir.StackWHIRROM +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame (Digest32 average average_const) +open WHIRFiatShamir +open StackWHIRReplay (Key Answer Catalog Roots query projectSample) +open Classical +set_option maxRecDepth 10000 +set_option maxHeartbeats 800000 + +abbrev Machine (p : Profile) (B K : Nat) := + TypedOracleCompiler.Machine Digest32 WHIRHistory.Pending + (@StackWHIRReplay.Sample (config p)) B K +abbrev TerminalView (p : Profile) (B : Nat) := + TypedOracleCompiler.Terminal (A := @StackWHIRReplay.Sample (config p)) (query p) B + +def initialAnswer {c : Config} {q : Coordinate c} (h : q = .initial) + (x : StackWHIRReplay.Sample q) : RingPCSGame.Prefix × E := + cast (congrArg StackWHIRReplay.Sample h) x + +theorem initial_average {c : Config} {q : Coordinate c} (h : q = .initial) + (f : RingPCSGame.Prefix × E → ℚ) : + average (fun x : StackWHIRReplay.Sample q => f (initialAnswer h x)) = average f := by + subst q + rfl + +theorem later_average {c : Config} (q : Coordinate c) (h : q ≠ .initial) + (f : Sample q → ℚ) : + average (fun x : StackWHIRReplay.Sample q => f (projectSample q x)) = average f := by + cases q with + | initial => exact (h rfl).elim + | fold i j => rfl + | ood i j => rfl + | query i => rfl + | tail j => rfl + +theorem seedValue_initial {c : Config} {q : Coordinate c} (h : q = .initial) + (x : StackWHIRReplay.Sample q) : + StackWHIRReplay.seedValue ⟨q,x⟩ = some (initialAnswer h x) := by + subst q + rfl + +/-- A malformed key has no algebraic bad event. Rejection does not bypass its +compiler allocation cost. The initial sample uses the original frozen family. -/ +def keyBad (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (x : Answer p key) : Prop := + if h : query p (key.statement,key.messages) = .initial then + match StackWHIRReplay.decodeInitial p cap catalog key with + | none => False + | some data => RingPCSGame.InitialEvent p data.lanes data.root data.family data.points + (initialAnswer h x) + else + match StackWHIRReplay.decode p cap catalog roots key with + | none => False + | some replay => allocationBad (WHIRReplay.request (StackWHIRReplay.projectKey key) replay.whir) + (projectSample _ x) + +theorem stackEta_nonneg (p : Profile) (cap : Nat) : 0 ≤ stackEta p cap := + add_nonneg (eta_nonneg p) (ringCharge_nonneg cap) + +theorem key_sparse (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + (key : Key p) : + average (fun x => if keyBad p cap catalog roots key x then 1 else 0) ≤ stackEta p cap := by + by_cases h : query p (key.statement,key.messages) = .initial + · simp only [keyBad,dite_eq_left h] + cases decoded : StackWHIRReplay.decodeInitial p cap catalog key with + | none => simp only [↓reduceIte,average_const]; exact stackEta_nonneg p cap + | some data => + change average (fun x : StackWHIRReplay.Sample (query p (key.statement,key.messages)) => + if RingPCSGame.InitialEvent p data.lanes data.root data.family data.points + (initialAnswer h x) then 1 else 0) ≤ stackEta p cap + exact (initial_average h (fun z => + if RingPCSGame.InitialEvent p data.lanes data.root data.family data.points z then 1 else 0)).trans_le + (stack_sparse p cap (.initial data)) + · simp only [keyBad,dite_eq_right h] + cases decoded : StackWHIRReplay.decode p cap catalog roots key with + | none => simp only [↓reduceIte,average_const]; exact stackEta_nonneg p cap + | some replay => + change average (fun x : StackWHIRReplay.Sample (query p (key.statement,key.messages)) => + if allocationBad (WHIRReplay.request (StackWHIRReplay.projectKey key) replay.whir) + (projectSample (query p (key.statement,key.messages)) x) then 1 else 0) ≤ stackEta p cap + exact (later_average _ h (fun z => + if allocationBad (WHIRReplay.request (StackWHIRReplay.projectKey key) replay.whir) z + then 1 else 0)).trans_le + (stack_sparse p cap (.later (WHIRReplay.request (StackWHIRReplay.projectKey key) replay.whir) h)) + +/-- Failure refers to the actual causal verifier and the original commitment's +fixed K-witness list. The ring-transformed statement is produced by decoding. -/ +def FalseOpening {p : Profile} {cap : Nat} (r : StackWHIRReplay.Replay p cap) : Prop := + experiment r.whir.statement.input (CausalStrategy.indexedStrategy r.whir.replies) r.whir.tape = true ∧ + ¬ ∃ w ∈ InitialCandidates.witnesses (config p) r.original.lanes r.original.root, + RingPCSGame.Honest (config p) r.original.lanes r.original.family r.original.points w + +def HistoryFailure (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + (statement : Digest32) (messages : List WHIRHistory.Pending) + (history : List (WHIRHistory.Pending × Sigma (@StackWHIRReplay.Sample (config p)))) : Prop := + ∃ head past, ∃ x : StackWHIRReplay.Sample (query p (statement,messages)), + ∃ replay : StackWHIRReplay.Replay p cap, + history = (head,⟨query p (statement,messages),x⟩)::past ∧ + messages.length = WHIRHistory.depth (config p) ∧ + StackWHIRReplay.decode p cap catalog roots ⟨statement,messages,past⟩ = some replay ∧ + FalseOpening (StackWHIRReplay.finish ⟨statement,messages,past⟩ replay x) + +def TerminalFailure (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + {B : Nat} (result : TerminalView p B) : Prop := + HistoryFailure p cap catalog roots result.request.statement result.request.messages + result.allocation.history + +/-- Actual terminal failure is covered by an actual allocated vector. Initial +ring escape and initial lambda escape share one trace entry and one draw. -/ +theorem recorded_history_cover (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + (statement : Digest32) (messages : List WHIRHistory.Pending) + (completed : List (WHIRHistory.Pending × Sigma (@StackWHIRReplay.Sample (config p)))) + (trace : List (Sigma (Answer p))) + (recorded : TypedOracleCompiler.HistoryRecorded (query p) statement trace messages completed) + (failed : HistoryFailure p cap catalog roots statement messages completed) : + ∃ ka ∈ trace, keyBad p cap catalog roots ka.1 ka.2 := by + obtain ⟨head,past,x,replay,history,length,decoded,failed⟩ := failed + let key : Key p := ⟨statement,messages,past⟩ + let final := StackWHIRReplay.finish key replay x + change FalseOpening final at failed + rw [history] at recorded + obtain initial | later := StackWHIRReplay.accepted_false_cover catalog roots key replay decoded x + failed.1 failed.2 + · obtain ⟨m,a,allocated,parsed,seed⟩ := StackWHIRReplay.initial_trace_realization + catalog roots key replay decoded x head trace recorded + refine ⟨⟨⟨key.statement,[m],[]⟩,a⟩,allocated,?_⟩ + have phase : query p (key.statement,[m]) = .initial := WHIRReplay.query_singleton _ _ _ + simp only [keyBad,dite_eq_left phase,parsed] + rw [seedValue_initial phase] at seed + rw [Option.some.inj seed] + exact initial + · obtain ⟨q,notInitial,bad⟩ := later + let i := messages.length - position q - 1 + have bound : position q < key.messages.length := by + change position q < messages.length + rw [length] + exact WHIRHistory.position_lt_depth q + have positive : 0 < position q := by + have initialPos : position (Coordinate.initial (c := config p)) = 0 := by + simp [CausalProbability.position,visibleCoordinates] + by_contra h + have same : position q = position (Coordinate.initial (c := config p)) := by omega + exact notInitial (CausalPrefix.position_injective (config p) same) + have size := StackWHIRReplay.decode_ancestor_length catalog roots key replay decoded + have hi : i < key.ancestors.length := by dsimp [i,key] at *; omega + obtain ⟨m,tail,ancestors,a,before,_,allocated,parsed,_,_,agree,sample,pos⟩ := + StackWHIRReplay.trace_realization catalog roots key replay decoded x head trace recorded i hi + have qeq : q = query p (key.statement,m::tail) := by + apply CausalPrefix.position_injective + rw [pos] + dsimp [i,key] at bound ⊢ + omega + subst q + refine ⟨⟨⟨key.statement,m::tail,ancestors⟩,a⟩,allocated,?_⟩ + simp only [keyBad,dite_eq_right notInitial,parsed] + change allocationBad (requestOfTape before.whir.statement + (CausalStrategy.indexedStrategy before.whir.replies) + (query p (key.statement,m::tail)) before.whir.tape) (projectSample _ a) + have congr := CausalStrategy.allocationBad_indexed_congr p before.whir.statement + before.whir.replies final.whir.replies (query p (key.statement,m::tail)) + before.whir.tape final.whir.tape (projectSample _ a) agree.replies agree.tape + apply congr.mpr + rw [agree.statement] + exact Eq.mp (congrArg (fun value : Sample (query p (key.statement,m::tail)) => + allocationBad (requestOfTape final.whir.statement (CausalStrategy.indexedStrategy final.whir.replies) + (query p (key.statement,m::tail)) final.whir.tape) value) sample) bad + +/-- Compiler metadata is irrelevant to the history-level accepted-false cover. -/ +theorem recorded_terminal_cover (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + {B : Nat} (trace : List (Sigma (Answer p))) (result : TerminalView p B) + (recorded : TypedOracleCompiler.HistoryRecorded (query p) result.request.statement trace + result.request.messages result.allocation.history) + (failed : TerminalFailure p cap catalog roots result) : + ∃ ka ∈ trace, keyBad p cap catalog roots ka.1 ka.2 := + recorded_history_cover p cap catalog roots result.request.statement result.request.messages + result.allocation.history trace recorded failed + +/-- The typed compiler supplies the recorded-history premise operationally. -/ +theorem terminal_cover (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + {B K : Nat} (machine : Machine p B K) (trace result) + (run : TypedOracleCompiler.Sampling.Runs + (TypedOracleCompiler.compile (query p) machine (fun _ => none)) trace result) + (failed : TerminalFailure p cap catalog roots result) : + ∃ ka ∈ trace, keyBad p cap catalog roots ka.1 ka.2 := + recorded_terminal_cover p cap catalog roots trace result + (TypedOracleCompiler.final_history_in_trace (query p) machine run) failed + +/-- Conditional ordinary-ROM stacked list binding, with every adversarial +request and the final invisible completion charged. There is no supplied +soundness, parser, trace-cover, or successful-path resource premise. -/ +theorem rom_list_binding (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + {B K : Nat} (machine : Machine p B K) : + TypedOracleCompiler.Sampling.failureProbability (TerminalFailure p cap catalog roots) + (TypedOracleCompiler.compile (query p) machine (fun _ => none)) ≤ + min 1 (((B*(K+1) : Nat) : ℚ) * stackEta p cap) := by + apply le_min + · apply TypedOracleCompiler.Sampling.expectation_le_one + intro result + split <;> norm_num + · exact TypedOracleCompiler.compiler_failure_bound (query p) machine + (keyBad p cap catalog roots) (TerminalFailure p cap catalog roots) + (stackEta p cap) (stackEta_nonneg p cap) (key_sparse p cap catalog roots) + (terminal_cover p cap catalog roots machine) + +theorem rom_list_binding_numeric (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + {B K : Nat} (machine : Machine p B K) : + TypedOracleCompiler.Sampling.failureProbability (TerminalFailure p cap catalog roots) + (TypedOracleCompiler.compile (query p) machine (fun _ => none)) ≤ + min 1 (((B*(K+1) : Nat) : ℚ) * ((1 / 2^79 : ℚ) + ringCharge cap)) := by + apply (rom_list_binding p cap catalog roots machine).trans + apply min_le_min_left + have h : stackEta p cap ≤ (1 / 2^79 : ℚ) + ringCharge cap := by + simpa only [stackEta,add_comm] using add_le_add_right (eta_le p) (ringCharge cap) + exact mul_le_mul_of_nonneg_left h (show (0 : ℚ) ≤ ((B*(K+1) : Nat) : ℚ) from Nat.cast_nonneg _) + +end Whir.StackWHIRROM diff --git a/verification/whir/Whir/StackWHIRReplay.lean b/verification/whir/Whir/StackWHIRReplay.lean new file mode 100644 index 000000000..d6cc74313 --- /dev/null +++ b/verification/whir/Whir/StackWHIRReplay.lean @@ -0,0 +1,334 @@ +import Whir.WHIRReplay + +/-! The actual stacked opening uses one initial eight-scalar allocation. The +ring prefix transforms the original frozen statement before ordinary WHIR +replay; it is not a second query or a preselected transformed statement. -/ +namespace Whir.StackWHIRReplay +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame (Digest32) +open WHIRHistory (Pending) + +abbrev Sample {c : Config} : Coordinate c → Type := WHIRHistory.StackSample + +instance {c : Config} (q : Coordinate c) : Fintype (Sample q) := by + cases q <;> unfold Sample <;> infer_instance +instance {c : Config} (q : Coordinate c) : Nonempty (Sample q) := by + cases q <;> unfold Sample <;> infer_instance + +abbrev Key (p : Profile) := + TypedFiatShamirGame.FullInput Digest32 Pending (Coordinate (config p)) Sample +abbrev query := WHIRReplay.query +abbrev Answer (p : Profile) (key : Key p) := Sample (query p (key.statement,key.messages)) +abbrev Catalog (p : Profile) (cap : Nat) := Digest32 → Option (WHIRFiatShamir.StackInitial p cap) +abbrev Roots := WHIRReplay.Roots + +def transformedStatement {p : Profile} {cap : Nat} (data : WHIRFiatShamir.StackInitial p cap) + (ringPrefix : RingPCSGame.Prefix) : WHIRFiatShamir.Statement p where + lanes := data.lanes + root := data.root + claims := RingPCSGame.transformedClaims (2 ^ (config p).logN) data.family data.points ringPrefix + lane_bound := data.lane_bound + claim_shape := RingPCSGame.transformedClaims_shapes _ _ _ _ + claim_cap := by simpa only [RingPCSGame.transformedClaims_size, Nat.add_comm] using data.claim_bound + +/-- Projection keeps the WHIR lambda but not the preceding seven ring scalars. +The full compiler cache and its keys still retain the entire initial vector. -/ +def projectSample {c : Config} (q : Coordinate c) : Sample q → CausalProbability.Sample q := + match q with + | .initial => fun x => x.2 + | .fold _ _ => id + | .ood _ _ => id + | .query _ => id + | .tail _ => id + +def projectEntry {c : Config} (entry : Pending × Sigma (@Sample c)) : + Pending × Sigma (@CausalProbability.Sample c) := + (entry.1,⟨entry.2.1,projectSample entry.2.1 entry.2.2⟩) + +def projectKey {p : Profile} (key : Key p) : WHIRReplay.Key p := + ⟨key.statement,key.messages,key.ancestors.map projectEntry⟩ + +def seedValue {c : Config} : Sigma (@Sample c) → Option (RingPCSGame.Prefix × E) + | ⟨.initial,x⟩ => some x + | _ => none + +/-- The oldest completed ancestor is the indivisible initial allocation. -/ +def initialSeed {c : Config} (history : List (Pending × Sigma (@Sample c))) : + Option (RingPCSGame.Prefix × E) := + history.getLast?.bind (fun entry => seedValue entry.2) + +theorem initialSeed_drop {c : Config} (history : List (Pending × Sigma (@Sample c))) + (i : Nat) (hi : i < history.length) : initialSeed (history.drop i) = initialSeed history := by + simp [initialSeed, List.getLast?_drop, Nat.not_le_of_lt hi] + +theorem initialSeed_last {c : Config} (history : List (Pending × Sigma (@Sample c))) + (seed : RingPCSGame.Prefix × E) (ok : initialSeed history = some seed) : + ∃ m, history.getLast? = some (m,⟨.initial,seed⟩) := by + unfold initialSeed at ok + cases last : history.getLast? with + | none => simp [last] at ok + | some entry => + rcases entry with ⟨m,q,a⟩ + cases q <;> simp [last,seedValue] at ok + subst seed + exact ⟨m,rfl⟩ + +structure Replay (p : Profile) (cap : Nat) where + original : WHIRFiatShamir.StackInitial p cap + initial : RingPCSGame.Prefix × E + whir : WHIRReplay.Replay p + +/-- This local catalog is used only after the original digest has been resolved. +All recursive decoder calls retain that same digest. -/ +def localCatalog {p : Profile} {cap : Nat} (data : WHIRFiatShamir.StackInitial p cap) + (seed : RingPCSGame.Prefix × E) : WHIRReplay.Catalog p := + fun _ => some (transformedStatement data seed.1) + +def decode (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + (key : Key p) : Option (Replay p cap) := do + let original ← catalog key.statement + let initial ← initialSeed key.ancestors + let whir ← WHIRReplay.decode p (localCatalog original initial) roots (projectKey key) + pure ⟨original,initial,whir⟩ + +/-- Initial requests are parsed before their eight-scalar answer exists. -/ +def decodeInitial (p : Profile) (cap : Nat) (catalog : Catalog p cap) (key : Key p) : + Option (WHIRFiatShamir.StackInitial p cap) := + match key.messages, key.ancestors with + | [m], [] => if m.scalars.isEmpty && m.nonce.isNone then catalog key.statement else none + | _, _ => none + +def request (p : Profile) (cap : Nat) (catalog : Catalog p cap) (roots : Roots) + (key : Key p) : Option (WHIRFiatShamir.StackRequest p cap) := + if h : query p (key.statement,key.messages) = .initial then + (decodeInitial p cap catalog key).map WHIRFiatShamir.StackRequest.initial + else + (decode p cap catalog roots key).map (fun r => + .later (WHIRReplay.request (projectKey key) r.whir) h) + +def finish {p : Profile} {cap : Nat} (key : Key p) (r : Replay p cap) (x : Answer p key) : Replay p cap := + {r with whir := WHIRReplay.finish (projectKey key) r.whir (projectSample _ x)} + +theorem decode_spec {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) : + catalog key.statement = some out.original ∧ initialSeed key.ancestors = some out.initial ∧ + WHIRReplay.decode p (localCatalog out.original out.initial) roots (projectKey key) = some out.whir := by + unfold decode at ok + cases hd : catalog key.statement with + | none => simp [hd] at ok + | some data => + cases hs : initialSeed key.ancestors with + | none => simp [hd,hs] at ok + | some seed => + cases hw : WHIRReplay.decode p (localCatalog data seed) roots (projectKey key) with + | none => simp [hd,hs,hw] at ok + | some whir => + simp [hd,hs,hw] at ok + subst out + exact ⟨rfl,rfl,hw⟩ + +theorem decode_statement {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) : + out.whir.statement = transformedStatement out.original out.initial.1 := by + have hw := (decode_spec catalog roots key out ok).2.2 + have hs := (WHIRReplay.decodeHistory_decodes p _ _ _ _ _ out.whir hw).statement + exact (Option.some.inj hs).symm + +theorem decode_initial_lambda {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) + (x : Answer p key) : get .initial (finish key out x).whir.tape = out.initial.2 := by + obtain ⟨_,hs,hw⟩ := decode_spec catalog roots key out ok + obtain ⟨m,last⟩ := initialSeed_last key.ancestors out.initial hs + have hm : projectEntry (m,⟨.initial,out.initial⟩) ∈ (projectKey key).ancestors := + List.mem_map.mpr ⟨_,List.mem_of_getLast? last,rfl⟩ + exact (WHIRReplay.finish_samples _ roots (projectKey key) out.whir hw (projectSample _ x)).2 _ hm + +/-- No resampling or transformed-statement hypothesis is needed when moving to +an earlier non-initial key: its oldest eight-scalar ancestor is unchanged. -/ +theorem decode_prefix_finish {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) + (x : Answer p key) (i : Nat) (hi : i < key.ancestors.length) (hm : i < key.messages.length) : + ∃ before, decode p cap catalog roots ⟨key.statement,key.messages.drop i,key.ancestors.drop i⟩ = + some before ∧ before.original = out.original ∧ before.initial = out.initial ∧ + WHIRReplay.PrefixAgreement (position (query p (key.statement,key.messages.drop i))) + before.whir (finish key out x).whir := by + obtain ⟨hd,hs,hw⟩ := decode_spec catalog roots key out ok + obtain ⟨before,hb,hp⟩ := WHIRReplay.decode_prefix_finish _ roots (projectKey key) out.whir hw + (projectSample _ x) i hm + refine ⟨⟨out.original,out.initial,before⟩,?_,rfl,rfl,hp⟩ + have hb' : WHIRReplay.decode p (localCatalog out.original out.initial) roots + (projectKey ⟨key.statement,key.messages.drop i,key.ancestors.drop i⟩) = some before := by + simpa only [projectKey,List.map_drop] using hb + simp [decode,hd,initialSeed_drop _ i hi,hs,hb'] + +theorem decoded_ancestor_length {p : Profile} {catalog : WHIRReplay.Catalog p} {roots : Roots} + {s messages ancestors out} (h : WHIRReplay.Decodes p catalog roots s messages ancestors out) : + ancestors.length + 1 = messages.length := by + induction h <;> simp_all + +theorem decode_ancestor_length {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) : + key.ancestors.length + 1 = key.messages.length := by + have hw := (decode_spec catalog roots key out ok).2.2 + simpa only [projectKey,List.length_map] using + decoded_ancestor_length (WHIRReplay.decodeHistory_decodes p _ _ _ _ _ out.whir hw) + +theorem finish_samples {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) + (x : Answer p key) : + get (query p (key.statement,key.messages)) (finish key out x).whir.tape = projectSample _ x ∧ + ∀ entry ∈ key.ancestors, get entry.2.1 (finish key out x).whir.tape = + projectSample entry.2.1 entry.2.2 := by + have hw := (decode_spec catalog roots key out ok).2.2 + obtain ⟨current,past⟩ := WHIRReplay.finish_samples _ roots (projectKey key) out.whir hw (projectSample _ x) + refine ⟨current,?_⟩ + intro entry member + exact past (projectEntry entry) (List.mem_map.mpr ⟨entry,member,rfl⟩) + +/-- Exact trace realization for every later WHIR allocation, retaining the +original first vector in both the full key and the decoded stack context. -/ +theorem trace_realization {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) + (x : Answer p key) (head : Pending) (trace : List (Sigma (Answer p))) + (recorded : TypedOracleCompiler.HistoryRecorded (query p) key.statement trace key.messages + ((head,⟨query p (key.statement,key.messages),x⟩)::key.ancestors)) + (i : Nat) (hi : i < key.ancestors.length) : + ∃ m tail past, ∃ a : Sample (query p (key.statement,m::tail)), ∃ before : Replay p cap, + key.messages.drop i = m::tail ∧ + (⟨⟨key.statement,m::tail,past⟩,a⟩ : Sigma (Answer p)) ∈ trace ∧ + decode p cap catalog roots ⟨key.statement,m::tail,past⟩ = some before ∧ + before.original = out.original ∧ before.initial = out.initial ∧ + WHIRReplay.PrefixAgreement (position (query p (key.statement,m::tail))) + before.whir (finish key out x).whir ∧ + get (query p (key.statement,m::tail)) (finish key out x).whir.tape = projectSample _ a ∧ + position (query p (key.statement,m::tail)) = key.messages.length - i - 1 := by + have len := decode_ancestor_length catalog roots key out ok + have him : i < key.messages.length := by omega + obtain ⟨m,tail,past,a,hm,hh,allocated⟩ := TypedOracleCompiler.HistoryRecorded.at_index + (query p) recorded i him + obtain ⟨before,hb,hd,hs,hp⟩ := decode_prefix_finish catalog roots key out ok x i hi him + have ha : key.ancestors.drop i = past := by + have ht := congrArg List.tail hh + simpa only [List.tail_drop,List.drop_succ_cons,List.tail_cons] using ht + have parsed : decode p cap catalog roots ⟨key.statement,m::tail,past⟩ = some before := by + simpa only [hm,ha] using hb + have agree : WHIRReplay.PrefixAgreement (position (query p (key.statement,m::tail))) + before.whir (finish key out x).whir := by simpa only [hm] using hp + have sample : get (query p (key.statement,m::tail)) (finish key out x).whir.tape = projectSample _ a := by + have member : (m,(⟨query p (key.statement,m::tail),a⟩ : Sigma Sample)) ∈ + (head,⟨query p (key.statement,key.messages),x⟩)::key.ancestors := + List.mem_of_mem_drop (by rw [hh]; exact List.mem_cons_self) + rcases List.mem_cons.mp member with same | older + · have eqs := congrArg Prod.snd same + exact Eq.mp (congrArg (fun qa : Sigma Sample => + get qa.1 (finish key out x).whir.tape = projectSample qa.1 qa.2) eqs.symm) + (finish_samples catalog roots key out ok x).1 + · exact (finish_samples catalog roots key out ok x).2 _ older + have hw := (decode_spec catalog roots _ before parsed).2.2 + have pos := (WHIRReplay.decodeHistory_decodes p _ _ _ _ _ before.whir hw).phase_position + have length := congrArg List.length hm + rw [List.length_drop] at length + refine ⟨m,tail,past,a,before,hm,allocated,parsed,hd,hs,agree,sample,?_⟩ + change position (query p (key.statement,m::tail)) = (m::tail).length - 1 at pos + rw [pos,← length] + +/-- The oldest initial allocation is present as the original full eight-scalar +sample, not just its lambda projection, and parses to the frozen original +stack statement. -/ +theorem initial_trace_realization {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) + (x : Answer p key) (head : Pending) (trace : List (Sigma (Answer p))) + (recorded : TypedOracleCompiler.HistoryRecorded (query p) key.statement trace key.messages + ((head,⟨query p (key.statement,key.messages),x⟩)::key.ancestors)) : + ∃ m, ∃ a : Sample (query p (key.statement,[m])), + (⟨⟨key.statement,[m],[]⟩,a⟩ : Sigma (Answer p)) ∈ trace ∧ + decodeInitial p cap catalog ⟨key.statement,[m],[]⟩ = some out.original ∧ + seedValue ⟨query p (key.statement,[m]),a⟩ = some out.initial := by + obtain ⟨hd,hs,hw⟩ := decode_spec catalog roots key out ok + have len := decode_ancestor_length catalog roots key out ok + have hi : key.ancestors.length < key.messages.length := by omega + obtain ⟨m,tail,past,a,hm,hh,allocated⟩ := TypedOracleCompiler.HistoryRecorded.at_index + (query p) recorded key.ancestors.length hi + have htail : tail = [] := by + have h := congrArg List.length hm + simp only [List.length_drop,List.length_cons] at h + exact List.length_eq_zero_iff.mp (by omega) + subst tail + have hpast : past = [] := by + have h := congrArg List.length hh + simp only [List.length_drop,List.length_cons] at h + exact List.length_eq_zero_iff.mp (by omega) + subst past + have nonempty : key.ancestors ≠ [] := by + intro he + simp [he,initialSeed] at hs + have last : key.ancestors.getLast? = some (m,⟨query p (key.statement,[m]),a⟩) := by + have h := congrArg List.getLast? hh + simpa [List.getLast?_drop,List.getLast?_cons_of_ne_nil nonempty] using h + have sample : seedValue ⟨query p (key.statement,[m]),a⟩ = some out.initial := by + simpa only [initialSeed,last,Option.bind_some] using hs + obtain ⟨before,hb,_⟩ := WHIRReplay.decode_prefix _ roots (projectKey key) out.whir hw + key.ancestors.length hi + have parsed : WHIRReplay.decode p (localCatalog out.original out.initial) roots + ⟨key.statement,[m],[]⟩ = some before := by + have drop : (key.ancestors.map projectEntry).drop key.ancestors.length = [] := by simp + simpa only [projectKey,hm,drop] using hb + have derivation := WHIRReplay.decodeHistory_decodes p _ _ _ _ _ before parsed + have initial : decodeInitial p cap catalog ⟨key.statement,[m],[]⟩ = some out.original := by + cases derivation with + | initial shape found => simp [decodeInitial,shape,hd] + exact ⟨m,a,allocated,initial,sample⟩ + +/-- Original fixed-list falsity is transported through the actual executable +ring-family transformation unless the charged ring event already occurred. -/ +theorem false_or_initial_event {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) + (hfalse : ¬ ∃ w ∈ InitialCandidates.witnesses (config p) out.original.lanes out.original.root, + RingPCSGame.Honest (config p) out.original.lanes out.original.family out.original.points w) + (outside : ¬ RingPCSGame.InitialEvent p out.original.lanes out.original.root + out.original.family out.original.points out.initial) : + ¬ ∃ w ∈ InitialCandidates.witnesses (config p) out.whir.statement.lanes out.whir.statement.root, + ∀ claim ∈ out.whir.statement.claims.toList, + dot (paddedWitness (config p) out.whir.statement.lanes w) claim.weight = claim.value := by + rw [decode_statement catalog roots key out ok] + exact RingPCSGame.false_or_escape (config p) _ _ _ _ _ hfalse (fun h => outside (Or.inl h)) + +/-- The actual accepted-false cover separates the one grouped initial event +from all later WHIR coordinates. Original honesty, not transformed honesty, +is the input predicate. Both alternatives are proved from the checked verifier. -/ +theorem accepted_false_cover {p : Profile} {cap : Nat} (catalog : Catalog p cap) (roots : Roots) + (key : Key p) (out : Replay p cap) (ok : decode p cap catalog roots key = some out) + (x : Answer p key) + (accepted : CausalGame.experiment out.whir.statement.input + (CausalStrategy.indexedStrategy out.whir.replies) (finish key out x).whir.tape = true) + (hfalse : ¬ ∃ w ∈ InitialCandidates.witnesses (config p) out.original.lanes out.original.root, + RingPCSGame.Honest (config p) out.original.lanes out.original.family out.original.points w) : + RingPCSGame.InitialEvent p out.original.lanes out.original.root + out.original.family out.original.points out.initial ∨ + ∃ q : Coordinate (config p), q ≠ .initial ∧ + WHIRFiatShamir.allocationBad + (WHIRFiatShamir.requestOfTape out.whir.statement + (CausalStrategy.indexedStrategy out.whir.replies) q (finish key out x).whir.tape) + (get q (finish key out x).whir.tape) := by + classical + by_cases initial : RingPCSGame.InitialEvent p out.original.lanes out.original.root + out.original.family out.original.points out.initial + · exact Or.inl initial + · right + obtain ⟨q,hq⟩ := WHIRFiatShamir.accepted_false_prefix_cover p out.whir.statement + (CausalStrategy.indexedStrategy out.whir.replies) (finish key out x).whir.tape accepted + (false_or_initial_event catalog roots key out ok hfalse initial) + by_cases same : q = .initial + · subst q + apply (initial (Or.inr ?_)).elim + change get .initial (set .initial + (WHIRFiatShamir.Prefix.ofTape .initial (finish key out x).whir.tape).tape + (get .initial (finish key out x).whir.tape)) ∈ + InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) out.whir.statement.lanes out.whir.statement.root) + out.whir.statement.claims at hq + rw [get_set,decode_initial_lambda catalog roots key out ok x] at hq + simpa only [decode_statement catalog roots key out ok,transformedStatement] using hq + · exact ⟨q,same,hq⟩ + +end Whir.StackWHIRReplay diff --git a/verification/whir/Whir/StratifiedDensity.lean b/verification/whir/Whir/StratifiedDensity.lean new file mode 100644 index 000000000..4ee7c4e95 --- /dev/null +++ b/verification/whir/Whir/StratifiedDensity.lean @@ -0,0 +1,245 @@ +import Whir.Layout +import Whir.QuerySoundness + +namespace Whir.StratifiedDensity + +open scoped BigOperators + +/-- The actual top-bit coset used by `Layout.placeQuery`. -/ +def coset {depth : ℕ} (s : Layout.Stratum depth) : Finset (Fin (2 ^ depth)) := + Finset.univ.filter fun q => q.val / 2 ^ (depth - s.bits) = s.index + +/-- Agreement density in the stratum, with its explicit low-bit cardinality. -/ +noncomputable def density {depth : ℕ} (A : Finset (Fin (2 ^ depth))) + (s : Layout.Stratum depth) : ℝ := + ((A ∩ coset s).card : ℝ) / (2 ^ (depth - s.bits) : ℕ) + +noncomputable def globalDensity {depth : ℕ} (A : Finset (Fin (2 ^ depth))) : ℝ := + (A.card : ℝ) / (2 ^ depth : ℕ) + +@[simp] theorem mem_coset {depth : ℕ} (s : Layout.Stratum depth) + (q : Fin (2 ^ depth)) : q ∈ coset s ↔ q.val / 2 ^ (depth - s.bits) = s.index := by + simp [coset] + +/-- Low-bit choices enumerate the coset without collisions. -/ +def cosetEquiv {depth : ℕ} (s : Layout.Stratum depth) : + Fin (2 ^ (depth - s.bits)) ≃ {q : Fin (2 ^ depth) // q ∈ coset s} where + toFun r := ⟨⟨Layout.placeQuery s r.val, Layout.placeQuery_bound s r.val⟩, + (mem_coset s _).mpr (Layout.placeQuery_top s r.val)⟩ + invFun q := ⟨q.val.val % 2 ^ (depth - s.bits), Nat.mod_lt _ (by positivity)⟩ + left_inv r := by + apply Fin.ext + simp [Layout.placeQuery, Nat.mod_eq_of_lt r.isLt] + right_inv q := by + apply Subtype.ext + apply Fin.ext + have hq := (mem_coset s q.val).mp q.property + simp only [Layout.placeQuery, Nat.mod_mod] + rw [← hq] + simpa [Nat.mul_comm] using Nat.mod_add_div q.val.val (2 ^ (depth - s.bits)) + +@[simp] theorem coset_card {depth : ℕ} (s : Layout.Stratum depth) : + (coset s).card = 2 ^ (depth - s.bits) := by + simpa only [Fintype.card_coe, Fintype.card_fin] using + (Fintype.card_congr (cosetEquiv s)).symm + +theorem density_eq_card_div {depth : ℕ} (A : Finset (Fin (2 ^ depth))) + (s : Layout.Stratum depth) : + density A s = ((A ∩ coset s).card : ℝ) / (coset s).card := by + simp [density] + +theorem density_nonneg {depth : ℕ} (A : Finset (Fin (2 ^ depth))) + (s : Layout.Stratum depth) : 0 ≤ density A s := by + unfold density + positivity + +theorem globalDensity_nonneg {depth : ℕ} (A : Finset (Fin (2 ^ depth))) : + 0 ≤ globalDensity A := by + unfold globalDensity + positivity + +private theorem pow_split (depth bits : ℕ) (h : bits ≤ depth) : + 2 ^ depth = 2 ^ bits * 2 ^ (depth - bits) := by + rw [← pow_add, Nat.add_sub_of_le h] + +/-- Each agreement point belongs to exactly one coset at a fixed bit depth. -/ +theorem sum_agreement_cards {depth bits : ℕ} (h : bits ≤ depth) + (A : Finset (Fin (2 ^ depth))) : + (∑ j ∈ Finset.range (2 ^ bits), (A ∩ coset (Layout.stratumAt depth bits j)).card) = + A.card := by + have hf : ∀ q ∈ A, q.val / 2 ^ (depth - bits) ∈ Finset.range (2 ^ bits) := by + intro q _ + rw [Finset.mem_range, Nat.div_lt_iff_lt_mul (by positivity)] + simp [← pow_split depth bits h] + have hc := Finset.card_eq_sum_card_fiberwise hf + rw [hc] + apply Finset.sum_congr rfl + intro j hj + congr 1 + ext q + simp [coset, Layout.stratumAt, Nat.min_eq_left h, + Nat.mod_eq_of_lt (Finset.mem_range.mp hj)] + +/-- The sum of the concrete coset densities is obtained by counting agreement points. -/ +theorem sum_densities {depth bits : ℕ} (h : bits ≤ depth) + (A : Finset (Fin (2 ^ depth))) : + (∑ j ∈ Finset.range (2 ^ bits), density A (Layout.stratumAt depth bits j)) = + (2 ^ bits : ℕ) * globalDensity A := by + simp only [density, Layout.stratumAt, Nat.min_eq_left h] + rw [← Finset.sum_div] + have hc := sum_agreement_cards h A + simp only [Layout.stratumAt, Nat.min_eq_left h] at hc + rw [← Nat.cast_sum, hc] + unfold globalDensity + conv_rhs => arg 2; arg 2; rw [pow_split depth bits h, Nat.cast_mul] + field_simp + +private theorem sum_range_mod (f : ℕ → ℝ) (n k : ℕ) : + (∑ j ∈ Finset.range (n * k), f (j % n)) = + k * ∑ j ∈ Finset.range n, f j := by + induction k with + | zero => simp + | succ k ih => + rw [Nat.mul_succ, Finset.sum_range_add, ih] + have h : (∑ j ∈ Finset.range n, f ((n * k + j) % n)) = + ∑ j ∈ Finset.range n, f j := by + apply Finset.sum_congr rfl + intro j hj + simp [Nat.add_mod, Nat.mod_eq_of_lt (Finset.mem_range.mp hj)] + rw [h, Nat.cast_add, Nat.cast_one] + ring + +/-- Larger binary groups repeat all top-bit cosets equally, rather than deduplicating. -/ +theorem group_sum_densities (depth g : ℕ) (A : Finset (Fin (2 ^ depth))) : + (∑ j ∈ Finset.range (2 ^ g), density A (Layout.stratumAt depth g j)) = + (2 ^ g : ℕ) * globalDensity A := by + let b := min g depth + have hb : b ≤ depth := Nat.min_le_right _ _ + have hbg : b ≤ g := Nat.min_le_left _ _ + have hs (j : ℕ) : Layout.stratumAt depth g j = + Layout.stratumAt depth b (j % 2 ^ b) := by + simp [Layout.stratumAt, b] + simp_rw [hs] + conv_lhs => rw [pow_split g b hbg] + rw [sum_range_mod (fun j => density A (Layout.stratumAt depth b j)), + sum_densities hb] + conv_rhs => rw [pow_split g b hbg, Nat.cast_mul] + ring + +private theorem list_prod_range (f : ℕ → ℝ) (n : ℕ) : + ((List.range n).map f).prod = ∏ j ∈ Finset.range n, f j := by + induction n with + | zero => simp + | succ n ih => simp [List.range_succ, Finset.prod_range_succ, ih] + +/-- AM-GM applied to the actual finite cosets of one binary group. -/ +theorem group_product_le (depth g : ℕ) (A : Finset (Fin (2 ^ depth))) : + ((Layout.stratumGroup depth g).map (density A)).prod ≤ + globalDensity A ^ (2 ^ g) := by + let : NeZero (2 ^ g) := ⟨by positivity⟩ + have h := QuerySoundness.strata_amgm + (fun j : Fin (2 ^ g) => density A (Layout.stratumAt depth g j.val)) + (fun _ => density_nonneg A _) + have hs : (∑ j : Fin (2 ^ g), density A (Layout.stratumAt depth g j.val)) = + (2 ^ g : ℕ) * globalDensity A := by + rw [Fin.sum_univ_eq_sum_range (fun j => density A (Layout.stratumAt depth g j))] + exact group_sum_densities depth g A + rw [hs, Fintype.card_fin, mul_div_cancel_left₀ _ (by positivity)] at h + unfold QuerySoundness.missProduct at h + rw [Fin.prod_univ_eq_prod_range (fun j => density A (Layout.stratumAt depth g j))] at h + simpa only [Layout.stratumGroup, List.map_map, Function.comp_def, list_prod_range] using h + +/-- Every symbolic binary group contributes its exact query count to the exponent. +This includes zero count, depth zero, empty agreement, and groups larger than the domain. -/ +theorem strataBits_product_le (width count depth : ℕ) (A : Finset (Fin (2 ^ depth))) + (hc : count < 2 ^ width) : + ((Layout.strataBits width count depth).map (density A)).prod ≤ + globalDensity A ^ count := by + induction width generalizing count with + | zero => + have : count = 0 := by simpa using hc + simp [Layout.strataBits, this] + | succ width ih => + have hp : 2 ^ (width + 1) = 2 ^ width * 2 := by rw [pow_succ] + simp only [Layout.strataBits] + split_ifs with h + · rw [List.map_append, List.prod_append] + have hn : 0 ≤ ((Layout.strataBits width (count - 2 ^ width) depth).map + (density A)).prod := List.prod_nonneg (by + intro x hx + obtain ⟨s, _, rfl⟩ := List.mem_map.mp hx + exact density_nonneg A s) + calc + _ ≤ globalDensity A ^ (2 ^ width) * globalDensity A ^ (count - 2 ^ width) := + mul_le_mul (group_product_le depth width A) + (ih (count - 2 ^ width) (by omega)) hn + (pow_nonneg (globalDensity_nonneg A) _) + _ = _ := by rw [← pow_add, Nat.add_sub_of_le h] + · exact ih count (by omega) + +/-- Finite-domain form of the exact query placement. -/ +def placed {depth : ℕ} (s : Layout.Stratum depth) (raw : Fin (2 ^ depth)) : + Fin (2 ^ depth) := ⟨Layout.placeQuery s raw.val, Layout.placeQuery_bound s raw.val⟩ + +/-- A successful raw sample is an agreement point in the coset and arbitrary discarded top bits. -/ +def rawAgreementEquiv {depth : ℕ} (A : Finset (Fin (2 ^ depth))) + (s : Layout.Stratum depth) : + {raw : Fin (2 ^ depth) // placed s raw ∈ A} ≃ + Fin (2 ^ s.bits) × {q : Fin (2 ^ depth) // q ∈ A ∩ coset s} where + toFun raw := (⟨raw.val.val / 2 ^ (depth - s.bits), by + rw [Nat.div_lt_iff_lt_mul (by positivity)] + simp [← pow_split depth s.bits s.bits_le]⟩, + ⟨placed s raw.val, Finset.mem_inter.mpr ⟨raw.property, + (mem_coset s _).mpr (Layout.placeQuery_top s raw.val.val)⟩⟩) + invFun p := by + let r := p.2.val.val % 2 ^ (depth - s.bits) + + p.1.val * 2 ^ (depth - s.bits) + have hr : r < 2 ^ depth := by + rw [pow_split depth s.bits s.bits_le] + have hm := Nat.mod_lt p.2.val.val (show 0 < 2 ^ (depth - s.bits) by positivity) + have ht := Nat.mul_le_mul_right (2 ^ (depth - s.bits)) p.1.isLt + dsimp [r] + nlinarith + refine ⟨⟨r, hr⟩, ?_⟩ + have hp : placed s ⟨r, hr⟩ = p.2.val := by + apply Fin.ext + have hq := (mem_coset s p.2.val).mp (Finset.mem_inter.mp p.2.property).2 + simp only [placed, Layout.placeQuery, r, Nat.add_mod, Nat.mul_mod, + Nat.mod_self, mul_zero, Nat.mod_mod] + rw [← hq] + simpa [Nat.mul_comm] using Nat.mod_add_div p.2.val.val (2 ^ (depth - s.bits)) + rw [hp] + exact (Finset.mem_inter.mp p.2.property).1 + left_inv raw := by + apply Subtype.ext + apply Fin.ext + simp only [placed, Layout.placeQuery] + simp only [Nat.add_mod, Nat.mul_mod, Nat.mod_self, mul_zero, Nat.mod_mod] + simpa [Nat.mul_comm] using Nat.mod_add_div raw.val.val (2 ^ (depth - s.bits)) + right_inv p := by + apply Prod.ext + · apply Fin.ext + dsimp + rw [Nat.add_mul_div_right _ _ (by positivity)] + simp [Nat.div_eq_of_lt (Nat.mod_lt _ (show 0 < 2 ^ (depth - s.bits) by positivity))] + · apply Subtype.ext + apply Fin.ext + have hq := (mem_coset s p.2.val).mp (Finset.mem_inter.mp p.2.property).2 + simp only [placed, Layout.placeQuery] + simp only [Nat.add_mod, Nat.mul_mod, Nat.mod_self, mul_zero, Nat.mod_mod] + rw [← hq] + simpa [Nat.mul_comm] using Nat.mod_add_div p.2.val.val (2 ^ (depth - s.bits)) + +/-- Uniform raw samples induce uniform sampling in the actual coset. -/ +theorem raw_probability_eq_density {depth : ℕ} (A : Finset (Fin (2 ^ depth))) + (s : Layout.Stratum depth) : + (Fintype.card {raw : Fin (2 ^ depth) // placed s raw ∈ A} : ℝ) / + (2 ^ depth : ℕ) = density A s := by + have hc := Fintype.card_congr (rawAgreementEquiv A s) + simp only [Fintype.card_prod, Fintype.card_fin, Fintype.card_coe] at hc + rw [hc, Nat.cast_mul] + unfold density + conv_lhs => arg 2; rw [pow_split depth s.bits s.bits_le, Nat.cast_mul] + field_simp + +end Whir.StratifiedDensity diff --git a/verification/whir/Whir/SuccinctPointWeight.lean b/verification/whir/Whir/SuccinctPointWeight.lean new file mode 100644 index 000000000..fa3a99fc1 --- /dev/null +++ b/verification/whir/Whir/SuccinctPointWeight.lean @@ -0,0 +1,468 @@ +import Whir.RingPCSGame +import Whir.ExecutableOOD + +/-! Source stack selectors, with explicit alignment and slot guards. These +are stronger than the original verifier's range-only point checks. -/ +namespace Whir.SuccinctPointWeight +open scoped BigOperators +open ExecutableOOD +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 + +variable {R : Type*} [CommRing R] + +def natMle (n : Nat) (f : Nat → R) (x : Fin n → R) : R := + Whir.mle (fun u => f (cubeIndex u)) x + +def eqBits {n : Nat} (q : Nat) (x : Fin n → R) : R := + ∏ i, if q.testBit i.val then x i else 1 - x i + +lemma natMle_succ {n : Nat} (f : Nat → R) (x : Fin (n+1) → R) : + natMle (n+1) f x = + (1-x 0) * natMle n (fun v => f (2*v)) (fun i => x i.succ) + + x 0 * natMle n (fun v => f (2*v+1)) (fun i => x i.succ) := by + have hx : x = Fin.cons (x 0) (fun i => x i.succ) := by ext i; exact Fin.cases rfl (fun _ => rfl) i + rw [hx] + simp only [natMle, Whir.mle, innerProduct, sum_cube_succ, Whir.eqWeight_cons, + cubeIndex_cons, Bool.false_eq_true, ↓reduceIte, Nat.add_zero, + Fin.cons_zero, Fin.cons_succ, mul_assoc, ← Finset.mul_sum] + +lemma cubeIndex_sum {n : Nat} (u : Cube n) : + cubeIndex u = ∑ i : Fin n, 2^i.val * (if u i then 1 else 0) := by + induction n with + | zero => simp [cubeIndex] + | succ n ih => + rw [cubeIndex, Fin.sum_univ_succ, ih] + simp only [Fin.val_zero, pow_zero, one_mul, Fin.val_succ, pow_succ] + simp only [mul_right_comm (2^_) 2, ← Finset.sum_mul] + omega + +lemma cubeIndex_append {d h : Nat} (a : Cube d) (b : Cube h) : + cubeIndex (Fin.addCases a b) = cubeIndex a + 2^d * cubeIndex b := by + simp only [cubeIndex_sum, Fin.sum_univ_add, Fin.addCases_left, Fin.addCases_right, + Fin.val_castAdd, Fin.val_natAdd, pow_add, mul_assoc, Finset.mul_sum] + +lemma eqWeight_append {d h : Nat} (x : Fin d → R) (y : Fin h → R) + (a : Cube d) (b : Cube h) : + Whir.eqWeight (Fin.addCases x y) (Fin.addCases a b) = + Whir.eqWeight x a * Whir.eqWeight y b := by + simp [Whir.eqWeight, Fin.prod_univ_add] + +def cubeAppendEquiv (d h : Nat) : Cube d × Cube h ≃ Cube (d+h) where + toFun p := Fin.addCases p.1 p.2 + invFun u := (fun i => u (Fin.castAdd h i), fun i => u (Fin.natAdd d i)) + left_inv p := by rcases p with ⟨a,b⟩; simp + right_inv u := by ext i; refine Fin.addCases (fun _ => ?_) (fun _ => ?_) i <;> simp + +lemma natMle_split {d h : Nat} (f : Nat → R) (x : Fin d → R) (y : Fin h → R) : + natMle (d+h) f (Fin.addCases x y) = + ∑ b : Cube h, Whir.eqWeight y b * + natMle d (fun v => f (v + 2^d*cubeIndex b)) x := by + unfold natMle Whir.mle innerProduct + rw [← Equiv.sum_comp (cubeAppendEquiv d h)] + simp only [Fintype.sum_prod_type, cubeAppendEquiv, Equiv.coe_fn_mk, + eqWeight_append, cubeIndex_append] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro b _ + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro a _ + ring + +lemma cubeIndex_testBit {n : Nat} (u : Cube n) (i : Fin n) : + (cubeIndex u).testBit i.val = u i := by + induction n with + | zero => exact Fin.elim0 i + | succ n ih => + have bits : cubeIndex u = Nat.bit (u 0) (cubeIndex (fun j : Fin n => u j.succ)) := by + cases h : u 0 <;> + simp only [cubeIndex, h, Bool.false_eq_true, ↓reduceIte, Nat.add_zero, + Nat.bit_false_apply, Nat.bit_true_apply] + refine Fin.cases ?_ (fun j => ?_) i + · simpa only [bits, Fin.val_zero] using Nat.testBit_bit_zero (u 0) (cubeIndex (fun j : Fin n => u j.succ)) + · simpa only [bits, Fin.val_succ, Nat.testBit_bit_succ] using ih (fun j : Fin n => u j.succ) j + +lemma cubeIndex_injective (n : Nat) : Function.Injective (@cubeIndex n) := by + intro a b equal + funext i + have h := congrArg (fun k => k.testBit i.val) equal + simpa only [cubeIndex_testBit] using h + +lemma eqBits_cubeIndex {n : Nat} (u : Cube n) (x : Fin n → R) : + eqBits (cubeIndex u) x = Whir.eqWeight x u := by + simp only [eqBits, cubeIndex_testBit, Whir.eqWeight] + +def region (offset d : Nat) (f : Nat → R) (v : Nat) : R := + if offset ≤ v ∧ v < offset + 2^d then f (v-offset) else 0 + +lemma region_block {d : Nat} (q b a : Nat) (low : a < 2^d) (f : Nat → R) : + region (2^d*q) d f (a+2^d*b) = if b=q then f a else 0 := by + have positive : 0 < 2^d := by positivity + have selected : 2^d*q ≤ a+2^d*b ∧ a+2^d*b < 2^d*q+2^d ↔ b=q := by + constructor + · intro selected + rcases lt_trichotomy b q with below | equal | above + · have h := Nat.mul_le_mul_left (2^d) (Nat.succ_le_of_lt below) + nlinarith + · exact equal + · have h := Nat.mul_le_mul_left (2^d) (Nat.succ_le_of_lt above) + nlinarith + · rintro rfl + omega + simp only [region, selected] + split + · rename_i equal + subst b + simp + · rfl + +lemma alignedRegion_mle {d h : Nat} (q : Nat) (bound : q < 2^h) + (f : Nat → R) (lo : Fin d → R) (hi : Fin h → R) : + natMle (d+h) (region (2^d*q) d f) (Fin.addCases lo hi) = + natMle d f lo * eqBits q hi := by + obtain ⟨chosen,hchosen⟩ := cubeIndex_surjective q bound + rw [natMle_split] + have inner (b : Cube h) : + natMle d (fun v => region (2^d*q) d f (v+2^d*cubeIndex b)) lo = + if b=chosen then natMle d f lo else 0 := by + unfold natMle + by_cases equal : b=chosen + · subst b + simp only [hchosen, region_block _ _ _ (cubeIndex_lt _) _, ↓reduceIte] + · have different : cubeIndex b ≠ q := by + intro same + exact equal (cubeIndex_injective h (same.trans hchosen.symm)) + simp only [region_block _ _ _ (cubeIndex_lt _) _, different, equal, ↓reduceIte, + Whir.mle_const] + simp_rw [inner] + simp only [mul_ite, mul_zero, Finset.sum_ite_eq', Finset.mem_univ, ↓reduceIte] + rw [← hchosen, eqBits_cubeIndex] + exact mul_comm _ _ + +/-- Arbitrary low-dimensional weights scatter onto an aligned dyadic region. +The arithmetic selector and full cube bound are proved, not bridge premises. -/ +theorem region_mle {d h : Nat} (offset : Nat) (f : Nat → R) + (lo : Fin d → R) (hi : Fin h → R) + (aligned : offset % 2^d = 0) (bounded : offset+2^d ≤ 2^(d+h)) : + natMle (d+h) (region offset d f) (Fin.addCases lo hi) = + natMle d f lo * eqBits (offset/2^d) hi := by + have positive : 0 < 2^d := by positivity + have offset_eq : offset = 2^d*(offset/2^d) := by + have h := Nat.mod_add_div offset (2^d) + omega + have bound : offset/2^d < 2^h := by + rw [pow_add, offset_eq] at bounded + nlinarith + conv_lhs => rw [offset_eq] + exact alignedRegion_mle _ bound _ _ _ + +lemma mle_eqWeight [CharP R 2] {n : Nat} (point x : Fin n → R) : + Whir.mle (Whir.eqWeight point) x = ∏ i, (1 + point i + x i) := by + induction n with + | zero => simp [Whir.mle, innerProduct, Whir.eqWeight, Cube] + | succ n ih => + have hp : point = Fin.cons (point 0) (fun i => point i.succ) := by + ext i; exact Fin.cases rfl (fun _ => rfl) i + have hx : x = Fin.cons (x 0) (fun i => x i.succ) := by + ext i; exact Fin.cases rfl (fun _ => rfl) i + rw [hp, hx] + unfold Whir.mle innerProduct + rw [sum_cube_succ, Fin.prod_univ_succ] + simp only [Whir.eqWeight_cons, Bool.false_eq_true, ↓reduceIte, Fin.cons_zero, Fin.cons_succ] + have scalar (a b : R) : + (∑ u : Cube n, (a * Whir.eqWeight (fun i => x i.succ) u) * + (b * Whir.eqWeight (fun i => point i.succ) u)) = + a*b*Whir.mle (Whir.eqWeight (fun i => point i.succ)) (fun i => x i.succ) := by + unfold Whir.mle innerProduct + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro u _ + ring + rw [scalar, scalar, ← add_mul, ih] + have coordinate : (1-x 0)*(1-point 0)+x 0*point 0 = 1+point 0+x 0 := by + rw [CharTwo.sub_eq_add, CharTwo.sub_eq_add] + ring_nf + simp [CharTwo.two_eq_zero] + rw [coordinate] + +theorem eqWeight_mle (point : Array Concrete.E) (lo : Fin point.size → Concrete.E) : + natMle point.size (RingPCSGame.eqWeight point) lo = ∏ i, (1+point[i]+lo i) := by + have decoded : (fun u : Cube point.size => RingPCSGame.eqWeight point (cubeIndex u)) = + Whir.eqWeight (fun i => point[i]) := by + funext u + simp only [RingPCSGame.eqWeight, cubeIndex_testBit, Whir.eqWeight, CharTwo.sub_eq_add] + unfold natMle + rw [decoded, mle_eqWeight] + simp + +theorem mle_tab [Inhabited R] [CharP R 2] (n : Nat) (f : Nat → R) (x : Fin n → R) : + Concrete.mle (Concrete.tab (2^n) f) (Array.ofFn x) = natMle n f x := by + rw [mle_eq_cube _ _ (ArrayLayout.size_tab _ _)] + unfold natMle + congr 1 + funext u + exact ArrayLayout.getElem!_tab _ _ _ (cubeIndex_lt u) + +lemma natMle_delta {n : Nat} (q : Nat) (bound : q < 2^n) (value : R) (x : Fin n → R) : + natMle n (fun v => if v=q then value else 0) x = eqBits q x * value := by + obtain ⟨chosen,hchosen⟩ := cubeIndex_surjective q bound + have select (u : Cube n) : cubeIndex u=q ↔ u=chosen := + ⟨fun h => cubeIndex_injective n (h.trans hchosen.symm),fun h => h ▸ hchosen⟩ + simp only [natMle, Whir.mle, innerProduct, select, mul_ite, mul_zero, + Finset.sum_ite_eq', Finset.mem_univ, ↓reduceIte] + rw [← hchosen, eqBits_cubeIndex] + +def strideWeight (stride slot : Nat) (f : Nat → R) (v : Nat) : R := + if v % 2^stride = slot then f (v/2^stride) else 0 + +lemma strideWeight_block {s : Nat} (slot a b : Nat) (low : a < 2^s) (f : Nat → R) : + strideWeight s slot f (a+2^s*b) = if a=slot then f b else 0 := by + simp [strideWeight, Nat.add_mul_mod_self_left, Nat.mod_eq_of_lt low, + Nat.add_mul_div_left, Nat.div_eq_of_lt low] + +theorem strideWeight_mle {s d : Nat} (slot : Nat) (valid : slot < 2^s) + (f : Nat → R) (low : Fin s → R) (point : Fin d → R) : + natMle (s+d) (strideWeight s slot f) (Fin.addCases low point) = + eqBits slot low * natMle d f point := by + rw [natMle_split] + have inner (b : Cube d) : + natMle s (fun v => strideWeight s slot f (v+2^s*cubeIndex b)) low = + eqBits slot low * f (cubeIndex b) := by + have same : (fun u : Cube s => strideWeight s slot f (cubeIndex u+2^s*cubeIndex b)) = + (fun u : Cube s => if cubeIndex u=slot then f (cubeIndex b) else 0) := by + funext u + exact strideWeight_block _ _ _ (cubeIndex_lt u) _ + unfold natMle + rw [same] + exact natMle_delta slot valid _ low + simp_rw [inner] + unfold natMle Whir.mle innerProduct + rw [Finset.mul_sum] + apply Finset.sum_congr rfl + intro u _ + ring + +lemma strided_region (offset slot stride : Nat) (point : Array Concrete.E) (value : Concrete.E) : + RingPCSGame.pointWeight (.strided offset slot stride point value) = + region offset (stride+point.size) (strideWeight stride slot (RingPCSGame.eqWeight point)) := by + funext v + have mod_le : (v-offset) % 2^stride ≤ v-offset := Nat.mod_le _ _ + unfold RingPCSGame.pointWeight region strideWeight + by_cases bounds : offset ≤ v ∧ v < offset+2^(stride+point.size) + · by_cases slotEq : (v-offset) % 2^stride = slot + · have lower : offset+slot ≤ v := by omega + simp only [bounds, slotEq, lower, and_self, ↓reduceIte] + · simp [bounds, slotEq] + · have impossible : ¬(offset+slot ≤ v ∧ v < offset+2^(stride+point.size) ∧ + (v-offset)%2^stride=slot) := by omega + simp only [bounds, impossible, ↓reduceIte] + +/-- Source `Arith::eq_eval` on one contiguous coordinate segment. -/ +def eqEval (point x : Array Concrete.E) (start : Nat) : Concrete.E := + ∏ i : Fin point.size, (1+point[i]+x[start+i.val]!) + +/-- Source `Arith::eq_bits`; coordinates are little-endian. -/ +def eqBitsAt (selector : Nat) (x : Array Concrete.E) (start count : Nat) : Concrete.E := + ∏ i : Fin count, if selector.testBit i.val then x[start+i.val]! else 1+x[start+i.val]! + +/-- The two products in `StackClaim::eq_at`, not a dense-table evaluator. +The shape predicate below rules out out-of-range coordinate slices. -/ +def eqAt : RingPCSGame.PointClaim → Array Concrete.E → Concrete.E + | .point offset point _, x => + eqEval point x 0 * eqBitsAt (offset >>> point.size) x point.size (x.size-point.size) + | .strided offset slot stride point _, x => + (eqBitsAt slot x 0 stride * eqEval point x stride) * + eqBitsAt (offset >>> (stride+point.size)) x (stride+point.size) (x.size-(stride+point.size)) + +def Shape (n : Nat) : RingPCSGame.PointClaim → Prop + | .point offset point _ => + point.size ≤ n ∧ offset % 2^point.size = 0 ∧ offset+2^point.size ≤ 2^n + | .strided offset slot stride point _ => + stride+point.size ≤ n ∧ offset % 2^(stride+point.size) = 0 ∧ + offset+2^(stride+point.size) ≤ 2^n ∧ slot < 2^stride + +instance (n : Nat) (claim : RingPCSGame.PointClaim) : Decidable (Shape n claim) := by + cases claim <;> unfold Shape <;> infer_instance + +/-- Explicit additional source guards; the old range-only `check_statement` +does not imply this predicate. No occupied-lane count changes these selectors. -/ +def check (n : Nat) (claim : RingPCSGame.PointClaim) : Bool := decide (Shape n claim) + +theorem check_iff (n : Nat) (claim : RingPCSGame.PointClaim) : + check n claim = true ↔ Shape n claim := by simp [check] + +omit [CommRing R] in +lemma array_split_left [Inhabited R] {d h : Nat} (a : Fin d → R) (b : Fin h → R) (i : Fin d) : + (Array.ofFn (Fin.addCases a b))[i.val]! = a i := by + rw [getElem!_pos _ _ (by simp only [Array.size_ofFn]; omega), Array.getElem_ofFn] + change Fin.addCases a b (Fin.castAdd h i) = a i + exact Fin.addCases_left i + +omit [CommRing R] in +lemma array_split_right [Inhabited R] {d h : Nat} (a : Fin d → R) (b : Fin h → R) (i : Fin h) : + (Array.ofFn (Fin.addCases a b))[d+i.val]! = b i := by + rw [getElem!_pos _ _ (by simp only [Array.size_ofFn]; omega), Array.getElem_ofFn] + change Fin.addCases a b (Fin.natAdd d i) = b i + exact Fin.addCases_right i + +theorem eqAt_point_split {h : Nat} (offset : Nat) (point : Array Concrete.E) (value : Concrete.E) + (lo : Fin point.size → Concrete.E) (hi : Fin h → Concrete.E) : + eqAt (.point offset point value) (Array.ofFn (Fin.addCases lo hi)) = + (∏ i, (1+point[i]+lo i)) * eqBits (offset/2^point.size) hi := by + simp only [eqAt, Nat.shiftRight_eq_div_pow, Array.size_ofFn, Nat.add_sub_cancel_left] + simp only [eqEval, eqBitsAt, Nat.zero_add, array_split_left, array_split_right, + eqBits, CharTwo.sub_eq_add] + simp + +theorem eqAt_strided_split {s h : Nat} (offset slot : Nat) (point : Array Concrete.E) + (value : Concrete.E) (low : Fin s → Concrete.E) (middle : Fin point.size → Concrete.E) + (hi : Fin h → Concrete.E) : + eqAt (.strided offset slot s point value) (Array.ofFn (Fin.addCases (Fin.addCases low middle) hi)) = + (eqBits slot low * (∏ i, (1+point[i]+middle i))) * eqBits (offset/2^(s+point.size)) hi := by + have getLow (i : Fin s) : + (Array.ofFn (Fin.addCases (Fin.addCases low middle) hi))[i.val]! = low i := by + have h := array_split_left (Fin.addCases low middle) hi (Fin.castAdd point.size i) + simpa only [Fin.val_castAdd, Fin.addCases_left] using h + have getMiddle (i : Fin point.size) : + (Array.ofFn (Fin.addCases (Fin.addCases low middle) hi))[s+i.val]! = middle i := by + have h := array_split_left (Fin.addCases low middle) hi (Fin.natAdd s i) + simpa only [Fin.val_natAdd, Fin.addCases_right] using h + simp only [eqAt, Nat.shiftRight_eq_div_pow, Array.size_ofFn, Nat.add_sub_cancel_left] + simp only [eqEval, eqBitsAt, Nat.zero_add, getLow, getMiddle, array_split_right, + eqBits, CharTwo.sub_eq_add] + simp + +theorem point_mle {h : Nat} (offset : Nat) (point : Array Concrete.E) (value : Concrete.E) + (lo : Fin point.size → Concrete.E) (hi : Fin h → Concrete.E) + (aligned : offset % 2^point.size = 0) + (bounded : offset+2^point.size ≤ 2^(point.size+h)) : + natMle (point.size+h) (RingPCSGame.pointWeight (.point offset point value)) (Fin.addCases lo hi) = + eqAt (.point offset point value) (Array.ofFn (Fin.addCases lo hi)) := by + change natMle _ (region offset point.size (RingPCSGame.eqWeight point)) _ = _ + rw [region_mle offset _ lo hi aligned bounded, eqWeight_mle, eqAt_point_split] + +theorem strided_mle {s h : Nat} (offset slot : Nat) (point : Array Concrete.E) (value : Concrete.E) + (low : Fin s → Concrete.E) (middle : Fin point.size → Concrete.E) (hi : Fin h → Concrete.E) + (aligned : offset % 2^(s+point.size) = 0) + (bounded : offset+2^(s+point.size) ≤ 2^(s+point.size+h)) (valid : slot < 2^s) : + natMle (s+point.size+h) (RingPCSGame.pointWeight (.strided offset slot s point value)) + (Fin.addCases (Fin.addCases low middle) hi) = + eqAt (.strided offset slot s point value) (Array.ofFn (Fin.addCases (Fin.addCases low middle) hi)) := by + rw [strided_region, region_mle offset _ _ hi aligned bounded, + strideWeight_mle slot valid, eqWeight_mle, eqAt_strided_split] + +theorem eqAt_eq_natMle (n : Nat) (claim : RingPCSGame.PointClaim) (x : Fin n → Concrete.E) + (shape : Shape n claim) : + eqAt claim (Array.ofFn x) = natMle n (RingPCSGame.pointWeight claim) x := by + cases claim with + | point offset point value => + obtain ⟨dimension,aligned,bounded⟩ := shape + obtain ⟨h,rfl⟩ := Nat.exists_eq_add_of_le dimension + have split : x = Fin.addCases (fun i => x (Fin.castAdd h i)) (fun i => x (Fin.natAdd point.size i)) := by + ext i + refine Fin.addCases (fun j => ?_) (fun j => ?_) i <;> simp + rw [split] + exact (point_mle offset point value _ _ aligned bounded).symm + | strided offset slot stride point value => + obtain ⟨dimension,aligned,bounded,valid⟩ := shape + obtain ⟨h,rfl⟩ := Nat.exists_eq_add_of_le dimension + let low : Fin stride → Concrete.E := fun i => x (Fin.castAdd h (Fin.castAdd point.size i)) + let middle : Fin point.size → Concrete.E := fun i => x (Fin.castAdd h (Fin.natAdd stride i)) + let hi : Fin h → Concrete.E := fun i => x (Fin.natAdd (stride+point.size) i) + have split : x = Fin.addCases (Fin.addCases low middle) hi := by + ext i + refine Fin.addCases (fun j => ?_) (fun j => ?_) i + · refine Fin.addCases (fun k => ?_) (fun k => ?_) j <;> simp [low,middle] + · simp [hi] + rw [split] + exact (strided_mle offset slot point value low middle hi aligned bounded valid).symm + +/-- Exact source selector versus the existing dense public claim evaluator. -/ +theorem eqAt_eq_mle (claim : RingPCSGame.PointClaim) (x : Array Concrete.E) + (shape : Shape x.size claim) : + eqAt claim x = Concrete.mle (RingPCSGame.publicPoint (2^x.size) claim).weight x := by + have h := eqAt_eq_natMle x.size claim (fun i => x[i]) shape + rw [← mle_tab] at h + have copied : (Array.ofFn (fun i : Fin x.size => x[i])) = x := by + apply Array.ext + · simp + · intro i hi hj + simp + rw [copied] at h + exact h + +lemma dense_dot_comm (a b : Array Concrete.E) : Concrete.dot a b = Concrete.dot b a := by + simp only [ArrayAlgebra.dot_eq_sum] + rw [Nat.min_comm] + apply Finset.sum_congr rfl + intro i _ + exact mul_comm _ _ + +lemma dense_dot_zero (width : Nat) (a : Array Concrete.E) : + Concrete.dot (Concrete.tab width (fun _ => 0)) a = 0 := by + simp only [ArrayAlgebra.dot_eq_sum, ArrayLayout.size_tab] + apply Finset.sum_eq_zero + intro i member + have hi : i < width := lt_of_lt_of_le (Finset.mem_range.mp member) (Nat.min_le_left _ _) + rw [ArrayLayout.getElem!_tab _ _ _ hi, zero_mul] + +/-- Linearity of the actual imperative initial accumulator, derived from its +existing discrepancy refinement rather than replacing the accumulator. -/ +theorem mle_batchClaims (claims : Array CausalGame.Claim) (lambda : Concrete.E) (x : Array Concrete.E) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2^x.size) : + Concrete.mle (CausalGame.batchClaims (2^x.size) claims lambda).weight x = + ∑ j ∈ Finset.range claims.size, lambda^j * Concrete.mle claims[j]!.weight x := by + have hz := InitialBatching.batchClaims_discrepancy (Concrete.tab (2^x.size) (fun _ => 0)) claims lambda + (by simpa only [ArrayLayout.size_tab] using shape) + have hx := InitialBatching.batchClaims_discrepancy (Concrete.eqTable x) claims lambda + (by simpa only [TerminalRefinement.size_eqTable] using shape) + simp only [ArrayLayout.size_tab, InitialBatching.errorPolynomial_eval, InitialBatching.claimError, + dense_dot_zero, zero_sub, mul_neg, Finset.sum_neg_distrib, neg_inj] at hz + simp only [TerminalRefinement.size_eqTable, InitialBatching.errorPolynomial_eval, + InitialBatching.claimError, mul_sub, Finset.sum_sub_distrib, hz] at hx + have linear := congrArg (fun z => z + ∑ j ∈ Finset.range claims.size, lambda^j*claims[j]!.value) hx + simp only [sub_add_cancel] at linear + simpa only [Concrete.mle, dense_dot_comm] using linear + +theorem mle_transformedClaims {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) + (lambda : Concrete.E) (x : Array Concrete.E) : + Concrete.mle (CausalGame.batchClaims (2^x.size) + (RingPCSGame.transformedClaims (2^x.size) family points seed) lambda).weight x = + Concrete.mle (RingPCSGame.familyPublic (2^x.size) family seed).weight x + + ∑ i : Fin points.size, + lambda^(i.val+1)*Concrete.mle (RingPCSGame.publicPoint (2^x.size) points[i]).weight x := by + rw [mle_batchClaims] + · have size : (RingPCSGame.transformedClaims (2^x.size) family points seed).size = points.size+1 := by + simp [Nat.add_comm] + rw [size, Finset.sum_range_succ'] + have head : (RingPCSGame.transformedClaims (2^x.size) family points seed)[0]! = + RingPCSGame.familyPublic (2^x.size) family seed := by + simp [RingPCSGame.transformedClaims] + rw [head, pow_zero, one_mul, add_comm, ← Fin.sum_univ_eq_sum_range] + congr 1 + apply Finset.sum_congr rfl + intro i _ + have tail : (RingPCSGame.transformedClaims (2^x.size) family points seed)[i.val+1]! = + RingPCSGame.publicPoint (2^x.size) points[i] := by + rw [getElem!_pos _ _ (by simp; omega)] + unfold RingPCSGame.transformedClaims + rw [Array.getElem_append_right (by simp)] + simp + rw [tail] + · intro j + have member : (RingPCSGame.transformedClaims (2^x.size) family points seed)[j] ∈ + RingPCSGame.transformedClaims (2^x.size) family points seed := Array.getElem_mem j.isLt + simp only [RingPCSGame.transformedClaims, Array.mem_append, Array.mem_singleton, Array.mem_map] at member + rcases member with head | ⟨point,_,head⟩ + · have equal : (RingPCSGame.transformedClaims (2^x.size) family points seed)[j] = + RingPCSGame.familyPublic (2^x.size) family seed := head + rw [equal] + simp [RingPCSGame.familyPublic] + · have equal : (RingPCSGame.transformedClaims (2^x.size) family points seed)[j] = + RingPCSGame.publicPoint (2^x.size) point := head.symm + rw [equal] + simp [RingPCSGame.publicPoint] + +end Whir.SuccinctPointWeight diff --git a/verification/whir/Whir/SuccinctRingCoefficients.lean b/verification/whir/Whir/SuccinctRingCoefficients.lean new file mode 100644 index 000000000..a6e8ce120 --- /dev/null +++ b/verification/whir/Whir/SuccinctRingCoefficients.lean @@ -0,0 +1,128 @@ +import Whir.SuccinctRingWeight + +namespace Whir.SuccinctRingCoefficients +open Concrete RingPCSGame SuccinctRingWeight +set_option maxRecDepth 10000 +set_option maxHeartbeats 1200000 + +/-- The source uses the materialized descending-squaring ladder at every stage. -/ +def sourceExtend (f : E) (shift : Nat) (ps : List (Nat × E)) : List (Nat × E) := + let ladder := inverseFrobeniusLadder f shift + ps ++ ps.map (fun t => (t.1+shift,t.2*ladder[t.1+shift]!)) + +theorem sourceExtend_eq (f : E) (shift : Nat) (ps : List (Nat × E)) + (positive : 1 ≤ shift) (bound : ∀ t ∈ ps, t.1+shift < 64) : + sourceExtend f shift ps = extendCoefficients f shift ps := by + dsimp only [sourceExtend,extendCoefficients] + congr 1 + apply List.map_congr_left + intro t member + have hk := bound t member + have active : max shift 1 ≤ t.1+shift := by omega + have h := inverseFrobeniusLadder_get f shift ⟨t.1+shift,hk⟩ + have index : t.1+shift < (inverseFrobeniusLadder f shift).length := by + simpa only [inverseFrobeniusLadder_length] using hk + rw [getElem!_pos (inverseFrobeniusLadder f shift) (t.1+shift) index] + simpa only [active,↓reduceIte] using congrArg (fun power => (t.1+shift,t.2*power)) h + +def sourceNewCoefficients (f : Fin 6 → E) : List (Nat × E) := + (List.finRange 6).foldl (fun ps p => sourceExtend (f p) (2^(5-p.val)) ps) [(0,1)] + +theorem sourceNewCoefficients_eq (f : Fin 6 → E) : sourceNewCoefficients f = newCoefficients f := by + have foldEq (stages : List (E × Nat)) (ps : List (Nat × E)) (b : Nat) + (bound : ∀ t ∈ ps, t.1 ≤ b) + (budget : b + (stages.map Prod.snd).sum ≤ 63) + (positive : ∀ stage ∈ stages, 1 ≤ stage.2) : + stages.foldl (fun acc fs => sourceExtend fs.1 fs.2 acc) ps = + stages.foldl (fun acc fs => extendCoefficients fs.1 fs.2 acc) ps := by + induction stages generalizing ps b with + | nil => rfl + | cons fs stages ih => + have positiveHead := positive fs (by simp) + have positiveTail : ∀ stage ∈ stages, 1 ≤ stage.2 := + fun stage member => positive stage (by simp [member]) + simp only [List.map_cons,List.sum_cons] at budget + simp only [List.foldl_cons] + rw [sourceExtend_eq fs.1 fs.2 ps positiveHead (by intro t member; have := bound t member; omega)] + exact ih _ (b+fs.2) (extend_bound ps fs.1 fs.2 b bound) (by omega) positiveTail + let stages := (List.finRange 6).map (fun p => (f p,2^(5-p.val))) + have budget : 0 + (stages.map Prod.snd).sum ≤ 63 := by + change 0 + ((List.finRange 6).map (fun p => 2^(5-p.val))).sum ≤ 63 + decide +kernel + have positive : ∀ stage ∈ stages, 1 ≤ stage.2 := by + intro stage member + obtain ⟨p,_,rfl⟩ := List.mem_map.mp member + have positive : 0 < 2^(5-p.val) := by positivity + exact positive + have h := foldEq stages [(0,1)] 0 (by simp) budget positive + simpa only [stages,List.foldl_map,sourceNewCoefficients,newCoefficients] using h + +private theorem fill_size (ps : List (Nat × E)) (out : Array E) : + (ps.foldl (fun acc t => acc.set! t.1 t.2) out).size = out.size := by + induction ps generalizing out with + | nil => rfl + | cons t ps ih => simp only [List.foldl_cons,ih,Array.size_set!] + +private theorem fill_get (ps : List (Nat × E)) (target : Fin 64 → E) + (sound : ∀ t ∈ ps, ∀ k : Fin 64, t.1=k.val → t.2=target k) + (out : Array E) (size : out.size=64) (k : Fin 64) : + (ps.foldl (fun acc t => acc.set! t.1 t.2) out)[k.val]! = + if k.val ∈ ps.map Prod.fst then target k else out[k.val]! := by + induction ps generalizing out with + | nil => simp + | cons t ps ih => + have tailSound : ∀ a ∈ ps, ∀ k : Fin 64, a.1=k.val → a.2=target k := + fun a member => sound a (by simp [member]) + rw [List.foldl_cons,ih tailSound _ (by simpa only [Array.size_set!] using size)] + by_cases later : k.val ∈ ps.map Prod.fst + · simp [later] + · by_cases same : t.1=k.val + · have value := sound t (by simp) k same + have updated : (out.set! t.1 t.2)[k.val]! = target k := by + rw [same,Array.getElem!_set!_self _ _ _ (by rw [size]; exact k.isLt),value] + rw [updated] + simp [later,same] + · rw [Array.getElem!_set!_ne _ _ _ _ same] + simp [later,Ne.symm same] + +theorem coefficientArray_get (f : Fin 6 → E) (k : Fin 64) : + (coefficientArray f)[k.val]! = coefficients f k := by + have sound : ∀ t ∈ newCoefficients f, ∀ k : Fin 64, t.1=k.val → t.2=coefficients f k := by + intro t member k same + rw [newCoefficients_ofFn] at member + obtain ⟨i,rfl⟩ := List.mem_ofFn.mp member + exact congrArg (coefficients f) (Fin.ext same) + have present : k.val ∈ (newCoefficients f).map Prod.fst := by + rw [newCoefficients_keys,coefficientIndices_eq] + exact List.mem_ofFn.mpr ⟨reverseIndex.symm k,by simp⟩ + exact (fill_get (newCoefficients f) (coefficients f) sound (Array.replicate 64 1) + (by simp) k).trans (ite_eq_left present) + +theorem coefficientArray_size (f : Fin 6 → E) : (coefficientArray f).size=64 := by + rw [coefficientArray,fill_size] + rfl + +/-- Rust RingMap::new, including all six actual ladders and indexed writes. -/ +def sourceCoefficientArray (f : Fin 6 → E) : Array E := + (sourceNewCoefficients f).foldl (fun out term => out.set! term.1 term.2) (Array.replicate 64 1) + +theorem sourceCoefficientArray_get (f : Fin 6 → E) (k : Fin 64) : + (sourceCoefficientArray f)[k.val]! = coefficients f k := by + rw [sourceCoefficientArray,sourceNewCoefficients_eq] + exact coefficientArray_get f k + +theorem sourceCoefficientArray_size (f : Fin 6 → E) : (sourceCoefficientArray f).size=64 := by + rw [sourceCoefficientArray,sourceNewCoefficients_eq] + exact coefficientArray_size f + +theorem queryLadder_get (q : E) (k : Fin 64) : + (inverseFrobeniusLadder q 1)[k.val]! = inverseFrobenius q k.val := by + rw [getElem!_pos (inverseFrobeniusLadder q 1) k.val + (by simpa only [inverseFrobeniusLadder_length] using k.isLt)] + have h := inverseFrobeniusLadder_get q 1 k + by_cases zero : k.val=0 + · simpa [zero,inverseFrobenius] using h + · have active : max 1 1 ≤ k.val := by omega + simpa only [active,↓reduceIte] using h + +end Whir.SuccinctRingCoefficients diff --git a/verification/whir/Whir/SuccinctRingGroups.lean b/verification/whir/Whir/SuccinctRingGroups.lean new file mode 100644 index 000000000..9441a6400 --- /dev/null +++ b/verification/whir/Whir/SuccinctRingGroups.lean @@ -0,0 +1,289 @@ +import Whir.SuccinctRingCoefficients + +namespace Whir.SuccinctRingGroups +open Concrete RingPCSGame SuccinctRingWeight +open scoped BigOperators +set_option maxRecDepth 10000 +set_option maxHeartbeats 1200000 + +/-- One multiplication per coordinate and Frobenius slot. Retaining every +prefix is equivalent to the source's take slots, including duplicate lengths. -/ +def prefixScan (cs : Fin 64 → E) : List (E × E) → List (Fin 64 → E) + | [] => [cs] + | pair :: rest => cs :: prefixScan (fun k => cs k * (1+pair.1+inverseFrobenius pair.2 k.val)) rest + +theorem prefixScan_length (cs : Fin 64 → E) (pairs : List (E × E)) : + (prefixScan cs pairs).length = pairs.length+1 := by + induction pairs generalizing cs with + | nil => rfl + | cons pair rest ih => simp [prefixScan,ih] + +theorem prefixScan_get (cs : Fin 64 → E) (pairs : List (E × E)) (n : Nat) + (bound : n ≤ pairs.length) : + (prefixScan cs pairs)[n]'(by rw [prefixScan_length]; omega) = + fun k => cs k * ((pairs.take n).map (fun pair => 1+pair.1+inverseFrobenius pair.2 k.val)).prod := by + induction n generalizing cs pairs with + | zero => cases pairs <;> simp [prefixScan] + | succ n ih => + cases pairs with + | nil => simp at bound + | cons pair rest => + simp only [prefixScan,List.getElem_cons_succ,List.take_succ_cons,List.map_cons,List.prod_cons] + rw [ih _ rest (by simpa using bound)] + funext k + exact mul_assoc _ _ _ + +theorem prefixScan_lookup (cs : Fin 64 → E) (z q : List E) (n : Nat) + (hz : n ≤ z.length) (hq : n ≤ q.length) : + (prefixScan cs (z.zip q))[n]! = prefixTerm cs (z.take n) (q.take n) := by + have bound : n ≤ (z.zip q).length := by simp; omega + rw [getElem!_pos _ _ (by rw [prefixScan_length]; omega),prefixScan_get cs _ n bound] + have zipped : (z.zip q).take n = (z.take n).zip (q.take n) := by + clear hz hq bound + induction n generalizing z q with + | zero => simp + | succ n ih => cases z <;> cases q <;> simp [ih] + funext k + simp only [zipped,prefixTerm] + +/-- Actual source prefix compatibility, established by the insertion test. +No coverage or membership correctness premise is supplied by a caller. -/ +structure PrefixGroup {m : Nat} (family : Fin m → FamilyClaim) where + lead : List E + members : List (Fin m) + compatible : ∀ j ∈ members, (family j).point.toList = lead.take (family j).point.size + +def insertGroup {m : Nat} (family : Fin m → FamilyClaim) (j : Fin m) : + List (PrefixGroup family) → List (PrefixGroup family) + | [] => [⟨(family j).point.toList,[j],by + intro i member + have same : i=j := by simpa using member + subst i + simp⟩] + | g :: rest => + if fits : (family j).point.toList = g.lead.take (family j).point.size then + ⟨g.lead,g.members++[j],by + intro i member + rcases List.mem_append.mp member with old | fresh + · exact g.compatible i old + · have same : i=j := by simpa using fresh + subst i + exact fits⟩ :: rest + else g :: insertGroup family j rest + +/-- Longest first, as in PrefixGroup::of. Equal-length ties do not affect the +proved semantics or the original claim indices used for gamma powers. -/ +def prefixGroups {m : Nat} (family : Fin m → FamilyClaim) : List (PrefixGroup family) := + ((List.finRange m).mergeSort (fun i j => decide ((family j).point.size ≤ (family i).point.size))).foldl + (fun groups j => insertGroup family j groups) [] + +def memberSum {m : Nat} {family : Fin m → FamilyClaim} (weight : Fin m → E) + (groups : List (PrefixGroup family)) : E := + (groups.map (fun g => (g.members.map weight).sum)).sum + +theorem insertGroup_sum {m : Nat} (family : Fin m → FamilyClaim) (weight : Fin m → E) + (j : Fin m) (groups : List (PrefixGroup family)) : + memberSum weight (insertGroup family j groups) = weight j + memberSum weight groups := by + induction groups with + | nil => simp [insertGroup,memberSum] + | cons g rest ih => + simp only [insertGroup] + split + · simp only [memberSum,List.map_cons,List.sum_cons,List.map_append,List.sum_append, + List.map_nil,List.sum_nil,add_zero] + abel + · change (g.members.map weight).sum + memberSum weight (insertGroup family j rest) = _ + rw [ih] + simp only [memberSum,List.map_cons,List.sum_cons] + abel + +theorem prefixGroups_sum {m : Nat} (family : Fin m → FamilyClaim) (weight : Fin m → E) : + memberSum weight (prefixGroups family) = ∑ j, weight j := by + have foldSum (js : List (Fin m)) (groups : List (PrefixGroup family)) : + memberSum weight (js.foldl (fun groups j => insertGroup family j groups) groups) = + (js.map weight).sum + memberSum weight groups := by + induction js generalizing groups with + | nil => simp + | cons j js ih => + rw [List.foldl_cons,ih,insertGroup_sum] + simp only [List.map_cons,List.sum_cons] + abel + unfold prefixGroups + rw [foldSum] + simp only [memberSum,List.map_nil,List.sum_nil,add_zero] + rw [((List.mergeSort_perm (List.finRange m) + (fun i j => decide ((family j).point.size ≤ (family i).point.size))).map weight).sum_eq] + simp [List.finRange,List.sum_ofFn] + +def groupWeight {m : Nat} {family : Fin m → FamilyClaim} (cs : Fin 64 → E) + (gamma : E) (x : Array E) (group : PrefixGroup family) : E := + let cached := prefixScan cs (group.lead.zip x.toList) + (group.members.map (fun j => + SuccinctPointWeight.eqBitsAt ((family j).offset / 2^(family j).point.size) x + (family j).point.size (x.size-(family j).point.size) * + close (List.ofFn (fun k : Fin 64 => gamma^j.val * (cached[(family j).point.size]!) k)))).sum + +theorem take_query (x : Array E) (n : Nat) (bound : n ≤ x.size) : + x.toList.take n = List.ofFn (fun i : Fin n => x[i.val]!) := by + apply List.ext_getElem + · simp [Nat.min_eq_left bound] + · intro i hi hj + have hn : i < n := by simpa using hj + have hx : i < x.size := lt_of_lt_of_le hn bound + simp [getElem!_pos,hx] + +theorem groupWeight_eq {m : Nat} (family : Fin m → FamilyClaim) (cs : Fin 64 → E) + (gamma : E) (x : Array E) (shape : ∀ j, (family j).point.size ≤ x.size) + (group : PrefixGroup family) : + groupWeight cs gamma x group = + (group.members.map (fun j => claimWeightAt cs (gamma^j.val) (family j) x)).sum := by + unfold groupWeight + apply congrArg List.sum + apply List.map_congr_left + intro j member + have fits := group.compatible j member + have length := congrArg List.length fits + have hz : (family j).point.size ≤ group.lead.length := by + simp only [Array.length_toList,List.length_take] at length + omega + have hq : (family j).point.size ≤ x.toList.length := by simpa using shape j + rw [prefixScan_lookup cs _ _ _ hz hq,← fits,take_query x _ (shape j)] + rfl + +/-- Executable grouping covers every original claim exactly once in every +additive observation. Its shared-prefix cache then computes the same terms. -/ +def sourceRingWeightAt {m : Nat} (family : Fin m → FamilyClaim) (seed : Prefix) (x : Array E) : E := + let cs := SuccinctRingCoefficients.sourceCoefficientArray seed.2 + ((prefixGroups family).map (groupWeight (fun k => cs[k.val]!) seed.1 x)).sum + +theorem sourceRingWeightAt_eq {m : Nat} (family : Fin m → FamilyClaim) (seed : Prefix) + (x : Array E) (shape : ∀ j, (family j).point.size ≤ x.size) : + sourceRingWeightAt family seed x = ringWeightAt family seed x := by + unfold sourceRingWeightAt + have stored : (fun k : Fin 64 => (SuccinctRingCoefficients.sourceCoefficientArray seed.2)[k.val]!) = + coefficients seed.2 := funext (SuccinctRingCoefficients.sourceCoefficientArray_get seed.2) + dsimp only + rw [stored] + calc + _ = memberSum (fun j => claimWeightAt (coefficients seed.2) (seed.1^j.val) (family j) x) + (prefixGroups family) := by + unfold memberSum + apply congrArg List.sum + apply List.map_congr_left + intro group _ + exact groupWeight_eq family _ _ x shape group + _ = _ := prefixGroups_sum family _ + +/-- The source may add all terms of one region before a single close. -/ +theorem close_sum {m : Nat} (terms : Fin m → Fin 64 → E) : + close (List.ofFn (fun k => ∑ j, terms j k)) = + ∑ j, close (List.ofFn (terms j)) := by + simp only [close_ofFn,squareIter_eq,sum_pow_char_pow] + exact Finset.sum_comm + +/-- Per-region source accumulation and one close per region. The owner is the +literal original claim's region index, so every claim has exactly one owner. -/ +theorem region_closes {m r : Nat} (owner : Fin m → Fin r) (selector : Fin r → E) + (terms : Fin m → Fin 64 → E) : + (∑ region, selector region * close (List.ofFn (fun k => + ∑ j, if owner j=region then terms j k else 0))) = + ∑ j, selector (owner j) * close (List.ofFn (terms j)) := by + simp_rw [close_sum] + have selected (j : Fin m) (region : Fin r) : + close (List.ofFn (fun k => if owner j=region then terms j k else 0)) = + if owner j=region then close (List.ofFn (terms j)) else 0 := by + split_ifs + · rfl + · rw [close_ofFn] + simp [squareIter_eq] + simp_rw [selected] + simp only [Finset.mul_sum,mul_ite,mul_zero] + rw [Finset.sum_comm] + simp + +/-- The source query ladders, rather than inverse powers supplied by a caller. -/ +def sourcePrefixScan (cs : Fin 64 → E) : List (E × List E) → List (Fin 64 → E) + | [] => [cs] + | pair :: rest => cs :: sourcePrefixScan (fun k => cs k*(1+pair.1+pair.2[k.val]!)) rest + +theorem sourcePrefixScan_eq (cs : Fin 64 → E) (pairs : List (E × E)) : + sourcePrefixScan cs (pairs.map (fun pair => (pair.1,inverseFrobeniusLadder pair.2 1))) = + prefixScan cs pairs := by + induction pairs generalizing cs with + | nil => rfl + | cons pair pairs ih => + simp only [List.map_cons,sourcePrefixScan,prefixScan] + rw [show (fun k : Fin 64 => cs k*(1+pair.1+(inverseFrobeniusLadder pair.2 1)[k.val]!)) = + (fun k => cs k*(1+pair.1+inverseFrobenius pair.2 k.val)) by + funext k + rw [SuccinctRingCoefficients.queryLadder_get]] + rw [ih] + +def sourcePrefixTerms (cs : Fin 64 → E) (z q : List E) (lengths : List Nat) : + List (Fin 64 → E) := + let cached := sourcePrefixScan cs ((z.zip q).map (fun pair => (pair.1,inverseFrobeniusLadder pair.2 1))) + lengths.map (fun n => cached[n]!) + +theorem sourcePrefixTerms_eq (cs : Fin 64 → E) (z q : List E) (lengths : List Nat) + (bounds : ∀ n ∈ lengths, n ≤ z.length ∧ n ≤ q.length) : + sourcePrefixTerms cs z q lengths = prefixTerms cs z q lengths := by + simp only [sourcePrefixTerms,sourcePrefixScan_eq,prefixTerms] + apply List.map_congr_left + intro n member + exact prefixScan_lookup cs z q n (bounds n member).1 (bounds n member).2 + +def sourceGroupWeight {m : Nat} {family : Fin m → FamilyClaim} (cs : Fin 64 → E) + (gamma : E) (x : Array E) (ladders : List (List E)) (group : PrefixGroup family) : E := + let cached := sourcePrefixScan cs (group.lead.zip ladders) + (group.members.map (fun j => + SuccinctPointWeight.eqBitsAt ((family j).offset / 2^(family j).point.size) x + (family j).point.size (x.size-(family j).point.size) * + close (List.ofFn (fun k : Fin 64 => gamma^j.val * (cached[(family j).point.size]!) k)))).sum + +theorem sourceGroupWeight_eq {m : Nat} {family : Fin m → FamilyClaim} + (cs : Fin 64 → E) (gamma : E) (x : Array E) (group : PrefixGroup family) : + sourceGroupWeight cs gamma x (x.toList.map (fun q => inverseFrobeniusLadder q 1)) group = + groupWeight cs gamma x group := by + have zipped (z q : List E) : + z.zip (q.map (fun q => inverseFrobeniusLadder q 1)) = + (z.zip q).map (fun pair => (pair.1,inverseFrobeniusLadder pair.2 1)) := by + induction z generalizing q with + | nil => simp + | cons z zs ih => cases q <;> simp [ih] + simp only [sourceGroupWeight,zipped,sourcePrefixScan_eq,groupWeight] + +/-- Coefficient construction and all query ladders are materialized once, +then each longest prefix is scanned once for every member of its group. -/ +def sourceSharedRingWeightAt {m : Nat} (family : Fin m → FamilyClaim) + (seed : Prefix) (x : Array E) : E := + let cs := SuccinctRingCoefficients.sourceCoefficientArray seed.2 + let ladders := x.toList.map (fun q => inverseFrobeniusLadder q 1) + ((prefixGroups family).map (sourceGroupWeight (fun k => cs[k.val]!) seed.1 x ladders)).sum + +theorem sourceSharedRingWeightAt_eq {m : Nat} (family : Fin m → FamilyClaim) + (seed : Prefix) (x : Array E) : + sourceSharedRingWeightAt family seed x = sourceRingWeightAt family seed x := by + unfold sourceSharedRingWeightAt sourceRingWeightAt + apply congrArg List.sum + apply List.map_congr_left + intro group _ + exact sourceGroupWeight_eq _ _ x group + +def sourceStackWeightAt {m : Nat} (family : Fin m → FamilyClaim) (points : Array PointClaim) + (seed : Prefix) (lambda : E) (x : Array E) : E := + sourceSharedRingWeightAt family seed x + + ∑ i : Fin points.size, lambda^(i.val+1)*SuccinctPointWeight.eqAt points[i] x + +theorem sourceStackWeightAt_eq_batch_mle {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (seed : Prefix) (lambda : E) (x : Array E) + (familyShape : FamilyShape x.size family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape x.size points[i]) : + sourceStackWeightAt family points seed lambda x = + Concrete.mle (CausalGame.batchClaims (2^x.size) + (transformedClaims (2^x.size) family points seed) lambda).weight x := by + unfold sourceStackWeightAt + rw [sourceSharedRingWeightAt_eq] + rw [sourceRingWeightAt_eq family seed x (fun j => (familyShape j).1)] + exact stackWeightAt_eq_batch_mle family points seed lambda x familyShape pointShapes + +end Whir.SuccinctRingGroups diff --git a/verification/whir/Whir/SuccinctRingWeight.lean b/verification/whir/Whir/SuccinctRingWeight.lean new file mode 100644 index 000000000..d44fcefc4 --- /dev/null +++ b/verification/whir/Whir/SuccinctRingWeight.lean @@ -0,0 +1,435 @@ +import Whir.RingPCSGame +import Whir.RingMapSoundness +import Whir.SuccinctPointWeight + +namespace Whir.SuccinctRingWeight +open Concrete RingPCSGame +open scoped BigOperators +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 + +/-- Repeated squaring, with the exact 192-bit extension-field period. -/ +def inverseFrobenius (v : E) (k : Nat) : E := + if k = 0 then v else squareIter v (192 - k) + +theorem squareIter_add (v : E) (a b : Nat) : + squareIter (squareIter v a) b = squareIter v (a + b) := by + simp only [squareIter_eq, ← pow_mul, ← Nat.pow_add] + +theorem squareIter_period (v : E) : squareIter v 192 = v := by + rw [squareIter_eq, ← FieldModel.card_E] + exact FiniteField.pow_card v + +theorem inverseFrobenius_cancel (v : E) (k : Nat) (hk : k ≤ 192) : + squareIter (inverseFrobenius v k) k = v := by + unfold inverseFrobenius + split_ifs with h + · subst k; rfl + · rw [squareIter_add, Nat.sub_add_cancel hk, squareIter_period] + +/-- The source initializes every slot with v, and overwrites slots 63 down to +max(lowest,1), starting at v^(2^128). This recursive loop keeps that order. -/ +def ladderLoop (v : E) (lowest : Nat) : Nat → E → List E + | 0, _ => [] + | n + 1, power => + if lowest ≤ n then + let next := power * power + ladderLoop v lowest n next ++ [next] + else List.replicate (n + 1) v + +def inverseFrobeniusLadder (v : E) (lowest : Nat) : List E := + ladderLoop v (max lowest 1) 64 (squareIter v 128) + +/-- Linearized Horner closure; unlike a field-linear dot product its squarings +also apply to the claim's gamma scaling. -/ +def close : List E → E + | [] => 0 + | t :: ts => t + squareIter (close ts) 1 + +theorem close_eq (ts : List E) : + close ts = (ts.zipIdx.map fun (t, k) => squareIter t k).sum := by + induction ts with + | nil => rfl + | cons t ts ih => + simp only [close, List.zipIdx_cons', List.map_cons, List.sum_cons, ih] + congr 1 + simp only [squareIter_eq, List.map_map, list_sum_pow_char_pow] + apply congrArg List.sum + apply List.map_congr_left + intro ⟨a,k⟩ _ + simp only [Function.comp_apply, Prod.map, id_eq, Nat.pow_add, pow_mul, pow_one] + +def prefixTerm (coefficients : Fin 64 → E) (z q : List E) (k : Fin 64) : E := + coefficients k * ((z.zip q).map fun (zn, qn) => + 1 + zn + inverseFrobenius qn k.val).prod + +/-- Unshared prefix evaluator, the semantic value of each source take slot. -/ +def prefixTerms (coefficients : Fin 64 → E) (z q : List E) + (lengths : List Nat) : List (Fin 64 → E) := + lengths.map fun n => prefixTerm coefficients (z.take n) (q.take n) + +/-- Six-stage coefficient prefix extension, in the source append order. -/ +def extendCoefficients (f : E) (shift : Nat) (prefixes : List (Nat × E)) : List (Nat × E) := + prefixes ++ prefixes.map fun (k, c) => + (k + shift, c * inverseFrobenius f (k + shift)) + +def newCoefficients (challenges : Fin 6 → E) : List (Nat × E) := + (List.finRange 6).foldl (fun ps p => + extendCoefficients (challenges p) (2 ^ (5 - p.val)) ps) [(0, 1)] + +def evaluateCoefficients (ps : List (Nat × E)) (a : E) : E := + (ps.map fun (k, c) => squareIter (c * a) k).sum + +theorem evaluate_extend (ps : List (Nat × E)) (f a : E) (s : Nat) + (bound : ∀ t ∈ ps, t.1 + s ≤ 192) : + evaluateCoefficients (extendCoefficients f s ps) a = + mapStage f s (evaluateCoefficients ps a) := by + simp only [evaluateCoefficients, extendCoefficients, List.map_append, + List.sum_append, List.map_map, mapStage, AddMonoidHom.coe_mk, ZeroHom.coe_mk] + congr 1 + simp only [squareIter_eq, list_sum_pow_char_pow, List.map_map] + rw [← List.sum_map_mul_left] + apply congrArg List.sum + apply List.map_congr_left + intro t ht + obtain ⟨k, c⟩ := t + have hc := inverseFrobenius_cancel f (k + s) (bound (k, c) ht) + simp only [squareIter_eq] at hc + simp only [Function.comp_apply,mul_pow] + rw [hc] + simp only [Nat.pow_add,pow_mul] + ring + +theorem extend_bound (ps : List (Nat × E)) (f : E) (s b : Nat) + (bound : ∀ t ∈ ps, t.1 ≤ b) : + ∀ t ∈ extendCoefficients f s ps, t.1 ≤ b + s := by + intro t ht + simp only [extendCoefficients, List.mem_append, List.mem_map] at ht + rcases ht with ht | ⟨u, hu, rfl⟩ + · exact (bound t ht).trans (Nat.le_add_right b s) + · exact Nat.add_le_add_right (bound u hu) s + +private theorem fold_evaluate (stages : List (E × Nat)) (ps : List (Nat × E)) + (a : E) (b : Nat) (bound : ∀ t ∈ ps, t.1 ≤ b) + (budget : b + (stages.map Prod.snd).sum ≤ 192) : + evaluateCoefficients + (stages.foldl (fun acc fs => extendCoefficients fs.1 fs.2 acc) ps) a = + stages.foldl (fun acc fs => mapStage fs.1 fs.2 acc) (evaluateCoefficients ps a) := by + induction stages generalizing ps b with + | nil => rfl + | cons fs stages ih => + simp only [List.map_cons, List.sum_cons] at budget + simp only [List.foldl_cons] + rw [ih _ (b + fs.2) (extend_bound ps fs.1 fs.2 b bound) (by omega)] + rw [evaluate_extend ps fs.1 a fs.2 (by intro t ht; have := bound t ht; omega)] + +theorem newCoefficients_evaluate (f : Fin 6 → E) (a : E) : + evaluateCoefficients (newCoefficients f) a = executableMap f a := by + let stages := (List.finRange 6).map fun p => (f p, 2 ^ (5 - p.val)) + have h := fold_evaluate stages [(0, 1)] a 0 (by simp) + (by + change 0 + ((List.finRange 6).map (fun p => 2 ^ (5-p.val))).sum ≤ 192 + decide +kernel) + simp only [stages, List.foldl_map, evaluateCoefficients, List.map_cons, + List.map_nil, List.sum_cons, List.sum_nil, squareIter, one_mul, add_zero] at h + rw [executableMap_eq, RingSwitch.composedMap, RingMapSoundness.fold_apply] + simpa only [newCoefficients,evaluateCoefficients,AddMonoidHom.id_apply,mapStage_eq] using h + +theorem ladderLoop_eq (v : E) (lowest n : Nat) (power : E) : + ladderLoop v lowest n power = + (List.range n).map (fun k => if lowest ≤ k then squareIter power (n-k) else v) := by + induction n generalizing power with + | zero => rfl + | succ n ih => + by_cases reaches : lowest ≤ n + · simp only [ladderLoop,reaches,↓reduceIte] + rw [ih,List.range_succ,List.map_append,List.map_singleton] + have last : (if lowest ≤ n then squareIter power (n+1-n) else v) = power * power := by + simp [reaches,squareIter] + rw [last] + congr 1 + apply List.map_congr_left + intro k member + have hk : k < n := List.mem_range.mp member + by_cases active : lowest ≤ k + · simp only [active,↓reduceIte] + change squareIter (squareIter power 1) (n-k) = squareIter power (n+1-k) + rw [squareIter_add] + congr 1 + omega + · simp only [active,↓reduceIte] + · rw [ladderLoop,ite_eq_right reaches] + calc + List.replicate (n+1) v = (List.range (n+1)).map (fun _ => v) := by simp + _ = _ := by + apply List.map_congr_left + intro k member + have hk := List.mem_range.mp member + have inactive : ¬ lowest ≤ k := by omega + simp [inactive] + +theorem inverseFrobeniusLadder_length (v : E) (lowest : Nat) : + (inverseFrobeniusLadder v lowest).length = 64 := by + simp [inverseFrobeniusLadder,ladderLoop_eq] + +theorem inverseFrobeniusLadder_get (v : E) (lowest : Nat) (k : Fin 64) : + (inverseFrobeniusLadder v lowest)[k.val]'(by + simpa only [inverseFrobeniusLadder_length] using k.isLt) = + if max lowest 1 ≤ k.val then inverseFrobenius v k.val else v := by + simp only [inverseFrobeniusLadder,ladderLoop_eq,List.getElem_map,List.getElem_range] + split_ifs with active + · have positive : k.val ≠ 0 := by omega + rw [squareIter_add,inverseFrobenius,ite_eq_right positive] + congr 1 + omega + · rfl + +/-- The source stores each generated term at its Frobenius index. -/ +def coefficientArray (f : Fin 6 → E) : Array E := + (newCoefficients f).foldl (fun out term => out.set! term.1 term.2) (Array.replicate 64 1) + + +def reverseIndexFn (k : Fin 64) : Fin 64 := + ⟨k.val % 2 * 32 + k.val / 2 % 2 * 16 + k.val / 4 % 2 * 8 + + k.val / 8 % 2 * 4 + k.val / 16 % 2 * 2 + k.val / 32, by omega⟩ + +theorem reverseIndex_involutive : Function.Involutive reverseIndexFn := by + change ∀ k : Fin 64, reverseIndexFn (reverseIndexFn k) = k + decide +kernel + +def reverseIndex : Fin 64 ≃ Fin 64 where + toFun := reverseIndexFn + invFun := reverseIndexFn + left_inv := reverseIndex_involutive + right_inv := reverseIndex_involutive +def coefficientIndices : List Nat := + (List.finRange 6).foldl (fun ps p => ps ++ ps.map (fun k => k + 2 ^ (5-p.val))) [0] + +theorem coefficientIndices_eq : + coefficientIndices = List.ofFn (fun i : Fin 64 => (reverseIndex i).val) := by decide +kernel + +theorem newCoefficients_keys (f : Fin 6 → E) : + (newCoefficients f).map Prod.fst = coefficientIndices := by + have foldKeys (stages : List (Fin 6)) (ps : List (Nat × E)) : + (stages.foldl (fun acc p => extendCoefficients (f p) (2^(5-p.val)) acc) ps).map Prod.fst = + stages.foldl (fun acc p => acc ++ acc.map (fun k => k + 2^(5-p.val))) (ps.map Prod.fst) := by + induction stages generalizing ps with + | nil => rfl + | cons p stages ih => + simp only [List.foldl_cons] + rw [ih] + simp only [extendCoefficients,List.map_append,List.map_map] + rfl + exact foldKeys _ _ + +theorem newCoefficients_length (f : Fin 6 → E) : (newCoefficients f).length = 64 := by + have h := congrArg List.length (newCoefficients_keys f) + simpa only [List.length_map,coefficientIndices_eq,List.length_ofFn] using h + +/-- Bit reversal is the generated append order, not a different coefficient map. -/ +def coefficients (f : Fin 6 → E) (k : Fin 64) : E := + ((newCoefficients f)[(reverseIndex k).val]'(by + simpa only [newCoefficients_length] using (reverseIndex k).isLt)).2 + +theorem newCoefficients_key (f : Fin 6 → E) (i : Fin 64) : + ((newCoefficients f)[i.val]'(by simpa only [newCoefficients_length] using i.isLt)).1 = + (reverseIndex i).val := by + have h := congrArg (fun xs : List Nat => xs[i.val]!) (newCoefficients_keys f) + have hi : i.val < (newCoefficients f).length := by + simpa only [newCoefficients_length] using i.isLt + simpa only [coefficientIndices_eq,getElem!_pos, List.length_map, + List.length_ofFn,List.getElem_map,List.getElem_ofFn,hi,i.isLt] using h + + +theorem newCoefficients_ofFn (f : Fin 6 → E) : + newCoefficients f = + List.ofFn (fun i : Fin 64 => ((reverseIndex i).val,coefficients f (reverseIndex i))) := by + apply List.ext_getElem + · simp only [newCoefficients_length,List.length_ofFn] + · intro i hi _ + have bound : i < 64 := by simpa only [newCoefficients_length] using hi + simp only [List.getElem_ofFn] + apply Prod.ext + · exact newCoefficients_key f ⟨i,bound⟩ + · have rev (k : Fin 64) : reverseIndex (reverseIndex k) = k := reverseIndex_involutive k + simp only [coefficients,rev] + +theorem coefficients_evaluate (f : Fin 6 → E) (a : E) : + (∑ k : Fin 64, squareIter (coefficients f k * a) k.val) = executableMap f a := by + rw [← newCoefficients_evaluate,newCoefficients_ofFn,evaluateCoefficients] + simp only [List.map_ofFn,List.sum_ofFn] + exact (Equiv.sum_comp reverseIndex (fun k => squareIter (coefficients f k * a) k.val)).symm + +theorem squareIter_eqWeight {n : Nat} (z : Fin n → E) (u : Cube n) (k : Nat) : + squareIter (Whir.eqWeight z u) k = Whir.eqWeight (fun i => squareIter (z i) k) u := by + simp only [squareIter_eq,Whir.eqWeight,← Finset.prod_pow] + apply Finset.prod_congr rfl + intro i _ + split_ifs <;> simp [sub_pow_char_pow] + +theorem squareIter_prefix {n : Nat} (a : E) (z q : Fin n → E) (k : Nat) (hk : k ≤ 192) : + squareIter (a * ∏ i, (1 + z i + inverseFrobenius (q i) k)) k = + squareIter a k * ∏ i, (1 + squareIter (z i) k + q i) := by + have cancel (i : Fin n) := inverseFrobenius_cancel (q i) k hk + simp only [squareIter_eq] at cancel ⊢ + simp only [mul_pow,← Finset.prod_pow,add_pow_char_pow,one_pow,cancel] + +theorem mle_square_eqWeight {n : Nat} (a : E) (z q : Fin n → E) (k : Nat) (hk : k ≤ 192) : + Whir.mle (fun u => squareIter (a * Whir.eqWeight z u) k) q = + squareIter (a * ∏ i, (1 + z i + inverseFrobenius (q i) k)) k := by + rw [squareIter_prefix a z q k hk] + simp only [Whir.mle,innerProduct,squareIter_eq,mul_pow] + have eqw (u : Cube n) := squareIter_eqWeight z u k + simp only [squareIter_eq] at eqw + simp_rw [eqw] + have value := SuccinctPointWeight.mle_eqWeight (fun i => (z i) ^ (2^k)) q + change (∑ u, Whir.eqWeight q u * (a ^ (2^k) * + Whir.eqWeight (fun i => (z i) ^ (2^k)) u)) = _ + rw [show (∑ u, Whir.eqWeight q u * (a ^ (2^k) * + Whir.eqWeight (fun i => (z i) ^ (2^k)) u)) = + a ^ (2^k) * Whir.mle (Whir.eqWeight (fun i => (z i) ^ (2^k))) q by + simp only [Whir.mle,innerProduct,Finset.mul_sum] + apply Finset.sum_congr rfl + intro u _ + ring] + rw [value] + +theorem prefixTerm_ofFn {n : Nat} (cs : Fin 64 → E) (z q : Fin n → E) (k : Fin 64) : + prefixTerm cs (List.ofFn z) (List.ofFn q) k = + cs k * ∏ i, (1 + z i + inverseFrobenius (q i) k.val) := by + have zipped : (List.ofFn z).zip (List.ofFn q) = List.ofFn (fun i => (z i,q i)) := by + apply List.ext_getElem <;> simp + simp only [prefixTerm,zipped,List.map_ofFn,List.prod_ofFn,Function.comp_apply] + +/-- Every gamma power remains inside the Frobenius closure. -/ +theorem map_eqWeight_mle {n : Nat} (f : Fin 6 → E) (gamma : E) (z q : Fin n → E) : + Whir.mle (fun u => executableMap f (gamma * Whir.eqWeight z u)) q = + ∑ k : Fin 64, squareIter + (gamma * prefixTerm (coefficients f) (List.ofFn z) (List.ofFn q) k) k.val := by + simp_rw [← coefficients_evaluate] + simp only [Whir.mle,innerProduct,Finset.mul_sum] + rw [Finset.sum_comm] + apply Finset.sum_congr rfl + intro k _ + have h := mle_square_eqWeight (coefficients f k * gamma) z q k.val (by omega) + rw [prefixTerm_ofFn] + simpa only [Whir.mle,innerProduct,mul_assoc,mul_left_comm,mul_comm] using h + +theorem ring_eqWeight_cube (point : Array E) (u : Cube point.size) : + RingPCSGame.eqWeight point (ExecutableOOD.cubeIndex u) = Whir.eqWeight (fun i => point[i]) u := by + simp only [RingPCSGame.eqWeight,Whir.eqWeight,SuccinctPointWeight.cubeIndex_testBit, + CharTwo.sub_eq_add] + +theorem map_region_low_mle (f : Fin 6 → E) (gamma : E) (point : Array E) + (q : Fin point.size → E) : + SuccinctPointWeight.natMle point.size + (fun v => executableMap f (gamma * RingPCSGame.eqWeight point v)) q = + ∑ k : Fin 64, squareIter + (gamma * prefixTerm (coefficients f) point.toList (List.ofFn q) k) k.val := by + unfold SuccinctPointWeight.natMle + simp_rw [ring_eqWeight_cube] + have pointList : point.toList = List.ofFn (fun i : Fin point.size => point[i]) := by + apply List.ext_getElem <;> simp + rw [pointList] + exact map_eqWeight_mle f gamma _ q + +theorem close_ofFn {n : Nat} (terms : Fin n → E) : + close (List.ofFn terms) = ∑ k : Fin n, squareIter (terms k) k.val := by + rw [close_eq] + have zipped : (List.ofFn terms).zipIdx = List.ofFn (fun i => (terms i,i.val)) := by + apply List.ext_getElem <;> simp + simp only [zipped,List.map_ofFn,List.sum_ofFn,Function.comp_apply] + +def claimWeightAt (cs : Fin 64 → E) (gamma : E) (claim : FamilyClaim) (x : Array E) : E := + SuccinctPointWeight.eqBitsAt (claim.offset / 2^claim.point.size) x + claim.point.size (x.size-claim.point.size) * + close (List.ofFn (fun k : Fin 64 => gamma * + prefixTerm cs claim.point.toList (List.ofFn (fun i : Fin claim.point.size => x[i.val]!)) k)) + +def FamilyShape (n : Nat) {m : Nat} (family : Fin m → FamilyClaim) : Prop := + ∀ j, (family j).point.size ≤ n ∧ + (family j).offset % 2^(family j).point.size = 0 ∧ + (family j).offset + 2^(family j).point.size ≤ 2^n + +theorem mapped_region (f : Fin 6 → E) (gamma : E) (claim : FamilyClaim) : + (fun v => executableMap f (gamma * regionWeight claim.offset claim.point v)) = + SuccinctPointWeight.region claim.offset claim.point.size + (fun v => executableMap f (gamma * RingPCSGame.eqWeight claim.point v)) := by + funext v + simp only [regionWeight,SuccinctPointWeight.region] + split_ifs <;> simp + +theorem claimWeightAt_split (f : Fin 6 → E) (gamma : E) (claim : FamilyClaim) + {h : Nat} (lo : Fin claim.point.size → E) (hi : Fin h → E) + (aligned : claim.offset % 2^claim.point.size = 0) + (bounded : claim.offset + 2^claim.point.size ≤ 2^(claim.point.size+h)) : + claimWeightAt (coefficients f) gamma claim (Array.ofFn (Fin.addCases lo hi)) = + SuccinctPointWeight.natMle (claim.point.size+h) + (fun v => executableMap f (gamma * regionWeight claim.offset claim.point v)) + (Fin.addCases lo hi) := by + rw [mapped_region,SuccinctPointWeight.region_mle _ _ _ _ aligned bounded, + map_region_low_mle] + simp only [claimWeightAt,Array.size_ofFn,Nat.add_sub_cancel_left] + simp only [SuccinctPointWeight.eqBitsAt,SuccinctPointWeight.array_split_right, + SuccinctPointWeight.array_split_left,close_ofFn,SuccinctPointWeight.eqBits,CharTwo.sub_eq_add] + exact mul_comm _ _ + +theorem claimWeightAt_eq_natMle (n : Nat) (f : Fin 6 → E) (gamma : E) (claim : FamilyClaim) + (x : Fin n → E) (dimension : claim.point.size ≤ n) + (aligned : claim.offset % 2^claim.point.size = 0) + (bounded : claim.offset + 2^claim.point.size ≤ 2^n) : + claimWeightAt (coefficients f) gamma claim (Array.ofFn x) = + SuccinctPointWeight.natMle n + (fun v => executableMap f (gamma * regionWeight claim.offset claim.point v)) x := by + obtain ⟨h,rfl⟩ := Nat.exists_eq_add_of_le dimension + have split : x = Fin.addCases (fun i => x (Fin.castAdd h i)) + (fun i => x (Fin.natAdd claim.point.size i)) := by + ext i + refine Fin.addCases (fun j => ?_) (fun j => ?_) i <;> simp + rw [split] + exact claimWeightAt_split _ _ _ _ _ aligned bounded + +def ringWeightAt {m : Nat} (family : Fin m → FamilyClaim) (seed : Prefix) (x : Array E) : E := + ∑ j, claimWeightAt (coefficients seed.2) (seed.1 ^ j.val) (family j) x + +theorem ringWeightAt_eq_natMle {m n : Nat} (family : Fin m → FamilyClaim) (seed : Prefix) + (x : Fin n → E) (shape : FamilyShape n family) : + ringWeightAt family seed (Array.ofFn x) = SuccinctPointWeight.natMle n (transparentWeight family seed) x := by + unfold ringWeightAt + simp_rw [claimWeightAt_eq_natMle n _ _ _ x (shape _).1 (shape _).2.1 (shape _).2.2] + simp only [SuccinctPointWeight.natMle,transparentWeight,Whir.mle,innerProduct,Finset.mul_sum] + exact Finset.sum_comm + +theorem ringWeightAt_eq_mle {m : Nat} (family : Fin m → FamilyClaim) (seed : Prefix) + (x : Array E) (shape : FamilyShape x.size family) : + ringWeightAt family seed x = Concrete.mle (familyPublic (2^x.size) family seed).weight x := by + have h := ringWeightAt_eq_natMle family seed (fun i => x[i]) shape + rw [← SuccinctPointWeight.mle_tab] at h + have copied : Array.ofFn (fun i : Fin x.size => x[i]) = x := by + apply Array.ext <;> simp + rw [copied] at h + exact h + +def stackWeightAt {m : Nat} (family : Fin m → FamilyClaim) (points : Array PointClaim) + (seed : Prefix) (lambda : E) (x : Array E) : E := + ringWeightAt family seed x + + ∑ i : Fin points.size, lambda^(i.val+1) * SuccinctPointWeight.eqAt points[i] x + +/-- The original source terminal caller formula, including family power zero +and every subsequent point power, equals the actual dense initial batch MLE. -/ +theorem stackWeightAt_eq_batch_mle {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (seed : Prefix) (lambda : E) (x : Array E) + (familyShape : FamilyShape x.size family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape x.size points[i]) : + stackWeightAt family points seed lambda x = + Concrete.mle (CausalGame.batchClaims (2^x.size) + (transformedClaims (2^x.size) family points seed) lambda).weight x := by + rw [SuccinctPointWeight.mle_transformedClaims] + unfold stackWeightAt + rw [ringWeightAt_eq_mle family seed x familyShape] + congr 1 + apply Finset.sum_congr rfl + intro i _ + rw [SuccinctPointWeight.eqAt_eq_mle _ x (pointShapes i)] + +end Whir.SuccinctRingWeight diff --git a/verification/whir/Whir/TapeValidity.lean b/verification/whir/Whir/TapeValidity.lean new file mode 100644 index 000000000..9d7a0161b --- /dev/null +++ b/verification/whir/Whir/TapeValidity.lean @@ -0,0 +1,165 @@ +import Whir.CausalGame +import Whir.SamplingRefinement + +/-! Every typed field tape is accepted by the concrete challenge-shape validator. +The prefix-sum invariant connects both mutable dimension loops to `remaining`; +there is no rejection or conditioning on sampled field values. -/ +namespace Whir.TapeValidity +open Concrete Protocol CausalGame + +private def before (c : Config) (i : Nat) : Nat := + c.logN - (c.folds.toList.take i).sum + +private theorem before_step (c : Config) (i : Nat) (hi : i < c.folds.size) : + before c i - c.folds[i]! = before c (i + 1) := by + simp [before, List.take_add_one, getElem?_pos, getElem!_pos, hi, Nat.sub_sub] + +private def configStep (c : Config) (i : Nat) (s : Option Bool × Nat) : + Id (ForInStep (Option Bool × Nat)) := do + let n := s.2 + if c.folds[i]! == 0 || c.folds[i]! >= n || c.rates[i]! == 0 || c.queries[i]! == 0 then + return .done (some false, n) + let n := n - c.folds[i]! + if n + c.rates[i]! >= 64 then return .done (some false, n) + return .yield (none, n) + +private theorem config_loop_bounds (c : Config) (len start : Nat) + (hr : start + len ≤ c.folds.size) + (h : ((forIn (List.range' start len) (none, before c start) (configStep c)).run.1).getD true = true) : + ∀ i, start ≤ i → i < start + len → + 1 ≤ remaining c i + c.rates[i]! ∧ remaining c i + c.rates[i]! ≤ 64 := by + induction len generalizing start with + | zero => intro i hlo hhi; omega + | succ len ih => + have hi : start < c.folds.size := by omega + simp only [List.range'_succ, List.forIn_cons, configStep] at h + split at h + · simp at h + · rename_i hg + split at h + · simp at h + · rename_i hd + have hstep := before_step c start hi + simp only [pure_bind] at h + rw [hstep] at h + intro i hlo hhi + by_cases he : i = start + · subst i + simp only [Bool.or_eq_true, beq_iff_eq, decide_eq_true_eq, not_or] at hg + change 1 ≤ before c (start + 1) + c.rates[start]! ∧ + before c (start + 1) + c.rates[start]! ≤ 64 + rw [← hstep] + omega + · exact ih (start + 1) (by omega) h i (by omega) (by omega) + +/-- Actual `Config.valid` certifies all query depths used by the typed tape. -/ +theorem config_query_depth (c : Config) (hc : c.valid = true) + (i : Nat) (hi : i < c.folds.size) : + 1 ≤ remaining c i + c.rates[i]! ∧ remaining c i + c.rates[i]! ≤ 64 := by + unfold Config.valid at hc + dsimp only [Id.run] at hc + split at hc + · simp at hc + · simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one] at hc + have hloop : ((forIn (List.range' 0 c.folds.size) (none, before c 0) + (configStep c)).run.1).getD true = true := by + have hz : before c 0 = c.logN := by simp [before] + rw [hz] + cases he : (forIn (List.range' 0 c.folds.size) (none, c.logN) (configStep c)).run.1 with + | none => simp + | some b => + unfold configStep at he + dsimp only [Id.run, Bind.bind, Pure.pure] at he hc + rw [he] at hc + exact hc + exact config_loop_bounds c c.folds.size 0 (by omega) hloop i (by omega) (by omega) + +/-- Typed levels carry exactly the folds, OOD points and squeeze words requested. -/ +theorem level_shapes (c : Config) (tape : Tape c) (i : Nat) (hi : i < c.folds.size) : + let l := (challenges c tape).levels[i]! + l.folds.size = c.folds[i]! ∧ l.oodPoints.size = oodCount c i ∧ + (∀ p ∈ l.oodPoints, p.size = remaining c i) ∧ + l.querySqueezes.size = queryChunks c i := by + simp [challenges, getElem!_pos, hi] + +/-- Every typed level's sampler succeeds, without examining or restricting its E values. -/ +theorem queries_succeed (c : Config) (hc : c.valid = true) (tape : Tape c) + (i : Nat) (hi : i < c.folds.size) : + (deriveQueries (remaining c i + c.rates[i]!) c.queries[i]! + (challenges c tape).levels[i]!.querySqueezes).isNone = false := by + have hd := config_query_depth c hc i hi + have hs := (level_shapes c tape i hi).2.2.2 + rw [SamplingRefinement.deriveQueries_eq _ _ _ hd.1 hd.2 (by + simpa [queryChunks] using hs)] + rfl + +private def challengeStep (c : Config) (ch : Challenges) (i : Nat) + (s : Option Bool × Nat) : Id (ForInStep (Option Bool × Nat)) := do + let n := s.2 - c.folds[i]! + let l := ch.levels[i]! + let count := if i + 1 < c.folds.size then c.oodCounts[i + 1]! else 0 + if l.folds.size != c.folds[i]! || l.oodPoints.size != count then + return .done (some false, n) + if !(l.oodPoints.all fun p => p.size == n) then return .done (some false, n) + if (deriveQueries (n + c.rates[i]!) c.queries[i]! l.querySqueezes).isNone then + return .done (some false, n) + return .yield (none, n) + +private theorem challenge_step (c : Config) (hc : c.valid = true) (tape : Tape c) + (i : Nat) (hi : i < c.folds.size) : + challengeStep c (challenges c tape) i (none, before c i) = + pure (.yield (none, before c (i + 1))) := by + have hs := level_shapes c tape i hi + have hq := queries_succeed c hc tape i hi + unfold challengeStep + dsimp only + rw [before_step c i hi] + change (if _ then _ else if _ then _ else if _ then _ else _) = _ + have ha : ((challenges c tape).levels[i]!.oodPoints.all + fun p => p.size == before c (i + 1)) = true := by + apply Array.all_eq_true.mpr + intro j hj + exact beq_iff_eq.mpr (hs.2.2.1 _ (Array.getElem_mem hj)) + have hb : ((challenges c tape).levels[i]!.folds.size != c.folds[i]! || + (challenges c tape).levels[i]!.oodPoints.size != + if i + 1 < c.folds.size then c.oodCounts[i + 1]! else 0) = false := by + simp [hs.1, hs.2.1, oodCount] + simp only [hb, ha, Bool.not_true, Bool.false_eq_true, ↓reduceIte] + simp only [show before c (i + 1) = remaining c i from rfl, hq, + Bool.false_eq_true, ↓reduceIte] + +private theorem challenge_loop (c : Config) (hc : c.valid = true) (tape : Tape c) + (len start : Nat) (hr : start + len ≤ c.folds.size) : + forIn (List.range' start len) (none, before c start) + (challengeStep c (challenges c tape)) = + pure (none, before c (start + len)) := by + induction len generalizing start with + | zero => simp + | succ len ih => + rw [List.range'_succ, List.forIn_cons, challenge_step c hc tape start (by omega)] + simp only [pure_bind] + simpa [Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using + ih (start + 1) (by omega) + +/-- All raw typed tapes satisfy the actual imperative challenge validator. +This is universal over field values, not a success-conditioned distribution. -/ +theorem challenges_valid (c : Config) (hc : c.valid = true) (tape : Tape c) : + (challenges c tape).valid c = true := by + have hz : before c 0 = c.logN := by simp [before] + have hl := challenge_loop c hc tape c.folds.size 0 (by omega) + rw [hz] at hl + unfold challengeStep at hl + have hsize : (challenges c tape).levels.size = c.folds.size := by simp [challenges] + unfold Challenges.valid + simp only [hc, Bool.not_true, hsize, bne_self_eq_false, + Bool.false_or, Bool.false_eq_true, ↓reduceIte, + Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one] + dsimp only [Id.run, Bind.bind, Pure.pure] at hl ⊢ + rw [hl] + have ht : c.folds.toList.take c.folds.size = c.folds.toList := by + simp [← Array.length_toList] + simp [before, challenges, ht] + +end Whir.TapeValidity diff --git a/verification/whir/Whir/TerminalRefinement.lean b/verification/whir/Whir/TerminalRefinement.lean new file mode 100644 index 000000000..05ca0d70a --- /dev/null +++ b/verification/whir/Whir/TerminalRefinement.lean @@ -0,0 +1,169 @@ +import Whir.ArrayAlgebra + +/-! Terminal refinement of the executable append-halves equality table and +adjacent-pair folds. All size premises refer to the actual arrays. + +The concrete kernels use `1 + r` and `a + r * (a + b)`, so their agreement +already holds over any commutative ring, in particular characteristic two. +The index formulas identify the first coordinate with the least significant +bit; no reversed-point convention or abstract replacement evaluator is used. +These theorems do not supply ring laws for the machine representation `E`. -/ +namespace Whir.TerminalRefinement +open Concrete ArrayLayout ArrayAlgebra +open scoped BigOperators + +variable {R : Type*} [CommRing R] + +private def tableStep (a : Array R) (r : R) : Array R := + (a.map fun x => x * (1 + r)) ++ (a.map fun x => x * r) + +private theorem eqTable_foldl (point : Array R) : + eqTable point = point.toList.foldl tableStep #[1] := by + unfold eqTable + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + exact (Array.foldl_toList ..).symm + +@[simp] theorem eqTable_empty : eqTable (#[] : Array R) = #[1] := by + rw [eqTable_foldl] + rfl + +private theorem tableLoop_size (point : List R) (a : Array R) : + (point.foldl tableStep a).size = a.size * 2 ^ point.length := by + induction point generalizing a with + | nil => simp + | cons r point ih => + simp only [List.foldl_cons, ih, tableStep, Array.size_append, Array.size_map, + List.length_cons, pow_succ] + ring + +@[simp] theorem size_eqTable (point : Array R) : + (eqTable point).size = 2 ^ point.size := by + rw [eqTable_foldl, tableLoop_size] + simp + +private def interleave (c d : R) (a : Array R) : Array R := + (a.toList.flatMap fun x => [x * c, x * d]).toArray + +private theorem interleave_step (a : Array R) (c d r : R) : + tableStep (interleave c d a) r = interleave c d (tableStep a r) := by + apply Array.toList_inj.mp + simp [tableStep, interleave, List.flatMap_append, List.map_flatMap, + List.flatMap_map, mul_assoc, mul_comm, mul_left_comm] + +private theorem interleave_loop (point : List R) (a : Array R) (c d : R) : + point.foldl tableStep (interleave c d a) = + interleave c d (point.foldl tableStep a) := by + induction point generalizing a with + | nil => rfl + | cons r point ih => + simp only [List.foldl_cons, interleave_step, ih] + +/-- The first array coordinate occupies the least significant index bit, +although the implementation appends halves for each successive coordinate. -/ +theorem eqTable_cons_toList (r : R) (point : Array R) : + (eqTable (#[r] ++ point)).toList = + (eqTable point).toList.flatMap (fun x => [x * (1 + r), x * r]) := by + rw [eqTable_foldl] + rw [Array.toList_append] + change (point.toList.foldl tableStep (tableStep #[1] r)).toList = _ + have h : tableStep #[1] r = interleave (1 + r) r #[1] := by + simp [tableStep, interleave] + rw [h, interleave_loop] + simp only [interleave, List.toList_toArray, ← eqTable_foldl] + +variable [Inhabited R] + +private theorem flatMap_pair_get (xs : List R) (c d : R) (i : Nat) + (hi : i < xs.length) : + (xs.flatMap (fun x => [x * c, x * d]))[2*i]! = xs[i]! * c ∧ + (xs.flatMap (fun x => [x * c, x * d]))[2*i+1]! = xs[i]! * d := by + induction xs generalizing i with + | nil => simp at hi + | cons x xs ih => + cases i with + | zero => simp + | succ i => + simpa [Nat.mul_succ, Nat.add_assoc, List.getElem!_cons_succ] using + ih i (by simpa using hi) + +theorem eqTable_cons_get (r : R) (point : Array R) (i : Nat) + (hi : i < 2 ^ point.size) : + (eqTable (#[r] ++ point))[2*i]! = (eqTable point)[i]! * (1 + r) ∧ + (eqTable (#[r] ++ point))[2*i+1]! = (eqTable point)[i]! * r := by + have h := flatMap_pair_get (eqTable point).toList (1+r) r i (by simpa using hi) + rw [← eqTable_cons_toList] at h + simpa only [Array.getElem!_toList] using h + +/-- Evaluating the first coordinate is exactly the executable adjacent fold. +The valid-size premise excludes truncation and default reads. -/ +theorem mle_cons (a point : Array R) (r : R) + (ha : a.size = 2 ^ (point.size + 1)) : + Concrete.mle a (#[r] ++ point) = Concrete.mle (foldLow a r) point := by + have half : a.size / 2 = 2 ^ point.size := by + rw [ha, pow_succ, Nat.mul_div_left _ (by decide : 0 < 2)] + have pairs (g : Nat → R) : + (∑ j ∈ Finset.range (2 ^ point.size * 2), g j) = + ∑ i ∈ Finset.range (2 ^ point.size), (g (2*i) + g (2*i+1)) := by + generalize 2 ^ point.size = n + induction n with + | zero => simp + | succ n ih => + rw [Nat.succ_mul, Finset.sum_range_add, ih, Finset.sum_range_succ] + simp [Finset.sum_range_succ, Nat.mul_comm] + simp only [Concrete.mle, dot_eq_sum, size_eqTable, Array.size_append, + Array.size_singleton, size_foldLow, half] + rw [show 1 + point.size = point.size + 1 by omega, ha, min_self, min_self, + pow_succ, pairs] + apply Finset.sum_congr rfl + intro i hi + have h := eqTable_cons_get r point i (Finset.mem_range.mp hi) + rw [h.1, h.2, foldLow, getElem!_tab _ _ _ (by simpa [half] using Finset.mem_range.mp hi)] + unfold foldPair + ring + +/-- An empty point evaluates exactly the first scalar on a valid witness. -/ +theorem mle_empty (a : Array R) (ha : a.size = 1) : + Concrete.mle a #[] = a[0]! := by + simp [Concrete.mle, dot_eq_sum, ha, eqTable_empty] + +private theorem foldLow_terminal_list (point : List R) (a : Array R) + (ha : a.size = 2 ^ point.length) : + point.foldl foldLow a = #[Concrete.mle a point.toArray] := by + induction point generalizing a with + | nil => + have ha' : a.size = 1 := by simpa using ha + change a = #[Concrete.mle a #[]] + rw [mle_empty a ha'] + apply Array.ext + · simpa using ha' + · intro i hi hi' + have : i = 0 := by simpa only [ha', Nat.lt_one_iff] using hi + subst i + simp [getElem!_pos, hi] + | cons r point ih => + rw [List.foldl_cons, ih (foldLow a r) (by + simp only [size_foldLow, ha, List.length_cons, pow_succ, + Nat.mul_div_left _ (by decide : 0 < 2)])] + congr 1 + have h := mle_cons a point.toArray r (by simpa using ha) + simpa using h.symm + +/-- The actual array-order sequence of executable folds terminates in exactly +one scalar, equal to the actual executable multilinear evaluation. -/ +theorem foldLow_terminal (a point : Array R) (ha : a.size = 2 ^ point.size) : + point.foldl foldLow a = #[Concrete.mle a point] := by + rw [← Array.foldl_toList] + simpa using foldLow_terminal_list point.toList a (by simpa using ha) + +theorem mle_eq_foldLow_terminal (a point : Array R) (ha : a.size = 2 ^ point.size) : + Concrete.mle a point = (point.foldl foldLow a)[0]! := by + rw [foldLow_terminal a point ha] + simp + +@[simp] theorem size_foldLow_terminal (a point : Array R) + (ha : a.size = 2 ^ point.size) : + (point.foldl foldLow a).size = 1 := by + rw [foldLow_terminal a point ha] + rfl + +end Whir.TerminalRefinement diff --git a/verification/whir/Whir/TerminalSoundness.lean b/verification/whir/Whir/TerminalSoundness.lean new file mode 100644 index 000000000..e78f707eb --- /dev/null +++ b/verification/whir/Whir/TerminalSoundness.lean @@ -0,0 +1,311 @@ +import Whir.VerifierInvariant +import Whir.TerminalRefinement +import Whir.OperationalRefinement +import Whir.FieldTower + +/-! Adversarial closing soundness for the executable verifier. The residual is +one fixed candidate, while every pending message (including the incoming one) +is arbitrary. The only exceptional challenges are actual quadratic collisions. +No acceptance or honest-message premise is used by the rejection theorem. -/ +namespace Whir.TerminalSoundness +open Concrete Protocol ArrayAlgebra ArrayLayout VerifierInvariant + +/-- Actual verifier state immediately before closing round `j`. -/ +def stateAt (ch : Challenges) (proof : Opening) (s : VerifierState E) (j : Nat) : + VerifierState E := runSteps (tailStep ch proof) j 0 s + +/-- The commitment-fixed residual after the same adjacent-pair folds. -/ +def residualAt (ch : Challenges) (residual : Array E) (j : Nat) : Array E := + runSteps (fun i a => foldLow a ch.tail[i]!) j 0 residual + +private theorem runSteps_add {S : Type*} (step : Nat → S → S) + (a b start : Nat) (s : S) : + runSteps step (a+b) start s = runSteps step b (start+a) (runSteps step a start s) := by + induction a generalizing start s with + | zero => simp [runSteps] + | succ a ih => + simpa [runSteps, Nat.succ_add, Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using + ih (start+1) (step start s) + +private theorem runSteps_succ_last {S : Type*} (step : Nat → S → S) (j : Nat) (s : S) : + runSteps step (j+1) 0 s = step j (runSteps step j 0 s) := by + rw [runSteps_add] + simp [runSteps] + +@[simp] theorem stateAt_zero (ch : Challenges) (proof : Opening) (s : VerifierState E) : + stateAt ch proof s 0 = s := rfl + +@[simp] theorem stateAt_succ (ch : Challenges) (proof : Opening) (s : VerifierState E) (j : Nat) : + stateAt ch proof s (j+1) = tailStep ch proof j (stateAt ch proof s j) := + runSteps_succ_last _ _ _ + +@[simp] theorem residualAt_zero (ch : Challenges) (a : Array E) : residualAt ch a 0 = a := rfl + +@[simp] theorem residualAt_succ (ch : Challenges) (a : Array E) (j : Nat) : + residualAt ch a (j+1) = foldLow (residualAt ch a j) ch.tail[j]! := + runSteps_succ_last _ _ _ + +/-- Power-of-two sizes evolve along the actual residual folds. -/ +theorem residualAt_size (ch : Challenges) (a : Array E) + (shape : a.size = 2 ^ ch.tail.size) (j : Nat) (hj : j ≤ ch.tail.size) : + (residualAt ch a j).size = 2 ^ (ch.tail.size-j) := by + induction j with + | zero => simpa using shape + | succ j ih => + rw [residualAt_succ, size_foldLow, ih (by omega)] + have h : ch.tail.size-j = (ch.tail.size-(j+1))+1 := by omega + rw [h, pow_succ, Nat.mul_div_left _ (by decide : 0 < 2)] + +/-- Verifier weights follow precisely the same executable folds, independently +of the claims and all supplied messages. -/ +theorem stateAt_weight (ch : Challenges) (proof : Opening) (s : VerifierState E) (j : Nat) : + (stateAt ch proof s j).weight = residualAt ch s.weight j := by + induction j with + | zero => rfl + | succ j ih => simp [tailStep, VerifierState.fold, foldValues, ih] + +theorem stateAt_weight_size (ch : Challenges) (proof : Opening) (s : VerifierState E) + (shape : s.weight.size = 2 ^ ch.tail.size) (j : Nat) (hj : j ≤ ch.tail.size) : + (stateAt ch proof s j).weight.size = 2 ^ (ch.tail.size-j) := by + rw [stateAt_weight] + exact residualAt_size ch s.weight shape j hj + +/-- Explicit singleton collision event for a fixed prior transcript. -/ +noncomputable def collision (a : Array E) (s : VerifierState E) : Finset E := + roundBad {a} s 1 + +theorem collision_probability (a : Array E) (s : VerifierState E) + (falseClaim : dot a s.weight ≠ s.claim) : + Soundness.uniformProb (collision a s) ≤ 2 / (Fintype.card E : ℚ) := by + have lost : Lost {a} s := by simpa [Lost] using falseClaim + simpa [collision] using roundBad_probability {a} s 1 lost + +/-- Avoiding the explicit event preserves falsity for any next message. -/ +theorem fold_false (a : Array E) (s : VerifierState E) (pairs : Nat) (r : E) + (next : Message E) (shape : a.size = pairs*2) (weights : s.weight.size = a.size) + (outside : r ∉ collision a s) : + dot (foldLow a r) (s.fold 1 r next).weight ≠ (s.fold 1 r next).claim := by + have h : Lost {foldLow a r} (s.fold 1 r next) := by + apply fold_lost {a} {foldLow a r} s 1 pairs r next + · simpa using shape + · simpa using weights + · simp [foldValues] + · exact outside + simpa [Lost] using h + +/-- At every prefix the candidate and weights retain their exact lengths, and +falsity persists without any honesty condition on the opening messages. -/ +theorem closing_false (ch : Challenges) (proof : Opening) (s : VerifierState E) + (shape : proof.residual.size = 2 ^ ch.tail.size) + (weights : s.weight.size = proof.residual.size) + (falseClaim : dot proof.residual s.weight ≠ s.claim) + (avoid : ∀ j < ch.tail.size, ch.tail[j]! ∉ + collision (residualAt ch proof.residual j) (stateAt ch proof s j)) + (j : Nat) (hj : j ≤ ch.tail.size) : + dot (residualAt ch proof.residual j) (stateAt ch proof s j).weight ≠ + (stateAt ch proof s j).claim := by + induction j with + | zero => exact falseClaim + | succ j ih => + rw [residualAt_succ, stateAt_succ] + unfold tailStep + apply fold_false _ _ (2^(ch.tail.size-(j+1))) + · rw [residualAt_size ch proof.residual shape j (by omega)] + rw [show ch.tail.size-j = (ch.tail.size-(j+1))+1 by omega, pow_succ] + · rw [stateAt_weight_size ch proof s (weights.trans shape) j (by omega), + residualAt_size ch proof.residual shape j (by omega)] + · exact avoid j (by omega) + +/-- Identification uses the actual array-order terminal refinement, rather than +assuming equality to a supplied final scalar. -/ +theorem residualAt_terminal (ch : Challenges) (a : Array E) + (shape : a.size = 2 ^ ch.tail.size) : + residualAt ch a ch.tail.size = #[Concrete.mle a ch.tail] := by + have mapped : (List.range ch.tail.size).map (fun i => ch.tail[i]!) = ch.tail.toList := by + apply List.ext_getElem + · simp + · intro i hi hi' + simp only [List.getElem_map, List.getElem_range, Array.getElem_toList] + simp only [getElem!_pos ch.tail i (by simpa using hi')] + rw [residualAt, OperationalRefinement.runSteps_eq_foldl, ← List.range_eq_range'] + change (List.range ch.tail.size).foldl (fun a i => foldLow a ch.tail[i]!) a = _ + rw [← List.foldl_map, mapped, Array.foldl_toList] + exact TerminalRefinement.foldLow_terminal a ch.tail shape + +/-- False terminal singleton claims reject through the actual residual MLE check. -/ +theorem checkClosing_rejects_of_terminal_false (ch : Challenges) (proof : Opening) + (s : VerifierState E) (shape : proof.residual.size = 2 ^ ch.tail.size) + (weights : s.weight.size = proof.residual.size) + (h : dot (residualAt ch proof.residual ch.tail.size) + (stateAt ch proof s ch.tail.size).weight ≠ (stateAt ch proof s ch.tail.size).claim) : + checkClosing ch proof (closeTail ch proof s) = .error "terminal mismatch" := by + rw [residualAt_terminal ch proof.residual shape] at h + have hw := stateAt_weight_size ch proof s (weights.trans shape) ch.tail.size le_rfl + simp only [Nat.sub_self, pow_zero] at hw + have hdot : dot #[Concrete.mle proof.residual ch.tail] + (stateAt ch proof s ch.tail.size).weight = + Concrete.mle proof.residual ch.tail * (stateAt ch proof s ch.tail.size).weight[0]! := by + simp [dot_eq_sum, hw] + rw [hdot] at h + have bad : (closeTail ch proof s).checkTerminal (Concrete.mle proof.residual ch.tail) = false := by + simpa [VerifierState.checkTerminal, closeTail, stateAt, ne_comm] using h + simp only [checkClosing, bad, Bool.not_false, ite_true] + rfl + +/-- An arbitrary adversarial closing transcript must be rejected if its incoming +weighted residual claim is false and none of its actual quadratic events occurs. -/ +theorem checkClosing_rejects (ch : Challenges) (proof : Opening) (s : VerifierState E) + (shape : proof.residual.size = 2 ^ ch.tail.size) + (weights : s.weight.size = proof.residual.size) + (falseClaim : dot proof.residual s.weight ≠ s.claim) + (avoid : ∀ j < ch.tail.size, ch.tail[j]! ∉ + collision (residualAt ch proof.residual j) (stateAt ch proof s j)) : + checkClosing ch proof (closeTail ch proof s) = .error "terminal mismatch" := + checkClosing_rejects_of_terminal_false ch proof s shape weights + (closing_false ch proof s shape weights falseClaim avoid ch.tail.size le_rfl) + +/-- Two actual roots at most, for every fixed adversarial pending message. -/ +theorem collision_card (a : Array E) (s : VerifierState E) + (falseClaim : dot a s.weight ≠ s.claim) : (collision a s).card ≤ 2 := by + have h := Soundness.evaluation_agreement (Finset.univ : Finset E) + (messagePolynomial (roundMessage a s.weight 1) (dot a s.weight)) + (messagePolynomial s.message s.claim) + (false_candidate_polynomials s a 1 falseClaim) 2 + (messagePolynomial_degree _ _) (messagePolynomial_degree _ _) + simpa [collision, roundBad] using h + +/-- Finite conditional counting: the arbitrary state and candidate may depend on +all prior history, but not on the fresh field element. Histories at which the +claim is already true are not charged as an escape. -/ +theorem conditional_collision_count {History : Type*} [Fintype History] + (candidate : History → Array E) (state : History → VerifierState E) : + (Finset.univ.filter fun hr : History × E => + dot (candidate hr.1) (state hr.1).weight ≠ (state hr.1).claim ∧ + hr.2 ∈ collision (candidate hr.1) (state hr.1)).card ≤ Fintype.card History * 2 := by + classical + simp only [Finset.card_filter, Fintype.sum_prod_type] + calc + _ ≤ ∑ h : History, 2 := by + apply Finset.sum_le_sum + intro h _ + by_cases hf : dot (candidate h) (state h).weight ≠ (state h).claim + · simpa [hf, ← Finset.card_filter] using collision_card (candidate h) (state h) hf + · simp [hf] + _ = _ := by simp + +/-- The fixed-history two-root estimate survives arbitrary finite conditioning +on prior transcripts. The fresh challenge is the independent product factor. -/ +theorem conditional_collision_probability {History : Type*} [Fintype History] + [Nonempty History] (candidate : History → Array E) (state : History → VerifierState E) : + Soundness.uniformProb (Finset.univ.filter fun hr : History × E => + dot (candidate hr.1) (state hr.1).weight ≠ (state hr.1).claim ∧ + hr.2 ∈ collision (candidate hr.1) (state hr.1)) ≤ 2 / (Fintype.card E : ℚ) := by + classical + unfold Soundness.uniformProb + rw [Fintype.card_prod, Nat.cast_mul] + have hp : (0 : ℚ) < Fintype.card History := by exact_mod_cast Fintype.card_pos + calc + _ ≤ ((Fintype.card History : ℚ) * 2) / + ((Fintype.card History : ℚ) * Fintype.card E) := by + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast conditional_collision_count candidate state + _ = _ := by field_simp + +/-- Actual acceptance of a false incoming claim exposes a first quadratic +collision while the residual weighted claim is still false. -/ +theorem accepted_has_collision (ch : Challenges) (proof : Opening) (s : VerifierState E) + (shape : proof.residual.size = 2 ^ ch.tail.size) + (weights : s.weight.size = proof.residual.size) + (falseClaim : dot proof.residual s.weight ≠ s.claim) + (accepted : checkClosing ch proof (closeTail ch proof s) = .ok ()) : + ∃ j < ch.tail.size, + dot (residualAt ch proof.residual j) (stateAt ch proof s j).weight ≠ + (stateAt ch proof s j).claim ∧ + ch.tail[j]! ∈ collision (residualAt ch proof.residual j) (stateAt ch proof s j) := by + classical + let lost := fun j => dot (residualAt ch proof.residual j) (stateAt ch proof s j).weight ≠ + (stateAt ch proof s j).claim + have initial : lost 0 := falseClaim + have final : ¬ lost ch.tail.size := by + intro h + have bad := checkClosing_rejects_of_terminal_false ch proof s shape weights h + rw [bad] at accepted + contradiction + obtain ⟨j, hj, hl, hn⟩ := Soundness.first_escape lost ch.tail.size initial final + refine ⟨j, hj, hl, ?_⟩ + by_contra outside + apply hn + dsimp only [lost] + rw [residualAt_succ, stateAt_succ] + unfold tailStep + apply fold_false _ _ (2^(ch.tail.size-(j+1))) + · rw [residualAt_size ch proof.residual shape j (by omega)] + rw [show ch.tail.size-j = (ch.tail.size-(j+1))+1 by omega, pow_succ] + · rw [stateAt_weight_size ch proof s (weights.trans shape) j (by omega), + residualAt_size ch proof.residual shape j (by omega)] + · exact outside + +/-- Finite causal composition for actual closing executions. Each `split` exposes +the fresh independent field coordinate; the two causality equations require +the candidate and pending verifier state to be fixed without that coordinate. +No local or global probability bound is assumed. -/ +theorem causal_closing_bound {Ω History : Type*} [Fintype Ω] [Fintype History] + [Nonempty History] (n : Nat) + (ch : Ω → Challenges) (proof : Ω → Opening) (s : Ω → VerifierState E) + (lengths : ∀ ω, (ch ω).tail.size = n) + (shape : ∀ ω, (proof ω).residual.size = 2 ^ (ch ω).tail.size) + (weights : ∀ ω, (s ω).weight.size = (proof ω).residual.size) + (falseClaim : ∀ ω, dot (proof ω).residual (s ω).weight ≠ (s ω).claim) + (split : Fin n → Ω ≃ (History × E)) + (candidate : Fin n → History → Array E) + (prior : Fin n → History → VerifierState E) + (candidate_causal : ∀ (i : Fin n) ω, + residualAt (ch ω) (proof ω).residual i = candidate i (split i ω).1) + (state_causal : ∀ (i : Fin n) ω, + stateAt (ch ω) (proof ω) (s ω) i = prior i (split i ω).1) + (fresh : ∀ (i : Fin n) ω, (ch ω).tail[i.val]! = (split i ω).2) : + Soundness.uniformProb (Finset.univ.filter fun ω => + checkClosing (ch ω) (proof ω) (closeTail (ch ω) (proof ω) (s ω)) = .ok ()) ≤ + (n : ℚ) * (2 / (Fintype.card E : ℚ)) := by + classical + let event : Fin n → Finset Ω := fun i => Finset.univ.filter fun ω => + dot (candidate i (split i ω).1) (prior i (split i ω).1).weight ≠ + (prior i (split i ω).1).claim ∧ + (split i ω).2 ∈ collision (candidate i (split i ω).1) (prior i (split i ω).1) + have sub : (Finset.univ.filter fun ω => + checkClosing (ch ω) (proof ω) (closeTail (ch ω) (proof ω) (s ω)) = .ok ()) ⊆ + Finset.univ.biUnion event := by + intro ω hω + obtain ⟨j, hj, h⟩ := accepted_has_collision (ch ω) (proof ω) (s ω) + (shape ω) (weights ω) (falseClaim ω) (Finset.mem_filter.mp hω).2 + let i : Fin n := ⟨j, by simpa [lengths ω] using hj⟩ + change dot (residualAt (ch ω) (proof ω).residual i) + (stateAt (ch ω) (proof ω) (s ω) i).weight ≠ + (stateAt (ch ω) (proof ω) (s ω) i).claim ∧ + (ch ω).tail[i.val]! ∈ collision (residualAt (ch ω) (proof ω).residual i) + (stateAt (ch ω) (proof ω) (s ω) i) at h + rw [candidate_causal, state_causal, fresh] at h + exact Finset.mem_biUnion.mpr ⟨i, Finset.mem_univ _, Finset.mem_filter.mpr + ⟨Finset.mem_univ _, h⟩⟩ + have bounded (i : Fin n) : Soundness.uniformProb (event i) ≤ 2 / (Fintype.card E : ℚ) := by + have count : (event i).card = (Finset.univ.filter fun hr : History × E => + dot (candidate i hr.1) (prior i hr.1).weight ≠ (prior i hr.1).claim ∧ + hr.2 ∈ collision (candidate i hr.1) (prior i hr.1)).card := by + simp only [event, Finset.card_filter] + exact Equiv.sum_comp (split i) (fun hr : History × E => + if dot (candidate i hr.1) (prior i hr.1).weight ≠ (prior i hr.1).claim ∧ + hr.2 ∈ collision (candidate i hr.1) (prior i hr.1) then (1 : Nat) else 0) + unfold Soundness.uniformProb + rw [count, Fintype.card_congr (split i)] + exact conditional_collision_probability (candidate i) (prior i) + calc + _ ≤ Soundness.uniformProb (Finset.univ.biUnion event) := by + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_le_card sub + _ ≤ ∑ i, Soundness.uniformProb (event i) := Soundness.union_bound event + _ ≤ ∑ _i : Fin n, 2 / (Fintype.card E : ℚ) := + Finset.sum_le_sum (fun i _ => bounded i) + _ = _ := by simp + +end Whir.TerminalSoundness diff --git a/verification/whir/Whir/TypedFiatShamirGame.lean b/verification/whir/Whir/TypedFiatShamirGame.lean new file mode 100644 index 000000000..fb216f780 --- /dev/null +++ b/verification/whir/Whir/TypedFiatShamirGame.lean @@ -0,0 +1,278 @@ +import Whir.FiatShamirGame + +/-! Dependent-alphabet lazy sampling. The request is selected before its answer; +only the selected fiber is sampled. A sigma of heterogeneous answers is never +sampled uniformly. Stopping is built into the finite experiment. -/ +namespace Whir.TypedFiatShamirGame +open scoped BigOperators +open FiatShamirGame +open Classical + +variable {Key : Type*} {Answer : Key → Type*} +variable [∀ k, Fintype (Answer k)] [∀ k, Nonempty (Answer k)] + +/-- A finite allocation experiment. Deterministic work, cache hits, clone +selection and partial-slice projections are compiled into the continuation; +only a fresh whole-vector allocation uses `draw`. -/ +inductive Game (Key : Type*) (Answer : Key → Type*) : Nat → Type _ where + | stop {n} : Game Key Answer n + | draw {n} (key : Key) (next : Answer key → Game Key Answer n) : Game Key Answer (n+1) + +noncomputable def risk (bad : (k : Key) → Answer k → Prop) : + {n : Nat} → Game Key Answer n → ℚ + | _, .stop => 0 + | _, .draw k next => by + classical + exact average (fun a => if bad k a then 1 else risk bad (next a)) + +theorem risk_nonneg (bad : (k : Key) → Answer k → Prop) {n : Nat} + (g : Game Key Answer n) : 0 ≤ risk bad g := by + induction g with + | stop => exact le_rfl + | draw k next ih => + classical + rw [risk, ← average_const (C := Answer k) 0] + apply average_mono + intro a + split + · norm_num + · exact ih a + +theorem risk_le_one (bad : (k : Key) → Answer k → Prop) {n : Nat} + (g : Game Key Answer n) : risk bad g ≤ 1 := by + induction g with + | stop => norm_num [risk] + | draw k next ih => + classical + calc + _ ≤ average (fun _ : Answer k => (1 : ℚ)) := by + apply average_mono + intro a + split + · exact le_rfl + · exact ih a + _ = 1 := average_const 1 + +/-- Optional stopping never requires a successful-path depth bound: every branch +has the index cap, and an early stop contributes zero additional failure. -/ +theorem risk_bound (bad : (k : Key) → Answer k → Prop) (epsilon : ℚ) + (nonneg : 0 ≤ epsilon) + (sparse : ∀ k, average (fun a => if bad k a then 1 else 0) ≤ epsilon) + {n : Nat} (g : Game Key Answer n) : risk bad g ≤ n * epsilon := by + induction g with + | @stop n => simpa [risk] using mul_nonneg (show (0 : ℚ) ≤ n by positivity) nonneg + | @draw n k next ih => + classical + rw [risk] + calc + _ ≤ average (fun a => (if bad k a then 1 else 0) + n * epsilon) := by + apply average_mono + intro a + split + · have hn : (0 : ℚ) ≤ n * epsilon := mul_nonneg (by positivity) nonneg + linarith + · simpa using ih a + _ = average (fun a => if bad k a then 1 else 0) + n * epsilon := by + rw [average_add, average_const] + _ ≤ epsilon + n * epsilon := by have h := sparse k; linarith + _ = (n+1 : Nat) * epsilon := by push_cast; ring + +/-- A single global, dependent cache. Its key includes the statement and full +canonical history in applications. Repeated slices all project this same value. -/ +abbrev Cache (Key : Type*) (Answer : Key → Type*) := (k : Key) → Option (Answer k) + +def put [DecidableEq Key] (cache : Cache Key Answer) + (k : Key) (a : Answer k) : Cache Key Answer := Function.update cache k (some a) + +omit [∀ k, Fintype (Answer k)] [∀ k, Nonempty (Answer k)] in +@[simp] theorem put_self [DecidableEq Key] (cache : Cache Key Answer) + (k : Key) (a : Answer k) : put cache k a k = some a := by + simp [put] + +omit [∀ k, Fintype (Answer k)] [∀ k, Nonempty (Answer k)] in +@[simp] theorem put_other [DecidableEq Key] (cache : Cache Key Answer) + (k j : Key) (a : Answer k) (h : j ≠ k) : put cache k a j = cache j := by + simp [put, h] + +/-- A hit, clone, repeated request or partial-coordinate request has no sampling +operation at all. The projection may consume any overlapping part of the vector. -/ +def readPart {R : Type*} (cache : Cache Key Answer) (k : Key) + (project : Answer k → R) : Option R := (cache k).map project + +omit [∀ k, Fintype (Answer k)] [∀ k, Nonempty (Answer k)] in +theorem readPart_put [DecidableEq Key] {R : Type*} (cache : Cache Key Answer) + (k : Key) (a : Answer k) (project : Answer k → R) : + readPart (put cache k a) k project = some (project a) := by simp [readPart] + +omit [∀ k, Nonempty (Answer k)] in +/-- Exact conditional uniformity of a fresh dependent table fiber. This identity +is an integration statement, not an interface exposing the other table entries. -/ +theorem fresh_coordinate [Fintype Key] [DecidableEq Key] (k : Key) + (f : ((j : {j : Key // j ≠ k}) → Answer j) → Answer k → ℚ) : + average (fun table : (j : Key) → Answer j => f (fun j => table j) (table k)) = + average (fun rest : (j : {j : Key // j ≠ k}) → Answer j => average (f rest)) := by + let e := Equiv.piSplitAt k Answer + have hs : (∑ table : (j : Key) → Answer j, f (fun j => table j) (table k)) = + ∑ pair : Answer k × ((j : {j : Key // j ≠ k}) → Answer j), f pair.2 pair.1 := + Fintype.sum_equiv e _ _ (fun _ => rfl) + have hc := Fintype.card_congr e + unfold average + rw [hs, hc, Fintype.card_prod, Fintype.sum_prod_type, Finset.sum_comm] + simp only [Nat.cast_mul, ← Finset.sum_div] + ring + +section Ancestors +variable {S M Q : Type*} {A : Q → Type*} + +/-- A canonical full input records both the raw prefix key and every completed +ancestor answer. Equality therefore includes the statement and all history. -/ +structure FullInput (S M Q : Type*) (A : Q → Type*) where + statement : S + messages : List M + ancestors : List (M × Sigma A) + +abbrev Oracle (query : S × List M → Q) := + (input : FullInput S M Q A) → A (query (input.statement, input.messages)) + +def complete (query : S × List M → Q) (oracle : Oracle (A := A) query) (s : S) : + List M → List (M × Sigma A) + | [] => [] + | m :: older => + let past := complete query oracle s older + (m, ⟨query (s, m :: older), oracle ⟨s, m :: older, past⟩⟩) :: past + +theorem complete_erases (query : S × List M → Q) (oracle : Oracle (A := A) query) + (s : S) (p : List M) : (complete query oracle s p).map Prod.fst = p := by + induction p with + | nil => rfl + | cons m p ih => simp [complete, ih] + +structure Allocation (query : S × List M → Q) (A : Q → Type*) where + history : List (M × Sigma A) + cache : Cache (S × List M) (fun key => A (query key)) + fresh : Nat + +/-- Ancestor completion uses one shared dependent cache across all statements, +branches and clones. No unused component of another alphabet is sampled. -/ +def allocate [DecidableEq S] [DecidableEq M] + (query : S × List M → Q) (oracle : Oracle (A := A) query) (s : S) : + List M → Cache (S × List M) (fun key => A (query key)) → Allocation query A + | [], cache => ⟨[], cache, 0⟩ + | m :: p, cache => + let a := allocate query oracle s p cache + match a.cache (s, m :: p) with + | some x => ⟨(m, ⟨query (s, m :: p), x⟩) :: a.history, a.cache, a.fresh⟩ + | none => + let x := oracle ⟨s, m :: p, a.history⟩ + ⟨(m, ⟨query (s, m :: p), x⟩) :: a.history, + Function.update a.cache (s, m :: p) (some x), a.fresh + 1⟩ + +def canonicalAnswer (query : S × List M → Q) (oracle : Oracle (A := A) query) + (key : S × List M) : Option (A (query key)) := + match key.2 with + | [] => none + | _m :: p => some (oracle ⟨key.1, key.2, complete query oracle key.1 p⟩) + +def CacheCorrect (query : S × List M → Q) (oracle : Oracle (A := A) query) + (cache : Cache (S × List M) (fun key => A (query key))) : Prop := + ∀ key x, cache key = some x → canonicalAnswer query oracle key = some x + +theorem empty_cache_correct (query : S × List M → Q) (oracle : Oracle (A := A) query) : + CacheCorrect query oracle (fun _ => none) := by + intro key x h + cases h + +theorem allocate_correct [DecidableEq S] [DecidableEq M] + (query : S × List M → Q) (oracle : Oracle (A := A) query) (s : S) (p : List M) + (cache : Cache (S × List M) (fun key => A (query key))) + (correct : CacheCorrect query oracle cache) : + (allocate query oracle s p cache).history = complete query oracle s p ∧ + CacheCorrect query oracle (allocate query oracle s p cache).cache := by + induction p generalizing cache with + | nil => exact ⟨rfl, correct⟩ + | cons m p ih => + obtain ⟨hh, hc⟩ := ih cache correct + have ho : oracle ⟨s, m :: p, (allocate query oracle s p cache).history⟩ = + oracle ⟨s, m :: p, complete query oracle s p⟩ := by + congr 1 + rw [hh] + simp only [allocate] + split + next x h => + have he := hc (s, m :: p) x h + simp only [canonicalAnswer, Option.some.injEq] at he + exact ⟨by simp [complete, hh, he], hc⟩ + next h => + constructor + · simp [complete, hh, ho] + · intro key x he + by_cases hk : key = (s, m :: p) + · subst key + simp only [Function.update_self, Option.some.injEq] at he + simp only [canonicalAnswer, Option.some.injEq] + exact ho.symm.trans he + · exact hc key x (by simpa only [Function.update_of_ne hk] using he) + +theorem allocate_fresh_le [DecidableEq S] [DecidableEq M] + (query : S × List M → Q) (oracle : Oracle (A := A) query) (s : S) (p : List M) + (cache : Cache (S × List M) (fun key => A (query key))) : + (allocate query oracle s p cache).fresh ≤ p.length := by + induction p with + | nil => simp [allocate] + | cons m p ih => + simp only [allocate] + split <;> simp only [List.length_cons] <;> omega + +def serve [DecidableEq S] [DecidableEq M] + (query : S × List M → Q) (oracle : Oracle (A := A) query) : + List (S × List M) → Cache (S × List M) (fun key => A (query key)) → + Cache (S × List M) (fun key => A (query key)) × Nat + | [], cache => (cache, 0) + | key :: rest, cache => + let a := allocate query oracle key.1 key.2 cache + let b := serve query oracle rest a.cache + (b.1, a.fresh + b.2) + +theorem serve_correct [DecidableEq S] [DecidableEq M] + (query : S × List M → Q) (oracle : Oracle (A := A) query) + (requests : List (S × List M)) (cache : Cache (S × List M) (fun key => A (query key))) + (correct : CacheCorrect query oracle cache) : + CacheCorrect query oracle (serve query oracle requests cache).1 := by + induction requests generalizing cache with + | nil => exact correct + | cons key rest ih => + exact ih _ (allocate_correct query oracle key.1 key.2 cache correct).2 + +theorem serve_cost_le [DecidableEq S] [DecidableEq M] + (query : S × List M → Q) (oracle : Oracle (A := A) query) + (requests : List (S × List M)) (cache : Cache (S × List M) (fun key => A (query key))) : + (serve query oracle requests cache).2 ≤ allocationWork (requests.map Prod.snd) := by + induction requests generalizing cache with + | nil => simp [serve, allocationWork] + | cons key rest ih => + have ha := allocate_fresh_le query oracle key.1 key.2 cache + have hb := ih (allocate query oracle key.1 key.2 cache).cache + simpa only [serve, allocationWork, List.map_cons, List.sum_cons, ancestors_length] + using Nat.add_le_add ha hb + +/-- Pointwise for arbitrary queried branches, including rejecting ones. Applied +to every leaf of an adaptive request tree, this is a deterministic stopping cap. -/ +theorem serve_cap [DecidableEq S] [DecidableEq M] + (query : S × List M → Q) (oracle : Oracle (A := A) query) + (B K : Nat) (requests : List (S × List M)) (final : S × List M) + (cache : Cache (S × List M) (fun key => A (query key))) + (budget : requests.length ≤ K) (bounded : ∀ key ∈ requests, key.2.length ≤ B) + (finalBound : final.2.length ≤ B) : + (serve query oracle (requests ++ [final]) cache).2 ≤ B * (K+1) := by + apply (serve_cost_le query oracle _ cache).trans + simp only [List.map_append, List.map_cons, List.map_nil] + apply allocation_cap B K (requests.map Prod.snd) final.2 + · simpa using budget + · intro p hp + obtain ⟨key, hk, rfl⟩ := List.mem_map.mp hp + exact bounded key hk + · exact finalBound + +end Ancestors + +end Whir.TypedFiatShamirGame diff --git a/verification/whir/Whir/TypedOracleCompiler.lean b/verification/whir/Whir/TypedOracleCompiler.lean new file mode 100644 index 000000000..6b6a8d411 --- /dev/null +++ b/verification/whir/Whir/TypedOracleCompiler.lean @@ -0,0 +1,727 @@ +import Whir.TypedFiatShamirGame + +/-! Causal, bounded typed-oracle programs. Only requested projections reach the +strategy. Ancestor completion and the terminal completion share one cache. -/ +namespace Whir.TypedOracleCompiler +open TypedFiatShamirGame +open FiatShamirGame (average average_mono average_const) + +universe u v w + +/-- A lazy-sampling computation with a return value and a worst-case draw cap. -/ +inductive Sampling (Key : Type u) (Answer : Key → Type v) (R : Type w) : Nat → Type (max u v w) where + | ret {n} (value : R) : Sampling Key Answer R n + | draw {n} (key : Key) (next : Answer key → Sampling Key Answer R n) : + Sampling Key Answer R (n + 1) + +namespace Sampling +variable {Key : Type u} {Answer : Key → Type v} {R : Type w} + +def pad {n m} (h : n ≤ m) : Sampling Key Answer R n → Sampling Key Answer R m + | .ret r => .ret r + | .draw k next => match m with + | 0 => False.elim (by omega) + | m + 1 => .draw k (fun a => pad (by omega) (next a)) + +def bind {T : Type*} {n m} (t : Sampling Key Answer R n) + (f : R → Sampling Key Answer T m) : Sampling Key Answer T (n + m) := + match t with + | .ret r => pad (by omega) (f r) + | @draw _ _ _ n k next => + pad (by omega) (.draw k (fun a => bind (next a) f)) + +def erase {n} : Sampling Key Answer R n → Game Key Answer n + | .ret _ => .stop + | .draw k next => .draw k (fun a => erase (next a)) + +/-- This evaluator is a denotational reference, never an argument to a strategy. -/ +def eval (oracle : (k : Key) → Answer k) {n} : Sampling Key Answer R n → R + | .ret r => r + | .draw k next => eval oracle (next (oracle k)) + +@[simp] theorem eval_pad (oracle : (k : Key) → Answer k) {n m} (h : n ≤ m) + (t : Sampling Key Answer R n) : eval oracle (pad h t) = eval oracle t := by + induction t generalizing m with + | ret => simp [pad, eval] + | draw k next ih => + cases m with + | zero => omega + | succ m => exact ih _ _ + +@[simp] theorem eval_bind (oracle : (k : Key) → Answer k) {T : Type*} {n m} + (t : Sampling Key Answer R n) (f : R → Sampling Key Answer T m) : + eval oracle (bind t f) = eval oracle (f (eval oracle t)) := by + induction t with + | ret r => simp [bind, eval] + | draw k next ih => simpa [bind, eval] using ih (oracle k) + +/-- Operational traces list only actually allocated full vectors, in order. -/ +inductive Runs : {n : Nat} → Sampling Key Answer R n → List (Sigma Answer) → R → Prop where + | ret {n} (r : R) : Runs (.ret (n := n) r) [] r + | draw {n k} {next : Answer k → Sampling Key Answer R n} {trace r} + (a : Answer k) : Runs (next a) trace r → Runs (.draw k next) (⟨k,a⟩ :: trace) r + +theorem Runs.length_le {n} {t : Sampling Key Answer R n} {trace r} + (h : Runs t trace r) : trace.length ≤ n := by + induction h with + | ret => simp + | draw a h ih => simpa using Nat.succ_le_succ ih + +/-- A universal operational postcondition, with no reference oracle. -/ +def Every (predicate : R → Prop) {n} : Sampling Key Answer R n → Prop + | .ret r => predicate r + | .draw _ next => ∀ a, Every predicate (next a) + +theorem Every.mono {P Q : R → Prop} {n} {t : Sampling Key Answer R n} + (h : Every P t) (imp : ∀ r, P r → Q r) : Every Q t := by + induction t with + | ret r => exact imp r h + | draw k next ih => exact fun a => ih a (h a) + +@[simp] theorem every_pad (P : R → Prop) {n m} (h : n ≤ m) + (t : Sampling Key Answer R n) : Every P (pad h t) ↔ Every P t := by + induction t generalizing m with + | ret => simp [pad, Every] + | draw k next ih => + cases m with + | zero => omega + | succ m => simp only [pad, Every, ih] + +@[simp] theorem every_bind {T : Type*} (P : T → Prop) {n m} + (t : Sampling Key Answer R n) (f : R → Sampling Key Answer T m) : + Every P (bind t f) ↔ Every (fun r => Every P (f r)) t := by + induction t with + | ret r => simp [bind, Every] + | draw k next ih => simp only [bind, every_pad, Every, ih] + +theorem Runs.postcondition {P : R → Prop} {n} {t : Sampling Key Answer R n} + {trace r} (run : Runs t trace r) (h : Every P t) : P r := by + induction run with + | ret => exact h + | draw a run ih => exact ih (h a) + +@[simp] theorem runs_pad {n m} (h : n ≤ m) (t : Sampling Key Answer R n) {trace r} : + Runs (pad h t) trace r ↔ Runs t trace r := by + induction t generalizing m trace r with + | ret value => + simp only [pad] + constructor <;> intro run <;> cases run <;> exact .ret _ + | draw k next ih => + cases m with + | zero => omega + | succ m => + simp only [pad] + constructor + · intro run + cases run with + | draw a hr => exact .draw a ((ih a _).mp hr) + · intro run + cases run with + | draw a hr => exact .draw a ((ih a _).mpr hr) + +theorem runs_bind {T : Type*} {n m} (t : Sampling Key Answer R n) + (f : R → Sampling Key Answer T m) {trace result} : + Runs (bind t f) trace result ↔ + ∃ before value after, trace = before ++ after ∧ + Runs t before value ∧ Runs (f value) after result := by + induction t generalizing trace result with + | ret value => + simp only [bind, runs_pad] + constructor + · intro run + exact ⟨[], value, trace, rfl, .ret _, run⟩ + · rintro ⟨before, value', after, ht, first, last⟩ + cases first + simpa using ht ▸ last + | draw k next ih => + simp only [bind, runs_pad] + constructor + · intro run + cases run with + | draw a hr => + obtain ⟨before, value, after, ht, first, last⟩ := (ih a).mp hr + exact ⟨⟨k,a⟩ :: before, value, after, by simp [ht], .draw a first, last⟩ + · rintro ⟨before, value, after, ht, first, last⟩ + cases first with + | draw a hr => + subst trace + exact .draw a ((ih a).mpr ⟨_, value, after, rfl, hr, last⟩) + +def execute (oracle : (k : Key) → Answer k) {n} : + Sampling Key Answer R n → R × List (Sigma Answer) + | .ret r => (r, []) + | .draw k next => + let result := execute oracle (next (oracle k)) + (result.1, ⟨k, oracle k⟩ :: result.2) + +theorem execute_runs (oracle : (k : Key) → Answer k) {n} + (t : Sampling Key Answer R n) : Runs t (execute oracle t).2 (execute oracle t).1 := by + induction t with + | ret r => exact .ret r + | draw k next ih => exact .draw (oracle k) (ih (oracle k)) + +@[simp] theorem execute_value (oracle : (k : Key) → Answer k) {n} + (t : Sampling Key Answer R n) : (execute oracle t).1 = eval oracle t := by + induction t with + | ret => rfl + | draw k next ih => exact ih (oracle k) + +@[simp] theorem execute_pad (oracle : (k : Key) → Answer k) {n m} (h : n ≤ m) + (t : Sampling Key Answer R n) : execute oracle (pad h t) = execute oracle t := by + induction t generalizing m with + | ret => simp [pad, execute] + | draw k next ih => + cases m with + | zero => omega + | succ m => simp only [pad, execute, ih] + +theorem execute_bind (oracle : (k : Key) → Answer k) {T : Type*} {n m} + (t : Sampling Key Answer R n) (f : R → Sampling Key Answer T m) : + execute oracle (bind t f) = + ((execute oracle (f (eval oracle t))).1, + (execute oracle t).2 ++ (execute oracle (f (eval oracle t))).2) := by + induction t with + | ret r => simp only [bind, execute_pad, execute, eval, List.nil_append] + | draw k next ih => simp [bind, execute, eval, ih] + +variable [∀ k, Fintype (Answer k)] [∀ k, Nonempty (Answer k)] + +/-- Exact expectation in the operational experiment: sample a fresh selected +fiber uniformly, then continue with that answer, and no other oracle data. -/ +noncomputable def expectation (payoff : R → ℚ) {n} : Sampling Key Answer R n → ℚ + | .ret r => payoff r + | .draw _k next => average (fun a => expectation payoff (next a)) + +omit [∀ k, Nonempty (Answer k)] in +@[simp] theorem expectation_pad (payoff : R → ℚ) {n m} (h : n ≤ m) + (t : Sampling Key Answer R n) : + expectation payoff (pad h t) = expectation payoff t := by + induction t generalizing m with + | ret => simp [pad, expectation] + | draw k next ih => + cases m with + | zero => omega + | succ m => simp only [pad, expectation, ih] + +omit [∀ k, Nonempty (Answer k)] in +theorem expectation_bind {T : Type*} (payoff : T → ℚ) {n m} + (t : Sampling Key Answer R n) (f : R → Sampling Key Answer T m) : + expectation payoff (bind t f) = + expectation (fun r => expectation payoff (f r)) t := by + induction t with + | ret r => simp [bind, expectation] + | draw k next ih => simp only [bind, expectation_pad, expectation, ih] + +noncomputable def failureProbability (failure : R → Prop) {n} + (t : Sampling Key Answer R n) : ℚ := by + classical + exact expectation (fun r => if failure r then 1 else 0) t + +noncomputable def badProbability (bad : (k : Key) → Answer k → Prop) {n} : + Sampling Key Answer R n → ℚ + | .ret _ => 0 + | .draw k next => by + classical + exact average (fun a => if bad k a then 1 else badProbability bad (next a)) + +omit [∀ k, Nonempty (Answer k)] in +/-- Erasure preserves the exact probability of an allocated bad vector, not +merely its upper bound. Deterministic work and cache hits do not draw. -/ +theorem distribution_correspondence (bad : (k : Key) → Answer k → Prop) {n} + (t : Sampling Key Answer R n) : badProbability bad t = risk bad (erase t) := by + induction t with + | ret => rfl + | draw k next ih => simp only [badProbability, erase, risk, ih] + +theorem expectation_le_one (payoff : R → ℚ) (h : ∀ r, payoff r ≤ 1) {n} + (t : Sampling Key Answer R n) : expectation payoff t ≤ 1 := by + induction t with + | ret r => exact h r + | draw k next ih => + exact (average_mono ih).trans_eq (average_const 1) + +/-- A terminal cover is checked on operational executions, including early +stops. No successful-path budget or oracle tape is supplied to the strategy. -/ +theorem failure_le_risk (bad : (k : Key) → Answer k → Prop) (failure : R → Prop) + {n} (t : Sampling Key Answer R n) + (cover : ∀ trace r, Runs t trace r → failure r → + ∃ ka ∈ trace, bad ka.1 ka.2) : + failureProbability failure t ≤ risk bad (erase t) := by + classical + induction t with + | ret r => + have hf : ¬ failure r := by + intro h + obtain ⟨ka, hk, _⟩ := cover [] r (.ret r) h + simp at hk + simp [failureProbability, expectation, erase, risk, hf] + | draw k next ih => + change average (fun a => expectation (fun r => if failure r then 1 else 0) (next a)) ≤ _ + rw [erase, risk] + apply average_mono + intro a + by_cases hb : bad k a + · simp only [ite_eq_left hb] + exact expectation_le_one _ (by intro r; split <;> norm_num) _ + · simp only [ite_eq_right hb] + apply ih a + intro trace r hr hf + obtain ⟨ka, hk, hbad⟩ := cover _ r (.draw a hr) hf + simp only [List.mem_cons] at hk + rcases hk with rfl | hk + · exact (hb hbad).elim + · exact ⟨ka, hk, hbad⟩ + +end Sampling + +section Compiler +variable {S M Q : Type u} {A : Q → Type u} +variable [DecidableEq S] [DecidableEq M] +variable (query : S × List M → Q) + +abbrev History := List (M × Sigma A) +abbrev RawCache := Cache (S × List M) (fun key => A (query key)) +abbrev FullKey := FullInput S M Q A +abbrev Fiber (key : FullKey (S := S) (M := M) (A := A)) := + A (query (key.statement, key.messages)) +abbrev Computation (R : Type u) (n : Nat) := + Sampling (FullKey (S := S) (M := M) (A := A)) (Fiber query) R n + +/-- A syntax-level bound on every request, even abandoned and rejecting branches. -/ +structure Request (S M : Type u) (B : Nat) where + statement : S + messages : List M + bounded : messages.length ≤ B + +/-- `stop` requests invisible final verification completion. The continuation +receives only the requested projection, never the cache or a total oracle. -/ +inductive Machine (S M : Type u) (A : Q → Type u) (B : Nat) : Nat → Type (u+1) where + | stop {K} (final : Request S M B) : Machine S M A B K + | ask {K} (request : Request S M B) (R : Type u) + (project : History (M := M) (A := A) → R) + (next : R → Machine S M A B K) : Machine S M A B (K+1) + +/-- Recursive ancestor completion. Raw cache keys are globally shared; a miss +samples the full canonical key containing the ancestors just completed. -/ +def completeCausal (s : S) : (p : List M) → RawCache (A := A) query → + Computation (A := A) query (Allocation query A) p.length + | [], cache => .ret ⟨[], cache, 0⟩ + | m :: p, cache => + Sampling.bind (completeCausal s p cache) (fun past => + match past.cache (s, m :: p) with + | some a => .ret ⟨(m, ⟨query (s,m::p),a⟩) :: past.history, past.cache, past.fresh⟩ + | none => .draw ⟨s, m :: p, past.history⟩ (fun a => + .ret ⟨(m, ⟨query (s,m::p),a⟩) :: past.history, + put past.cache (s,m::p) a, past.fresh + 1⟩)) + +theorem completeCausal_reference (oracle : Oracle (A := A) query) (s : S) (p : List M) + (cache : RawCache (A := A) query) : + Sampling.eval oracle (completeCausal query s p cache) = allocate query oracle s p cache := by + induction p generalizing cache with + | nil => rfl + | cons m p ih => + rw [completeCausal, Sampling.eval_bind, ih] + simp only [allocate] + split <;> rename_i h <;> simp [h, Sampling.eval, put] + +/-- The deterministic reference invariant therefore holds for the causal +interpreter, without exposing the reference oracle to any continuation. -/ +theorem completeCausal_correct (oracle : Oracle (A := A) query) (s : S) (p : List M) + (cache : RawCache (A := A) query) (correct : CacheCorrect query oracle cache) : + (Sampling.eval oracle (completeCausal query s p cache)).history = complete query oracle s p ∧ + CacheCorrect query oracle (Sampling.eval oracle (completeCausal query s p cache)).cache := by + rw [completeCausal_reference] + exact allocate_correct query oracle s p cache correct + +/-- Existing entries are immutable, independently of the statement or clone +currently being completed. This property does not need cache correctness. -/ +theorem allocate_preserves (oracle : Oracle (A := A) query) (s : S) (p : List M) + (cache : RawCache (A := A) query) (key : S × List M) (x : A (query key)) + (hit : cache key = some x) : + (allocate query oracle s p cache).cache key = some x := by + induction p with + | nil => exact hit + | cons m p ih => + simp only [allocate] + split + · exact ih + · rename_i miss + have ne : key ≠ (s,m::p) := by + intro he + subst key + rw [ih] at miss + contradiction + simpa only [Function.update_of_ne ne] using ih + +/-- Exact allocation count for the executable interpreter. A cache hit adds +zero trace entries; a miss adds exactly one full-vector entry. -/ +theorem completeCausal_count (oracle : Oracle (A := A) query) (s : S) (p : List M) + (cache : RawCache (A := A) query) : + (Sampling.execute oracle (completeCausal query s p cache)).2.length = + (allocate query oracle s p cache).fresh := by + induction p generalizing cache with + | nil => rfl + | cons m p ih => + rw [completeCausal, Sampling.execute_bind, completeCausal_reference] + simp only [allocate] + split <;> rename_i h <;> simp [h, Sampling.execute, ih] + +theorem completeCausal_preserves_every (s : S) (p : List M) + (cache : RawCache (A := A) query) (key : S × List M) (x : A (query key)) + (hit : cache key = some x) : + Sampling.Every (fun a => a.cache key = some x) (completeCausal query s p cache) := by + induction p with + | nil => exact hit + | cons m p ih => + rw [completeCausal, Sampling.every_bind] + apply ih.mono + intro past hp + split + · exact hp + · rename_i miss + intro a + have ne : key ≠ (s,m::p) := by + intro he + subst key + rw [hp] at miss + contradiction + simpa only [Sampling.Every, put_other _ _ _ _ ne] using hp + +structure Terminal (B : Nat) where + request : Request S M B + allocation : Allocation query A + +def completeRequest {B} (request : Request S M B) (cache : RawCache (A := A) query) : + Computation (A := A) query (Allocation query A) B := + Sampling.pad request.bounded (completeCausal query request.statement request.messages cache) + +def compile {B K} (machine : Machine S M A B K) (cache : RawCache (A := A) query) : + Computation (A := A) query (Terminal (A := A) query B) (B * (K+1)) := + match machine with + | .stop final => + Sampling.pad (by simp only [Nat.mul_add, Nat.mul_one]; omega) (Sampling.bind (completeRequest query final cache) + (fun a => Sampling.ret (n := 0) ⟨final,a⟩)) + | @Machine.ask _ _ _ _ _ K request R project next => + Sampling.pad (by simp only [Nat.mul_add, Nat.mul_one]; omega) (Sampling.bind (completeRequest query request cache) + (fun a => compile (next (project a.history)) a.cache)) + +/-- Functional reference execution of the same adaptive syntax. -/ +def reference (oracle : Oracle (A := A) query) {B K} + (machine : Machine S M A B K) (cache : RawCache (A := A) query) : + Terminal (A := A) query B := + match machine with + | .stop final => ⟨final, allocate query oracle final.statement final.messages cache⟩ + | .ask request _ project next => + let a := allocate query oracle request.statement request.messages cache + reference oracle (next (project a.history)) a.cache + +theorem compile_reference (oracle : Oracle (A := A) query) {B K} + (machine : Machine S M A B K) (cache : RawCache (A := A) query) : + Sampling.eval oracle (compile query machine cache) = reference query oracle machine cache := by + induction machine generalizing cache with + | stop final => simp [compile, reference, completeRequest, completeCausal_reference, Sampling.eval] + | ask request R project next ih => + simp only [compile, Sampling.eval_pad, Sampling.eval_bind, completeRequest, + completeCausal_reference, reference] + exact ih _ _ + +/-- One global cache survives all adaptive requests and final completion. +In particular, switching statements or selecting a clone cannot reset it. -/ +theorem compile_preserves (oracle : Oracle (A := A) query) {B K} + (machine : Machine S M A B K) (cache : RawCache (A := A) query) + (key : S × List M) (x : A (query key)) (hit : cache key = some x) : + (Sampling.eval oracle (compile query machine cache)).allocation.cache key = some x := by + rw [compile_reference] + induction machine generalizing cache with + | stop final => exact allocate_preserves query oracle _ _ cache key x hit + | ask request R project next ih => + exact ih _ _ (allocate_preserves query oracle _ _ cache key x hit) + +theorem compile_correct (oracle : Oracle (A := A) query) {B K} + (machine : Machine S M A B K) (cache : RawCache (A := A) query) + (correct : CacheCorrect query oracle cache) : + CacheCorrect query oracle + (Sampling.eval oracle (compile query machine cache)).allocation.cache := by + rw [compile_reference] + induction machine generalizing cache with + | stop final => exact (allocate_correct query oracle _ _ cache correct).2 + | ask request R project next ih => + exact ih _ _ (allocate_correct query oracle _ _ cache correct).2 + +theorem compile_preserves_every {B K} (machine : Machine S M A B K) + (cache : RawCache (A := A) query) (key : S × List M) (x : A (query key)) + (hit : cache key = some x) : + Sampling.Every (fun r => r.allocation.cache key = some x) (compile query machine cache) := by + induction machine generalizing cache with + | stop final => + simp only [compile, Sampling.every_pad, Sampling.every_bind, completeRequest, Sampling.Every] + exact completeCausal_preserves_every query _ _ cache key x hit + | ask request R project next ih => + simp only [compile, Sampling.every_pad, Sampling.every_bind, completeRequest] + exact (completeCausal_preserves_every query _ _ cache key x hit).mono + (fun past hp => ih _ past.cache hp) + +/-- Global-cache immutability for every operational branch, not only those +evaluated against a preselected oracle table. -/ +theorem compile_runs_preserves {B K} (machine : Machine S M A B K) + (cache : RawCache (A := A) query) (key : S × List M) (x : A (query key)) + (hit : cache key = some x) {trace result} + (run : Sampling.Runs (compile query machine cache) trace result) : + result.allocation.cache key = some x := + run.postcondition (compile_preserves_every query machine cache key x hit) + +/-- All executions have the resource cap, not just accepted terminal paths. -/ +theorem compile_cap {B K} (machine : Machine S M A B K) (cache : RawCache (A := A) query) + {trace result} (run : Sampling.Runs (compile query machine cache) trace result) : + trace.length ≤ B * (K+1) := run.length_le + +/-- A completed history can be read solely from the current partial cache. -/ +inductive CachedHistory (cache : RawCache (A := A) query) (s : S) : + List M → History (M := M) (A := A) → Prop where + | nil : CachedHistory cache s [] [] + | cons {m p history} (a : A (query (s,m::p))) + (older : CachedHistory cache s p history) (hit : cache (s,m::p) = some a) : + CachedHistory cache s (m::p) ((m,⟨query (s,m::p),a⟩)::history) + +omit [DecidableEq S] [DecidableEq M] in +theorem CachedHistory.mono {cache next : RawCache (A := A) query} {s p history} + (h : CachedHistory query cache s p history) + (growth : ∀ key a, cache key = some a → next key = some a) : + CachedHistory query next s p history := by + induction h with + | nil => exact .nil + | cons a older hit ih => exact .cons a ih (growth _ _ hit) + +omit [DecidableEq S] [DecidableEq M] in +theorem CachedHistory.unique {cache : RawCache (A := A) query} {s p left right} + (hl : CachedHistory query cache s p left) (hr : CachedHistory query cache s p right) : + left = right := by + induction hl generalizing right with + | nil => cases hr; rfl + | cons a older hit ih => + cases hr with + | cons b prior hb => + have hab : a = b := Option.some.inj (hit.symm.trans hb) + subst b + rw [ih prior] + +/-- Every cached answer remembers an actual earlier allocation at its exact +full key. Ancestors are read from the same immutable global cache. -/ +def CacheRecorded (cache : RawCache (A := A) query) + (trace : List (Sigma (Fiber (A := A) query))) : Prop := + ∀ s m p a, cache (s,m::p) = some a → + ∃ history, CachedHistory query cache s p history ∧ + (⟨⟨s,m::p,history⟩,a⟩ : Sigma (Fiber query)) ∈ trace + +omit [DecidableEq S] [DecidableEq M] in +theorem empty_cache_recorded : + CacheRecorded (A := A) query (fun _ => none) [] := by + intro s m p a h + cases h + +omit [DecidableEq S] [DecidableEq M] in +theorem CacheRecorded.mono_trace {cache : RawCache (A := A) query} {trace more} + (h : CacheRecorded query cache trace) (subset : ∀ x ∈ trace, x ∈ more) : + CacheRecorded query cache more := by + intro s m p a hit + obtain ⟨history, hc, ht⟩ := h s m p a hit + exact ⟨history,hc,subset _ ht⟩ + +theorem CacheRecorded.insert {cache : RawCache (A := A) query} {trace s m p history} + (h : CacheRecorded query cache trace) (past : CachedHistory query cache s p history) + (miss : cache (s,m::p) = none) (a : A (query (s,m::p))) : + CacheRecorded query (put cache (s,m::p) a) + (trace ++ [⟨⟨s,m::p,history⟩,a⟩]) := by + have growth : ∀ key x, cache key = some x → put cache (s,m::p) a key = some x := by + intro key x hx + have ne : key ≠ (s,m::p) := by + intro he + subst key + rw [miss] at hx + contradiction + simpa only [put_other _ _ _ _ ne] using hx + intro t n q b hb + by_cases he : (t,n::q) = (s,m::p) + · cases he + simp only [put_self, Option.some.injEq] at hb + subst b + exact ⟨history,CachedHistory.mono query past growth,by simp⟩ + · rw [put_other _ _ _ _ he] at hb + obtain ⟨older, hc, ht⟩ := h t n q b hb + exact ⟨older,CachedHistory.mono query hc growth,List.mem_append_left _ ht⟩ + +/-- Completion preserves the trace provenance invariant and reconstructs the +returned history from the final cache, on every operational branch. -/ +theorem completeCausal_recorded (s : S) (p : List M) + (cache : RawCache (A := A) query) {before trace result} + (recorded : CacheRecorded query cache before) + (run : Sampling.Runs (completeCausal query s p cache) trace result) : + CachedHistory query result.cache s p result.history ∧ + CacheRecorded query result.cache (before ++ trace) := by + induction p generalizing cache before trace result with + | nil => + cases run + exact ⟨.nil, by simpa using recorded⟩ + | cons m p ih => + rw [completeCausal, Sampling.runs_bind] at run + obtain ⟨firstTrace, past, lastTrace, ht, first, last⟩ := run + obtain ⟨hp, hs⟩ := ih cache recorded first + subst trace + split at last + · rename_i a hit + cases last + exact ⟨.cons a hp hit, by simpa using hs⟩ + · rename_i miss + cases last with + | draw a rest => + cases rest + have growth : ∀ key x, past.cache key = some x → + put past.cache (s,m::p) a key = some x := by + intro key x hx + have ne : key ≠ (s,m::p) := by + intro he + subst key + rw [miss] at hx + contradiction + simpa only [put_other _ _ _ _ ne] using hx + exact ⟨.cons a (CachedHistory.mono query hp growth) (put_self _ _ _), + by simpa only [List.append_assoc] using CacheRecorded.insert query hs hp miss a⟩ + +/-- Full-key/value membership, recursively for every ancestor in a completed +history. Unlike raw-key coverage this also fixes the completed ancestor vector. -/ +inductive HistoryRecorded (s : S) (trace : List (Sigma (Fiber (A := A) query))) : + List M → History (M := M) (A := A) → Prop where + | nil : HistoryRecorded s trace [] [] + | cons {m p history} (a : A (query (s,m::p))) + (older : HistoryRecorded s trace p history) + (allocated : (⟨⟨s,m::p,history⟩,a⟩ : Sigma (Fiber query)) ∈ trace) : + HistoryRecorded s trace (m::p) ((m,⟨query (s,m::p),a⟩)::history) + +omit [DecidableEq S] [DecidableEq M] in +theorem HistoryRecorded.erases {s trace p history} + (h : HistoryRecorded (A := A) query s trace p history) : history.map Prod.fst = p := by + induction h with + | nil => rfl + | cons a older allocated ih => simp [ih] + +omit [DecidableEq S] [DecidableEq M] in +theorem HistoryRecorded.at_index {s trace p history} + (h : HistoryRecorded (A := A) query s trace p history) (i : Nat) (hi : i < p.length) : + ∃ m tail past, ∃ a : A (query (s,m::tail)), + p.drop i = m::tail ∧ history.drop i = (m,⟨query (s,m::tail),a⟩)::past ∧ + (⟨⟨s,m::tail,past⟩,a⟩ : Sigma (Fiber query)) ∈ trace := by + induction h generalizing i with + | nil => simp at hi + | @cons m p history a older allocated ih => + cases i with + | zero => exact ⟨m,p,history,a,rfl,rfl,allocated⟩ + | succ i => + simpa only [List.drop_succ_cons] using ih i (by simpa using hi) + +omit [DecidableEq S] [DecidableEq M] in +theorem CachedHistory.recorded {cache : RawCache (A := A) query} {s p history trace} + (hc : CachedHistory query cache s p history) (ht : CacheRecorded query cache trace) : + HistoryRecorded query s trace p history := by + induction hc with + | nil => exact .nil + | @cons m p history a older hit ih => + obtain ⟨past,hp,hm⟩ := ht s m p a hit + have he := CachedHistory.unique query hp older + subst past + exact .cons a ih hm + +theorem compile_recorded {B K} (machine : Machine S M A B K) + (cache : RawCache (A := A) query) {before trace result} + (recorded : CacheRecorded query cache before) + (run : Sampling.Runs (compile query machine cache) trace result) : + HistoryRecorded query result.request.statement (before ++ trace) + result.request.messages result.allocation.history := by + induction machine generalizing cache before trace result with + | stop final => + simp only [compile, Sampling.runs_pad, Sampling.runs_bind] at run + obtain ⟨firstTrace, past, lastTrace, ht, first, last⟩ := run + cases last + simp only [completeRequest, Sampling.runs_pad] at first + obtain ⟨hc,hr⟩ := completeCausal_recorded query _ _ cache recorded first + simpa only [ht, List.append_nil] using CachedHistory.recorded query hc hr + | ask request R project next ih => + simp only [compile, Sampling.runs_pad, Sampling.runs_bind] at run + obtain ⟨firstTrace, past, lastTrace, ht, first, last⟩ := run + simp only [completeRequest, Sampling.runs_pad] at first + obtain ⟨_,hr⟩ := completeCausal_recorded query _ _ cache recorded first + have hf := ih _ past.cache hr last + simpa only [ht, List.append_assoc] using hf + +/-- Every final ancestor, including cache hits allocated on earlier branches, +has its exact canonical full-key/value pair in the actual allocation trace. -/ +theorem final_history_in_trace {B K} (machine : Machine S M A B K) {trace result} + (run : Sampling.Runs (compile query machine (fun _ => none)) trace result) : + HistoryRecorded query result.request.statement trace + result.request.messages result.allocation.history := by + simpa using compile_recorded query machine _ (empty_cache_recorded query) run + +theorem final_ancestor_allocated {B K} (machine : Machine S M A B K) {trace result} + (run : Sampling.Runs (compile query machine (fun _ => none)) trace result) + (i : Nat) (hi : i < result.request.messages.length) : + ∃ m tail past, ∃ a : A (query (result.request.statement,m::tail)), + result.request.messages.drop i = m::tail ∧ + result.allocation.history.drop i = + (m,⟨query (result.request.statement,m::tail),a⟩)::past ∧ + (⟨⟨result.request.statement,m::tail,past⟩,a⟩ : Sigma (Fiber query)) ∈ trace := + HistoryRecorded.at_index query (final_history_in_trace query machine run) i hi + +variable [∀ q, Fintype (A q)] [∀ q, Nonempty (A q)] +open Classical + +/-- Direct lazy-sampling semantics of the adaptive machine. Ancestors are +completed before the projected answer is passed to the continuation. -/ +noncomputable def operationalExpectation {B K} (payoff : Terminal (A := A) query B → ℚ) + (machine : Machine S M A B K) (cache : RawCache (A := A) query) : ℚ := + match machine with + | .stop final => + Sampling.expectation (fun a => payoff ⟨final, a⟩) + (completeCausal query final.statement final.messages cache) + | .ask request _ project next => + Sampling.expectation + (fun a => operationalExpectation payoff (next (project a.history)) a.cache) + (completeCausal query request.statement request.messages cache) + +omit [∀ q, Nonempty (A q)] in +/-- Exact equality for every terminal payoff, hence the entire terminal +distribution, between the direct machine interpreter and its compiled tree. -/ +theorem compile_distribution {B K} (payoff : Terminal (A := A) query B → ℚ) + (machine : Machine S M A B K) (cache : RawCache (A := A) query) : + Sampling.expectation payoff (compile query machine cache) = + operationalExpectation query payoff machine cache := by + induction machine generalizing cache with + | stop final => + simp [compile, Sampling.expectation_bind, Sampling.expectation, completeRequest, + operationalExpectation] + | ask request R project next ih => + simp only [compile, Sampling.expectation_pad, Sampling.expectation_bind, + completeRequest, ih, operationalExpectation] + +theorem compiler_risk_bound {B K} (machine : Machine S M A B K) + (bad : (key : FullKey (S := S) (M := M) (A := A)) → Fiber query key → Prop) + (epsilon : ℚ) (nonneg : 0 ≤ epsilon) + (sparse : ∀ key, average (fun a => if bad key a then 1 else 0) ≤ epsilon) : + Sampling.badProbability bad (compile query machine (fun _ => none)) ≤ + (B * (K+1)) * epsilon := by + rw [Sampling.distribution_correspondence] + simpa only [Nat.cast_mul, Nat.cast_add, Nat.cast_one] using + risk_bound bad epsilon nonneg sparse (Sampling.erase (compile query machine (fun _ => none))) + +theorem compiler_failure_bound {B K} (machine : Machine S M A B K) + (bad : (key : FullKey (S := S) (M := M) (A := A)) → Fiber query key → Prop) + (failure : Terminal (A := A) query B → Prop) + (epsilon : ℚ) (nonneg : 0 ≤ epsilon) + (sparse : ∀ key, average (fun a => if bad key a then 1 else 0) ≤ epsilon) + (cover : ∀ trace result, Sampling.Runs (compile query machine (fun _ => none)) trace result → + failure result → ∃ ka ∈ trace, bad ka.1 ka.2) : + Sampling.failureProbability failure (compile query machine (fun _ => none)) ≤ + ((B * (K+1) : Nat) : ℚ) * epsilon := + (Sampling.failure_le_risk bad failure _ cover).trans + (risk_bound bad epsilon nonneg sparse _) + +end Compiler +end Whir.TypedOracleCompiler diff --git a/verification/whir/Whir/VerifierInvariant.lean b/verification/whir/Whir/VerifierInvariant.lean new file mode 100644 index 000000000..e0c03f8a3 --- /dev/null +++ b/verification/whir/Whir/VerifierInvariant.lean @@ -0,0 +1,101 @@ +import Whir.ArrayAlgebra +import Whir.ReplayRefinement +import Whir.Soundness + +/-! The lost invariant is about arbitrary received messages, not honest-prover +traces. Candidate lifting is separated from polynomial collision events so the +coding-theoretic obligation cannot disappear inside a composition hypothesis. -/ +namespace Whir.VerifierInvariant +open Concrete Protocol Polynomial +open scoped BigOperators + +variable {F : Type*} [Field F] [Fintype F] [DecidableEq F] [Inhabited F] [CharP F 2] + +/-- The polynomial represented by the actual transmitted pair and running claim. -/ +noncomputable def messagePolynomial (message : Message F) (claim : F) : F[X] := + C message.u2 * X ^ 2 + C (claim + message.u2) * X + C message.u0 + +omit [Fintype F] [DecidableEq F] [Inhabited F] [CharP F 2] in +@[simp] theorem messagePolynomial_eval (message : Message F) (claim r : F) : + (messagePolynomial message claim).eval r = message.eval claim r := by + simp only [messagePolynomial, eval_add, eval_mul, eval_pow, eval_C, eval_X, Message.eval] + ring + +omit [Fintype F] [DecidableEq F] [Inhabited F] [CharP F 2] in +theorem messagePolynomial_degree (message : Message F) (claim : F) : + (messagePolynomial message claim).natDegree ≤ 2 := natDegree_quadratic_le + +omit [Fintype F] [DecidableEq F] [Inhabited F] in +theorem messagePolynomial_endpoints (message : Message F) (claim : F) : + (messagePolynomial message claim).eval 0 + (messagePolynomial message claim).eval 1 = claim := by + simp only [messagePolynomial_eval, ArrayAlgebra.message_eval] + exact Whir.compactRound_endpoints claim message.u0 message.u2 + +/-- Every commitment-fixed candidate violates the current weighted claim. -/ +def Lost (candidates : Finset (Array F)) (state : VerifierState F) : Prop := + ∀ witness ∈ candidates, dot witness state.weight ≠ state.claim + +noncomputable def roundBad (candidates : Finset (Array F)) (state : VerifierState F) + (block : Nat) : Finset F := by + classical + exact Finset.univ.filter fun r => ∃ witness ∈ candidates, + (roundMessage witness state.weight block).eval (dot witness state.weight) r = + state.message.eval state.claim r + +omit [Fintype F] [DecidableEq F] in +/-- A false running claim forces distinct polynomials even for a malicious intro. -/ +theorem false_candidate_polynomials (state : VerifierState F) (witness : Array F) + (block : Nat) (falseClaim : dot witness state.weight ≠ state.claim) : + messagePolynomial (roundMessage witness state.weight block) (dot witness state.weight) ≠ + messagePolynomial state.message state.claim := by + apply Soundness.false_claim_distinct _ _ state.claim + · simpa only [messagePolynomial_endpoints] using falseClaim + · exact messagePolynomial_endpoints _ _ + +/-- Actual compressed-message collisions cost at most two roots per candidate. -/ +theorem roundBad_probability (candidates : Finset (Array F)) (state : VerifierState F) + (block : Nat) (lost : Lost candidates state) : + Soundness.uniformProb (roundBad candidates state block) ≤ + (candidates.card : ℚ) * (2 / (Fintype.card F : ℚ)) := by + classical + let events : candidates → Finset F := fun witness => Finset.univ.filter fun r => + (messagePolynomial (roundMessage witness.val state.weight block) + (dot witness.val state.weight)).eval r = + (messagePolynomial state.message state.claim).eval r + have heq : roundBad candidates state block = Finset.univ.biUnion events := by + ext r + simp [roundBad, events] + rw [heq] + calc + _ ≤ ∑ witness : candidates, Soundness.uniformProb (events witness) := Soundness.union_bound events + _ ≤ ∑ _witness : candidates, (2 : ℚ) / Fintype.card F := by + apply Finset.sum_le_sum + intro witness _ + exact Soundness.round_error _ _ + (false_candidate_polynomials state witness.val block (lost _ witness.property)) 2 + (messagePolynomial_degree _ _) (messagePolynomial_degree _ _) + _ = _ := by simp + +/-- The next pending message is arbitrary. Only list lifting and avoidance of the +explicit root event are needed for preservation through the actual fold helper. -/ +theorem fold_lost (oldCandidates newCandidates : Finset (Array F)) + (state : VerifierState F) (block lanes : Nat) (r : F) (next : Message F) + (shape : ∀ witness ∈ oldCandidates, witness.size = (lanes * 2) * block) + (weights : ∀ witness ∈ oldCandidates, state.weight.size = witness.size) + (lifts : ∀ folded ∈ newCandidates, ∃ witness ∈ oldCandidates, + folded = foldValues witness block r) + (outside : r ∉ roundBad oldCandidates state block) : + Lost newCandidates (state.fold block r next) := by + intro folded hfolded heq + obtain ⟨witness, hwitness, rfl⟩ := lifts folded hfolded + apply outside + apply Finset.mem_filter.mpr + refine ⟨Finset.mem_univ _, witness, hwitness, ?_⟩ + rw [show (roundMessage witness state.weight block).eval (dot witness state.weight) r = + dot (foldValues witness block r) (foldValues state.weight block r) by + simp only [ReplayRefinement.foldValues_eq_lane] + exact ArrayAlgebra.honest_foldLane witness state.weight block lanes + (shape witness hwitness) (weights witness hwitness) r] + exact heq + +end Whir.VerifierInvariant diff --git a/verification/whir/Whir/WHIRCallerOutputs.lean b/verification/whir/Whir/WHIRCallerOutputs.lean new file mode 100644 index 000000000..90efeda1d --- /dev/null +++ b/verification/whir/Whir/WHIRCallerOutputs.lean @@ -0,0 +1,234 @@ +import Whir.WHIRCallerShape + +/-! Prior caller outputs are real compression queries at strict history prefixes. Their count is bounded by the public caller shape, not by compression path length: a consumed cursor is encoded data and can name many output blocks. No oracle table is exposed by this enumeration; a resolver must obtain these particular answers through its global cache. -/ +namespace Whir.WHIRCallerOutputs +open Concrete FiatShamirGame DuplexRefinement DuplexEncoding + +def previousConsumed : Frame → Nat + | .absorb n _ => n + | .nonce n _ _ => n + +def outputBlocks (n : Nat) : Nat := (n + 31) / 32 + +def callerOutputCount (frames : List Frame) : Nat := + (frames.map (fun f => outputBlocks (previousConsumed f))).sum + +def outputsFrom (entry : FramedHistory) (pre : List Frame) : List Frame → List Coordinate + | [] => [] + | f :: fs => + (List.range (outputBlocks (previousConsumed f))).map + (fun block => ⟨{entry with frames := pre},.output block⟩) ++ + outputsFrom entry (pre ++ [f]) fs + +def callerOutputs (entry : FramedHistory) : List Coordinate := + outputsFrom entry [] entry.frames + +theorem outputsFrom_length (entry : FramedHistory) (pre frames : List Frame) : + (outputsFrom entry pre frames).length = callerOutputCount frames := by + induction frames generalizing pre with + | nil => rfl + | cons f fs ih => simp [outputsFrom, callerOutputCount, ih] + +theorem callerOutputs_length (entry : FramedHistory) : + (callerOutputs entry).length = callerOutputCount entry.frames := outputsFrom_length _ _ _ + +theorem outputsFrom_mem (entry : FramedHistory) (pre frames : List Frame) (q : Coordinate) + (mem : q ∈ outputsFrom entry pre frames) : + ∃ middle f suffix block, frames = middle ++ f :: suffix ∧ + block < outputBlocks (previousConsumed f) ∧ + q = ⟨{entry with frames := pre ++ middle},.output block⟩ := by + induction frames generalizing pre with + | nil => simp [outputsFrom] at mem + | cons f fs ih => + rcases List.mem_append.mp mem with head | tail + · obtain ⟨block,hb,hq⟩ := List.mem_map.mp head + exact ⟨[],f,fs,block,rfl,List.mem_range.mp hb,by simpa using hq.symm⟩ + · obtain ⟨middle,g,suffix,block,eqn,hb,hq⟩ := ih (pre ++ [f]) tail + refine ⟨f :: middle,g,suffix,block,by simp [eqn],hb,?_⟩ + simpa [List.append_assoc] using hq + +theorem callerOutputs_mem (entry : FramedHistory) (q : Coordinate) (mem : q ∈ callerOutputs entry) : + ∃ pre f suffix block, entry.frames = pre ++ f :: suffix ∧ + block < outputBlocks (previousConsumed f) ∧ + q = ⟨{entry with frames := pre},.output block⟩ := by + simpa using outputsFrom_mem entry [] entry.frames q mem + +theorem outputsFrom_append (entry : FramedHistory) (pre a b : List Frame) : + outputsFrom entry pre (a ++ b) = + outputsFrom entry pre a ++ outputsFrom entry (pre ++ a) b := by + induction a generalizing pre with + | nil => simp [outputsFrom] + | cons f fs ih => simp [outputsFrom, ih, List.append_assoc] + +theorem callerOutput_mem (entry : FramedHistory) (pre : List Frame) (f : Frame) + (suffix : List Frame) (block : Nat) (split : entry.frames = pre ++ f :: suffix) + (bound : block < outputBlocks (previousConsumed f)) : + (⟨{entry with frames := pre},.output block⟩ : Coordinate) ∈ callerOutputs entry := by + unfold callerOutputs + rw [split, outputsFrom_append] + apply List.mem_append_right + simp only [List.nil_append, outputsFrom] + apply List.mem_append_left + exact List.mem_map.mpr ⟨block,List.mem_range.mpr bound,rfl⟩ + +theorem callerOutputs_strict_prefix (entry : FramedHistory) (q : Coordinate) + (mem : q ∈ callerOutputs entry) : + q.history.domain = entry.domain ∧ q.history.statement = entry.statement ∧ + q.history.frames.length < entry.frames.length ∧ + q.history.frames = entry.frames.take q.history.frames.length := by + obtain ⟨pre,f,suffix,block,split,_,rfl⟩ := callerOutputs_mem entry q mem + simp [split] + +theorem callerOutputs_admissible (entry : FramedHistory) + (valid : ∀ f ∈ entry.frames, FrameValid f) (q : Coordinate) (mem : q ∈ callerOutputs entry) : + Admissible q := by + obtain ⟨pre,f,suffix,block,split,bound,rfl⟩ := callerOutputs_mem entry q mem + have hf := valid f (by simp [split]) + have hp : previousConsumed f < 2^49 := by cases f <;> exact hf.1 + refine ⟨?_,?_⟩ + · intro g hg + exact valid g (by simp only [split, List.mem_append, List.mem_cons]; exact Or.inl hg) + · change block < 2^44 + unfold outputBlocks at bound + omega + +theorem callerOutputs_reachable_admissible (c : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (reachable : Reachable c iv domain statement m s) + (q : Coordinate) (mem : q ∈ callerOutputs (closeRun m).history) : Admissible q := + callerOutputs_admissible _ (WHIRCallerPrefix.reachable_entry_frameValid _ _ _ _ reachable) q mem + +theorem callerOutputs_pathCost_le (entry : FramedHistory) (q : Coordinate) + (mem : q ∈ callerOutputs entry) (terminal : Terminal) : + DuplexFraming.pathCost q ≤ DuplexFraming.pathCost ⟨entry,terminal⟩ := by + obtain ⟨pre,f,suffix,block,split,_,rfl⟩ := callerOutputs_mem entry q mem + simp [DuplexFraming.pathCost, plan, split, List.flatMap_append] + omega + +theorem callerOutputs_extended_pathCost_le (entry : FramedHistory) (q : Coordinate) + (mem : q ∈ callerOutputs entry) (suffix : List Frame) (terminal : Terminal) : + DuplexFraming.pathCost q ≤ DuplexFraming.pathCost ⟨{entry with frames := entry.frames ++ suffix},terminal⟩ := by + have h := callerOutputs_pathCost_le entry q mem terminal + apply h.trans + simp [DuplexFraming.pathCost, plan, List.flatMap_append] + +/-- Recover only requested output bytes from answers already obtained for their keys. -/ +def recoveredBytes (answers : Coordinate → Digest32) (history : FramedHistory) (offset n : Nat) : List Byte := + List.ofFn (fun i : Fin n => answers ⟨history,.output ((offset+i.val)/32)⟩ + ⟨(offset+i.val)%32,Nat.mod_lt _ (by decide)⟩) + +theorem stream_ofFn (c : Compression) (cv : Digest32) (offset n : Nat) : + stream c cv offset n = List.ofFn (fun i : Fin n => + outputBlock c cv ((offset+i.val)/32) ⟨(offset+i.val)%32,Nat.mod_lt _ (by decide)⟩) := by + induction n generalizing offset with + | zero => simp [stream] + | succ n ih => + simp [stream, List.ofFn_succ, ih, Nat.add_comm, Nat.add_left_comm] + +theorem callerBytes_recovery (c : Compression) (iv : Digest32) (entry : FramedHistory) + (answers : Coordinate → Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) + (pre : List Frame) (f : Frame) (suffix : List Frame) + (split : entry.frames = pre ++ f :: suffix) (offset n : Nat) + (within : offset + n ≤ previousConsumed f) : + recoveredBytes answers {entry with frames := pre} offset n = + stream c (evalHistory c iv {entry with frames := pre}) offset n := by + rw [stream_ofFn] + unfold recoveredBytes + congr 1 + funext i + have bound : (offset+i.val)/32 < outputBlocks (previousConsumed f) := by + have hi := i.isLt + unfold outputBlocks + omega + rw [observed _ (callerOutput_mem entry pre f suffix _ split bound)] + rfl + +theorem actual_callerBytes_recovery (c : Compression) (iv : Digest32) (entry : FramedHistory) + (answers : Coordinate → Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) + (pre : List Frame) (f : Frame) (suffix : List Frame) + (split : entry.frames = pre ++ f :: suffix) (m : Model) (s t : State) + (represented : Represents c iv m s) + (history : (closeRun m).history = {entry with frames := pre}) + (n : Nat) (bytes : List Byte) (ok : squeeze c s n = .ok (t,bytes)) + (within : m.consumed + n ≤ previousConsumed f) : + recoveredBytes answers {entry with frames := pre} m.consumed n = bytes := by + rw [squeeze_frame_bytes c iv m s t represented n bytes ok, history] + exact callerBytes_recovery c iv entry answers observed pre f suffix split _ _ within + +end Whir.WHIRCallerOutputs + +namespace Whir.WHIRCallerShape +open FiatShamirGame DuplexRefinement WHIRCallerOutputs + +/-- Exact accumulated caller output-block count paired with the existing control abstraction. -/ +def abstractOutputs (m : Model) : StateShape × Nat := + (abstractModel m,callerOutputCount m.history.frames) + +def closeOutputs (s : StateShape × Nat) : StateShape × Nat := + (closeShape s.1, s.2 + if s.1.run = 0 then 0 else outputBlocks s.1.previous) + +def applyOutputs (s : StateShape × Nat) (event : EventShape) : StateShape × Nat := + (applyShape s.1 event, match event with + | .absorb _ => s.2 + | .squeeze n => if n = 0 then s.2 else (closeOutputs s).2 + | .nonce _ => (closeOutputs s).2 + outputBlocks s.1.consumed) + +def runOutputs (s : StateShape × Nat) (events : List EventShape) : StateShape × Nat := + events.foldl applyOutputs s + +theorem abstract_closeOutputs (m : Model) : + abstractOutputs (closeRun m) = closeOutputs (abstractOutputs m) := by + apply Prod.ext + · exact abstract_closeRun m + · by_cases h : m.run = [] <;> + simp [abstractOutputs, closeOutputs, closeRun, abstractModel, h, + callerOutputCount, previousConsumed, List.map_append] + +theorem abstract_applyOutputs (m : Model) (op : Operation) : + abstractOutputs (applyOperation m op) = applyOutputs (abstractOutputs m) (operationShape op) := by + apply Prod.ext + · exact abstract_applyOperation m op + · cases op with + | absorb bs => + by_cases h : bs = [] <;> simp [applyOperation, modelAbsorb, applyOutputs, operationShape, abstractOutputs, h] + | squeeze n => + by_cases h : n = 0 + · simp [applyOperation, modelSqueeze, applyOutputs, operationShape, abstractOutputs, h] + · simpa [applyOperation, modelSqueeze, applyOutputs, operationShape, abstractOutputs, h] using + congrArg Prod.snd (abstract_closeOutputs m) + | nonce bits value => + have hc : (closeRun m).consumed = m.consumed := by + by_cases h : m.run = [] <;> simp [closeRun, h] + have he := congrArg Prod.snd (abstract_closeOutputs m) + simp only [abstractOutputs] at he + simp only [applyOperation, modelNonce, applyOutputs, operationShape, abstractOutputs, + callerOutputCount, List.map_append, List.map_cons, List.map_nil, + List.sum_append, List.sum_cons, List.sum_nil, Nat.add_zero, previousConsumed, hc] + exact congrArg (fun n => n + outputBlocks m.consumed) he + +theorem abstract_runOutputs (m : Model) (ops : List Operation) : + abstractOutputs (runOperations m ops) = runOutputs (abstractOutputs m) (ops.map operationShape) := by + induction ops generalizing m with + | nil => rfl + | cons op ops ih => + simp only [runOperations, runOutputs, List.foldl_cons, List.map_cons] at ih ⊢ + rw [ih, abstract_applyOutputs] + +/-- A concrete public cap; unlike path cost it accounts for every prior output block. -/ +def callerOutputCap (shape : List EventShape) : Nat := + (closeOutputs (runOutputs (⟨0,0,0,0⟩,0) shape)).2 + +theorem normalized_callerOutputCount (domain statement : Digest32) (ops : List Operation) : + callerOutputCount (closeRun (runOperations (seedModel domain statement) ops)).history.frames = + callerOutputCap (ops.map operationShape) := by + exact congrArg Prod.snd + ((abstract_closeOutputs _).trans (congrArg closeOutputs (abstract_runOutputs _ _))) + +theorem normalized_modelEvents_outputCount (domain statement : Digest32) + (events : List WHIRHistory.Event) : + callerOutputCount (closeRun (WHIRHistory.modelEvents (seedModel domain statement) events)).history.frames = + callerOutputCap (events.map (operationShape ∘ ofWHIREvent)) := by + rw [← run_ofWHIREvents, normalized_callerOutputCount, List.map_map] + +end Whir.WHIRCallerShape diff --git a/verification/whir/Whir/WHIRCallerPrefix.lean b/verification/whir/Whir/WHIRCallerPrefix.lean new file mode 100644 index 000000000..01ada0434 --- /dev/null +++ b/verification/whir/Whir/WHIRCallerPrefix.lean @@ -0,0 +1,355 @@ +import Whir.WHIRHistoryKey +import Whir.DuplexFraming + +/-! Continuation from the live caller transcript at conditional #552. The caller +ends by absorbing scalars (`flock/src/lincheck.rs:515-517`, or a root in direct +PCS tests), so its output cursor is zero but its buffered run need not be empty. +The first PCS squeeze finishes that run. We retain its exact seed and all prior +frames; no live chaining value is replaced by `seed(domain, statement)`. -/ +/-! These lemmas apply to each actual entered context. Entry domain and statement are the original caller seed fields, not a new PCS claim digest. The raw recognizer retains the actual prefix bytes in each packet; it does not select one fixed prefix for all clones of a seed. `WHIRCallerShape` computes the boundary count from public control shape while permitting arbitrary data values. Binding that public caller shape and the PCS profile remains separate. -/ +namespace Whir.WHIRCallerPrefix +open Concrete Protocol FiatShamirGame DuplexRefinement WHIRHistory WHIRHistoryKey + +/-- Prefixing a ghost history changes no buffer or cursor and computes no hash. -/ +def prepend (frames : List Frame) (m : Model) : Model := + {m with history := {m.history with frames := frames ++ m.history.frames}} + +@[simp] theorem prepend_nil (m : Model) : prepend [] m = m := by + cases m; rfl + +@[simp] theorem prepend_history (frames : List Frame) (m : Model) : + (prepend frames m).history = + ⟨m.history.domain,m.history.statement,frames ++ m.history.frames⟩ := rfl + + theorem prepend_closeRun (frames : List Frame) (m : Model) : + closeRun (prepend frames m) = prepend frames (closeRun m) := by + by_cases h : m.run = [] <;> + simp [prepend, closeRun, h, List.append_assoc] + + theorem prepend_modelAbsorb (frames : List Frame) (m : Model) (bytes : List Byte) : + modelAbsorb (prepend frames m) bytes = prepend frames (modelAbsorb m bytes) := by + by_cases h : bytes = [] + · simp [modelAbsorb, h] + · simp [modelAbsorb, prepend, h] + rfl + + theorem prepend_modelNonce (frames : List Frame) (m : Model) (nonce : Scalar24) (bits : Nat) : + modelNonce (prepend frames m) nonce bits = prepend frames (modelNonce m nonce bits) := by + simp only [modelNonce, prepend_closeRun] + simp [prepend, List.append_assoc] + + theorem prepend_modelSqueeze (frames : List Frame) (m : Model) (n : Nat) : + modelSqueeze (prepend frames m) n = prepend frames (modelSqueeze m n) := by + by_cases h : n = 0 + · simp [modelSqueeze, h] + · simp only [modelSqueeze, h, ↓reduceIte, prepend_closeRun] + rfl + + theorem prepend_pendingModel (frames : List Frame) (m : Model) (p : Pending) : + pendingModel (prepend frames m) p = prepend frames (pendingModel m p) := by + simp only [pendingModel, prepend_modelAbsorb] + cases p.nonce <;> simp [prepend_modelNonce] + + theorem prepend_modelEvent (frames : List Frame) (m : Model) (e : WHIRHistory.Event) : + modelEvent (prepend frames m) e = prepend frames (modelEvent m e) := by + cases e <;> simp only [modelEvent, prepend_modelAbsorb, prepend_modelNonce, prepend_modelSqueeze] + + theorem prepend_modelEvents (frames : List Frame) (m : Model) (events : List WHIRHistory.Event) : + modelEvents (prepend frames m) events = prepend frames (modelEvents m events) := by + induction events generalizing m with + | nil => rfl + | cons e es ih => + change modelEvents (modelEvent (prepend frames m) e) es = + prepend frames (modelEvents (modelEvent m e) es) + rw [prepend_modelEvent, ih] + +/-- Reuse the existing protocol recurrence, with the actual normalized entry +history as its fixed prefix. Only the ghost initial history is extended. -/ +def completedModelFrom (width : Nat → Nat) (entry : FramedHistory) (ps : List Pending) : Model := + prepend entry.frames (completedModel width entry.domain entry.statement ps) + +def beforeModelFrom (width : Nat → Nat) (entry : FramedHistory) (ps : List Pending) : Model := + prepend entry.frames (beforeModel width entry.domain entry.statement ps) + +def outputKeyFrom (width : Nat → Nat) (entry : FramedHistory) + (ps : List Pending) (block : Nat) : FiatShamirGame.Coordinate := + ⟨(closeRun (beforeModelFrom width entry ps)).history,.output block⟩ + +@[simp] theorem completedModelFrom_empty (width : Nat → Nat) (domain statement : Digest32) + (ps : List Pending) : completedModelFrom width ⟨domain,statement,[]⟩ ps = + completedModel width domain statement ps := by simp [completedModelFrom] + +@[simp] theorem beforeModelFrom_empty (width : Nat → Nat) (domain statement : Digest32) + (ps : List Pending) : beforeModelFrom width ⟨domain,statement,[]⟩ ps = + beforeModel width domain statement ps := by simp [beforeModelFrom] + + theorem completedModelFrom_cons (width : Nat → Nat) (entry : FramedHistory) + (m : Pending) (ps : List Pending) : + completedModelFrom width entry (m :: ps) = + modelSqueeze (pendingModel (completedModelFrom width entry ps) m) (width ps.length) := by + simp only [completedModelFrom, completedModel, prepend_pendingModel, prepend_modelSqueeze] + + theorem beforeModelFrom_cons (width : Nat → Nat) (entry : FramedHistory) + (m : Pending) (ps : List Pending) : + beforeModelFrom width entry (m :: ps) = pendingModel (completedModelFrom width entry ps) m := by + simp only [beforeModelFrom, beforeModel, completedModelFrom, prepend_pendingModel] + + theorem outputKeyFrom_empty (width : Nat → Nat) (domain statement : Digest32) + (ps : List Pending) (block : Nat) : + outputKeyFrom width ⟨domain,statement,[]⟩ ps block = outputKey width domain statement ps block := by + simp [outputKeyFrom, beforeModelFrom, outputKey] + + theorem before_historyFrom (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (entry : FramedHistory) {ps : List Pending} (normal : Normal ps) : + (closeRun (beforeModelFrom width entry ps)).history = + ⟨entry.domain,entry.statement,entry.frames ++ canonicalFrames width ps⟩ := by + simp only [beforeModelFrom, prepend_closeRun, prepend_history, + before_history width positive entry.domain entry.statement normal] + + theorem outputKeyFrom_history (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (entry : FramedHistory) {ps : List Pending} (normal : Normal ps) (block : Nat) : + (outputKeyFrom width entry ps block).history = + ⟨entry.domain,entry.statement,entry.frames ++ canonicalFrames width ps⟩ := + before_historyFrom width positive entry normal + + theorem parse_outputKeyFrom (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (entry : FramedHistory) {ps : List Pending} (normal : Normal ps) (block : Nat) : + parseSteps ((outputKeyFrom width entry ps block).history.frames.drop entry.frames.length) = + some ps.dropLast.reverse := by + rw [outputKeyFrom_history width positive entry normal] + simp only [List.drop_left, canonicalFrames, steps_roundtrip, List.map_reverse, annotated_erases] + + theorem outputKeyFrom_injective (width width' : Nat → Nat) + (positive : ∀ n, 0 < width n) (positive' : ∀ n, 0 < width' n) + (entry : FramedHistory) {ps qs : List Pending} (hp : Normal ps) (hq : Normal qs) + (block block' : Nat) (same : outputKeyFrom width entry ps block = outputKeyFrom width' entry qs block') : + ps = qs ∧ block = block' := by + have hh := congrArg (fun k : FiatShamirGame.Coordinate => k.history.frames) same + have ht := congrArg FiatShamirGame.Coordinate.terminal same + rw [outputKeyFrom_history width positive entry hp, + outputKeyFrom_history width' positive' entry hq] at hh + exact ⟨canonicalFrames_injective width width' hp hq (List.append_cancel_left hh), Terminal.output.inj ht⟩ + + theorem outputKeyFrom_admissible (c : Config) (width : Nat → Nat) + (positive : ∀ n, 0 < width n) (bounded : ∀ n, width n < 2^49) + (entry : FramedHistory) (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) + (ps : List Pending) (block : Nat) (nonempty : ps ≠ []) + (admitted : scheduledAdmissible c ps = true) + (blockBound : block < (width (ps.length-1)+31)/32) : + DuplexEncoding.Admissible (outputKeyFrom width entry ps block) := by + have hn := scheduled_normal c ps nonempty admitted + have hs := outputKey_admissible c width positive bounded entry.domain entry.statement ps block nonempty admitted blockBound + constructor + · rw [outputKeyFrom_history width positive entry hn] + intro f hf + rcases List.mem_append.mp hf with hf | hf + · exact entryValid f hf + · exact canonicalFrames_valid width bounded hn (scheduled_nonce_bits c ps admitted) f hf + · exact hs.2 + + theorem production_stackOutputKeyFrom_admissible (p : ParameterBounds.Profile) + (entry : FramedHistory) (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) + (ps : List Pending) (block : Nat) (nonempty : ps ≠ []) + (admitted : scheduledAdmissible (ParameterBounds.config p) ps = true) + (blockBound : block < (stackWidth (ParameterBounds.config p) (ps.length-1)+31)/32) : + DuplexEncoding.Admissible (outputKeyFrom (stackWidth (ParameterBounds.config p)) entry ps block) := + outputKeyFrom_admissible _ _ (stackWidth_positive p) (stackWidth_bounded p) + entry entryValid ps block nonempty admitted blockBound + + theorem production_outputKeyFrom_admissible (p : ParameterBounds.Profile) + (entry : FramedHistory) (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) + (ps : List Pending) (block : Nat) (nonempty : ps ≠ []) + (admitted : scheduledAdmissible (ParameterBounds.config p) ps = true) + (blockBound : block < (standaloneWidth (ParameterBounds.config p) (ps.length-1)+31)/32) : + DuplexEncoding.Admissible (outputKeyFrom (standaloneWidth (ParameterBounds.config p)) entry ps block) := + outputKeyFrom_admissible _ _ (standaloneWidth_positive p) (standaloneWidth_bounded p) + entry entryValid ps block nonempty admitted blockBound + + theorem closeRun_idempotent (m : Model) : closeRun (closeRun m) = closeRun m := by + by_cases h : m.run = [] <;> simp [closeRun, h] + + theorem modelSqueeze_closeRun (m : Model) (n : Nat) (positive : 0 < n) : + modelSqueeze (closeRun m) n = modelSqueeze m n := by + simp only [modelSqueeze, Nat.ne_of_gt positive, ↓reduceIte, closeRun_idempotent, closeRun_consumed] + +/-- The actual pending caller run is normalized once, exactly as a positive +squeeze does. In particular a held 64-byte block remains final, not nonfinal. -/ + theorem normalized_entry (width : Nat → Nat) (m : Model) (valid : m.Valid) + (cursor : m.consumed = 0) : + closeRun m = completedModelFrom width (closeRun m).history [] := by + have hr := closeRun_empty m + have hp := (closeRun_valid m valid).2.1 hr + have hc : (closeRun m).consumed = 0 := (closeRun_consumed m).trans cursor + cases he : closeRun m + simp_all [completedModelFrom, completedModel, prepend] + +/-- No reseeding: the input executable state is the live caller state. The +continuation theorem follows from actual event execution and its first positive +squeeze, which is exactly the WHIR/stack wire compiler's first event. -/ + theorem execute_from_entry (compress : Compression) (powOK : Digest32 → Scalar24 → Nat → Bool) + (iv : Digest32) (entry : Model) (s t : State) (width : Nat → Nat) + (h : Represents compress iv entry s) (cursor : entry.consumed = 0) + (n : Nat) (positive : 0 < n) (events : List WHIRHistory.Event) + (ok : executeEvents compress powOK s (.squeeze n :: events) = some t) : + Represents compress iv + (modelEvents (completedModelFrom width (closeRun entry).history []) (.squeeze n :: events)) t := by + have actual := executeEvents_represents compress powOK iv (.squeeze n :: events) entry s t h ok + have hn := normalized_entry width entry h.1 cursor + have eq : modelEvents (completedModelFrom width (closeRun entry).history []) (.squeeze n :: events) = + modelEvents entry (.squeeze n :: events) := by + rw [← hn] + simp only [modelEvents, List.foldl_cons, modelEvent, modelSqueeze_closeRun entry n positive] + rw [eq] + exact actual + + theorem beforeModelFrom_consumed (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (entry : FramedHistory) {ps : List Pending} (normal : Normal ps) : + (beforeModelFrom width entry ps).consumed = 0 := by + change (beforeModel width entry.domain entry.statement ps).consumed = 0 + cases normal with + | initial => simp [beforeModel, completedModel, initialPending, pendingModel, modelAbsorb, scalarBytes] + | @cons ps prior m nonempty => + rw [beforeModel, completed_normal width positive _ _ prior] + have hn : scalarBytes m.scalars ≠ [] := fun h => nonempty ((scalarBytes_empty _).mp h) + simp only [pendingModel, modelAbsorb, hn, ↓reduceIte] + cases m.nonce <;> simp [modelNonce] + +/-- Exact byte stream of the real next squeeze at a continued caller history. +`Represents` is the checked machine relation, propagated by execute_from_entry. -/ + theorem squeeze_frame_bytes_from (compress : Compression) (iv : Digest32) + (width : Nat → Nat) (positive : ∀ n, 0 < width n) (entry : FramedHistory) + {ps : List Pending} (normal : Normal ps) (s t : State) + (h : Represents compress iv (beforeModelFrom width entry ps) s) + (n : Nat) (bytes : List Byte) (ok : squeeze compress s n = .ok (t,bytes)) : + bytes = stream compress (evalHistory compress iv (outputKeyFrom width entry ps 0).history) 0 n := by + have he := squeeze_frame_bytes compress iv (beforeModelFrom width entry ps) s t h n bytes ok + simpa only [outputKeyFrom, beforeModelFrom_consumed width positive entry normal] using he + + theorem initial_squeeze_frame_bytes (compress : Compression) (iv : Digest32) + (entry : Model) (s t : State) (h : Represents compress iv entry s) + (cursor : entry.consumed = 0) (n : Nat) (bytes : List Byte) + (ok : squeeze compress s n = .ok (t,bytes)) : + bytes = stream compress (evalHistory compress iv (closeRun entry).history) 0 n := by + simpa only [cursor] using squeeze_frame_bytes compress iv entry s t h n bytes ok + +theorem closeRun_frameValid (m : Model) (valid : m.Valid) + (frames : ∀ f ∈ m.history.frames, DuplexEncoding.FrameValid f) : + ∀ f ∈ (closeRun m).history.frames, DuplexEncoding.FrameValid f := by + by_cases h : m.run = [] + · simpa [closeRun, h] using frames + · simp only [closeRun, h, ↓reduceIte] + intro f hf + rcases List.mem_append.mp hf with hf | hf + · exact frames f hf + · have he : f = .absorb m.previous m.run := List.mem_singleton.mp hf + subst f + exact ⟨by have hp := valid.2.2.2; unfold maxCursor at hp; omega, h⟩ + +/-- Prefix validity is derived from the actual source transition system. +It is not a semantic claim-binding or compression-collision certificate. -/ +theorem reachable_frameValid (compress : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (h : Reachable compress iv domain statement m s) : + ∀ f ∈ m.history.frames, DuplexEncoding.FrameValid f := by + induction h with + | seed => simp + | absorb h bytes ih => + simp only [modelAbsorb] + split <;> exact ih + | squeeze h n ok ih => + simp only [modelSqueeze] + split + · exact ih + · exact closeRun_frameValid _ (reachable_represents _ _ _ _ h).1 ih + | nonce h nonce bits limit ih => + have valid := (reachable_represents _ _ _ _ h).1 + have closed := closeRun_frameValid _ valid ih + simp only [modelNonce] + intro f hf + rcases List.mem_append.mp hf with hf | hf + · exact closed f hf + · have he : f = .nonce _ bits nonce := List.mem_singleton.mp hf + subst f + refine ⟨?_,limit⟩ + rw [closeRun_consumed] + have hc := valid.2.2.1 + unfold maxCursor at hc + omega + +theorem reachable_entry_frameValid (compress : Compression) (iv domain statement : Digest32) + {m : Model} {s : State} (h : Reachable compress iv domain statement m s) : + ∀ f ∈ (closeRun m).history.frames, DuplexEncoding.FrameValid f := + closeRun_frameValid m (reachable_represents _ _ _ _ h).1 (reachable_frameValid _ _ _ _ h) + +/-- Caller work stays charged: it is an actual additional root-to-terminal +prefix, not a cached or free seed replacement. -/ +theorem pathCostFrom (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (entry : FramedHistory) {ps : List Pending} (normal : Normal ps) (block : Nat) : + DuplexFraming.pathCost (outputKeyFrom width entry ps block) = + 2 + (entry.frames.flatMap DuplexEncoding.framePlan).length + + ((canonicalFrames width ps).flatMap DuplexEncoding.framePlan).length := by + unfold DuplexFraming.pathCost DuplexEncoding.plan + rw [outputKeyFrom_history width positive entry normal] + simp [List.flatMap_append, Nat.add_comm, Nat.add_left_comm] + omega + +theorem canonical_cost_drop (width : Nat → Nat) {ps : List Pending} + (normal : Normal ps) (n : Nat) : + ((canonicalFrames width (ps.drop n)).flatMap DuplexEncoding.framePlan).length ≤ + ((canonicalFrames width ps).flatMap DuplexEncoding.framePlan).length := by + induction normal generalizing n with + | initial => + cases n <;> simp [canonicalFrames, annotated, encodeSteps] + | @cons ps hp m hm ih => + cases n with + | zero => simp + | succ n => + simp only [List.drop_succ_cons] + apply (ih n).trans + rw [canonicalFrames_cons width m ps hp.nonempty] + simp + +theorem pathCostFrom_drop (c : Config) (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (entry : FramedHistory) (ps : List Pending) (n block block' : Nat) + (nonempty : ps ≠ []) (suffixNonempty : ps.drop n ≠ []) + (admitted : scheduledAdmissible c ps = true) : + DuplexFraming.pathCost (outputKeyFrom width entry (ps.drop n) block) ≤ + DuplexFraming.pathCost (outputKeyFrom width entry ps block') := by + have hn := scheduled_normal c ps nonempty admitted + have hs := scheduled_normal c (ps.drop n) suffixNonempty + (scheduledAdmissible_drop c ps n admitted) + rw [pathCostFrom width positive entry hs, pathCostFrom width positive entry hn] + exact Nat.add_le_add_left (canonical_cost_drop width hn n) _ + +theorem stackWireEvents_head (config : Config) (digests : Nat → Digest32) + (bits : Nat → Nat) (nonces : Nat → E) (replies : List CausalGame.Reply) + (events : List WHIRHistory.Event) + (compiled : stackWireEvents config digests bits nonces replies = some events) : + ∃ rest, events = .squeeze 192 :: rest := by + simp only [stackWireEvents] at compiled + cases hw : wireEvents config digests bits nonces replies with + | none => simp [hw] at compiled + | some es => + simp only [hw] at compiled + cases es with + | nil => cases compiled + | cons e rest => + cases e <;> cases compiled + exact ⟨rest,rfl⟩ + +/-- The actual stack wire compiler, not an assumed continuation shape, provides +the first positive squeeze used to preserve the live caller transcript. -/ +theorem execute_stackWire_from_entry (compress : Compression) + (powOK : Digest32 → Scalar24 → Nat → Bool) (iv : Digest32) + (entry : Model) (s t : State) (h : Represents compress iv entry s) + (cursor : entry.consumed = 0) (config : Config) (digests : Nat → Digest32) + (bits : Nat → Nat) (nonces : Nat → E) (replies : List CausalGame.Reply) + (events : List WHIRHistory.Event) + (compiled : stackWireEvents config digests bits nonces replies = some events) + (executed : executeEvents compress powOK s events = some t) : + Represents compress iv + (modelEvents (completedModelFrom (stackWidth config) (closeRun entry).history []) events) t := by + obtain ⟨rest,rfl⟩ := stackWireEvents_head config digests bits nonces replies events compiled + exact execute_from_entry compress powOK iv entry s t (stackWidth config) h cursor 192 + (by decide) rest executed + +end Whir.WHIRCallerPrefix diff --git a/verification/whir/Whir/WHIRCallerShape.lean b/verification/whir/Whir/WHIRCallerShape.lean new file mode 100644 index 000000000..b3b1320e2 --- /dev/null +++ b/verification/whir/Whir/WHIRCallerShape.lean @@ -0,0 +1,174 @@ +import Whir.WHIRCallerPrefix + +/-! Public caller-control shapes for the conditional #552 transcript. CPU and recursion callers run layout-shaped reductions before opening. In particular, `flock/src/lincheck.rs:495-517` runs a public number of rounds, then reads each public-sized scalar vector and one scalar without another sample. This module checks the mode-level family for an explicitly fixed public operation shape; it does not claim a universal refinement of the Rust callers. Payload bytes, nonce values and challenge-dependent messages may differ between clones. The original seed is retained and no boundary tag is added to the wire. Distinct public caller shapes may require distinct boundary counts even at the same abstract seed; selecting and binding the public family remains a caller obligation. -/ +namespace Whir.WHIRCallerShape +open Concrete FiatShamirGame DuplexRefinement + +/-- Raw mode operations, including byte absorptions not divisible by 24. -/ +inductive Operation where + | absorb (bytes : List Byte) + | squeeze (count : Nat) + | nonce (bits : Nat) (value : Scalar24) + +/-- Only public operation control and lengths remain, never payload bytes. -/ +inductive EventShape where + | absorb (bytes : Nat) + | squeeze (count : Nat) + | nonce (bits : Nat) + deriving DecidableEq, Repr + +def operationShape : Operation → EventShape + | .absorb bs => .absorb bs.length + | .squeeze n => .squeeze n + | .nonce bits _ => .nonce bits + +def applyOperation (m : Model) : Operation → Model + | .absorb bs => modelAbsorb m bs + | .squeeze n => modelSqueeze m n + | .nonce bits value => modelNonce m value bits + +def runOperations (m : Model) (ops : List Operation) : Model := + ops.foldl applyOperation m + +/-- This records all control-relevant fields of the actual ghost model. -/ +structure StateShape where + frames : Nat + run : Nat + previous : Nat + consumed : Nat + deriving DecidableEq, Repr + +def abstractModel (m : Model) : StateShape := + ⟨m.history.frames.length,m.run.length,m.previous,m.consumed⟩ + +def closeShape (s : StateShape) : StateShape := + if s.run = 0 then s else {s with frames := s.frames + 1, run := 0, previous := 0} + +def applyShape (s : StateShape) : EventShape → StateShape + | .absorb n => if n = 0 then s else + {s with run := s.run + n, previous := if s.consumed = 0 then s.previous else s.consumed, consumed := 0} + | .squeeze n => if n = 0 then s else {closeShape s with consumed := s.consumed + n} + | .nonce _ => ⟨(closeShape s).frames + 1,0,0,0⟩ + +def runShapes (s : StateShape) (events : List EventShape) : StateShape := + events.foldl applyShape s + +@[simp] theorem abstract_closeRun (m : Model) : + abstractModel (closeRun m) = closeShape (abstractModel m) := by + by_cases h : m.run = [] <;> + simp [closeRun, closeShape, abstractModel, h] + +@[simp] theorem abstract_modelAbsorb (m : Model) (bs : List Byte) : + abstractModel (modelAbsorb m bs) = applyShape (abstractModel m) (.absorb bs.length) := by + by_cases h : bs = [] + · simp [modelAbsorb, applyShape, abstractModel, h] + · simp [modelAbsorb, applyShape, abstractModel, h] + rfl + +@[simp] theorem abstract_modelSqueeze (m : Model) (n : Nat) : + abstractModel (modelSqueeze m n) = applyShape (abstractModel m) (.squeeze n) := by + by_cases h : n = 0 + · simp [modelSqueeze, applyShape, h] + · simp only [modelSqueeze, applyShape, h, ↓reduceIte] + have hc := abstract_closeRun m + cases hc' : closeRun m + simp only [hc', abstractModel] at hc ⊢ + rw [← hc] + +theorem abstract_modelNonce (m : Model) (bits : Nat) (value : Scalar24) : + abstractModel (modelNonce m value bits) = applyShape (abstractModel m) (.nonce bits) := by + simp only [modelNonce, abstractModel, List.length_append, List.length_cons, + List.length_nil, Nat.zero_add, applyShape] + exact congrArg (fun s : StateShape => StateShape.mk (s.frames + 1) 0 0 0) + (abstract_closeRun m) + +theorem abstract_applyOperation (m : Model) (op : Operation) : + abstractModel (applyOperation m op) = applyShape (abstractModel m) (operationShape op) := by + cases op with + | absorb bs => exact abstract_modelAbsorb m bs + | squeeze n => exact abstract_modelSqueeze m n + | nonce bits value => exact abstract_modelNonce m bits value + +theorem abstract_runOperations (m : Model) (ops : List Operation) : + abstractModel (runOperations m ops) = runShapes (abstractModel m) (ops.map operationShape) := by + induction ops generalizing m with + | nil => rfl + | cons op ops ih => + simp only [runOperations, runShapes, List.foldl_cons, List.map_cons] at ih ⊢ + rw [ih, abstract_applyOperation] + +/-- Same public shape determines every control field, even from an active run. -/ +theorem same_shape (a b : Model) (ops ops' : List Operation) + (initial : abstractModel a = abstractModel b) + (control : ops.map operationShape = ops'.map operationShape) : + abstractModel (runOperations a ops) = abstractModel (runOperations b ops') := by + rw [abstract_runOperations, abstract_runOperations, initial, control] + +def seedModel (domain statement : Digest32) : Model := ⟨⟨domain,statement,[]⟩,[],0,0⟩ + +def entryCount (shape : List EventShape) : Nat := + (closeShape (runShapes ⟨0,0,0,0⟩ shape)).frames + +/-- A computed public boundary count, not an assumed fixed-history certificate. -/ +theorem normalized_entry_count (domain statement : Digest32) (ops : List Operation) : + (closeRun (runOperations (seedModel domain statement) ops)).history.frames.length = + entryCount (ops.map operationShape) := by + exact congrArg StateShape.frames + ((abstract_closeRun _).trans (congrArg closeShape (abstract_runOperations _ _))) + +theorem cloned_entry_count (domain statement : Digest32) (ops ops' : List Operation) + (control : ops.map operationShape = ops'.map operationShape) : + (closeRun (runOperations (seedModel domain statement) ops)).history.frames.length = + (closeRun (runOperations (seedModel domain statement) ops')).history.frames.length := by + rw [normalized_entry_count, normalized_entry_count, control] + +/-- The existing WHIR scalar event compiler is an instance of raw operations. -/ +def ofWHIREvent : WHIRHistory.Event → Operation + | .observe xs => .absorb (WHIRHistory.scalarBytes xs) + | .squeeze n => .squeeze n + | .nonce bits value => .nonce bits (ByteCodec.encodeE value) + +@[simp] theorem shape_of_observe (xs : List E) : + operationShape (ofWHIREvent (.observe xs)) = .absorb (24 * xs.length) := by + simp [operationShape, ofWHIREvent, WHIRHistory.scalarBytes_length] + +@[simp] theorem apply_ofWHIREvent (m : Model) (event : WHIRHistory.Event) : + applyOperation m (ofWHIREvent event) = WHIRHistory.modelEvent m event := by + cases event <;> rfl + +theorem run_ofWHIREvents (m : Model) (events : List WHIRHistory.Event) : + runOperations m (events.map ofWHIREvent) = WHIRHistory.modelEvents m events := by + induction events generalizing m with + | nil => rfl + | cons event events ih => + simp only [runOperations, WHIRHistory.modelEvents, List.map_cons, List.foldl_cons] at ih ⊢ + rw [apply_ofWHIREvent, ih] + +theorem abstract_modelEvents (m : Model) (events : List WHIRHistory.Event) : + abstractModel (WHIRHistory.modelEvents m events) = + runShapes (abstractModel m) (events.map (operationShape ∘ ofWHIREvent)) := by + rw [← run_ofWHIREvents, abstract_runOperations, List.map_map] + +theorem normalized_modelEvents_entry_count (domain statement : Digest32) + (events : List WHIRHistory.Event) : + (closeRun (WHIRHistory.modelEvents (seedModel domain statement) events)).history.frames.length = + entryCount (events.map (operationShape ∘ ofWHIREvent)) := by + rw [← run_ofWHIREvents, normalized_entry_count, List.map_map] + +/-- The final nonempty read resets the real cursor, regardless of earlier data. -/ +theorem ending_absorb_consumed (c : Compression) (s : State) (bs : List Byte) (nonempty : bs ≠ []) : + (absorb c s bs).consumed = 0 := absorb_nonempty_cursor c s bs nonempty + +theorem ending_scalar_consumed (c : Compression) (s : State) (value : E) : + (observe c s value).consumed = 0 := by + apply absorb_nonempty_cursor + intro h + have hl := congrArg List.length h + simp at hl + +theorem ending_model_absorb_consumed (m : Model) (ops : List Operation) + (bs : List Byte) (nonempty : bs ≠ []) : + (runOperations m (ops ++ [.absorb bs])).consumed = 0 := by + simp [runOperations, List.foldl_append, applyOperation, modelAbsorb, nonempty] + +end Whir.WHIRCallerShape diff --git a/verification/whir/Whir/WHIRCausalRawROM.lean b/verification/whir/Whir/WHIRCausalRawROM.lean new file mode 100644 index 000000000..d2a6d15b0 --- /dev/null +++ b/verification/whir/Whir/WHIRCausalRawROM.lean @@ -0,0 +1,322 @@ +import Whir.WHIRRawROM +import Whir.CausalBindingState +import Whir.CausalAllocationLabels + +namespace Whir.WHIRCausalRawROM +open Concrete Protocol CausalProbability ParameterBounds +open FiatShamirGame (Digest32 average) +open RawOracleCoupling RawOracleCoupling.Concrete WHIRRawReplay +open Classical +set_option maxHeartbeats 800000 +set_option maxRecDepth 100000 + +structure Extension {cap : Nat} (before : CausalBindingState.State cap) where + state : CausalBindingState.State cap + growth : CausalBindingState.Extends before state + +/-- The resolver sees only the already accumulated finite state and current +raw-input prefix. It has no total oracle argument. Its claim request is formed +before sampling; immutable registration handles repeats and earlier prequeries. -/ +structure Resolver (ctx : RawWHIRKeys.Context) (Q cap : Nat) where + before : (state : CausalBindingState.State cap) → AllocationKey ctx Q → Extension state + claims : CausalBindingState.State cap → (packet : RawWHIRKeys.Packet ctx Q) → + List (Sigma (GroupAnswer ctx Q)) → Option (CausalBindingState.ClaimRequest cap packet.val.profile) + after : (state : CausalBindingState.State cap) → (key : AllocationKey ctx Q) → + AllocationAnswer ctx Q key → Extension state + +inductive Label (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) where + | packet (packet : RawWHIRKeys.Packet ctx Q) (history : List (Sigma (GroupAnswer ctx Q))) + (binding : CausalBindingState.Label cap packet.val.profile) + (key : binding.key = localKey (allocationKey ctx stack Q packet history)) + (entry : binding.entry = callerEntry ctx Q packet) + | garbage (key : (partition ctx Q).Garbage) (history : List (Sigma (GroupAnswer ctx Q))) + (state : CausalBindingState.State cap) + +def Label.allocation {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} : + Label ctx stack Q cap → AllocationKey ctx Q + | .packet pkt history _ _ _ => (.inl pkt,history) + | .garbage key history _ => (.inr key,history) + +def Label.state {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} : + Label ctx stack Q cap → CausalBindingState.State cap + | .packet _ _ binding _ _ => binding.state + | .garbage _ _ state => state + +abbrev Answer {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (label : Label ctx stack Q cap) := AllocationAnswer ctx Q label.allocation + +noncomputable def prepare (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (resolver : Resolver ctx Q cap) (state : CausalBindingState.State cap) : + (key : AllocationKey ctx Q) → CausalBindingState.State cap × Label ctx stack Q cap + | (.inl packet,history) => + let prior := (resolver.before state (.inl packet,history)).state + let built := CausalBindingState.prepareClaims prior packet.val.profile (callerEntry ctx Q packet) + (localKey (allocationKey ctx stack Q packet history)) (resolver.claims prior packet history) + (built.1,.packet packet history built.2 + (CausalBindingState.prepareClaims_key _ _ _ _ _) + (CausalBindingState.prepareClaims_entry _ _ _ _ _)) + | (.inr key,history) => + let prior := (resolver.before state (.inr key,history)).state + (prior,.garbage key history prior) + +@[simp] theorem prepare_allocation (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (state : CausalBindingState.State cap) + (key : AllocationKey ctx Q) : (prepare ctx stack Q cap resolver state key).2.allocation = key := by + rcases key with ⟨key,history⟩ + cases key <;> rfl + +@[simp] theorem prepare_state (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (state : CausalBindingState.State cap) + (key : AllocationKey ctx Q) : + (prepare ctx stack Q cap resolver state key).2.state = (prepare ctx stack Q cap resolver state key).1 := by + rcases key with ⟨key,history⟩ + cases key with + | inl packet => exact CausalBindingState.prepareClaims_state _ _ _ _ _ + | inr garbage => rfl + +theorem prepare_extends (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (state : CausalBindingState.State cap) + (key : AllocationKey ctx Q) : + CausalBindingState.Extends state (prepare ctx stack Q cap resolver state key).1 := by + rcases key with ⟨key,history⟩ + cases key with + | inl packet => + exact (resolver.before state (.inl packet,history)).growth.trans + (CausalBindingState.prepareClaims_extends _ _ _ _ _) + | inr garbage => exact (resolver.before state (.inr garbage,history)).growth + +noncomputable def decorator (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (resolver : Resolver ctx Q cap) : + CausalAllocationLabels.Decorator (CausalBindingState.State cap) + (AllocationKey ctx Q) (AllocationAnswer ctx Q) (Label ctx stack Q cap) Answer where + prepare := prepare ctx stack Q cap resolver + answer state key := by + rcases key with ⟨key,history⟩ + cases key <;> exact Equiv.refl _ + advance state label answer := (resolver.after state label.allocation answer).state + +def Label.bad {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (label : Label ctx stack Q cap) (answer : Answer label) : Prop := + WHIRRawROM.bad ctx stack Q cap label.state.catalog (CausalBindingState.roots label.state) + label.allocation answer + +theorem evolution_extends (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) + {state final : CausalBindingState.State cap} {raw labeled} + (evolution : (decorator ctx stack Q cap resolver).Evolves state raw labeled final) : + CausalBindingState.Extends state final := by + induction evolution with + | nil => exact .refl _ + | cons state key answer tail ih => + exact (prepare_extends ctx stack Q cap resolver state key).trans + ((resolver.after _ _ _).growth.trans ih) + +theorem emitted_state_extends (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) + {state final : CausalBindingState.State cap} {raw labeled} + (evolution : (decorator ctx stack Q cap resolver).Evolves state raw labeled final) + (entry : Sigma (@Answer ctx stack Q cap)) (member : entry ∈ labeled) : + CausalBindingState.Extends entry.1.state final := by + induction evolution with + | nil => simp at member + | cons state key answer tail ih => + rcases List.mem_cons.mp member with equal | member + · subst entry + change CausalBindingState.Extends (prepare ctx stack Q cap resolver state key).2.state _ + rw [prepare_state] + exact (resolver.after _ _ _).growth.trans + (evolution_extends ctx stack Q cap resolver tail) + · exact ih member + +def eraseEntry {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (entry : Sigma (@Answer ctx stack Q cap)) : Sigma (AllocationAnswer ctx Q) := + ⟨entry.1.allocation,entry.2⟩ + +@[simp] theorem erase_prepared (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (state : CausalBindingState.State cap) + (key : AllocationKey ctx Q) (answer : AllocationAnswer ctx Q key) : + eraseEntry ⟨(prepare ctx stack Q cap resolver state key).2, + (decorator ctx stack Q cap resolver).answer state key answer⟩ = ⟨key,answer⟩ := by + rcases key with ⟨key,history⟩ + cases key <;> rfl + +theorem evolution_erases (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) + {state final : CausalBindingState.State cap} {raw labeled} + (evolution : (decorator ctx stack Q cap resolver).Evolves state raw labeled final) : + labeled.map eraseEntry = raw := by + induction evolution with + | nil => rfl + | cons state key answer tail ih => + rw [List.map_cons,ih] + congr 1 + exact erase_prepared ctx stack Q cap resolver state key answer + +theorem Label.sparse {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (label : Label ctx stack Q cap) : + average (fun answer => if label.bad answer then 1 else 0) ≤ WHIRRawROM.epsilon cap := + WHIRRawROM.sparse ctx stack Q cap label.state.catalog (CausalBindingState.roots label.state) _ + +theorem Label.bad_final {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (label : Label ctx stack Q cap) (final : CausalBindingState.State cap) + (growth : CausalBindingState.Extends label.state final) (answer : Answer label) : + label.bad answer ↔ + WHIRRawROM.bad ctx stack Q cap final.catalog (CausalBindingState.roots final) + label.allocation answer := by + cases label with + | garbage key history state => rfl + | packet packet history binding key entry => + rcases binding with ⟨state,entered,logical,original,found,prepared⟩ + dsimp only at key entry + subst logical + subst entered + exact CausalBindingState.Label.bad_final + ⟨state,callerEntry ctx Q packet,localKey (allocationKey ctx stack Q packet history), + original,found,prepared⟩ final growth (decodePacket ctx stack Q packet answer) + +theorem compiler_cover (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (resolver : Resolver ctx Q cap) (initial : CausalBindingState.State cap) {R : Type} {K : Nat} + (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) + (trace result final) + (run : TypedOracleCompiler.Sampling.Runs + ((decorator ctx stack Q cap resolver).decorate (compile ctx Q select program) initial) + trace (result,final)) + (failed : WHIRRawROM.Failure ctx stack Q cap final.catalog (CausalBindingState.roots final) + (select result.1) result.2) : + ∃ entry ∈ trace, entry.1.bad entry.2 := by + obtain ⟨raw,original,evolution⟩ := + (decorator ctx stack Q cap resolver).runs_causal _ initial run + obtain ⟨allocation,member,bad⟩ := WHIRRawROM.compiler_cover ctx stack Q cap + final.catalog (CausalBindingState.roots final) select program raw result original failed + have mapped : allocation ∈ trace.map eraseEntry := by + rw [evolution_erases ctx stack Q cap resolver evolution] + exact member + obtain ⟨entry,inTrace,equal⟩ := List.mem_map.mp mapped + refine ⟨entry,inTrace,(entry.1.bad_final final + (emitted_state_extends ctx stack Q cap resolver evolution entry inTrace) entry.2).mpr ?_⟩ + cases equal + exact bad + +/-- Each event uses its retained pre-draw snapshot. Final-state catalogs may +depend on all preceding answers; they are used only for deterministic replay, +never substituted into a fresh-sample probability bound. -/ +theorem allocation_list_binding (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (initial : CausalBindingState.State cap) + {R : Type} {K : Nat} (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) : + TypedOracleCompiler.Sampling.failureProbability + (fun result => WHIRRawROM.Failure ctx stack Q cap result.2.catalog + (CausalBindingState.roots result.2) (select result.1.1) result.1.2) + ((decorator ctx stack Q cap resolver).decorate (compile ctx Q select program) initial) ≤ + min 1 (((allocationBudget ctx * (K+1) : Nat) : ℚ) * WHIRRawROM.epsilon cap) := by + apply le_min + · apply TypedOracleCompiler.Sampling.expectation_le_one + intro result + split <;> norm_num + · have cover := TypedOracleCompiler.Sampling.failure_le_risk + (fun label answer => label.bad answer) + (fun result => WHIRRawROM.Failure ctx stack Q cap result.2.catalog + (CausalBindingState.roots result.2) (select result.1.1) result.1.2) + ((decorator ctx stack Q cap resolver).decorate (compile ctx Q select program) initial) + (by + intro trace result run failed + exact compiler_cover ctx stack Q cap resolver initial select program + trace result.1 result.2 run failed) + have bounded := TypedFiatShamirGame.risk_bound + (fun label answer => label.bad answer) (WHIRRawROM.epsilon cap) + (WHIRRawROM.epsilon_nonneg cap) Label.sparse + (TypedOracleCompiler.Sampling.erase + ((decorator ctx stack Q cap resolver).decorate (compile ctx Q select program) initial)) + simpa only [Nat.mul_add,Nat.mul_one] using cover.trans bounded + +private theorem expectation_eq_of_runs {Key : Type} {A : Key → Type} {R : Type} + [∀ key, Fintype (A key)] {n : Nat} + (program : TypedOracleCompiler.Sampling Key A R n) (left right : R → ℚ) + (agree : ∀ trace result, TypedOracleCompiler.Sampling.Runs program trace result → + left result = right result) : + TypedOracleCompiler.Sampling.expectation left program = + TypedOracleCompiler.Sampling.expectation right program := by + induction program with + | ret result => exact agree [] result (.ret result) + | draw key next ih => + apply congrArg average + funext answer + apply ih answer + intro trace result run + exact agree (⟨key,answer⟩ :: trace) result (.draw answer run) + +/-- Replay recovers the original chronological labels from the immutable +completed cache. The cache is not supplied to label preparation: each step +still sees only the prefix state and its already completed dependencies. -/ +noncomputable def stateOfResult (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (initial : CausalBindingState.State cap) + {R : Type} {K : Nat} (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) + (result : R × TypedFiatShamirGame.Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) : + CausalBindingState.State cap := + ((decorator ctx stack Q cap resolver).traceRecode initial + (TypedOracleCompiler.Sampling.execute (cacheOracle ctx Q result.2) + (compile ctx Q select program)).2).2 + +theorem stateOfResult_exact (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (initial : CausalBindingState.State cap) + {R : Type} {K : Nat} (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) + {trace result final} + (run : TypedOracleCompiler.Sampling.Runs + ((decorator ctx stack Q cap resolver).decorate (compile ctx Q select program) initial) + trace (result,final)) : + stateOfResult ctx stack Q cap resolver initial select program result = final := by + obtain ⟨raw,original,evolution⟩ := + (decorator ctx stack Q cap resolver).runs_causal _ initial run + unfold stateOfResult + rw [compile_reconstruct ctx Q select program original] + exact congrArg Prod.snd evolution.exact + +theorem decorated_distribution (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (initial : CausalBindingState.State cap) + {R : Type} {K : Nat} (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) + (payoff : (R × TypedFiatShamirGame.Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) × + CausalBindingState.State cap → ℚ) : + TypedOracleCompiler.Sampling.expectation payoff + ((decorator ctx stack Q cap resolver).decorate (compile ctx Q select program) initial) = + TypedOracleCompiler.Sampling.expectation + (fun result => payoff (result,stateOfResult ctx stack Q cap resolver initial select program result)) + (compile ctx Q select program) := by + calc + _ = TypedOracleCompiler.Sampling.expectation + (fun result => payoff (result.1,stateOfResult ctx stack Q cap resolver initial select program result.1)) + ((decorator ctx stack Q cap resolver).decorate (compile ctx Q select program) initial) := by + apply expectation_eq_of_runs + intro trace result run + rw [stateOfResult_exact ctx stack Q cap resolver initial select program run] + _ = _ := (decorator ctx stack Q cap resolver).expectation (compile ctx Q select program) initial + (fun result => payoff (result,stateOfResult ctx stack Q cap resolver initial select program result)) + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ + +theorem raw_table_list_binding (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : Resolver ctx Q cap) (initial : CausalBindingState.State cap) + {R : Type} {K : Nat} (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) : + average (fun table : DuplexModeGame.RawKey Q → Digest32 => + let result := tableExecution ctx Q select program table + let final := stateOfResult ctx stack Q cap resolver initial select program result + if WHIRRawROM.Failure ctx stack Q cap final.catalog (CausalBindingState.roots final) + (select result.1) result.2 then 1 else 0) ≤ + min 1 (((allocationBudget ctx * (K+1) : Nat) : ℚ) * WHIRRawROM.epsilon cap) := by + rw [distribution_full ctx Q select program + (fun result => + let final := stateOfResult ctx stack Q cap resolver initial select program result + if WHIRRawROM.Failure ctx stack Q cap final.catalog (CausalBindingState.roots final) + (select result.1) result.2 then 1 else 0)] + rw [← decorated_distribution ctx stack Q cap resolver initial select program + (fun result => if WHIRRawROM.Failure ctx stack Q cap result.2.catalog + (CausalBindingState.roots result.2) (select result.1.1) result.1.2 then 1 else 0)] + exact allocation_list_binding ctx stack Q cap resolver initial select program + +end Whir.WHIRCausalRawROM diff --git a/verification/whir/Whir/WHIRFiatShamir.lean b/verification/whir/Whir/WHIRFiatShamir.lean new file mode 100644 index 000000000..676dc25b7 --- /dev/null +++ b/verification/whir/Whir/WHIRFiatShamir.lean @@ -0,0 +1,446 @@ +import Whir.CausalBadEvents +import Whir.TypedFiatShamirGame +import Whir.ByteCodec +import Whir.CausalPrefix +import Whir.InteractiveSoundness +import Whir.RingPCSGame + +/-! Ordinary classical, dependent-alphabet WHIR allocation bounds. Concrete +prefix events come from actual checked states and commitment-fixed lists. +No homogeneous sigma sampling, future-tape exposure, grinding credit or +numerical 128-bit claim is used. -/ +namespace Whir.WHIRFiatShamir +open Concrete Protocol CausalGame CausalProbability ParameterBounds GroupedChallenges +open scoped BigOperators +open Classical + +/-- Deterministic public-statement syntax is imposed on every queried branch, +not only on the final accepted proof. -/ +structure Statement (p : Profile) where + lanes : Nat + root : BaseOracle + claims : Array Claim + lane_bound : lanes ≤ 2 ^ (config p).folds[0]! + claim_shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN + claim_cap : claims.size ≤ 2^64 + +abbrev Statement.input {p : Profile} (s : Statement p) : Public := + ⟨config p, s.lanes, s.root, s.claims⟩ + +/-- Only strict-past values exist at this interface. The suffix below is filled +with deterministic zeros, never sampled or disclosed as random future tape. -/ +abbrev Prefix {c : Config} (q : Coordinate c) := + (r : Coordinate c) → position r < position q → Sample r + +noncomputable def Prefix.tape {c : Config} {q : Coordinate c} (past : Prefix q) : Tape c := + (coordinates c).symm (fun r => if h : position r < position q then past r h else 0) + +/-- A concrete request includes the fixed public commitment and a causal strategy. +The strategy is allowed to choose its pending response after seeing this sample. -/ +structure Request (p : Profile) where + statement : Statement p + strategy : Strategy + coordinate : Coordinate (config p) + past : Prefix coordinate + +abbrev Answer {p : Profile} (r : Request p) := Sample r.coordinate + +def bad {p : Profile} (r : Request p) (x : Answer r) : Prop := + CausalBadEvents.Bad r.statement.input r.strategy r.coordinate + (set r.coordinate r.past.tape x) + +/-- The conservative largest actual grouped error, with the supported claim cap. -/ +def eta (p : Profile) : ℚ := groupedMaximum (config p) (estimates (config p)) (2^64) + +theorem eta_nonneg (p : Profile) : 0 ≤ eta p := by + apply le_trans (show (0 : ℚ) ≤ 2 / fieldSize by norm_num [fieldSize]) + exact (le_max_left _ _).trans (le_max_right _ _) + +theorem eta_le (p : Profile) : eta p ≤ 1 / 2^79 := + production_grouped p (2^64) le_rfl + +/-- All five actual prefix-event providers are instantiated here. There is no +PCS/RBR/local-escape premise left for the caller to assume. -/ +theorem sparse (p : Profile) (r : Request p) : + FiatShamirGame.average (fun x : Answer r => if bad r x then 1 else 0) ≤ eta p := by + have hf := CausalBadEvents.fiber_bound p r.statement.lanes r.statement.root + r.statement.claims r.statement.lane_bound r.statement.claim_shape + r.strategy r.coordinate r.past.tape + have hl := CausalBadEvents.localError_le_groupedMaximum r.statement.input r.coordinate + have hm : groupedMaximum (config p) (estimates (config p)) r.statement.claims.size ≤ eta p := by + unfold eta groupedMaximum + exact max_le_max (initialBatch_mono _ r.statement.claim_cap) le_rfl + calc + _ = Soundness.uniformProb (Finset.univ.filter fun x : Answer r => bad r x) := by + simp only [FiatShamirGame.average, Soundness.uniformProb, Finset.sum_boole] + _ ≤ eta p := hf.trans (hl.trans hm) + +abbrev AllocationGame (p : Profile) (n : Nat) := + TypedFiatShamirGame.Game (Request p) Answer n + +noncomputable def risk {p : Profile} {n : Nat} (game : AllocationGame p n) : ℚ := + TypedFiatShamirGame.risk bad game + +/-- Adaptive stopping and arbitrary branches are already inside the game; the +resource cap is the type index of the entire tree, not its successful path. -/ +theorem ordinary_bound (p : Profile) (B K : Nat) (game : AllocationGame p (B*(K+1))) : + risk game ≤ min 1 ((B*(K+1) : Nat) * eta p) := + le_min (TypedFiatShamirGame.risk_le_one bad game) + (TypedFiatShamirGame.risk_bound bad (eta p) (eta_nonneg p) (sparse p) game) + +theorem ordinary_bound_numeric (p : Profile) (B K : Nat) + (game : AllocationGame p (B*(K+1))) : + risk game ≤ min 1 (((B*(K+1) : Nat) : ℚ) / 2^79) := by + apply (ordinary_bound p B K game).trans + apply min_le_min le_rfl + have h := mul_le_mul_of_nonneg_left (eta_le p) (show (0 : ℚ) ≤ (B*(K+1) : Nat) by positivity) + simpa only [mul_one_div] using h + +/-- The actual codec is bijective; query chunks and lambda stay in one product. -/ +abbrev Bytes {c : Config} : Coordinate c → Type + | .initial => FiatShamirGame.Scalar24 + | .fold _ _ => FiatShamirGame.Scalar24 + | .ood i _ => Fin (remaining c i) → FiatShamirGame.Scalar24 + | .query i => (Fin (queryChunks c i) → FiatShamirGame.Scalar24) × FiatShamirGame.Scalar24 + | .tail _ => FiatShamirGame.Scalar24 + +instance {c : Config} (q : Coordinate c) : Fintype (Bytes q) := by + cases q <;> unfold Bytes <;> infer_instance + +def scalarCodec : FiatShamirGame.Scalar24 ≃ E where + toFun := ByteCodec.decodeE + invFun := ByteCodec.encodeE + left_inv := ByteCodec.encodeE_decodeE + right_inv := ByteCodec.decodeE_encodeE + +def codec {c : Config} (q : Coordinate c) : Bytes q ≃ Sample q := + match q with + | .initial => scalarCodec + | .fold _ _ => scalarCodec + | .ood _ _ => Equiv.piCongrRight (fun _ => scalarCodec) + | .query _ => Equiv.prodCongr (Equiv.piCongrRight (fun _ => scalarCodec)) scalarCodec + | .tail _ => scalarCodec + +/-- Exact distribution, not an approximation or cardinality-only assertion. -/ +theorem codec_average {c : Config} (q : Coordinate c) (f : Sample q → ℚ) : + FiatShamirGame.average (fun b : Bytes q => f (codec q b)) = + FiatShamirGame.average f := by + unfold FiatShamirGame.average + rw [Fintype.sum_equiv (codec q) _ f (fun _ => rfl), Fintype.card_congr (codec q)] + +theorem byte_sparse (p : Profile) (r : Request p) : + FiatShamirGame.average (fun b : Bytes r.coordinate => + if bad r (codec r.coordinate b) then 1 else 0) ≤ eta p := by + rw [codec_average r.coordinate (fun x => if bad r x then 1 else 0)] + exact sparse p r + +/-- Unused independent padding is integrated out, never returned to the strategy +as an extra challenge and never resampled on a partial-vector cache read. -/ +theorem padding_average {X Pad : Type*} [Fintype X] [Fintype Pad] [Nonempty Pad] + (f : X → ℚ) : + FiatShamirGame.average (fun pair : X × Pad => f pair.1) = FiatShamirGame.average f := by + have hp : (Fintype.card Pad : ℚ) ≠ 0 := by exact_mod_cast Fintype.card_ne_zero + simp only [FiatShamirGame.average, Fintype.sum_prod_type, Finset.sum_const, + Finset.card_univ, nsmul_eq_mul, ← Finset.mul_sum, Fintype.card_prod, Nat.cast_mul] + field_simp + +/-- Pending coefficients do not enter the truth of the newly folded claim. -/ +theorem fold_pending_irrelevant (candidates : Finset (Array E)) (state : VerifierState E) + (block : Nat) (x : E) (a b : Message E) : + VerifierInvariant.Lost candidates (state.fold block x a) ↔ + VerifierInvariant.Lost candidates (state.fold block x b) := Iff.rfl + +/-- After successful authentication, arbitrary lambda-dependent rows and the +current intro can be replaced by canonical rows and a fixed default intro. +Thus allocation-time truth does not guess the current prover response. -/ +theorem canonical_query_restores (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (state : VerifierState E) + (candidates : Finset (Array E)) + (rowsAt : LevelBoundary.QueryTape (n+rate) count → E → Oracle) + (introAt : LevelBoundary.QueryTape (n+rate) count → E → Message E) + (x : LevelBoundary.QueryTape (n+rate) count × E) + (h : QueryBatchSoundness.Restores n rate count i root cs p state candidates rowsAt introAt x) : + QueryBatchSoundness.Restores n rate count i root cs p state candidates + (fun tape _ => (QueryBatchSoundness.queries (n+rate) count tape).map (fun q => root[q]!)) + (fun _ _ => default) x := by + obtain ⟨hs, ha, hl⟩ := h + have rows := BatchingRefinement.checked_rows_eq root + (QueryBatchSoundness.queries (n+rate) count x.1) + {p with rows := rowsAt x.1 x.2, intro := introAt x.1 x.2} hs ha + change rowsAt x.1 x.2 = + (QueryBatchSoundness.queries (n+rate) count x.1).map (fun q => root[q]!) at rows + refine ⟨by simp, ?_, ?_⟩ + · have he : authenticateRow root (QueryBatchSoundness.queries (n+rate) count x.1) + {p with rows := (QueryBatchSoundness.queries (n+rate) count x.1).map (fun q => root[q]!), intro := default} = + authenticateRow root (QueryBatchSoundness.queries (n+rate) count x.1) + {p with rows := rowsAt x.1 x.2, intro := introAt x.1 x.2} := by + funext j u + simp only [authenticateRow, rows] + rw [he] + exact ha + · have he (ch : LevelChallenges) : + oodBatch ch {p with rows := rowsAt x.1 x.2, intro := introAt x.1 x.2} state = + oodBatch ch {p with rows := (QueryBatchSoundness.queries (n+rate) count x.1).map (fun q => root[q]!), intro := default} state := rfl + dsimp only [queryBatch, VerifierInvariant.Lost, VerifierState.batch] at hl ⊢ + rw [he, rows] at hl + exact hl + +/-- Actual prequery data only: current rows are canonical, current intro ignored. -/ +def QueryEnvelope (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (t : Tape input.config) (x : Sample (.query i)) : Prop := + CausalBoundary.QueryPrior input strategy i t ∧ + QueryBatchSoundness.Restores (remaining input.config i) input.config.rates[i.val]! + input.config.queries[i.val]! i (CausalExecution.levelAt input strategy t i).oracle + (challenges input.config t).levels[i.val]! (CausalExecution.proof input strategy t).levels[i.val]! + (CausalBoundary.boundary input strategy t i).state (CausalExecution.followingCandidates input strategy t i) + (fun tape _ => (QueryBatchSoundness.queries + (remaining input.config i + input.config.rates[i.val]!) input.config.queries[i.val]! tape).map + (fun q => (CausalExecution.levelAt input strategy t i).oracle[q]!)) + (fun _ _ => default) x + +theorem query_implies_envelope (p : Profile) (s : Statement p) (strategy : Strategy) + (i : Fin (config p).folds.size) (t : Tape (config p)) (x : Sample (.query i)) + (h : CausalBoundary.QueryEvent s.input strategy i (set (.query i) t x)) : + QueryEnvelope s.input strategy i t x := by + have facts := CausalBoundary.production_boundary_facts p i + obtain ⟨prior, restores⟩ := CausalBoundary.query_event_fiber s.input strategy t i x + facts.1 facts.2.1 h + exact ⟨prior, canonical_query_restores _ _ _ _ _ _ _ _ _ _ _ _ restores⟩ + +theorem query_envelope_bound (p : Profile) (s : Statement p) (strategy : Strategy) + (i : Fin (config p).folds.size) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter (QueryEnvelope s.input strategy i t)) ≤ + queryBatchError (config p) (estimates (config p)) i := by + classical + by_cases prior : CausalBoundary.QueryPrior s.input strategy i t + · have hb := CausalBoundary.actual_transition s.input strategy t p rfl i + (fun tape _ => (QueryBatchSoundness.queries + (remaining (config p) i + (config p).rates[i.val]!) (config p).queries[i.val]! tape).map + (fun q => (CausalExecution.levelAt s.input strategy t i).oracle[q]!)) + (fun _ _ => default) prior.2.1 prior.2.2.1 prior.2.2.2 + unfold QueryEnvelope + simp only [prior, true_and] + convert hb using 1 + rfl + · have he : (Finset.univ.filter (QueryEnvelope s.input strategy i t)) = ∅ := by + apply Finset.filter_eq_empty_iff.mpr + intro x _ hx + exact prior hx.1 + rw [he] + simp only [Soundness.uniformProb, Finset.card_empty, Nat.cast_zero, zero_div] + have alpha := (production_level_facts p i).2.2.2.2.2.2.1 + unfold queryBatchError estimates fieldSize + split_ifs <;> positivity + +/-- Response-independent envelope on the whole typed draw. -/ +def Envelope (input : Public) (strategy : Strategy) (q : Coordinate input.config) + (t : Tape input.config) : Sample q → Prop := + match q with + | .query i => QueryEnvelope input strategy i t + | q => fun x => CausalBadEvents.Bad input strategy q (set q t x) + +theorem bad_implies_envelope (p : Profile) (s : Statement p) (strategy : Strategy) + (q : Coordinate (config p)) (t : Tape (config p)) (x : Sample q) + (h : CausalBadEvents.Bad s.input strategy q (set q t x)) : + Envelope s.input strategy q t x := by + cases q with + | query i => exact query_implies_envelope p s strategy i t x h + | initial => exact h + | fold i j => exact h + | ood i j => exact h + | tail j => exact h + +theorem envelope_fiber (p : Profile) (s : Statement p) (strategy : Strategy) + (q : Coordinate (config p)) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter (Envelope s.input strategy q t)) ≤ + CausalBadEvents.localError s.input q := by + cases q with + | query i => exact query_envelope_bound p s strategy i t + | initial => exact CausalBadEvents.fiber_bound p s.lanes s.root s.claims s.lane_bound s.claim_shape strategy .initial t + | fold i j => exact CausalBadEvents.fiber_bound p s.lanes s.root s.claims s.lane_bound s.claim_shape strategy (.fold i j) t + | ood i j => exact CausalBadEvents.fiber_bound p s.lanes s.root s.claims s.lane_bound s.claim_shape strategy (.ood i j) t + | tail j => exact CausalBadEvents.fiber_bound p s.lanes s.root s.claims s.lane_bound s.claim_shape strategy (.tail j) t + +def allocationBad {p : Profile} (r : Request p) : Answer r → Prop := + Envelope r.statement.input r.strategy r.coordinate r.past.tape + +theorem allocation_sparse (p : Profile) (r : Request p) : + FiatShamirGame.average (fun x : Answer r => if allocationBad r x then 1 else 0) ≤ eta p := by + have hf := envelope_fiber p r.statement r.strategy r.coordinate r.past.tape + have hl := CausalBadEvents.localError_le_groupedMaximum r.statement.input r.coordinate + have hm : groupedMaximum (config p) (estimates (config p)) r.statement.claims.size ≤ eta p := by + unfold eta groupedMaximum + exact max_le_max (initialBatch_mono _ r.statement.claim_cap) le_rfl + calc + _ = Soundness.uniformProb (Finset.univ.filter fun x : Answer r => allocationBad r x) := by + simp only [FiatShamirGame.average, Soundness.uniformProb, Finset.sum_boole] + _ ≤ eta p := hf.trans (hl.trans hm) + +theorem bad_implies_allocationBad {p : Profile} (r : Request p) (x : Answer r) + (h : bad r x) : allocationBad r x := + bad_implies_envelope p r.statement r.strategy r.coordinate r.past.tape x h + +noncomputable def allocationRisk {p : Profile} {n : Nat} (game : AllocationGame p n) : ℚ := + TypedFiatShamirGame.risk allocationBad game + +theorem allocation_bound (p : Profile) (B K : Nat) (game : AllocationGame p (B*(K+1))) : + allocationRisk game ≤ min 1 ((B*(K+1) : Nat) * eta p) := + le_min (TypedFiatShamirGame.risk_le_one allocationBad game) + (TypedFiatShamirGame.risk_bound allocationBad (eta p) (eta_nonneg p) (allocation_sparse p) game) + +theorem allocation_byte_sparse (p : Profile) (r : Request p) : + FiatShamirGame.average (fun b : Bytes r.coordinate => + if allocationBad r (codec r.coordinate b) then 1 else 0) ≤ eta p := by + rw [codec_average r.coordinate (fun x => if allocationBad r x then 1 else 0)] + exact allocation_sparse p r + +/-- Profiles may change between branches/statements. Only the request tag is a +sum; the random answer is always uniform in that request's exact fiber. -/ +abbrev AnyRequest := (p : Profile) × Request p +abbrev AnyAnswer (r : AnyRequest) := Answer r.2 + +def anyAllocationBad (r : AnyRequest) : AnyAnswer r → Prop := allocationBad r.2 + +theorem any_allocation_sparse (r : AnyRequest) : + FiatShamirGame.average (fun x : AnyAnswer r => if anyAllocationBad r x then 1 else 0) ≤ + (1 / 2^79 : ℚ) := + (allocation_sparse r.1 r.2).trans (eta_le r.1) + +theorem all_profiles_allocation_bound (B K : Nat) + (game : TypedFiatShamirGame.Game AnyRequest AnyAnswer (B*(K+1))) : + TypedFiatShamirGame.risk anyAllocationBad game ≤ + min 1 (((B*(K+1) : Nat) : ℚ) / 2^79) := by + refine le_min (TypedFiatShamirGame.risk_le_one anyAllocationBad game) ?_ + have h := TypedFiatShamirGame.risk_bound anyAllocationBad (1/2^79) + (by positivity) any_allocation_sparse game + simpa only [mul_one_div] using h + +def Prefix.ofTape {c : Config} (q : Coordinate c) (t : Tape c) : Prefix q := + fun r _ => get r t + +theorem prefix_get {c : Config} (q r : Coordinate c) (t : Tape c) + (past : position r < position q) : + get r (Prefix.ofTape q t).tape = get r t := by + change (coordinates c ((coordinates c).symm _)) r = _ + simp only [Equiv.apply_symm_apply] + simp only [Prefix.ofTape, dite_eq_left past] + +/-- Zero filling does not leak a sampled suffix: every relevant event is +identical on the actual tape and its strict prefix plus current response. -/ +theorem bad_prefix (p : Profile) (s : Statement p) (strategy : Strategy) + (q : Coordinate (config p)) (t : Tape (config p)) : + CausalBadEvents.Bad s.input strategy q t ↔ + CausalBadEvents.Bad s.input strategy q + (set q (Prefix.ofTape q t).tape (get q t)) := by + apply CausalPrefix.bad_congr s.input strategy (production_config_valid p).1 + intro r hr + by_cases same : r = q + · subst r + rw [get_set] + · rw [get_set_ne q r _ _ same] + symm + apply prefix_get + have ne : position r ≠ position q := fun h => same (CausalPrefix.position_injective _ h) + omega + +def requestOfTape {p : Profile} (s : Statement p) (strategy : Strategy) + (q : Coordinate (config p)) (t : Tape (config p)) : Request p := + ⟨s, strategy, q, Prefix.ofTape q t⟩ + +/-- The parent actual-verifier cover is instantiated, not left as a soundness +assumption. The list was fixed from the initial commitment before the claims. -/ +theorem accepted_false_prefix_cover (p : Profile) (s : Statement p) (strategy : Strategy) + (t : Tape (config p)) (accepted : experiment s.input strategy t = true) + (hfalse : ¬ ∃ w ∈ InitialCandidates.witnesses (config p) s.lanes s.root, + ∀ claim ∈ s.claims.toList, + dot (paddedWitness (config p) s.lanes w) claim.weight = claim.value) : + ∃ q, allocationBad (requestOfTape s strategy q t) (get q t) := by + obtain ⟨q, hq⟩ := InteractiveSoundness.accepted_false_cover p s.lanes s.root + s.claims strategy t accepted hfalse + refine ⟨q, bad_implies_allocationBad _ _ ?_⟩ + exact (bad_prefix p s strategy q t).mp hq + +/-- The stacked-opening first allocation is eight field elements: gamma, six +map scalars, and lambda. There is no intermediate response or second draw. -/ +structure StackInitial (p : Profile) (familyCap : Nat) where + lanes : Nat + root : BaseOracle + lane_bound : lanes ≤ 2 ^ (config p).folds[0]! + familyCount : Nat + family : Fin familyCount → RingPCSGame.FamilyClaim + family_bound : familyCount ≤ familyCap + points : Array RingPCSGame.PointClaim + claim_bound : points.size + 1 ≤ 2^64 + +def ringCharge (familyCap : Nat) : ℚ := + (2^32 : ℚ) * (((familyCap-1 : Nat) : ℚ) / 2^192 + 1/2^160) + +theorem ringCharge_nonneg (familyCap : Nat) : 0 ≤ ringCharge familyCap := by + unfold ringCharge + positivity + +theorem ringCharge_mono {a b : Nat} (h : a ≤ b) : ringCharge a ≤ ringCharge b := by + unfold ringCharge + apply mul_le_mul_of_nonneg_left _ (by positivity) + apply add_le_add + · apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Nat.sub_le_sub_right h 1 + · exact le_rfl + +inductive StackRequest (p : Profile) (familyCap : Nat) where + | initial (data : StackInitial p familyCap) + | later (request : Request p) (notInitial : request.coordinate ≠ .initial) + +abbrev StackAnswer {p : Profile} {cap : Nat} : StackRequest p cap → Type + | .initial _ => RingPCSGame.Prefix × E + | .later r _ => Answer r + +instance {p : Profile} {cap : Nat} (r : StackRequest p cap) : Fintype (StackAnswer r) := by + cases r <;> unfold StackAnswer <;> infer_instance + +instance {p : Profile} {cap : Nat} (r : StackRequest p cap) : Nonempty (StackAnswer r) := by + cases r <;> unfold StackAnswer <;> infer_instance + +def stackBad {p : Profile} {cap : Nat} (r : StackRequest p cap) : StackAnswer r → Prop := + match r with + | .initial d => RingPCSGame.InitialEvent p d.lanes d.root d.family d.points + | .later r _ => allocationBad r + +def stackEta (p : Profile) (familyCap : Nat) : ℚ := eta p + ringCharge familyCap + +theorem stack_sparse (p : Profile) (cap : Nat) (r : StackRequest p cap) : + FiatShamirGame.average (fun x : StackAnswer r => if stackBad r x then 1 else 0) ≤ + stackEta p cap := by + cases r with + | later r hn => + exact (allocation_sparse p r).trans (le_add_of_nonneg_right (ringCharge_nonneg cap)) + | initial d => + have hb := RingPCSGame.initial_event_probability p d.lanes d.root d.lane_bound d.family d.points + have hi : (d.points.size : ℚ) / 2^160 = + initialBatch (config p) (estimates (config p)) (d.points.size+1) := by + unfold initialBatch + rw [dite_eq_left (production_config_valid p).2.1] + simp only [estimates, fieldSize, Nat.add_sub_cancel_right] + norm_num + ring + have hp : (d.points.size : ℚ) / 2^160 ≤ eta p := by + rw [hi] + exact (initialBatch_mono _ d.claim_bound).trans (le_max_left _ _) + have hr := ringCharge_mono d.family_bound + calc + _ = Soundness.uniformProb (Finset.univ.filter (RingPCSGame.InitialEvent p d.lanes d.root d.family d.points)) := by + change FiatShamirGame.average (fun x : RingPCSGame.Prefix × E => + if RingPCSGame.InitialEvent p d.lanes d.root d.family d.points x then (1 : ℚ) else 0) = _ + simp only [FiatShamirGame.average, Soundness.uniformProb, Finset.sum_boole] + _ ≤ ringCharge d.familyCount + (d.points.size : ℚ) / 2^160 := hb + _ ≤ stackEta p cap := by unfold stackEta; linarith + +theorem stack_allocation_bound (p : Profile) (familyCap B K : Nat) + (game : TypedFiatShamirGame.Game (StackRequest p familyCap) StackAnswer (B*(K+1))) : + TypedFiatShamirGame.risk stackBad game ≤ + min 1 ((B*(K+1) : Nat) * stackEta p familyCap) := + le_min (TypedFiatShamirGame.risk_le_one stackBad game) + (TypedFiatShamirGame.risk_bound stackBad (stackEta p familyCap) + (add_nonneg (eta_nonneg p) (ringCharge_nonneg familyCap)) (stack_sparse p familyCap) game) + +end Whir.WHIRFiatShamir diff --git a/verification/whir/Whir/WHIRHistory.lean b/verification/whir/Whir/WHIRHistory.lean new file mode 100644 index 000000000..48e0f1435 --- /dev/null +++ b/verification/whir/Whir/WHIRHistory.lean @@ -0,0 +1,900 @@ +import Whir.ByteCodec +import Whir.CausalProbability +import Whir.CausalPrefix +import Whir.TypedFiatShamirGame +import Whir.DuplexRefinement + +/-! Concrete PCS transport syntax at conditional #552, revision +`ff6a275304a3b577118b066ddcff83bfafa5998d`. This is a hand-port of the +Rust call schedule, not a theorem about compilation of Rust. Scalars are the +three little-endian words; a root is two scalars with zero spare limbs. +Merkle rows and paths, and the reconstructed linear coefficient, are not +absorbed. The caller binds the initial root and claims upstream; the initial +batching scalar adds no observation. No injectivity of a digest is asserted. +PoW is a separate nonce event, with no amplification of the PCS error. -/ +namespace Whir.WHIRHistory +open Concrete Protocol CausalGame CausalProbability FiatShamirGame + +/-- Concatenation intentionally forgets individual `observe` call boundaries. -/ +def scalarBytes (xs : List E) : List Byte := + xs.flatMap (fun x => List.ofFn (ByteCodec.encodeE x)) + +theorem scalarBytes_length (xs : List E) : (scalarBytes xs).length = 24 * xs.length := by + induction xs with + | nil => simp [scalarBytes] + | cons x xs ih => + change (List.ofFn (ByteCodec.encodeE x) ++ scalarBytes xs).length = _ + rw [List.length_append, List.length_ofFn, ih, List.length_cons] + omega + +/-- A bounded parser, retaining an unconsumed suffix for the next wire field. -/ +def parseScalars : Nat → List Byte → Option (List E × List Byte) + | 0, bs => some ([], bs) + | n+1, bs => + if h : 24 ≤ bs.length then + let x := ByteCodec.decodeE (fun i => bs[i.val]'(by omega)) + (parseScalars n (bs.drop 24)).map (fun p => (x :: p.1, p.2)) + else none + +theorem parseScalars_append (xs : List E) (suffix : List Byte) : + parseScalars xs.length (scalarBytes xs ++ suffix) = some (xs, suffix) := by + induction xs with + | nil => rfl + | cons x xs ih => + have hlen : 24 ≤ (scalarBytes (x :: xs) ++ suffix).length := by + simp [scalarBytes_length]; omega + simp only [List.length_cons, parseScalars, hlen, dite_true] + have first : (fun i : Fin 24 => + (scalarBytes (x :: xs) ++ suffix)[i.val]'(by have := i.isLt; omega)) = + ByteCodec.encodeE x := by + funext i + simp only [scalarBytes, List.flatMap_cons, List.append_assoc] + rw [List.getElem_append_left (by simpa only [List.length_ofFn] using i.isLt)] + exact List.getElem_ofFn _ + rw [first, ByteCodec.decodeE_encodeE] + simpa [scalarBytes, List.drop_append] using + congrArg (Option.map (fun p : List E × List Byte => (x :: p.1, p.2))) ih + +theorem scalarBytes_injective : Function.Injective scalarBytes := by + intro xs ys h + have hl := congrArg List.length h + rw [scalarBytes_length, scalarBytes_length] at hl + have hn : xs.length = ys.length := by omega + have hx := parseScalars_append xs [] + have hy := parseScalars_append ys [] + simp only [List.append_nil] at hx hy + rw [h, hn, hy] at hx + exact (Prod.mk.inj (Option.some.inj hx)).1.symm + +def parseExact (n : Nat) (bs : List Byte) : Option (List E) := do + let (xs, rest) ← parseScalars n bs + if rest = [] then some xs else none + +theorem parseExact_roundtrip (xs : List E) : + parseExact xs.length (scalarBytes xs) = some xs := by + have h := parseScalars_append xs [] + simp only [List.append_nil] at h + simp [parseExact, h] + +def rootScalars (root : Digest32) : List E := + let p := ByteCodec.hashToScalars root + [p.1, p.2] + +def rootBytes (root : Digest32) : List Byte := scalarBytes (rootScalars root) + +def parseRoot (bs : List Byte) : Option Digest32 := do + let xs ← parseExact 2 bs + match xs with + | [a,b] => ByteCodec.scalarsToHash (a,b) + | _ => none + +theorem parseRoot_roundtrip (root : Digest32) : parseRoot (rootBytes root) = some root := by + have h := parseExact_roundtrip (rootScalars root) + simp only [rootScalars, List.length_cons, List.length_nil] at h + simp [parseRoot, rootBytes, h, rootScalars, ByteCodec.scalarsToHash_hashToScalars] + +theorem rootBytes_injective : Function.Injective rootBytes := by + intro a b h + have := congrArg parseRoot h + simpa only [parseRoot_roundtrip, Option.some.injEq] using this + +/-- WHIR sends only the constant and quadratic coefficients, in that order. -/ +def messageScalars (m : Message E) : List E := [m.u0, m.u2] + +/-- The missing linear coefficient is reconstructed, never serialized. -/ +def decodeMessage (xs : List E) : Option (Message E) := + match xs with + | [a,b] => some ⟨a,b⟩ + | _ => none + +theorem message_roundtrip (m : Message E) : decodeMessage (messageScalars m) = some m := by + cases m; rfl + +/-- Last-level residuals are absorbed in full; earlier boundaries absorb a +48-byte digest encoding, not the extracted full oracle. -/ +def boundaryScalars (c : Config) (i : Nat) (digest : Digest32) (residual : Array E) : List E := + if i + 1 < c.folds.size then rootScalars digest else residual.toList + +/-- Projection of actual causal replies to the absorbed scalar stream. The +root digest is explicit side input: relating it to `Reply.fold.next` is the +Merkle extraction game's responsibility. Query rows are deliberately erased. +Tag mismatches reject here, without affecting the fixed challenge cap. -/ +def replyScalars {c : Config} (q : Coordinate c) (digest : Digest32) : Reply → Option (List E) := + match q with + | .initial => fun r => match r with + | .initial m => some (messageScalars m) + | _ => none + | .fold i j => fun r => match r with + | .fold m _ residual => some (messageScalars m ++ + if j.val + 1 = c.folds[i.val]! then boundaryScalars c i.val digest residual else []) + | _ => none + | .ood _ _ => fun r => match r with + | .ood claim => some (claim.value :: messageScalars claim.intro) + | _ => none + | .query _ => fun r => match r with + | .query _ m => some (messageScalars m) + | _ => none + | .tail _ => fun r => match r with + | .tail m => some (messageScalars m) + | _ => none + +theorem query_rows_unbound {c : Config} (i : Fin c.folds.size) (d : Digest32) + (rows rows' : Oracle) (m : Message E) : + replyScalars (.query i) d (.query rows m) = replyScalars (.query i) d (.query rows' m) := rfl + +theorem fold_oracle_unbound {c : Config} (i : Fin c.folds.size) + (j : Fin c.folds[i.val]!) (d : Digest32) (a b : Option Oracle) + (m : Message E) (residual : Array E) : + replyScalars (.fold i j) d (.fold m a residual) = + replyScalars (.fold i j) d (.fold m b residual) := rfl + +/-- Each call consumes a complete field element, including unused query bits. +The lambda is the last coordinate of the same allocation as the query chunks. -/ +def scalarCount {c : Config} : Coordinate c → Nat + | .ood i _ => remaining c i.val + | .query i => queryChunks c i.val + 1 + | _ => 1 + +def sampleScalars {c : Config} (q : Coordinate c) : Sample q → List E := + match q with + | .initial => fun x => [x] + | .fold _ _ => fun x => [x] + | .ood _ _ => List.ofFn + | .query _ => fun x => List.ofFn x.1 ++ [x.2] + | .tail _ => fun x => [x] + +theorem sampleScalars_length {c : Config} (q : Coordinate c) (x : Sample q) : + (sampleScalars q x).length = scalarCount q := by + cases q <;> simp [sampleScalars, scalarCount] + +/-- The final tail squeeze is real, but has no following adversarial response. -/ +def hiddenTail (c : Config) : List (Coordinate c) := + if h : 0 < c.logN - c.folds.toList.sum then + [.tail ⟨c.logN - c.folds.toList.sum - 1, by omega⟩] + else [] + +def schedule (c : Config) : List (Coordinate c) := visibleCoordinates c ++ hiddenTail c + +def depth (c : Config) : Nat := (schedule c).length + +theorem schedule_visible (c : Config) (t : Tape c) : + (visibleCoordinates c).map (fun q => batch q (get q t)) = + visibleBatches c t.1 (challenges c t) := visibleCoordinates_map c t + +theorem hiddenTail_no_response (c : Config) (j : Fin (c.logN - c.folds.toList.sum)) + (last : j.val + 1 = c.logN - c.folds.toList.sum) (t : Tape c) (x : E) + (strategy : Strategy) (input : Public) : + run strategy input [] (visibleBatches c (set (.tail j) t x).1 (challenges c (set (.tail j) t x))) = + run strategy input [] (visibleBatches c t.1 (challenges c t)) := + final_tail_response j last t x strategy input + +/-- One canonical pending input. Empty scalar input is permitted, in particular +for initial batching and adjacent squeezes. PoW nonces are not `observe` calls. -/ +structure Pending where + scalars : List E + nonce : Option (Nat × E) + + deriving DecidableEq +def encodePending (m : Pending) : List Byte × Option (Nat × Scalar24) := + (scalarBytes m.scalars, m.nonce.map (fun p => (p.1, ByteCodec.encodeE p.2))) + +def decodePending (n : Nat) (wire : List Byte × Option (Nat × Scalar24)) : Option Pending := do + let scalars ← parseExact n wire.1 + pure ⟨scalars, wire.2.map (fun p => (p.1, ByteCodec.decodeE p.2))⟩ + +theorem pending_roundtrip (m : Pending) : + decodePending m.scalars.length (encodePending m) = some m := by + rcases m with ⟨xs, nonce⟩ + simp only [decodePending, encodePending, parseExact_roundtrip] + cases nonce <;> simp [ByteCodec.decodeE_encodeE] + +theorem encodePending_injective : Function.Injective encodePending := by + rintro ⟨xs,n⟩ ⟨ys,m⟩ h + have hx : xs = ys := scalarBytes_injective (congrArg Prod.fst h) + subst ys + have hn := congrArg Prod.snd h + have hi : Function.Injective (fun p : Nat × E => (p.1, ByteCodec.encodeE p.2)) := by + intro a b he + change (a.1, ByteCodec.encodeE a.2) = (b.1, ByteCodec.encodeE b.2) at he + exact Prod.ext (Prod.mk.inj he).1 (ByteCodec.encodeE_injective (Prod.mk.inj he).2) + have hm : n = m := Option.map_injective hi hn + subst m + rfl + +/-- Execute the exact special nonce transition, not a guessed ordinary absorb. -/ +def pendingModel (m : DuplexRefinement.Model) (p : Pending) : DuplexRefinement.Model := + let m := DuplexRefinement.modelAbsorb m (scalarBytes p.scalars) + match p.nonce with + | none => m + | some (bits, nonce) => DuplexRefinement.modelNonce m (ByteCodec.encodeE nonce) bits + +def requestModel {c : Config} (m : DuplexRefinement.Model) (p : Pending) + (q : Coordinate c) : DuplexRefinement.Model := + DuplexRefinement.modelSqueeze (pendingModel m p) (24 * scalarCount q) + +/-- Canonical syntax keys retain whole typed ancestor answers. This encoder +changes only the absorbed-message representation, not the dependent alphabet. -/ +def encodeInput {c : Config} + (input : TypedFiatShamirGame.FullInput Digest32 Pending (Coordinate c) Sample) : + TypedFiatShamirGame.FullInput Digest32 (List Byte × Option (Nat × Scalar24)) (Coordinate c) Sample := + ⟨input.statement, input.messages.map encodePending, + input.ancestors.map (fun p => (encodePending p.1, p.2))⟩ + +theorem encodeInput_injective (c : Config) : Function.Injective (@encodeInput c) := by + intro a b h + have hs := congrArg TypedFiatShamirGame.FullInput.statement h + have hm := congrArg TypedFiatShamirGame.FullInput.messages h + have ha := congrArg TypedFiatShamirGame.FullInput.ancestors h + have hm' := (List.map_injective_iff.mpr encodePending_injective) hm + have hi : Function.Injective (fun p : Pending × Sigma (@Sample c) => (encodePending p.1, p.2)) := by + intro x y he + change (encodePending x.1, x.2) = (encodePending y.1, y.2) at he + exact Prod.ext (encodePending_injective (Prod.mk.inj he).1) (Prod.mk.inj he).2 + have ha' := (List.map_injective_iff.mpr hi) ha + change a.statement = b.statement at hs + cases a; cases b; simp_all + +/-- Syntax admission is independent of acceptance: arbitrary pending bytes and +malformed replies may occur, but extra challenge positions are rejected. -/ +def admissible (c : Config) (messages : List Pending) : Bool := decide (messages.length ≤ depth c) + +theorem admitted_depth (c : Config) (messages : List Pending) + (h : admissible c messages = true) : messages.length ≤ depth c := by + simpa [admissible] using h + +/-- A single global cache across statements and branches, with the final +invisible request charged as well. No accepted-proof hypothesis appears. -/ +theorem cache_cap (c : Config) + (query : Digest32 × List Pending → Coordinate c) + (oracle : TypedFiatShamirGame.Oracle (A := Sample) query) + (K : Nat) (requests : List (Digest32 × List Pending)) + (final : Digest32 × List Pending) + (cache : TypedFiatShamirGame.Cache (Digest32 × List Pending) (fun key => Sample (query key))) + (budget : requests.length ≤ K) + (admitted : ∀ key ∈ requests, admissible c key.2 = true) + (finalAdmitted : admissible c final.2 = true) : + (TypedFiatShamirGame.serve query oracle (requests ++ [final]) cache).2 ≤ depth c * (K+1) := by + classical + exact TypedFiatShamirGame.serve_cap query oracle (depth c) K requests final cache budget + (fun key hk => admitted_depth c key.2 (admitted key hk)) + (admitted_depth c final.2 finalAdmitted) + +/-- Primitive events generated by the PCS schedule. The auxiliary nonce is +opaque to the PCS algebra; verification of its predicate is separate. -/ +inductive Event where + | observe (xs : List E) + | nonce (bits : Nat) (value : E) + | squeeze (bytes : Nat) + +def challengeEvents {c : Config} (q : Coordinate c) (bits : Nat) (nonce : E) : List Event := + (match q with | .query _ => [.nonce bits nonce] | _ => []) ++ + [.squeeze (24 * scalarCount q)] + +def coordinateLevel {c : Config} : Coordinate c → Nat + | .fold i _ => i.val + | .ood i _ => i.val + | .query i => i.val + | _ => 0 + +/-- Merkle side data contributes no event. This compiler checks all reply tags, +including those on rejecting branches, and never reads a future challenge. -/ +def visibleEvents {c : Config} (digests : Nat → Digest32) (bits : Nat → Nat) + (nonces : Nat → E) : List (Coordinate c) → List Reply → Option (List Event) + | [], [] => some [] + | q :: qs, r :: rs => do + let xs ← replyScalars q (digests (coordinateLevel q)) r + let rest ← visibleEvents digests bits nonces qs rs + pure (challengeEvents q (bits (coordinateLevel q)) (nonces (coordinateLevel q)) ++ [.observe xs] ++ rest) + | _, _ => none + +def wireEvents (c : Config) (digests : Nat → Digest32) (bits : Nat → Nat) + (nonces : Nat → E) (replies : List Reply) : Option (List Event) := do + let visible ← visibleEvents digests bits nonces (visibleCoordinates c) replies + pure (visible ++ (hiddenTail c).map (fun q => Event.squeeze (24 * scalarCount q))) + +def modelEvent (m : DuplexRefinement.Model) : Event → DuplexRefinement.Model + | .observe xs => DuplexRefinement.modelAbsorb m (scalarBytes xs) + | .nonce bits value => DuplexRefinement.modelNonce m (ByteCodec.encodeE value) bits + | .squeeze n => DuplexRefinement.modelSqueeze m n + +def modelEvents (m : DuplexRefinement.Model) (events : List Event) : DuplexRefinement.Model := + events.foldl modelEvent m + +/-- The executable mode checks cursor limits and the actual PoW predicate. +Failure rejects; no continuation, retry, or grinding credit is added. -/ +def executeEvent (compress : DuplexRefinement.Compression) + (powOK : Digest32 → Scalar24 → Nat → Bool) + (s : DuplexRefinement.State) : Event → Option DuplexRefinement.State + | .observe xs => some (DuplexRefinement.absorb compress s (scalarBytes xs)) + | .nonce bits value => + match DuplexRefinement.verifyNonce compress powOK s (ByteCodec.encodeE value) bits with + | .ok (t, true) => some t + | _ => none + | .squeeze n => + match DuplexRefinement.squeeze compress s n with + | .ok (t, _) => some t + | .error _ => none + +def executeEvents (compress : DuplexRefinement.Compression) + (powOK : Digest32 → Scalar24 → Nat → Bool) : + DuplexRefinement.State → List Event → Option DuplexRefinement.State + | s, [] => some s + | s, e :: es => do + let t ← executeEvent compress powOK s e + executeEvents compress powOK t es + +theorem executeEvent_represents (compress : DuplexRefinement.Compression) + (powOK : Digest32 → Scalar24 → Nat → Bool) (iv : Digest32) + (m : DuplexRefinement.Model) (s t : DuplexRefinement.State) (e : Event) + (h : DuplexRefinement.Represents compress iv m s) + (ok : executeEvent compress powOK s e = some t) : + DuplexRefinement.Represents compress iv (modelEvent m e) t := by + cases e with + | observe xs => + simp only [executeEvent, Option.some.injEq] at ok + subst t + exact DuplexRefinement.absorb_represents compress iv m s h (scalarBytes xs) + | nonce bits value => + simp only [executeEvent] at ok + split at ok + next u he => + cases ok + exact DuplexRefinement.verifyNonce_represents compress powOK iv m s t h + (ByteCodec.encodeE value) bits true he + next => contradiction + | squeeze n => + simp only [executeEvent] at ok + split at ok + next u bs he => + cases ok + exact DuplexRefinement.squeeze_represents compress iv m s t h n bs he + next => contradiction + +theorem executeEvents_represents (compress : DuplexRefinement.Compression) + (powOK : Digest32 → Scalar24 → Nat → Bool) (iv : Digest32) + (events : List Event) (m : DuplexRefinement.Model) (s t : DuplexRefinement.State) + (h : DuplexRefinement.Represents compress iv m s) + (ok : executeEvents compress powOK s events = some t) : + DuplexRefinement.Represents compress iv (modelEvents m events) t := by + induction events generalizing m s with + | nil => + simp only [executeEvents, Option.some.injEq] at ok + subst t + exact h + | cons e es ih => + simp only [executeEvents] at ok + cases he : executeEvent compress powOK s e with + | none => simp [he] at ok + | some u => + simp only [he] at ok + exact ih (modelEvent m e) u (executeEvent_represents compress powOK iv m s u e h he) ok + +/-- Canonical semantic runs, rather than the unobservable boundaries between +individual `observe` calls. Length and cursor are part of the real frame. -/ +inductive SemanticFrame where + | absorb (previous : Nat) (scalars : List E) + | nonce (previous bits : Nat) (value : E) + +def encodeFrame : SemanticFrame → Frame + | .absorb previous xs => .absorb previous (scalarBytes xs) + | .nonce previous bits x => .nonce previous bits (ByteCodec.encodeE x) + +def parseFrame : Frame → Option SemanticFrame + | .absorb previous bytes => + (parseExact (bytes.length / 24) bytes).map (SemanticFrame.absorb previous) + | .nonce previous bits bytes => some (.nonce previous bits (ByteCodec.decodeE bytes)) + +theorem frame_roundtrip (f : SemanticFrame) : parseFrame (encodeFrame f) = some f := by + cases f with + | absorb previous xs => + simp only [encodeFrame, parseFrame, scalarBytes_length] + simp [parseExact_roundtrip] + | nonce previous bits value => simp [encodeFrame, parseFrame, ByteCodec.decodeE_encodeE] + +theorem encodeFrame_injective : Function.Injective encodeFrame := by + intro a b h + have := congrArg parseFrame h + simpa only [frame_roundtrip, Option.some.injEq] using this + +structure SemanticHistory where + domain : Digest32 + statement : Digest32 + frames : List SemanticFrame + +def encodeHistory (h : SemanticHistory) : FramedHistory := + ⟨h.domain, h.statement, h.frames.map encodeFrame⟩ + +def parseFrames : List Frame → Option (List SemanticFrame) + | [] => some [] + | f :: fs => do + let x ← parseFrame f + let xs ← parseFrames fs + pure (x :: xs) + +theorem frames_roundtrip (fs : List SemanticFrame) : + parseFrames (fs.map encodeFrame) = some fs := by + induction fs with + | nil => rfl + | cons f fs ih => simp [parseFrames, frame_roundtrip, ih] + +def parseHistory (h : FramedHistory) : Option SemanticHistory := + (parseFrames h.frames).map (fun fs => ⟨h.domain,h.statement,fs⟩) + +theorem history_roundtrip (h : SemanticHistory) : + parseHistory (encodeHistory h) = some h := by + cases h + simp [parseHistory, encodeHistory, frames_roundtrip] + +theorem encodeHistory_injective : Function.Injective encodeHistory := by + intro a b h + have := congrArg parseHistory h + simpa only [history_roundtrip, Option.some.injEq] using this + +theorem scalarBytes_append (xs ys : List E) : + scalarBytes (xs ++ ys) = scalarBytes xs ++ scalarBytes ys := by + exact List.flatMap_append + +theorem scalarBytes_empty (xs : List E) : scalarBytes xs = [] ↔ xs = [] := by + constructor + · intro h + have hl := congrArg List.length h + rw [scalarBytes_length] at hl + exact List.length_eq_zero_iff.mp (by simpa using hl) + · rintro rfl + rfl + +/-- A concrete scalar-run lift of the #552 ghost state. This remembers no +unbound proof fields and no boundaries between adjacent scalar observations. -/ +structure SemanticModel where + history : SemanticHistory + run : List E := [] + previous : Nat := 0 + consumed : Nat := 0 + +def encodeModel (m : SemanticModel) : DuplexRefinement.Model := + ⟨encodeHistory m.history, scalarBytes m.run, m.previous, m.consumed⟩ + +def closeSemantic (m : SemanticModel) : SemanticModel := + if m.run = [] then m else + {m with + history := {m.history with frames := m.history.frames ++ [.absorb m.previous m.run]} + run := [] + previous := 0} + +theorem closeSemantic_encode (m : SemanticModel) : + encodeModel (closeSemantic m) = DuplexRefinement.closeRun (encodeModel m) := by + by_cases h : m.run = [] + · simp [closeSemantic, DuplexRefinement.closeRun, encodeModel, scalarBytes_empty, h] + · simp only [closeSemantic, DuplexRefinement.closeRun, encodeModel, scalarBytes_empty, h, + ↓reduceIte, encodeHistory, List.map_append, List.map_cons, List.map_nil, encodeFrame] + rfl + +def semanticEvent (m : SemanticModel) : Event → SemanticModel + | .observe xs => if xs = [] then m else + {m with + run := m.run ++ xs + previous := if m.consumed = 0 then m.previous else m.consumed + consumed := 0} + | .nonce bits value => + let m := closeSemantic m + {history := {m.history with frames := m.history.frames ++ [.nonce m.consumed bits value]}} + | .squeeze n => if n = 0 then m else {closeSemantic m with consumed := m.consumed + n} + +theorem semanticEvent_encode (m : SemanticModel) (e : Event) : + encodeModel (semanticEvent m e) = modelEvent (encodeModel m) e := by + cases e with + | observe xs => + by_cases h : xs = [] + · simp [semanticEvent, modelEvent, DuplexRefinement.modelAbsorb, scalarBytes_empty, h] + · simp [semanticEvent, modelEvent, DuplexRefinement.modelAbsorb, scalarBytes_empty, h, + encodeModel, scalarBytes_append] + rfl + | nonce bits value => + simp only [semanticEvent, modelEvent, DuplexRefinement.modelNonce, + ← closeSemantic_encode] + simp [encodeModel, encodeHistory, encodeFrame, scalarBytes] + | squeeze n => + by_cases h : n = 0 + · simp [semanticEvent, modelEvent, DuplexRefinement.modelSqueeze, h] + · simp only [semanticEvent, modelEvent, DuplexRefinement.modelSqueeze, h, ↓reduceIte, + ← closeSemantic_encode] + rfl + +def semanticEvents (m : SemanticModel) (events : List Event) : SemanticModel := + events.foldl semanticEvent m + +theorem semanticEvents_encode (m : SemanticModel) (events : List Event) : + encodeModel (semanticEvents m events) = modelEvents (encodeModel m) events := by + induction events generalizing m with + | nil => rfl + | cons e es ih => + change encodeModel (semanticEvents (semanticEvent m e) es) = + modelEvents (modelEvent (encodeModel m) e) es + rw [ih, semanticEvent_encode] + +/-- Every compiled PCS trace, including concatenated observations and empty +squeezes, has a checked executable canonical semantic-history parser. -/ +theorem compiled_history_parses (m : SemanticModel) (events : List Event) : + parseHistory (DuplexRefinement.closeRun (modelEvents (encodeModel m) events)).history = + some (closeSemantic (semanticEvents m events)).history := by + rw [← semanticEvents_encode, ← closeSemantic_encode] + exact history_roundtrip _ + +/-- Inverse of the absorbed-field projection. `lookup` is the separately +extracted commitment table; `rows` are separately authenticated ordered rows. +Neither is serialized or postulated to be recoverable from a hash alone. -/ +def decodeReplyScalars {c : Config} (q : Coordinate c) (lookup : Digest32 → Oracle) + (rows : Oracle) (xs : List E) : Option Reply := + match q with + | .initial => (decodeMessage xs).map Reply.initial + | .tail _ => (decodeMessage xs).map Reply.tail + | .ood _ _ => match xs with + | [y,a,b] => some (.ood ⟨y,⟨a,b⟩⟩) + | _ => none + | .query _ => (decodeMessage xs).map (Reply.query rows) + | .fold i j => match xs with + | a :: b :: rest => + if j.val + 1 = c.folds[i.val]! then + if i.val + 1 < c.folds.size then + match rest with + | [r,s] => (ByteCodec.scalarsToHash (r,s)).map + (fun digest => .fold ⟨a,b⟩ (some (lookup digest)) #[]) + | _ => none + else if rest.length = 2 ^ remaining c i.val then + some (.fold ⟨a,b⟩ none rest.toArray) + else none + else if rest = [] then some (.fold ⟨a,b⟩ none #[]) else none + | _ => none + +/-- Canonicalization removes precisely the proof fields absent from this wire +position. It does not assert that arbitrary unauthenticated input equals its +canonicalization. -/ +def canonicalReply {c : Config} (q : Coordinate c) (digest : Digest32) + (lookup : Digest32 → Oracle) (rows : Oracle) : Reply → Option Reply := + match q with + | .initial => fun r => match r with | .initial m => some (.initial m) | _ => none + | .tail _ => fun r => match r with | .tail m => some (.tail m) | _ => none + | .ood _ _ => fun r => match r with | .ood o => some (.ood o) | _ => none + | .query _ => fun r => match r with | .query _ m => some (.query rows m) | _ => none + | .fold i j => fun r => match r with + | .fold m _ residual => + if j.val + 1 = c.folds[i.val]! then + if i.val + 1 < c.folds.size then some (.fold m (some (lookup digest)) #[]) + else if residual.size = 2 ^ remaining c i.val then some (.fold m none residual) + else none + else some (.fold m none #[]) + | _ => none + +/-- Checked inverse on arbitrary replies, including malformed tags and wrong +residual lengths. The only normalization is explicit external authentication +data and fields which the original parser ignores. -/ +theorem replyScalars_roundtrip {c : Config} (q : Coordinate c) (digest : Digest32) + (lookup : Digest32 → Oracle) (rows : Oracle) (reply : Reply) : + (replyScalars q digest reply).bind (decodeReplyScalars q lookup rows) = + canonicalReply q digest lookup rows reply := by + cases q <;> cases reply <;> + simp only [replyScalars, canonicalReply, decodeReplyScalars, Option.bind_none, + Option.bind_some, messageScalars, decodeMessage, Option.map_some] + case fold.fold i j message next residual => + cases message + have hh : c.folds[i.val]! = c.folds[i.val] := by simp + simp only [hh] at * + by_cases h : j.val + 1 = c.folds[i.val] + · by_cases hi : i.val + 1 < c.folds.size + · simp [h, hi, boundaryScalars, rootScalars, ByteCodec.scalarsToHash_hashToScalars] + · simp [h, hi, boundaryScalars] + · simp [h] + +/-- Counts are fixed by the public schedule, including rejecting messages. -/ +def replyScalarCount {c : Config} : Coordinate c → Nat + | .fold i j => 2 + if j.val + 1 = c.folds[i.val]! then + if i.val + 1 < c.folds.size then 2 else 2 ^ remaining c i.val + else 0 + | .ood _ _ => 3 + | _ => 2 + +def parseReply {c : Config} (q : Coordinate c) (lookup : Digest32 → Oracle) + (rows : Oracle) (bytes : List Byte) : Option Reply := + (parseExact (replyScalarCount q) bytes).bind (decodeReplyScalars q lookup rows) + +theorem parseReply_roundtrip {c : Config} (q : Coordinate c) (lookup : Digest32 → Oracle) + (rows : Oracle) (xs : List E) (size : xs.length = replyScalarCount q) : + parseReply q lookup rows (scalarBytes xs) = decodeReplyScalars q lookup rows xs := by + simp only [parseReply, ← size, parseExact_roundtrip, Option.bind_some] + +/-- Erase auxiliary phases without splitting a whole-vector request. -/ +def requestSizes (events : List Event) : List Nat := + events.filterMap (fun e => match e with | .squeeze n => some n | _ => none) + +theorem visibleEvents_sizes {c : Config} (digests : Nat → Digest32) (bits : Nat → Nat) + (nonces : Nat → E) (qs : List (Coordinate c)) (replies : List Reply) (events : List Event) + (ok : visibleEvents digests bits nonces qs replies = some events) : + requestSizes events = qs.map (fun q => 24 * scalarCount q) := by + induction qs generalizing replies events with + | nil => + cases replies with + | nil => cases ok; rfl + | cons r rs => cases ok + | cons q qs ih => + cases replies with + | nil => cases ok + | cons r rs => + simp only [visibleEvents] at ok + cases hx : replyScalars q (digests (coordinateLevel q)) r with + | none => simp [hx] at ok + | some xs => + cases hr : visibleEvents digests bits nonces qs rs with + | none => simp [hx, hr] at ok + | some rest => + simp [hx, hr] at ok + subst events + have hrest := ih rs rest hr + have hb := congrArg (List.cons (24 * scalarCount q)) hrest + cases q <;> simpa [requestSizes, challengeEvents, List.filterMap_append] using hb + +theorem wireEvents_sizes (c : Config) (digests : Nat → Digest32) (bits : Nat → Nat) + (nonces : Nat → E) (replies : List Reply) (events : List Event) + (ok : wireEvents c digests bits nonces replies = some events) : + requestSizes events = (schedule c).map (fun q => 24 * scalarCount q) := by + unfold wireEvents at ok + cases hv : visibleEvents digests bits nonces (visibleCoordinates c) replies with + | none => simp [hv] at ok + | some vs => + simp [hv] at ok + subst events + have hs := visibleEvents_sizes digests bits nonces _ _ _ hv + simp only [requestSizes, List.filterMap_append, List.filterMap_map] at hs ⊢ + rw [hs] + simp [schedule] + +/-- This cap follows from compiling the fixed syntax, not from acceptance. -/ +theorem wireEvents_depth (c : Config) (digests : Nat → Digest32) (bits : Nat → Nat) + (nonces : Nat → E) (replies : List Reply) (events : List Event) + (ok : wireEvents c digests bits nonces replies = some events) : + (requestSizes events).length = depth c := by + rw [wireEvents_sizes c digests bits nonces replies events ok, List.length_map] + rfl + +/-- Reverse-chronological keys select the next dependent alphabet by their +syntactic length. The fallback is unreachable for nonempty admitted requests. -/ +def queryFor (c : Config) (key : Digest32 × List Pending) : Coordinate c := + ((schedule c)[key.2.length - 1]?).getD .initial + +theorem queryFor_at (c : Config) (s : Digest32) (messages : List Pending) + (n : Fin (depth c)) (size : messages.length = n.val + 1) : + queryFor c (s,messages) = (schedule c)[n.val]'n.isLt := by + have hn : n.val < (schedule c).length := n.isLt + simp [queryFor, size, hn] + rfl + +/-- Fixed-position syntax recognizer. Scalar sizes and nonce presence are +checked before any algebra or authentication; malformed scalar values may +still reject later. PoW difficulty obeys the source's 63-bit hard limit. -/ +def scheduledAdmissible (c : Config) (messages : List Pending) : Bool := + admissible c messages && + (messages.reverse.zipIdx.all fun (m, n) => + let q := ((schedule c)[n]?).getD .initial + let previous := ((schedule c)[n-1]?).getD .initial + decide (m.scalars.length = if n = 0 then 0 else replyScalarCount previous) && + match q with + | .query _ => m.nonce.isSome && m.nonce.all (fun p => decide (p.1 ≤ 63)) + | _ => m.nonce.isNone) + +theorem scheduledAdmissible_depth (c : Config) (messages : List Pending) + (h : scheduledAdmissible c messages = true) : messages.length ≤ depth c := by + simp only [scheduledAdmissible, Bool.and_eq_true] at h + exact admitted_depth c messages h.1 + +/-- Concrete dependent-alphabet instantiation of the one-global-cache cap. +All branches use the same parser and include the invisible final request. -/ +theorem scheduled_cache_cap (c : Config) + (oracle : TypedFiatShamirGame.Oracle (A := Sample) (queryFor c)) + (K : Nat) (requests : List (Digest32 × List Pending)) + (final : Digest32 × List Pending) + (cache : TypedFiatShamirGame.Cache (Digest32 × List Pending) + (fun key => Sample (queryFor c key))) + (budget : requests.length ≤ K) + (admitted : ∀ key ∈ requests, scheduledAdmissible c key.2 = true) + (finalAdmitted : scheduledAdmissible c final.2 = true) : + (TypedFiatShamirGame.serve (queryFor c) oracle (requests ++ [final]) cache).2 ≤ depth c * (K+1) := by + classical + exact TypedFiatShamirGame.serve_cap (queryFor c) oracle (depth c) K requests final cache budget + (fun key hk => scheduledAdmissible_depth c key.2 (admitted key hk)) + (scheduledAdmissible_depth c final.2 finalAdmitted) + +/-- Definitionally `RingPCSGame.Prefix × E` at the initial coordinate: +gamma, six map scalars, then the WHIR batching lambda. There is no intervening +observation in `RingFamily::sample` or `stack_open`, so this is one allocation. -/ +abbrev StackSample {c : Config} : Coordinate c → Type + | .initial => (E × (Fin 6 → E)) × E + | q => Sample q + +def stackScalarCount {c : Config} : Coordinate c → Nat + | .initial => 8 + | q => scalarCount q + +def stackSampleScalars {c : Config} (q : Coordinate c) : StackSample q → List E := + match q with + | .initial => fun x => [x.1.1] ++ List.ofFn x.1.2 ++ [x.2] + | .fold i j => sampleScalars (.fold i j) + | .ood i j => sampleScalars (.ood i j) + | .query i => sampleScalars (.query i) + | .tail j => sampleScalars (.tail j) + +theorem stackSampleScalars_length {c : Config} (q : Coordinate c) (x : StackSample q) : + (stackSampleScalars q x).length = stackScalarCount q := by + cases q <;> simp [stackSampleScalars, stackScalarCount, sampleScalars_length] + +/-- This replacement groups the seven adjacent ring-switch draws with lambda, +without adding an allocation or a prover response between them. -/ +def stackWireEvents (c : Config) (digests : Nat → Digest32) (bits : Nat → Nat) + (nonces : Nat → E) (replies : List Reply) : Option (List Event) := do + let events ← wireEvents c digests bits nonces replies + match events with + | .squeeze _ :: rest => some (.squeeze 192 :: rest) + | _ => none + +theorem stackWireEvents_depth (c : Config) (digests : Nat → Digest32) (bits : Nat → Nat) + (nonces : Nat → E) (replies : List Reply) (events : List Event) + (ok : stackWireEvents c digests bits nonces replies = some events) : + (requestSizes events).length = depth c := by + simp only [stackWireEvents] at ok + cases hw : wireEvents c digests bits nonces replies with + | none => simp [hw] at ok + | some es => + simp only [hw] at ok + cases es with + | nil => cases ok + | cons e rest => + cases e <;> cases ok + simpa [requestSizes] using wireEvents_depth c digests bits nonces replies _ hw + +theorem coordinate_mem_schedule {c : Config} (q : Coordinate c) : q ∈ schedule c := by + obtain hv | ⟨j, rfl, last⟩ := CausalPrefix.visible_or_last q + · exact List.mem_append_left _ hv + · apply List.mem_append_right + have hp : 0 < c.logN - c.folds.toList.sum := by omega + simp only [hiddenTail, hp, dite_true, List.mem_singleton] + congr 1 + apply Fin.ext + dsimp + omega + +theorem schedule_idxOf {c : Config} (q : Coordinate c) : + (schedule c).idxOf q = position q := by + by_cases hv : q ∈ visibleCoordinates c + · exact List.idxOf_append_of_mem hv + · obtain ⟨j, rfl, last⟩ := (CausalPrefix.visible_or_last q).resolve_left hv + have hp : 0 < c.logN - c.folds.toList.sum := by omega + have hj : j = (⟨c.logN - c.folds.toList.sum - 1, by omega⟩ : + Fin (c.logN - c.folds.toList.sum)) := by apply Fin.ext; dsimp; omega + rw [schedule, List.idxOf_append_of_notMem hv] + unfold position + rw [List.idxOf_of_notMem hv] + simp only [hiddenTail, hp, dite_true, ← hj] + simp + +theorem schedule_get_position {c : Config} (q : Coordinate c) : + (schedule c)[position q]? = some q := by + rw [← schedule_idxOf] + exact List.getElem?_idxOf (coordinate_mem_schedule q) + +theorem position_lt_depth {c : Config} (q : Coordinate c) : position q < depth c := by + rw [← schedule_idxOf] + exact List.idxOf_lt_length_of_mem (coordinate_mem_schedule q) + +private theorem coordinateLevel_mem (c : Config) (i : Nat) (q : Coordinate c) + (h : q ∈ levelCoordinates c i) : coordinateLevel q = i := by + unfold levelCoordinates at h + split_ifs at h with hi + · simp only [List.mem_append, List.mem_ofFn, List.mem_singleton] at h + rcases h with (⟨j,rfl⟩ | ⟨j,rfl⟩) | rfl <;> rfl + · simp at h + +theorem levelCoordinates_nodup (c : Config) (i : Nat) : (levelCoordinates c i).Nodup := by + unfold levelCoordinates + split_ifs <;> + simp [List.nodup_append, List.nodup_ofFn, Function.Injective] + rintro a b (⟨j,rfl⟩ | rfl) <;> simp + +theorem visibleCoordinates_nodup (c : Config) : (visibleCoordinates c).Nodup := by + have hl : ((List.range c.folds.size).flatMap (levelCoordinates c)).Nodup := by + apply List.nodup_flatMap.mpr + refine ⟨fun i _ => levelCoordinates_nodup c i, ?_⟩ + apply (List.nodup_range (n := c.folds.size)).imp + intro i j hij q hi hj + exact hij ((coordinateLevel_mem c i q hi).symm.trans (coordinateLevel_mem c j q hj)) + have initial_not : Coordinate.initial ∉ (List.range c.folds.size).flatMap (levelCoordinates c) := by + simp only [List.mem_flatMap, not_exists] + intro i + unfold levelCoordinates + split_ifs <;> simp + have tail_not (j : Fin (c.logN - c.folds.toList.sum)) : + Coordinate.tail j ∉ (List.range c.folds.size).flatMap (levelCoordinates c) := by + simp only [List.mem_flatMap, not_exists] + intro i + unfold levelCoordinates + split_ifs <;> simp + unfold visibleCoordinates + apply List.Nodup.append + · simpa using List.nodup_cons.mpr ⟨initial_not, hl⟩ + · apply List.nodup_ofFn_ofInjective + intro a b he + apply Fin.ext + exact congrArg (fun k : Fin (c.logN - c.folds.toList.sum) => k.val) (Coordinate.tail.inj he) + · intro q hq ht + obtain ⟨j,rfl⟩ := List.mem_ofFn.mp ht + simp only [List.mem_append, List.mem_singleton] at hq + rcases hq with impossible | hq + · cases impossible + · exact tail_not _ hq + +theorem schedule_nodup (c : Config) : (schedule c).Nodup := by + apply List.Nodup.append (visibleCoordinates_nodup c) + · unfold hiddenTail + split_ifs <;> simp + · intro q hv hh + unfold hiddenTail at hh + split_ifs at hh with hp + · simp only [List.mem_singleton] at hh + subst q + simp only [visibleCoordinates, List.mem_append, List.mem_singleton, List.mem_flatMap, + List.mem_ofFn] at hv + rcases hv with ((impossible | ⟨i,_,hi⟩) | ⟨j,hj⟩) + · cases impossible + · unfold levelCoordinates at hi + split_ifs at hi <;> simp at hi + · have he : j.val = c.logN - c.folds.toList.sum - 1 := by + exact congrArg Fin.val (Coordinate.tail.inj hj) + have := j.isLt + omega + · simp at hh + +theorem position_schedule_get (c : Config) (i : Fin (depth c)) : + position ((schedule c)[i.val]'i.isLt) = i.val := by + rw [← schedule_idxOf] + exact (schedule_nodup c).idxOf_getElem i.val i.isLt + +/-- Removing newer requests preserves every older syntax check, including the +fixed alphabet, reply length and actual nonce-difficulty guard. -/ +theorem scheduledAdmissible_drop (c : Config) (messages : List Pending) (n : Nat) + (admitted : scheduledAdmissible c messages = true) : + scheduledAdmissible c (messages.drop n) = true := by + simp only [scheduledAdmissible, Bool.and_eq_true, List.all_eq_true, + List.forall_mem_zipIdx'] at admitted ⊢ + constructor + · have hb := admitted_depth c messages admitted.1 + simp only [admissible, decide_eq_true_eq, List.length_drop] + omega + · intro i hi + have hi' : i < messages.reverse.length := by + simp only [List.length_reverse, List.length_drop] at hi ⊢ + omega + simpa only [List.reverse_drop, List.getElem_take] using admitted.2 i hi' + +theorem scheduledAdmissible_tail (c : Config) (messages : List Pending) + (admitted : scheduledAdmissible c messages = true) : + scheduledAdmissible c messages.tail = true := by + simpa only [List.drop_one] using scheduledAdmissible_drop c messages 1 admitted + +end Whir.WHIRHistory diff --git a/verification/whir/Whir/WHIRHistoryKey.lean b/verification/whir/Whir/WHIRHistoryKey.lean new file mode 100644 index 000000000..8ec6bec5f --- /dev/null +++ b/verification/whir/Whir/WHIRHistoryKey.lean @@ -0,0 +1,412 @@ +import Whir.WHIRHistory +import Whir.DuplexEncoding + +/-! Recovery of scheduled cache prefixes from the actual #552 framed history. +Every noninitial PCS reply has at least two absorbed scalars. The initial +request has no new absorption. Nonces are separate frame constructors, not +ordinary bytes. Parsing these real delimiters recovers the whole pending +prefix; no root, compression, or semantic serialization injectivity is assumed. -/ +namespace Whir.WHIRHistoryKey +open Concrete Protocol CausalProbability FiatShamirGame WHIRHistory DuplexRefinement + + def initialPending : Pending := ⟨[], none⟩ + +inductive Normal : List Pending → Prop where + | initial : Normal [initialPending] + | cons {ps : List Pending} (prior : Normal ps) (m : Pending) + (nonempty : m.scalars ≠ []) : Normal (m :: ps) + + theorem Normal.nonempty {ps : List Pending} (h : Normal ps) : ps ≠ [] := by + cases h <;> simp + +/-- An executable syntax test, including rejecting branches. -/ +def normal? : List Pending → Bool + | [] => false + | [m] => decide (m = initialPending) + | m :: n :: ps => !m.scalars.isEmpty && normal? (n :: ps) + + theorem normal?_correct (ps : List Pending) : normal? ps = true ↔ Normal ps := by + induction ps with + | nil => simp [normal?]; intro h; cases h + | cons m ps ih => + cases ps with + | nil => + simp only [normal?, decide_eq_true_eq] + constructor + · rintro rfl; exact .initial + · intro h; cases h with + | initial => rfl + | cons prior _ _ => exact False.elim (prior.nonempty rfl) + | cons n ps => + simp only [normal?, Bool.and_eq_true, Bool.not_eq_true', List.isEmpty_eq_false_iff, ih] + constructor + · rintro ⟨hn,hp⟩; exact .cons hp m hn + · intro h; cases h with | cons hp _ hn => exact ⟨hn,hp⟩ + + def stepFrames (previous : Nat) (m : Pending) : List Frame := + [.absorb previous (scalarBytes m.scalars)] ++ + (m.nonce.toList.map (fun p => Frame.nonce 0 p.1 (ByteCodec.encodeE p.2))) + + def parseSteps : List Frame → Option (List Pending) + | [] => some [] + | .absorb _ bytes :: .nonce _ bits nonce :: rest => do + let xs ← parseExact (bytes.length / 24) bytes + let ms ← parseSteps rest + pure (⟨xs, some (bits,ByteCodec.decodeE nonce)⟩ :: ms) + | .absorb _ bytes :: rest => do + let xs ← parseExact (bytes.length / 24) bytes + let ms ← parseSteps rest + pure (⟨xs, none⟩ :: ms) + | _ => none + + def encodeSteps (steps : List (Nat × Pending)) : List Frame := + steps.flatMap (fun p => stepFrames p.1 p.2) + + theorem steps_roundtrip (steps : List (Nat × Pending)) : + parseSteps (encodeSteps steps) = some (steps.map Prod.snd) := by + induction steps with + | nil => rfl + | cons step steps ih => + rcases step with ⟨previous,⟨xs,nonce⟩⟩ + cases nonce with + | none => + cases steps with + | nil => simp [encodeSteps, stepFrames, parseSteps, scalarBytes_length, parseExact_roundtrip] + | cons next rest => + rcases next with ⟨n,⟨ys,nonce⟩⟩ + cases nonce <;> + simp [encodeSteps, stepFrames, parseSteps, scalarBytes_length, parseExact_roundtrip, + ByteCodec.decodeE_encodeE] at ih ⊢ <;> + rw [ih] <;> rfl + | some nonce => + rcases nonce with ⟨bits,value⟩ + simp [encodeSteps, stepFrames] at ih + simp [encodeSteps, stepFrames, parseSteps, scalarBytes_length, parseExact_roundtrip, + ByteCodec.decodeE_encodeE] + rw [ih] + rfl + + def annotated (width : Nat → Nat) : List Pending → List (Nat × Pending) + | [] => [] + | m :: ps => if ps = [] then [] else (width (ps.length-1),m) :: annotated width ps + + def canonicalFrames (width : Nat → Nat) (ps : List Pending) : List Frame := + encodeSteps (annotated width ps).reverse + + theorem annotated_erases (width : Nat → Nat) (ps : List Pending) : + (annotated width ps).map Prod.snd = ps.dropLast := by + induction ps with + | nil => rfl + | cons m ps ih => + cases ps with + | nil => simp [annotated] + | cons n ps => + simp only [annotated, List.cons_ne_nil, ↓reduceIte, List.map_cons, List.dropLast_cons_cons] + exact congrArg (List.cons m) ih + + theorem Normal.restore {ps : List Pending} (h : Normal ps) : + ps.dropLast ++ [initialPending] = ps := by + induction h with + | initial => rfl + | @cons ps hp m hn ih => + simpa only [List.dropLast_cons_of_ne_nil hp.nonempty, List.cons_append] using congrArg (List.cons m) ih + + theorem canonicalFrames_injective (width width' : Nat → Nat) {ps qs : List Pending} + (hp : Normal ps) (hq : Normal qs) + (he : canonicalFrames width ps = canonicalFrames width' qs) : ps = qs := by + have parsed := congrArg parseSteps he + simp only [canonicalFrames, steps_roundtrip, Option.some.injEq, + List.map_reverse, annotated_erases] at parsed + have erased : ps.dropLast = qs.dropLast := List.reverse_injective parsed + rw [← hp.restore, ← hq.restore, erased] + +/-- Generic recurrence used by both standalone WHIR and stack_open. `width n` +is the fixed whole-vector byte count at position n, including initial 192 +bytes for stack_open and the invisible final 24 bytes. -/ +def completedModel (width : Nat → Nat) (domain statement : Digest32) : List Pending → Model + | [] => ⟨⟨domain,statement,[]⟩,[],0,0⟩ + | m :: ps => modelSqueeze (pendingModel (completedModel width domain statement ps) m) (width ps.length) + + def beforeModel (width : Nat → Nat) (domain statement : Digest32) : List Pending → Model + | [] => completedModel width domain statement [] + | m :: ps => pendingModel (completedModel width domain statement ps) m + + theorem completed_normal (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (domain statement : Digest32) {ps : List Pending} (h : Normal ps) : + completedModel width domain statement ps = + ⟨⟨domain,statement,canonicalFrames width ps⟩,[],0,width (ps.length-1)⟩ := by + induction h with + | initial => + simp [completedModel, initialPending, pendingModel, modelAbsorb, scalarBytes, + modelSqueeze, closeRun, canonicalFrames, annotated, encodeSteps, Nat.ne_of_gt (positive 0)] + | @cons ps hp m hn ih => + have hb : scalarBytes m.scalars ≠ [] := fun h => hn ((scalarBytes_empty _).mp h) + have hw : width ps.length ≠ 0 := Nat.ne_of_gt (positive ps.length) + rw [completedModel, ih] + rcases m with ⟨xs,nonce⟩ + cases nonce with + | none => + simp only [pendingModel, modelAbsorb, hb, ↓reduceIte, List.nil_append, + modelSqueeze, hw, closeRun] + simp [canonicalFrames, annotated, hp.nonempty, encodeSteps, stepFrames, + Nat.ne_of_gt (positive (ps.length-1))] + | some nonce => + rcases nonce with ⟨bits,value⟩ + simp only [pendingModel, modelAbsorb, hb, ↓reduceIte, List.nil_append, + modelNonce, modelSqueeze, hw, closeRun] + simp [canonicalFrames, annotated, hp.nonempty, encodeSteps, stepFrames, + Nat.ne_of_gt (positive (ps.length-1))] + + theorem before_history (width : Nat → Nat) (positive : ∀ n, 0 < width n) + (domain statement : Digest32) {ps : List Pending} (h : Normal ps) : + (closeRun (beforeModel width domain statement ps)).history = + ⟨domain,statement,canonicalFrames width ps⟩ := by + have hc := congrArg Model.history (completed_normal width positive domain statement h) + cases ps with + | nil => exact False.elim (h.nonempty rfl) + | cons m ps => + simpa only [completedModel, beforeModel, modelSqueeze, + Nat.ne_of_gt (positive ps.length), ↓reduceIte] using hc + +/-- This is actual framed-history-to-cache-prefix injection. Counts need only +be positive; the parser reads the real absorb/nonce constructors and bytes. +There is no injectivity premise for a digest or compression function. -/ +theorem before_history_injective (width width' : Nat → Nat) + (positive : ∀ n, 0 < width n) (positive' : ∀ n, 0 < width' n) + (domain statement domain' statement' : Digest32) {ps qs : List Pending} + (hp : Normal ps) (hq : Normal qs) + (same : (closeRun (beforeModel width domain statement ps)).history = + (closeRun (beforeModel width' domain' statement' qs)).history) : + domain = domain' ∧ statement = statement' ∧ ps = qs := by + rw [before_history width positive domain statement hp, + before_history width' positive' domain' statement' hq] at same + exact ⟨congrArg FramedHistory.domain same, congrArg FramedHistory.statement same, + canonicalFrames_injective width width' hp hq (congrArg FramedHistory.frames same)⟩ + +theorem replyScalarCount_positive {c : Config} (q : Coordinate c) : 0 < replyScalarCount q := by + cases q <;> simp only [replyScalarCount] <;> omega + +private theorem normal_reverse (rest : List Pending) + (hn : ∀ m ∈ rest, m.scalars ≠ []) : Normal (rest.reverse ++ [initialPending]) := by + induction rest using List.reverseRecOn with + | nil => exact .initial + | append_singleton rest m ih => + simp only [List.reverse_append, List.reverse_cons, List.reverse_nil, List.nil_append, + List.cons_append] + exact .cons (ih (fun a ha => hn a (by simp [ha]))) m (hn m (by simp)) + +/-- The regular fixed-position recognizer already implies the delimiter syntax +needed above: every postinitial reply contributes at least two scalars. -/ +theorem scheduled_normal (c : Config) (ps : List Pending) (nonempty : ps ≠ []) + (admitted : scheduledAdmissible c ps = true) : Normal ps := by + have checks := admitted + simp only [scheduledAdmissible, Bool.and_eq_true, List.all_eq_true, + List.forall_mem_zipIdx'] at checks + have hc := checks.2 + cases hr : ps.reverse with + | nil => + have : ps = [] := by simpa only [List.reverse_eq_nil_iff] using hr + exact False.elim (nonempty this) + | cons m rest => + rw [hr] at hc + have first := hc 0 (by simp) + simp [schedule, visibleCoordinates] at first + have hm : m = initialPending := by + rcases m with ⟨xs,nonce⟩ + simp only at first + rcases first with ⟨hx,hn⟩ + have hnonce : nonce = none := by simpa using hn + subst xs + subst nonce + rfl + subst m + have hn : ∀ m ∈ rest, m.scalars ≠ [] := by + intro m hm + obtain ⟨i,hi,he⟩ := List.mem_iff_getElem.mp hm + have step := hc (i+1) (by simp; omega) + simp only [List.getElem_cons_succ, Nat.add_one_ne_zero, ↓reduceIte, + decide_eq_true_eq] at step + have hp := replyScalarCount_positive (((schedule c)[i+1-1]?).getD .initial) + intro empty + have len : m.scalars.length = 0 := by rw [empty]; rfl + have hs := step.1 + rw [he] at hs + omega + have recovered := normal_reverse rest hn + have eq : rest.reverse ++ [initialPending] = ps := by + have := congrArg List.reverse hr + simpa only [List.reverse_reverse, List.reverse_cons] using this.symm + exact eq ▸ recovered + +/-- Ancestor answers are completed through the same global dependent oracle. +They are not placed in the byte stream, and an arbitrary future table is not +part of the adversary's message syntax. -/ +def fullInput (c : Config) {A : CausalProbability.Coordinate c → Type*} + (oracle : TypedFiatShamirGame.Oracle (A := A) (queryFor c)) + (statement : Digest32) (ps : List Pending) : + TypedFiatShamirGame.FullInput Digest32 Pending (CausalProbability.Coordinate c) A := + ⟨statement, ps, TypedFiatShamirGame.complete (queryFor c) oracle statement ps.tail⟩ + +/-- Equal actual canonical mode histories yield equal completed typed inputs. +The sole width premise is arithmetic positivity; the schedule recognizer and +history parser are executable definitions with checked inverse theorems. -/ +theorem framed_fullInput_injective (c : Config) {A : CausalProbability.Coordinate c → Type*} + (oracle : TypedFiatShamirGame.Oracle (A := A) (queryFor c)) + (width width' : Nat → Nat) + (positive : ∀ n, 0 < width n) (positive' : ∀ n, 0 < width' n) + (domain statement domain' statement' : Digest32) (ps qs : List Pending) + (hp : ps ≠ []) (hq : qs ≠ []) + (ap : scheduledAdmissible c ps = true) (aq : scheduledAdmissible c qs = true) + (same : (closeRun (beforeModel width domain statement ps)).history = + (closeRun (beforeModel width' domain' statement' qs)).history) : + fullInput c oracle statement ps = fullInput c oracle statement' qs := by + obtain ⟨_,hs,hps⟩ := before_history_injective width width' positive positive' + domain statement domain' statement' (scheduled_normal c ps hp ap) + (scheduled_normal c qs hq aq) same + subst statement' + subst qs + rfl + +def standaloneWidth (c : Config) (n : Nat) : Nat := + 24 * scalarCount (((schedule c)[n]?).getD .initial) + +def stackWidth (c : Config) (n : Nat) : Nat := + 24 * stackScalarCount (((schedule c)[n]?).getD .initial) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 800000 in +theorem production_sample_counts : + ∀ p : ParameterBounds.Profile, + ∀ q : CausalProbability.Coordinate (ParameterBounds.config p), + 0 < scalarCount q ∧ 0 < stackScalarCount q := by + have residual : ∀ p : ParameterBounds.Profile, + 0 < (ParameterBounds.config p).logN - (ParameterBounds.config p).folds.toList.sum := by + decide +kernel + intro p q + cases q <;> simp only [scalarCount, stackScalarCount] <;> try omega + rename_i i j + have hr := residual p + have hs := List.sum_take_add_sum_drop (ParameterBounds.config p).folds.toList (i.val+1) + unfold CausalGame.remaining + omega + +theorem standaloneWidth_positive (p : ParameterBounds.Profile) (n : Nat) : + 0 < standaloneWidth (ParameterBounds.config p) n := + Nat.mul_pos (by decide) (production_sample_counts p _).1 + +theorem stackWidth_positive (p : ParameterBounds.Profile) (n : Nat) : + 0 < stackWidth (ParameterBounds.config p) n := + Nat.mul_pos (by decide) (production_sample_counts p _).2 + +def outputKey (width : Nat → Nat) (domain statement : Digest32) + (ps : List Pending) (block : Nat) : FiatShamirGame.Coordinate := + ⟨(closeRun (beforeModel width domain statement ps)).history, .output block⟩ + +/-- Distinct scheduled statement/prefix/block keys cannot alias a physical +framed output coordinate. Repeated prefixes therefore reuse the same key; +there is no new allocation for a clone or an overlapping output slice. -/ +theorem outputKey_injective (c : Config) (width width' : Nat → Nat) + (positive : ∀ n, 0 < width n) (positive' : ∀ n, 0 < width' n) + (domain statement domain' statement' : Digest32) (ps qs : List Pending) + (block block' : Nat) (hp : ps ≠ []) (hq : qs ≠ []) + (ap : scheduledAdmissible c ps = true) (aq : scheduledAdmissible c qs = true) + (same : outputKey width domain statement ps block = + outputKey width' domain' statement' qs block') : + domain = domain' ∧ statement = statement' ∧ ps = qs ∧ block = block' := by + have hh := congrArg FiatShamirGame.Coordinate.history same + have ht := congrArg FiatShamirGame.Coordinate.terminal same + obtain ⟨hd,hs,hps⟩ := before_history_injective width width' positive positive' + domain statement domain' statement' (scheduled_normal c ps hp ap) + (scheduled_normal c qs hq aq) hh + exact ⟨hd,hs,hps,Terminal.output.inj ht⟩ + +theorem scheduled_nonce_bits (c : Config) (ps : List Pending) + (admitted : scheduledAdmissible c ps = true) : + ∀ m ∈ ps, ∀ bits value, m.nonce = some (bits,value) → bits ≤ 63 := by + simp only [scheduledAdmissible, Bool.and_eq_true, List.all_eq_true, + List.forall_mem_zipIdx'] at admitted + intro m hm bits value hn + have hr : m ∈ ps.reverse := List.mem_reverse.mpr hm + obtain ⟨i,hi,he⟩ := List.mem_iff_getElem.mp hr + have hc := (admitted.2 i hi).2 + rw [he] at hc + cases hq : ((schedule c)[i]?).getD .initial <;> simp [hq, hn] at hc + exact hc + +theorem canonicalFrames_cons (width : Nat → Nat) (m : Pending) (ps : List Pending) + (hp : ps ≠ []) : canonicalFrames width (m :: ps) = + canonicalFrames width ps ++ stepFrames (width (ps.length-1)) m := by + simp [canonicalFrames, annotated, hp, encodeSteps] + +theorem canonicalFrames_valid (width : Nat → Nat) (bounded : ∀ n, width n < 2^49) + {ps : List Pending} (h : Normal ps) + (nonces : ∀ m ∈ ps, ∀ bits value, m.nonce = some (bits,value) → bits ≤ 63) : + ∀ f ∈ canonicalFrames width ps, DuplexEncoding.FrameValid f := by + revert nonces + induction h with + | initial => simp [canonicalFrames, annotated, encodeSteps] + | @cons ps hp m hn ih => + intro nonces f hf + rw [canonicalFrames_cons width m ps hp.nonempty] at hf + rcases List.mem_append.mp hf with hf | hf + · exact ih (fun a ha => nonces a (by simp [ha])) f hf + · simp only [stepFrames, List.mem_append, List.mem_singleton, List.mem_map] at hf + rcases hf with rfl | ⟨p,hp,rfl⟩ + · exact ⟨bounded _, fun he => hn ((scalarBytes_empty _).mp he)⟩ + · rcases p with ⟨bits,value⟩ + have he : m.nonce = some (bits,value) := by simpa using hp + exact ⟨by decide, nonces m (by simp) bits value he⟩ + +theorem outputKey_admissible (c : Config) (width : Nat → Nat) + (positive : ∀ n, 0 < width n) (bounded : ∀ n, width n < 2^49) + (domain statement : Digest32) (ps : List Pending) (block : Nat) + (nonempty : ps ≠ []) (admitted : scheduledAdmissible c ps = true) + (blockBound : block < (width (ps.length-1) + 31) / 32) : + DuplexEncoding.Admissible (outputKey width domain statement ps block) := by + have hn := scheduled_normal c ps nonempty admitted + have hf := canonicalFrames_valid width bounded hn (scheduled_nonce_bits c ps admitted) + constructor + · simpa only [outputKey, before_history width positive domain statement hn] using hf + · change block < 2^44 + have hw := bounded (ps.length-1) + omega + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 800000 in +theorem production_sample_upper : + ∀ p : ParameterBounds.Profile, + ∀ q : CausalProbability.Coordinate (ParameterBounds.config p), + scalarCount q < 2^40 ∧ stackScalarCount q < 2^40 := by + decide +kernel + +theorem standaloneWidth_bounded (p : ParameterBounds.Profile) (n : Nat) : + standaloneWidth (ParameterBounds.config p) n < 2^49 := by + have h := (production_sample_upper p (((schedule (ParameterBounds.config p))[n]?).getD .initial)).1 + unfold standaloneWidth + omega + +theorem stackWidth_bounded (p : ParameterBounds.Profile) (n : Nat) : + stackWidth (ParameterBounds.config p) n < 2^49 := by + have h := (production_sample_upper p (((schedule (ParameterBounds.config p))[n]?).getD .initial)).2 + unfold stackWidth + omega + +theorem production_outputKey_admissible (p : ParameterBounds.Profile) + (domain statement : Digest32) (ps : List Pending) (block : Nat) + (nonempty : ps ≠ []) (admitted : scheduledAdmissible (ParameterBounds.config p) ps = true) + (blockBound : block < (standaloneWidth (ParameterBounds.config p) (ps.length-1) + 31) / 32) : + DuplexEncoding.Admissible + (outputKey (standaloneWidth (ParameterBounds.config p)) domain statement ps block) := + outputKey_admissible (ParameterBounds.config p) _ (standaloneWidth_positive p) + (standaloneWidth_bounded p) domain statement ps block nonempty admitted blockBound + +theorem production_stackOutputKey_admissible (p : ParameterBounds.Profile) + (domain statement : Digest32) (ps : List Pending) (block : Nat) + (nonempty : ps ≠ []) (admitted : scheduledAdmissible (ParameterBounds.config p) ps = true) + (blockBound : block < (stackWidth (ParameterBounds.config p) (ps.length-1) + 31) / 32) : + DuplexEncoding.Admissible + (outputKey (stackWidth (ParameterBounds.config p)) domain statement ps block) := + outputKey_admissible (ParameterBounds.config p) _ (stackWidth_positive p) + (stackWidth_bounded p) domain statement ps block nonempty admitted blockBound + +end Whir.WHIRHistoryKey diff --git a/verification/whir/Whir/WHIRModeFinal.lean b/verification/whir/Whir/WHIRModeFinal.lean new file mode 100644 index 000000000..13ba37dd4 --- /dev/null +++ b/verification/whir/Whir/WHIRModeFinal.lean @@ -0,0 +1,352 @@ +import Whir.WHIRModeProgram +import Whir.RawOracleProvenance + +/-! Metered physical final verification completion. The final selection is made +from the preceding program result. Prior caller outputs, followed by oldest-first +ancestor packets and the final packet, are actually queried before returning +their data to a view observer. No observer receives an oracle or performs +unmetered caller recovery or packet completion. -/ +namespace Whir.WHIRModeFinal +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling.Concrete (GroupAnswer terminalCompletion) + +variable {R S : Type} + +structure Completed (ctx : Context) (Q : Nat) (R : Type) where + result : R + packet : Option (Packet ctx Q) + history : List (Sigma (GroupAnswer ctx Q)) + +def bind : Program R → (R → Program S) → Program S + | .done r, next => next r + | .ask q next, after => .ask q (fun answer => bind (next answer) after) + +theorem counts_mono {p : Program R} {a b : Nat} (h : Counts a p) (hab : a ≤ b) : Counts b p := by + induction p generalizing a b with + | done => trivial + | ask q next ih => + exact ⟨h.1.trans hab, fun answer => ih answer (h.2 answer) (Nat.sub_le_sub_right hab _)⟩ + +theorem bind_counted (p : Program R) (next : R → Program S) (a b : Nat) + (before : Counts a p) (after : ∀ r, Counts b (next r)) : Counts (a+b) (bind p next) := by + induction p generalizing a with + | done r => exact counts_mono (after r) (by omega) + | ask q cont ih => + refine ⟨by have := before.1; omega, fun answer => ?_⟩ + have h := ih answer (a-q.cost) (before.2 answer) + have he : a+b-q.cost = (a-q.cost)+b := by have := before.1; omega + simpa only [he] using h + +/-- An appended program's certificate already certifies its whole prefix. -/ +theorem bind_prefix_counted (p : Program R) (next : R → Program S) (budget : Nat) + (counted : Counts budget (bind p next)) : Counts budget p := by + induction p generalizing budget with + | done => trivial + | ask q cont ih => exact ⟨counted.1, fun answer => ih answer _ (counted.2 answer)⟩ + +def request (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (i : Fin (RawWHIRKeys.blocks ctx p.val)) : Query := + .construction (RawWHIRKeys.coordinate ctx p.val i.val) + (RawWHIRKeys.coordinate_admissible ctx Q ⟨p,i⟩) + +def realPacket (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) (p : Packet ctx Q) : + GroupAnswer ctx Q (.inl p) := fun i => + evalCoordinate (compressionOf oracle) ctx.iv (RawWHIRKeys.coordinate ctx p.val i.val) + +def idealPacket (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) (p : Packet ctx Q) : + GroupAnswer ctx Q (.inl p) := fun i => ro (RawWHIRKeys.encode ctx Q ⟨p,i⟩) + +def packetCost (ctx : Context) (Q : Nat) (p : Packet ctx Q) : Nat := + ∑ i : Fin (RawWHIRKeys.blocks ctx p.val), pathCost (RawWHIRKeys.coordinate ctx p.val i.val) + +def packetsCost (ctx : Context) (Q : Nat) (ps : List (Packet ctx Q)) : Nat := + (ps.map (packetCost ctx Q)).sum + +abbrev CallerPosition (ctx : Context) (Q : Nat) (p : Packet ctx Q) := + {q : Coordinate // q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx p.val)} + +def callerPositions (ctx : Context) (Q : Nat) (p : Packet ctx Q) : List (CallerPosition ctx Q p) := + (WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx p.val)).attach + +def callerCost {ctx : Context} {Q : Nat} {p : Packet ctx Q} (qs : List (CallerPosition ctx Q p)) : Nat := + (qs.map (fun q => pathCost q.val)).sum + +def completionCost (ctx : Context) (Q : Nat) : Option (Packet ctx Q) → Nat + | none => 0 + | some p => callerCost (callerPositions ctx Q p) + packetsCost ctx Q (terminalCompletion ctx Q (some p)) + +def readPackets (ctx : Context) (Q : Nat) : List (Packet ctx Q) → + (List (Sigma (GroupAnswer ctx Q)) → Program R) → Program R + | [], next => next [] + | p :: ps, next => + WHIRModeProgram.readPacket (RawWHIRKeys.blocks ctx p.val) (request ctx Q p) + (fun raw => readPackets ctx Q ps (fun rest => next (⟨.inl p,raw⟩ :: rest))) + +/-- Caller singleton reads and packet reads form one continuation chain. +History cells are built once, without copying an intermediate caller list. -/ +def readCallerThenPackets (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + List (CallerPosition ctx Q p) → List (Packet ctx Q) → + (List (Sigma (GroupAnswer ctx Q)) → Program R) → Program R + | [], ps, next => readPackets ctx Q ps next + | q :: qs, ps, next => + .ask (.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q p q.val q.property)) + (fun answer => readCallerThenPackets ctx Q p qs ps (fun rest => + next (⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property),answer⟩ :: rest))) + +def finish (ctx : Context) (Q : Nat) (r : R) : + Option (Packet ctx Q) → Program (Completed ctx Q R) + | none => .done ⟨r,none,[]⟩ + | some p => readCallerThenPackets ctx Q p (callerPositions ctx Q p) + (terminalCompletion ctx Q (some p)) (fun history => .done ⟨r,some p,history⟩) + +def append (ctx : Context) (Q : Nat) (p : Program R) (final : R → Option (Packet ctx Q)) : + Program (Completed ctx Q R) := bind p (fun r => finish ctx Q r (final r)) + +def realHistory (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) (ps : List (Packet ctx Q)) : + List (Sigma (GroupAnswer ctx Q)) := ps.map (fun p => ⟨.inl p,realPacket ctx Q oracle p⟩) + +def idealHistory (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) (ps : List (Packet ctx Q)) : + List (Sigma (GroupAnswer ctx Q)) := ps.map (fun p => ⟨.inl p,idealPacket ctx Q ro p⟩) + +def realCallers (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) (p : Packet ctx Q) + (qs : List (CallerPosition ctx Q p)) : List (Sigma (GroupAnswer ctx Q)) := + qs.map (fun q => ⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property), + evalCoordinate (compressionOf oracle) ctx.iv q.val⟩) + +def idealCallers (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) (p : Packet ctx Q) + (qs : List (CallerPosition ctx Q p)) : List (Sigma (GroupAnswer ctx Q)) := + qs.map (fun q => ⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property), + ro (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property).val⟩) + +/-- Exact cache annotation order for the coordinate-backed caller requests. -/ +theorem idealCallers_groups (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) (p : Packet ctx Q) : + idealCallers ctx Q ro p (callerPositions ctx Q p) = + (RawWHIRKeys.callerGroups ctx Q p).map (fun key => ⟨.inr key,ro key.val⟩) := by + simp only [idealCallers, callerPositions, RawWHIRKeys.callerGroups, List.map_map, Function.comp_def] + +def realCompletion (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) : + Option (Packet ctx Q) → List (Sigma (GroupAnswer ctx Q)) + | none => [] + | some p => realCallers ctx Q oracle p (callerPositions ctx Q p) ++ + realHistory ctx Q oracle (terminalCompletion ctx Q (some p)) + +def idealCompletion (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) : + Option (Packet ctx Q) → List (Sigma (GroupAnswer ctx Q)) + | none => [] + | some p => idealCallers ctx Q ro p (callerPositions ctx Q p) ++ + idealHistory ctx Q ro (terminalCompletion ctx Q (some p)) + +theorem idealCompletion_some (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) (p : Packet ctx Q) : + idealCompletion ctx Q ro (some p) = + (RawWHIRKeys.callerGroups ctx Q p).map (fun key => ⟨.inr key,ro key.val⟩) ++ + idealHistory ctx Q ro (RawWHIRKeys.ancestors ctx Q p ++ [p]) := by + rw [idealCompletion, idealCallers_groups] + rfl + +theorem bind_real_result (oracle : PrimitiveOracle) (iv : Digest32) (p : Program R) + (next : R → Program S) : + (runReal oracle iv (bind p next)).view.result = + (runReal oracle iv (next (runReal oracle iv p).view.result)).view.result := by + induction p with + | done r => rfl + | ask q cont ih => simpa only [bind, runReal, prepend] using ih (realAnswer oracle iv q) + +theorem readPackets_real_result (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (ps : List (Packet ctx Q)) (next : List (Sigma (GroupAnswer ctx Q)) → Program R) : + (runReal oracle ctx.iv (readPackets ctx Q ps next)).view.result = + (runReal oracle ctx.iv (next (realHistory ctx Q oracle ps))).view.result := by + induction ps generalizing next with + | nil => rfl + | cons p ps ih => + simp only [readPackets, WHIRModeProgram.readPacket_result, ih] + rfl + +theorem readCallerThenPackets_real_result (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (p : Packet ctx Q) (qs : List (CallerPosition ctx Q p)) (ps : List (Packet ctx Q)) + (next : List (Sigma (GroupAnswer ctx Q)) → Program R) : + (runReal oracle ctx.iv (readCallerThenPackets ctx Q p qs ps next)).view.result = + (runReal oracle ctx.iv + (next (realCallers ctx Q oracle p qs ++ realHistory ctx Q oracle ps))).view.result := by + induction qs generalizing next with + | nil => exact readPackets_real_result ctx Q oracle ps next + | cons q qs ih => + simp only [readCallerThenPackets, runReal, prepend, ih] + rfl + +theorem finish_real_result (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (r : R) (p : Option (Packet ctx Q)) : + (runReal oracle ctx.iv (finish ctx Q r p)).view.result = + ⟨r,p,realCompletion ctx Q oracle p⟩ := by + cases p with + | none => rfl + | some p => + rw [finish, readCallerThenPackets_real_result] + rfl + +theorem append_real_result (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (p : Program R) (final : R → Option (Packet ctx Q)) : + (runReal oracle ctx.iv (append ctx Q p final)).view.result = + let r := (runReal oracle ctx.iv p).view.result + (⟨r,final r,realCompletion ctx Q oracle (final r)⟩ : Completed ctx Q R) := by + rw [append, bind_real_result, finish_real_result] + +/-- A construction-only packet does not change the private primitive simulator +state. Its replies are the actual mode raw keys, independent of proof budgets. -/ +theorem readPacket_ideal_result {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (n : Nat) + (coords : Fin n → Coordinate) (valid : ∀ i, DuplexEncoding.Admissible (coords i)) + (bound : ∀ i, pathCost (coords i) ≤ Q) (next : (Fin n → Digest32) → Program R) + (value : (Fin n → Digest32) → R) + (after : ∀ raw remaining (cap : remaining ≤ Q) (counted : Counts remaining (next raw)), + (runIdeal sim ro iv state (next raw) remaining cap counted).view.result = value raw) + (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (WHIRModeProgram.readPacket n (fun i => .construction (coords i) (valid i)) next)) : + (runIdeal sim ro iv state (WHIRModeProgram.readPacket n (fun i => .construction (coords i) (valid i)) next) + remaining cap counted).view.result = + value (fun i => ro (constructionKey Q iv (coords i) (bound i))) := by + induction n generalizing remaining with + | zero => + have h := after Fin.elim0 remaining cap counted + have he : (fun i : Fin 0 => ro (constructionKey Q iv (coords i) (bound i))) = Fin.elim0 := by + funext i; exact Fin.elim0 i + simpa only [WHIRModeProgram.readPacket, he] using h + | succ n ih => + let answer := ro (constructionKey Q iv (coords 0) (bound 0)) + have h := ih (fun i => coords i.succ) (fun i => valid i.succ) (fun i => bound i.succ) + (fun rest => next (Fin.cases answer rest)) (fun rest => value (Fin.cases answer rest)) + (fun rest rem hc hn => after (Fin.cases answer rest) rem hc hn) + (remaining-pathCost (coords 0)) (by omega) (counted.2 answer) + have he : Fin.cases answer (fun i => ro (constructionKey Q iv (coords i.succ) (bound i.succ))) = + (fun i => ro (constructionKey Q iv (coords i) (bound i))) := by + funext i + refine Fin.cases ?_ (fun j => ?_) i <;> rfl + simpa only [WHIRModeProgram.readPacket, runIdeal, prepend, he] using h + +theorem readPackets_ideal_result (ctx : Context) (Q : Nat) {Seed State : Type} + (sim : Simulator Q Seed State) (ro : RawKey Q → Digest32) (state : State) + (ps : List (Packet ctx Q)) (next : List (Sigma (GroupAnswer ctx Q)) → Program R) + (value : List (Sigma (GroupAnswer ctx Q)) → R) + (after : ∀ history remaining (cap : remaining ≤ Q) (counted : Counts remaining (next history)), + (runIdeal sim ro ctx.iv state (next history) remaining cap counted).view.result = value history) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining (readPackets ctx Q ps next)) : + (runIdeal sim ro ctx.iv state (readPackets ctx Q ps next) remaining cap counted).view.result = + value (idealHistory ctx Q ro ps) := by + induction ps generalizing next value remaining with + | nil => exact after [] remaining cap counted + | cons p ps ih => + exact readPacket_ideal_result sim ro ctx.iv state (RawWHIRKeys.blocks ctx p.val) + (fun i => RawWHIRKeys.coordinate ctx p.val i.val) + (fun i => RawWHIRKeys.coordinate_admissible ctx Q ⟨p,i⟩) + (fun i => by rw [RawWHIRKeys.pathCost_block]; exact RawWHIRKeys.packet_pathBound ctx Q p) + (fun raw => readPackets ctx Q ps (fun rest => next (⟨.inl p,raw⟩ :: rest))) + (fun raw => value (⟨.inl p,raw⟩ :: idealHistory ctx Q ro ps)) + (fun raw rem hc hn => ih _ _ (fun rest => after (⟨.inl p,raw⟩ :: rest)) rem hc hn) + remaining cap counted + +theorem readCallerThenPackets_ideal_result (ctx : Context) (Q : Nat) {Seed State : Type} + (sim : Simulator Q Seed State) (ro : RawKey Q → Digest32) (state : State) + (p : Packet ctx Q) (qs : List (CallerPosition ctx Q p)) (ps : List (Packet ctx Q)) + (next : List (Sigma (GroupAnswer ctx Q)) → Program R) + (value : List (Sigma (GroupAnswer ctx Q)) → R) + (after : ∀ history remaining (cap : remaining ≤ Q) (counted : Counts remaining (next history)), + (runIdeal sim ro ctx.iv state (next history) remaining cap counted).view.result = value history) + (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (readCallerThenPackets ctx Q p qs ps next)) : + (runIdeal sim ro ctx.iv state (readCallerThenPackets ctx Q p qs ps next) + remaining cap counted).view.result = + value (idealCallers ctx Q ro p qs ++ idealHistory ctx Q ro ps) := by + induction qs generalizing next value remaining with + | nil => exact readPackets_ideal_result ctx Q sim ro state ps next value after remaining cap counted + | cons q qs ih => + let key := RawWHIRKeys.callerOutputKey ctx Q p q.val q.property + let answer := ro key.val + exact ih (fun rest => next (⟨.inr key,answer⟩ :: rest)) + (fun rest => value (⟨.inr key,answer⟩ :: rest)) + (fun rest => after (⟨.inr key,answer⟩ :: rest)) + (remaining-pathCost q.val) (by omega) (counted.2 answer) + +theorem finish_ideal_result (ctx : Context) (Q : Nat) {Seed State : Type} + (sim : Simulator Q Seed State) (ro : RawKey Q → Digest32) (state : State) + (r : R) (p : Option (Packet ctx Q)) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (finish ctx Q r p)) : + (runIdeal sim ro ctx.iv state (finish ctx Q r p) remaining cap counted).view.result = + ⟨r,p,idealCompletion ctx Q ro p⟩ := by + cases p with + | none => rfl + | some p => + apply readCallerThenPackets_ideal_result ctx Q sim ro state p _ _ + _ (fun history => ⟨r,some p,history⟩) + (fun _ _ _ _ => rfl) remaining cap counted + +theorem append_ideal_result (ctx : Context) (Q : Nat) {Seed State : Type} + (sim : Simulator Q Seed State) (ro : RawKey Q → Digest32) (state : State) + (p : Program R) (final : R → Option (Packet ctx Q)) (remaining : Nat) (cap : remaining ≤ Q) + (before : Counts remaining p) (counted : Counts remaining (append ctx Q p final)) : + (runIdeal sim ro ctx.iv state (append ctx Q p final) remaining cap counted).view.result = + let r := (runIdeal sim ro ctx.iv state p remaining cap before).view.result + (⟨r,final r,idealCompletion ctx Q ro (final r)⟩ : Completed ctx Q R) := by + induction p generalizing state remaining with + | done r => exact finish_ideal_result ctx Q sim ro state r (final r) remaining cap counted + | ask q next ih => + cases q with + | primitive purpose input => + exact ih (runRO ro (sim.answer state input)).1.2 (runRO ro (sim.answer state input)).1.1 + (remaining-1) (by omega) (before.2 _) (counted.2 _) + | construction q valid => + exact ih (ro (constructionKey Q ctx.iv q (before.1.trans cap))) state + (remaining-pathCost q) (by omega) (before.2 _) (counted.2 _) + +theorem readPackets_counted (ctx : Context) (Q : Nat) (ps : List (Packet ctx Q)) + (next : List (Sigma (GroupAnswer ctx Q)) → Program R) (budget : Nat) + (after : ∀ history, Counts budget (next history)) : + Counts (packetsCost ctx Q ps + budget) (readPackets ctx Q ps next) := by + induction ps generalizing next with + | nil => simpa only [packetsCost, List.map_nil, List.sum_nil, Nat.zero_add, readPackets] using after [] + | cons p ps ih => + have h := WHIRModeProgram.readPacket_counted (RawWHIRKeys.blocks ctx p.val) (request ctx Q p) + (fun raw => readPackets ctx Q ps (fun rest => next (⟨.inl p,raw⟩ :: rest))) + (packetsCost ctx Q ps + budget) (fun raw => ih _ (fun rest => after (⟨.inl p,raw⟩ :: rest))) + simpa only [packetsCost, List.map_cons, List.sum_cons, packetCost, request, Query.cost, Nat.add_assoc, + readPackets] using h + +theorem readCallerThenPackets_counted (ctx : Context) (Q : Nat) + (p : Packet ctx Q) (qs : List (CallerPosition ctx Q p)) (ps : List (Packet ctx Q)) + (next : List (Sigma (GroupAnswer ctx Q)) → Program R) (budget : Nat) + (after : ∀ history, Counts budget (next history)) : + Counts (callerCost qs + packetsCost ctx Q ps + budget) + (readCallerThenPackets ctx Q p qs ps next) := by + induction qs generalizing next with + | nil => + simpa only [callerCost, List.map_nil, List.sum_nil, Nat.zero_add, readCallerThenPackets] + using readPackets_counted ctx Q ps next budget after + | cons q qs ih => + simp only [readCallerThenPackets, Counts, callerCost, List.map_cons, List.sum_cons, Query.cost] + refine ⟨by omega, fun answer => ?_⟩ + have h := ih (fun rest => next + (⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property),answer⟩ :: rest)) + (fun rest => after (⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property),answer⟩ :: rest)) + convert h using 1 + dsimp only [callerCost] + omega + +theorem finish_counted (ctx : Context) (Q : Nat) (r : R) (p : Option (Packet ctx Q)) : + Counts (completionCost ctx Q p) (finish ctx Q r p) := by + cases p with + | none => trivial + | some p => + simpa only [Nat.add_zero, completionCost, finish] using + readCallerThenPackets_counted ctx Q p (callerPositions ctx Q p) (terminalCompletion ctx Q (some p)) + (fun history => Program.done (⟨r,some p,history⟩ : Completed ctx Q R)) 0 (fun _ => True.intro) + +/-- Every caller output and final packet block pays its entire uncached path. +Neither cached caller replies nor already-seen packets receive a silent discount. -/ +theorem append_counted (ctx : Context) (Q : Nat) (p : Program R) + (final : R → Option (Packet ctx Q)) (a b : Nat) (before : Counts a p) + (after : ∀ r, completionCost ctx Q (final r) ≤ b) : Counts (a+b) (append ctx Q p final) := + bind_counted p _ a b before (fun r => counts_mono (finish_counted ctx Q r (final r)) (after r)) + +@[simp] theorem finish_none (ctx : Context) (Q : Nat) (r : R) : + finish ctx Q r none = .done ⟨r,none,[]⟩ := rfl + +end Whir.WHIRModeFinal diff --git a/verification/whir/Whir/WHIRModeProgram.lean b/verification/whir/Whir/WHIRModeProgram.lean new file mode 100644 index 000000000..4cc1bdda7 --- /dev/null +++ b/verification/whir/Whir/WHIRModeProgram.lean @@ -0,0 +1,150 @@ +import Whir.WHIRROM +import Whir.DuplexModeGame + +/-! Executable construction-query realization of the typed compiler. This is +only the checked construction linker; direct primitive/simulator interactions +remain in DuplexModeGame's shared public-oracle experiment. -/ +namespace Whir.WHIRModeProgram +open Concrete Protocol CausalProbability ParameterBounds FiatShamirGame WHIRROM +open DuplexModeGame + +variable {R : Type} + +def readPacket (n : Nat) (request : Fin n → Query) + (next : (Fin n → Digest32) → Program R) : Program R := + match n with + | 0 => next Fin.elim0 + | n+1 => .ask (request 0) (fun first => + readPacket n (fun i => request i.succ) (fun rest => next (Fin.cases first rest))) + +theorem readPacket_result (oracle : PrimitiveOracle) (iv : Digest32) (n : Nat) + (request : Fin n → Query) (next : (Fin n → Digest32) → Program R) : + (runReal oracle iv (readPacket n request next)).view.result = + (runReal oracle iv (next (fun i => realAnswer oracle iv (request i)))).view.result := by + induction n with + | zero => + unfold readPacket + congr 3 + apply congrArg next + funext i + exact Fin.elim0 i + | succ n ih => + simp only [readPacket, runReal, prepend] + rw [ih] + congr 3 + apply congrArg next + funext i + refine Fin.cases ?_ (fun j => ?_) i <;> rfl + +def coordinate (p : Profile) (domain : Digest32) (key : WHIRROM.Key p) (block : Nat) : + FiatShamirGame.Coordinate := + WHIRHistoryKey.outputKey (WHIRHistoryKey.standaloneWidth (config p)) + domain key.statement key.messages block + +def AdmissibleTree {p : Profile} (domain : Digest32) {n : Nat} : + TypedOracleCompiler.Sampling (WHIRROM.Key p) + WHIRROM.Packet R n → Prop + | .ret _ => True + | .draw key next => WHIRHistoryKey.Normal key.messages ∧ + (∀ i : Fin (outputBlocks (WHIRROM.query p (key.statement,key.messages))), + DuplexEncoding.Admissible (coordinate p domain key i.val)) ∧ + ∀ a, AdmissibleTree domain (next a) + +def ScheduledTree {p : Profile} {n : Nat} : + TypedOracleCompiler.Sampling (WHIRROM.Key p) + WHIRROM.Packet R n → Prop + | .ret _ => True + | .draw key next => key.messages ≠ [] ∧ + WHIRHistory.scheduledAdmissible (config p) key.messages = true ∧ + ∀ a, ScheduledTree (next a) + +theorem scheduled_admissible {p : Profile} (domain : Digest32) {n : Nat} + (tree : TypedOracleCompiler.Sampling (WHIRROM.Key p) + WHIRROM.Packet R n) + (scheduled : ScheduledTree tree) : AdmissibleTree domain tree := by + induction tree with + | ret r => trivial + | draw key next ih => + refine ⟨WHIRHistoryKey.scheduled_normal _ _ scheduled.1 scheduled.2.1, ?_, + fun a => ih a (scheduled.2.2 a)⟩ + intro i + apply WHIRHistoryKey.production_outputKey_admissible p domain key.statement key.messages + i.val scheduled.1 scheduled.2.1 + simpa only [WHIRHistoryKey.standaloneWidth, outputBlocks, WHIRROM.query, + WHIRHistory.queryFor, List.getD, Nat.mul_comm] using i.isLt + +def program {p : Profile} (domain : Digest32) {n : Nat} + (tree : TypedOracleCompiler.Sampling (WHIRROM.Key p) + WHIRROM.Packet R n) + (valid : AdmissibleTree domain tree) : Program R := + match tree with + | .ret r => .done r + | .draw key next => + readPacket (outputBlocks (WHIRROM.query p (key.statement,key.messages))) + (fun i => .construction (coordinate p domain key i.val) (valid.2.1 i)) + (fun raw => program domain (next raw) (valid.2.2 raw)) + +/-- Concrete evaluation equality, with no distribution, correctness, or PCS +acceptance assumption. The side condition is solely checked frame syntax. -/ +theorem program_real_result {p : Profile} (domain : Digest32) (oracle : PrimitiveOracle) + (iv : Digest32) {n : Nat} + (tree : TypedOracleCompiler.Sampling (WHIRROM.Key p) + WHIRROM.Packet R n) + (valid : AdmissibleTree domain tree) : + (runReal oracle iv (program domain tree valid)).view.result = + TypedOracleCompiler.Sampling.eval (physicalPacket p (compressionOf oracle) iv domain) tree := by + induction tree with + | ret r => rfl + | draw key next ih => + simp only [program] + rw [readPacket_result] + rw [ih] + simp only [TypedOracleCompiler.Sampling.eval] + rfl + +theorem readPacket_counted (n : Nat) (request : Fin n → Query) + (next : (Fin n → Digest32) → Program R) (budget : Nat) + (after : ∀ raw, Counts budget (next raw)) : + Counts ((∑ i, (request i).cost) + budget) (readPacket n request next) := by + induction n generalizing budget with + | zero => simpa only [readPacket, Fin.sum_univ_zero, Nat.zero_add] using after Fin.elim0 + | succ n ih => + simp only [readPacket, Counts, Fin.sum_univ_succ] + constructor + · omega + · intro first + convert ih (fun i => request i.succ) (fun rest => next (Fin.cases first rest)) + budget (fun rest => after (Fin.cases first rest)) using 1 + omega + +/-- Every output block pays its complete uncached primitive path. -/ +def packetCost (p : Profile) (domain : Digest32) (key : WHIRROM.Key p) : Nat := + ∑ i : Fin (outputBlocks (WHIRROM.query p (key.statement,key.messages))), + DuplexFraming.pathCost (coordinate p domain key i.val) + +def CostBound {p : Profile} (domain : Digest32) {n : Nat} (Q : Nat) : + TypedOracleCompiler.Sampling (WHIRROM.Key p) + WHIRROM.Packet R n → Prop + | .ret _ => True + | .draw key next => packetCost p domain key ≤ Q ∧ + ∀ a, CostBound domain (Q-packetCost p domain key) (next a) + +theorem program_counted {p : Profile} (domain : Digest32) {n Q : Nat} + (tree : TypedOracleCompiler.Sampling (WHIRROM.Key p) + WHIRROM.Packet R n) + (valid : AdmissibleTree domain tree) (counted : CostBound domain Q tree) : + Counts Q (program domain tree valid) := by + induction tree generalizing Q with + | ret r => trivial + | draw key next ih => + have h := readPacket_counted + (outputBlocks (WHIRROM.query p (key.statement,key.messages))) + (fun i => Query.construction (coordinate p domain key i.val) (valid.2.1 i)) + (fun raw => program domain (next raw) (valid.2.2 raw)) + (Q-packetCost p domain key) + (fun raw => ih _ (valid.2.2 _) (counted.2 _)) + change Counts (packetCost p domain key + (Q-packetCost p domain key)) + (program domain (.draw key next) valid) at h + simpa only [Nat.add_sub_of_le counted.1] using h + +end Whir.WHIRModeProgram diff --git a/verification/whir/Whir/WHIRModeReplay.lean b/verification/whir/Whir/WHIRModeReplay.lean new file mode 100644 index 000000000..79b45dfdd --- /dev/null +++ b/verification/whir/Whir/WHIRModeReplay.lean @@ -0,0 +1,143 @@ +import Whir.WHIRCausalRawROM +import Whir.WHIRModeFinal + +namespace Whir.WHIRModeReplay +open FiatShamirGame (Digest32) +open RawOracleCoupling RawOracleCoupling.Concrete WHIRRawReplay +open Classical +set_option maxHeartbeats 800000 + +/-- Only bytes actually returned by the metered final program are decoded. -/ +def history (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (physical : List (Sigma (GroupAnswer ctx Q))) := + (decodeHistory ctx stack Q physical).filterMap (restrictEntry packet.val.profile) + +theorem decode_completion (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (table : DuplexModeGame.RawKey Q → Digest32) (packet : RawWHIRKeys.Packet ctx Q) : + decodeHistory ctx stack Q (WHIRModeFinal.idealCompletion ctx Q table (some packet)) = + packetEntry ctx stack Q packet (WHIRModeFinal.idealPacket ctx Q table packet) :: + decodeHistory ctx stack Q (WHIRModeFinal.idealHistory ctx Q table + (RawWHIRKeys.ancestors ctx Q packet)) := by + rw [WHIRModeFinal.idealCompletion_some] + have callers : ((RawWHIRKeys.callerGroups ctx Q packet).map + (fun key => (⟨.inr key,table key.val⟩ : Sigma (GroupAnswer ctx Q)))).filterMap + (decodeEntry ctx stack Q) = [] := by + apply List.filterMap_eq_nil_iff.mpr + intro value member + obtain ⟨key,_,equal⟩ := List.mem_map.mp member + subst value + rfl + simp only [decodeHistory,List.filterMap_append] + have dropped := congrArg (fun values : List GlobalEntry => + (values ++ (WHIRModeFinal.idealHistory ctx Q table + (RawWHIRKeys.ancestors ctx Q packet ++ [packet])).filterMap (decodeEntry ctx stack Q)).reverse) callers + apply dropped.trans + simp only [WHIRModeFinal.idealHistory,List.map_append,List.map_cons,List.map_nil, + List.filterMap_append,List.filterMap_cons,decodeEntry, + List.filterMap_nil,List.reverse_append,List.reverse_cons,List.reverse_nil, + List.nil_append,List.singleton_append] + +private theorem cached_packets (ctx : RawWHIRKeys.Context) (Q : Nat) + (table : DuplexModeGame.RawKey Q → Digest32) + (cache : TypedFiatShamirGame.Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (packets : List (RawWHIRKeys.Packet ctx Q)) + (hits : ∀ packet ∈ packets, cache (.inl packet) = + some (WHIRModeFinal.idealPacket ctx Q table packet)) : + packets.filterMap (fun packet => (cache (.inl packet)).map + (fun raw => (⟨.inl packet,raw⟩ : Sigma (GroupAnswer ctx Q)))) = + WHIRModeFinal.idealHistory ctx Q table packets := by + induction packets with + | nil => rfl + | cons packet rest ih => + have head := hits packet (by simp) + have tail := ih (fun p h => hits p (List.mem_cons_of_mem packet h)) + simp only [List.filterMap_cons,head,Option.map_some,tail, + WHIRModeFinal.idealHistory,List.map_cons] + +theorem completed_history (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + {R : Type} {K : Nat} (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) + (table : DuplexModeGame.RawKey Q → Digest32) (packet : RawWHIRKeys.Packet ctx Q) + (selected : select (tableExecution ctx Q select program table).1 = some packet) + (raw : GroupAnswer ctx Q (.inl packet)) + (hit : (tableExecution ctx Q select program table).2 (.inl packet) = some raw) : + history ctx stack Q packet (WHIRModeFinal.idealCompletion ctx Q table (some packet)) = + WHIRRawROM.completedHistory ctx stack Q (tableExecution ctx Q select program table).2 packet raw := by + have cached := tableExecution_cached ctx Q select program table + rw [selected] at cached + have packetHits : ∀ p ∈ RawWHIRKeys.ancestors ctx Q packet, + (tableExecution ctx Q select program table).2 (.inl p) = + some (WHIRModeFinal.idealPacket ctx Q table p) := by + intro p member + obtain ⟨answer,found⟩ := cached p (List.mem_append_left [packet] member) + have equal : WHIRModeFinal.idealPacket ctx Q table p = answer := + tableExecution_cache ctx Q select program table (.inl p) answer found + exact found.trans (congrArg some equal.symm) + have current : WHIRModeFinal.idealPacket ctx Q table packet = raw := + tableExecution_cache ctx Q select program table (.inl packet) raw hit + unfold history WHIRRawROM.completedHistory + rw [decode_completion,current,WHIRRawHistory.decoded_ancestors_eq, + cached_packets ctx Q table _ _ packetHits] + +/-- The verifier consumes only the explicit completed transcript, not an +ambient oracle. Catalog and root snapshots are separate caller bookkeeping. -/ +def Failure (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (catalog : WHIRRawROM.Catalogs cap) (roots : WHIRRawROM.RootFamilies) + (selected : Option (RawWHIRKeys.Packet ctx Q)) (physical : List (Sigma (GroupAnswer ctx Q))) : Prop := + ∃ packet, selected = some packet ∧ + StackWHIRROM.HistoryFailure packet.val.profile cap + (WHIRRawROM.localCatalog catalog packet.val.profile (callerEntry ctx Q packet)) + (roots packet.val.profile) packet.val.statement packet.val.messages + (history ctx stack Q packet physical) + +theorem failure_iff_cache (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (catalog : WHIRRawROM.Catalogs cap) (roots : WHIRRawROM.RootFamilies) + {R : Type} {K : Nat} (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) + (table : DuplexModeGame.RawKey Q → Digest32) : + Failure ctx stack Q cap catalog roots (select (tableExecution ctx Q select program table).1) + (WHIRModeFinal.idealCompletion ctx Q table + (select (tableExecution ctx Q select program table).1)) ↔ + WHIRRawROM.Failure ctx stack Q cap catalog roots + (select (tableExecution ctx Q select program table).1) + (tableExecution ctx Q select program table).2 := by + constructor + · rintro ⟨packet,selected,failed⟩ + have cached := tableExecution_cached ctx Q select program table + rw [selected] at cached + obtain ⟨raw,hit⟩ := cached packet (List.mem_append_right _ (by simp)) + refine ⟨packet,selected,raw,hit,?_⟩ + rw [selected,completed_history ctx stack Q select program table packet selected raw hit] at failed + exact failed + · rintro ⟨packet,selected,raw,hit,failed⟩ + refine ⟨packet,selected,?_⟩ + rw [selected,completed_history ctx stack Q select program table packet selected raw hit] + exact failed + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ + +/-- Exact raw-ROM bound for the explicit completed transcript. The binding +state here remains the causal interpreter's private state; this theorem does +not assert that it is reconstructible from a mode observer's public view. -/ +theorem physical_table_list_binding (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (resolver : WHIRCausalRawROM.Resolver ctx Q cap) + (initial : CausalBindingState.State cap) {R : Type} {K : Nat} + (select : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) : + FiatShamirGame.average (fun table : DuplexModeGame.RawKey Q → Digest32 => + let result := tableExecution ctx Q select program table + let final := WHIRCausalRawROM.stateOfResult ctx stack Q cap resolver initial select program result + if Failure ctx stack Q cap final.catalog (CausalBindingState.roots final) + (select result.1) (WHIRModeFinal.idealCompletion ctx Q table (select result.1)) + then 1 else 0) ≤ + min 1 (((allocationBudget ctx * (K+1) : Nat) : ℚ) * WHIRRawROM.epsilon cap) := by + apply le_trans _ (WHIRCausalRawROM.raw_table_list_binding ctx stack Q cap resolver initial select program) + apply le_of_eq + apply congrArg FiatShamirGame.average + funext table + dsimp only + rw [failure_iff_cache] + +end Whir.WHIRModeReplay diff --git a/verification/whir/Whir/WHIRNativeArithmetic.lean b/verification/whir/Whir/WHIRNativeArithmetic.lean new file mode 100644 index 000000000..d0ae35123 --- /dev/null +++ b/verification/whir/Whir/WHIRNativeArithmetic.lean @@ -0,0 +1,738 @@ +import Whir.AccumulatedTerminalRefinement +import Whir.OperationalRefinement +import Whir.WHIRNativeGuards + +namespace Whir.WHIRNativeArithmetic +open Concrete Protocol AccumulatedTerminalRefinement +set_option maxHeartbeats 1600000 + +/-- Only the source claim, the two transmitted coefficients, remaining dimension, +and native saved contexts occur in executable arithmetic state. -/ +structure State where + n : Nat + claim : E + message : Message E + source : SourceState + deriving Repr + +def foldScalar (s : State) (r : E) (next : Message E) : State := + ⟨s.n - 1, s.message.eval s.claim r, next, s.source.step (.fold r)⟩ + +def batchScalar (s : State) (basis : Basis) (value beta : E) (intro : Message E) : State := + ⟨s.n, s.claim + beta * value, s.message.glue intro beta, s.source.step (.glue basis beta)⟩ + +def foldStep (cs : LevelChallenges) (p : LevelProof) (j : Nat) (s : State) : State := + foldScalar s cs.folds[j]! p.afterFold[j]! + +def foldBlock (cs : LevelChallenges) (p : LevelProof) (s : State) : State := + runSteps (foldStep cs p) cs.folds.size 0 s + +def oodStep (cs : LevelChallenges) (p : LevelProof) (j : Nat) (s : State × E) : State × E := + let beta := s.2 * cs.lambda + (batchScalar s.1 (.ood cs.oodPoints[j]!) p.oods[j]!.value beta p.oods[j]!.intro, beta) + +def oodBatch (cs : LevelChallenges) (p : LevelProof) (s : State) : State × E := + runSteps (oodStep cs p) p.oods.size 0 (s, E.one) + +def queryBatch (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : State × E) : State := + batchScalar s.1 (.query n qs cs.lambda) + (enforced p.rows cs.folds (powers cs.lambda qs.size) (i == 0)) + (s.2 * cs.lambda) p.intro + +/-- Merkle roots are only presence markers here. Public root shapes and actual +opened-row authentication are handled by the physical driver, not by oracle +lookup or dense-weight construction in this executable checker. -/ +def verifyLevel (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (s : State) : Except String State := do + let cs := ch.levels[i]! + let p := proof.levels[i]! + if p.afterFold.size != cs.folds.size || p.oods.size != cs.oodPoints.size then + throw "round/OOD length" + let s := foldBlock cs p s + if i + 1 < c.folds.size then + if !p.nextOracle.isSome then throw "missing commitment" + else + if p.nextOracle.isSome || proof.residual.size != 2 ^ s.n then throw "final length" + let qs ← (deriveQueries (s.n + c.rates[i]!) c.queries[i]! cs.querySqueezes).elim + (throw "query challenges") pure + if p.rows.size != qs.size then throw "query length" + return queryBatch s.n i cs p qs (oodBatch cs p s) + +def tailStep (ch : Challenges) (proof : Opening) (j : Nat) (s : State) : State := + let next := if j + 1 < ch.tail.size then proof.tailMessages[j]! else s.message + { s with claim := s.message.eval s.claim ch.tail[j]!, message := next } + +def closeTail (ch : Challenges) (proof : Opening) (s : State) : State := + runSteps (tailStep ch proof) ch.tail.size 0 s + +def nativeVerify (c : Config) (ch : Challenges) (lanes : Nat) (initialClaim : E) + (callerAt : Array E → E) (proof : Opening) : Except String Unit := do + if !ch.valid c || lanes == 0 || lanes > 2 ^ c.folds[0]! then + throw "configuration/challenges/weight" + if proof.levels.size != c.folds.size || proof.tailMessages.size + 1 != ch.tail.size then + throw "proof length" + let s ← runChecked (verifyLevel c ch proof) c.folds.size 0 + ⟨c.logN, initialClaim, proof.initial, ⟨[], []⟩⟩ + let final := closeTail ch proof s + let callerPoint := rotatePoint c.folds[0]! (s.source.ris ++ ch.tail.toList).toArray + let terminal := sourceTerminal (callerAt callerPoint) s.source.saved s.source.ris ch.tail.toList proof.residual + if !(final.claim == terminal) then throw "terminal mismatch" + return () + +/-- Local semantic relation used below. It is proved from initialization and +preserved by scalar operations; it is not an input to nativeVerify. -/ +structure WeightInvariant (callerAt : Array E → E) (initialK : Nat) (s : State) (w : Array E) : Prop where + size : w.size = 2 ^ s.n + contexts : ∀ ctx ∈ s.source.saved, + ctx.risStart ≤ s.source.ris.length ∧ + ctx.basis.Shape (s.source.ris.length + s.n - ctx.risStart) + eval : ∀ point : List E, point.length = s.n → + Concrete.mle w point.toArray = + callerAt (rotatePoint initialK (s.source.ris ++ point).toArray) + + nativeSaved s.source.saved s.source.ris point + +/-- A low fold extends the unrotated transcript, never a context-local rotation. -/ +theorem WeightInvariant.fold (callerAt : Array E → E) (k : Nat) (s : State) (w : Array E) + (h : WeightInvariant callerAt k s w) (hn : 0 < s.n) (r : E) (next : Message E) : + WeightInvariant callerAt k (foldScalar s r next) (foldLow w r) := by + constructor + · simp only [ArrayLayout.size_foldLow, h.size, foldScalar] + have he : s.n = (s.n - 1) + 1 := by omega + rw [he, pow_succ, Nat.mul_div_left _ (by decide : 0 < 2)] + simp + · intro ctx hc + obtain ⟨hstart, hshape⟩ := h.contexts ctx hc + constructor + · simpa [foldScalar, SourceState.step] using hstart.trans (Nat.le_add_right _ 1) + · simpa only [foldScalar, SourceState.step, List.length_append, List.length_singleton, + show s.source.ris.length + 1 + (s.n - 1) = s.source.ris.length + s.n by omega] using hshape + · intro point hp + have hp' : point.length = s.n - 1 := hp + have he := h.eval (r :: point) (by simp; omega) + rw [show (r :: point).toArray = #[r] ++ point.toArray by simp, + TerminalRefinement.mle_cons _ _ _ (by rw [h.size]; congr 1; simp; omega)] at he + simpa [foldScalar, SourceState.step, nativeSaved, List.append_assoc] using he + +theorem WeightInvariant.batch (callerAt : Array E → E) (k : Nat) (s : State) (w : Array E) + (h : WeightInvariant callerAt k s w) (basis : Basis) (hb : basis.Shape s.n) + (value beta : E) (intro : Message E) : + WeightInvariant callerAt k (batchScalar s basis value beta intro) (weightGlue w basis.dense beta) := by + constructor + · simpa [batchScalar] using h.size + · intro ctx hc + simp only [batchScalar, SourceState.step, List.mem_append, List.mem_singleton] at hc + rcases hc with hc | rfl + · exact h.contexts ctx hc + · exact ⟨le_rfl, by simpa [batchScalar, SourceState.step] using hb⟩ + · intro point hp + change point.length = s.n at hp + rw [AccumulatedTerminalAlgebra.mle_weightGlue _ _ _ _ + (by simpa [batchScalar] using h.size.trans (congrArg (2 ^ ·) hp.symm)) + ((basis.size_dense _ hb).trans h.size.symm)] + rw [h.eval point hp, ← basis.native_eq_mle point (by simpa [hp] using hb)] + simp [batchScalar, SourceState.step, nativeSaved, List.map_append, + List.sum_append, add_assoc] + +theorem runSteps_related {A B : Type*} (f : Nat → A → A) (g : Nat → B → B) + (P : A → B → Prop) (count start : Nat) (a : A) (b : B) (hab : P a b) + (step : ∀ j x y, start ≤ j → j < start + count → P x y → P (f j x) (g j y)) : + P (runSteps f count start a) (runSteps g count start b) := by + induction count generalizing start a b with + | zero => exact hab + | succ count ih => + apply ih (start + 1) (f start a) (g start b) + · exact step start a b (by omega) (by omega) hab + · intro j x y hlo hhi hp + exact step j x y (by omega) (by omega) hp + +def ScalarSame (s : State) (d : VerifierState E) : Prop := + s.claim = d.claim ∧ s.message = d.message + +theorem same_fold (s : State) (d : VerifierState E) (h : ScalarSame s d) + (block : Nat) (r : E) (next : Message E) : + ScalarSame (foldScalar s r next) (d.fold block r next) := by + simp [ScalarSame, foldScalar, VerifierState.fold, h.1, h.2] + +theorem same_batch (s : State) (d : VerifierState E) (h : ScalarSame s d) + (basis : Basis) (value beta : E) (intro : Message E) : + ScalarSame (batchScalar s basis value beta intro) (d.batch basis.dense value beta intro) := by + simp only [ScalarSame, batchScalar, VerifierState.batch] + exact ⟨by rw [h.1], by rw [h.2]⟩ + +theorem foldBlock_same (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : State) (d : CheckedState) (h : ScalarSame s d.state) : + ScalarSame (foldBlock cs p s) (Protocol.foldBlock block cs p d).state := by + exact runSteps_related (foldStep cs p) (Protocol.foldStep block cs p) + (fun s d => ScalarSame s d.state) _ _ _ _ h + (by intro j s d _ _ h; exact same_fold s d.state h block _ _) + +theorem foldSteps_n (cs : LevelChallenges) (p : LevelProof) (count start : Nat) (s : State) : + (runSteps (foldStep cs p) count start s).n = s.n - count := by + induction count generalizing start s with + | zero => simp [runSteps] + | succ count ih => simp [runSteps, ih, foldStep, foldScalar, Nat.sub_sub, Nat.add_comm] + +theorem foldSteps_source (cs : LevelChallenges) (p : LevelProof) + (count start : Nat) (s : State) : + (runSteps (foldStep cs p) count start s).source = + ⟨s.source.ris ++ (List.range' start count).map (fun j => cs.folds[j]!), s.source.saved⟩ := by + induction count generalizing start s with + | zero => simp only [runSteps, List.range'_zero, List.map_nil, List.append_nil] + | succ count ih => + simp [runSteps, ih, foldStep, foldScalar, SourceState.step, List.range'_succ, List.append_assoc] + +theorem foldBlock_source (cs : LevelChallenges) (p : LevelProof) (s : State) : + (foldBlock cs p s).source = ⟨s.source.ris ++ cs.folds.toList, s.source.saved⟩ := by + have mapped : (List.range cs.folds.size).map (fun i => cs.folds[i]!) = cs.folds.toList := by + apply List.ext_getElem + · simp + · intro i hi hi' + simp only [List.getElem_map, List.getElem_range, Array.getElem_toList] + simp only [getElem!_pos cs.folds i (by simpa using hi')] + rw [foldBlock, foldSteps_source, ← List.range_eq_range', mapped] + +theorem foldBlock_n (cs : LevelChallenges) (p : LevelProof) (s : State) : + (foldBlock cs p s).n = s.n - cs.folds.size := foldSteps_n cs p _ _ s + +theorem lowFoldSteps_invariant (callerAt : Array E → E) (k : Nat) + (cs : LevelChallenges) (p : LevelProof) (count start : Nat) (s : State) (d : CheckedState) + (h : WeightInvariant callerAt k s d.state.weight) (bound : count ≤ s.n) : + WeightInvariant callerAt k (runSteps (foldStep cs p) count start s) + (runSteps (Protocol.foldStep 1 cs p) count start d).state.weight := by + induction count generalizing start s d with + | zero => exact h + | succ count ih => + apply ih (start + 1) (foldStep cs p start s) (Protocol.foldStep 1 cs p start d) + · simpa only [foldStep, Protocol.foldStep, VerifierState.fold, foldValues, BEq.rfl, ↓reduceIte] using + h.fold callerAt k s d.state.weight (by omega) cs.folds[start]! p.afterFold[start]! + · change count ≤ s.n - 1 + omega + +theorem oodBatch_related (callerAt : Array E → E) (k : Nat) + (cs : LevelChallenges) (p : LevelProof) (s : State) (d : VerifierState E) + (same : ScalarSame s d) (inv : WeightInvariant callerAt k s d.weight) + (shape : ∀ j < p.oods.size, cs.oodPoints[j]!.size = s.n) : + let ns := oodBatch cs p s + let ds := Protocol.oodBatch cs p d + ns.2 = ds.2 ∧ ns.1.n = s.n ∧ ScalarSame ns.1 ds.1 ∧ + WeightInvariant callerAt k ns.1 ds.1.weight := by + apply runSteps_related (oodStep cs p) (Protocol.oodStep cs p) + (fun ns ds => ns.2 = ds.2 ∧ ns.1.n = s.n ∧ ScalarSame ns.1 ds.1 ∧ + WeightInvariant callerAt k ns.1 ds.1.weight) _ _ _ _ + · exact ⟨rfl, rfl, same, inv⟩ + · intro j ns ds _ hj h + obtain ⟨hbeta, hn, hsame, hinv⟩ := h + have hb : (Basis.ood cs.oodPoints[j]!).Shape ns.1.n := by + exact (shape j (by omega)).trans hn.symm + refine ⟨by simp [oodStep, Protocol.oodStep, hbeta], hn, ?_, ?_⟩ + · simpa [oodStep, Protocol.oodStep, hbeta, Basis.dense] using + same_batch ns.1 ds.1 hsame (.ood cs.oodPoints[j]!) p.oods[j]!.value + (ds.2 * cs.lambda) p.oods[j]!.intro + · simpa [oodStep, Protocol.oodStep, VerifierState.batch, hbeta, Basis.dense] using + hinv.batch callerAt k ns.1 ds.1.weight (.ood cs.oodPoints[j]!) hb + p.oods[j]!.value (ds.2 * cs.lambda) p.oods[j]!.intro + +theorem initial_fold_invariant (callerAt : Array E → E) (cs : LevelChallenges) + (p : LevelProof) (s : State) (b : Array E) (n k : Nat) + (sn : s.n = n + k) (sk : cs.folds.size = k) (empty : s.source = ⟨[], []⟩) + (hb : b.size = 2 ^ (n + k)) + (caller : ∀ point : Array E, point.size = n + k → callerAt point = Concrete.mle b point) : + WeightInvariant callerAt k (foldBlock cs p s) + (cs.folds.foldl (fun b r => foldLane b (2 ^ n) r) b) := by + have hn : (foldBlock cs p s).n = n := by rw [foldBlock_n, sn, sk]; omega + have hs : (foldBlock cs p s).source = ⟨cs.folds.toList, []⟩ := by + rw [foldBlock_source, empty]; simp + constructor + · rw [QueryRefinement.foldLane_blocks _ _ _ (by rw [sk, hb, pow_add, Nat.mul_comm]), hn] + simp + · simp [hs] + · intro point hp + have hp' : point.length = n := hp.trans hn + rw [hs] + simp only [nativeSaved, List.map_nil, List.sum_nil, add_zero] + have hrot : rotatePoint k (cs.folds.toList ++ point).toArray = point.toArray ++ cs.folds := by + have ha : (cs.folds.toList ++ point).toArray = cs.folds ++ point.toArray := by + apply Array.toList_inj.mp + simp + rw [ha, ← sk] + exact InitialTerminalRefinement.rotate_initial _ _ + rw [caller _ (by simp [ArrayLayout.size_rotatePoint, sk, hp', Nat.add_comm]), hrot] + have he := InitialTerminalRefinement.mle_foldLane_initial b cs.folds point.toArray + (by simpa [hp', sk] using hb) + simpa [hp'] using he + +theorem WeightInvariant.terminal (callerAt : Array E → E) (k : Nat) (s : State) (w residual : Array E) + (h : WeightInvariant callerAt k s w) (tail : List E) (ht : tail.length = s.n) : + Concrete.mle residual tail.toArray * Concrete.mle w tail.toArray = + sourceTerminal (callerAt (rotatePoint k (s.source.ris ++ tail).toArray)) + s.source.saved s.source.ris tail residual := by + have hs : nativeSaved s.source.saved s.source.ris tail = + (s.source.saved.map (fun ctx => ctx.beta * + ctx.basis.native (ctx.sourcePoint s.source.ris tail))).sum := by + unfold nativeSaved + congr 1 + apply List.map_congr_left + intro ctx hc + obtain ⟨hstart, hshape⟩ := h.contexts ctx hc + have hdim := ctx.basis.dimension_eq _ hshape + have hlen : ctx.basis.dimension - tail.length = (s.source.ris.drop ctx.risStart).length := by + simp only [List.length_drop] + omega + simp only [Saved.sourcePoint, hlen, List.take_length] + rw [List.drop_append_of_le_length hstart] + rw [h.eval tail ht, hs, source_terms] + unfold sourceTerminal + ring + +theorem closeTail_same (ch : Challenges) (proof : Opening) (s : State) (d : VerifierState E) + (same : ScalarSame s d) : + ScalarSame (closeTail ch proof s) (Protocol.closeTail ch proof d) := by + apply runSteps_related (tailStep ch proof) (Protocol.tailStep ch proof) ScalarSame _ _ _ _ same + intro j s d _ _ h + simp [ScalarSame, tailStep, Protocol.tailStep, VerifierState.fold, h.1, h.2] + +theorem tailSteps_weight (ch : Challenges) (proof : Opening) + (count start : Nat) (d : VerifierState E) : + (runSteps (Protocol.tailStep ch proof) count start d).weight = + (List.range' start count).foldl (fun b j => foldLow b ch.tail[j]!) d.weight := by + induction count generalizing start d with + | zero => rfl + | succ count ih => + simp only [runSteps, List.range'_succ, List.foldl_cons, ih, + Protocol.tailStep, VerifierState.fold, foldValues, BEq.rfl, ↓reduceIte] + +theorem closeTail_weight (ch : Challenges) (proof : Opening) (d : VerifierState E) : + (Protocol.closeTail ch proof d).weight = ch.tail.foldl foldLow d.weight := by + have mapped : (List.range ch.tail.size).map (fun i => ch.tail[i]!) = ch.tail.toList := by + apply List.ext_getElem + · simp + · intro i hi hi' + simp only [List.getElem_map, List.getElem_range, Array.getElem_toList] + simp only [getElem!_pos ch.tail i (by simpa using hi')] + rw [Protocol.closeTail, tailSteps_weight, ← List.range_eq_range', ← List.foldl_map, + mapped, Array.foldl_toList] + +private theorem except_pure {S : Type*} (s : S) : (pure s : Except String S) = .ok s := rfl +private theorem except_bind_ok {S T : Type} (s : S) (f : S → Except String T) : + ((Except.ok s : Except String S) >>= f) = f s := rfl +private theorem except_bind_error {S T : Type} (e : String) (f : S → Except String T) : + ((Except.error e : Except String S) >>= f) = Except.error e := rfl +private theorem except_throw {S : Type*} (e : String) : (throw e : Except String S) = .error e := rfl +attribute [local simp] except_pure except_bind_ok except_bind_error except_throw + +theorem verifyLevel_success (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (s finish : State) (success : verifyLevel c ch proof i s = .ok finish) : + let cs := ch.levels[i]! + let p := proof.levels[i]! + let folded := foldBlock cs p s + p.afterFold.size = cs.folds.size ∧ p.oods.size = cs.oodPoints.size ∧ + (if i + 1 < c.folds.size then p.nextOracle.isSome = true + else p.nextOracle.isSome = false ∧ proof.residual.size = 2 ^ folded.n) ∧ + ∃ qs, deriveQueries (folded.n + c.rates[i]!) c.queries[i]! cs.querySqueezes = some qs ∧ + p.rows.size = qs.size ∧ finish = queryBatch folded.n i cs p qs (oodBatch cs p folded) := by + dsimp + unfold verifyLevel at success + generalize hf : foldBlock ch.levels[i]! proof.levels[i]! s = folded at success ⊢ + cases hn : proof.levels[i]!.nextOracle <;> + cases hq : deriveQueries (folded.n + c.rates[i]!) c.queries[i]! ch.levels[i]!.querySqueezes + all_goals + simp only [hn, Option.elim, Option.isSome, except_pure, + except_bind_error, except_throw] at success + split_ifs at success <;> simp_all + all_goals (split_ifs at success; simp_all) + +theorem protocolLevel_of_checks (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (d : CheckedState) (qs : Array Nat) + (rounds : proof.levels[i]!.afterFold.size = ch.levels[i]!.folds.size) + (oods : proof.levels[i]!.oods.size = ch.levels[i]!.oodPoints.size) + (boundary : + let f := Protocol.foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! d + if i + 1 < c.folds.size then + ∃ next, proof.levels[i]!.nextOracle = some next ∧ + oracleValid next (2^(f.n-c.folds[i+1]!+c.rates[i+1]!)) (2^c.folds[i+1]!) = true + else proof.levels[i]!.nextOracle.isSome = false ∧ proof.residual.size = 2^f.n) + (query : + deriveQueries ((Protocol.foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! d).n + c.rates[i]!) c.queries[i]! + ch.levels[i]!.querySqueezes = some qs) + (rows : proof.levels[i]!.rows.size = qs.size) + (auth : ∀ j < qs.size, proof.levels[i]!.rows[j]! = + (Protocol.foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! d).oracle[qs[j]!]!) : + let f := Protocol.foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! d + Protocol.verifyLevel c ch proof i d = + .ok ⟨f.n, Protocol.queryBatch f.n i ch.levels[i]! proof.levels[i]! qs + (Protocol.oodBatch ch.levels[i]! proof.levels[i]! f.state), + proof.levels[i]!.nextOracle.getD #[]⟩ := by + have ha := (OperationalRefinement.authentication_ok_iff + (Protocol.foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! d).oracle qs proof.levels[i]!).mpr + (by intro j hj; simp [auth j hj]) + dsimp only at boundary ⊢ + by_cases more : i + 1 < c.folds.size + · rw [ite_eq_left more] at boundary + obtain ⟨next, hn, hv⟩ := boundary + simp_all [Protocol.verifyLevel] + · rw [ite_eq_right more] at boundary + have hn : proof.levels[i]!.nextOracle = none := by + cases h : proof.levels[i]!.nextOracle <;> simp_all + simp_all [Protocol.verifyLevel] + +theorem foldBlock_oracle (block : Nat) (cs : LevelChallenges) (p : LevelProof) (d : CheckedState) : + (Protocol.foldBlock block cs p d).oracle = d.oracle := by + have aux (count start : Nat) (d : CheckedState) : + (runSteps (Protocol.foldStep block cs p) count start d).oracle = d.oracle := by + induction count generalizing start d with + | zero => rfl + | succ count ih => exact ih (start + 1) (Protocol.foldStep block cs p start d) + exact aux _ _ _ + +/-- Ghost oracle table used solely in the refinement theorem. No native runtime +definition reads this function or any full oracle. -/ +def oracleBefore (proof : Opening) (root : Oracle) (i : Nat) : Oracle := + if i = 0 then root else proof.levels[i-1]!.nextOracle.getD #[] + +def RootShapes (c : Config) (proof : Opening) : Prop := + ∀ i, i < c.folds.size → i + 1 < c.folds.size → + ∀ next, proof.levels[i]!.nextOracle = some next → + oracleValid next (2^(CausalGame.remaining c i-c.folds[i+1]!+c.rates[i+1]!)) + (2^c.folds[i+1]!) = true + +def AuthenticatedRows (c : Config) (ch : Challenges) (proof : Opening) (root : Oracle) : Prop := + ∀ i, i < c.folds.size → ∀ qs, + deriveQueries (CausalGame.remaining c i+c.rates[i]!) c.queries[i]! + ch.levels[i]!.querySqueezes = some qs → + ∀ j, j < qs.size → proof.levels[i]!.rows[j]! = (oracleBefore proof root i)[qs[j]!]! + +structure ReplayInvariant (c : Config) (callerAt : Array E → E) (b : Array E) + (proof : Opening) (root : Oracle) (i : Nat) (s : State) (d : CheckedState) : Prop where + native_n : s.n = WHIRNativeGuards.before c i + dense_n : d.n = WHIRNativeGuards.before c i + scalar : ScalarSame s d.state + oracle : d.oracle = oracleBefore proof root i + first_weight : i = 0 → d.state.weight = b + first_source : i = 0 → s.source = ⟨[], []⟩ + weight : 0 < i → WeightInvariant callerAt c.folds[0]! s d.state.weight + +theorem verifyLevel_refines (c : Config) (ch : Challenges) (proof : Opening) + (callerAt : Array E → E) (b : Array E) (root : Oracle) + (hc : ch.valid c = true) (hb : b.size = 2^c.logN) + (caller : ∀ point : Array E, point.size = c.logN → callerAt point = Concrete.mle b point) + (roots : RootShapes c proof) (authenticated : AuthenticatedRows c ch proof root) + (i : Nat) (hi : i < c.folds.size) (s finish : State) (d : CheckedState) + (inv : ReplayInvariant c callerAt b proof root i s d) + (success : verifyLevel c ch proof i s = .ok finish) : + ∃ df, Protocol.verifyLevel c ch proof i d = .ok df ∧ + ReplayInvariant c callerAt b proof root (i+1) finish df := by + let cs := ch.levels[i]! + let p := proof.levels[i]! + let block := if i == 0 then 2^(c.logN-c.folds[0]!) else 1 + let nf := foldBlock cs p s + let df := Protocol.foldBlock block cs p d + have hconfig := WHIRNativeGuards.challenges_config c ch hc + have hfold := WHIRNativeGuards.challenges_folds c ch hc i hi + have hdims := (WHIRNativeGuards.config_remaining c hconfig i hi).2 + have hlevel := WHIRNativeGuards.config_level c hconfig i hi + have hn : nf.n = CausalGame.remaining c i := by + rw [foldBlock_n, inv.native_n, hfold] + exact WHIRNativeGuards.before_step c i hi + have hdn : df.n = CausalGame.remaining c i := by + exact OracleReplay.foldBlock_dimensions block cs p d _ _ + (inv.dense_n.trans hdims.symm) hfold + have hscalar : ScalarSame nf df.state := foldBlock_same block cs p s d inv.scalar + have hweight : WeightInvariant callerAt c.folds[0]! nf df.state.weight := by + by_cases hz : i = 0 + · have hsum : CausalGame.remaining c i + c.folds[0]! = c.logN := by + simpa [hz, WHIRNativeGuards.before] using hdims + have hblock : block = 2^(CausalGame.remaining c i) := by + simp only [block, show (i == 0) = true by simp [hz], ↓reduceIte] + congr 1 + omega + rw [show df.state.weight = cs.folds.foldl (fun b r => foldLane b block r) d.state.weight from + AccumulatedTerminalRefinement.foldBlock_weight_lane block cs p d] + rw [hblock, inv.first_weight hz] + exact initial_fold_invariant callerAt cs p s b _ _ + (by rw [hsum]; simpa [hz, WHIRNativeGuards.before] using inv.native_n) + (hfold.trans (by rw [hz])) (inv.first_source hz) + (by simpa [hsum] using hb) (by simpa [hsum] using caller) + · have hblock : block = 1 := by simp [block, hz] + simpa only [df, nf, Protocol.foldBlock, foldBlock, hblock] using + lowFoldSteps_invariant callerAt c.folds[0]! cs p cs.folds.size 0 s d + (inv.weight (by omega)) (by rw [hfold, inv.native_n]; exact hlevel.2.1.le) + obtain ⟨hround, hood, hboundary, qs, hquery, hrows, hfinish⟩ := + verifyLevel_success c ch proof i s finish success + change p.afterFold.size = cs.folds.size at hround + change p.oods.size = cs.oodPoints.size at hood + change deriveQueries (nf.n+c.rates[i]!) c.queries[i]! cs.querySqueezes = some qs at hquery + change (if i+1 < c.folds.size then p.nextOracle.isSome = true + else p.nextOracle.isSome = false ∧ proof.residual.size = 2^nf.n) at hboundary + have hquery' : deriveQueries (CausalGame.remaining c i+c.rates[i]!) c.queries[i]! + cs.querySqueezes = some qs := by simpa [hn] using hquery + have hoods : ∀ j < p.oods.size, cs.oodPoints[j]!.size = nf.n := by + intro j hj + have hj' : j < cs.oodPoints.size := by omega + rw [hn] + apply WHIRNativeGuards.challenges_ood_point c ch hc i hi + rw [getElem!_pos cs.oodPoints j hj'] + exact Array.getElem_mem hj' + have hob := oodBatch_related callerAt c.folds[0]! cs p nf df.state hscalar hweight hoods + dsimp only at hob + let nb := oodBatch cs p nf + let db := Protocol.oodBatch cs p df.state + have hbeta : nb.2 = db.2 := hob.1 + have hqshape : (Basis.query nf.n qs cs.lambda).Shape nb.1.n := by + change nf.n = nb.1.n ∧ nf.n ≤ 64 + have hdepth := hlevel.2.2.2.2 + exact ⟨hob.2.1.symm, by rw [hn]; omega⟩ + have hqinv : WeightInvariant callerAt c.folds[0]! (queryBatch nf.n i cs p qs nb) + (Protocol.queryBatch df.n i cs p qs db).weight := by + have h := hob.2.2.2.batch callerAt c.folds[0]! nb.1 db.1.weight + (.query nf.n qs cs.lambda) hqshape + (enforced p.rows cs.folds (powers cs.lambda qs.size) (i == 0)) + (db.2*cs.lambda) p.intro + simpa [queryBatch, Protocol.queryBatch, VerifierState.batch, Basis.dense, hbeta, hn, hdn] using h + have hqsame : ScalarSame (queryBatch nf.n i cs p qs nb) + (Protocol.queryBatch df.n i cs p qs db) := by + simpa [queryBatch, Protocol.queryBatch, Basis.dense, hbeta, hn, hdn] using + same_batch nb.1 db.1 hob.2.2.1 (.query nf.n qs cs.lambda) + (enforced p.rows cs.folds (powers cs.lambda qs.size) (i == 0)) (db.2*cs.lambda) p.intro + let finishD : CheckedState := ⟨df.n, Protocol.queryBatch df.n i cs p qs db, p.nextOracle.getD #[]⟩ + refine ⟨finishD, ?_, ?_⟩ + · apply protocolLevel_of_checks c ch proof i d qs hround hood + · dsimp only + by_cases more : i+1 < c.folds.size + · simp only [ite_eq_left more] at hboundary ⊢ + cases he : p.nextOracle with + | none => simp [he] at hboundary + | some next => + refine ⟨next, rfl, ?_⟩ + change oracleValid next (2^(df.n-c.folds[i+1]!+c.rates[i+1]!)) (2^c.folds[i+1]!) = true + rw [hdn] + exact roots i hi more next he + · simp only [ite_eq_right more] at hboundary ⊢ + change p.nextOracle.isSome = false ∧ proof.residual.size = 2^df.n + simpa only [hn, hdn] using hboundary + · change deriveQueries (df.n+c.rates[i]!) c.queries[i]! cs.querySqueezes = some qs + rw [hdn] + exact hquery' + · exact hrows + · intro j hj + rw [foldBlock_oracle, inv.oracle] + exact authenticated i hi qs hquery' j hj + · have hf : finish = queryBatch nf.n i cs p qs nb := hfinish + rw [hf] + constructor + · change nb.1.n = WHIRNativeGuards.before c (i+1) + exact hob.2.1.trans hn + · exact hdn + · exact hqsame + · simp [finishD, oracleBefore, p] + · omega + · omega + · intro _ + exact hqinv + +theorem replay_refines (c : Config) (ch : Challenges) (proof : Opening) + (callerAt : Array E → E) (b : Array E) (root : Oracle) + (hc : ch.valid c = true) (hb : b.size = 2^c.logN) + (caller : ∀ point : Array E, point.size = c.logN → callerAt point = Concrete.mle b point) + (roots : RootShapes c proof) (authenticated : AuthenticatedRows c ch proof root) + (count start : Nat) (bound : start + count ≤ c.folds.size) + (s finish : State) (d : CheckedState) + (inv : ReplayInvariant c callerAt b proof root start s d) + (success : runChecked (verifyLevel c ch proof) count start s = .ok finish) : + ∃ df, runChecked (Protocol.verifyLevel c ch proof) count start d = .ok df ∧ + ReplayInvariant c callerAt b proof root (start+count) finish df := by + induction count generalizing start s d with + | zero => + simp only [runChecked, Except.ok.injEq] at success + subst finish + exact ⟨d, rfl, inv⟩ + | succ count ih => + cases hstep : verifyLevel c ch proof start s with + | error e => simp [runChecked, hstep] at success + | ok next => + obtain ⟨nextD, hd, hr⟩ := verifyLevel_refines c ch proof callerAt b root hc hb caller + roots authenticated start (by omega) s next d inv hstep + obtain ⟨finishD, hf, hrel⟩ := ih (start+1) (by omega) next nextD hr + (by simpa [runChecked, hstep] using success) + refine ⟨finishD, by simpa [runChecked, hd] using hf, ?_⟩ + simpa [Nat.add_assoc, Nat.add_left_comm, Nat.add_comm] using hrel + +theorem nativeVerify_success (c : Config) (ch : Challenges) (lanes : Nat) + (initialClaim : E) (callerAt : Array E → E) (proof : Opening) + (success : nativeVerify c ch lanes initialClaim callerAt proof = .ok ()) : + ch.valid c = true ∧ proof.levels.size = c.folds.size ∧ + proof.tailMessages.size + 1 = ch.tail.size ∧ + ∃ s, runChecked (verifyLevel c ch proof) c.folds.size 0 + ⟨c.logN, initialClaim, proof.initial, ⟨[], []⟩⟩ = .ok s ∧ + (closeTail ch proof s).claim = + sourceTerminal + (callerAt (rotatePoint c.folds[0]! (s.source.ris ++ ch.tail.toList).toArray)) + s.source.saved s.source.ris ch.tail.toList proof.residual := by + unfold nativeVerify at success + cases hr : runChecked (verifyLevel c ch proof) c.folds.size 0 + ⟨c.logN, initialClaim, proof.initial, ⟨[], []⟩⟩ with + | error e => + simp only [hr, except_bind_error] at success + split_ifs at success <;> simp_all + | ok s => + simp only [hr, except_bind_ok] at success + split_ifs at success <;> simp_all + +/-- Complete arithmetic refinement. The only external premises are public +initial/commitment shapes, actual row authentication, and the original caller +weight specification. All scalar, context, dimensional and terminal relations +are established by the checked native execution. -/ +theorem nativeVerify_refines (c : Config) (ch : Challenges) (lanes : Nat) + (initialClaim : E) (callerAt : Array E → E) (proof : Opening) + (b : Array E) (root : Oracle) + (weightShape : shapeValid c lanes b = true) + (rootShape : oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes = true) + (roots : RootShapes c proof) (authenticated : AuthenticatedRows c ch proof root) + (caller : ∀ point : Array E, point.size = c.logN → callerAt point = Concrete.mle b point) + (success : nativeVerify c ch lanes initialClaim callerAt proof = .ok ()) : + Protocol.verify c ch lanes root b initialClaim proof = .ok () := by + obtain ⟨hc, hlevels, htailMessages, s, hr, hterminal⟩ := + nativeVerify_success c ch lanes initialClaim callerAt proof success + have hb : b.size = 2^c.logN := by + have h := weightShape + simp only [shapeValid, Bool.and_eq_true, beq_iff_eq, decide_eq_true_eq] at h + exact h.1.2 + let initial : State := ⟨c.logN, initialClaim, proof.initial, ⟨[], []⟩⟩ + let initialD : CheckedState := ⟨c.logN, ⟨b, initialClaim, proof.initial⟩, root⟩ + have hi : ReplayInvariant c callerAt b proof root 0 initial initialD := by + constructor + · simp [initial, WHIRNativeGuards.before] + · simp [initialD, WHIRNativeGuards.before] + · exact ⟨rfl, rfl⟩ + · simp [initialD, oracleBefore] + · intro; rfl + · intro; rfl + · omega + obtain ⟨d, hd, hf⟩ := replay_refines c ch proof callerAt b root hc hb caller + roots authenticated c.folds.size 0 (by omega) initial s initialD hi hr + simp only [Nat.zero_add] at hf + have hpositive : 0 < c.folds.size := by + have h := (WHIRNativeGuards.config_header c (WHIRNativeGuards.challenges_config c ch hc)).1 + omega + have hw := hf.weight hpositive + have ht : ch.tail.toList.length = s.n := by + rw [hf.native_n] + change ch.tail.size = c.logN - (c.folds.toList.take c.folds.size).sum + rw [show c.folds.size = c.folds.toList.length from rfl, List.take_length] + exact WHIRNativeGuards.challenges_tail c ch hc + have hv := hw.terminal callerAt c.folds[0]! s d.state.weight proof.residual ch.tail.toList ht + simp only [Array.toArray_toList] at hv + have hmle : Concrete.mle d.state.weight ch.tail = (Protocol.closeTail ch proof d.state).weight[0]! := by + rw [closeTail_weight] + exact TerminalRefinement.mle_eq_foldLow_terminal _ _ + (by rw [hw.size]; congr 1; simpa using ht.symm) + have hcheck : (Protocol.closeTail ch proof d.state).checkTerminal + (Concrete.mle proof.residual ch.tail) = true := by + apply beq_iff_eq.mpr + rw [← hmle, hv] + exact (closeTail_same ch proof s d.state hf.scalar).1.symm.trans hterminal + have hinit : initializeVerifier c ch lanes root b initialClaim proof = .ok initialD := by + simp [initializeVerifier, hc, weightShape, rootShape, hlevels, htailMessages, initialD] + simp [Protocol.verify, hinit, Protocol.replayLevels, hd, checkClosing, hcheck] + +/-- Literal source caller cutover: no evaluator-equality hypothesis is exposed. -/ +def sourceNativeVerify {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (ch : Challenges) (lanes : Nat) (initialClaim : E) (proof : Opening) : Except String Unit := + nativeVerify c ch lanes initialClaim + (SuccinctRingGroups.sourceStackWeightAt family points seed lambda) proof + +theorem sourceNativeVerify_refines {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (ch : Challenges) (lanes : Nat) (initialClaim : E) (proof : Opening) (root : Oracle) + (familyShape : SuccinctRingWeight.FamilyShape c.logN family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape c.logN points[i]) + (weightShape : shapeValid c lanes + (CausalGame.batchClaims (2^c.logN) (RingPCSGame.transformedClaims (2^c.logN) family points seed) lambda).weight = true) + (rootShape : oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes = true) + (roots : RootShapes c proof) (authenticated : AuthenticatedRows c ch proof root) + (success : sourceNativeVerify family points seed lambda c ch lanes initialClaim proof = .ok ()) : + Protocol.verify c ch lanes root + (CausalGame.batchClaims (2^c.logN) (RingPCSGame.transformedClaims (2^c.logN) family points seed) lambda).weight + initialClaim proof = .ok () := by + apply nativeVerify_refines c ch lanes initialClaim + (SuccinctRingGroups.sourceStackWeightAt family points seed lambda) proof _ root + weightShape rootShape roots authenticated _ success + intro point hp + have h := SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle family points seed lambda point + (by simpa only [hp] using familyShape) (by simpa only [hp] using pointShapes) + simpa only [hp] using h + +/-- Source initial target accumulation, without constructing dense claim weights +merely to read their scalar projection. The family occupies power zero. -/ +def initialClaim {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) : E := + (points.foldl (fun s point => (s.1 + s.2 * RingPCSGame.pointValue point, s.2 * lambda)) + (RingPCSGame.familyTarget (fun j => (family j).slices) seed, lambda)).1 + +private def denseBatchStep (lambda : E) (s : CausalGame.Claim × E) (claim : CausalGame.Claim) : + CausalGame.Claim × E := + (⟨weightGlue s.1.weight claim.weight s.2, s.1.value + s.2 * claim.value⟩, s.2 * lambda) + +private theorem batchProjection (lambda : E) (claims : List CausalGame.Claim) (s : CausalGame.Claim × E) : + ((claims.foldl (denseBatchStep lambda) s).1.value, (claims.foldl (denseBatchStep lambda) s).2) = + claims.foldl (fun q claim => (q.1 + q.2 * claim.value, q.2 * lambda)) (s.1.value, s.2) := by + induction claims generalizing s with + | nil => rfl + | cons claim claims ih => + simp only [List.foldl_cons, ih, denseBatchStep] + +theorem batchClaims_value (width : Nat) (claims : Array CausalGame.Claim) (lambda : E) : + (CausalGame.batchClaims width claims lambda).value = + (claims.toList.foldl (fun s claim => (s.1 + s.2 * claim.value, s.2 * lambda)) (0, 1)).1 := by + have hfold : CausalGame.batchClaims width claims lambda = + (claims.foldl (denseBatchStep lambda) (⟨tab width (fun _ => 0), 0⟩, 1)).1 := by + unfold CausalGame.batchClaims + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + rfl + rw [hfold, ← Array.foldl_toList] + exact congrArg Prod.fst (batchProjection lambda claims.toList (⟨tab width (fun _ => 0), 0⟩, 1)) + +theorem initialClaim_eq_batch_value {m : Nat} (width : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) : + initialClaim family points seed lambda = + (CausalGame.batchClaims width (RingPCSGame.transformedClaims width family points seed) lambda).value := by + rw [batchClaims_value] + simp only [RingPCSGame.transformedClaims, Array.toList_append, + Array.toList_map, List.cons_append, List.nil_append, List.foldl_cons, + RingPCSGame.familyPublic, zero_add, one_mul, List.foldl_map] + rw [initialClaim, ← Array.foldl_toList] + rfl + +/-- Full executable caller-side arithmetic entry point: both the initial claim +and final caller weight are computed by source scalar routines only. -/ +def sourceVerify {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (ch : Challenges) (lanes : Nat) (proof : Opening) : Except String Unit := + sourceNativeVerify family points seed lambda c ch lanes (initialClaim family points seed lambda) proof + +theorem sourceVerify_refines {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (ch : Challenges) (lanes : Nat) (proof : Opening) (root : Oracle) + (familyShape : SuccinctRingWeight.FamilyShape c.logN family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape c.logN points[i]) + (weightShape : shapeValid c lanes + (CausalGame.batchClaims (2^c.logN) (RingPCSGame.transformedClaims (2^c.logN) family points seed) lambda).weight = true) + (rootShape : oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes = true) + (roots : RootShapes c proof) (authenticated : AuthenticatedRows c ch proof root) + (success : sourceVerify family points seed lambda c ch lanes proof = .ok ()) : + let batched := CausalGame.batchClaims (2^c.logN) + (RingPCSGame.transformedClaims (2^c.logN) family points seed) lambda + Protocol.verify c ch lanes root batched.weight batched.value proof = .ok () := by + have h := sourceNativeVerify_refines family points seed lambda c ch lanes + (initialClaim family points seed lambda) proof root familyShape pointShapes + weightShape rootShape roots authenticated success + rwa [initialClaim_eq_batch_value (2^c.logN) family points seed lambda] at h + +end Whir.WHIRNativeArithmetic diff --git a/verification/whir/Whir/WHIRNativeArithmeticRegression.lean b/verification/whir/Whir/WHIRNativeArithmeticRegression.lean new file mode 100644 index 000000000..ed3708e45 --- /dev/null +++ b/verification/whir/Whir/WHIRNativeArithmeticRegression.lean @@ -0,0 +1,110 @@ +import Whir.WHIRNativeArithmetic +import Whir.WHIRNativeErasure + +namespace Whir.WHIRNativeArithmeticRegression +open Concrete Protocol +open WHIRNativeArithmetic + +private def e (n : Nat) : E := E.ofK (UInt64.ofNat n) +private def config : Config := ⟨3, #[1, 1], #[1, 1], #[2, 2], #[0, 1]⟩ +private def challenges (a b : E) : Challenges := + ⟨#[⟨#[e 2], #[#[e 13, e 17]], #[e 43], a⟩, + ⟨#[e 3], #[], #[e 47], b⟩], #[e 5]⟩ +private def witness : Array K := #[1, 7, 19, 5, 42, 99, 31, 11] +private def callerPoint : Array E := #[e 23, e 29, e 31] +private def callerWeight : Array E := eqTable callerPoint +private def callerAt (point : Array E) : E := + AccumulatedTerminalAlgebra.equalityProduct callerPoint.toList point.toList + +private def expectOk (label : String) (result : Except String Unit) : IO Unit := + match result with + | .ok () => pure () + | .error message => throw (IO.userError s!"{label}: {message}") + +private def expectError (label expected : String) (result : Except String Unit) : IO Unit := + match result with + | .error message => + unless message == expected do throw (IO.userError s!"{label}: wrong error {message}") + | .ok () => throw (IO.userError s!"{label}: unexpectedly accepted") + +private def runCase (label : String) (a b : E) (negative : Bool) : IO Unit := do + let ch := challenges a b + let target := dot (witness.map E.ofK) callerWeight + let (root, proof) ← match Protocol.prove config ch witness callerWeight target with + | .ok result => pure result + | .error message => throw (IO.userError s!"prover: {message}") + expectOk (label ++ "/dense") (Protocol.verify config ch 2 root callerWeight target proof) + let physical := WHIRPhysicalErasure.eraseOracles proof + expectOk (label ++ "/native") (nativeVerify config ch 2 target callerAt physical) + if negative then + expectError "wrong target" "terminal mismatch" (nativeVerify config ch 2 (target+1) callerAt physical) + let alteredIntro := { physical with initial := {physical.initial with u0 := physical.initial.u0+1} } + expectError "altered initial scalar" "terminal mismatch" (nativeVerify config ch 2 target callerAt alteredIntro) + let first := physical.levels[0]! + let last := physical.levels[1]! + let missing := { physical with levels := physical.levels.set! 0 {first with nextOracle := none} } + expectError "missing commitment" "missing commitment" (nativeVerify config ch 2 target callerAt missing) + let extra := { physical with levels := physical.levels.set! 1 {last with nextOracle := some #[]} } + expectError "extra final commitment" "final length" (nativeVerify config ch 2 target callerAt extra) + let wrongResidual := { physical with residual := physical.residual.pop } + expectError "wrong residual length" "final length" (nativeVerify config ch 2 target callerAt wrongResidual) + let wrongRows := { physical with levels := physical.levels.set! 0 {first with rows := first.rows.pop} } + expectError "wrong query row count" "query length" (nativeVerify config ch 2 target callerAt wrongRows) + let wrongFolds := { physical with levels := physical.levels.set! 0 {first with afterFold := first.afterFold.pop} } + expectError "wrong fold scalar count" "round/OOD length" (nativeVerify config ch 2 target callerAt wrongFolds) + let wrongOod := { physical with levels := physical.levels.set! 0 {first with oods := #[]} } + expectError "wrong OOD scalar count" "round/OOD length" (nativeVerify config ch 2 target callerAt wrongOod) + let wrongTail := { physical with tailMessages := #[⟨0, 0⟩] } + expectError "wrong tail scalar count" "proof length" (nativeVerify config ch 2 target callerAt wrongTail) + expectError "zero lanes" "configuration/challenges/weight" (nativeVerify config ch 0 target callerAt physical) + expectError "too many lanes" "configuration/challenges/weight" (nativeVerify config ch 3 target callerAt physical) + let malformed := { ch with levels := ch.levels.set! 0 { ch.levels[0]! with oodPoints := #[#[e 13]] } } + expectError "wrong OOD dimension" "configuration/challenges/weight" + (nativeVerify config malformed 2 target callerAt physical) + IO.println s!"{label}: dense and scalar-only erased-root verifier accept" + +#eval do + runCase "two-level source arithmetic/nonzero glue" (e 7) (e 11) true + runCase "zero first glue" 0 (e 11) false + runCase "zero second glue" (e 7) 0 false + runCase "zero all glue" 0 0 false + IO.println "scalar tampering and all exercised length/presence/dimension guards reject" + +private def family : Fin 2 → RingPCSGame.FamilyClaim := fun j => + if j.val = 0 then ⟨0, #[e 13, e 17], fun _ => 0⟩ + else ⟨4, #[e 19, e 23], fun _ => 0⟩ +private def points : Array RingPCSGame.PointClaim := + #[.point 0 #[e 29, e 31] 0, .strided 4 1 1 #[e 37] 0] +private def seed : RingPCSGame.Prefix := (⟨3, 1, 0⟩, fun i => e (i.val + 2)) + +#eval do + let ch := challenges (e 7) (e 11) + let weight := (CausalGame.batchClaims 8 (RingPCSGame.transformedClaims 8 family points seed) (e 41)).weight + let target := dot (witness.map E.ofK) weight + let (root, proof) ← match Protocol.prove config ch witness weight target with + | .ok result => pure result + | .error message => throw (IO.userError s!"full caller prover: {message}") + expectOk "full caller dense" (Protocol.verify config ch 2 root weight target proof) + expectOk "full caller source" (sourceNativeVerify family points seed (e 41) config ch 2 target + (WHIRPhysicalErasure.eraseOracles proof)) + IO.println "full source ring family + ordinary/strided points: scalar-only verifier accepts" + let honestPoints := points.set! 0 (.point 0 #[e 29, e 31] (target.scale (kinv 41))) + let scalarTarget := WHIRNativeArithmetic.initialClaim family honestPoints seed (e 41) + unless scalarTarget == target do + throw (IO.userError "scalar initial claim disagrees with honest witness target") + let projected := (CausalGame.batchClaims 0 + (RingPCSGame.transformedClaims 0 family honestPoints seed) (e 41)).value + unless scalarTarget == projected do + throw (IO.userError "scalar initial claim disagrees with width-independent dense projection") + expectOk "full source initial/final arithmetic" + (sourceVerify family honestPoints seed (e 41) config ch 2 (WHIRPhysicalErasure.eraseOracles proof)) + IO.println "source-computed initial claim and final weight: full verifier accepts" + +#print axioms WHIRNativeArithmetic.nativeVerify_refines +#print axioms WHIRNativeArithmetic.sourceNativeVerify_refines +#print axioms WHIRNativeArithmetic.verifyLevel_refines +#print axioms WHIRNativeErasure.nativeVerify_erased +#print axioms WHIRNativeArithmetic.initialClaim_eq_batch_value +#print axioms WHIRNativeArithmetic.sourceVerify_refines + +end Whir.WHIRNativeArithmeticRegression diff --git a/verification/whir/Whir/WHIRNativeErasure.lean b/verification/whir/Whir/WHIRNativeErasure.lean new file mode 100644 index 000000000..44da92a67 --- /dev/null +++ b/verification/whir/Whir/WHIRNativeErasure.lean @@ -0,0 +1,51 @@ +import Whir.WHIRNativeArithmetic +import Whir.WHIRPhysicalErasure + +/-! Native scalar arithmetic observes commitment presence but never the embedded ghost oracle. Erasing it preserves the exact result, including every error branch and actual query-row computation. -/ +namespace Whir.WHIRNativeErasure +open Concrete Protocol WHIRPhysicalErasure WHIRNativeArithmetic + +@[simp] theorem eraseLevel_default : eraseLevel default = default := rfl + +@[simp] theorem getElem!_eraseLevel (levels : Array LevelProof) (i : Nat) : + (levels.map eraseLevel)[i]! = eraseLevel levels[i]! := by + by_cases h : i < levels.size + · simp only [getElem!_pos, Array.size_map, h, Array.getElem_map] + · rw [getElem!_neg (levels.map eraseLevel) i (by simpa using h), getElem!_neg levels i h] + rfl + +@[simp] theorem foldBlock_erase (cs : LevelChallenges) (p : LevelProof) (s : State) : + foldBlock cs (eraseLevel p) s = foldBlock cs p s := rfl + +@[simp] theorem oodBatch_erase (cs : LevelChallenges) (p : LevelProof) (s : State) : + oodBatch cs (eraseLevel p) s = oodBatch cs p s := rfl + +@[simp] theorem queryBatch_erase (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : State × E) : + queryBatch n i cs (eraseLevel p) qs s = queryBatch n i cs p qs s := rfl + +theorem verifyLevel_erase (c : Config) (ch : Challenges) (proof : Opening) (i : Nat) (s : State) : + WHIRNativeArithmetic.verifyLevel c ch (eraseOracles proof) i s = + WHIRNativeArithmetic.verifyLevel c ch proof i s := by + simp only [WHIRNativeArithmetic.verifyLevel, eraseOracles, getElem!_eraseLevel] + simp only [foldBlock_erase, oodBatch_erase, queryBatch_erase] + simp only [eraseLevel, Option.isSome_map] + rfl + +theorem closeTail_erase (ch : Challenges) (proof : Opening) (s : State) : + closeTail ch (eraseOracles proof) s = closeTail ch proof s := rfl + +theorem nativeVerify_erased (c : Config) (ch : Challenges) (lanes : Nat) (initialClaim : E) + (callerAt : Array E → E) (proof : Opening) : + nativeVerify c ch lanes initialClaim callerAt (eraseOracles proof) = + nativeVerify c ch lanes initialClaim callerAt proof := by + have levels : WHIRNativeArithmetic.verifyLevel c ch (eraseOracles proof) = + WHIRNativeArithmetic.verifyLevel c ch proof := by + funext i s + exact verifyLevel_erase c ch proof i s + simp only [nativeVerify] + simp only [levels, closeTail_erase] + simp only [eraseOracles, Array.size_map] + rfl + +end Whir.WHIRNativeErasure diff --git a/verification/whir/Whir/WHIRNativeGuards.lean b/verification/whir/Whir/WHIRNativeGuards.lean new file mode 100644 index 000000000..d2f7e5df1 --- /dev/null +++ b/verification/whir/Whir/WHIRNativeGuards.lean @@ -0,0 +1,250 @@ +import Whir.TapeValidity + +/-! Guard facts extracted from the existing imperative validators, for arbitrary +challenge arrays. OOD points belong to the next level, exactly as in the validator. -/ +namespace Whir.WHIRNativeGuards +open Concrete Protocol CausalGame + +/-- Dimension on entry to level `i`, before its folds. -/ +def before (c : Config) (i : Nat) : Nat := + c.logN - (c.folds.toList.take i).sum + +theorem before_step (c : Config) (i : Nat) (hi : i < c.folds.size) : + before c i - c.folds[i]! = remaining c i := by + simp [before, remaining, List.take_add_one, getElem?_pos, getElem!_pos, hi, + Nat.sub_sub] + +/-- Every configuration guard used by one loop iteration. -/ +def ConfigLevel (c : Config) (i : Nat) : Prop := + 0 < c.folds[i]! ∧ c.folds[i]! < before c i ∧ + 0 < c.rates[i]! ∧ 0 < c.queries[i]! ∧ + remaining c i + c.rates[i]! < 64 + +private def configStep (c : Config) (i : Nat) (s : Option Bool × Nat) : + Id (ForInStep (Option Bool × Nat)) := do + let n := s.2 + if c.folds[i]! == 0 || c.folds[i]! >= n || c.rates[i]! == 0 || c.queries[i]! == 0 then + return .done (some false, n) + let n := n - c.folds[i]! + if n + c.rates[i]! >= 64 then return .done (some false, n) + return .yield (none, n) + +private theorem config_loop (c : Config) (len start : Nat) + (hr : start + len ≤ c.folds.size) + (h : ((forIn (List.range' start len) (none, before c start) + (configStep c)).run.1).getD true = true) : + ∀ i, start ≤ i → i < start + len → ConfigLevel c i := by + induction len generalizing start with + | zero => intro i hlo hhi; omega + | succ len ih => + have hi : start < c.folds.size := by omega + simp only [List.range'_succ, List.forIn_cons, configStep] at h + split at h + · simp at h + · rename_i hg + split at h + · simp at h + · rename_i hd + have hs : before c start - c.folds[start]! = before c (start + 1) := + before_step c start hi + simp only [pure_bind] at h + rw [hs] at h + intro i hlo hhi + by_cases he : i = start + · subst i + simp only [Bool.or_eq_true, beq_iff_eq, decide_eq_true_eq, not_or] at hg + dsimp [ConfigLevel] + rw [← before_step c start hi] + omega + · exact ih (start + 1) (by omega) h i (by omega) (by omega) + +/-- The actual configuration header checks, without additional acceptance guards. -/ +theorem config_header (c : Config) (hc : c.valid = true) : + 2 ≤ c.folds.size ∧ c.rates.size = c.folds.size ∧ + c.queries.size = c.folds.size ∧ c.oodCounts.size = c.folds.size ∧ + c.oodCounts[0]! = 0 := by + unfold Config.valid at hc + dsimp only [Id.run] at hc + split at hc + · simp at hc + · rename_i h + simp only [Bool.or_eq_true, decide_eq_true_eq, bne_iff_ne, not_or, not_not] at h + omega + +/-- Positive folds/rates/query counts, no subtraction underflow, and depth bound. -/ +theorem config_level (c : Config) (hc : c.valid = true) + (i : Nat) (hi : i < c.folds.size) : ConfigLevel c i := by + unfold Config.valid at hc + dsimp only [Id.run] at hc + split at hc + · simp at hc + · simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one] at hc + have hloop : ((forIn (List.range' 0 c.folds.size) (none, before c 0) + (configStep c)).run.1).getD true = true := by + have hz : before c 0 = c.logN := by simp [before] + rw [hz] + cases he : (forIn (List.range' 0 c.folds.size) (none, c.logN) (configStep c)).run.1 with + | none => simp + | some b => + unfold configStep at he + dsimp only [Id.run, Bind.bind, Pure.pure] at he hc + rw [he] at hc + exact hc + exact config_loop c c.folds.size 0 (by omega) hloop i (by omega) (by omega) + +/-- Saved shapes and sampler success checked at an arbitrary challenge level. -/ +def ChallengeLevel (c : Config) (ch : Challenges) (i : Nat) : Prop := + ch.levels[i]!.folds.size = c.folds[i]! ∧ + ch.levels[i]!.oodPoints.size = oodCount c i ∧ + (∀ p ∈ ch.levels[i]!.oodPoints, p.size = remaining c i) ∧ + (deriveQueries (remaining c i + c.rates[i]!) c.queries[i]! + ch.levels[i]!.querySqueezes).isNone = false + +private def challengeStep (c : Config) (ch : Challenges) (i : Nat) + (s : Option Bool × Nat) : Id (ForInStep (Option Bool × Nat)) := do + let n := s.2 - c.folds[i]! + let l := ch.levels[i]! + let count := if i + 1 < c.folds.size then c.oodCounts[i + 1]! else 0 + if l.folds.size != c.folds[i]! || l.oodPoints.size != count then + return .done (some false, n) + if !(l.oodPoints.all fun p => p.size == n) then return .done (some false, n) + if (deriveQueries (n + c.rates[i]!) c.queries[i]! l.querySqueezes).isNone then + return .done (some false, n) + return .yield (none, n) + +private theorem challenge_loop (c : Config) (ch : Challenges) (len start : Nat) + (hr : start + len ≤ c.folds.size) + (h : let result := (forIn (List.range' start len) (none, before c start) + (challengeStep c ch)).run + result.1.getD (ch.tail.size == result.2) = true) : + ch.tail.size = before c (start + len) ∧ + ∀ i, start ≤ i → i < start + len → ChallengeLevel c ch i := by + induction len generalizing start with + | zero => + simp at h + exact ⟨h, by intro i hlo hhi; omega⟩ + | succ len ih => + have hi : start < c.folds.size := by omega + simp only [List.range'_succ, List.forIn_cons, challengeStep] at h + rw [← oodCount] at h + split at h + · simp at h + · rename_i hg + split at h + · simp at h + · rename_i hp + split at h + · simp at h + · rename_i hq + have hs : before c start - c.folds[start]! = before c (start + 1) := + before_step c start hi + simp only [pure_bind] at h + rw [hs] at h + have ht := ih (start + 1) (by omega) h + refine ⟨by simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using ht.1, ?_⟩ + intro i hlo hhi + by_cases he : i = start + · subst i + simp only [Bool.or_eq_true, bne_iff_ne, not_or, not_not] at hg + have ha : (ch.levels[start]!.oodPoints.all + fun p => p.size == before c start - c.folds[start]!) = true := by + simpa using hp + have hpoints : ∀ p ∈ ch.levels[start]!.oodPoints, + p.size = before c start - c.folds[start]! := by + intro p hmem + obtain ⟨j, hj, rfl⟩ := Array.mem_iff_getElem.mp hmem + exact beq_iff_eq.mp ((Array.all_eq_true.mp ha) j hj) + refine ⟨hg.1, hg.2, ?_, ?_⟩ + · simpa only [before_step c start hi] using hpoints + · simpa only [before_step c start hi, Bool.not_eq_true] using hq + · exact ht.2 i (by omega) (by omega) + +/-- All shape facts follow from `Challenges.valid` for arbitrary challenge values. -/ +theorem challenges_guards (c : Config) (ch : Challenges) (h : ch.valid c = true) : + c.valid = true ∧ ch.levels.size = c.folds.size ∧ + ch.tail.size = c.logN - c.folds.toList.sum ∧ + ∀ i, i < c.folds.size → ChallengeLevel c ch i := by + unfold Challenges.valid at h + dsimp only [Id.run] at h + split at h + · simp at h + · rename_i hh + simp only [Bool.or_eq_true, Bool.not_eq_true, + bne_iff_ne, not_or, not_not] at hh + refine ⟨by simpa using hh.1, hh.2, ?_⟩ + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one] at h + have hl : let result := (forIn (List.range' 0 c.folds.size) (none, before c 0) + (challengeStep c ch)).run + result.1.getD (ch.tail.size == result.2) = true := by + have hz : before c 0 = c.logN := by simp [before] + rw [hz] + unfold challengeStep + dsimp only [Id.run, Bind.bind, Pure.pure] at h ⊢ + exact h + have ht := challenge_loop c ch c.folds.size 0 (by omega) hl + refine ⟨?_, fun i hi => ht.2 i (by omega) (by omega)⟩ + simpa [before, ← Array.length_toList] using ht.1 + +/-- Each used configuration array index is in bounds. -/ +theorem config_indices (c : Config) (hc : c.valid = true) + (i : Nat) (hi : i < c.folds.size) : + i < c.rates.size ∧ i < c.queries.size ∧ i < c.oodCounts.size := by + have hs := config_header c hc + rw [hs.2.1, hs.2.2.1, hs.2.2.2.1] + exact ⟨hi, hi, hi⟩ + +/-- The next-level OOD count is read only at an in-bounds index. -/ +theorem config_next_ood_index (c : Config) (hc : c.valid = true) + (i : Nat) (hi : i + 1 < c.folds.size) : + i + 1 < c.oodCounts.size := + (config_indices c hc (i + 1) hi).2.2 + +theorem config_remaining (c : Config) (hc : c.valid = true) + (i : Nat) (hi : i < c.folds.size) : + 0 < remaining c i ∧ remaining c i + c.folds[i]! = before c i := by + have hk := (config_level c hc i hi).2.1 + rw [← before_step c i hi] + omega + +theorem challenges_config (c : Config) (ch : Challenges) (h : ch.valid c = true) : + c.valid = true := (challenges_guards c ch h).1 + +theorem challenges_levels (c : Config) (ch : Challenges) (h : ch.valid c = true) : + ch.levels.size = c.folds.size := (challenges_guards c ch h).2.1 + +theorem challenges_tail (c : Config) (ch : Challenges) (h : ch.valid c = true) : + ch.tail.size = c.logN - c.folds.toList.sum := (challenges_guards c ch h).2.2.1 + +theorem challenges_level (c : Config) (ch : Challenges) (h : ch.valid c = true) + (i : Nat) (hi : i < c.folds.size) : ChallengeLevel c ch i := + (challenges_guards c ch h).2.2.2 i hi + +theorem challenges_folds (c : Config) (ch : Challenges) (h : ch.valid c = true) + (i : Nat) (hi : i < c.folds.size) : + ch.levels[i]!.folds.size = c.folds[i]! := (challenges_level c ch h i hi).1 + +theorem challenges_ood_count (c : Config) (ch : Challenges) (h : ch.valid c = true) + (i : Nat) (hi : i < c.folds.size) : + ch.levels[i]!.oodPoints.size = oodCount c i := (challenges_level c ch h i hi).2.1 + +theorem challenges_ood_point (c : Config) (ch : Challenges) (h : ch.valid c = true) + (i : Nat) (hi : i < c.folds.size) (p : Array E) (hp : p ∈ ch.levels[i]!.oodPoints) : + p.size = remaining c i := (challenges_level c ch h i hi).2.2.1 p hp + +theorem challenges_queries (c : Config) (ch : Challenges) (h : ch.valid c = true) + (i : Nat) (hi : i < c.folds.size) : + (deriveQueries (remaining c i + c.rates[i]!) c.queries[i]! + ch.levels[i]!.querySqueezes).isNone = false := + (challenges_level c ch h i hi).2.2.2 + +/-- A malformed saved point cannot pass the actual challenge validator. -/ +theorem reject_ood_point (c : Config) (ch : Challenges) + (i : Nat) (hi : i < c.folds.size) (p : Array E) (hp : p ∈ ch.levels[i]!.oodPoints) + (hsize : p.size ≠ remaining c i) : ch.valid c = false := by + cases h : ch.valid c with + | false => rfl + | true => exact False.elim (hsize (challenges_ood_point c ch h i hi p hp)) + +end Whir.WHIRNativeGuards diff --git a/verification/whir/Whir/WHIRObservableAllocations.lean b/verification/whir/Whir/WHIRObservableAllocations.lean new file mode 100644 index 000000000..1f16aacc8 --- /dev/null +++ b/verification/whir/Whir/WHIRObservableAllocations.lean @@ -0,0 +1,364 @@ +import Whir.WHIRPublicBackfill + +/-! Chronological allocation replay from executed public requests and physical +completion records, without an adversary program, private coins, or raw table. -/ +namespace Whir.WHIRObservableAllocations +open TypedOracleCompiler TypedFiatShamirGame RawOracleCoupling +open RawOracleCoupling.Concrete FiatShamirGame DuplexModeGame +open RawWHIRKeys (Context Packet) +open WHIRPublicBackfill WHIRModeFinal + +section Replay +universe u w +variable {Key : Type u} {Answer : Key → Type u} [DecidableEq Key] +variable (deps : Key → List Key) + +/-- An unavailable public answer remains an explicit failure. Existing entries +are reused; only misses generate a chronological allocation annotation. -/ +def replayKeys (source : Cache Key Answer) : List Key → Cache Key Answer → + Option (Cache Key Answer × List (Sigma (AnnotatedAnswer (Answer := Answer)))) + | [], cache => some (cache,[]) + | key :: keys, cache => + match cache key with + | some _ => replayKeys source keys cache + | none => (source key).bind fun answer => + (replayKeys source keys (put cache key answer)).map fun result => + (result.1,⟨(key,dependencyHistory deps cache key),answer⟩ :: result.2) + +def tableReplay (table : (key : Key) → Answer key) : List Key → Cache Key Answer → + Cache Key Answer × List (Sigma (AnnotatedAnswer (Answer := Answer))) + | [], cache => (cache,[]) + | key :: keys, cache => + match cache key with + | some _ => tableReplay table keys cache + | none => + let result := tableReplay table keys (put cache key (table key)) + (result.1,⟨(key,dependencyHistory deps cache key),table key⟩ :: result.2) + +theorem replayKeys_of_hits (source : Cache Key Answer) (table : (key : Key) → Answer key) + (keys : List Key) (cache : Cache Key Answer) + (covered : ∀ key ∈ keys, source key = some (table key)) : + replayKeys deps source keys cache = some (tableReplay deps table keys cache) := by + induction keys generalizing cache with + | nil => rfl + | cons key keys ih => + simp only [replayKeys, tableReplay] + cases hit : cache key with + | some answer => exact ih cache (fun k h => covered k (List.mem_cons_of_mem _ h)) + | none => + simp only [covered key (by simp), Option.bind_some, + ih _ (fun k h => covered k (List.mem_cons_of_mem _ h)), Option.map_some] + +def Consistent (table : (key : Key) → Answer key) (cache : Cache Key Answer) : Prop := + ∀ key answer, cache key = some answer → table key = answer + +theorem Consistent.put {table : (key : Key) → Answer key} {cache : Cache Key Answer} + (consistent : Consistent table cache) (key : Key) : + Consistent table (put cache key (table key)) := by + intro k answer hit + by_cases same : k = key + · subst k + simpa only [put_self, Option.some.injEq] using hit + · exact consistent k answer (by simpa only [put_other _ _ _ _ same] using hit) + +/-- The memo compiler follows exactly the executed path, including cache hits +whose answers select the continuation. No off-path continuation is inspected. -/ +theorem execute_relabelMemo {R : Type w} {n} + (table : (key : Key) → Answer key) (p : Sampling Key Answer R n) + (cache : Cache Key Answer) (consistent : Consistent table cache) : + Sampling.execute (fun key : Annotated (Answer := Answer) => table key.1) + (relabelMemo (dependencyLabels deps) p cache) = + ((Sampling.eval table p,(tableReplay deps table ((Sampling.execute table p).2.map Sigma.fst) cache).1), + (tableReplay deps table ((Sampling.execute table p).2.map Sigma.fst) cache).2) := by + induction p generalizing cache with + | ret result => rfl + | draw key next ih => + cases hit : cache key with + | some answer => + have equal := consistent key answer hit + simp only [relabelMemo, hit, Sampling.execute_pad, Sampling.execute, Sampling.eval, + List.map_cons, tableReplay] + rw [equal] + exact ih answer cache consistent + | none => + simp only [relabelMemo, hit, Sampling.execute, Sampling.eval, dependencyLabels, + Equiv.refl_apply, List.map_cons, tableReplay] + have step := ih (table key) (put cache key (table key)) (consistent.put key) + simp only [dependencyLabels] at step + rw [step] + +omit [DecidableEq Key] in +theorem execute_answers {R : Type w} {n} (table : (key : Key) → Answer key) + (p : Sampling Key Answer R n) : + ∀ entry ∈ (Sampling.execute table p).2, table entry.1 = entry.2 := by + induction p with + | ret => intro entry member; cases member + | draw key next ih => + intro entry member + rcases List.mem_cons.mp member with equal | member + · subst entry; rfl + · exact ih (table key) entry member + +theorem eval_relabelMemo {R : Type w} {n} (table : (key : Key) → Answer key) + (p : Sampling Key Answer R n) (cache : Cache Key Answer) : + Sampling.eval (fun key : Annotated (Answer := Answer) => table key.1) + (relabelMemo (dependencyLabels deps) p cache) = Sampling.eval table (memo p cache) := by + induction p generalizing cache with + | ret => rfl + | draw key next ih => + cases hit : cache key with + | some answer => simpa only [relabelMemo, memo, hit, Sampling.eval_pad] using ih answer cache + | none => + simpa only [relabelMemo, memo, hit, Sampling.eval, dependencyLabels, Equiv.refl_apply] + using ih (table key) (put cache key (table key)) + +end Replay + +private instance (ctx : Context) (Q : Nat) : DecidableEq (GroupKey ctx Q) := inferInstance + +/-- Every recognized request completes its real caller outputs and canonical +packet ancestors. Off-image requests have one independent garbage group. -/ +def requestKeys (ctx : Context) (Q : Nat) (raw : RawKey Q) : List (GroupKey ctx Q) := + match recognized : RawWHIRKeys.recognize ctx Q raw with + | some pos => completionKeys ctx Q pos.1 + | none => [.inr ⟨raw,recognized⟩] + +def finalKeys (ctx : Context) (Q : Nat) : Option (Packet ctx Q) → List (GroupKey ctx Q) + | none => [] + | some packet => completionKeys ctx Q packet + +def allocationRequests (ctx : Context) (Q : Nat) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) : List (GroupKey ctx Q) := + requests.flatMap (requestKeys ctx Q) ++ finalKeys ctx Q final + +/-- The executable observer has no access to the source program or its private +coins. Completed records are explicit physical public-output arguments. -/ +def observe (ctx : Context) (Q : Nat) (answers : List (RawKey Q × Digest32)) + (final : Option (Packet ctx Q)) (records : List (Record ctx Q)) : + Option (PublicCache ctx Q × List (Sigma (AllocationAnswer ctx Q))) := + replayKeys (dependencyKeys ctx Q) (observableCache ctx Q answers records) + (allocationRequests ctx Q (answers.map Prod.fst) final) (fun _ => none) + +theorem warm_keys (ctx : Context) (Q : Nat) + (table : (key : GroupKey ctx Q) → GroupAnswer ctx Q key) (packets : List (Packet ctx Q)) : + (Sampling.execute table ((partition ctx Q).warm packets)).2.map Sigma.fst = packets.map Sum.inl := by + induction packets with + | nil => rfl + | cons packet rest ih => simp only [Partition.warm, Sampling.execute, List.map_cons, ih] + +theorem warmCaller_keys (ctx : Context) (Q : Nat) + (table : (key : GroupKey ctx Q) → GroupAnswer ctx Q key) + (calls : List (partition ctx Q).Garbage) : + (Sampling.execute table ((partition ctx Q).warmCaller calls)).2.map Sigma.fst = calls.map Sum.inr := by + induction calls with + | nil => rfl + | cons raw rest ih => simp only [Partition.warmCaller, Sampling.execute, List.map_cons, ih] + +theorem completePacket_keys (ctx : Context) (Q : Nat) + (table : (key : GroupKey ctx Q) → GroupAnswer ctx Q key) (packet : Packet ctx Q) : + (Sampling.execute table ((partition ctx Q).completePacket (schedule ctx Q) (callerPlan ctx Q) packet)).2.map + Sigma.fst = completionKeys ctx Q packet := by + simp only [Partition.completePacket, Sampling.execute_pad, Sampling.execute_bind, + Sampling.execute, List.map_append, warmCaller_keys, warm_keys, List.map_cons, List.map_nil] + simp only [completionKeys, dependencyKeys, Partition.dependencies, List.append_assoc] + +theorem request_keys (ctx : Context) (Q : Nat) + (table : (key : GroupKey ctx Q) → GroupAnswer ctx Q key) (raw : RawKey Q) : + (Sampling.execute table ((partition ctx Q).request (schedule ctx Q) (callerPlan ctx Q) raw)).2.map + Sigma.fst = requestKeys ctx Q raw := by + unfold Partition.request requestKeys + split + · rename_i pos recognized + simp only [Sampling.execute_pad, Sampling.execute_bind, Sampling.execute, + List.append_nil, completePacket_keys] + split + · rename_i other h + have equal : other = pos := Option.some.inj (h.symm.trans recognized) + subst other + rfl + · rename_i h + have impossible := h.symm.trans recognized + cases impossible + · rename_i recognized + simp only [Sampling.execute_pad, Sampling.execute, List.map_cons, List.map_nil] + split + · rename_i other h + have impossible := h.symm.trans recognized + cases impossible + · rfl + +theorem program_keys (ctx : Context) (Q : Nat) {R : Type} {n} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : + (Sampling.execute ((partition ctx Q).split table) + ((partition ctx Q).program (schedule ctx Q) (callerPlan ctx Q) final p)).2.map Sigma.fst = + allocationRequests ctx Q ((Sampling.execute table p).2.map Sigma.fst) (final (Sampling.eval table p)) := by + induction p with + | ret result => + simp only [Partition.program, Sampling.execute, Sampling.eval, List.map_nil, + allocationRequests, List.flatMap_nil, List.nil_append] + split <;> simp_all only [Sampling.execute_pad, Sampling.execute_bind, Sampling.execute, + List.append_nil, completePacket_keys, finalKeys, List.map_nil] + | draw raw next ih => + simp only [Partition.program, Sampling.execute_pad, Sampling.execute_bind, + Partition.eval_request, Partition.join_split, Sampling.execute, Sampling.eval, + List.map_append, request_keys, ih, List.map_cons, allocationRequests, List.flatMap_cons, + List.append_assoc] + +theorem requestKeys_some (ctx : Context) (Q : Nat) (raw : RawKey Q) + (pos : RawWHIRKeys.Position ctx Q) (recognized : RawWHIRKeys.recognize ctx Q raw = some pos) : + requestKeys ctx Q raw = completionKeys ctx Q pos.1 := by + unfold requestKeys + split + · rename_i other h + have equal : other = pos := Option.some.inj (h.symm.trans recognized) + subst other + rfl + · rename_i h + have impossible := h.symm.trans recognized + cases impossible + +theorem requestKeys_none (ctx : Context) (Q : Nat) (raw : RawKey Q) + (recognized : RawWHIRKeys.recognize ctx Q raw = none) : + requestKeys ctx Q raw = [.inr ⟨raw,recognized⟩] := by + unfold requestKeys + split + · rename_i other h + have impossible := h.symm.trans recognized + cases impossible + · rfl + +/-- Coverage is derived from every executed request and the selected completion, +not assumed as a property of the reconstructed state. -/ +theorem observable_covered (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (final : Option (Packet ctx Q)) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) : + ∀ key ∈ allocationRequests ctx Q (answers.map Prod.fst) final, + observableCache ctx Q answers + (idealRecords ctx Q table (selections ctx Q (answers.map Prod.fst) final)) key = + some ((partition ctx Q).split table key) := by + intro key member + rcases List.mem_append.mp member with request | terminal + · obtain ⟨raw,requested,member⟩ := List.mem_flatMap.mp request + cases recognized : RawWHIRKeys.recognize ctx Q raw with + | some pos => + rw [requestKeys_some ctx Q raw pos recognized] at member + exact observableCache_request ctx Q table answers _ final consistent raw requested pos recognized key member + | none => + rw [requestKeys_none ctx Q raw recognized] at member + have equal : key = .inr ⟨raw,recognized⟩ := List.mem_singleton.mp member + subst key + obtain ⟨answer,observed,same⟩ := List.mem_map.mp requested + have rawEq : answer.1 = raw := same + have hit := observableCache_garbage ctx Q table answers + (selections ctx Q (answers.map Prod.fst) final) consistent ⟨raw,recognized⟩ answer.2 + (by simpa only [← rawEq] using observed) + exact hit + · cases final with + | none => cases terminal + | some packet => + exact observableCache_final ctx Q table answers _ packet consistent key terminal + +def rawAnswers (Q : Nat) {R : Type} {n} (table : RawKey Q → Digest32) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : List (RawKey Q × Digest32) := + (Sampling.execute table p).2.map (fun entry => (entry.1,entry.2)) + +theorem rawAnswers_consistent (Q : Nat) {R : Type} {n} (table : RawKey Q → Digest32) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : + ∀ answer ∈ rawAnswers Q table p, table answer.1 = answer.2 := by + intro answer member + obtain ⟨entry,hm,rfl⟩ := List.mem_map.mp member + exact execute_answers table p entry hm + +theorem rawAnswers_keys (Q : Nat) {R : Type} {n} (table : RawKey Q → Digest32) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : + (rawAnswers Q table p).map Prod.fst = (Sampling.execute table p).2.map Sigma.fst := by + simp only [rawAnswers, List.map_map, Function.comp_def] + +def allocationOracle (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (key : AllocationKey ctx Q) : AllocationAnswer ctx Q key := + (partition ctx Q).split table key.1 + +/-- Exact chronological keys, full group answers, and final cache are functions +of the executed raw request path and final selection, not off-path code. -/ +theorem compile_execution (ctx : Context) (Q : Nat) {R : Type} {n} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : + Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p) = + let replay := tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) + (allocationRequests ctx Q (rawAnswers Q table p |>.map Prod.fst) (final (Sampling.eval table p))) + (fun _ => none) + ((Sampling.eval table p,replay.1),replay.2) := by + unfold RawOracleCoupling.Concrete.compile allocationOracle + rw [execute_relabelMemo (dependencyKeys ctx Q) _ _ _ (by intro key answer h; cases h)] + simp only [program_keys, Partition.eval_program, Partition.join_split, rawAnswers_keys] + +/-- Public replay recovers the complete compiler allocation transcript and its +final cache. Actual executed answers provide consistency, and physical completion +records provide coverage; neither condition is a new coupling assumption. -/ +theorem observe_execution (ctx : Context) (Q : Nat) {R : Type} {n} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : + observe ctx Q (rawAnswers Q table p) (final (Sampling.eval table p)) + (idealRecords ctx Q table (selections ctx Q ((rawAnswers Q table p).map Prod.fst) + (final (Sampling.eval table p)))) = + some ((Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p)).1.2, + (Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p)).2) := by + unfold observe + rw [replayKeys_of_hits _ _ ((partition ctx Q).split table) _ _ + (observable_covered ctx Q table _ _ (rawAnswers_consistent Q table p))] + rw [compile_execution] + +theorem compile_cache (ctx : Context) (Q : Nat) {R : Type} {n} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : + (Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p)).1 = + tableExecution ctx Q final p table := by + rw [Sampling.execute_value] + exact eval_relabelMemo (dependencyKeys ctx Q) _ _ _ + +theorem observe_tableExecution (ctx : Context) (Q : Nat) {R : Type} {n} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) : + observe ctx Q (rawAnswers Q table p) (final (Sampling.eval table p)) + (idealRecords ctx Q table (selections ctx Q ((rawAnswers Q table p).map Prod.fst) + (final (Sampling.eval table p)))) = + some ((tableExecution ctx Q final p table).2, + (Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p)).2) := by + rw [observe_execution, compile_cache] + +/-- Distinct adaptive programs, result types, and bounds can be substituted +when their executed raw paths and selected terminal packets agree. -/ +theorem compile_path_congr (ctx : Context) (Q : Nat) {R S : Type} {n m} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (otherFinal : S → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) + (other : Sampling (RawKey Q) (fun _ => Digest32) S m) + (path : (rawAnswers Q table p).map Prod.fst = (rawAnswers Q table other).map Prod.fst) + (selected : final (Sampling.eval table p) = otherFinal (Sampling.eval table other)) : + ((Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p)).1.2, + (Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p)).2) = + ((Sampling.execute (allocationOracle ctx Q table) (compile ctx Q otherFinal other)).1.2, + (Sampling.execute (allocationOracle ctx Q table) (compile ctx Q otherFinal other)).2) := by + simp only [compile_execution, path, selected] + +/-- The same reconstruction theorem directly on the physically executed +completion program. Its records are derived by `runIdeal`, not supplied by a +cache-coverage or state-equality premise. -/ +theorem observe_backfill (ctx : Context) (Q : Nat) {R Out Seed State : Type} {n} + (sim : Simulator Q Seed State) (table : RawKey Q → Digest32) (state : State) + (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) (output : Out) + (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (backfill ctx Q output ((rawAnswers Q table p).map Prod.fst) + (final (Sampling.eval table p)))) : + observe ctx Q (rawAnswers Q table p) (final (Sampling.eval table p)) + (runIdeal sim table ctx.iv state + (backfill ctx Q output ((rawAnswers Q table p).map Prod.fst) (final (Sampling.eval table p))) + remaining cap counted).view.result.records = + some ((tableExecution ctx Q final p table).2, + (Sampling.execute (allocationOracle ctx Q table) (compile ctx Q final p)).2) := by + rw [backfill_ideal_result] + exact observe_tableExecution ctx Q table final p + +end Whir.WHIRObservableAllocations diff --git a/verification/whir/Whir/WHIRPhysicalErasure.lean b/verification/whir/Whir/WHIRPhysicalErasure.lean new file mode 100644 index 000000000..825ddaa6d --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalErasure.lean @@ -0,0 +1,206 @@ +import Whir.WHIRPhysicalHistory + +/-! Erasure changes only ghost commitment oracles, never physical query rows or scalar parsing. The physical decoder retains all root, nonce, position and ancestor guards. -/ +namespace Whir.WHIRPhysicalErasure +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame (Digest32) +open WHIRHistory (Pending) + +def eraseReply : Reply → Reply + | .fold m next residual => .fold m (next.map fun _ => #[]) residual + | r => r + +def eraseLevel (level : LevelProof) : LevelProof := + {level with nextOracle := level.nextOracle.map fun _ => #[]} + +def eraseOracles (proof : Opening) : Opening := + {proof with levels := proof.levels.map eraseLevel} + +def zeroRoots : WHIRReplay.Roots := fun _ _ => #[] + +def eraseReplay {p : Profile} (r : WHIRReplay.Replay p) : WHIRReplay.Replay p := + {r with replies := r.replies.map eraseReply} + +def eraseStackReplay {p : Profile} {cap : Nat} (r : StackWHIRReplay.Replay p cap) : + StackWHIRReplay.Replay p cap := + {r with whir := eraseReplay r.whir} + +@[simp] theorem eraseReply_default : eraseReply default = default := rfl + +@[simp] theorem initialField_erase (r : Reply) : initialField (eraseReply r) = initialField r := by + cases r <;> rfl +@[simp] theorem foldField_erase (r : Reply) : foldField (eraseReply r) = foldField r := by + cases r <;> rfl +@[simp] theorem rootField_erase (r : Reply) : + rootField (eraseReply r) = (rootField r).map (fun _ => #[]) := by + cases r <;> rfl +@[simp] theorem residualField_erase (r : Reply) : residualField (eraseReply r) = residualField r := by + cases r <;> rfl +@[simp] theorem oodField_erase (r : Reply) : oodField (eraseReply r) = oodField r := by + cases r <;> rfl +@[simp] theorem rowsField_erase (r : Reply) : rowsField (eraseReply r) = rowsField r := by + cases r <;> rfl +@[simp] theorem introField_erase (r : Reply) : introField (eraseReply r) = introField r := by + cases r <;> rfl +@[simp] theorem tailField_erase (r : Reply) : tailField (eraseReply r) = tailField r := by + cases r <;> rfl + +@[simp] theorem getElem!_erase (answers : Array Reply) (i : Nat) : + (answers.map eraseReply)[i]! = eraseReply answers[i]! := by + by_cases h : i < answers.size + · simp only [getElem!_pos, Array.size_map, h, Array.getElem_map] + · rw [getElem!_neg (answers.map eraseReply) i (by simpa using h), + getElem!_neg answers i h] + rfl + +/-- All serialized scalars, including the explicit root digest, are unchanged. -/ +theorem replyScalars_erase {c : Config} (q : Coordinate c) (digest : Digest32) (r : Reply) : + WHIRHistory.replyScalars q digest (eraseReply r) = WHIRHistory.replyScalars q digest r := by + cases q <;> cases r <;> rfl + +theorem decodeReplyScalars_zero {c : Config} (q : Coordinate c) + (lookup : Digest32 → Oracle) (rows : Oracle) (xs : List E) : + WHIRHistory.decodeReplyScalars q (fun _ => #[]) rows xs = + (WHIRHistory.decodeReplyScalars q lookup rows xs).map eraseReply := by + cases q with + | initial => simp [WHIRHistory.decodeReplyScalars, Option.map_map, Function.comp_def, eraseReply] + | tail j => simp [WHIRHistory.decodeReplyScalars, Option.map_map, Function.comp_def, eraseReply] + | query i => simp [WHIRHistory.decodeReplyScalars, Option.map_map, Function.comp_def, eraseReply] + | ood i j => + cases xs with + | nil => rfl + | cons a xs => cases xs with + | nil => rfl + | cons b xs => cases xs with + | nil => rfl + | cons d xs => cases xs <;> rfl + | fold i j => + cases xs with + | nil => rfl + | cons a xs => cases xs with + | nil => rfl + | cons b rest => + simp only [WHIRHistory.decodeReplyScalars] + split + · split + · cases rest with + | nil => rfl + | cons r rest => cases rest with + | nil => rfl + | cons s rest => cases rest <;> + simp [Option.map_map, Function.comp_def, eraseReply] + · split <;> rfl + · split <;> rfl + +theorem parseReply_zero {c : Config} (q : Coordinate c) + (lookup : Digest32 → Oracle) (rows : Oracle) (bytes : List FiatShamirGame.Byte) : + WHIRHistory.parseReply q (fun _ => #[]) rows bytes = + (WHIRHistory.parseReply q lookup rows bytes).map eraseReply := by + unfold WHIRHistory.parseReply + cases WHIRHistory.parseExact (WHIRHistory.replyScalarCount q) bytes with + | none => rfl + | some xs => exact decodeReplyScalars_zero q lookup rows xs + +theorem checkReplies_erase (batches : List Batch) (answers : List Reply) : + checkReplies batches (answers.map eraseReply) = checkReplies batches answers := by + induction batches generalizing answers with + | nil => cases answers <;> rfl + | cons b bs ih => + cases answers with + | nil => cases b <;> rfl + | cons r rs => cases b <;> cases r <;> simp [checkReplies, eraseReply, ih] + +theorem decodedLevel_erase (c : Config) (ch : Challenges) (answers : Array Reply) (i : Nat) : + decodedLevel c ch (answers.map eraseReply) i = eraseLevel (decodedLevel c ch answers i) := by + simp only [decodedLevel, getElem!_erase, foldField_erase, rootField_erase, + oodField_erase, rowsField_erase, introField_erase, eraseLevel] + split <;> rfl + +theorem decodedOpening_erase (c : Config) (ch : Challenges) (answers : Array Reply) : + decodedOpening c ch (answers.map eraseReply) = eraseOracles (decodedOpening c ch answers) := by + simp [decodedOpening, eraseOracles, Array.map_ofFn, Function.comp_def, decodedLevel_erase] + +theorem opening_erase (c : Config) (ch : Challenges) (answers : Array Reply) : + opening c ch (answers.map eraseReply) = (opening c ch answers).map eraseOracles := by + simp only [opening, Array.toList_map, checkReplies_erase] + cases checkReplies (visibleBatches c E.zero ch) answers.toList <;> + simp [decodedOpening_erase, Except.map] + +theorem reply_zero {p : Profile} (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) + (q : Coordinate (config p)) (pending : Pending) : + WHIRPhysicalHistory.reply zeroRoots rows q pending = + (WHIRPhysicalHistory.reply roots rows q pending).map eraseReply := + decodeReplyScalars_zero q _ _ _ + +theorem step_zero {p : Profile} (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) + (r : WHIRReplay.Replay p) (q : Coordinate (config p)) (x : Sample q) (pending : Pending) : + WHIRPhysicalHistory.step zeroRoots rows (eraseReplay r) q x pending = + (WHIRPhysicalHistory.step roots rows r q x pending).map eraseReplay := by + unfold WHIRPhysicalHistory.step + rw [reply_zero roots] + simp [Option.map_map, Function.comp_def, eraseReplay, Array.map_push] + +theorem decodeHistory_zero (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) : + WHIRPhysicalHistory.decodeHistory p catalog zeroRoots rows s messages ancestors = + (WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors).map eraseReplay := by + induction messages generalizing ancestors with + | nil => rfl + | cons m messages ih => + cases messages with + | nil => + cases ancestors with + | nil => + simp only [WHIRPhysicalHistory.decodeHistory] + split + · cases catalog s <;> simp [eraseReplay] + · rfl + | cons a ancestors => rfl + | cons previous older => + cases ancestors with + | nil => rfl + | cons entry past => + rcases entry with ⟨previous',q,x⟩ + simp only [WHIRPhysicalHistory.decodeHistory] + split + · split + · split + · split + · split + · rw [ih] + cases WHIRPhysicalHistory.decodeHistory p catalog roots rows s (previous::older) past with + | none => rfl + | some before => exact step_zero roots rows before q x m + · rfl + · rfl + · rfl + · rfl + · rfl + +theorem decode_zero (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (key : WHIRReplay.Key p) : + WHIRPhysicalHistory.decode p catalog zeroRoots rows key = + (WHIRPhysicalHistory.decode p catalog roots rows key).map eraseReplay := + decodeHistory_zero p catalog roots rows _ _ _ + +theorem decodeStack_zero (p : Profile) (cap : Nat) (catalog : StackWHIRReplay.Catalog p cap) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (key : StackWHIRReplay.Key p) : + WHIRPhysicalHistory.decodeStack p cap catalog zeroRoots rows key = + (WHIRPhysicalHistory.decodeStack p cap catalog roots rows key).map eraseStackReplay := by + unfold WHIRPhysicalHistory.decodeStack + cases catalog key.statement with + | none => rfl + | some original => + cases StackWHIRReplay.initialSeed key.ancestors with + | none => rfl + | some initial => + change (WHIRPhysicalHistory.decode p (StackWHIRReplay.localCatalog original initial) zeroRoots rows + (StackWHIRReplay.projectKey key)).bind (fun whir => some ⟨original,initial,whir⟩) = + ((WHIRPhysicalHistory.decode p (StackWHIRReplay.localCatalog original initial) roots rows + (StackWHIRReplay.projectKey key)).bind (fun whir => some ⟨original,initial,whir⟩)).map eraseStackReplay + rw [decode_zero p _ roots] + cases WHIRPhysicalHistory.decode p (StackWHIRReplay.localCatalog original initial) roots rows + (StackWHIRReplay.projectKey key) <;> rfl + +end Whir.WHIRPhysicalErasure diff --git a/verification/whir/Whir/WHIRPhysicalHistory.lean b/verification/whir/Whir/WHIRPhysicalHistory.lean new file mode 100644 index 000000000..43f5f5f2f --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalHistory.lean @@ -0,0 +1,191 @@ +import Whir.StackWHIRReplay + +/-! Scalar-history reconstruction from actual counted Merkle opening rows. Query rows are supplied by the physical verifier, in sampled order, and are never synthesized by this decoder. Scalar, root, nonce, ancestor and position guards are the existing transport guards. Frozen root lookup reconstructs ghost next-oracle fields only; it is not native Merkle acceptance. Row dimensions and authentication belong to the physical opening checker. -/ +namespace Whir.WHIRPhysicalHistory +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame (Digest32) +open WHIRHistory (Pending) + +abbrev Rows := Nat → Oracle + +def reply {p : Profile} (roots : WHIRReplay.Roots) (rows : Rows) + (q : Coordinate (config p)) (pending : Pending) : Option Reply := + WHIRHistory.decodeReplyScalars q + (fun digest => roots digest (WHIRHistory.coordinateLevel q + 1)) + (match q with | .query i => rows i.val | _ => #[]) pending.scalars + +@[simp] theorem reply_query {p : Profile} (roots : WHIRReplay.Roots) (rows : Rows) + (i : Fin (config p).folds.size) (pending : Pending) : + reply roots rows (.query i) pending = + (WHIRHistory.decodeMessage pending.scalars).map (Reply.query (rows i.val)) := rfl + +theorem reply_fold_root {p : Profile} (roots : WHIRReplay.Roots) (rows : Rows) + (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) + (last : j.val + 1 = (config p).folds[i.val]!) (next : i.val + 1 < (config p).folds.size) + (a b r s : E) (nonce : Option (Nat × E)) : + reply roots rows (.fold i j) ⟨[a,b,r,s],nonce⟩ = + (ByteCodec.scalarsToHash (r,s)).map + (fun digest => .fold ⟨a,b⟩ (some (roots digest (i.val+1))) #[]) := by + simp [reply, WHIRHistory.decodeReplyScalars, WHIRHistory.coordinateLevel, last, next] + +def step {p : Profile} (roots : WHIRReplay.Roots) (rows : Rows) (r : WHIRReplay.Replay p) + (q : Coordinate (config p)) (x : Sample q) (pending : Pending) : Option (WHIRReplay.Replay p) := + (reply roots rows q pending).map (fun response => + ⟨r.statement,set q r.tape x,r.replies.push response⟩) + +theorem step_eq {p : Profile} (roots : WHIRReplay.Roots) (rows : Rows) (r : WHIRReplay.Replay p) + (q : Coordinate (config p)) (x : Sample q) (pending : Pending) + (agrees : match q,x with | .query i,x => rows i.val = WHIRReplay.queryRows r i x | _,_ => True) : + step roots rows r q x pending = WHIRReplay.step roots r q x pending := by + cases q with + | query i => simp only [step,WHIRReplay.step,reply,WHIRReplay.reply,agrees] + | initial => rfl + | fold i j => rfl + | ood i j => rfl + | tail j => rfl + +/-- Exact existing history guards; only the query-row source differs. -/ +def decodeHistory (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (rows : Rows) (s : Digest32) : + List Pending → List (Pending × Sigma (@Sample (config p))) → Option (WHIRReplay.Replay p) + | [], _ => none + | [m], [] => do + if m.scalars.isEmpty && m.nonce.isNone then + let statement ← catalog s + pure ⟨statement,WHIRReplay.zeroTape p,#[]⟩ + else none + | m :: previous :: older, (previous',⟨q,x⟩) :: past => do + if previous' = previous then + if q = WHIRReplay.query p (s,previous::older) then + if position q = older.length then + if position (WHIRReplay.query p (s,m::previous::older)) = older.length + 1 then + if WHIRReplay.nonceShape (WHIRReplay.query p (s,m::previous::older)) m then + let before ← decodeHistory p catalog roots rows s (previous::older) past + step roots rows before q x m + else none + else none + else none + else none + else none + | _, _ => none + +/-- Only recorded query answers and successfully parsed physical prefixes enter the agreement premise. This is literal equality of opened rows with frozen sampled rows, not an assumed decoder-correctness or soundness certificate. -/ +def RowsAgree (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (rows : Rows) (s : Digest32) (messages : List Pending) + (ancestors : List (Pending × Sigma (@Sample (config p)))) : Prop := + ∀ (k : Nat) (previous : Pending) (i : Fin (config p).folds.size) (x : Sample (.query i)) + (before : WHIRReplay.Replay p), + ancestors[k]? = some (previous,⟨.query i,x⟩) → + decodeHistory p catalog roots rows s (messages.drop (k+1)) (ancestors.drop (k+1)) = some before → + rows i.val = WHIRReplay.queryRows before i x + +theorem RowsAgree_tail {p : Profile} {catalog : WHIRReplay.Catalog p} {roots : WHIRReplay.Roots} + {rows : Rows} {s : Digest32} {m messages a ancestors} + (agree : RowsAgree p catalog roots rows s (m::messages) (a::ancestors)) : + RowsAgree p catalog roots rows s messages ancestors := by + intro k previous i x before entry parsed + apply agree (k+1) previous i x before + · simpa using entry + · simpa [Nat.add_assoc] using parsed + +theorem decodeHistory_eq (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (rows : Rows) (s : Digest32) (messages : List Pending) + (ancestors : List (Pending × Sigma (@Sample (config p)))) + (agree : RowsAgree p catalog roots rows s messages ancestors) : + decodeHistory p catalog roots rows s messages ancestors = + WHIRReplay.decodeHistory p catalog roots s messages ancestors := by + induction messages generalizing ancestors with + | nil => rfl + | cons m messages ih => + cases messages with + | nil => cases ancestors <;> rfl + | cons previous older => + cases ancestors with + | nil => rfl + | cons entry past => + rcases entry with ⟨previous',q,x⟩ + have priorEq := ih past (RowsAgree_tail agree) + simp only [decodeHistory,WHIRReplay.decodeHistory] + split + · split + · split + · split + · split + · rw [← priorEq] + cases parsed : decodeHistory p catalog roots rows s (previous::older) past with + | none => rfl + | some before => + apply step_eq + cases q with + | query i => exact agree 0 previous' i x before (by simp) (by simpa using parsed) + | initial => trivial + | fold i j => trivial + | ood i j => trivial + | tail j => trivial + · rfl + · rfl + · rfl + · rfl + · rfl + +def decode (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (rows : Rows) (key : WHIRReplay.Key p) : Option (WHIRReplay.Replay p) := + decodeHistory p catalog roots rows key.statement key.messages key.ancestors + +theorem decode_eq (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (rows : Rows) (key : WHIRReplay.Key p) + (agree : RowsAgree p catalog roots rows key.statement key.messages key.ancestors) : + decode p catalog roots rows key = WHIRReplay.decode p catalog roots key := + decodeHistory_eq p catalog roots rows key.statement key.messages key.ancestors agree + +theorem decodeHistory_success (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (rows : Rows) (s : Digest32) (messages : List Pending) + (ancestors : List (Pending × Sigma (@Sample (config p)))) (out : WHIRReplay.Replay p) + (agree : RowsAgree p catalog roots rows s messages ancestors) + (parsed : decodeHistory p catalog roots rows s messages ancestors = some out) : + WHIRReplay.decodeHistory p catalog roots s messages ancestors = some out := by + rwa [decodeHistory_eq p catalog roots rows s messages ancestors agree] at parsed + +/-- Preserve the full initial eight-scalar stack answer, then project its WHIR lambda exactly as the existing stack decoder does. -/ +def decodeStack (p : Profile) (cap : Nat) (catalog : StackWHIRReplay.Catalog p cap) + (roots : WHIRReplay.Roots) (rows : Rows) (key : StackWHIRReplay.Key p) : + Option (StackWHIRReplay.Replay p cap) := do + let original ← catalog key.statement + let initial ← StackWHIRReplay.initialSeed key.ancestors + let whir ← decode p (StackWHIRReplay.localCatalog original initial) roots rows + (StackWHIRReplay.projectKey key) + pure ⟨original,initial,whir⟩ + +def StackRowsAgree (p : Profile) (cap : Nat) (catalog : StackWHIRReplay.Catalog p cap) + (roots : WHIRReplay.Roots) (rows : Rows) (key : StackWHIRReplay.Key p) : Prop := + ∀ original initial, catalog key.statement = some original → + StackWHIRReplay.initialSeed key.ancestors = some initial → + RowsAgree p (StackWHIRReplay.localCatalog original initial) roots rows + key.statement key.messages (key.ancestors.map StackWHIRReplay.projectEntry) + +theorem decodeStack_eq (p : Profile) (cap : Nat) (catalog : StackWHIRReplay.Catalog p cap) + (roots : WHIRReplay.Roots) (rows : Rows) (key : StackWHIRReplay.Key p) + (agree : StackRowsAgree p cap catalog roots rows key) : + decodeStack p cap catalog roots rows key = StackWHIRReplay.decode p cap catalog roots key := by + unfold decodeStack StackWHIRReplay.decode + cases found : catalog key.statement with + | none => rfl + | some original => + cases seed : StackWHIRReplay.initialSeed key.ancestors with + | none => rfl + | some initial => + change (decode p (StackWHIRReplay.localCatalog original initial) roots rows + (StackWHIRReplay.projectKey key)).bind (fun whir => some (StackWHIRReplay.Replay.mk original initial whir)) = + (WHIRReplay.decode p (StackWHIRReplay.localCatalog original initial) roots + (StackWHIRReplay.projectKey key)).bind (fun whir => some (StackWHIRReplay.Replay.mk original initial whir)) + rw [decode_eq p (StackWHIRReplay.localCatalog original initial) roots rows + (StackWHIRReplay.projectKey key) (agree original initial found seed)] + +theorem decodeStack_success (p : Profile) (cap : Nat) (catalog : StackWHIRReplay.Catalog p cap) + (roots : WHIRReplay.Roots) (rows : Rows) (key : StackWHIRReplay.Key p) + (out : StackWHIRReplay.Replay p cap) (agree : StackRowsAgree p cap catalog roots rows key) + (parsed : decodeStack p cap catalog roots rows key = some out) : + StackWHIRReplay.decode p cap catalog roots key = some out := by + rwa [decodeStack_eq p cap catalog roots rows key agree] at parsed + +end Whir.WHIRPhysicalHistory diff --git a/verification/whir/Whir/WHIRPhysicalRows.lean b/verification/whir/Whir/WHIRPhysicalRows.lean new file mode 100644 index 000000000..5a6303b4a --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalRows.lean @@ -0,0 +1,93 @@ +import Whir.MerkleTransport + +/-! The native opening verifier hashes the full padded leaf, removes its leading +absent lanes, and leaves the occupied row in raw descending order. The WHIR +base-row fold performs the one reversal; extraction must not reverse twice. -/ +namespace Whir.WHIRPhysicalRows +open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments MerkleBinding + +noncomputable def compactBaseRow (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index leafWords lanes : Nat) : List K := + (baseRow hash snapshot root height index leafWords).drop (leafWords - lanes) + +noncomputable def compactBaseOracle (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows leafWords lanes : Nat) : Array (Array K) := + Array.ofFn (fun q : Fin numRows => + (compactBaseRow hash snapshot root height q.val leafWords lanes).toArray) + +theorem compactBaseRow_length (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index leafWords lanes : Nat) (fits : lanes ≤ leafWords) : + (compactBaseRow hash snapshot root height index leafWords lanes).length = lanes := by + simp only [compactBaseRow,List.length_drop,baseRow_length] + omega + +theorem compactBaseOracle_size (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows leafWords lanes : Nat) : + (compactBaseOracle hash snapshot root height numRows leafWords lanes).size = numRows := by + simp [compactBaseOracle] + +theorem compactBaseOracle_get (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows leafWords lanes index : Nat) (bound : index < numRows) : + (compactBaseOracle hash snapshot root height numRows leafWords lanes)[index]! = + (compactBaseRow hash snapshot root height index leafWords lanes).toArray := by + simp [compactBaseOracle,bound] + +theorem compactBaseOracle_row_size (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows leafWords lanes index : Nat) (fits : lanes ≤ leafWords) (bound : index < numRows) : + ((compactBaseOracle hash snapshot root height numRows leafWords lanes)[index]!).size = lanes := by + rw [compactBaseOracle_get _ _ _ _ _ _ _ _ bound] + simpa using compactBaseRow_length hash snapshot root height index leafWords lanes fits + +theorem compactBaseRow_of_leaf (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height index leafWords lanes : Nat) (stored : List K) + (width : stored.length = lanes) (fits : lanes ≤ leafWords) + (extracted : row hash snapshot root height index = leafImage 0 leafWords stored) : + compactBaseRow hash snapshot root height index leafWords lanes = stored := by + have full : (leafImage (0 : K) leafWords stored).length = leafWords := + leafImage_length 0 leafWords stored (width ▸ fits) + unfold compactBaseRow baseRow + rw [extracted,ite_eq_left full] + simpa only [leafImage,width,List.length_replicate] using + (List.drop_left : (List.replicate (leafWords-lanes) (0 : K) ++ stored).drop + (List.replicate (leafWords-lanes) (0 : K)).length = stored) + +theorem compactBaseOracle_locality (hash other : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows leafWords lanes : Nat) (agree : ∀ x ∈ snapshot.table, hash x = other x) : + compactBaseOracle hash snapshot root height numRows leafWords lanes = + compactBaseOracle other snapshot root height numRows leafWords lanes := by + simp only [compactBaseOracle,compactBaseRow,baseRow,row, + oracle_locality hash other snapshot root agree] + rfl + +theorem compactBaseOracle_eq_recorded (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows leafWords lanes : Nat) (records : Records) (absent : Digest32) + (authentic : Authentic hash records) (covered : snapshot.table ⊆ recordDomain records) : + compactBaseOracle hash snapshot root height numRows leafWords lanes = + compactBaseOracle (recordedHash records absent) snapshot root height numRows leafWords lanes := + compactBaseOracle_locality hash _ snapshot root height numRows leafWords lanes + (recordedHash_agrees_on_snapshot hash records absent snapshot authentic covered) + +/-- Accepted native padded paths give the same occupied rows, in original query +order, once the public primitive binding theorem supplies its non-bad branch. -/ +theorem open_compact_rows (hash : Primitive) (snapshot : Snapshot) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (lanes leafWords : Nat) (output : List RawPath) + (accepted : proof.open hash root numLeaves queries lanes leafWords = some output) + (bound : ∀ path ∈ output, + path.leafData = row hash snapshot root numLeaves.log2 path.leafIndex) : + List.Forall₂ (fun q path => (path.leafData.drop (leafWords-lanes)).toArray = + (compactBaseOracle hash snapshot root numLeaves.log2 numLeaves leafWords lanes)[q]!) + queries output := by + have refined := open_refines _ _ _ _ _ _ _ _ accepted + have conditions := ((open_spec _ _ _ _ _ _ _ _).mp accepted).1 + apply List.forall₂_of_length_eq_of_get refined.length_eq + intro i hi ho + obtain ⟨stored,hs,hw,hindex,hdata,hlen,hdepth,hroot⟩ := refined.get hi ho + have hq := conditions.range (queries.get ⟨i,hi⟩) (List.get_mem _ _) + have hraw := bound (output.get ⟨i,ho⟩) (List.get_mem _ _) + rw [compactBaseOracle_get _ _ _ _ _ _ _ _ hq] + congr 1 + rw [← hindex] + simp only [compactBaseRow,baseRow,← hraw,hlen,↓reduceIte] + +end Whir.WHIRPhysicalRows diff --git a/verification/whir/Whir/WHIRPowProgram.lean b/verification/whir/Whir/WHIRPowProgram.lean new file mode 100644 index 000000000..ce629bb10 --- /dev/null +++ b/verification/whir/Whir/WHIRPowProgram.lean @@ -0,0 +1,489 @@ +import Whir.PublicMerkleProgram + +/-! Source-pinned #552 nonce verification as metered public primitive requests. +Finishing and nonce binding occur on zero-difficulty and rejecting branches. +Packet entry replays the complete framed prefix conservatively; no live CV is +supplied by a decoder premise. No grinding amplification is claimed. -/ +namespace Whir.WHIRPowProgram +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicMerkleProgram (Runs runReal_runs runIdeal_runs) +open RawWHIRKeys (Context Packet) +open WHIRHistory (Pending scalarBytes) +open WHIRHistoryKey (Normal initialPending canonicalFrames) + +variable {R S : Type} + +def askPow (n : Node) (next : Digest32 → Program R) : Program R := .ask (.primitive .pow n) next + +private def askPowStored (n : Node) (next : Digest32 → Program R) : Program R := + .ask (.primitive .pow n) fun answer => + let bytes := Array.ofFn answer + next (fun i => bytes[i.val]'(by simp only [bytes,Array.size_ofFn]; exact i.isLt)) + +@[csimp] theorem askPow_stored : @askPow = @askPowStored := by + funext R n next + simp [askPow,askPowStored] + +theorem askPow_counted (n : Node) (next : Digest32 → Program R) (budget : Nat) + (after : ∀ d, Counts budget (next d)) : Counts (1+budget) (askPow n next) := by + simpa [askPow,Counts,Query.cost] using And.intro (by omega : 1 ≤ 1+budget) after + +def payload (base : Digest32) (nonce : Scalar24) : List Byte := + List.ofFn base ++ List.ofFn nonce ++ littleWord 0x31574f502d534646 + +theorem payload_length (base : Digest32) (nonce : Scalar24) : (payload base nonce).length = 64 := by + simp [payload,littleWord] + +def powNode (base : Digest32) (nonce : Scalar24) : Node := + PublicMerkleLog.node DuplexCompression.parameterIV 0 (payload base nonce) true + +def passed (digest : Digest32) (bits : Nat) : Bool := + ByteCodec.decodeNat 8 (fun i => digest ⟨i.val,by omega⟩) % 2^bits == 0 + +def powOK (C : PrimitiveOracle) (base : Digest32) (nonce : Scalar24) (bits : Nat) : Bool := + passed (C (powNode base nonce)) bits + +theorem powOK_blake (base : Digest32) (nonce : Scalar24) (bits : Nat) : + powOK blake2sOracle base nonce bits = DuplexCompression.powOK base nonce bits := by + simp [powOK,passed,powNode,payload,PublicMerkleLog.node,blake2sOracle, + DuplexCompression.powOK,DuplexCompression.hashBlock] + +def finishNode (s : State) : Node := + ⟨s.cv,padded s.pending,absorbTweak s.first true s.pending.size s.previous,true⟩ + +def baseNode (cv : Digest32) (consumed bits : Nat) : Node := + ⟨cv,wordsBlock [consumed,bits],UInt64.ofNat (8*2^56),true⟩ + +def bindNode (cv : Digest32) (consumed : Nat) (nonce : Scalar24) (bits : Nat) : Node := + ⟨cv,nonceBlock nonce consumed bits,UInt64.ofNat (9*2^56),true⟩ + +def finishProgram (s : State) : Program State := + if s.pending.isEmpty then .done s else + askPow (finishNode s) (fun cv => .done {s with cv := cv,pending := #[],first := true,previous := 0}) + +def finishCost (s : State) : Nat := if s.pending.isEmpty then 0 else 1 + +/-- The native order is base, ordinary PoW predicate, then mandatory nonce +binding. The zero-bit branch still makes the binding query. -/ +def verifyClosed (cv : Digest32) (consumed : Nat) (nonce : Scalar24) (bits : Nat) : Program (Digest32 × Bool) := + if bits = 0 then + askPow (bindNode cv consumed nonce bits) (fun updated => .done (updated,decide (nonce = fun _ => 0))) + else + askPow (baseNode cv consumed bits) fun base => + askPow (powNode base nonce) fun digest => + askPow (bindNode cv consumed nonce bits) (fun updated => .done (updated,passed digest bits)) + +def closedCost (bits : Nat) : Nat := if bits = 0 then 1 else 3 + +def verifyBounded (s : State) (nonce : Scalar24) (bits : Nat) : Program (State × Bool) := + WHIRModeFinal.bind (finishProgram s) fun finished => + WHIRModeFinal.bind (verifyClosed finished.cv finished.consumed nonce bits) fun result => + .done ({finished with cv := result.1,consumed := 0},result.2) + +def verifyState (s : State) (nonce : Scalar24) (bits : Nat) : Program (Except Error (State × Bool)) := + if bits ≤ 63 then WHIRModeFinal.bind (verifyBounded s nonce bits) (fun result => .done (.ok result)) + else .done (.error .grindingBits) + +def stateCost (s : State) (bits : Nat) : Nat := + if bits ≤ 63 then finishCost s + closedCost bits else 0 + +theorem finishProgram_real (C : PrimitiveOracle) (iv : Digest32) (s : State) : + (runReal C iv (finishProgram s)).view.result = finish (compressionOf C) s := by + simp only [finishProgram,finish] + split <;> simp_all [askPow,runReal,prepend,realAnswer,finalized,finishNode,compressionOf] + +theorem verifyClosed_real (C : PrimitiveOracle) (iv cv : Digest32) (consumed : Nat) + (nonce : Scalar24) (bits : Nat) : + (runReal C iv (verifyClosed cv consumed nonce bits)).view.result = + (C (bindNode cv consumed nonce bits), + if bits = 0 then decide (nonce = fun _ => 0) else powOK C (C (baseNode cv consumed bits)) nonce bits) := by + by_cases h : bits = 0 <;> simp [verifyClosed,h,askPow,runReal,prepend,realAnswer,powOK] + +theorem verifyBounded_real (C : PrimitiveOracle) (iv : Digest32) (s : State) + (nonce : Scalar24) (bits : Nat) : + (runReal C iv (verifyBounded s nonce bits)).view.result = + (bindNonce (compressionOf C) s nonce bits, + if bits = 0 then decide (nonce = fun _ => 0) + else powOK C (powBase (compressionOf C) (finish (compressionOf C) s) bits) nonce bits) := by + rw [verifyBounded,WHIRModeFinal.bind_real_result,finishProgram_real, + WHIRModeFinal.bind_real_result,verifyClosed_real] + simp only [runReal,bindNonce,baseNode,bindNode,powBase,finalized,finish_pending, + Array.isEmpty_empty,↓reduceIte,compressionOf] + +theorem verifyState_real (C : PrimitiveOracle) (iv : Digest32) (s : State) + (nonce : Scalar24) (bits : Nat) : + (runReal C iv (verifyState s nonce bits)).view.result = + verifyNonce (compressionOf C) (powOK C) s nonce bits := by + by_cases h : bits ≤ 63 + · simp only [verifyState,h,↓reduceIte,WHIRModeFinal.bind_real_result,verifyBounded_real,runReal, + verifyNonce,bindNonce_finish] + · simp [verifyState,verifyNonce,h,runReal] + +theorem verifyState_blake (iv : Digest32) (s : State) (nonce : Scalar24) (bits : Nat) : + (runReal blake2sOracle iv (verifyState s nonce bits)).view.result = + verifyNonce DuplexCompression.compress DuplexCompression.powOK s nonce bits := by + rw [verifyState_real] + have h : powOK blake2sOracle = DuplexCompression.powOK := by funext base nonce bits; exact powOK_blake _ _ _ + rw [h] + rfl + +theorem finishProgram_counted (s : State) : Counts (finishCost s) (finishProgram s) := by + by_cases h : s.pending.isEmpty <;> simp [finishProgram,finishCost,h,askPow,Counts,Query.cost] + +theorem verifyClosed_counted (cv : Digest32) (consumed : Nat) (nonce : Scalar24) (bits : Nat) : + Counts (closedCost bits) (verifyClosed cv consumed nonce bits) := by + by_cases h : bits = 0 <;> simp [verifyClosed,closedCost,h,askPow,Counts,Query.cost] + +theorem verifyBounded_counted (s : State) (nonce : Scalar24) (bits : Nat) : + Counts (finishCost s + closedCost bits) (verifyBounded s nonce bits) := by + apply WHIRModeFinal.bind_counted _ _ _ _ (finishProgram_counted s) + intro finished + simpa only [Nat.add_zero] using WHIRModeFinal.bind_counted + (verifyClosed finished.cv finished.consumed nonce bits) + (fun result => .done ({finished with cv := result.1,consumed := 0},result.2)) + (closedCost bits) 0 (verifyClosed_counted _ _ _ _) (fun _ => True.intro) + +theorem verifyState_counted (s : State) (nonce : Scalar24) (bits : Nat) : + Counts (stateCost s bits) (verifyState s nonce bits) := by + by_cases h : bits ≤ 63 + · simpa only [verifyState,stateCost,h,↓reduceIte,Nat.add_zero] using + WHIRModeFinal.bind_counted (verifyBounded s nonce bits) + (fun result => .done (.ok result : Except Error (State × Bool))) + (finishCost s + closedCost bits) 0 (verifyBounded_counted s nonce bits) (fun _ => True.intro) + · simp [verifyState,stateCost,h,Counts] + +/-- Reuse the actual seed and frame encodings, without any terminal/export node. -/ +def historyInstructions (h : FramedHistory) : List DuplexEncoding.Instruction := + (ByteCodec.pairBytes (h.domain,h.statement),UInt64.ofNat (2^56)) :: h.frames.flatMap DuplexEncoding.framePlan + +theorem historyInstructions_plan (h : FramedHistory) (t : Terminal) : + historyInstructions h ++ [DuplexEncoding.terminalPlan t] = DuplexEncoding.plan ⟨h,t⟩ := rfl + +def instructions (cv : Digest32) : List DuplexEncoding.Instruction → Program Digest32 + | [] => .done cv + | i :: rest => askPow ⟨cv,i.1,i.2,true⟩ (fun answer => instructions answer rest) + +def historyProgram (iv : Digest32) (h : FramedHistory) : Program Digest32 := instructions iv (historyInstructions h) + +theorem instructions_real (C : PrimitiveOracle) (iv cv : Digest32) (is : List DuplexEncoding.Instruction) : + (runReal C iv (instructions cv is)).view.result = evalPlan (compressionOf C) cv is := by + induction is generalizing cv with + | nil => rfl + | cons i rest ih => simpa only [instructions,askPow,runReal,prepend,realAnswer,evalPlan,List.foldl_cons,compressionOf] using ih (C ⟨cv,i.1,i.2,true⟩) + +theorem historyProgram_real (C : PrimitiveOracle) (iv : Digest32) (h : FramedHistory) : + (runReal C iv (historyProgram iv h)).view.result = evalHistory (compressionOf C) iv h := by + rw [historyProgram,instructions_real] + change evalPlan (compressionOf C) (seed (compressionOf C) iv h.domain h.statement).cv + (h.frames.flatMap DuplexEncoding.framePlan) = _ + exact framesPlan_evaluate _ _ _ + +theorem instructions_counted (cv : Digest32) (is : List DuplexEncoding.Instruction) : + Counts is.length (instructions cv is) := by + induction is generalizing cv with + | nil => trivial + | cons i rest ih => simpa only [instructions,List.length_cons,Nat.add_comm] using askPow_counted ⟨cv,i.1,i.2,true⟩ _ rest.length ih + +theorem historyProgram_counted (iv : Digest32) (h : FramedHistory) : + Counts (historyInstructions h).length (historyProgram iv h) := instructions_counted _ _ + +def nonceAt : List Pending → Option (Nat × E) + | [] => none + | m :: _ => m.nonce + +def beforeNonceMessages : List Pending → List Pending + | [] => [] + | m :: ps => {m with nonce := none} :: ps + +def preHistory (ctx : Context) (p : RawWHIRKeys.PacketData) : FramedHistory := + ⟨ctx.domain,p.statement,p.entryFrames ++ canonicalFrames (RawWHIRKeys.width ctx.mode p.profile) (beforeNonceMessages p.messages)⟩ + +def preModel (ctx : Context) (p : RawWHIRKeys.PacketData) : Model := + WHIRCallerPrefix.beforeModelFrom (RawWHIRKeys.width ctx.mode p.profile) (RawWHIRKeys.entry ctx p) + (beforeNonceMessages p.messages) + +theorem nonce_shape (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) : + ∃ m ps, p.val.messages = m :: ps ∧ Normal ps ∧ m.scalars ≠ [] ∧ m.nonce = some (bits,value) := by + have normal := WHIRHistoryKey.scheduled_normal _ _ p.property.2.1 p.property.2.2.1 + generalize hm : p.val.messages = ms at normal hn ⊢ + cases normal with + | initial => simp [nonceAt,initialPending] at hn + | cons prior m nonempty => exact ⟨m,_,rfl,prior,nonempty,hn⟩ + +theorem nonce_bits (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) : bits ≤ 63 := by + obtain ⟨m,ps,hm,_,_,he⟩ := nonce_shape ctx Q p bits value hn + exact WHIRHistoryKey.scheduled_nonce_bits _ _ p.property.2.2.1 m (by simp [hm]) bits value he + +theorem post_history (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) (block : Nat) : + (RawWHIRKeys.coordinate ctx p.val block).history = + {preHistory ctx p.val with frames := (preHistory ctx p.val).frames ++ [.nonce 0 bits (ByteCodec.encodeE value)]} := by + obtain ⟨m,ps,hm,normal,_,he⟩ := nonce_shape ctx Q p bits value hn + simp only [RawWHIRKeys.coordinate,preHistory,hm,beforeNonceMessages, + WHIRHistoryKey.canonicalFrames_cons _ _ _ normal.nonempty,WHIRHistoryKey.stepFrames,he] + simp [List.append_assoc] + +theorem preModel_history (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) : + (closeRun (preModel ctx p.val)).history = preHistory ctx p.val := by + obtain ⟨m,ps,hm,normal,nonempty,_⟩ := nonce_shape ctx Q p bits value hn + have before : Normal (beforeNonceMessages p.val.messages) := by + rw [hm] + exact .cons normal {m with nonce := none} nonempty + exact WHIRCallerPrefix.before_historyFrom _ (RawWHIRKeys.width_positive ctx.mode p.val.profile) _ before + +theorem preModel_consumed (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) : (preModel ctx p.val).consumed = 0 := by + obtain ⟨m,ps,hm,_,nonempty,_⟩ := nonce_shape ctx Q p bits value hn + have hb : scalarBytes m.scalars ≠ [] := fun he => nonempty ((WHIRHistory.scalarBytes_empty _).mp he) + simp [preModel,hm,beforeNonceMessages,WHIRCallerPrefix.beforeModelFrom_cons,WHIRHistory.pendingModel,modelAbsorb,hb] + +def preCoordinate (ctx : Context) (p : RawWHIRKeys.PacketData) (bits : Nat) : Coordinate := + ⟨preHistory ctx p,.powBase 0 bits⟩ + +theorem preCoordinate_admissible (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) : DuplexEncoding.Admissible (preCoordinate ctx p.val bits) := by + have hb : 0 < RawWHIRKeys.blocks ctx p.val := by + have hp := RawWHIRKeys.width_positive ctx.mode p.val.profile (p.val.messages.length-1) + unfold RawWHIRKeys.blocks + omega + have h := RawWHIRKeys.coordinate_admissible ctx Q ⟨p,⟨0,hb⟩⟩ + refine ⟨?_,⟨by decide,nonce_bits ctx Q p bits value hn⟩⟩ + intro f hf + apply h.1 f + rw [post_history ctx Q p bits value hn 0] + exact List.mem_append_left _ hf + +theorem packet_path_split (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) : + pathCost (RawWHIRKeys.coordinate ctx p.val 0) = (historyInstructions (preHistory ctx p.val)).length + 2 := by + change (DuplexEncoding.plan (RawWHIRKeys.coordinate ctx p.val 0)).length = _ + unfold DuplexEncoding.plan + rw [post_history ctx Q p bits value hn 0] + simp [historyInstructions,DuplexEncoding.framePlan,List.flatMap_append,Nat.add_assoc] + +structure Outcome (ctx : Context) (Q : Nat) (p : Packet ctx Q) where + accepted : Bool + boundCV : Option Digest32 + history : FramedHistory + canonical : history = (RawWHIRKeys.coordinate ctx p.val 0).history + +def Outcome.coordinate {ctx Q p} (outcome : Outcome ctx Q p) (block : Nat) : Coordinate := + ⟨outcome.history,.output block⟩ + +theorem Outcome.coordinate_eq {ctx Q p} (outcome : Outcome ctx Q p) (block : Nat) : + outcome.coordinate block = RawWHIRKeys.coordinate ctx p.val block := by + simp only [Outcome.coordinate,outcome.canonical] + rfl + +theorem Outcome.coordinate_admissible {ctx Q p} (outcome : Outcome ctx Q p) + (i : Fin (RawWHIRKeys.blocks ctx p.val)) : DuplexEncoding.Admissible (outcome.coordinate i.val) := by + rw [Outcome.coordinate_eq] + exact RawWHIRKeys.coordinate_admissible ctx Q ⟨p,i⟩ + +/-- Binding retains the previous output cache, although cursor zero makes it +inactive. Supply those actual bytes rather than claiming a fake zero-cache state. -/ +def Outcome.state {ctx Q p} (outcome : Outcome ctx Q p) (oldOutput : Digest32) : Option State := + outcome.boundCV.map (fun cv => {cv := cv,output := oldOutput}) + +def verifyPacket (ctx : Context) (Q : Nat) (p : Packet ctx Q) : Program (Outcome ctx Q p) := + match hn : nonceAt p.val.messages with + | none => .done ⟨true,none,(RawWHIRKeys.coordinate ctx p.val 0).history,rfl⟩ + | some (bits,value) => + WHIRModeFinal.bind (historyProgram ctx.iv (preHistory ctx p.val)) fun cv => + WHIRModeFinal.bind (verifyClosed cv 0 (ByteCodec.encodeE value) bits) fun result => + .done ⟨result.2,some result.1, + {preHistory ctx p.val with frames := (preHistory ctx p.val).frames ++ [.nonce 0 bits (ByteCodec.encodeE value)]}, + (post_history ctx Q p bits value hn 0).symm⟩ + +def packetCost (ctx : Context) (p : RawWHIRKeys.PacketData) : Nat := + match nonceAt p.messages with + | none => 0 + | some (bits,_) => (historyInstructions (preHistory ctx p)).length + closedCost bits + +theorem verifyPacket_counted (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + Counts (packetCost ctx p.val) (verifyPacket ctx Q p) := by + unfold verifyPacket + split + · simp [Counts] + next bits value hn => + simp only [packetCost,hn] + apply WHIRModeFinal.bind_counted _ _ _ _ (historyProgram_counted _ _) + intro cv + have hc := verifyClosed_counted cv 0 (ByteCodec.encodeE value) bits + change Counts (closedCost bits) (WHIRModeFinal.bind _ _) + rw [← Nat.add_zero (closedCost bits)] + apply WHIRModeFinal.bind_counted _ _ _ _ hc + intro result + trivial + +theorem packetCost_bound (ctx : Context) (Q : Nat) (p : Packet ctx Q) : packetCost ctx p.val ≤ Q+1 := by + unfold packetCost + split + · omega + next bits value hn => + have h := packet_path_split ctx Q p bits value hn + have hp := RawWHIRKeys.packet_pathBound ctx Q p + unfold closedCost + split <;> omega + +theorem verifyPacket_real (C : PrimitiveOracle) (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + let out := (runReal C ctx.iv (verifyPacket ctx Q p)).view.result + match nonceAt p.val.messages with + | none => out.accepted = true ∧ out.boundCV = none + | some (bits,value) => + let cv := evalHistory (compressionOf C) ctx.iv (preHistory ctx p.val) + out.accepted = (if bits = 0 then decide (ByteCodec.encodeE value = fun _ => 0) + else powOK C (C (baseNode cv 0 bits)) (ByteCodec.encodeE value) bits) ∧ + out.boundCV = some (C (bindNode cv 0 (ByteCodec.encodeE value) bits)) := by + unfold verifyPacket + split + · next hn => simp [hn,runReal] + next bits value hn => + simp [hn,WHIRModeFinal.bind_real_result,historyProgram_real,verifyClosed_real,runReal] + +/-- The frame prefix is derived from the actual Pending packet. For every +represented native pre-nonce state, the returned full state (including retained +cache), Boolean, and rejection transition equal native verification exactly. -/ +theorem verifyPacket_source (C : PrimitiveOracle) (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (bits : Nat) (value : E) (hn : nonceAt p.val.messages = some (bits,value)) + (s : State) (represented : Represents (compressionOf C) ctx.iv (preModel ctx p.val) s) : + (verifyNonce (compressionOf C) (powOK C) s (ByteCodec.encodeE value) bits).toOption = + let out := (runReal C ctx.iv (verifyPacket ctx Q p)).view.result + (out.state s.output).map (fun state => (state,out.accepted)) := by + have result := verifyPacket_real C ctx Q p + simp only [hn] at result + have hf := finish_represents (compressionOf C) ctx.iv (preModel ctx p.val) s represented + have hm := materialize_closed (compressionOf C) ctx.iv (closeRun (preModel ctx p.val)) + (finish (compressionOf C) s).output hf.1 (closeRun_empty _) + have ho : (finish (compressionOf C) s).output = s.output := by unfold finish; split <;> rfl + have hs := hf.2.1.trans hm + simp only [preModel_history ctx Q p bits value hn,closeRun_consumed, + preModel_consumed ctx Q p bits value hn,ho] at hs + simp only [verifyNonce,nonce_bits ctx Q p bits value hn,↓reduceIte,hs, + Outcome.state,result.1,result.2,Option.map_some,Except.toOption] + simp [bindNonce,finish,powBase,finalized,baseNode,bindNode,compressionOf] + +theorem preModel_valid (ctx : Context) (Q : Nat) (p : Packet ctx Q) (bits : Nat) (value : E) + (hn : nonceAt p.val.messages = some (bits,value)) : (preModel ctx p.val).Valid := by + obtain ⟨m,ps,hm,normal,nonempty,_⟩ := nonce_shape ctx Q p bits value hn + have hb : scalarBytes m.scalars ≠ [] := fun he => nonempty ((WHIRHistory.scalarBytes_empty _).mp he) + have bound := RawWHIRKeys.width_bounded ctx.mode p.val.profile (ps.length-1) + have positive := RawWHIRKeys.width_positive ctx.mode p.val.profile (ps.length-1) + simp only [preModel,hm,beforeNonceMessages,WHIRCallerPrefix.beforeModelFrom_cons, + WHIRCallerPrefix.completedModelFrom, + WHIRHistoryKey.completed_normal _ (RawWHIRKeys.width_positive ctx.mode p.val.profile) _ _ normal, + WHIRCallerPrefix.prepend,WHIRHistory.pendingModel,modelAbsorb,hb,↓reduceIte, + List.nil_append,Model.Valid] + simp only [hb,not_false_eq_true,true_implies,false_implies, + Nat.zero_le,ne_eq,Nat.ne_of_gt positive,↓reduceIte,true_and] + change RawWHIRKeys.width ctx.mode p.val.profile (ps.length-1) ≤ 2^49-1 + omega + +/-- No assumed representation/codec bridge is needed for the actual source +state obtained by executing its pending absorption from this packet model. -/ +theorem verifyPacket_materialized (C : PrimitiveOracle) (ctx : Context) (Q : Nat) (p : Packet ctx Q) + (bits : Nat) (value : E) (hn : nonceAt p.val.messages = some (bits,value)) (oldOutput : Digest32) : + (verifyNonce (compressionOf C) (powOK C) + (materialize (compressionOf C) ctx.iv (preModel ctx p.val) oldOutput) + (ByteCodec.encodeE value) bits).toOption = + let out := (runReal C ctx.iv (verifyPacket ctx Q p)).view.result + (out.state oldOutput).map (fun state => (state,out.accepted)) := by + have hv := preModel_valid ctx Q p bits value hn + have represented : Represents (compressionOf C) ctx.iv (preModel ctx p.val) + (materialize (compressionOf C) ctx.iv (preModel ctx p.val) oldOutput) := by + refine ⟨hv,?_,?_⟩ + · rw [materialize_output] + · simp [CacheValid,materialize_consumed _ _ _ _ hv,preModel_consumed ctx Q p bits value hn] + simpa only [materialize_output] using verifyPacket_source C ctx Q p bits value hn _ represented + +/-- Every branch of the source helper asks only globally counted PoW-purpose +primitive queries, including finish and binding queries. -/ +def PowOnly : Program R → Prop + | .done _ => True + | .ask (.primitive .pow _) next => ∀ d, PowOnly (next d) + | .ask _ _ => False + +theorem PowOnly.bind {p : Program R} {next : R → Program S} + (hp : PowOnly p) (hn : ∀ r, PowOnly (next r)) : PowOnly (WHIRModeFinal.bind p next) := by + induction p with + | done r => exact hn r + | ask q cont ih => + cases q with + | construction q valid => exact False.elim hp + | primitive purpose node => + cases purpose <;> try exact False.elim hp + exact fun d => ih d (hp d) + +theorem finishProgram_powOnly (s : State) : PowOnly (finishProgram s) := by + unfold finishProgram + split <;> simp [askPow,PowOnly] + +theorem verifyClosed_powOnly (cv : Digest32) (consumed : Nat) (nonce : Scalar24) (bits : Nat) : + PowOnly (verifyClosed cv consumed nonce bits) := by + unfold verifyClosed + split <;> simp [askPow,PowOnly] + +theorem verifyState_powOnly (s : State) (nonce : Scalar24) (bits : Nat) : + PowOnly (verifyState s nonce bits) := by + unfold verifyState + split + · apply PowOnly.bind + · unfold verifyBounded + apply PowOnly.bind (finishProgram_powOnly s) + intro finished + exact PowOnly.bind (verifyClosed_powOnly _ _ _ _) (fun _ => True.intro) + · intro result + trivial + · trivial + +theorem instructions_powOnly (cv : Digest32) (is : List DuplexEncoding.Instruction) : + PowOnly (instructions cv is) := by + induction is generalizing cv with + | nil => trivial + | cons i rest ih => exact fun d => ih d + +theorem verifyPacket_powOnly (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + PowOnly (verifyPacket ctx Q p) := by + unfold verifyPacket + split + · trivial + · apply PowOnly.bind (instructions_powOnly _ _) + intro cv + exact PowOnly.bind (verifyClosed_powOnly _ _ _ _) (fun _ => True.intro) + +/-- Consume public answers in order. In particular, repeated nodes may have +different answers: replay neither consults a total hash nor silently memoizes. -/ +def replay (p : Program R) (trace : List Observation) : Option (R × List Observation) := + match p with + | .done r => some (r,trace) + | .ask (.primitive .pow n) next => + match trace with + | ⟨.primitive .pow observed,answer⟩ :: rest => + if n = observed then replay (next answer) rest else none + | _ => none + | .ask _ _ => none + +theorem replay_runs {p : Program R} {trace : List Observation} {result : R} + (only : PowOnly p) (run : Runs p trace result) (suffix : List Observation) : + replay p (trace ++ suffix) = some (result,suffix) := by + induction run with + | done r => rfl + | @ask q next trace r answer run ih => + cases q with + | construction q valid => exact False.elim only + | primitive purpose node => + cases purpose <;> try exact False.elim only + simpa only [replay,List.cons_append,↓reduceIte] using ih (only answer) + +theorem replay_ideal {G : Nat} {Seed SimState : Type} (sim : Simulator G Seed SimState) + (ro : RawKey G → Digest32) (iv : Digest32) (state : SimState) (p : Program R) + (remaining : Nat) (cap : remaining ≤ G) (counted : Counts remaining p) + (only : PowOnly p) (suffix : List Observation) : + replay p ((runIdeal sim ro iv state p remaining cap counted).view.observations ++ suffix) = + some ((runIdeal sim ro iv state p remaining cap counted).view.result,suffix) := + replay_runs only (runIdeal_runs sim ro iv state p remaining cap counted) suffix + +end Whir.WHIRPowProgram diff --git a/verification/whir/Whir/WHIRPublicBackfill.lean b/verification/whir/Whir/WHIRPublicBackfill.lean new file mode 100644 index 000000000..bb3c445ea --- /dev/null +++ b/verification/whir/Whir/WHIRPublicBackfill.lean @@ -0,0 +1,757 @@ +import Whir.WHIRModeFinal + +namespace Whir.WHIRPublicBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling RawOracleCoupling.Concrete +open WHIRModeFinal + +variable {R : Type} + +/-- One cell per public-derived raw request, followed by the final selection. +Unrecognized requests have empty cells: their public primitive answers must be +replayed from the original view, not read again through an ambient raw table. -/ +def selections (ctx : Context) (Q : Nat) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) : List (Option (Packet ctx Q)) := + requests.map (fun key => (RawWHIRKeys.recognize ctx Q key).map Sigma.fst) ++ [final] + +abbrev Record (ctx : Context) (Q : Nat) := WHIRModeFinal.Completed ctx Q Unit + +structure Completed (ctx : Context) (Q : Nat) (R : Type) where + result : R + records : List (Record ctx Q) + +/-- Cells retain request order and packet blocks remain one atomic group answer. +Repeats are deliberately physically reread, with their full uncached cost. -/ +def readSelections (ctx : Context) (Q : Nat) : List (Option (Packet ctx Q)) → + (List (Record ctx Q) → Program R) → Program R + | [], next => next [] + | none :: rest, next => readSelections ctx Q rest (fun records => next (⟨(),none,[]⟩ :: records)) + | some p :: rest, next => + readCallerThenPackets ctx Q p (callerPositions ctx Q p) (terminalCompletion ctx Q (some p)) + (fun history => readSelections ctx Q rest (fun records => next (⟨(),some p,history⟩ :: records))) + +def backfill (ctx : Context) (Q : Nat) (result : R) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) : Program (Completed ctx Q R) := + readSelections ctx Q (selections ctx Q requests final) (fun records => .done ⟨result,records⟩) + +def selectionsCost (ctx : Context) (Q : Nat) (ps : List (Option (Packet ctx Q))) : Nat := + (ps.map (completionCost ctx Q)).sum + +def cost (ctx : Context) (Q : Nat) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) : Nat := selectionsCost ctx Q (selections ctx Q requests final) + +def realRecords (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (ps : List (Option (Packet ctx Q))) : List (Record ctx Q) := + ps.map (fun p => ⟨(),p,realCompletion ctx Q oracle p⟩) + +def idealRecords (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (ps : List (Option (Packet ctx Q))) : List (Record ctx Q) := + ps.map (fun p => ⟨(),p,idealCompletion ctx Q table p⟩) + +theorem readSelections_real_result (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (ps : List (Option (Packet ctx Q))) (next : List (Record ctx Q) → Program R) : + (runReal oracle ctx.iv (readSelections ctx Q ps next)).view.result = + (runReal oracle ctx.iv (next (realRecords ctx Q oracle ps))).view.result := by + induction ps generalizing next with + | nil => rfl + | cons p ps ih => + cases p with + | none => exact ih _ + | some p => + rw [readSelections, readCallerThenPackets_real_result, ih] + rfl + +theorem readSelections_ideal_result (ctx : Context) (Q : Nat) {Seed State : Type} + (sim : Simulator Q Seed State) (table : RawKey Q → Digest32) (state : State) + (ps : List (Option (Packet ctx Q))) (next : List (Record ctx Q) → Program R) + (value : List (Record ctx Q) → R) + (after : ∀ records remaining (cap : remaining ≤ Q) (counted : Counts remaining (next records)), + (runIdeal sim table ctx.iv state (next records) remaining cap counted).view.result = value records) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining (readSelections ctx Q ps next)) : + (runIdeal sim table ctx.iv state (readSelections ctx Q ps next) remaining cap counted).view.result = + value (idealRecords ctx Q table ps) := by + induction ps generalizing next value remaining with + | nil => exact after [] remaining cap counted + | cons p ps ih => + cases p with + | none => exact ih _ _ (fun records => after (⟨(),none,[]⟩ :: records)) remaining cap counted + | some p => + exact readCallerThenPackets_ideal_result ctx Q sim table state p _ _ _ + (fun history => value (⟨(),some p,history⟩ :: idealRecords ctx Q table ps)) + (fun history rem hc hn => ih _ _ (fun records => after (⟨(),some p,history⟩ :: records)) rem hc hn) + remaining cap counted + +theorem backfill_real_result (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (result : R) (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) : + (runReal oracle ctx.iv (backfill ctx Q result requests final)).view.result = + ⟨result,realRecords ctx Q oracle (selections ctx Q requests final)⟩ := by + rw [backfill, readSelections_real_result] + rfl + +theorem backfill_ideal_result (ctx : Context) (Q : Nat) {Seed State : Type} + (sim : Simulator Q Seed State) (table : RawKey Q → Digest32) (state : State) + (result : R) (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining (backfill ctx Q result requests final)) : + (runIdeal sim table ctx.iv state (backfill ctx Q result requests final) remaining cap counted).view.result = + ⟨result,idealRecords ctx Q table (selections ctx Q requests final)⟩ := + readSelections_ideal_result ctx Q sim table state _ _ + (fun records => (⟨result,records⟩ : Completed ctx Q R)) + (fun _ _ _ _ => rfl) remaining cap counted + +theorem readSelections_counted (ctx : Context) (Q : Nat) (ps : List (Option (Packet ctx Q))) + (next : List (Record ctx Q) → Program R) (budget : Nat) + (after : ∀ records, Counts budget (next records)) : + Counts (selectionsCost ctx Q ps + budget) (readSelections ctx Q ps next) := by + induction ps generalizing next with + | nil => simpa [selectionsCost, readSelections] using after [] + | cons p ps ih => + cases p with + | none => + simpa [selectionsCost, completionCost, readSelections] using + (ih _ (fun records => after (⟨(),none,[]⟩ :: records))) + | some p => + have h := readCallerThenPackets_counted ctx Q p (callerPositions ctx Q p) + (terminalCompletion ctx Q (some p)) _ (selectionsCost ctx Q ps + budget) + (fun history => ih _ (fun records => after (⟨(),some p,history⟩ :: records))) + simpa only [selectionsCost, List.map_cons, List.sum_cons, completionCost, + Nat.add_assoc, readSelections] using h + +theorem backfill_counted (ctx : Context) (Q : Nat) (result : R) + (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) : + Counts (cost ctx Q requests final) (backfill ctx Q result requests final) := by + simpa only [cost, backfill, Nat.add_zero] using + readSelections_counted ctx Q (selections ctx Q requests final) + (fun records => Program.done (⟨result,records⟩ : Completed ctx Q R)) 0 (fun _ => True.intro) + +/-- Composition is certified for every continuation answer, not only the +observed real or ideal execution. The caller must budget the physical suffix. -/ +theorem bind_backfill_counted (ctx : Context) (Q : Nat) (program : Program R) + (requests : R → List (RawKey Q)) (final : R → Option (Packet ctx Q)) + (a b : Nat) (before : Counts a program) + (bound : ∀ result, cost ctx Q (requests result) (final result) ≤ b) : + Counts (a+b) (WHIRModeFinal.bind program (fun result => backfill ctx Q result (requests result) (final result))) := + bind_counted program _ a b before + (fun result => counts_mono (backfill_counted ctx Q result _ _) (bound result)) + +/-- The exact cost expands into full caller paths and every block of every +ancestor and selected packet; packet repeats occur separately in this sum. -/ +theorem cost_expansion (ctx : Context) (Q : Nat) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) : + cost ctx Q requests final = + ((requests.map (fun key => completionCost ctx Q ((RawWHIRKeys.recognize ctx Q key).map Sigma.fst))).sum + + completionCost ctx Q final) := by + simp [cost, selectionsCost, selections, List.map_map, Function.comp_def] + +/-- Completion membership includes callers, all ancestors, and the packet. -/ +def completionKeys (ctx : Context) (Q : Nat) (p : Packet ctx Q) : List (GroupKey ctx Q) := + dependencyKeys ctx Q (.inl p) ++ [.inl p] + +set_option backward.isDefEq.respectTransparency false in +theorem idealCompletion_eq (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (p : Packet ctx Q) : + idealCompletion ctx Q table (some p) = + (completionKeys ctx Q p).map (fun key => ⟨key,(partition ctx Q).split table key⟩) := by + rw [idealCompletion_some] + unfold completionKeys dependencyKeys Partition.dependencies callerPlan schedule + change _ = (((RawWHIRKeys.callerGroups ctx Q p).map + (fun key => (Sum.inr key : GroupKey ctx Q)) ++ + (RawWHIRKeys.ancestors ctx Q p).map (fun p => (Sum.inl p : GroupKey ctx Q))) ++ + [Sum.inl p]).map + (fun key => (⟨key,(partition ctx Q).split table key⟩ : Sigma (GroupAnswer ctx Q))) + rw [List.map_append, List.map_append, List.map_map, List.map_map] + simp only [idealHistory, List.map_append, List.map_cons, List.map_nil, List.append_assoc] + rfl + +theorem idealCompletion_agrees (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (p : Option (Packet ctx Q)) (entry : Sigma (GroupAnswer ctx Q)) + (member : entry ∈ idealCompletion ctx Q table p) : + (partition ctx Q).split table entry.1 = entry.2 := by + cases p with + | none => simp [idealCompletion] at member + | some p => + rw [idealCompletion_eq] at member + obtain ⟨key,_,rfl⟩ := List.mem_map.mp member + rfl + +theorem idealCompletion_covers (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (p : Packet ctx Q) (key : GroupKey ctx Q) (member : key ∈ completionKeys ctx Q p) : + (⟨key,(partition ctx Q).split table key⟩ : Sigma (GroupAnswer ctx Q)) ∈ + idealCompletion ctx Q table (some p) := by + rw [idealCompletion_eq] + exact List.mem_map.mpr ⟨key,member,rfl⟩ + +theorem recognized_covered (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) + (raw : RawKey Q) (member : raw ∈ requests) (pos : RawWHIRKeys.Position ctx Q) + (recognized : RawWHIRKeys.recognize ctx Q raw = some pos) : + (⟨(),some pos.1,idealCompletion ctx Q table (some pos.1)⟩ : Record ctx Q) ∈ + idealRecords ctx Q table (selections ctx Q requests final) := by + apply List.mem_map.mpr + refine ⟨some pos.1,List.mem_append_left _ ?_,rfl⟩ + exact List.mem_map.mpr ⟨raw,member,by simp [recognized]⟩ + +theorem final_covered (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) : + (⟨(),final,idealCompletion ctx Q table final⟩ : Record ctx Q) ∈ + idealRecords ctx Q table (selections ctx Q requests final) := by + apply List.mem_map.mpr + exact ⟨final,List.mem_append_right _ (by simp),rfl⟩ + +/-- A completed public answer equals any existing private immutable cache hit. +This is a consequence of the proved compiler invariant, not a cover premise. -/ +theorem agrees_compiler_cache (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + {S : Type} {K : Nat} (final : S → Option (Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (RawKey Q) (fun _ => Digest32) S K) + (p : Option (Packet ctx Q)) (entry : Sigma (GroupAnswer ctx Q)) + (member : entry ∈ idealCompletion ctx Q table p) (answer : GroupAnswer ctx Q entry.1) + (hit : (tableExecution ctx Q final program table).2 entry.1 = some answer) : + entry.2 = answer := + (idealCompletion_agrees ctx Q table p entry member).symm.trans + (tableExecution_cache ctx Q final program table entry.1 answer hit) + +end Whir.WHIRPublicBackfill + +namespace Whir.WHIRPublicBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling.Concrete WHIRModeFinal + +/-- A finite executable maximum over the actual catalog profile alphabet and +scheduled positions, rather than a claimed constant packet width. -/ +def maxPacketBlocks (ctx : Context) : Nat := + Finset.univ.sup (fun profile : ParameterBounds.Profile => + (Finset.range RawWHIRKeys.maxDepth).sup + (fun n => (RawWHIRKeys.width ctx.mode profile n + 31) / 32)) + +theorem blocks_le_max (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + RawWHIRKeys.blocks ctx p.val ≤ maxPacketBlocks ctx := by + have positive := List.length_pos_iff.mpr p.property.2.1 + have depth := (RawWHIRKeys.packet_depth ctx Q p).trans + (RawWHIRKeys.profile_depth_le p.val.profile) + apply le_trans (Finset.le_sup (f := fun n => (RawWHIRKeys.width ctx.mode p.val.profile n + 31) / 32) + (Finset.mem_range.mpr (show p.val.messages.length - 1 < RawWHIRKeys.maxDepth by omega))) + exact Finset.le_sup (f := fun profile : ParameterBounds.Profile => + (Finset.range RawWHIRKeys.maxDepth).sup + (fun n => (RawWHIRKeys.width ctx.mode profile n + 31) / 32)) (Finset.mem_univ _) + +private theorem sum_map_le {A : Type} (xs : List A) (f : A → Nat) (bound : Nat) + (bounded : ∀ x ∈ xs, f x ≤ bound) : (xs.map f).sum ≤ xs.length * bound := by + induction xs with + | nil => simp + | cons x xs ih => + have head := bounded x (by simp) + have rest := ih (fun a ha => bounded a (List.mem_cons_of_mem x ha)) + simp only [List.map_cons, List.sum_cons, List.length_cons, Nat.succ_mul] + omega + +theorem packetCost_bound (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + packetCost ctx Q p ≤ maxPacketBlocks ctx * Q := by + apply le_trans (b := RawWHIRKeys.blocks ctx p.val * Q) + · unfold packetCost + calc + _ ≤ ∑ _i : Fin (RawWHIRKeys.blocks ctx p.val), Q := + Finset.sum_le_sum (fun i _ => by + rw [RawWHIRKeys.pathCost_block] + exact RawWHIRKeys.packet_pathBound ctx Q p) + _ = _ := by simp + · exact Nat.mul_le_mul_right Q (blocks_le_max ctx Q p) + +theorem completionCost_bound (ctx : Context) (Q : Nat) (p : Option (Packet ctx Q)) : + completionCost ctx Q p ≤ (ctx.callerOutputCap + RawWHIRKeys.maxDepth * maxPacketBlocks ctx) * Q := by + cases p with + | none => exact Nat.zero_le _ + | some p => + have callers := sum_map_le (callerPositions ctx Q p) (fun q => pathCost q.val) Q + (fun q _ => RawWHIRKeys.callerOutput_pathBound ctx Q p q.val q.property) + have len : (callerPositions ctx Q p).length ≤ ctx.callerOutputCap := by + rw [callerPositions, List.length_attach, WHIRCallerOutputs.callerOutputs_length] + exact RawWHIRKeys.packet_callerOutputBound ctx Q p + have packets := sum_map_le (terminalCompletion ctx Q (some p)) (packetCost ctx Q) + (maxPacketBlocks ctx * Q) (fun packet _ => packetCost_bound ctx Q packet) + have packetLen := terminalCompletion_bound ctx Q (some p) + have c := callers.trans (Nat.mul_le_mul_right Q len) + have ps := packets.trans (Nat.mul_le_mul_right (maxPacketBlocks ctx * Q) packetLen) + change callerCost (callerPositions ctx Q p) + packetsCost ctx Q (terminalCompletion ctx Q (some p)) ≤ _ + dsimp only [callerCost, packetsCost] + calc + _ ≤ ctx.callerOutputCap * Q + RawWHIRKeys.maxDepth * (maxPacketBlocks ctx * Q) := Nat.add_le_add c ps + _ = _ := by rw [Nat.add_mul, Nat.mul_assoc] + +def overhead (ctx : Context) (Q requestCount : Nat) : Nat := + (requestCount + 1) * ((ctx.callerOutputCap + RawWHIRKeys.maxDepth * maxPacketBlocks ctx) * Q) + +theorem cost_bound (ctx : Context) (Q : Nat) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) : + cost ctx Q requests final ≤ overhead ctx Q requests.length := by + have h := sum_map_le (selections ctx Q requests final) (completionCost ctx Q) + ((ctx.callerOutputCap + RawWHIRKeys.maxDepth * maxPacketBlocks ctx) * Q) + (fun p _ => completionCost_bound ctx Q p) + simpa [cost, selectionsCost, overhead, selections] using h + +end Whir.WHIRPublicBackfill + +namespace Whir.WHIRPublicBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling.Concrete WHIRModeFinal + +theorem idealRecords_length (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) : + (idealRecords ctx Q table (selections ctx Q requests final)).length = requests.length + 1 := by + simp [idealRecords, selections] + +/-- Exact positional provenance, including empty garbage cells and repeats. -/ +theorem idealRecords_request (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) (i : Fin requests.length) : + (idealRecords ctx Q table (selections ctx Q requests final))[i.val]'(by + rw [idealRecords_length]; omega) = + let selected := (RawWHIRKeys.recognize ctx Q requests[i.val]).map Sigma.fst + (⟨(),selected,idealCompletion ctx Q table selected⟩ : Record ctx Q) := by + simp only [idealRecords, List.getElem_map] + unfold selections + rw [List.getElem_append_left (by simpa only [List.length_map] using i.isLt)] + simp only [List.getElem_map] + +theorem idealRecords_final (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) : + (idealRecords ctx Q table (selections ctx Q requests final))[requests.length]'(by + rw [idealRecords_length]; omega) = + (⟨(),final,idealCompletion ctx Q table final⟩ : Record ctx Q) := by + simp [idealRecords, selections] + +/-- At the exact request index, all dependency answers and the touched packet +are present and equal to the real ideal-table values. -/ +theorem request_dependencies (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) (i : Fin requests.length) + (pos : RawWHIRKeys.Position ctx Q) + (recognized : RawWHIRKeys.recognize ctx Q requests[i.val] = some pos) + (key : GroupKey ctx Q) (member : key ∈ completionKeys ctx Q pos.1) : + (⟨key,(partition ctx Q).split table key⟩ : Sigma (GroupAnswer ctx Q)) ∈ + ((idealRecords ctx Q table (selections ctx Q requests final))[i.val]'(by + rw [idealRecords_length]; omega)).history := by + rw [idealRecords_request] + simp only [recognized, Option.map_some] + exact idealCompletion_covers ctx Q table pos.1 key member + +theorem packetCost_full_paths (ctx : Context) (Q : Nat) (p : Packet ctx Q) : + packetCost ctx Q p = RawWHIRKeys.blocks ctx p.val * + ((p.val.entryFrames.flatMap DuplexEncoding.framePlan).length + + ((WHIRHistoryKey.canonicalFrames (RawWHIRKeys.width ctx.mode p.val.profile) + p.val.messages).flatMap DuplexEncoding.framePlan).length + 2) := by + simp [packetCost, RawWHIRKeys.pathCost_prefix] + +private def smokeContext : Context := + ⟨.stack,fun _ => 0,fun _ => 1,fun _ => some (0,0),fun _ => 1,1⟩ + +private def smokePacket (clone : Byte) (advanced : Bool) : Option (Packet smokeContext 4096) := + let messages := if advanced then + [⟨List.replicate (WHIRHistory.replyScalarCount + (c := ParameterBounds.config (0,0)) .initial) 0,none⟩,WHIRHistoryKey.initialPending] + else [WHIRHistoryKey.initialPending] + let p : RawWHIRKeys.PacketData := ⟨fun _ => 2,(0,0),messages,[.absorb 32 [clone]]⟩ + if valid : RawWHIRKeys.ValidPacket smokeContext 4096 p then some ⟨p,valid⟩ else none + +private def smokeMatches (table : RawKey 4096 → Digest32) (record : Record smokeContext 4096) : Bool := + record.history.all fun entry => + match entry with + | ⟨.inl p,answer⟩ => decide (answer = idealPacket smokeContext 4096 table p) + | ⟨.inr key,answer⟩ => decide (answer = table key.val) + +/-- Executable regression: a prior caller raw key, nonfinal packet prequery, +same-statement different-entry clone, unrelated garbage, and repeated packet. +The real and ideal interpreters execute the actual construction requests. -/ +private def smoke : IO Unit := do + let some early := smokePacket 3 false | throw (IO.userError "early packet rejected") + let some clone := smokePacket 4 false | throw (IO.userError "clone packet rejected") + let some final := smokePacket 3 true | throw (IO.userError "final packet rejected") + let some prior := (RawWHIRKeys.callerGroups smokeContext 4096 final).head? | + throw (IO.userError "missing prior caller output") + let garbage : RawKey 4096 := + (⟨⟨0,by decide⟩,Fin.elim0⟩,⟨⟨0,by decide⟩,Fin.elim0⟩) + let raw (p : Packet smokeContext 4096) := + RawWHIRKeys.encode smokeContext 4096 ⟨p,⟨0,RawWHIRKeys.blocks_positive smokeContext p.val⟩⟩ + let requests := [prior.val,raw early,raw clone,garbage,raw early] + let program := backfill smokeContext 4096 (37 : Nat) requests (some final) + let charge := cost smokeContext 4096 requests (some final) + if bounded : charge ≤ 4096 then + let table : RawKey 4096 → Digest32 := fun key _ => + ⟨(key.1.1.val + key.2.1.val) % 256,Nat.mod_lt _ (by decide)⟩ + let sim : Simulator 4096 Unit Unit := ⟨id,fun state _ => .done (state,fun _ => 0)⟩ + let ideal := runIdeal sim table smokeContext.iv () program charge bounded + (backfill_counted smokeContext 4096 37 requests (some final)) + let real := runReal (fun input i => input.block ⟨i.val,by omega⟩) smokeContext.iv program + let sizes := ideal.view.result.records.map (fun record => record.history.length) + unless sizes == [0,2,2,0,2,3] do + throw (IO.userError s!"completion cell sizes: {sizes}") + unless ideal.view.result.result == 37 && real.view.result.result == 37 && + ideal.primitiveCost == charge && real.primitiveCost == charge && + ideal.constructionRequests == 29 && real.constructionRequests == 29 && + ideal.view.result.records.all (smokeMatches table) && + decide (raw early ≠ raw clone) do + throw (IO.userError "physical backfill result, charge, answer, or clone mismatch") + IO.println s!"public backfill smoke: cells={sizes}, cost={charge}, construction requests={ideal.constructionRequests}, result=37; caller/prequery/clone/garbage/repeats checked" + else throw (IO.userError s!"backfill exceeds actual mode budget: {charge}") + +#eval smoke + +end Whir.WHIRPublicBackfill + +namespace Whir.WHIRPublicBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling RawOracleCoupling.Concrete WHIRModeFinal + +/-- The public path cap is independent of the raw-key domain bound. -/ +theorem recognized_path_eq_raw_length (ctx : Context) (Q : Nat) (raw : RawKey Q) + (pos : RawWHIRKeys.Position ctx Q) + (recognized : RawWHIRKeys.recognize ctx Q raw = some pos) : + pathCost (RawWHIRKeys.coordinate ctx pos.1.val 0) = raw.1.1.val := by + have h := congrArg (fun key : RawKey Q => key.1.1.val) + (RawWHIRKeys.encode_recognize ctx Q raw pos recognized) + change (modeKey ctx.iv (RawWHIRKeys.coordinate ctx pos.1.val pos.2.val)).message.length = _ at h + rw [(modeKey_lengths _ _).1, RawWHIRKeys.pathCost_block] at h + exact h + +theorem ancestor_path_le (ctx : Context) (Q : Nat) (p a : Packet ctx Q) + (member : a ∈ RawWHIRKeys.ancestors ctx Q p) : + pathCost (RawWHIRKeys.coordinate ctx a.val 0) ≤ + pathCost (RawWHIRKeys.coordinate ctx p.val 0) := by + obtain ⟨i,rfl⟩ := List.mem_ofFn.mp member + have h := RawWHIRKeys.canonicalCost_drop_le (RawWHIRKeys.width ctx.mode p.val.profile) + p.val.messages (p.val.messages.length - 1 - i.val) + simp only [RawWHIRKeys.pathCost_prefix, RawWHIRKeys.dropPacket] + omega + +theorem packetCost_path_bound (ctx : Context) (Q M : Nat) (p : Packet ctx Q) + (bounded : pathCost (RawWHIRKeys.coordinate ctx p.val 0) ≤ M) : + packetCost ctx Q p ≤ maxPacketBlocks ctx * M := by + apply le_trans (b := RawWHIRKeys.blocks ctx p.val * M) + · unfold packetCost + calc + _ ≤ ∑ _i : Fin (RawWHIRKeys.blocks ctx p.val), M := + Finset.sum_le_sum (fun i _ => by simpa only [RawWHIRKeys.pathCost_block] using bounded) + _ = _ := by simp + · exact Nat.mul_le_mul_right M (blocks_le_max ctx Q p) + +def pathFactor (ctx : Context) : Nat := + ctx.callerOutputCap + RawWHIRKeys.maxDepth * maxPacketBlocks ctx + +theorem completionCost_path_bound (ctx : Context) (Q M : Nat) (p : Packet ctx Q) + (bounded : pathCost (RawWHIRKeys.coordinate ctx p.val 0) ≤ M) : + completionCost ctx Q (some p) ≤ pathFactor ctx * M := by + have callers := sum_map_le (callerPositions ctx Q p) (fun q => pathCost q.val) M + (fun q _ => (WHIRCallerOutputs.callerOutputs_extended_pathCost_le + (RawWHIRKeys.entry ctx p.val) q.val q.property + (WHIRHistoryKey.canonicalFrames (RawWHIRKeys.width ctx.mode p.val.profile) p.val.messages) + (.output 0)).trans bounded) + have callerLen : (callerPositions ctx Q p).length ≤ ctx.callerOutputCap := by + rw [callerPositions, List.length_attach, WHIRCallerOutputs.callerOutputs_length] + exact RawWHIRKeys.packet_callerOutputBound ctx Q p + have packets := sum_map_le (terminalCompletion ctx Q (some p)) (packetCost ctx Q) + (maxPacketBlocks ctx * M) (by + intro a ha + apply packetCost_path_bound ctx Q M a + change a ∈ RawWHIRKeys.ancestors ctx Q p ++ [p] at ha + rcases List.mem_append.mp ha with ha | ha + · exact (ancestor_path_le ctx Q p a ha).trans bounded + · simpa only [List.mem_singleton.mp ha] using bounded) + have c := callers.trans (Nat.mul_le_mul_right M callerLen) + have ps := packets.trans (Nat.mul_le_mul_right (maxPacketBlocks ctx * M) + (terminalCompletion_bound ctx Q (some p))) + change callerCost (callerPositions ctx Q p) + packetsCost ctx Q (terminalCompletion ctx Q (some p)) ≤ _ + dsimp only [callerCost, packetsCost, pathFactor] + calc + _ ≤ ctx.callerOutputCap * M + RawWHIRKeys.maxDepth * (maxPacketBlocks ctx * M) := Nat.add_le_add c ps + _ = _ := by rw [Nat.add_mul, Nat.mul_assoc] + +/-- The prefix supplies an independent public message-length bound M. The +final selection is charged at its actual checked completion cost. -/ +theorem cost_bound_prefix (ctx : Context) (Q M : Nat) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) (bounded : ∀ raw ∈ requests, raw.1.1.val ≤ M) : + cost ctx Q requests final ≤ requests.length * (pathFactor ctx * M) + completionCost ctx Q final := by + rw [cost_expansion] + apply Nat.add_le_add_right + apply sum_map_le + intro raw member + cases recognized : RawWHIRKeys.recognize ctx Q raw with + | none => exact Nat.zero_le _ + | some pos => + apply completionCost_path_bound + rw [recognized_path_eq_raw_length ctx Q raw pos recognized] + exact bounded raw member + +/-- No circular Qtotal factor: M bounds prior public paths and Mf bounds the +selected final packet. Both may be strictly smaller than RawKey's domain Q. -/ +theorem cost_bound_pathCaps (ctx : Context) (Q M Mf : Nat) (requests : List (RawKey Q)) + (final : Option (Packet ctx Q)) (bounded : ∀ raw ∈ requests, raw.1.1.val ≤ M) + (finalBound : ∀ p, final = some p → pathCost (RawWHIRKeys.coordinate ctx p.val 0) ≤ Mf) : + cost ctx Q requests final ≤ requests.length * (pathFactor ctx * M) + pathFactor ctx * Mf := by + apply (cost_bound_prefix ctx Q M requests final bounded).trans + apply Nat.add_le_add_left + cases final with + | none => exact Nat.zero_le _ + | some p => exact completionCost_path_bound ctx Q Mf p (finalBound p rfl) + +end Whir.WHIRPublicBackfill + +namespace Whir.WHIRPublicBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling RawOracleCoupling.Concrete WHIRModeFinal +open TypedFiatShamirGame + +private instance (ctx : Context) (Q : Nat) : DecidableEq (GroupKey ctx Q) := inferInstance + +abbrev PublicCache (ctx : Context) (Q : Nat) := Cache (GroupKey ctx Q) (GroupAnswer ctx Q) + +/-- Executable finite-support cache reconstructed solely from explicit records. +No total raw table, simulator state, or private compiler cache is an argument. +Earlier duplicate cells take precedence; table consistency makes this choice +irrelevant on actual ideal executions. -/ +def entriesCache (ctx : Context) (Q : Nat) : + List (Sigma (GroupAnswer ctx Q)) → PublicCache ctx Q + | [] => fun _ => none + | entry :: rest => put (entriesCache ctx Q rest) entry.1 entry.2 + +def garbageEntry (ctx : Context) (Q : Nat) (answer : RawKey Q × Digest32) : + Option (Sigma (GroupAnswer ctx Q)) := + match recognized : RawWHIRKeys.recognize ctx Q answer.1 with + | none => some ⟨.inr ⟨answer.1,recognized⟩,answer.2⟩ + | some _ => none + +def observableEntries (ctx : Context) (Q : Nat) (answers : List (RawKey Q × Digest32)) + (records : List (Record ctx Q)) : List (Sigma (GroupAnswer ctx Q)) := + answers.filterMap (garbageEntry ctx Q) ++ records.flatMap (fun record => record.history) + +def observableCache (ctx : Context) (Q : Nat) (answers : List (RawKey Q × Digest32)) + (records : List (Record ctx Q)) : PublicCache ctx Q := + entriesCache ctx Q (observableEntries ctx Q answers records) + +theorem entriesCache_consistent (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (entries : List (Sigma (GroupAnswer ctx Q))) + (consistent : ∀ entry ∈ entries, (partition ctx Q).split table entry.1 = entry.2) + (key : GroupKey ctx Q) (answer : GroupAnswer ctx Q key) + (hit : entriesCache ctx Q entries key = some answer) : + (partition ctx Q).split table key = answer := by + induction entries with + | nil => simp [entriesCache] at hit + | cons entry rest ih => + by_cases same : key = entry.1 + · subst key + have equal : entry.2 = answer := by simpa only [entriesCache, put_self, Option.some.injEq] using hit + exact (consistent entry List.mem_cons_self).trans equal + · apply ih (fun e he => consistent e (List.mem_cons_of_mem entry he)) + simpa only [entriesCache, put_other _ _ _ _ same] using hit + +theorem entriesCache_covers (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (entries : List (Sigma (GroupAnswer ctx Q))) + (consistent : ∀ entry ∈ entries, (partition ctx Q).split table entry.1 = entry.2) + (key : GroupKey ctx Q) (member : key ∈ entries.map Sigma.fst) : + entriesCache ctx Q entries key = some ((partition ctx Q).split table key) := by + induction entries with + | nil => simp at member + | cons entry rest ih => + by_cases same : key = entry.1 + · subst key + rw [entriesCache, put_self, consistent entry List.mem_cons_self] + · rw [entriesCache, put_other _ _ _ _ same] + apply ih (fun e he => consistent e (List.mem_cons_of_mem entry he)) + simpa only [List.map_cons, List.mem_cons, same, false_or] using member + +theorem observableEntries_consistent (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (ps : List (Option (Packet ctx Q))) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (entry : Sigma (GroupAnswer ctx Q)) + (member : entry ∈ observableEntries ctx Q answers (idealRecords ctx Q table ps)) : + (partition ctx Q).split table entry.1 = entry.2 := by + rcases List.mem_append.mp member with garbage | packet + · obtain ⟨answer,ha,he⟩ := List.mem_filterMap.mp garbage + unfold garbageEntry at he + split at he + · cases Option.some.inj he + exact consistent answer ha + · contradiction + · obtain ⟨record,hr,he⟩ := List.mem_flatMap.mp packet + obtain ⟨p,_,rfl⟩ := List.mem_map.mp hr + exact idealCompletion_agrees ctx Q table p entry he + +theorem observableCache_consistent (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (ps : List (Option (Packet ctx Q))) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (key : GroupKey ctx Q) (answer : GroupAnswer ctx Q key) + (hit : observableCache ctx Q answers (idealRecords ctx Q table ps) key = some answer) : + (partition ctx Q).split table key = answer := + entriesCache_consistent ctx Q table _ (observableEntries_consistent ctx Q table answers ps consistent) + key answer hit + +/-- Every physically returned dependency is a genuine reconstructed cache hit. -/ +theorem observableCache_completion (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (ps : List (Option (Packet ctx Q))) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (p : Packet ctx Q) (selected : some p ∈ ps) + (key : GroupKey ctx Q) (member : key ∈ completionKeys ctx Q p) : + observableCache ctx Q answers (idealRecords ctx Q table ps) key = + some ((partition ctx Q).split table key) := by + apply entriesCache_covers ctx Q table _ + (observableEntries_consistent ctx Q table answers ps consistent) + apply List.mem_map.mpr + refine ⟨⟨key,(partition ctx Q).split table key⟩,?_,rfl⟩ + apply List.mem_append_right + apply List.mem_flatMap.mpr + refine ⟨⟨(),some p,idealCompletion ctx Q table (some p)⟩,?_, + idealCompletion_covers ctx Q table p key member⟩ + exact List.mem_map.mpr ⟨some p,selected,rfl⟩ + +theorem observableCache_garbage (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (ps : List (Option (Packet ctx Q))) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (raw : (partition ctx Q).Garbage) (answer : Digest32) (member : (raw.val,answer) ∈ answers) : + observableCache ctx Q answers (idealRecords ctx Q table ps) (.inr raw) = some (table raw.val) := by + apply entriesCache_covers ctx Q table _ + (observableEntries_consistent ctx Q table answers ps consistent) + apply List.mem_map.mpr + refine ⟨⟨.inr raw,answer⟩,List.mem_append_left _ ?_,rfl⟩ + apply List.mem_filterMap.mpr + refine ⟨(raw.val,answer),member,?_⟩ + have missing : RawWHIRKeys.recognize ctx Q raw.val = none := raw.property + unfold garbageEntry + split + · rfl + · rename_i pos recognized + have impossible : (none : Option (RawWHIRKeys.Position ctx Q)) = some pos := + missing.symm.trans recognized + cases impossible + +theorem observableCache_request (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (requests : List (RawKey Q)) (final : Option (Packet ctx Q)) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (raw : RawKey Q) (requested : raw ∈ requests) (pos : RawWHIRKeys.Position ctx Q) + (recognized : RawWHIRKeys.recognize ctx Q raw = some pos) + (key : GroupKey ctx Q) (member : key ∈ completionKeys ctx Q pos.1) : + observableCache ctx Q answers (idealRecords ctx Q table (selections ctx Q requests final)) key = + some ((partition ctx Q).split table key) := by + apply observableCache_completion ctx Q table answers _ consistent pos.1 _ key member + apply List.mem_append_left + exact List.mem_map.mpr ⟨raw,requested,by simp [recognized]⟩ + +theorem observableCache_final (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (requests : List (RawKey Q)) (p : Packet ctx Q) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (key : GroupKey ctx Q) (member : key ∈ completionKeys ctx Q p) : + observableCache ctx Q answers (idealRecords ctx Q table (selections ctx Q requests (some p))) key = + some ((partition ctx Q).split table key) := by + apply observableCache_completion ctx Q table answers _ consistent p _ key member + exact List.mem_append_right _ (by simp) + +end Whir.WHIRPublicBackfill + +namespace Whir.WHIRPublicBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling RawOracleCoupling.Concrete WHIRModeFinal + +/-- A partial oracle reconstructed from observed bytes; absence stays explicit. +There is no invented fallback answer for unseen raw requests. -/ +def publicRawAnswer (ctx : Context) (Q : Nat) (cache : PublicCache ctx Q) (raw : RawKey Q) : + Option Digest32 := + match recognized : RawWHIRKeys.recognize ctx Q raw with + | some pos => (cache (.inl pos.1)).map (fun packet => packet pos.2) + | none => cache (.inr ⟨raw,recognized⟩) + +theorem publicRawAnswer_observed (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (final : Option (Packet ctx Q)) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (raw : RawKey Q) (answer : Digest32) (member : (raw,answer) ∈ answers) : + publicRawAnswer ctx Q + (observableCache ctx Q answers (idealRecords ctx Q table (selections ctx Q (answers.map Prod.fst) final))) + raw = some answer := by + unfold publicRawAnswer + split + · rename_i pos recognized + have hit := observableCache_request ctx Q table answers (answers.map Prod.fst) final consistent + raw (List.mem_map.mpr ⟨(raw,answer),member,rfl⟩) pos recognized (.inl pos.1) + (List.mem_append_right _ (by simp)) + rw [hit, Option.map_some] + change some (table (RawWHIRKeys.encode ctx Q pos)) = some answer + rw [RawWHIRKeys.encode_recognize ctx Q raw pos recognized, consistent (raw,answer) member] + · rename_i recognized + have hit := observableCache_garbage ctx Q table answers + (selections ctx Q (answers.map Prod.fst) final) consistent ⟨raw,recognized⟩ answer member + exact hit.trans (congrArg some (consistent (raw,answer) member)) + +/-- On every publicly recognized request dependency, reconstruction equals the +actual compiler's immutable cached value, whenever that group was allocated. +The reconstruction hit is derived above, not supplied as a coverage premise. -/ +theorem observableCache_compiler_request (ctx : Context) (Q : Nat) (table : RawKey Q → Digest32) + (answers : List (RawKey Q × Digest32)) (requests : List (RawKey Q)) (selected : Option (Packet ctx Q)) + (consistent : ∀ answer ∈ answers, table answer.1 = answer.2) + (raw : RawKey Q) (requested : raw ∈ requests) (pos : RawWHIRKeys.Position ctx Q) + (recognized : RawWHIRKeys.recognize ctx Q raw = some pos) + {R : Type} {K : Nat} (final : R → Option (Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (RawKey Q) (fun _ => Digest32) R K) + (key : GroupKey ctx Q) (member : key ∈ completionKeys ctx Q pos.1) + (answer : GroupAnswer ctx Q key) + (hit : (tableExecution ctx Q final program table).2 key = some answer) : + observableCache ctx Q answers (idealRecords ctx Q table (selections ctx Q requests selected)) key = + some answer := by + rw [observableCache_request ctx Q table answers requests selected consistent raw requested pos recognized key member] + exact congrArg some (tableExecution_cache ctx Q final program table key answer hit) + +end Whir.WHIRPublicBackfill + +namespace Whir.WHIRPublicBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open RawOracleCoupling.Concrete WHIRModeFinal + +/-- A noncircular all-answer prefix/suffix certificate with independent public +source path and final path caps. Q only indexes the raw-key domain. -/ +theorem bind_backfill_path_counted (ctx : Context) (Q A N M Mf : Nat) {R : Type} + (program : Program R) (requests : R → List (RawKey Q)) (final : R → Option (Packet ctx Q)) + (before : Counts A program) (lengthBound : ∀ r, (requests r).length ≤ N) + (paths : ∀ r raw, raw ∈ requests r → raw.1.1.val ≤ M) + (finalPaths : ∀ r p, final r = some p → pathCost (RawWHIRKeys.coordinate ctx p.val 0) ≤ Mf) : + Counts (A + (N * (pathFactor ctx * M) + pathFactor ctx * Mf)) + (WHIRModeFinal.bind program (fun r => backfill ctx Q r (requests r) (final r))) := by + apply bind_backfill_counted ctx Q program requests final A _ before + intro r + exact (cost_bound_pathCaps ctx Q M Mf (requests r) (final r) (paths r) (finalPaths r)).trans + (Nat.add_le_add_right (Nat.mul_le_mul_right _ (lengthBound r)) _) + +private def cacheSmoke : IO Unit := do + let some early := smokePacket 3 false | throw (IO.userError "early packet rejected") + let some clone := smokePacket 4 false | throw (IO.userError "clone packet rejected") + let some final := smokePacket 3 true | throw (IO.userError "final packet rejected") + let some prior := (RawWHIRKeys.callerGroups smokeContext 4096 final).head? | + throw (IO.userError "missing prior caller output") + let garbage : RawKey 4096 := + (⟨⟨0,by decide⟩,Fin.elim0⟩,⟨⟨0,by decide⟩,Fin.elim0⟩) + let raw (p : Packet smokeContext 4096) := + RawWHIRKeys.encode smokeContext 4096 ⟨p,⟨0,RawWHIRKeys.blocks_positive smokeContext p.val⟩⟩ + let requests := [prior.val,raw early,raw clone,garbage,raw early] + let table : RawKey 4096 → Digest32 := fun key _ => + ⟨(key.1.1.val + key.2.1.val) % 256,Nat.mod_lt _ (by decide)⟩ + let answers := requests.map (fun key => (key,table key)) + let charge := cost smokeContext 4096 requests (some final) + if bounded : charge ≤ 4096 then + let sim : Simulator 4096 Unit Unit := ⟨id,fun state _ => .done (state,fun _ => 0)⟩ + let execution := runIdeal sim table smokeContext.iv () + (backfill smokeContext 4096 (37 : Nat) requests (some final)) charge bounded + (backfill_counted smokeContext 4096 37 requests (some final)) + let cache := observableCache smokeContext 4096 answers execution.view.result.records + unless requests.all (fun key => decide (publicRawAnswer smokeContext 4096 cache key = some (table key))) do + throw (IO.userError "observed raw cache reconstruction failed") + unless decide (publicRawAnswer smokeContext 4096 cache (raw final) = some (table (raw final))) do + throw (IO.userError "final packet cache reconstruction failed") + let sourceCap := (requests.map (fun key => key.1.1.val)).foldl max 0 + let finalCap := pathCost (RawWHIRKeys.coordinate smokeContext final.val 0) + let overhead := requests.length * (pathFactor smokeContext * sourceCap) + pathFactor smokeContext * finalCap + unless charge ≤ overhead && sourceCap == 3 && finalCap == 4 do + throw (IO.userError "independent path-cap overhead failed") + IO.println s!"public cache smoke: observed raw replies and final reconstructed; source path cap={sourceCap}, final path cap={finalCap}, key domain=4096, maxDepth={RawWHIRKeys.maxDepth}, maxBlocks={maxPacketBlocks smokeContext}, overhead={overhead}, actual cost={charge}" + else throw (IO.userError "cache smoke budget exceeded") + +#eval cacheSmoke + +end Whir.WHIRPublicBackfill diff --git a/verification/whir/Whir/WHIRROM.lean b/verification/whir/Whir/WHIRROM.lean new file mode 100644 index 000000000..9d0e94539 --- /dev/null +++ b/verification/whir/Whir/WHIRROM.lean @@ -0,0 +1,454 @@ +import Whir.WHIRFiatShamir +import Whir.WHIRHistory +import Whir.TypedOracleCompiler +import Whir.DuplexRefinement +import Whir.WHIRReplay +import Whir.WHIRHistoryKey + +/-! Source-pinned mode interface for the classical typed full-transcript game. +The mode assumption is a real-versus-ideal oracle-view distinguishing bound, +not an assumption about a PCS acceptance predicate. -/ +namespace Whir.WHIRROM +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame WHIRFiatShamir +open Classical + +abbrev Key (p : Profile) := + TypedFiatShamirGame.FullInput Digest32 WHIRHistory.Pending (Coordinate (config p)) Sample + +def query (p : Profile) : Digest32 × List WHIRHistory.Pending → Coordinate (config p) := + WHIRHistory.queryFor (config p) + +/-- The canonical syntax recovery model shared with the physical key-injection +proof. The domain and statement are part of the framed history. -/ +def beforeModel (p : Profile) (domain : Digest32) (key : Key p) : DuplexRefinement.Model := + WHIRHistoryKey.beforeModel (WHIRHistoryKey.standaloneWidth (config p)) + domain key.statement key.messages +theorem beforeModel_consumed (p : Profile) (domain : Digest32) (key : Key p) + (normal : WHIRHistoryKey.Normal key.messages) : (beforeModel p domain key).consumed = 0 := by + rcases key with ⟨statement,messages,ancestors⟩ + change WHIRHistoryKey.Normal messages at normal + unfold beforeModel + cases normal with + | initial => rfl + | @cons ps prior m nonempty => + have bytes : WHIRHistory.scalarBytes m.scalars ≠ [] := + fun h => nonempty ((WHIRHistory.scalarBytes_empty _).mp h) + simp only [WHIRHistoryKey.beforeModel, WHIRHistory.pendingModel] + cases m.nonce <;> simp [DuplexRefinement.modelAbsorb, bytes, DuplexRefinement.modelNonce] + +theorem stream_ofFn (compression : DuplexRefinement.Compression) (cv : Digest32) + (offset n : Nat) : + DuplexRefinement.stream compression cv offset n = + List.ofFn (fun i : Fin n => DuplexRefinement.outputBlock compression cv + ((offset+i.val)/32) ⟨(offset+i.val)%32,Nat.mod_lt _ (by decide)⟩) := by + induction n generalizing offset with + | zero => rfl + | succ n ih => + simp only [DuplexRefinement.stream, List.ofFn_succ, Fin.val_zero, Nat.add_zero] + rw [ih] + congr 1 + apply congrArg List.ofFn + funext i + simp only [Fin.val_succ] + simp only [Nat.add_left_comm, Nat.add_comm] + +/-- Byte positions are disjoint scalar24 slices. In particular, lambda follows +all query chunks in the same vector; it is not another allocation. -/ +def slices {c : Config} (q : Coordinate c) (bytes : List Byte) : Bytes q := + match q with + | .initial => fun j => bytes[j.val]! + | .fold _ _ => fun j => bytes[j.val]! + | .ood _ _ => fun i j => bytes[24*i.val+j.val]! + | .query i => (fun k j => bytes[24*k.val+j.val]!, + fun j => bytes[24*queryChunks c i+j.val]!) + | .tail _ => fun j => bytes[j.val]! + +/-- The concrete #552 framed-history stream; the reference oracle recomputes +full root-to-terminal paths, so resource accounting cannot claim cached work. -/ +def modeOracle (p : Profile) (compression : DuplexRefinement.Compression) + (iv domain : Digest32) : TypedFiatShamirGame.Oracle (A := Sample) (query p) := fun key => + let m := beforeModel p domain key + let q := query p (key.statement, key.messages) + codec q (slices q (DuplexRefinement.stream compression + (DuplexRefinement.evalHistory compression iv (DuplexRefinement.closeRun m).history) + m.consumed (24 * WHIRHistory.scalarCount q))) + +/-- This is an equality to the actual checked streaming operation, not a parser +or mode-correctness hypothesis. Reachability/limits are checked separately. -/ +theorem modeOracle_squeeze (p : Profile) (compression : DuplexRefinement.Compression) + (iv domain : Digest32) (key : Key p) (state next : DuplexRefinement.State) + (bytes : List Byte) + (represents : DuplexRefinement.Represents compression iv (beforeModel p domain key) state) + (squeezed : DuplexRefinement.squeeze compression state + (24 * WHIRHistory.scalarCount (query p (key.statement, key.messages))) = .ok (next, bytes)) : + modeOracle p compression iv domain key = + codec (query p (key.statement, key.messages)) + (slices (query p (key.statement, key.messages)) bytes) := by + have h := DuplexRefinement.squeeze_frame_bytes compression iv (beforeModel p domain key) + state next represents _ bytes squeezed + unfold modeOracle + rw [h] + +def appendScalar (n : Nat) : + ((Fin n → Scalar24) × Scalar24) ≃ (Fin (n+1) → Scalar24) where + toFun p := Fin.lastCases p.2 p.1 + invFun f := (fun i => f i.castSucc, f (Fin.last n)) + left_inv p := by + apply Prod.ext + · funext i + simp only [Fin.lastCases_castSucc] + · simp only [Fin.lastCases_last] + right_inv f := by + funext i + refine Fin.lastCases ?_ (fun j => ?_) i + · exact Fin.lastCases_last + · exact Fin.lastCases_castSucc j + +def scalarVector {c : Config} (q : Coordinate c) : + Bytes q ≃ (Fin (WHIRHistory.scalarCount q) → Scalar24) := + match q with + | .initial => (Equiv.funUnique (Fin 1) Scalar24).symm + | .fold _ _ => (Equiv.funUnique (Fin 1) Scalar24).symm + | .ood _ _ => Equiv.refl _ + | .query i => appendScalar (queryChunks c i) + | .tail _ => (Equiv.funUnique (Fin 1) Scalar24).symm + +/-- Bijection to the actual contiguous field-byte region, before independent +whole-block padding. There are no per-tag uniformity shortcuts. -/ +def packedBytes {c : Config} (q : Coordinate c) : + Bytes q ≃ (Fin (WHIRHistory.scalarCount q * 24) → Byte) := + (scalarVector q).trans + ((Equiv.curry (Fin (WHIRHistory.scalarCount q)) (Fin 24) Byte).symm.trans + (Equiv.arrowCongr finProdFinEquiv (Equiv.refl Byte))) + +theorem packed_average {c : Config} (q : Coordinate c) (f : Sample q → ℚ) : + average (fun bytes : Fin (WHIRHistory.scalarCount q * 24) → Byte => + f (codec q ((packedBytes q).symm bytes))) = average f := by + have h : average (fun bytes : Fin (WHIRHistory.scalarCount q * 24) → Byte => + f (codec q ((packedBytes q).symm bytes))) = + average (fun bytes : Bytes q => f (codec q bytes)) := by + unfold average + rw [Fintype.sum_equiv (packedBytes q).symm + (fun bytes => f (codec q ((packedBytes q).symm bytes))) + (fun bytes : Bytes q => f (codec q bytes)) (fun _ => rfl), + Fintype.card_congr (packedBytes q).symm] + exact h.trans (codec_average q f) + +private theorem byte_at {n : Nat} (bytes : Fin n → Byte) (i : Nat) (hi : i < n) : + (List.ofFn bytes)[i]! = bytes ⟨i, hi⟩ := by + rw [getElem!_pos _ _ (by simpa using hi)] + exact List.getElem_ofFn _ + +theorem slices_packed {c : Config} (q : Coordinate c) + (bytes : Fin (WHIRHistory.scalarCount q * 24) → Byte) : + slices q (List.ofFn bytes) = (packedBytes q).symm bytes := by + cases q with + | initial => + funext j + change (List.ofFn bytes)[j.val]! = bytes j + exact byte_at bytes j.val j.isLt + | fold i k => + funext j + change (List.ofFn bytes)[j.val]! = bytes j + exact byte_at bytes j.val j.isLt + | tail k => + funext j + change (List.ofFn bytes)[j.val]! = bytes j + exact byte_at bytes j.val j.isLt + | ood i k => + funext l j + have h : 24*l.val+j.val < remaining c i * 24 := by omega + change (List.ofFn bytes)[24*l.val+j.val]! = bytes ⟨j.val+24*l.val, by simp only [WHIRHistory.scalarCount]; omega⟩ + rw [byte_at bytes _ h] + congr 1 + apply Fin.ext + dsimp only + omega + | query i => + apply Prod.ext + · funext l j + have h : 24*l.val+j.val < (queryChunks c i+1)*24 := by omega + change (List.ofFn bytes)[24*l.val+j.val]! = bytes ⟨j.val+24*l.val, by simp only [WHIRHistory.scalarCount]; omega⟩ + rw [byte_at bytes _ h] + congr 1 + apply Fin.ext + dsimp only + omega + · funext j + have h : 24*queryChunks c i+j.val < (queryChunks c i+1)*24 := by omega + change (List.ofFn bytes)[24*queryChunks c i+j.val]! = + bytes ⟨j.val+24*queryChunks c i, by simp only [WHIRHistory.scalarCount]; omega⟩ + rw [byte_at bytes _ h] + congr 1 + apply Fin.ext + dsimp only + omega + +theorem slices_average {c : Config} (q : Coordinate c) (f : Sample q → ℚ) : + average (fun bytes : Fin (WHIRHistory.scalarCount q * 24) → Byte => + f (codec q (slices q (List.ofFn bytes)))) = average f := by + simp_rw [slices_packed] + exact packed_average q f + +def splitBytes (n m : Nat) : + (Fin (n+m) → Byte) ≃ (Fin n → Byte) × (Fin m → Byte) where + toFun f := (fun i => f (i.castAdd m), fun j => f (j.natAdd n)) + invFun p := Fin.addCases p.1 p.2 + left_inv f := by + funext i + refine Fin.addCases (fun j => ?_) (fun j => ?_) i <;> simp + right_inv p := by + apply Prod.ext <;> funext i <;> simp + +/-- Projection from a padded maximal byte vector preserves the exact payload +distribution. Unused final-block bytes never become additional challenges. -/ +theorem padded_average {c : Config} (q : Coordinate c) (padding : Nat) + (f : Sample q → ℚ) : + average (fun bytes : Fin (WHIRHistory.scalarCount q * 24 + padding) → Byte => + f (codec q (slices q (List.ofFn (fun i => bytes (i.castAdd padding)))))) = + average f := by + let n := WHIRHistory.scalarCount q * 24 + let g := fun bytes : Fin n → Byte => f (codec q (slices q (List.ofFn bytes))) + have hs : average (fun bytes : Fin (n+padding) → Byte => + g (fun i => bytes (i.castAdd padding))) = + average (fun pair : (Fin n → Byte) × (Fin padding → Byte) => g pair.1) := by + unfold average + rw [Fintype.sum_equiv (splitBytes n padding) + (fun bytes => g (fun i => bytes (i.castAdd padding))) + (fun pair => g pair.1) (fun _ => rfl), Fintype.card_congr (splitBytes n padding)] + exact hs.trans ((padding_average g).trans (slices_average q f)) + +def blockBytes (n : Nat) : (Fin n → Digest32) ≃ (Fin (n*32) → Byte) := + (Equiv.curry (Fin n) (Fin 32) Byte).symm.trans + (Equiv.arrowCongr finProdFinEquiv (Equiv.refl Byte)) + +def outputBlocks {c : Config} (q : Coordinate c) : Nat := + (WHIRHistory.scalarCount q * 24 + 31) / 32 + +theorem payload_le_outputBlocks {c : Config} (q : Coordinate c) : + WHIRHistory.scalarCount q * 24 ≤ outputBlocks q * 32 := by + unfold outputBlocks + omega + +def blockDecode {c : Config} (q : Coordinate c) (raw : Fin (outputBlocks q) → Digest32) : + Sample q := + codec q (slices q (List.ofFn (fun i : Fin (WHIRHistory.scalarCount q * 24) => + blockBytes (outputBlocks q) raw ⟨i.val, lt_of_lt_of_le i.isLt (payload_le_outputBlocks q)⟩))) + +/-- Exact projection of independently uniform 32-byte output blocks to the +maximal WHIR vector. A partial last block contributes no additional event. -/ +theorem block_average {c : Config} (q : Coordinate c) (f : Sample q → ℚ) : + average (fun raw : Fin (outputBlocks q) → Digest32 => f (blockDecode q raw)) = + average f := by + let n := WHIRHistory.scalarCount q * 24 + let total := outputBlocks q * 32 + have enough : n ≤ total := payload_le_outputBlocks q + have size : n+(total-n) = total := by omega + let payload := fun bytes : Fin total → Byte => + f (codec q (slices q (List.ofFn (fun i : Fin n => + bytes ⟨i.val, lt_of_lt_of_le i.isLt enough⟩)))) + have first : average (fun raw : Fin (outputBlocks q) → Digest32 => + f (blockDecode q raw)) = average payload := by + unfold average + rw [Fintype.sum_equiv (blockBytes (outputBlocks q)) + (fun raw => f (blockDecode q raw)) payload (fun _ => rfl), + Fintype.card_congr (blockBytes (outputBlocks q))] + have second : average payload = + average (fun bytes : Fin (n+(total-n)) → Byte => + f (codec q (slices q (List.ofFn (fun i : Fin n => bytes (i.castAdd (total-n))))))) := by + let e := Equiv.arrowCongr (finCongr size.symm) (Equiv.refl Byte) + unfold average + rw [Fintype.sum_equiv e payload + (fun bytes => f (codec q (slices q + (List.ofFn (fun i : Fin n => bytes (i.castAdd (total-n))))))) (fun _ => rfl), + Fintype.card_congr e] + exact first.trans (second.trans (padded_average q (total-n) f)) + +abbrev Packet {p : Profile} (key : Key p) := + Fin (outputBlocks (query p (key.statement,key.messages))) → Digest32 + +/-- Replace each fresh maximal-vector allocation by its complete packet of +32-byte outputs. Cache hits remain absent from the allocation tree. -/ +def packetize {p : Profile} {R : Type*} {n : Nat} : + TypedOracleCompiler.Sampling (Key p) (TypedOracleCompiler.Fiber (query p)) R n → + TypedOracleCompiler.Sampling (Key p) Packet R n + | .ret r => .ret r + | .draw key next => .draw key (fun raw => + packetize (next (blockDecode (query p (key.statement,key.messages)) raw))) + +theorem packetize_eval {p : Profile} {R : Type*} {n : Nat} + (oracle : (key : Key p) → Packet key) + (tree : TypedOracleCompiler.Sampling (Key p) (TypedOracleCompiler.Fiber (query p)) R n) : + TypedOracleCompiler.Sampling.eval oracle (packetize tree) = + TypedOracleCompiler.Sampling.eval (Answer := TypedOracleCompiler.Fiber (query p)) + (fun key : Key p => blockDecode (query p (key.statement,key.messages)) (oracle key)) tree := by + induction tree with + | ret r => rfl + | draw key next ih => + simp only [packetize, TypedOracleCompiler.Sampling.eval] + exact ih _ + +/-- Equality for every terminal payoff, not merely the PCS failure indicator. -/ +theorem packetize_distribution {p : Profile} {R : Type*} {n : Nat} + (payoff : R → ℚ) + (tree : TypedOracleCompiler.Sampling (Key p) (TypedOracleCompiler.Fiber (query p)) R n) : + TypedOracleCompiler.Sampling.expectation payoff (packetize tree) = + TypedOracleCompiler.Sampling.expectation payoff tree := by + induction tree with + | ret r => rfl + | draw key next ih => + simp only [packetize, TypedOracleCompiler.Sampling.expectation] + simp_rw [ih] + exact block_average (query p (key.statement,key.messages)) + (fun a => TypedOracleCompiler.Sampling.expectation payoff (next a)) + +def physicalPacket (p : Profile) (compression : DuplexRefinement.Compression) + (iv domain : Digest32) (key : Key p) : Packet key := fun i => + DuplexRefinement.evalCoordinate compression iv + (WHIRHistoryKey.outputKey (WHIRHistoryKey.standaloneWidth (config p)) + domain key.statement key.messages i.val) + +/-- Whole-packet construction queries evaluate to exactly the bytes consumed +by the pinned streaming implementation, not a separate transcript oracle. -/ +theorem modeOracle_packet (p : Profile) (compression : DuplexRefinement.Compression) + (iv domain : Digest32) (key : Key p) (normal : WHIRHistoryKey.Normal key.messages) : + modeOracle p compression iv domain key = + blockDecode (query p (key.statement,key.messages)) + (physicalPacket p compression iv domain key) := by + unfold modeOracle + dsimp only + rw [beforeModel_consumed p domain key normal, stream_ofFn] + simp only [Nat.zero_add] + unfold blockDecode + rw [Nat.mul_comm 24] + rfl + +def keyBad (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (key : Key p) (x : Sample (query p (key.statement,key.messages))) : Prop := + match WHIRReplay.decode p catalog roots key with + | none => False + | some replay => allocationBad (WHIRReplay.request key replay) x + +theorem key_sparse (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + (key : Key p) : + average (fun x => if keyBad p catalog roots key x then 1 else 0) ≤ eta p := by + cases decoded : WHIRReplay.decode p catalog roots key with + | none => simp only [keyBad, decoded, ↓reduceIte, average_const]; exact eta_nonneg p + | some replay => + simp only [keyBad, decoded] + convert allocation_sparse p (WHIRReplay.request key replay) using 1 + rfl + +/-- The predicate runs the actual causal verifier on the concretely parsed +canonical transcript and tests the commitment-time candidate list. -/ +def FalseOpening {p : Profile} (r : WHIRReplay.Replay p) : Prop := + experiment r.statement.input (CausalStrategy.indexedStrategy r.replies) r.tape = true ∧ + ¬ ∃ w ∈ InitialCandidates.witnesses (config p) r.statement.lanes r.statement.root, + ∀ claim ∈ r.statement.claims.toList, + dot (paddedWitness (config p) r.statement.lanes w) claim.weight = claim.value + +abbrev TerminalView (p : Profile) (B : Nat) := + TypedOracleCompiler.Terminal (A := @Sample (config p)) (query p) B + +/-- A final submission must contain the entire fixed challenge schedule, and +must parse under the actual scalar decoder. No algebraic success defines syntax. -/ +def TerminalFailure (p : Profile) (catalog : WHIRReplay.Catalog p) (roots : WHIRReplay.Roots) + {B : Nat} (result : TerminalView p B) : Prop := + ∃ head past, ∃ x : Sample (query p (result.request.statement,result.request.messages)), + ∃ replay : WHIRReplay.Replay p, + result.allocation.history = + (head,⟨query p (result.request.statement,result.request.messages),x⟩)::past ∧ + result.request.messages.length = WHIRHistory.depth (config p) ∧ + WHIRReplay.decode p catalog roots + ⟨result.request.statement,result.request.messages,past⟩ = some replay ∧ + FalseOpening (WHIRReplay.finish + ⟨result.request.statement,result.request.messages,past⟩ replay x) + +/-- Accepted false final replays are covered by an actual fresh allocation in +the compiler trace, including when that allocation was made on a cloned branch. -/ +theorem recorded_terminal_cover (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) {B : Nat} + (trace : List (Sigma (TypedOracleCompiler.Fiber (query p)))) (result : TerminalView p B) + (recorded : TypedOracleCompiler.HistoryRecorded (query p) result.request.statement + trace result.request.messages result.allocation.history) + (failed : TerminalFailure p catalog roots result) : + ∃ ka ∈ trace, keyBad p catalog roots ka.1 ka.2 := by + obtain ⟨head,past,x,replay,history,length,decoded,failed⟩ := failed + let key : Key p := ⟨result.request.statement,result.request.messages,past⟩ + let final := WHIRReplay.finish key replay x + change FalseOpening final at failed + obtain ⟨q,bad⟩ := accepted_false_prefix_cover p final.statement + (CausalStrategy.indexedStrategy final.replies) final.tape failed.1 failed.2 + let i := result.request.messages.length - position q - 1 + have bound : position q < result.request.messages.length := by + rw [length] + exact WHIRHistory.position_lt_depth q + have hi : i < key.messages.length := by dsimp [i,key]; omega + rw [history] at recorded + obtain ⟨m,tail,ancestors,a,before,_,allocated,parsed,agree,sample,pos⟩ := + WHIRReplay.trace_realization catalog roots key replay decoded x head trace recorded i hi + have qeq : q = query p (key.statement,m::tail) := by + apply CausalPrefix.position_injective + change position q = position (WHIRReplay.query p (key.statement,m::tail)) + rw [pos] + dsimp [i,key] + omega + subst q + refine ⟨⟨⟨key.statement,m::tail,ancestors⟩,a⟩,allocated,?_⟩ + simp only [keyBad, parsed] + change allocationBad (requestOfTape before.statement + (CausalStrategy.indexedStrategy before.replies) + (query p (key.statement,m::tail)) before.tape) a + have congr := CausalStrategy.allocationBad_indexed_congr p before.statement + before.replies final.replies (query p (key.statement,m::tail)) + before.tape final.tape a agree.replies agree.tape + apply congr.mpr + rw [agree.statement] + exact Eq.mp (congrArg (fun value : Sample (query p (key.statement,m::tail)) => + allocationBad (requestOfTape final.statement (CausalStrategy.indexedStrategy final.replies) + (query p (key.statement,m::tail)) final.tape) value) sample) bad + +theorem terminal_cover (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) {B K : Nat} + (machine : TypedOracleCompiler.Machine Digest32 WHIRHistory.Pending + (@Sample (config p)) B K) (trace result) + (run : TypedOracleCompiler.Sampling.Runs + (TypedOracleCompiler.compile (query p) machine (fun _ => none)) trace result) + (failed : TerminalFailure p catalog roots result) : + ∃ ka ∈ trace, keyBad p catalog roots ka.1 ka.2 := + recorded_terminal_cover p catalog roots trace result + (TypedOracleCompiler.final_history_in_trace (query p) machine run) failed + +/-- Full adaptive stopped-ROM list binding. The only hypothesis on a machine is +the syntactic request-depth cap encoded by its type; the final verifier run is +included in `K+1`. There is no supplied acceptance-to-event implication. -/ +theorem rom_list_binding (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) {B K : Nat} + (machine : TypedOracleCompiler.Machine Digest32 WHIRHistory.Pending + (@Sample (config p)) B K) : + TypedOracleCompiler.Sampling.failureProbability (TerminalFailure p catalog roots) + (TypedOracleCompiler.compile (query p) machine (fun _ => none)) ≤ + min 1 (((B*(K+1) : Nat) : ℚ) * eta p) := by + apply le_min + · apply TypedOracleCompiler.Sampling.expectation_le_one + intro result + split <;> norm_num + · exact TypedOracleCompiler.compiler_failure_bound (query p) machine + (keyBad p catalog roots) (TerminalFailure p catalog roots) + (eta p) (eta_nonneg p) (key_sparse p catalog roots) + (terminal_cover p catalog roots machine) + +theorem rom_list_binding_numeric (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) {B K : Nat} + (machine : TypedOracleCompiler.Machine Digest32 WHIRHistory.Pending + (@Sample (config p)) B K) : + TypedOracleCompiler.Sampling.failureProbability (TerminalFailure p catalog roots) + (TypedOracleCompiler.compile (query p) machine (fun _ => none)) ≤ + min 1 (((B*(K+1) : Nat) : ℚ) / 2^79) := by + apply (rom_list_binding p catalog roots machine).trans + apply min_le_min_left + simpa only [div_eq_mul_inv, one_div, one_mul] using + mul_le_mul_of_nonneg_left (eta_le p) (Nat.cast_nonneg (B*(K+1))) + +end Whir.WHIRROM diff --git a/verification/whir/Whir/WHIRRawHistory.lean b/verification/whir/Whir/WHIRRawHistory.lean new file mode 100644 index 000000000..9355828f2 --- /dev/null +++ b/verification/whir/Whir/WHIRRawHistory.lean @@ -0,0 +1,146 @@ +import Whir.WHIRRawReplay + +/-! Canonical raw-cache provenance becomes the actual typed full-input history. -/ +namespace Whir.WHIRRawHistory +open RawOracleCoupling RawOracleCoupling.Concrete WHIRRawReplay +open TypedOracleCompiler TypedFiatShamirGame +open RawWHIRKeys + +variable (ctx : Context) (stack : ctx.mode = .stack) (Q : Nat) + +abbrev Ancestors (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) (packet : Packet ctx Q) := + dependencyHistory (dependencyKeys ctx Q) cache (.inl packet) + +abbrev CallerHistory (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) (packet : Packet ctx Q) := + (callerGroups ctx Q packet).filterMap + (fun raw => (cache (.inr raw)).map (fun answer => (⟨.inr raw,answer⟩ : Sigma (GroupAnswer ctx Q)))) + +theorem ancestors_eq (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) (packet : Packet ctx Q) : + Ancestors ctx Q cache packet = CallerHistory ctx Q cache packet ++ + (RawWHIRKeys.ancestors ctx Q packet).filterMap + (fun p => (cache (.inl p)).map (fun raw => (⟨.inl p,raw⟩ : Sigma (GroupAnswer ctx Q)))) := by + simp only [Ancestors, dependencyHistory, dependencyKeys, Partition.dependencies, + schedule, callerPlan, List.filterMap_append, List.filterMap_map] + apply congrArg₂ List.append + · exact List.filterMap_map + · rfl + +theorem decode_callers (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (calls : List (partition ctx Q).Garbage) : + decodeHistory ctx stack Q (calls.filterMap + (fun raw => (cache (.inr raw)).map (fun answer => (⟨.inr raw,answer⟩ : Sigma (GroupAnswer ctx Q))))) = [] := by + induction calls with + | nil => rfl + | cons raw rest ih => + cases hit : cache (.inr raw) <;> + simp [List.filterMap_cons, hit, decodeHistory, decodeEntry] at ih ⊢ <;> exact ih + +/-- Caller values are privately available in the raw annotation, while their +garbage tags prevent them from changing the canonical typed WHIR ancestors. -/ +theorem decoded_ancestors_eq (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (packet : Packet ctx Q) : + decodeHistory ctx stack Q (Ancestors ctx Q cache packet) = + decodeHistory ctx stack Q ((RawWHIRKeys.ancestors ctx Q packet).filterMap + (fun p => (cache (.inl p)).map (fun raw => (⟨.inl p,raw⟩ : Sigma (GroupAnswer ctx Q))))) := by + rw [ancestors_eq] + have callers := decode_callers ctx stack Q cache (callerGroups ctx Q packet) + simp only [decodeHistory, List.filterMap_append, List.reverse_append] + change _ ++ decodeHistory ctx stack Q (CallerHistory ctx Q cache packet) = _ + rw [callers, List.append_nil] + + theorem ancestor_history_append (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (packet parent : Packet ctx Q) (raw : GroupAnswer ctx Q (.inl parent)) + (chain : RawWHIRKeys.ancestors ctx Q packet = RawWHIRKeys.ancestors ctx Q parent ++ [parent]) + (hit : cache (.inl parent) = some raw) : + decodeHistory ctx stack Q (Ancestors ctx Q cache packet) = + packetEntry ctx stack Q parent raw :: decodeHistory ctx stack Q (Ancestors ctx Q cache parent) := by + rw [decoded_ancestors_eq, chain, List.filterMap_append, decoded_ancestors_eq] + simp only [List.filterMap_cons, hit, Option.map_some, List.filterMap_nil] + simp [decodeHistory, decodeEntry] + + theorem allocated_decoded (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (trace : List (Sigma (AllocationAnswer ctx Q))) + (recorded : Recorded (dependencyKeys ctx Q) cache trace) + (packet : Packet ctx Q) (raw : GroupAnswer ctx Q (.inl packet)) + (hit : cache (.inl packet) = some raw) : + (⟨allocationKey ctx stack Q packet (Ancestors ctx Q cache packet), + decodePacket ctx stack Q packet raw⟩ : Sigma GlobalAnswer) ∈ decodedTrace ctx stack Q trace := by + apply List.mem_filterMap.mpr + exact ⟨_, (recorded _ _ hit).2, rfl⟩ + + +theorem cons_packet (packet : Packet ctx Q) (raw : GroupAnswer ctx Q (.inl packet)) + (past : List GlobalEntry) (trace : List (Sigma GlobalAnswer)) + (prior : HistoryRecorded globalQuery (packet.val.profile,RawWHIRKeys.entry ctx packet.val) trace + packet.val.messages.tail past) + (allocated : (⟨⟨(packet.val.profile,RawWHIRKeys.entry ctx packet.val),packet.val.messages,past⟩, + decodePacket ctx stack Q packet raw⟩ : Sigma GlobalAnswer) ∈ trace) : + HistoryRecorded globalQuery (packet.val.profile,RawWHIRKeys.entry ctx packet.val) trace + packet.val.messages (packetEntry ctx stack Q packet raw :: past) := by + rcases packet with ⟨⟨statement,profile,messages,entryFrames⟩,valid⟩ + cases messages with + | nil => exact (valid.2.1 rfl).elim + | cons m tail => exact .cons _ prior allocated + +theorem recorded_history (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (trace : List (Sigma (AllocationAnswer ctx Q))) + (recorded : Recorded (dependencyKeys ctx Q) cache trace) + (packet : Packet ctx Q) (raw : GroupAnswer ctx Q (.inl packet)) + (hit : cache (.inl packet) = some raw) : + HistoryRecorded globalQuery (packet.val.profile,RawWHIRKeys.entry ctx packet.val) + (decodedTrace ctx stack Q trace) packet.val.messages + (packetEntry ctx stack Q packet raw :: decodeHistory ctx stack Q (Ancestors ctx Q cache packet)) := by + generalize hn : packet.val.messages.length = n + induction n using Nat.strong_induction_on generalizing packet with + | h n ih => + apply cons_packet ctx stack Q packet raw _ _ + · by_cases empty : packet.val.messages.drop 1 = [] + · have one : packet.val.messages.length = 1 := by + have hp := List.length_pos_iff.mpr packet.property.2.1 + have h := congrArg List.length empty + simp only [List.length_drop, List.length_nil] at h + omega + have ancestorsNil := ancestors_singleton ctx Q packet one + have pastNil : decodeHistory ctx stack Q (Ancestors ctx Q cache packet) = [] := by + rw [decoded_ancestors_eq, ancestorsNil] + rfl + have tailNil : packet.val.messages.tail = [] := by simpa only [List.drop_one] using empty + simp only [pastNil, tailNil] + exact .nil + · let parent := dropPacket ctx Q packet 1 empty + have chain : ancestors ctx Q packet = ancestors ctx Q parent ++ [parent] := + ancestors_drop_one ctx Q packet empty + have parentMem : (.inl parent : GroupKey ctx Q) ∈ + dependencyKeys ctx Q (.inl packet) := by + apply List.mem_append_right + change Sum.inl parent ∈ (ancestors ctx Q packet).map Sum.inl + rw [chain] + simp + obtain ⟨parentRaw,parentHit⟩ := (recorded _ _ hit).1 _ parentMem + have shorter : parent.val.messages.length < n := by + dsimp [parent,dropPacket] + rw [List.length_drop] + have hp := List.length_pos_iff.mpr packet.property.2.1 + omega + have previous := ih parent.val.messages.length shorter parent parentRaw parentHit rfl + rw [ancestor_history_append ctx stack Q cache packet parent parentRaw chain parentHit] + simpa only [parent,dropPacket, RawWHIRKeys.entry, List.drop_one] using previous + · exact allocated_decoded ctx stack Q cache trace recorded packet raw hit + +/-- Actual final completion supplies both the cache entry and the fully decoded +canonical history theorem. No correctness/provenance certificate is an input. -/ +theorem final_history {R : Type} {K : Nat} (final : R → Option (Packet ctx Q)) + (program : Sampling (DuplexModeGame.RawKey Q) (fun _ => FiatShamirGame.Digest32) R K) + {trace result} (run : Sampling.Runs (RawOracleCoupling.Concrete.compile ctx Q final program) trace result) + (packet : Packet ctx Q) (selected : final result.1 = some packet) : + ∃ raw : GroupAnswer ctx Q (.inl packet), + result.2 (.inl packet) = some raw ∧ + HistoryRecorded globalQuery (packet.val.profile,RawWHIRKeys.entry ctx packet.val) + (decodedTrace ctx stack Q trace) packet.val.messages + (packetEntry ctx stack Q packet raw :: + decodeHistory ctx stack Q (Ancestors ctx Q result.2 packet)) := by + have hr := RawOracleCoupling.Concrete.recorded ctx Q final program run + obtain ⟨raw,hit⟩ := hr.1 packet + (by simp [selected, terminalCompletion, completion]) + exact ⟨raw,hit,recorded_history ctx stack Q result.2 trace hr.2 packet raw hit⟩ +end Whir.WHIRRawHistory diff --git a/verification/whir/Whir/WHIRRawROM.lean b/verification/whir/Whir/WHIRRawROM.lean new file mode 100644 index 000000000..f88aeb75c --- /dev/null +++ b/verification/whir/Whir/WHIRRawROM.lean @@ -0,0 +1,177 @@ +import Whir.WHIRRawReplay +import Whir.WHIRRawHistory + +namespace Whir.WHIRRawROM +open Concrete Protocol CausalProbability ParameterBounds +open FiatShamirGame (Digest32 average) +open RawOracleCoupling RawOracleCoupling.Concrete WHIRRawReplay +open Classical +set_option maxHeartbeats 800000 +set_option maxRecDepth 100000 + +abbrev Catalogs (cap : Nat) := (p : Profile) → FiatShamirGame.FramedHistory → + Option (WHIRFiatShamir.StackInitial p cap) + +def localCatalog {cap : Nat} (catalog : Catalogs cap) (p : Profile) + (entry : FiatShamirGame.FramedHistory) : StackWHIRReplay.Catalog p cap := + fun seed => if seed = entry.statement then catalog p entry else none +abbrev RootFamilies := (p : Profile) → StackWHIRReplay.Roots + +def epsilon (cap : Nat) : ℚ := (1 : ℚ)/2^79 + WHIRFiatShamir.ringCharge cap + +theorem epsilon_nonneg (cap : Nat) : 0 ≤ epsilon cap := + add_nonneg (by positivity) (WHIRFiatShamir.ringCharge_nonneg cap) + +def bad (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (catalog : Catalogs cap) (roots : RootFamilies) : + (label : AllocationKey ctx Q) → AllocationAnswer ctx Q label → Prop + | (.inl packet,history),raw => + StackWHIRROM.keyBad packet.val.profile cap + (localCatalog catalog packet.val.profile (callerEntry ctx Q packet)) (roots packet.val.profile) + (localKey (allocationKey ctx stack Q packet history)) (decodePacket ctx stack Q packet raw) + | (.inr _,_),_ => False + +attribute [local irreducible] StackWHIRROM.keyBad StackWHIRCodec.blockDecode + +private theorem average_instances {α : Type} (old new : Fintype α) (f : α → ℚ) : + @average α old f = @average α new f := by + cases Subsingleton.elim old new + rfl + +theorem sparse (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (catalog : Catalogs cap) (roots : RootFamilies) (label : AllocationKey ctx Q) : + average (fun raw => if bad ctx stack Q cap catalog roots label raw then 1 else 0) ≤ epsilon cap := by + rcases label with ⟨group,history⟩ + cases group with + | inr garbage => + simp only [bad, ↓reduceIte, FiatShamirGame.average_const] + exact epsilon_nonneg cap + | inl packet => + refine (average_instances _ (inferInstance : Fintype (GroupAnswer ctx Q (.inl packet))) + (fun raw : GroupAnswer ctx Q (.inl packet) => + if bad ctx stack Q cap catalog roots (.inl packet,history) raw then 1 else 0)).trans_le ?_ + let key := localKey (allocationKey ctx stack Q packet history) + have bound := StackWHIRCodec.key_block_sparse packet.val.profile cap + (localCatalog catalog packet.val.profile (callerEntry ctx Q packet)) (roots packet.val.profile) key + have scale : WHIRFiatShamir.stackEta packet.val.profile cap ≤ epsilon cap := by + exact add_le_add (WHIRFiatShamir.eta_le packet.val.profile) + (le_refl (WHIRFiatShamir.ringCharge cap)) + have finalBound := bound.trans scale + have equal := RawOracleCoupling.average_equiv (packetEquiv ctx stack Q packet) + (fun raw => if StackWHIRROM.keyBad packet.val.profile cap + (localCatalog catalog packet.val.profile (callerEntry ctx Q packet)) + (roots packet.val.profile) key (StackWHIRCodec.blockDecode + (StackWHIRReplay.query packet.val.profile (packet.val.statement,packet.val.messages)) raw) + then (1 : ℚ) else 0) + change average (fun raw : GroupAnswer ctx Q (.inl packet) => + if StackWHIRROM.keyBad packet.val.profile cap + (localCatalog catalog packet.val.profile (callerEntry ctx Q packet)) (roots packet.val.profile) key + (decodePacket ctx stack Q packet raw) then 1 else 0) ≤ epsilon cap + exact equal.le.trans finalBound + +theorem lift_bad_member (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (catalog : Catalogs cap) (roots : RootFamilies) (p : Profile) + (entry : FiatShamirGame.FramedHistory) + (trace : List (Sigma (AllocationAnswer ctx Q))) + (covered : ∃ ka ∈ localTrace p entry (decodedTrace ctx stack Q trace), + StackWHIRROM.keyBad p cap (localCatalog catalog p entry) (roots p) ka.1 ka.2) : + ∃ ka ∈ trace, bad ctx stack Q cap catalog roots ka.1 ka.2 := by + obtain ⟨ka,member,failed⟩ := covered + obtain ⟨encoded,inDecoded,restricted⟩ := List.mem_filterMap.mp member + obtain ⟨allocation,inTrace,decoded⟩ := List.mem_filterMap.mp inDecoded + rcases allocation with ⟨⟨group,history⟩,raw⟩ + cases group with + | inr garbage => simp only [decodeAllocation, reduceCtorEq] at decoded + | inl packet => + simp only [decodeAllocation, Option.some.injEq] at decoded + subst encoded + simp only [restrictAllocation, allocationKey] at restricted + by_cases same : packet.val.profile = p + · simp only [same, ↓reduceDIte] at restricted + by_cases sameEntry : callerEntry ctx Q packet = entry + · simp only [sameEntry, ↓reduceIte] at restricted + subst p + subst entry + cases restricted + exact ⟨_,inTrace,failed⟩ + · simp only [sameEntry, ↓reduceIte, reduceCtorEq] at restricted + · simp only [same, ↓reduceDIte, reduceCtorEq] at restricted + +def completedHistory (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (cache : TypedFiatShamirGame.Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (packet : RawWHIRKeys.Packet ctx Q) (raw : GroupAnswer ctx Q (.inl packet)) : + List (LocalEntry packet.val.profile) := + (packetEntry ctx stack Q packet raw :: + decodeHistory ctx stack Q (WHIRRawHistory.Ancestors ctx Q cache packet)).filterMap + (restrictEntry packet.val.profile) + +/-- The terminal predicate parses and verifies the actual completed cache. A +rejected submission selects no packet; no fabricated fallback is introduced. -/ +def Failure (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (catalog : Catalogs cap) (roots : RootFamilies) + (selected : Option (RawWHIRKeys.Packet ctx Q)) + (cache : TypedFiatShamirGame.Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) : Prop := + ∃ packet, selected = some packet ∧ ∃ raw, cache (.inl packet) = some raw ∧ + StackWHIRROM.HistoryFailure packet.val.profile cap + (localCatalog catalog packet.val.profile (callerEntry ctx Q packet)) (roots packet.val.profile) + packet.val.statement packet.val.messages (completedHistory ctx stack Q cache packet raw) + +theorem compiler_cover (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q cap : Nat) + (catalog : Catalogs cap) (roots : RootFamilies) {R : Type} {K : Nat} + (final : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) + (trace result) + (run : TypedOracleCompiler.Sampling.Runs (compile ctx Q final program) trace result) + (failed : Failure ctx stack Q cap catalog roots (final result.1) result.2) : + ∃ ka ∈ trace, bad ctx stack Q cap catalog roots ka.1 ka.2 := by + obtain ⟨packet,_,raw,hit,failed⟩ := failed + have recorded := WHIRRawHistory.recorded_history ctx stack Q result.2 trace + (RawOracleCoupling.Concrete.recorded ctx Q final program run).2 packet raw hit + have localProof := restrict_recorded packet.val.profile (callerEntry ctx Q packet) + (decodedTrace ctx stack Q trace) packet.val.messages _ recorded + have covered := StackWHIRROM.recorded_history_cover packet.val.profile cap + (localCatalog catalog packet.val.profile (callerEntry ctx Q packet)) + (roots packet.val.profile) packet.val.statement packet.val.messages _ + (localTrace packet.val.profile (callerEntry ctx Q packet) (decodedTrace ctx stack Q trace)) localProof failed + exact lift_bad_member ctx stack Q cap catalog roots packet.val.profile (callerEntry ctx Q packet) trace covered + +theorem allocation_list_binding (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (catalog : Catalogs cap) (roots : RootFamilies) {R : Type} {K : Nat} + (final : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) : + TypedOracleCompiler.Sampling.failureProbability + (fun result => Failure ctx stack Q cap catalog roots (final result.1) result.2) + (compile ctx Q final program) ≤ + min 1 (((allocationBudget ctx * (K+1) : Nat) : ℚ) * epsilon cap) := by + apply le_min + · apply TypedOracleCompiler.Sampling.expectation_le_one + intro result + split <;> norm_num + · have cover := TypedOracleCompiler.Sampling.failure_le_risk + (bad ctx stack Q cap catalog roots) + (fun result => Failure ctx stack Q cap catalog roots (final result.1) result.2) + (compile ctx Q final program) (compiler_cover ctx stack Q cap catalog roots final program) + have bounded := TypedFiatShamirGame.risk_bound (bad ctx stack Q cap catalog roots) + (epsilon cap) (epsilon_nonneg cap) (sparse ctx stack Q cap catalog roots) + (TypedOracleCompiler.Sampling.erase (compile ctx Q final program)) + simpa only [Nat.mul_add, Nat.mul_one] using cover.trans bounded + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ + +/-- All raw requests, including garbage, partial blocks and final completion, +share one coupled cache. This theorem conditions on no future oracle values. -/ +theorem raw_table_list_binding (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q cap : Nat) (catalog : Catalogs cap) (roots : RootFamilies) {R : Type} {K : Nat} + (final : R → Option (RawWHIRKeys.Packet ctx Q)) + (program : TypedOracleCompiler.Sampling (DuplexModeGame.RawKey Q) (fun _ => Digest32) R K) : + average (fun table : DuplexModeGame.RawKey Q → Digest32 => + let result := tableExecution ctx Q final program table + if Failure ctx stack Q cap catalog roots (final result.1) result.2 then 1 else 0) ≤ + min 1 (((allocationBudget ctx * (K+1) : Nat) : ℚ) * epsilon cap) := by + rw [RawOracleCoupling.Concrete.distribution_full ctx Q final program + (fun result => if Failure ctx stack Q cap catalog roots (final result.1) result.2 then 1 else 0)] + exact allocation_list_binding ctx stack Q cap catalog roots final program + +end Whir.WHIRRawROM diff --git a/verification/whir/Whir/WHIRRawReplay.lean b/verification/whir/Whir/WHIRRawReplay.lean new file mode 100644 index 000000000..31ae8e2e7 --- /dev/null +++ b/verification/whir/Whir/WHIRRawReplay.lean @@ -0,0 +1,127 @@ +import Whir.RawOracleProvenance +import Whir.StackWHIRCodec + +namespace Whir.WHIRRawReplay +open Concrete Protocol CausalProbability ParameterBounds +open FiatShamirGame (Digest32 average) +open RawOracleCoupling RawOracleCoupling.Concrete +open Classical +set_option maxHeartbeats 800000 +set_option maxRecDepth 10000 + +abbrev GlobalCoordinate := (p : Profile) × Coordinate (config p) +abbrev GlobalSample (q : GlobalCoordinate) := StackWHIRReplay.Sample q.2 +abbrev GlobalStatement := Profile × FiatShamirGame.FramedHistory + +def globalQuery (input : GlobalStatement × List WHIRHistory.Pending) : GlobalCoordinate := + ⟨input.1.1, StackWHIRReplay.query input.1.1 (input.1.2.statement,input.2)⟩ + +abbrev GlobalKey := TypedFiatShamirGame.FullInput GlobalStatement WHIRHistory.Pending + GlobalCoordinate GlobalSample +abbrev GlobalAnswer := TypedOracleCompiler.Fiber (A := GlobalSample) globalQuery +abbrev GlobalEntry := WHIRHistory.Pending × Sigma GlobalSample + +theorem packet_blocks (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) : + RawWHIRKeys.blocks ctx packet.val = StackWHIRCodec.outputBlocks + (StackWHIRReplay.query packet.val.profile (packet.val.statement,packet.val.messages)) := by + rw [StackWHIRCodec.outputBlocks_eq] + simp only [RawWHIRKeys.blocks, RawWHIRKeys.width, stack, WHIRHistoryKey.stackWidth, + StackWHIRReplay.query, WHIRReplay.query, WHIRHistory.queryFor, Nat.mul_comm] + +def packetEquiv (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) : + GroupAnswer ctx Q (.inl packet) ≃ + (Fin (StackWHIRCodec.outputBlocks + (StackWHIRReplay.query packet.val.profile (packet.val.statement,packet.val.messages))) → Digest32) := + Equiv.arrowCongr (finCongr (packet_blocks ctx stack Q packet)) (Equiv.refl Digest32) + +def decodePacket (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (raw : GroupAnswer ctx Q (.inl packet)) : + StackWHIRReplay.Sample + (StackWHIRReplay.query packet.val.profile (packet.val.statement,packet.val.messages)) := + StackWHIRCodec.blockDecode _ (packetEquiv ctx stack Q packet raw) + +def packetEntry (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (raw : GroupAnswer ctx Q (.inl packet)) : GlobalEntry := + (packet.val.messages.headD ⟨[],none⟩, + ⟨⟨packet.val.profile,StackWHIRReplay.query packet.val.profile + (packet.val.statement,packet.val.messages)⟩,decodePacket ctx stack Q packet raw⟩) + +def decodeEntry (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) : + Sigma (GroupAnswer ctx Q) → Option GlobalEntry + | ⟨.inl packet,raw⟩ => some (packetEntry ctx stack Q packet raw) + | ⟨.inr _,_⟩ => none + +def decodeHistory (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (history : List (Sigma (GroupAnswer ctx Q))) : List GlobalEntry := + (history.filterMap (decodeEntry ctx stack Q)).reverse + +def callerEntry (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) : + FiatShamirGame.FramedHistory := + RawWHIRKeys.entry ctx packet.val + +def allocationKey (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (history : List (Sigma (GroupAnswer ctx Q))) : GlobalKey := + ⟨(packet.val.profile,callerEntry ctx Q packet),packet.val.messages, + decodeHistory ctx stack Q history⟩ + +def decodeAllocation (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) : + Sigma (AllocationAnswer ctx Q) → Option (Sigma GlobalAnswer) + | ⟨(.inl packet,history),raw⟩ => + some ⟨allocationKey ctx stack Q packet history,decodePacket ctx stack Q packet raw⟩ + | ⟨(.inr _,_),_⟩ => none + +def decodedTrace (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (trace : List (Sigma (AllocationAnswer ctx Q))) : List (Sigma GlobalAnswer) := + trace.filterMap (decodeAllocation ctx stack Q) + +abbrev LocalEntry (p : Profile) := + WHIRHistory.Pending × Sigma (@StackWHIRReplay.Sample (config p)) + +def restrictEntry (p : Profile) : GlobalEntry → Option (LocalEntry p) + | (m,⟨⟨r,q⟩,x⟩) => + if h : r = p then some (h ▸ (m,⟨q,x⟩)) else none + +@[simp] theorem restrictEntry_self (p : Profile) (m : WHIRHistory.Pending) + (q : Coordinate (config p)) (x : StackWHIRReplay.Sample q) : + restrictEntry p (m,⟨⟨p,q⟩,x⟩) = some (m,⟨q,x⟩) := by + simp [restrictEntry] + +def localKey (key : GlobalKey) : StackWHIRReplay.Key key.statement.1 := + ⟨key.statement.2.statement,key.messages,key.ancestors.filterMap (restrictEntry key.statement.1)⟩ + +def restrictAllocation (p : Profile) (entry : FiatShamirGame.FramedHistory) : Sigma GlobalAnswer → + Option (Sigma (StackWHIRReplay.Answer p)) + | ⟨⟨(r,s),messages,history⟩,a⟩ => + if h : r = p then + if s = entry then + some (h ▸ (⟨⟨s.statement,messages,history.filterMap (restrictEntry r)⟩,a⟩ : + Sigma (StackWHIRReplay.Answer r))) + else none + else none + +@[simp] theorem restrictAllocation_self (p : Profile) (s : FiatShamirGame.FramedHistory) + (messages : List WHIRHistory.Pending) (history : List GlobalEntry) + (a : StackWHIRReplay.Sample (StackWHIRReplay.query p (s.statement,messages))) : + restrictAllocation p s ⟨⟨(p,s),messages,history⟩,a⟩ = + some ⟨⟨s.statement,messages,history.filterMap (restrictEntry p)⟩,a⟩ := by + simp [restrictAllocation] + +def localTrace (p : Profile) (entry : FiatShamirGame.FramedHistory) (trace : List (Sigma GlobalAnswer)) := + trace.filterMap (restrictAllocation p entry) + +theorem restrict_recorded (p : Profile) (s : FiatShamirGame.FramedHistory) (trace : List (Sigma GlobalAnswer)) + (messages : List WHIRHistory.Pending) (history : List GlobalEntry) + (recorded : TypedOracleCompiler.HistoryRecorded globalQuery (p,s) trace messages history) : + TypedOracleCompiler.HistoryRecorded (StackWHIRReplay.query p) s.statement + (localTrace p s trace) messages (history.filterMap (restrictEntry p)) := by + induction recorded with + | nil => exact .nil + | @cons m messages history a older allocated ih => + simp only [List.filterMap_cons, globalQuery, restrictEntry] + apply TypedOracleCompiler.HistoryRecorded.cons + (query := StackWHIRReplay.query p) (A := @StackWHIRReplay.Sample (config p)) a ih + exact List.mem_filterMap.mpr ⟨_,allocated,restrictAllocation_self p s _ _ a⟩ + +end Whir.WHIRRawReplay diff --git a/verification/whir/Whir/WHIRReplay.lean b/verification/whir/Whir/WHIRReplay.lean new file mode 100644 index 000000000..14823498c --- /dev/null +++ b/verification/whir/Whir/WHIRReplay.lean @@ -0,0 +1,401 @@ +import Whir.WHIRHistory +import Whir.CausalStrategy +import Whir.TypedOracleCompiler + +/-! Concrete reification of canonical typed-ROM keys. The immutable statement +catalog and extracted commitment table are explicit inputs, not assumed parsers +or a source of future challenge samples. Malformed keys return `none`. -/ +namespace Whir.WHIRReplay +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame (Digest32) +open WHIRHistory (Pending) + +abbrev Key (p : Profile) := + TypedFiatShamirGame.FullInput Digest32 Pending (Coordinate (config p)) Sample +abbrev query (p : Profile) := WHIRHistory.queryFor (config p) +abbrev Answer (p : Profile) (key : Key p) := Sample (query p (key.statement,key.messages)) +abbrev Catalog (p : Profile) := Digest32 → Option (WHIRFiatShamir.Statement p) +/-- Frozen extracted commitments, indexed by the requested code level. -/ +abbrev Roots := Digest32 → Nat → Oracle + +structure Replay (p : Profile) where + statement : WHIRFiatShamir.Statement p + tape : Tape (config p) + replies : Array Reply + +def zeroTape (p : Profile) : Tape (config p) := + (coordinates (config p)).symm (fun _ => 0) + +/-- Rows are reconstructed in sampled order from the actual prequery oracle. +They are not read from a guessed proof body or supplied through a certificate. -/ +def queryRows {p : Profile} (r : Replay p) (i : Fin (config p).folds.size) + (x : Sample (.query i)) : Oracle := + (QueryBatchSoundness.queries (remaining (config p) i + (config p).rates[i.val]!) + (config p).queries[i.val]! x.1).map + (fun q => (CausalExecution.levelAt r.statement.input + (CausalStrategy.indexedStrategy r.replies) r.tape i).oracle[q]!) + +def reply {p : Profile} (roots : Roots) (r : Replay p) (q : Coordinate (config p)) + (x : Sample q) (pending : Pending) : Option Reply := + let lookup := fun digest => roots digest (WHIRHistory.coordinateLevel q + 1) + let rows := match q, x with + | .query i, x => queryRows r i x + | _, _ => #[] + WHIRHistory.decodeReplyScalars q lookup rows pending.scalars + +/-- Extend only by the answer actually recorded for the preceding full key, +then parse the absorbed response with the concrete transport decoder. -/ +def step {p : Profile} (roots : Roots) (r : Replay p) (q : Coordinate (config p)) + (x : Sample q) (pending : Pending) : Option (Replay p) := + (reply roots r q x pending).map (fun response => + ⟨r.statement, set q r.tape x, r.replies.push response⟩) + +theorem step_spec {p : Profile} (roots : Roots) (r out : Replay p) + (q : Coordinate (config p)) (x : Sample q) (pending : Pending) + (ok : step roots r q x pending = some out) : + ∃ response, reply roots r q x pending = some response ∧ + out = ⟨r.statement,set q r.tape x,r.replies.push response⟩ := by + unfold step at ok + cases hr : reply roots r q x pending with + | none => simp [hr] at ok + | some response => + simp only [hr, Option.map_some, Option.some.injEq] at ok + exact ⟨response,rfl,ok.symm⟩ + +/-- The nonce is an auxiliary public event exactly at a query batch. It is not +an algebraic query row and earns no grinding factor. -/ +def nonceShape {c : Config} (q : Coordinate c) (m : Pending) : Bool := + match q with + | .query _ => m.nonce.isSome + | _ => m.nonce.isNone + +/-- The raw syntax and completed ancestors must agree at each recursive step. +Position checks enforce strict chronological challenge use even on malformed +or rejecting branches. Only successful decoding produces a replay state. -/ +def decodeHistory (p : Profile) (catalog : Catalog p) (roots : Roots) (s : Digest32) : + List Pending → List (Pending × Sigma (@Sample (config p))) → Option (Replay p) + | [], _ => none + | [m], [] => do + if m.scalars.isEmpty && m.nonce.isNone then + let statement ← catalog s + pure ⟨statement,zeroTape p,#[]⟩ + else none + | m :: previous :: older, (previous' , ⟨q,x⟩) :: past => do + if previous' = previous then + if _hq : q = query p (s,previous::older) then + if position q = older.length then + if position (query p (s,m::previous::older)) = older.length + 1 then + if nonceShape (query p (s,m::previous::older)) m then + let before ← decodeHistory p catalog roots s (previous::older) past + step roots before q x m + else none + else none + else none + else none + else none + | _, _ => none + +def decode (p : Profile) (catalog : Catalog p) (roots : Roots) (key : Key p) : Option (Replay p) := + decodeHistory p catalog roots key.statement key.messages key.ancestors + +def request {p : Profile} (key : Key p) (r : Replay p) : WHIRFiatShamir.Request p := + WHIRFiatShamir.requestOfTape r.statement (CausalStrategy.indexedStrategy r.replies) + (query p (key.statement,key.messages)) r.tape + +/-- The executable decoder's successful derivations. Each constructor performs +the concrete scalar parser, rather than assuming a replay certificate. -/ +inductive Decodes (p : Profile) (catalog : Catalog p) (roots : Roots) (s : Digest32) : + List Pending → List (Pending × Sigma (@Sample (config p))) → Replay p → Prop where + | initial {m statement} + (shape : (m.scalars.isEmpty && m.nonce.isNone) = true) + (found : catalog s = some statement) : + Decodes p catalog roots s [m] [] ⟨statement,zeroTape p,#[]⟩ + | next {m previous older past q x before out} + (prior : Decodes p catalog roots s (previous::older) past before) + (phase : q = query p (s,previous::older)) + (previousPosition : position q = older.length) + (currentPosition : position (query p (s,m::previous::older)) = older.length + 1) + (nonce : nonceShape (query p (s,m::previous::older)) m = true) + (parsed : step roots before q x m = some out) : + Decodes p catalog roots s (m::previous::older) ((previous,⟨q,x⟩)::past) out + +theorem decodeHistory_decodes (p : Profile) (catalog : Catalog p) (roots : Roots) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) + (out : Replay p) (ok : decodeHistory p catalog roots s messages ancestors = some out) : + Decodes p catalog roots s messages ancestors out := by + induction messages generalizing ancestors out with + | nil => cases ok + | cons m messages ih => + cases messages with + | nil => + cases ancestors with + | cons a as => cases ok + | nil => + simp only [decodeHistory] at ok + split at ok + · rename_i shape + cases found : catalog s with + | none => simp [found] at ok + | some statement => + simp [found] at ok + subst out + exact .initial shape found + · cases ok + | cons previous older => + cases ancestors with + | nil => cases ok + | cons a past => + rcases a with ⟨previous',q,x⟩ + simp only [decodeHistory] at ok + split at ok + · rename_i same + subst previous' + split at ok + · rename_i phase + split at ok + · rename_i previousPosition + split at ok + · rename_i currentPosition + split at ok + · rename_i nonce + cases prior : decodeHistory p catalog roots s (previous::older) past with + | none => simp [prior] at ok + | some before => + simp only [prior] at ok + exact .next (ih past before prior) phase previousPosition currentPosition nonce ok + · cases ok + · cases ok + · cases ok + · cases ok + · cases ok + +theorem Decodes.to_decode {p : Profile} {catalog : Catalog p} {roots : Roots} {s messages ancestors out} + (h : Decodes p catalog roots s messages ancestors out) : + decodeHistory p catalog roots s messages ancestors = some out := by + induction h with + | initial shape found => simp [decodeHistory, shape, found] + | next prior phase previousPosition currentPosition nonce parsed ih => + cases phase + simp [decodeHistory, previousPosition, currentPosition, nonce, ih, parsed] + +theorem Decodes.size {p : Profile} {catalog : Catalog p} {roots : Roots} {s messages ancestors out} + (h : Decodes p catalog roots s messages ancestors out) : + out.replies.size = messages.length - 1 := by + induction h with + | initial => rfl + | next prior phase previousPosition currentPosition nonce parsed ih => + obtain ⟨response,_,rfl⟩ := step_spec _ _ _ _ _ _ parsed + simp only [Array.size_push, List.length_cons] at ih ⊢ + omega + +theorem query_singleton (p : Profile) (s : Digest32) (m : Pending) : + query p (s,[m]) = .initial := by + simp [query, WHIRHistory.queryFor, WHIRHistory.schedule, visibleCoordinates] + +theorem Decodes.phase_position {p : Profile} {catalog : Catalog p} {roots : Roots} {s messages ancestors out} + (h : Decodes p catalog roots s messages ancestors out) : + position (query p (s,messages)) = messages.length - 1 := by + cases h with + | initial => + simp [query_singleton, CausalProbability.position, visibleCoordinates] + | next prior phase previousPosition currentPosition nonce parsed => + simpa using currentPosition + +theorem Decodes.statement {p : Profile} {catalog : Catalog p} {roots : Roots} + {s messages ancestors out} (h : Decodes p catalog roots s messages ancestors out) : + catalog s = some out.statement := by + induction h with + | initial shape found => exact found + | next prior phase previousPosition currentPosition nonce parsed ih => + obtain ⟨response,_,rfl⟩ := step_spec _ _ _ _ _ _ parsed + exact ih + +/-- Precisely the information relevant to an allocation before its answer is +sampled. The response at index `n` is deliberately not compared. -/ +structure PrefixAgreement {p : Profile} (n : Nat) (before after : Replay p) : Prop where + statement : before.statement = after.statement + replies : ∀ i, i < n → before.replies[i]! = after.replies[i]! + tape : ∀ q, position q < n → get q before.tape = get q after.tape + +theorem PrefixAgreement.refl {p : Profile} (n : Nat) (r : Replay p) : PrefixAgreement n r r := + ⟨rfl,fun _ _ => rfl,fun _ _ => rfl⟩ + +theorem PrefixAgreement.mono {p : Profile} {m n : Nat} {before after : Replay p} + (h : PrefixAgreement n before after) (le : m ≤ n) : PrefixAgreement m before after := + ⟨h.statement,fun i hi => h.replies i (lt_of_lt_of_le hi le), + fun q hq => h.tape q (lt_of_lt_of_le hq le)⟩ + +theorem PrefixAgreement.trans {p : Profile} {n : Nat} {a b c : Replay p} + (h : PrefixAgreement n a b) (k : PrefixAgreement n b c) : PrefixAgreement n a c := + ⟨h.statement.trans k.statement,fun i hi => (h.replies i hi).trans (k.replies i hi), + fun q hq => (h.tape q hq).trans (k.tape q hq)⟩ + +theorem step_prefix {p : Profile} (roots : Roots) (before after : Replay p) + (q : Coordinate (config p)) (x : Sample q) (pending : Pending) + (ok : step roots before q x pending = some after) + (size : before.replies.size = position q) : + PrefixAgreement (position q) before after := by + obtain ⟨response,_,rfl⟩ := step_spec _ _ _ _ _ _ ok + refine ⟨rfl,?_,?_⟩ + · intro i hi + have hb : i < before.replies.size := by omega + have ha : i < (before.replies.push response).size := by simp; omega + simp only [_root_.getElem!_pos before.replies i hb, + _root_.getElem!_pos (before.replies.push response) i ha, Array.getElem_push_lt hb] + · intro r hr + have ne : r ≠ q := by intro he; subst r; omega + exact (get_set_ne q r before.tape x ne).symm + +/-- Dropping the same newest prefix from raw messages and completed ancestors +replays exactly an earlier state, agreeing on every strict-past response and +challenge. This is a theorem about the concrete decoder, not an input premise. -/ +theorem Decodes.drop {p : Profile} {catalog : Catalog p} {roots : Roots} {s messages ancestors out} + (h : Decodes p catalog roots s messages ancestors out) (i : Nat) (hi : i < messages.length) : + ∃ before, Decodes p catalog roots s (messages.drop i) (ancestors.drop i) before ∧ + PrefixAgreement (messages.length - i - 1) before out := by + induction h generalizing i with + | initial shape found => + have hz : i = 0 := by simpa using hi + subst i + exact ⟨_,.initial shape found,.refl _ _⟩ + | @next m previous older past q x before out prior phase previousPosition currentPosition nonce parsed ih => + cases i with + | zero => + exact ⟨_,.next prior phase previousPosition currentPosition nonce parsed,.refl _ _⟩ + | succ i => + obtain ⟨ancestor,ha,hp⟩ := ih i (by simpa using hi) + have size : before.replies.size = position q := by + rw [prior.size, previousPosition] + simp + have he := step_prefix roots before out q x m parsed size + have hn : (previous::older).length - i - 1 ≤ position q := by + simp only [List.length_cons, previousPosition] + omega + have result := hp.trans (he.mono hn) + have eqn : (m::previous::older).length - (i+1) - 1 = + (previous::older).length - i - 1 := by simp only [List.length_cons]; omega + exact ⟨ancestor,by simpa only [List.drop_succ_cons] using ha,by simpa only [eqn] using result⟩ + +/-- Every ancestor value is literally the corresponding coordinate of the +decoded tape, and its coordinate is strictly earlier than the current one. -/ +theorem Decodes.samples {p : Profile} {catalog : Catalog p} {roots : Roots} {s messages ancestors out} + (h : Decodes p catalog roots s messages ancestors out) : + ∀ entry ∈ ancestors, + position entry.2.1 < position (query p (s,messages)) ∧ + get entry.2.1 out.tape = entry.2.2 := by + induction h with + | initial => + intro entry member + cases member + | @next m previous older past q x before out prior phase previousPosition currentPosition nonce parsed ih => + obtain ⟨response,_,rfl⟩ := step_spec _ _ _ _ _ _ parsed + intro entry member + rcases List.mem_cons.mp member with rfl | member + · exact ⟨by simpa only [currentPosition, previousPosition] using Nat.lt_succ_self older.length, + get_set q before.tape x⟩ + · obtain ⟨earlier,value⟩ := ih entry member + rw [← phase] at earlier + have ne : entry.2.1 ≠ q := by intro he; rw [he] at earlier; omega + refine ⟨?_,?_⟩ + · rw [currentPosition] + rw [previousPosition] at earlier + omega + · simpa only [get_set_ne q _ _ _ ne] using value + +/-- Explicit final completion installs the terminal sampled vector. It does not +invoke an adversarial continuation, including at the hidden last tail. -/ +def finish {p : Profile} (key : Key p) (r : Replay p) + (x : Sample (query p (key.statement,key.messages))) : Replay p := + {r with tape := set (query p (key.statement,key.messages)) r.tape x} + +theorem finish_prefix {p : Profile} (key : Key p) (r : Replay p) + (x : Sample (query p (key.statement,key.messages))) : + PrefixAgreement (position (query p (key.statement,key.messages))) r (finish key r x) := by + refine ⟨rfl,fun _ _ => rfl,?_⟩ + intro q hq + have ne : q ≠ query p (key.statement,key.messages) := by intro he; subst q; omega + exact (get_set_ne _ _ _ _ ne).symm + +theorem decode_prefix {p : Profile} (catalog : Catalog p) (roots : Roots) (key : Key p) + (out : Replay p) (ok : decode p catalog roots key = some out) + (i : Nat) (hi : i < key.messages.length) : + ∃ before, decode p catalog roots ⟨key.statement,key.messages.drop i,key.ancestors.drop i⟩ = + some before ∧ + PrefixAgreement (position (query p (key.statement,key.messages.drop i))) before out := by + obtain ⟨before,hb,hp⟩ := (decodeHistory_decodes p catalog roots _ _ _ out ok).drop i hi + refine ⟨before,hb.to_decode,?_⟩ + rw [hb.phase_position, List.length_drop] + exact hp + +/-- Installing the final invisible sample preserves all recorded ancestors. -/ +theorem finish_samples {p : Profile} (catalog : Catalog p) (roots : Roots) (key : Key p) + (out : Replay p) (ok : decode p catalog roots key = some out) + (x : Sample (query p (key.statement,key.messages))) : + (get (query p (key.statement,key.messages)) (finish key out x).tape = x) ∧ + ∀ entry ∈ key.ancestors, get entry.2.1 (finish key out x).tape = entry.2.2 := by + refine ⟨get_set _ _ _,?_⟩ + intro entry member + obtain ⟨earlier,value⟩ := (decodeHistory_decodes p catalog roots _ _ _ out ok).samples entry member + have ne : entry.2.1 ≠ query p (key.statement,key.messages) := by + intro he + rw [he] at earlier + omega + simpa only [finish, get_set_ne _ _ _ _ ne] using value + +theorem decode_prefix_finish {p : Profile} (catalog : Catalog p) (roots : Roots) (key : Key p) + (out : Replay p) (ok : decode p catalog roots key = some out) (x : Answer p key) + (i : Nat) (hi : i < key.messages.length) : + ∃ before, decode p catalog roots ⟨key.statement,key.messages.drop i,key.ancestors.drop i⟩ = + some before ∧ + PrefixAgreement (position (query p (key.statement,key.messages.drop i))) before + (finish key out x) := by + obtain ⟨before,hb,hp⟩ := decode_prefix catalog roots key out ok i hi + refine ⟨before,hb,hp.trans ((finish_prefix key out x).mono ?_)⟩ + have hpos := (decodeHistory_decodes p catalog roots _ _ _ out ok).phase_position + have bpos := (decodeHistory_decodes p catalog roots _ _ _ before hb).phase_position + rw [bpos,hpos,List.length_drop] + omega + +/-- The compiler's recorded-history theorem and the concrete decoder jointly +realize each allocated final-path key as the strict prefix of one actual +terminal replay. No parser-correctness or cover certificate is assumed. -/ +theorem trace_realization {p : Profile} (catalog : Catalog p) (roots : Roots) + (key : Key p) (out : Replay p) (ok : decode p catalog roots key = some out) + (x : Answer p key) (head : Pending) (trace : List (Sigma (Answer p))) + (recorded : TypedOracleCompiler.HistoryRecorded (query p) key.statement trace key.messages + ((head,⟨query p (key.statement,key.messages),x⟩)::key.ancestors)) + (i : Nat) (hi : i < key.messages.length) : + ∃ m tail past, ∃ a : Sample (query p (key.statement,m::tail)), ∃ before : Replay p, + key.messages.drop i = m::tail ∧ + (⟨⟨key.statement,m::tail,past⟩,a⟩ : Sigma (Answer p)) ∈ trace ∧ + decode p catalog roots ⟨key.statement,m::tail,past⟩ = some before ∧ + PrefixAgreement (position (query p (key.statement,m::tail))) before (finish key out x) ∧ + get (query p (key.statement,m::tail)) (finish key out x).tape = a ∧ + position (query p (key.statement,m::tail)) = key.messages.length - i - 1 := by + obtain ⟨m,tail,past,a,hm,hh,allocated⟩ := TypedOracleCompiler.HistoryRecorded.at_index + (query p) recorded i hi + obtain ⟨before,hb,hp⟩ := decode_prefix_finish catalog roots key out ok x i hi + have ha : key.ancestors.drop i = past := by + have ht := congrArg List.tail hh + simpa only [List.tail_drop,List.drop_succ_cons,List.tail_cons] using ht + have parsed : decode p catalog roots ⟨key.statement,m::tail,past⟩ = some before := by + simpa only [hm,ha] using hb + have agree : PrefixAgreement (position (query p (key.statement,m::tail))) before + (finish key out x) := by simpa only [hm] using hp + have sample : get (query p (key.statement,m::tail)) (finish key out x).tape = a := by + have member : (m,(⟨query p (key.statement,m::tail),a⟩ : Sigma Sample)) ∈ + (head,⟨query p (key.statement,key.messages),x⟩)::key.ancestors := + List.mem_of_mem_drop (by rw [hh]; exact List.mem_cons_self) + rcases List.mem_cons.mp member with same | older + · have hs := congrArg Prod.snd same + have result := (finish_samples catalog roots key out ok x).1 + exact Eq.mp (congrArg (fun qa : Sigma Sample => + get qa.1 (finish key out x).tape = qa.2) hs.symm) result + · exact (finish_samples catalog roots key out ok x).2 _ older + have pos := (decodeHistory_decodes p catalog roots _ _ _ before parsed).phase_position + have len := congrArg List.length hm + rw [List.length_drop] at len + refine ⟨m,tail,past,a,before,hm,allocated,parsed,agree,sample,?_⟩ + rw [pos,← len] + +end Whir.WHIRReplay diff --git a/verification/whir/Whir/WHIRSnapshotReplay.lean b/verification/whir/Whir/WHIRSnapshotReplay.lean new file mode 100644 index 000000000..e5f146c37 --- /dev/null +++ b/verification/whir/Whir/WHIRSnapshotReplay.lean @@ -0,0 +1,221 @@ +import Whir.StackWHIRROM +import Whir.WHIRROM + +/-! Replay depends only on the original statement at its seed and on the +commitment references actually encoded at nonfinal last-fold positions. +Footprints inspect public pending messages, never future oracle answers. -/ +namespace Whir.WHIRSnapshotReplay +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open FiatShamirGame (Digest32) +open WHIRHistory (Pending) + +abbrev RootRef := Digest32 × Nat + +/-- The exact possible lookup of the scalar parser. Invalid digest encodings, +other phases, and extra or missing scalars contribute no reference. -/ +def replyFootprint {c : Config} (q : Coordinate c) (xs : List E) : List RootRef := + match q with + | .fold i j => match xs with + | _ :: _ :: rest => + if j.val + 1 = c.folds[i.val]! then + if i.val + 1 < c.folds.size then + match rest with + | [r,s] => (ByteCodec.scalarsToHash (r,s)).toList.map (fun digest => (digest,i.val + 1)) + | _ => [] + else [] + else [] + | _ => [] + | _ => [] + +/-- Syntactic references in chronological order. Rejected histories may retain +references in unreachable older or newer messages; no unrelated root is added. +The initial commitment is obtained from the seed catalog, not this registry. -/ +def historyFootprint (p : Profile) (s : Digest32) : List Pending → List RootRef + | [] => [] + | [_] => [] + | m :: previous :: older => + historyFootprint p s (previous :: older) ++ + replyFootprint (WHIRReplay.query p (s,previous :: older)) m.scalars + +/-- Local immutability, allowing every unmentioned digest and level to change. -/ +def AgreeOn (refs : List RootRef) (old new : WHIRReplay.Roots) : Prop := + ∀ ref ∈ refs, old ref.1 ref.2 = new ref.1 ref.2 + +theorem AgreeOn.mono {refs more : List RootRef} {old new : WHIRReplay.Roots} + (agree : AgreeOn more old new) (included : ∀ ref ∈ refs, ref ∈ more) : + AgreeOn refs old new := fun ref member => agree ref (included ref member) + +theorem decodeReplyScalars_congr {c : Config} (q : Coordinate c) + (old new : WHIRReplay.Roots) (rows : Oracle) (xs : List E) + (agree : AgreeOn (replyFootprint q xs) old new) : + WHIRHistory.decodeReplyScalars q (fun digest => old digest (WHIRHistory.coordinateLevel q + 1)) rows xs = + WHIRHistory.decodeReplyScalars q (fun digest => new digest (WHIRHistory.coordinateLevel q + 1)) rows xs := by + cases q with + | initial => rfl + | ood i j => rfl + | query i => rfl + | tail j => rfl + | fold i j => + cases xs with + | nil => rfl + | cons a xs => + cases xs with + | nil => rfl + | cons b rest => + by_cases lastFold : j.val + 1 = c.folds[i.val]! + · by_cases nonfinal : i.val + 1 < c.folds.size + · cases rest with + | nil => simp [WHIRHistory.decodeReplyScalars,lastFold,nonfinal] + | cons r rest => + cases rest with + | nil => simp [WHIRHistory.decodeReplyScalars,lastFold,nonfinal] + | cons s rest => + cases rest with + | cons extra rest => simp [WHIRHistory.decodeReplyScalars,lastFold,nonfinal] + | nil => + cases decoded : ByteCodec.scalarsToHash (r,s) with + | none => simp [WHIRHistory.decodeReplyScalars,lastFold,nonfinal,decoded] + | some digest => + have same := agree (digest,i.val + 1) (by + simp [replyFootprint,lastFold,nonfinal,decoded]) + simp only [WHIRHistory.decodeReplyScalars,lastFold,nonfinal,↓reduceIte, + decoded,Option.map_some,WHIRHistory.coordinateLevel] + rw [same] + · simp [WHIRHistory.decodeReplyScalars,lastFold,nonfinal] + · simp only [WHIRHistory.decodeReplyScalars,lastFold,↓reduceIte] + +theorem reply_congr {p : Profile} (old new : WHIRReplay.Roots) (r : WHIRReplay.Replay p) + (q : Coordinate (config p)) (x : Sample q) (m : Pending) + (agree : AgreeOn (replyFootprint q m.scalars) old new) : + WHIRReplay.reply old r q x m = WHIRReplay.reply new r q x m := + decodeReplyScalars_congr q old new _ m.scalars agree + +theorem step_congr {p : Profile} (old new : WHIRReplay.Roots) (r : WHIRReplay.Replay p) + (q : Coordinate (config p)) (x : Sample q) (m : Pending) + (agree : AgreeOn (replyFootprint q m.scalars) old new) : + WHIRReplay.step old r q x m = WHIRReplay.step new r q x m := by + simp only [WHIRReplay.step,reply_congr old new r q x m agree] + +theorem decodeHistory_congr (p : Profile) (oldCatalog newCatalog : WHIRReplay.Catalog p) + (old new : WHIRReplay.Roots) (s : Digest32) (messages : List Pending) + (ancestors : List (Pending × Sigma (@Sample (config p)))) + (catalog : oldCatalog s = newCatalog s) + (agree : AgreeOn (historyFootprint p s messages) old new) : + WHIRReplay.decodeHistory p oldCatalog old s messages ancestors = + WHIRReplay.decodeHistory p newCatalog new s messages ancestors := by + induction messages generalizing ancestors with + | nil => rfl + | cons m messages ih => + cases messages with + | nil => + cases ancestors with + | nil => simp only [WHIRReplay.decodeHistory,catalog] + | cons a rest => rfl + | cons previous older => + cases ancestors with + | nil => rfl + | cons a past => + rcases a with ⟨previous',q,x⟩ + have priorAgree : AgreeOn (historyFootprint p s (previous :: older)) old new := + agree.mono (fun ref member => List.mem_append_left _ member) + have currentAgree : AgreeOn + (replyFootprint (WHIRReplay.query p (s,previous :: older)) m.scalars) old new := + agree.mono (fun ref member => List.mem_append_right _ member) + have prior := ih past priorAgree + by_cases phase : q = WHIRReplay.query p (s,previous :: older) + · have current : ∀ before : WHIRReplay.Replay p, + WHIRReplay.step old before q x m = WHIRReplay.step new before q x m := + fun before => step_congr old new before q x m (by simpa only [phase] using currentAgree) + simp only [WHIRReplay.decodeHistory,phase,↓reduceDIte] + simp_rw [prior,current] + · simp [WHIRReplay.decodeHistory,phase] + +theorem decode_congr (p : Profile) (oldCatalog newCatalog : WHIRReplay.Catalog p) + (old new : WHIRReplay.Roots) (key : WHIRReplay.Key p) + (catalog : oldCatalog key.statement = newCatalog key.statement) + (agree : AgreeOn (historyFootprint p key.statement key.messages) old new) : + WHIRReplay.decode p oldCatalog old key = WHIRReplay.decode p newCatalog new key := + decodeHistory_congr p oldCatalog newCatalog old new key.statement key.messages key.ancestors catalog agree + +theorem keyBad_congr (p : Profile) (oldCatalog newCatalog : WHIRReplay.Catalog p) + (old new : WHIRReplay.Roots) (key : WHIRReplay.Key p) (x : WHIRReplay.Answer p key) + (catalog : oldCatalog key.statement = newCatalog key.statement) + (agree : AgreeOn (historyFootprint p key.statement key.messages) old new) : + WHIRROM.keyBad p oldCatalog old key x ↔ WHIRROM.keyBad p newCatalog new key x := by + simp only [WHIRROM.keyBad,decode_congr p oldCatalog newCatalog old new key catalog agree] + +theorem stack_decodeInitial_congr (p : Profile) (cap : Nat) + (oldCatalog newCatalog : StackWHIRReplay.Catalog p cap) (key : StackWHIRReplay.Key p) + (catalog : oldCatalog key.statement = newCatalog key.statement) : + StackWHIRReplay.decodeInitial p cap oldCatalog key = + StackWHIRReplay.decodeInitial p cap newCatalog key := by + simp only [StackWHIRReplay.decodeInitial,catalog] + +theorem stack_decode_congr (p : Profile) (cap : Nat) + (oldCatalog newCatalog : StackWHIRReplay.Catalog p cap) (old new : WHIRReplay.Roots) + (key : StackWHIRReplay.Key p) + (catalog : oldCatalog key.statement = newCatalog key.statement) + (agree : AgreeOn (historyFootprint p key.statement key.messages) old new) : + StackWHIRReplay.decode p cap oldCatalog old key = StackWHIRReplay.decode p cap newCatalog new key := by + have decoded : ∀ (data : WHIRFiatShamir.StackInitial p cap) seed, + WHIRReplay.decode p (StackWHIRReplay.localCatalog data seed) old (StackWHIRReplay.projectKey key) = + WHIRReplay.decode p (StackWHIRReplay.localCatalog data seed) new (StackWHIRReplay.projectKey key) := + fun data seed => decode_congr p _ _ old new _ rfl agree + simp only [StackWHIRReplay.decode,catalog] + simp_rw [decoded] + +theorem stack_keyBad_congr (p : Profile) (cap : Nat) + (oldCatalog newCatalog : StackWHIRReplay.Catalog p cap) (old new : WHIRReplay.Roots) + (key : StackWHIRReplay.Key p) (x : StackWHIRReplay.Answer p key) + (catalog : oldCatalog key.statement = newCatalog key.statement) + (agree : AgreeOn (historyFootprint p key.statement key.messages) old new) : + StackWHIRROM.keyBad p cap oldCatalog old key x ↔ StackWHIRROM.keyBad p cap newCatalog new key x := by + simp only [StackWHIRROM.keyBad,stack_decodeInitial_congr p cap oldCatalog newCatalog key catalog, + stack_decode_congr p cap oldCatalog newCatalog old new key catalog agree] + +theorem stack_historyFailure_congr (p : Profile) (cap : Nat) + (oldCatalog newCatalog : StackWHIRReplay.Catalog p cap) (old new : WHIRReplay.Roots) + (s : Digest32) (messages : List Pending) + (history : List (Pending × Sigma (@StackWHIRReplay.Sample (config p)))) + (catalog : oldCatalog s = newCatalog s) + (agree : AgreeOn (historyFootprint p s messages) old new) : + StackWHIRROM.HistoryFailure p cap oldCatalog old s messages history ↔ + StackWHIRROM.HistoryFailure p cap newCatalog new s messages history := by + have decoded : ∀ past, StackWHIRReplay.decode p cap oldCatalog old ⟨s,messages,past⟩ = + StackWHIRReplay.decode p cap newCatalog new ⟨s,messages,past⟩ := + fun past => stack_decode_congr p cap oldCatalog newCatalog old new _ catalog agree + simp only [StackWHIRROM.HistoryFailure,decoded] + +theorem terminalFailure_congr (p : Profile) (oldCatalog newCatalog : WHIRReplay.Catalog p) + (old new : WHIRReplay.Roots) {B : Nat} (result : WHIRROM.TerminalView p B) + (catalog : oldCatalog result.request.statement = newCatalog result.request.statement) + (agree : AgreeOn (historyFootprint p result.request.statement result.request.messages) old new) : + WHIRROM.TerminalFailure p oldCatalog old result ↔ WHIRROM.TerminalFailure p newCatalog new result := by + have decoded : ∀ past, + WHIRReplay.decode p oldCatalog old ⟨result.request.statement,result.request.messages,past⟩ = + WHIRReplay.decode p newCatalog new ⟨result.request.statement,result.request.messages,past⟩ := + fun past => decode_congr p oldCatalog newCatalog old new _ catalog agree + simp only [WHIRROM.TerminalFailure,decoded] + +/-- A frozen allocation needs no commitment first mentioned later in its branch. -/ +theorem historyFootprint_drop (p : Profile) (s : Digest32) (messages : List Pending) + (i : Nat) : ∀ ref ∈ historyFootprint p s (messages.drop i), + ref ∈ historyFootprint p s messages := by + induction i generalizing messages with + | zero => simp + | succ i ih => + cases messages with + | nil => simp [historyFootprint] + | cons m messages => + cases messages with + | nil => simp [historyFootprint,List.drop] + | cons previous older => + intro ref member + exact List.mem_append_left _ (ih (previous :: older) ref member) + +theorem AgreeOn.drop {p : Profile} {s : Digest32} {messages : List Pending} + {old new : WHIRReplay.Roots} (agree : AgreeOn (historyFootprint p s messages) old new) + (i : Nat) : AgreeOn (historyFootprint p s (messages.drop i)) old new := + agree.mono (historyFootprint_drop p s messages i) + +end Whir.WHIRSnapshotReplay diff --git a/verification/whir/Whir/WHIRSourceChronology.lean b/verification/whir/Whir/WHIRSourceChronology.lean new file mode 100644 index 000000000..caa8f470d --- /dev/null +++ b/verification/whir/Whir/WHIRSourceChronology.lean @@ -0,0 +1,382 @@ +import Whir.DuplexRawProgram +import Whir.CausalBindingState +import Whir.PublicMerkleLog + +/-! Source-owned bookkeeping is returned by the executable interaction, not supplied as a claimed trace or read from simulator-private state. The compiler preserves every public query, answer, result, and complete-path budget. This module does not assert that an arbitrary caller's claims can be recovered from its transcript bytes. -/ +namespace Whir.WHIRSourceChronology +open FiatShamirGame DuplexModeGame + +inductive Event (cap : Nat) where + | answer (query : Query) (value : Digest32) + | commit (root : Digest32) + | claims (profile : ParameterBounds.Profile) (entry : FramedHistory) + (request : CausalBindingState.ClaimRequest cap profile) + +structure Result (cap : Nat) (R : Type) where + value : R + events : List (Event cap) + +inductive Source (cap : Nat) (R : Type) where + | done (value : R) + | ask (query : Query) (next : Digest32 → Source cap R) + | commit (root : Digest32) (next : Source cap R) + | claims (profile : ParameterBounds.Profile) (entry : FramedHistory) + (request : CausalBindingState.ClaimRequest cap profile) (next : Source cap R) + +def prepend (event : Event cap) (result : Result cap R) : Result cap R := + ⟨result.value,event :: result.events⟩ + +def map (f : R → S) : Program R → Program S + | .done r => .done (f r) + | .ask q next => .ask q (fun answer => map f (next answer)) + +def compile : Source cap R → Program (Result cap R) + | .done r => .done ⟨r,[]⟩ + | .ask q next => .ask q (fun answer => map (prepend (.answer q answer)) (compile (next answer))) + | .commit root next => map (prepend (.commit root)) (compile next) + | .claims p entry request next => map (prepend (.claims p entry request)) (compile next) + +def erase : Source cap R → Program R + | .done r => .done r + | .ask q next => .ask q (fun answer => erase (next answer)) + | .commit _ next => erase next + | .claims _ _ _ next => erase next + +def observations : List (Event cap) → List Observation + | [] => [] + | .answer q d :: rest => ⟨q,d⟩ :: observations rest + | .commit _ :: rest => observations rest + | .claims _ _ _ :: rest => observations rest + +def Counts : Nat → Source cap R → Prop + | _, .done _ => True + | Q, .ask q next => q.cost ≤ Q ∧ ∀ d, Counts (Q-q.cost) (next d) + | Q, .commit _ next => Counts Q next + | Q, .claims _ _ _ next => Counts Q next + +theorem map_counted (f : R → S) (p : Program R) (Q : Nat) : + DuplexModeGame.Counts Q (map f p) ↔ DuplexModeGame.Counts Q p := by + induction p generalizing Q with + | done => rfl + | ask q next ih => simp only [map, DuplexModeGame.Counts, ih] + +theorem compile_counted (p : Source cap R) (Q : Nat) : + DuplexModeGame.Counts Q (compile p) ↔ Counts Q p := by + induction p generalizing Q with + | done => rfl + | ask q next ih => simp only [compile, Counts, DuplexModeGame.Counts, map_counted, ih] + | commit root next ih => simpa only [compile, Counts, map_counted] using ih Q + | claims profile entry request next ih => simpa only [compile, Counts, map_counted] using ih Q + +theorem erase_counted (p : Source cap R) (Q : Nat) : + DuplexModeGame.Counts Q (erase p) ↔ Counts Q p := by + induction p generalizing Q with + | done => rfl + | ask q next ih => simp only [erase, Counts, DuplexModeGame.Counts, ih] + | commit root next ih => exact ih Q + | claims profile entry request next ih => exact ih Q + +def mapExecution (f : R → S) (execution : Execution R) : Execution S := + {view := ⟨execution.view.observations,f execution.view.result⟩ + primitiveCost := execution.primitiveCost + constructionRequests := execution.constructionRequests + simulatorQueries := execution.simulatorQueries} + +theorem map_real (f : R → S) (oracle : PrimitiveOracle) (iv : Digest32) (p : Program R) : + runReal oracle iv (map f p) = mapExecution f (runReal oracle iv p) := by + induction p with + | done => rfl + | ask q next ih => simp only [map, runReal, ih]; rfl + +theorem map_ideal {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (f : R → S) + (p : Program R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : DuplexModeGame.Counts remaining p) : + runIdeal sim ro iv state (map f p) remaining limit ((map_counted f p remaining).mpr counted) = + mapExecution f (runIdeal sim ro iv state p remaining limit counted) := by + induction p generalizing state remaining with + | done => rfl + | ask q next ih => + cases q with + | primitive purpose input => + let answer := runRO ro (sim.answer state input) + exact congrArg (DuplexModeGame.prepend (.primitive purpose input) answer.1.2 answer.2) + (ih answer.1.2 answer.1.1 (remaining-1) (by omega) (counted.2 answer.1.2)) + | construction coordinate valid => + let answer := ro (constructionKey Q iv coordinate (counted.1.trans limit)) + exact congrArg (DuplexModeGame.prepend (.construction coordinate valid) answer 0) + (ih answer state (remaining-DuplexFraming.pathCost coordinate) (by omega) (counted.2 answer)) + +theorem real_source_trace (oracle : PrimitiveOracle) (iv : Digest32) (p : Source cap R) : + observations (runReal oracle iv (compile p)).view.result.events = + (runReal oracle iv (compile p)).view.observations := by + induction p with + | done => rfl + | ask q next ih => simpa only [compile, runReal, map_real, mapExecution, DuplexModeGame.prepend, + prepend, observations] using congrArg (List.cons ⟨q,realAnswer oracle iv q⟩) (ih (realAnswer oracle iv q)) + | commit root next ih => simpa only [compile, map_real, mapExecution, prepend, observations] using ih + | claims profile entry request next ih => simpa only [compile, map_real, mapExecution, prepend, observations] using ih + +theorem real_source_erasure (oracle : PrimitiveOracle) (iv : Digest32) (p : Source cap R) : + mapExecution Result.value (runReal oracle iv (compile p)) = runReal oracle iv (erase p) := by + induction p with + | done => rfl + | ask q next ih => + simp only [compile, erase, runReal, map_real] + rw [← ih (realAnswer oracle iv q)] + rfl + | commit root next ih => simpa only [compile, erase, map_real, mapExecution, prepend] using ih + | claims profile entry request next ih => simpa only [compile, erase, map_real, mapExecution, prepend] using ih + +structure Prefix (cap : Nat) (R : Type) where + events : List (Event cap) + pending : Option Query + value : Option R + +def prependPrefix (event : Event cap) (seen : Prefix cap R) : Prefix cap R := + {seen with events := event :: seen.events} + +/-- Stop before the first unanswered public query. Commit and claim instructions before that query are retained, including instructions between two queries. No future reply or simulator seed is an argument. -/ +def recover : Source cap R → List Observation → Prefix cap R + | .done r, _ => ⟨[],none,some r⟩ + | .ask q _, [] => ⟨[],some q,none⟩ + | .ask q next, answer :: rest => + prependPrefix (.answer q answer.answer) (recover (next answer.answer) rest) + | .commit root next, answers => prependPrefix (.commit root) (recover next answers) + | .claims p entry request next, answers => + prependPrefix (.claims p entry request) (recover next answers) + +def completedPrefix (result : Result cap R) : Prefix cap R := + ⟨result.events,none,some result.value⟩ + +theorem recover_real (oracle : PrimitiveOracle) (iv : Digest32) (p : Source cap R) : + recover p (runReal oracle iv (compile p)).view.observations = + completedPrefix (runReal oracle iv (compile p)).view.result := by + induction p with + | done => rfl + | ask q next ih => + simpa only [compile, runReal, map_real, mapExecution, DuplexModeGame.prepend, recover, + prepend, prependPrefix, completedPrefix] using + congrArg (prependPrefix (.answer q (realAnswer oracle iv q))) (ih (realAnswer oracle iv q)) + | commit root next ih => + simpa only [compile, map_real, mapExecution, recover, prepend, prependPrefix, completedPrefix] + using congrArg (prependPrefix (.commit root)) ih + | claims profile entry request next ih => + simpa only [compile, map_real, mapExecution, recover, prepend, prependPrefix, completedPrefix] + using congrArg (prependPrefix (.claims profile entry request)) ih + +theorem recover_ideal {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) + (p : Source cap R) (remaining : Nat) (limit : remaining ≤ Q) (counted : Counts remaining p) : + recover p (runIdeal sim ro iv state (compile p) remaining limit + ((compile_counted p remaining).mpr counted)).view.observations = + completedPrefix (runIdeal sim ro iv state (compile p) remaining limit + ((compile_counted p remaining).mpr counted)).view.result := by + induction p generalizing state remaining with + | done => rfl + | ask q next ih => + cases q with + | primitive purpose input => + let answer := runRO ro (sim.answer state input) + have mapped := map_ideal sim ro iv answer.1.1 + (prepend (.answer (.primitive purpose input) answer.1.2)) + (compile (next answer.1.2)) (remaining-1) (by omega) + ((compile_counted _ _).mpr (counted.2 answer.1.2)) + have inner := ih answer.1.2 answer.1.1 (remaining-1) (by omega) (counted.2 answer.1.2) + have whole : runIdeal sim ro iv state (compile (.ask (.primitive purpose input) next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := + congrArg (DuplexModeGame.prepend (.primitive purpose input) answer.1.2 answer.2) mapped + rw [whole] + simpa only [mapExecution, DuplexModeGame.prepend, recover, prepend, prependPrefix, + completedPrefix] using congrArg (prependPrefix (.answer (.primitive purpose input) answer.1.2)) inner + | construction coordinate valid => + let answer := ro (constructionKey Q iv coordinate (counted.1.trans limit)) + have mapped := map_ideal sim ro iv state + (prepend (.answer (.construction coordinate valid) answer)) + (compile (next answer)) (remaining-DuplexFraming.pathCost coordinate) (by omega) + ((compile_counted _ _).mpr (counted.2 answer)) + have inner := ih answer state (remaining-DuplexFraming.pathCost coordinate) + (by omega) (counted.2 answer) + have whole : runIdeal sim ro iv state (compile (.ask (.construction coordinate valid) next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := + congrArg (DuplexModeGame.prepend (.construction coordinate valid) answer 0) mapped + rw [whole] + simpa only [mapExecution, DuplexModeGame.prepend, recover, prepend, prependPrefix, + completedPrefix] using congrArg (prependPrefix (.answer (.construction coordinate valid) answer)) inner + | commit root next ih => + have mapped := map_ideal sim ro iv state (prepend (.commit root)) (compile next) + remaining limit ((compile_counted _ _).mpr counted) + have whole : runIdeal sim ro iv state (compile (.commit root next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := mapped + rw [whole] + simpa only [mapExecution, recover, prepend, prependPrefix, completedPrefix] + using congrArg (prependPrefix (.commit root)) (ih state remaining limit counted) + | claims profile entry request next ih => + have mapped := map_ideal sim ro iv state (prepend (.claims profile entry request)) (compile next) + remaining limit ((compile_counted _ _).mpr counted) + have whole : runIdeal sim ro iv state (compile (.claims profile entry request next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := mapped + rw [whole] + simpa only [mapExecution, recover, prepend, prependPrefix, completedPrefix] + using congrArg (prependPrefix (.claims profile entry request)) (ih state remaining limit counted) + +def observeRecords (state : CausalBindingState.State cap) + (records : MerkleTransport.Commitments.Records) : CausalBindingState.State cap := + records.foldl (fun state record => CausalBindingState.observe state record.1 record.2) state + +theorem observeRecords_extends (state : CausalBindingState.State cap) + (records : MerkleTransport.Commitments.Records) : + CausalBindingState.Extends state (observeRecords state records) := by + induction records generalizing state with + | nil => exact .refl _ + | cons record rest ih => + exact (CausalBindingState.observe_extends state record.1 record.2).trans (ih _) + +theorem observeRecords_authentic (hash : MerkleTransport.Primitive) + (state : CausalBindingState.State cap) (records : MerkleTransport.Commitments.Records) + (old : CausalBindingState.AuthenticState hash state) + (new : MerkleTransport.Commitments.Authentic hash records) : + CausalBindingState.AuthenticState hash (observeRecords state records) := by + induction records generalizing state with + | nil => exact old + | cons record rest ih => + apply ih + · exact CausalBindingState.observe_authentic hash state record.1 record.2 old + (new _ _ (by simp)) + · intro bytes digest member + exact new bytes digest (by simp [member]) + +/-- Ordinary Merkle hashes are recognized from actual public compression inputs and replies, including multiblock and final-first traces. A purported high-level hash record is never an input. -/ +def observePublic (state : CausalBindingState.State cap) (input : DuplexFraming.Node) + (answer : Digest32) : CausalBindingState.State cap := + let observed := PublicMerkleLog.observe state.publicLog input answer + observeRecords {state with publicLog := observed.1} observed.2 + +theorem observePublic_extends (state : CausalBindingState.State cap) + (input : DuplexFraming.Node) (answer : Digest32) : + CausalBindingState.Extends state (observePublic state input answer) := by + exact (show CausalBindingState.Extends state + {state with publicLog := (PublicMerkleLog.observe state.publicLog input answer).1} from + ⟨fun _ _ h => h,fun _ _ h => h,fun _ _ _ => rfl,fun _ _ _ h => h,fun _ _ _ => rfl⟩).trans + (observeRecords_extends _ _) + +theorem observePublic_authentic (oracle : PrimitiveOracle) (state : CausalBindingState.State cap) + (input : DuplexFraming.Node) + (old : CausalBindingState.AuthenticState (PublicMerkleLog.hash oracle) state) + (log : PublicMerkleLog.AuthenticLog oracle state.publicLog) : + CausalBindingState.AuthenticState (PublicMerkleLog.hash oracle) + (observePublic state input (oracle input)) := + observeRecords_authentic _ _ _ old (PublicMerkleLog.observe_authentic oracle state.publicLog log input) + +/-- Missing commitment announcements are explicit bookkeeping errors. Claim metadata checks announcement order only: original claims are recovered by the concrete caller decoder, never installed from this event. -/ +def step (state : CausalBindingState.State cap) : + Event cap → Except Digest32 (CausalBindingState.State cap) + | .answer (.primitive _ input) answer => .ok (observePublic state input answer) + | .answer (.construction _ _) _ => .ok state + | .commit root => .ok (CausalBindingState.registerRoot state root) + | .claims _ _ request => + match MerkleTransport.Commitments.lookup request.root state.registry with + | none => .error request.root + | some _ => .ok state + +theorem step_extends (state next : CausalBindingState.State cap) (event : Event cap) + (success : step state event = .ok next) : CausalBindingState.Extends state next := by + cases event with + | answer query value => + cases query with + | primitive purpose input => + cases success + exact observePublic_extends _ _ _ + | construction coordinate valid => + cases success + exact .refl _ + | commit root => + cases success + exact CausalBindingState.registerRoot_extends _ _ + | claims profile entry request => + unfold step at success + cases found : MerkleTransport.Commitments.lookup request.root state.registry with + | none => simp [found] at success + | some snapshot => + simp only [found] at success + cases success + exact .refl _ + +def replay (state : CausalBindingState.State cap) : + List (Event cap) → Except Digest32 (CausalBindingState.State cap) + | [] => .ok state + | event :: rest => + match step state event with + | .error root => .error root + | .ok next => replay next rest + +theorem replay_extends (state next : CausalBindingState.State cap) (events : List (Event cap)) + (success : replay state events = .ok next) : CausalBindingState.Extends state next := by + induction events generalizing state with + | nil => cases success; exact .refl _ + | cons event rest ih => + unfold replay at success + cases progress : step state event with + | error root => simp [progress] at success + | ok middle => + exact (step_extends state middle event progress).trans (ih middle (by simpa [progress] using success)) + +theorem replay_retains_commitment (state next : CausalBindingState.State cap) + (events : List (Event cap)) (success : replay state events = .ok next) + (profile : ParameterBounds.Profile) (root : Digest32) (lanes : Nat) + (bound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (snapshot : MerkleTransport.Commitments.Snapshot) + (known : MerkleTransport.Commitments.lookup root state.registry = some snapshot) : + CausalBindingState.capture next profile root lanes bound = + CausalBindingState.capture state profile root lanes bound := + (CausalBindingState.capture_stable (replay_extends state next events success) + profile root lanes bound snapshot known).symm + +/-- Public source metadata is retained only up to the next unanswered query. In particular the current reply and every claim derived after it are excluded. -/ +def beforeAnswers : Nat → List (Event cap) → List (Event cap) + | _, [] => [] + | 0, .answer _ _ :: _ => [] + | n+1, event@(.answer _ _) :: rest => event :: beforeAnswers n rest + | n, event@(.commit _) :: rest => event :: beforeAnswers n rest + | n, event@(.claims _ _ _) :: rest => event :: beforeAnswers n rest + +theorem beforeAnswers_recover (p : Source cap R) (answers : List Observation) (n : Nat) : + beforeAnswers n (recover p answers).events = (recover p (answers.take n)).events := by + induction p generalizing answers n with + | done => rfl + | ask q next ih => + cases answers with + | nil => cases n <;> rfl + | cons answer rest => + cases n with + | zero => rfl + | succ n => + simpa only [recover, prependPrefix, beforeAnswers, List.take_succ_cons] using + congrArg (List.cons (.answer q answer.answer)) (ih answer.answer rest n) + | commit root next ih => + simpa only [recover, prependPrefix, beforeAnswers] using + congrArg (List.cons (.commit root)) (ih answers n) + | claims profile entry request next ih => + simpa only [recover, prependPrefix, beforeAnswers] using + congrArg (List.cons (.claims profile entry request)) (ih answers n) + +theorem beforeAnswers_ideal_prefix {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Source cap R) + (remaining : Nat) (limit : remaining ≤ Q) (counted : Counts remaining p) + (seen : List Observation) + (prior : seen.IsPrefix (runIdeal sim ro iv state (compile p) remaining limit + ((compile_counted p remaining).mpr counted)).view.observations) : + beforeAnswers seen.length (runIdeal sim ro iv state (compile p) remaining limit + ((compile_counted p remaining).mpr counted)).view.result.events = (recover p seen).events := by + have take : (runIdeal sim ro iv state (compile p) remaining limit + ((compile_counted p remaining).mpr counted)).view.observations.take seen.length = seen := by + obtain ⟨rest,eq⟩ := prior + rw [← eq] + simp + have recovered := congrArg Prefix.events (recover_ideal sim ro iv state p remaining limit counted) + have cut := beforeAnswers_recover p (runIdeal sim ro iv state (compile p) remaining limit + ((compile_counted p remaining).mpr counted)).view.observations seen.length + rw [recovered,take] at cut + exact cut + +end Whir.WHIRSourceChronology diff --git a/verification/whir/Whir/WHIRSourceObserver.lean b/verification/whir/Whir/WHIRSourceObserver.lean new file mode 100644 index 000000000..5ad31f462 --- /dev/null +++ b/verification/whir/Whir/WHIRSourceObserver.lean @@ -0,0 +1,105 @@ +import Whir.WHIRSourceChronology +import Whir.DuplexPublicSimulator + +namespace Whir.WHIRSourceObserver +open FiatShamirGame DuplexModeGame +open WHIRSourceChronology + +/-- Only the returned source trace and public observations are inspected. The current missing raw reply, and metadata derived after it, are excluded. -/ +def publicEvents (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (view : View (Result cap R)) : List (Event cap) := + beforeAnswers (DuplexPublicSimulator.publicCut Q iv cache [] view.observations).length + view.result.events + +/-- The causal experiment can rerun its fixed source from its fixed simulator coins, but stops at the first unavailable raw answer. This definition has no total-oracle argument. -/ +def privateEvents (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) : + List (Event cap) := + (recover source (DuplexPublicSimulator.runPartial cache iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted)).observations).events + +theorem publicEvents_actual (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (agrees : DuplexPublicSimulator.CacheAgrees cache ro) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) : + publicEvents Q iv cache (runIdeal (DuplexPublicSimulator.simulator Q) ro iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted)).view = + privateEvents Q iv cache seed source counted := by + unfold publicEvents privateEvents + have cut := DuplexPublicSimulator.publicCut_runPartial cache ro agrees iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted) + change DuplexPublicSimulator.publicCut Q iv cache [] _ = _ at cut + rw [cut] + apply beforeAnswers_ideal_prefix (DuplexPublicSimulator.simulator Q) ro iv + ((DuplexPublicSimulator.simulator Q).initial seed) source Q (by omega) counted + obtain ⟨suffix,eq⟩ := DuplexPublicSimulator.runPartial_prefix cache ro agrees iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted) + exact ⟨suffix,eq.symm⟩ + +/-- Failed commitment-order bookkeeping is sticky. Previously captured commitments remain available, but an invalid source chronology is never silently repaired by later announcements. -/ +def replayTracked (state : CausalBindingState.State cap) : + List (Event cap) → CausalBindingState.State cap + | [] => state + | event :: rest => + match state.sourceError with + | some _ => state + | none => + match step state event with + | .error root => {state with sourceError := some root} + | .ok next => replayTracked next rest + +theorem replayTracked_extends (state : CausalBindingState.State cap) (events : List (Event cap)) : + CausalBindingState.Extends state (replayTracked state events) := by + induction events generalizing state with + | nil => exact .refl _ + | cons event rest ih => + unfold replayTracked + cases failed : state.sourceError with + | some root => exact .refl _ + | none => + cases progress : step state event with + | error root => exact ⟨fun _ _ h => h,fun _ _ h => h,fun _ _ _ => rfl, + fun _ _ _ h => h,fun _ _ _ => rfl⟩ + | ok next => exact (step_extends state next event progress).trans (ih next) + +theorem replayTracked_failed (state : CausalBindingState.State cap) (events : List (Event cap)) + (root : Digest32) (failed : state.sourceError = some root) : + replayTracked state events = state := by + cases events <;> simp [replayTracked,failed] + +def publicReplay (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (view : View (Result cap R)) (state : CausalBindingState.State cap) : + CausalBindingState.State cap := + replayTracked state (publicEvents Q iv cache view) + +def privateReplay (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) : CausalBindingState.State cap := + replayTracked state (privateEvents Q iv cache seed source counted) + +theorem publicReplay_actual (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (agrees : DuplexPublicSimulator.CacheAgrees cache ro) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) : + publicReplay Q iv cache (runIdeal (DuplexPublicSimulator.simulator Q) ro iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted)).view state = + privateReplay Q iv cache seed source counted state := by + unfold publicReplay privateReplay + rw [publicEvents_actual Q iv cache ro agrees seed source counted] + +theorem publicReplay_extends (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (view : View (Result cap R)) (state : CausalBindingState.State cap) : + CausalBindingState.Extends state (publicReplay Q iv cache view state) := + replayTracked_extends _ _ + +theorem privateReplay_extends (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) : + CausalBindingState.Extends state (privateReplay Q iv cache seed source counted state) := + replayTracked_extends _ _ + +end Whir.WHIRSourceObserver diff --git a/verification/whir/differential/run.py b/verification/whir/differential/run.py index bbb4da37e..8268dae7e 100755 --- a/verification/whir/differential/run.py +++ b/verification/whir/differential/run.py @@ -8,11 +8,16 @@ HERE = Path(__file__).resolve().parent PACKAGE = HERE.parent SCOPE = ["systemd-run", "--user", "--scope", "-q", "-p", "MemoryMax=16G", "-p", "MemorySwapMax=0"] -ENV = dict(os.environ, CARGO_TARGET_DIR="/tmp/whir-lean-target", CARGO_BUILD_JOBS="2", LEANVM_NUM_THREADS="1") +ENV = dict(os.environ, CARGO_TARGET_DIR="/tmp/whir-lean-target", CARGO_BUILD_JOBS="2", LEANVM_NUM_THREADS="1", LEAN_NUM_THREADS="2") -def run(command, cwd=PACKAGE): - result = subprocess.run(SCOPE + command, cwd=cwd, env=ENV, text=True, stdout=subprocess.PIPE, check=True) +def run(command, cwd=PACKAGE, clean_stderr=False): + result = subprocess.run( + SCOPE + command, cwd=cwd, env=ENV, text=True, stdout=subprocess.PIPE, + stderr=subprocess.PIPE if clean_stderr else None, check=True, + ) + if clean_stderr and result.stderr: + raise RuntimeError(f"Model emitted a runtime diagnostic:\n{result.stderr}") return result.stdout @@ -30,7 +35,7 @@ def main(): run(["lake", "build", "whirModel"]) rust = records(run(["cargo", "+1.97", "run", "--release", "--locked", "--manifest-path", str(HERE / "Cargo.toml")])) executable = str(PACKAGE / ".lake" / "build" / "bin" / "whirModel") - lean = records(run([executable])) + lean = records(run([executable], clean_stderr=True)) lean_smoke = lean.pop("lean_smoke") rust_smoke = rust.pop("rust_smoke") query_cases = [] @@ -40,7 +45,7 @@ def main(): values = rust.pop(key) expected = rust.pop(f"query_output_{depth}_{count}") limbs = values.split(",") if values else [] - actual = records(run([executable, "query", depth, count, *limbs])) + actual = records(run([executable, "query", depth, count, *limbs], clean_stderr=True)) if actual != {"queries": expected}: raise AssertionError(f"Query mismatch at depth={depth}, count={count}: {actual} != {expected}") query_cases.append((int(depth), int(count))) @@ -49,12 +54,10 @@ def main(): for key in lean: if lean[key] != rust[key]: raise AssertionError(f"Differential mismatch in {key}:\nLean {lean[key]}\nRust {rust[key]}") - if not lean_smoke.startswith("honest,") or not rust_smoke.startswith("honest,"): - raise AssertionError("Missing successful opening smokes") print(f"PASS: {len(lean)} live arithmetic/encoding/folding/weight vectors; {len(query_cases)} production query batches {query_cases}") print("Lean ideal replay: " + lean_smoke) print("Rust production opening: " + rust_smoke) - print("Boundary: no Lean refinement of bit arithmetic to Field, hash/FS/PoW, or cryptographic soundness is claimed.") + print("Boundary: differential execution is not Rust compiler correctness or an instantiation of cryptographic assumptions.") if __name__ == "__main__": diff --git a/verification/whir/lake-manifest.json b/verification/whir/lake-manifest.json index 9953533a1..8932859f7 100644 --- a/verification/whir/lake-manifest.json +++ b/verification/whir/lake-manifest.json @@ -1,7 +1,17 @@ {"version": "1.2.0", "packagesDir": ".lake/packages", "packages": - [{"url": "https://github.com/leanprover-community/mathlib4.git", + [{"url": "https://github.com/kevaundray/ArkLib", + "type": "git", + "subDir": null, + "scope": "", + "rev": "456f4f85acdde6aeb373794d0c5d0b133c2c11ea", + "name": "Arklib", + "manifestFile": "lake-manifest.json", + "inputRev": "456f4f85acdde6aeb373794d0c5d0b133c2c11ea", + "inherited": false, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover-community/mathlib4.git", "type": "git", "subDir": null, "scope": "", @@ -11,6 +21,46 @@ "inputRev": "5ed2965256430c3649e86755f9576b54eca72435", "inherited": false, "configFile": "lakefile.lean"}, + {"url": "https://github.com/Verified-zkEVM/CompPoly", + "type": "git", + "subDir": null, + "scope": "", + "rev": "df591bb8c6745126d1d72f5243faae3022b0432a", + "name": "CompPoly", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.34.0-patch2", + "inherited": true, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/PatrickMassot/checkdecls.git", + "type": "git", + "subDir": null, + "scope": "", + "rev": "3d425859e73fcfbef85b9638c2a91708ef4a22d4", + "name": "checkdecls", + "manifestFile": "lake-manifest.json", + "inputRev": "lean4.18.0", + "inherited": true, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/leanprover/doc-gen4", + "type": "git", + "subDir": null, + "scope": "", + "rev": "a6521b2d0c93dcdf2d640089f95548df5dd8bf46", + "name": "«doc-gen4»", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.34.0", + "inherited": true, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/Verified-zkEVM/VCVio", + "type": "git", + "subDir": null, + "scope": "", + "rev": "d7089e46d69e07640fa23b5ae6b1b966f1d4b949", + "name": "VCVio", + "manifestFile": "lake-manifest.json", + "inputRev": "d7089e46d69e07640fa23b5ae6b1b966f1d4b949", + "inherited": true, + "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, @@ -81,6 +131,16 @@ "inputRev": "main", "inherited": true, "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover/leansqlite", + "type": "git", + "subDir": null, + "scope": "", + "rev": "f9cdb9eacb5c8b8ecc02ee9fd9e568d7d28c1416", + "name": "leansqlite", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover/lean4-cli", "type": "git", "subDir": null, @@ -90,6 +150,56 @@ "manifestFile": "lake-manifest.json", "inputRev": "v4.34.0", "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/fgdorais/lean4-unicode-basic", + "type": "git", + "subDir": null, + "scope": "", + "rev": "0e569d08b6443ce0908d356884c765397253e2f0", + "name": "UnicodeBasic", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/dupuisf/BibtexQuery", + "type": "git", + "subDir": null, + "scope": "", + "rev": "4d8616fd4870d0a3453d845770833eac7951fe1c", + "name": "BibtexQuery", + "manifestFile": "lake-manifest.json", + "inputRev": "master", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/acmepjz/md4lean", + "type": "git", + "subDir": null, + "scope": "", + "rev": "31907cc18f48a95384f99cee5582c00fb39e0f67", + "name": "MD4Lean", + "manifestFile": "lake-manifest.json", + "inputRev": "main", + "inherited": true, + "configFile": "lakefile.lean"}, + {"url": "https://github.com/Verified-zkEVM/PolyFun", + "type": "git", + "subDir": null, + "scope": "", + "rev": "3710d71b28404a151b8d1f0ce080ea448778dec0", + "name": "PolyFun", + "manifestFile": "lake-manifest.json", + "inputRev": "3710d71b28404a151b8d1f0ce080ea448778dec0", + "inherited": true, + "configFile": "lakefile.toml"}, + {"url": "https://github.com/leanprover/cslib", + "type": "git", + "subDir": null, + "scope": "leanprover", + "rev": "990e65a685bed413f43b139db900a36ad5322a10", + "name": "cslib", + "manifestFile": "lake-manifest.json", + "inputRev": "v4.34.0", + "inherited": true, "configFile": "lakefile.toml"}], "name": "whirVerification", "lakeDir": ".lake", diff --git a/verification/whir/lakefile.toml b/verification/whir/lakefile.toml index fd4e585f5..bd83592b2 100644 --- a/verification/whir/lakefile.toml +++ b/verification/whir/lakefile.toml @@ -7,6 +7,11 @@ name = "mathlib" git = "https://github.com/leanprover-community/mathlib4.git" rev = "5ed2965256430c3649e86755f9576b54eca72435" +[[require]] +name = "Arklib" +git = "https://github.com/kevaundray/ArkLib" +rev = "456f4f85acdde6aeb373794d0c5d0b133c2c11ea" + [[lean_lib]] name = "Whir" From bc955fc361cfbd46cc417113fecd1ea1548d3cdc Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Thu, 8 Oct 2026 23:27:22 +0100 Subject: [PATCH 04/28] Compose native WHIR verification with observable list-binding games --- verification/whir/README.md | 24 +- verification/whir/Whir.lean | 2 + .../whir/Whir/PrunedMerkleCoverage.lean | 300 ++++ .../whir/Whir/PublicCompressionProgram.lean | 231 +++ .../whir/Whir/PublicMerkleProbability.lean | 526 ++++++ verification/whir/Whir/WHIRCallerClaims.lean | 184 +++ .../whir/Whir/WHIRCallerGeometry.lean | 916 +++++++++++ .../whir/Whir/WHIRCallerRegistry.lean | 399 +++++ verification/whir/Whir/WHIRCallerSource.lean | 1285 +++++++++++++++ verification/whir/Whir/WHIRCallerSupport.lean | 910 +++++++++++ verification/whir/Whir/WHIRHeaderRoots.lean | 287 ++++ verification/whir/Whir/WHIRNativeEvent.lean | 28 + .../whir/Whir/WHIRNativeRestoration.lean | 38 + .../whir/Whir/WHIRNativeSecurity.lean | 187 +++ .../whir/Whir/WHIRObservableSecurity.lean | 150 ++ .../whir/Whir/WHIRObservableSource.lean | 246 +++ .../whir/Whir/WHIRPhysicalBinding.lean | 357 +++++ .../whir/Whir/WHIRPhysicalCaller.lean | 536 +++++++ .../whir/Whir/WHIRPhysicalDriver.lean | 222 +++ .../whir/Whir/WHIRPhysicalOpeningRuns.lean | 225 +++ .../whir/Whir/WHIRPhysicalReplay.lean | 622 ++++++++ verification/whir/Whir/WHIRPhysicalRoots.lean | 742 +++++++++ .../whir/Whir/WHIRPhysicalRowsRegression.lean | 114 ++ .../whir/Whir/WHIRPhysicalSnapshots.lean | 498 ++++++ .../whir/Whir/WHIRPhysicalSoundness.lean | 884 +++++++++++ .../whir/Whir/WHIRPhysicalVerifier.lean | 925 +++++++++++ .../whir/Whir/WHIRQueryOracleRecurrence.lean | 638 ++++++++ verification/whir/Whir/WHIRRealSimulator.lean | 192 +++ .../whir/Whir/WHIRSourceAllocationCache.lean | 145 ++ .../whir/Whir/WHIRSourceAllocationOrigin.lean | 427 +++++ .../whir/Whir/WHIRSourceBackfill.lean | 352 ++++ verification/whir/Whir/WHIRSourceCatalog.lean | 470 ++++++ .../whir/Whir/WHIRSourceComposition.lean | 131 ++ .../whir/Whir/WHIRSourceFrozenPrefix.lean | 1411 +++++++++++++++++ .../whir/Whir/WHIRSourceMerkleSecurity.lean | 43 + .../whir/Whir/WHIRSourceObserver.lean | 78 +- .../whir/Whir/WHIRSourcePartialMonotone.lean | 385 +++++ .../whir/Whir/WHIRSourceRawCache.lean | 205 +++ .../whir/Whir/WHIRSourceRawProgram.lean | 208 +++ .../whir/Whir/WHIRSourceResolver.lean | 276 ++++ .../whir/Whir/WHIRSourceRootPolicy.lean | 675 ++++++++ 41 files changed, 16447 insertions(+), 27 deletions(-) create mode 100644 verification/whir/Whir/PrunedMerkleCoverage.lean create mode 100644 verification/whir/Whir/PublicCompressionProgram.lean create mode 100644 verification/whir/Whir/PublicMerkleProbability.lean create mode 100644 verification/whir/Whir/WHIRCallerClaims.lean create mode 100644 verification/whir/Whir/WHIRCallerGeometry.lean create mode 100644 verification/whir/Whir/WHIRCallerRegistry.lean create mode 100644 verification/whir/Whir/WHIRCallerSource.lean create mode 100644 verification/whir/Whir/WHIRCallerSupport.lean create mode 100644 verification/whir/Whir/WHIRHeaderRoots.lean create mode 100644 verification/whir/Whir/WHIRNativeEvent.lean create mode 100644 verification/whir/Whir/WHIRNativeRestoration.lean create mode 100644 verification/whir/Whir/WHIRNativeSecurity.lean create mode 100644 verification/whir/Whir/WHIRObservableSecurity.lean create mode 100644 verification/whir/Whir/WHIRObservableSource.lean create mode 100644 verification/whir/Whir/WHIRPhysicalBinding.lean create mode 100644 verification/whir/Whir/WHIRPhysicalCaller.lean create mode 100644 verification/whir/Whir/WHIRPhysicalDriver.lean create mode 100644 verification/whir/Whir/WHIRPhysicalOpeningRuns.lean create mode 100644 verification/whir/Whir/WHIRPhysicalReplay.lean create mode 100644 verification/whir/Whir/WHIRPhysicalRoots.lean create mode 100644 verification/whir/Whir/WHIRPhysicalRowsRegression.lean create mode 100644 verification/whir/Whir/WHIRPhysicalSnapshots.lean create mode 100644 verification/whir/Whir/WHIRPhysicalSoundness.lean create mode 100644 verification/whir/Whir/WHIRPhysicalVerifier.lean create mode 100644 verification/whir/Whir/WHIRQueryOracleRecurrence.lean create mode 100644 verification/whir/Whir/WHIRRealSimulator.lean create mode 100644 verification/whir/Whir/WHIRSourceAllocationCache.lean create mode 100644 verification/whir/Whir/WHIRSourceAllocationOrigin.lean create mode 100644 verification/whir/Whir/WHIRSourceBackfill.lean create mode 100644 verification/whir/Whir/WHIRSourceCatalog.lean create mode 100644 verification/whir/Whir/WHIRSourceComposition.lean create mode 100644 verification/whir/Whir/WHIRSourceFrozenPrefix.lean create mode 100644 verification/whir/Whir/WHIRSourceMerkleSecurity.lean create mode 100644 verification/whir/Whir/WHIRSourcePartialMonotone.lean create mode 100644 verification/whir/Whir/WHIRSourceRawCache.lean create mode 100644 verification/whir/Whir/WHIRSourceRawProgram.lean create mode 100644 verification/whir/Whir/WHIRSourceResolver.lean create mode 100644 verification/whir/Whir/WHIRSourceRootPolicy.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index 4a4341772..e9ef15e45 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -87,17 +87,17 @@ The production checkout used by the main differential harness still has the olde `DuplexModeGame` defines real public-compression and ideal raw-random-oracle/simulator games for adaptive direct and construction queries, including auxiliary and verifier work. Its transfer theorems expose two separate assumptions: `PublicRandomCompressionDMV` is the universal view-distinguishing bound for the actual mode and simulator; `ConcretePrimitiveGap` is the separate restricted-adversary gap between deterministic BLAKE2s and a random compression function. These are ordinary crypto games, not a PCS false-acceptance assumption. The external stochastic DMV theorem and a small concrete BLAKE2s advantage are not kernel-proved here. -### Published checked integration checkpoint +### Native source, caller and Merkle composition -`WHIRCausalRawROM.raw_table_list_binding` and `WHIRModeReplay.physical_table_list_binding` extend the bound to exact raw mode inputs, causal first-registration state, and physically completed caller/ancestor/final dependencies. The bound is `min 1 ((40 + callerOutputCap) * (K + 1) * (2^-79 + ringCharge cap))`. Allocation labels retain their pre-draw catalogs and root snapshots; a rejected caller entry is recorded separately from an unseen entry and cannot later be replaced by fabricated or valid claims. This theorem still takes a causal resolver. It is not yet the full production caller/source theorem. +`WHIRPhysicalDriver.verifyAfter` runs an arbitrary attacker-input source followed by the actual native verifier, not an arbitrary source returning fabricated acceptance evidence. Its one `ProductionRegistry` supplies both the physical CPU/recursion decoder and logical caller catalog, including production placements and lane counts. `WHIRPhysicalBinding.nativeFailure_or_frozen` proves that actual wrong native acceptance implies the causal raw-oracle failure or an ordinary Merkle primitive failure. Original caller decoding, actual sampled histories, authenticated-row restoration, first-frozen catalogs, opening-input lengths and coverage by actual compression calls are derived internally, not theorem premises. -`DuplexPublicSimulator` supplies a concrete public-query-log simulator, exact repeated-input caching, complete mode-input recognition, a checked private-query bound, and reconstruction of actual raw requests from public observations. `WHIRObservableAllocations` reconstructs the chronological allocation cache and dependency annotations from public raw answers and physically returned completion records, without receiving the adversary program, private coins, or a total oracle. `WHIRSourceObserver.publicReplay_actual` proves that a public-only cut of the returned source events equals the private finite-cache prefix replay. Composing this observer with the concrete production caller resolver and complete source acceptance remains in progress. +`WHIRNativeEvent.distinguisher` receives only the completed public result. `WHIRObservableSource.observe` reconstructs its chronological cache, labels and immutable first-registration state from public source events and physically returned completion records; neither receives a source program, adversary coins, simulator seed or total oracle. `WHIRSourceFrozenPrefix.actual_backfill_retained` connects every retained snapshot to its actual earlier full-compression prefix, including direct calls and hidden construction calls. The candidate list is `InitialCandidates.witnesses` of the first-frozen commitment, not a list selected after inspecting the claimed family; `bindClaims_witnesses` proves that binding claims leaves this list unchanged, and `WHIRPhysicalDriver.native_list_bound` bounds its cardinality by `2^32`. -`PrunedMerkleProgram` implements the actual flat pruned opener as counted public compression calls, including malformed-proof branches. `PublicMerkleBinding` reduces accepted deviations from first-frozen rows to observed compression collisions or an actual absent compression node hitting a previously fixed target, including final-first multiblock reconstruction. The probability bound for these ordinary Merkle primitive events is not yet part of this checkpoint. +`WHIRNativeSecurity.random_compression_list_binding` composes the actual native event with the checked adaptive raw-oracle bound, the explicit DMV game assumption, and `PublicMerkleProbability.opening_probability_bound`. Write `A = a + b` for attacker plus native-verifier source budgets, `R = (Q+1) * (free + (Q+1) * (40+1))`, and `epsilon = 2^-79 + ringCharge cap`. The bound is `min 1 ((40 + callerOutputCap) * (A+1) * epsilon) + min 1 (choose(Q,2) / 2^256) + (choose(Q,2) + Q*(R+3*Q)) / 2^256`. The physical budget is source-only and noncircular: `A + A*(pathFactor*A) + pathFactor*Mf <= Q`; verifier and final-path caps need hold only on reachable attacker outputs, and zero-cost commitment announcements have their own `FreeAnnouncements` resource. `WHIRNativeSecurity.concrete_list_binding` adds exactly one separate concrete-primitive gap for this final public native event, not an assumption about an unobservable Merkle event. No small concrete BLAKE2s gap is asserted. `SuccinctPointWeight.eqAt_eq_mle`, `SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle`, and `InducedTerminalRefinement.nativeBasisAt_eq_mle` connect the actual plain/strided selectors, shared-prefix ring evaluator, inverse-Frobenius coefficients, and native induced-basis recurrence to their dense meanings. `AccumulatedTerminalRefinement.stack_terminal_equivalence` composes every saved OOD/query context with the rotated original caller point. `WHIRNativeArithmetic.sourceVerify_refines` proves the complete scalar-only native-style verifier loop refines `Protocol.verify`, under explicit public shapes and authenticated-row premises; it does not assume caller-weight or terminal-evaluator equality. `WHIRNativeErasure.nativeVerify_erased` removes only ghost commitment oracles, preserving actual query rows and errors. -The checkpoint also fixes a Lean L0 extraction discrepancy: authenticate the full padded leaf, discard only its leading absent lanes, and reverse the occupied lanes exactly once at the protocol boundary. Separately executed pruned and full-width regression cases exercised the real parser and hash path. This is a model correction, distinct from the Rust guard fix below. +The model also fixes a Lean L0 extraction discrepancy: authenticate the full padded leaf, discard only its leading absent lanes, and reverse the occupied lanes exactly once at the protocol boundary. Separately executed pruned and full-width regression cases exercised the real parser and hash path. This is a model correction, distinct from the Rust guard fix below. ## Original papers and version limits @@ -119,19 +119,25 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 `Audit.lean` discovers every exported theorem in the elaborated `Whir` namespace and computes its transitive axioms. It rejects project axioms and every dependency axiom except `propext`, `Classical.choice` and `Quot.sound`. Selected principal algebra endpoints additionally retain `#print axioms` commands. No `sorry`, `admit`, `native_decide`, unsafe proof execution, or new correctness axiom is used in completed chains. Running the compiled model and Rust still trusts their compilers/runtime; differential testing is evidence for tested inputs, not a kernel proof of their correspondence. -The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, complete adaptive interactive list binding, typed and exact-raw oracle bounds, and the native scalar arithmetic refinement described above. The full observable production-source/caller/Merkle composition remains unfinished and is not claimed by this publication checkpoint. The Rust compiler, optimized Rust NTT, universal Rust-to-Lean correspondence, external DMV probability theorem, ordinary Merkle collision/target-hit probability bound, and concrete BLAKE2s idealization remain outside its kernel-proved conclusions. +The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, complete adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion callers, public source reconstruction, first-frozen Merkle transport, and the ordinary shared-compression collision/target-hit probability bound. The final native endpoints have resource-budget premises and the explicitly separated cryptographic game assumptions above, not verifier/source correctness, decoder agreement, row authentication or missing-cover premises. The Rust compiler, optimized Rust NTT, universal Rust-to-Lean correspondence, external DMV probability theorem and concrete BLAKE2s idealization remain outside the kernel-proved conclusions. -Merkle transport gives a fixed commitment-time row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. Concrete CPU/recursion caller decoding, production placement construction, and the physical source driver are being integrated separately; their unfinished files are not included in this checked checkpoint. +Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The concrete production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. The conditional public-mode theorem still targets only the pinned #552 source identified above, not the older keyed baseline. Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte-decoding error taxonomy or underflow behavior as production `TranscriptError`. The Rust smoke separately uses the actual stack-opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte-for-byte theorem for the older keyed transcript is claimed. Verification found and fixed a Lean model evaluation-order bug: a malformed public weight reached batching before its shape guard and emitted a runtime out-of-bounds diagnostic despite returning rejection. The guard now runs before batching; the maintained executable smoke and runner's stderr check cover it. No production Rust discrepancy follows from that model bug. +Further source composition exposed a second auxiliary-model bug: an invalid claim-order annotation stopped public compression observation although the underlying source program continued and later roots could still be registered. The observer now preserves its first error while continuing to record real public calls and commitments. This changes neither the native verifier nor the mode program, and claimed annotations still cannot install family or point data. An actual BLAKE2s reproduction failed before the correction with zero recorded calls and passed afterward with one recorded call and the original error unchanged. + ## Exercised validation -The dependency-closed publication checkpoint passed `lake build --wfail +Whir:olean +Main:olean` and the consolidated `lake env lean Audit.lean` census, with only `propext`, `Classical.choice` and `Quot.sound` permitted. Executing `lake env lean --run Main.lean` exercised the honest multilevel opening and its malformed/tampered rejection paths. The build also executed the maintained scalar-verifier, accumulated-terminal, public-simulator and backfill regressions. These are fresh checkpoint checks; the live Rust differential observations below were obtained separately, not rerun during publication. +The complete native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean` and the consolidated `lake env lean -E warning Audit.lean` census of 7477 exported theorem declarations, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound` permitted. Executing `lake env lean -E warning --run Main.lean` exercised the honest multilevel opening and its malformed/tampered rejection paths. This build freshly executed the maintained physical-row, source-backfill and partial-replay regressions; it replayed cached results for the previously executed scalar-verifier, accumulated-terminal and public-simulator regressions. The live Rust differential observations below were obtained separately, not rerun during this final publication. + +A separate executable public-observer smoke captured a pre-query commitment while excluding a reply-derived commitment until its raw answer became available, matched public and private causal prefixes, and confirmed that a source chronology error remains recorded after a later commitment. The protocol properties are enumerated above rather than counting generated declarations as independently substantial results. + +A separate production-registry `WHIRPhysicalDriver.verifyAfter` run accepted a genuine BLAKE2s-backed recursion opening with the real caller, both PoW checks and 56/32 query batches, then rejected changed occupied base-leaf data. Its complete attacker-prefix/native execution used 4948 compression calls within a checked reachable source budget of 5370; the selected terminal path had cost 103 within its checked cap. The maintained physical-row regression also executed padded 64-lane and full 4-lane nonzero base rows and two-element extension rows against independent BLAKE2s roots, checking duplicate queries and the single base-lane reversal. -A separate executable public-observer smoke captured a pre-query commitment while excluding a reply-derived commitment until its raw answer became available, matched public and private causal prefixes, and confirmed that a source chronology error remains rejected after a later commitment. The protocol properties are enumerated above rather than counting generated declarations as independently substantial results. +A separate source/completion run returned the actual ideal-source value, retained both repeated raw occurrences and all three physical completion cells while allocating only once, and reconstructed the cached raw answer. Its actual BLAKE2s execution returned the corresponding real mode value with the same completion count. The final native random-compression and concrete-primitive endpoints, and their deterministic native-to-raw-or-Merkle reduction, were individually axiom-audited with only the three permitted standard axioms. The live differential runner matched 71 record groups: 15 arithmetic/encoding/folding/weight groups plus all 56 production configurations. Six additional production query batches covered `(depth,count)` = `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`, including cross-limb extraction, uneven groups and repeated queries. Lean's three-level opening accepted and rejected wrong targets, short openings/final residuals, changed final residuals, missing queries, changed rows, changed/missing OOD answers, missing challenges and invalid layouts. Rust's real minimum-size stacked opening exercised ring-switch and point claims, truncated lanes, Merkle authentication, Fiat-Shamir and grinding; it rejected short/trailing streams, changed round/OOD/final scalars, missing authentication and invalid layouts. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index de66ff4c3..e1275db3c 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -139,3 +139,5 @@ import Whir.WHIRNativeArithmeticRegression import Whir.WHIRNativeErasure import Whir.WHIRSourceChronology import Whir.WHIRSourceObserver +import Whir.WHIRNativeSecurity +import Whir.WHIRPhysicalRowsRegression diff --git a/verification/whir/Whir/PrunedMerkleCoverage.lean b/verification/whir/Whir/PrunedMerkleCoverage.lean new file mode 100644 index 000000000..fdba444cc --- /dev/null +++ b/verification/whir/Whir/PrunedMerkleCoverage.lean @@ -0,0 +1,300 @@ +import Whir.PrunedMerkleProgram + +namespace Whir.PrunedMerkleProgram +open FiatShamirGame Concrete MerkleBinding MerkleLevels +open DuplexModeGame MerkleTransport + +theorem HashProgram.calls_bind {R S : Type} (H : Primitive) (p : HashProgram R) (next : R → HashProgram S) : + (p.bind next).calls H = p.calls H ++ (next (p.eval H)).calls H := by + induction p with + | done => rfl + | hash bytes cont ih => simp only [HashProgram.bind,HashProgram.calls,HashProgram.eval,ih,List.cons_append] + +theorem HashProgram.calls_map {R S : Type} (H : Primitive) (p : HashProgram R) (f : R → S) : + (p.map f).calls H = p.calls H := by + simp [HashProgram.map,HashProgram.calls_bind,HashProgram.calls] + +/-- Every even/odd pair retained by the level walk was actually hashed. +This states provenance, not just equality of recomputed root values. -/ +def PairedCoverage (known : Level Digest32) (calls : List (List Byte)) : Prop := + ∀ index left right, + lookup (2*index) known = some left → + lookup (2*index+1) known = some right → + pairBytes left right ∈ calls + +theorem PairedCoverage.prepend (known : Level Digest32) (calls : List (List Byte)) + (index : Nat) (left right : Digest32) (covered : PairedCoverage known calls) : + PairedCoverage ((2*index,left)::(2*index+1,right)::known) (pairBytes left right::calls) := by + intro j l r hl hr + by_cases same : j = index + · subst j + simp only [lookup,ite_true,Option.some.injEq] at hl + have hn : 2*index+1 ≠ 2*index := by omega + simp only [lookup,ite_eq_right hn,ite_true,Option.some.injEq] at hr + subst l + subst r + simp + · have hll : 2*j ≠ 2*index := by omega + have hlr : 2*j ≠ 2*index+1 := by omega + have hrl : 2*j+1 ≠ 2*index := by omega + have hrr : 2*j+1 ≠ 2*index+1 := by omega + simp only [lookup,ite_eq_right hll,ite_eq_right hlr] at hl + simp only [lookup,ite_eq_right hrl,ite_eq_right hrr] at hr + exact List.mem_cons_of_mem _ (covered j l r hl hr) + +theorem PairedCoverage.edge {known : Level Digest32} {calls : List (List Byte)} + (covered : PairedCoverage known calls) {index : Nat} {current other : Digest32} + (hc : lookup index known = some current) + (hs : lookup (MerkleLevels.sibling index) known = some other) : + List.ofFn (ByteCodec.pairBytes (MerkleLevels.orient index current other)) ∈ calls := by + by_cases even : index % 2 = 0 + · have he : 2*(index/2) = index := by omega + simpa only [MerkleLevels.orient,ite_eq_left even,pairBytes] using + covered (index/2) current other (by simpa [he] using hc) + (by simpa [he,MerkleLevels.sibling,even] using hs) + · have he : 2*(index/2) = index-1 := by omega + have ho : 2*(index/2)+1 = index := by omega + simpa only [MerkleLevels.orient,ite_eq_right even,pairBytes] using + covered (index/2) other current + (by simpa [he,MerkleLevels.sibling,even] using hs) (by simpa [ho] using hc) + +theorem foldLevel_calls_paired (H : Primitive) (i : Nat) (d e : Digest32) + (nodes : Level Digest32) (supplied : List Digest32) (even : i%2=0) : + (foldLevel ((i,d)::(i+1,e)::nodes) supplied).calls H = + pairBytes d e :: (foldLevel nodes supplied).calls H := by + rw [foldLevel.eq_def] + simp only [even,↓reduceIte,emit,HashProgram.calls,HashProgram.calls_map] + +theorem foldLevel_calls_even (H : Primitive) (i : Nat) (d s : Digest32) + (nodes : Level Digest32) (supplied : List Digest32) (even : i%2=0) + (unpaired : nodes.head?.map Prod.fst ≠ some (i+1)) : + (foldLevel ((i,d)::nodes) (s::supplied)).calls H = + pairBytes d s :: (foldLevel nodes supplied).calls H := by + rw [foldLevel.eq_def] + cases nodes with + | nil => simp [even,emit,HashProgram.calls,HashProgram.calls_map] + | cons x nodes => + rcases x with ⟨j,e⟩ + have hn : j ≠ i+1 := by simpa using unpaired + simp only [even,hn,↓reduceIte,emit,HashProgram.calls,HashProgram.calls_map] + +theorem foldLevel_calls_odd (H : Primitive) (i : Nat) (d s : Digest32) + (nodes : Level Digest32) (supplied : List Digest32) (odd : i%2≠0) : + (foldLevel ((i,d)::nodes) (s::supplied)).calls H = + pairBytes s d :: (foldLevel nodes supplied).calls H := by + rw [foldLevel.eq_def] + simp only [odd,↓reduceIte,emit,HashProgram.calls,HashProgram.calls_map] + +theorem foldLevel_coverage (H : Primitive) (nodes : Level Digest32) (supplied : List Digest32) + (parents known : Level Digest32) (rest : List Digest32) + (run : MerkleLevels.foldLevel (fun p => H (List.ofFn (ByteCodec.pairBytes p))) nodes supplied = some (parents,known,rest)) : + PairedCoverage known ((foldLevel nodes supplied).calls H) := by + have trace := foldLevel_spec _ _ _ run + clear run + induction trace with + | nil supplied => intro _ _ _ h; simp [lookup] at h + | paired i d e nodes supplied parents known rest even _ ih => + rw [foldLevel_calls_paired H i d e nodes supplied even] + have he : 2*(i/2) = i := by omega + simpa only [he] using PairedCoverage.prepend known _ (i/2) d e ih + | even i d s nodes supplied parents known rest even unpaired _ ih => + rw [foldLevel_calls_even H i d s nodes supplied even unpaired] + have he : 2*(i/2) = i := by omega + simpa only [he] using PairedCoverage.prepend known _ (i/2) d s ih + | odd i d s nodes supplied parents known rest odd _ ih => + rw [foldLevel_calls_odd H i d s nodes supplied odd] + have he : 2*(i/2) = i-1 := by omega + have ho : 2*(i/2)+1 = i := by omega + have h := PairedCoverage.prepend known _ (i/2) s d ih + rw [ho,he] at h + exact h + +def ascentInputs (H : Primitive) (index : Nat) (current : Digest32) : List Digest32 → List (List Byte) + | [] => [] + | other::rest => + let bytes := List.ofFn (ByteCodec.pairBytes (MerkleLevels.orient index current other)) + bytes :: ascentInputs H (index/2) (H bytes) rest + +theorem node_digest (H : Primitive) (index : Nat) (other : Digest32) + {below : List Bool} (p : Opening (List K) Digest32 below) : + (Opening.node (MerkleLevels.right index) other p).digest (hashing H) = + H (List.ofFn (ByteCodec.pairBytes (MerkleLevels.orient index (p.digest (hashing H)) other))) := by + simp only [Opening.digest,hashing,MerkleLevels.orient,MerkleLevels.right] + by_cases even : index%2=0 + · simp [even] + · have odd : index%2=1 := by omega + simp [odd] + +theorem node_inputs (H : Primitive) (index : Nat) (other : Digest32) + {below : List Bool} (p : Opening (List K) Digest32 below) : + (Opening.node (MerkleLevels.right index) other p).inputs (hashing H) = + insert (List.ofFn (ByteCodec.pairBytes (MerkleLevels.orient index (p.digest (hashing H)) other))) (p.inputs (hashing H)) := by + simp only [Opening.inputs,hashing,MerkleLevels.orient,MerkleLevels.right] + by_cases even : index%2=0 + · simp [even] + · have odd : index%2=1 := by omega + simp [odd] + +theorem wrap_inputs_coverage (H : Primitive) (index : Nat) (siblings : List Digest32) + {below : List Bool} (p : Opening (List K) Digest32 below) + (bytes : List Byte) (member : bytes ∈ (wrap index siblings p).inputs (hashing H)) : + bytes ∈ p.inputs (hashing H) ∨ bytes ∈ ascentInputs H index (p.digest (hashing H)) siblings := by + induction siblings generalizing index below with + | nil => exact Or.inl member + | cons other rest ih => + have h := ih (index/2) (.node (MerkleLevels.right index) other p) member + rw [node_inputs,node_digest] at h + rcases h with h | h + · rcases Finset.mem_insert.mp h with h | h + · exact Or.inr (List.mem_cons.mpr (Or.inl h)) + · exact Or.inl h + · exact Or.inr (List.mem_cons_of_mem _ h) + +theorem levels_path_coverage (H : Primitive) (n : Nat) (nodes : Level Digest32) + (supplied : List Digest32) (final : Level Digest32) (known : List (Level Digest32)) (rest : List Digest32) + (run : runLevels (fun p => H (List.ofFn (ByteCodec.pairBytes p))) n nodes supplied = some (final,known,rest)) + (sorted : Sorted nodes) (index : Nat) (digest : Digest32) + (start : lookup index nodes = some digest) (path : List Digest32) + (reconstructed : reconstruct index known = some path) : + ∀ bytes ∈ ascentInputs H index digest path, bytes ∈ (levels n nodes supplied).calls H := by + induction n generalizing nodes supplied final known rest index digest path with + | zero => + simp [runLevels] at run + rcases run with ⟨rfl,rfl,rfl⟩ + simp [reconstruct] at reconstructed + subst path + simp [ascentInputs] + | succ n ih => + simp [runLevels,Option.bind_eq_some_iff,-List.ofFn_succ] at run + obtain ⟨parents,current,remain,hfold,later,hrun,rfl⟩ := run + have facts := foldLevel_invariant _ sorted hfold + obtain ⟨other,hs,hparent⟩ := facts.edge start + have hs' : binaryLookup (MerkleTransport.sibling index) current = some other := + (binaryLookup_eq_lookup _ _ facts.known_sorted).trans hs + simp [reconstruct,hs',Option.bind_eq_some_iff] at reconstructed + obtain ⟨tail,htail,rfl⟩ := reconstructed + have htailCoverage := ih parents remain final later rest hrun facts.parents_sorted + (index/2) _ hparent tail htail + have hpair := (foldLevel_coverage H nodes supplied parents current remain hfold).edge + (facts.preserved start) hs + intro bytes member + rw [levels,HashProgram.calls_bind,foldLevel_eval,hfold] + simp only [HashProgram.calls_map,List.mem_append] + rcases List.mem_cons.mp member with rfl | member + · exact Or.inl hpair + · exact Or.inr (htailCoverage bytes member) + +theorem leafHashes_calls (H : Primitive) (rowWords leafWords : Nat) (rows : List (List K)) + (widths : ∀ row ∈ rows, row.length = rowWords) : + (leafHashes rowWords leafWords rows).calls H = + rows.map (fun row => ByteCodec.wordsBytes (leafImage 0 leafWords row)) := by + induction rows with + | nil => rfl + | cons row rows ih => + have hw := widths row (by simp) + have ht : ∀ r ∈ rows, r.length = rowWords := fun r hr => widths r (by simp [hr]) + simp only [leafHashes,hw,↓reduceIte,HashProgram.calls,HashProgram.calls_map,List.map_cons,ih ht] + +theorem plan_calls (H : Primitive) (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) + (conditions : OpenConditions proof numLeaves queries rowWords leafWords) : + (plan proof root numLeaves queries rowWords leafWords).calls H = + proof.leafData.map (fun row => ByteCodec.wordsBytes (leafImage 0 leafWords row)) ++ + (levels numLeaves.log2 (leafNodes H leafWords (leafTable queries proof.leafData)) + proof.siblingHashes).calls H := by + have hs : ¬(numLeaves=0 ∨ 2^numLeaves.log2≠numLeaves ∨ queries=[]) := by + simp [conditions.positive,conditions.power,conditions.queries_nonempty] + have hc : ¬((sortedUnique queries).length ≠ proof.leafData.length ∨ rowWords>leafWords) := by + simp [conditions.count,Nat.not_lt.mpr conditions.fits] + have hr : ¬∃ q ∈ queries, numLeaves ≤ q := by + rintro ⟨q,hq,hn⟩ + have := conditions.range q hq + omega + simp only [plan,ite_eq_right hs,ite_eq_right hc,HashProgram.calls_bind, + leafHashes_calls H rowWords leafWords proof.leafData conditions.widths,leafHashes_eval, + ite_eq_left conditions.widths,ite_eq_right hr,HashProgram.calls_map,zip_hashes,leafTable] + +theorem plan_opening_inputs (H : Primitive) (proof : PrunedMerklePaths) (root : Digest32) + (numLeaves : Nat) (queries : List Nat) (rowWords leafWords : Nat) (paths : List RawPath) + (accepted : proof.open H root numLeaves queries rowWords leafWords = some paths) + (p : RawPath) (member : p ∈ paths) (bytes : List Byte) + (input : bytes ∈ p.opening.inputs (hashing H)) : + bytes ∈ (plan proof root numLeaves queries rowWords leafWords).calls H := by + obtain ⟨conditions,final,known,index,distinct,hrun,hroot,hdistinct,hpaths⟩ := + (open_spec H proof root numLeaves queries rowWords leafWords paths).mp accepted + have hsorted := leafTable_sorted queries proof.leafData conditions.count + have hdSorted := distinctPaths_sorted leafWords known _ distinct hdistinct hsorted + obtain ⟨q,hq,hlookup⟩ := collect_mem _ queries paths hpaths member + rw [binaryLookup_eq_lookup _ _ hdSorted] at hlookup + obtain ⟨row,hrow,hindex,hdata,hpath⟩ := + distinctPaths_mem leafWords known _ distinct hdistinct q p (lookup_mem hlookup) + have hstart := leafNodes_lookup H leafWords _ q row (lookup_of_mem hsorted hrow) + have hcoverage := levels_path_coverage H numLeaves.log2 _ proof.siblingHashes final known [] hrun + (leafNodes_sorted H leafWords _ hsorted) q _ hstart p.path hpath + rw [plan_calls H proof root numLeaves queries rowWords leafWords conditions] + apply List.mem_append.mpr + rcases wrap_inputs_coverage H p.leafIndex p.path (.leaf p.leafData) bytes input with base | above + · left + simp only [Opening.inputs,hashing,Finset.mem_singleton] at base + rw [base,hdata] + exact List.mem_map.mpr ⟨row,(leafTable_mem hrow).2,rfl⟩ + · right + apply hcoverage bytes + simpa only [Opening.digest,hashing,hindex,hdata] using above + +/-- Every primitive invocation needed by any accepted reconstructed opening +is already present in the actual metered flat decoder trace. No independent +path hashing or assumed decoder-coverage bridge is used in this reduction. -/ +theorem verify_opening_primitive_coverage (C : PrimitiveOracle) (iv : Digest32) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (paths : List RawPath) + (accepted : (runReal C iv (verify proof root numLeaves queries rowWords leafWords)).view.result = some paths) + (p : RawPath) (member : p ∈ paths) (bytes : List Byte) + (input : bytes ∈ p.opening.inputs (hashing (PublicMerkleLog.hash C))) + (event : DuplexFraming.Node × Digest32) (present : event ∈ PublicMerkleLog.plan C bytes) : + (⟨.primitive .verification event.1,event.2⟩ : Observation) ∈ + (runReal C iv (verify proof root numLeaves queries rowWords leafWords)).view.observations := by + rw [verify_real_result] at accepted + have hb := plan_opening_inputs (PublicMerkleLog.hash C) proof root numLeaves queries rowWords leafWords + paths accepted p member bytes input + rw [verify_real_observations] + exact List.mem_flatMap.mpr ⟨bytes,hb,List.mem_map.mpr ⟨event,present,rfl⟩⟩ + +end Whir.PrunedMerkleProgram + +namespace Whir.PublicMerkleProgram +open FiatShamirGame DuplexModeGame + +theorem runReal_answers {R : Type} (C : PrimitiveOracle) (iv : Digest32) (p : Program R) : + ∀ o ∈ (runReal C iv p).view.observations, o.answer = realAnswer C iv o.query := by + induction p with + | done => simp [runReal] + | ask q next ih => + intro o member + simp only [runReal,prepend,List.mem_cons] at member + rcases member with rfl | member + · rfl + · exact ih (realAnswer C iv q) o member + +/-- An operational subtrace identifies the real result only after each +observed answer has been justified against the real query semantics. -/ +theorem Runs.real_view {R : Type} {p : Program R} {trace : List Observation} {result : R} + (run : Runs p trace result) (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ trace, o.answer = realAnswer C iv o.query) : + (runReal C iv p).view = ⟨trace,result⟩ := by + induction run with + | done r => rfl + | @ask q next trace result answer run ih => + have ha : answer = realAnswer C iv q := answers ⟨q,answer⟩ (by simp) + have ht : ∀ o ∈ trace, o.answer = realAnswer C iv o.query := + fun o ho => answers o (List.mem_cons_of_mem _ ho) + simp only [runReal,←ha,prepend,ih ht] + +theorem Runs.real_result_trace {R : Type} {p : Program R} {trace : List Observation} {result : R} + (run : Runs p trace result) (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ trace, o.answer = realAnswer C iv o.query) : + (runReal C iv p).view.result = result ∧ (runReal C iv p).view.observations = trace := by + have h := run.real_view C iv answers + exact ⟨congrArg View.result h,congrArg View.observations h⟩ + +end Whir.PublicMerkleProgram diff --git a/verification/whir/Whir/PublicCompressionProgram.lean b/verification/whir/Whir/PublicCompressionProgram.lean new file mode 100644 index 000000000..221b56188 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionProgram.lean @@ -0,0 +1,231 @@ +import Whir.PublicMerkleLog +import Whir.RawOracleCoupling + +/-! Real mode programs expanded into every shared compression call. Internal +construction nodes are counted, but remain absent from the public mode view. -/ +namespace Whir.PublicCompressionProgram +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +abbrev Computation (R : Type) (Q : Nat) := Sampling Node (fun _ => Digest32) R Q + +def mapResult {R S : Type} (f : R → S) {Q : Nat} : Computation R Q → Computation S Q + | .ret r => .ret (f r) + | .draw n next => .draw n (fun d => mapResult f (next d)) + +@[simp] theorem eval_mapResult {R S : Type} (C : PrimitiveOracle) (f : R → S) + {Q : Nat} (p : Computation R Q) : + Sampling.eval C (mapResult f p) = f (Sampling.eval C p) := by + induction p with + | ret => rfl + | draw n next ih => exact ih (C n) + +@[simp] theorem execute_mapResult {R S : Type} (C : PrimitiveOracle) (f : R → S) + {Q : Nat} (p : Computation R Q) : + Sampling.execute C (mapResult f p) = + (f (Sampling.execute C p).1,(Sampling.execute C p).2) := by + induction p with + | ret => rfl + | draw n next ih => simp only [mapResult,Sampling.execute,ih] + +def planCalls (cv : Digest32) : (xs : List DuplexEncoding.Instruction) → Computation Digest32 xs.length + | [] => .ret cv + | i :: rest => .draw ⟨cv,i.1,i.2,true⟩ (fun d => planCalls d rest) + + theorem planCalls_eval (C : PrimitiveOracle) (cv : Digest32) (xs : List DuplexEncoding.Instruction) : + Sampling.eval C (planCalls cv xs) = evalPlan (compressionOf C) cv xs := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => exact ih _ + +def queryCalls (iv : Digest32) : (q : Query) → Computation Digest32 q.cost + | .primitive _ n => .draw n (fun d => .ret d) + | .construction q _ => planCalls iv (DuplexEncoding.plan q) + + theorem queryCalls_eval (C : PrimitiveOracle) (iv : Digest32) (q : Query) : + Sampling.eval C (queryCalls iv q) = realAnswer C iv q := by + cases q with + | primitive => rfl + | construction q valid => exact (planCalls_eval C iv _).trans (plan_evaluate _ _ _) + +/-- The supplied Counts certificate charges each complete construction path. +There is no cached-path or successful-branch-only discount. -/ +def compile {R : Type} (iv : Digest32) : + (p : Program R) → (Q : Nat) → Counts Q p → Computation (Execution R) Q + | .done r, _, _ => .ret ⟨⟨[],r⟩,0,0,0⟩ + | .ask q next, Q, h => + Sampling.pad (by have := h.1; omega) + (Sampling.bind (queryCalls iv q) (fun d => + mapResult (prepend q d 0) (compile iv (next d) (Q-q.cost) (h.2 d)))) + + theorem compile_eval {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (h : Counts Q p) : + Sampling.eval C (compile iv p Q h) = runReal C iv p := by + induction p generalizing Q with + | done => rfl + | ask q next ih => + simp only [compile,Sampling.eval_pad,Sampling.eval_bind,eval_mapResult,queryCalls_eval,ih,runReal] + +def toLog (trace : List (Sigma (fun _ : Node => Digest32))) : PublicMerkleLog.PublicLog := + trace.map fun e => (e.1,e.2) + +def primitiveLog {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (h : Counts Q p) : PublicMerkleLog.PublicLog := + toLog (Sampling.execute C (compile iv p Q h)).2 + + theorem primitiveLog_length {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (h : Counts Q p) : + (primitiveLog C iv p Q h).length ≤ Q := by + simpa only [primitiveLog,toLog,List.length_map] using + (Sampling.execute_runs C (compile iv p Q h)).length_le + + theorem execute_authentic {R : Type} (C : PrimitiveOracle) {Q : Nat} (p : Computation R Q) : + PublicMerkleLog.AuthenticLog C (toLog (Sampling.execute C p).2) := by + induction p with + | ret => intro n d hm; simp [toLog,Sampling.execute] at hm + | draw n next ih => + intro m d hm + simp only [Sampling.execute,toLog,List.map_cons,List.mem_cons,Prod.mk.injEq] at hm + rcases hm with ⟨rfl,rfl⟩ | hm + · rfl + · exact ih (C n) m d hm + + theorem primitiveLog_authentic {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (h : Counts Q p) : + PublicMerkleLog.AuthenticLog C (primitiveLog C iv p Q h) := execute_authentic C _ + + theorem body_tags {ns : List Node} (h : Body ns) : ∀ n ∈ ns, 0 < tag n := by + induction h with + | seed hs => intro n hn; have he := List.mem_singleton.mp hn; subst n; rw [hs.1]; omega + | step hn hb ih => + intro n hm + rcases List.mem_cons.mp hm with rfl | hm + · rcases hn.1 with h | h | h | h | h <;> omega + · exact ih n hm + + theorem complete_tags {ns : List Node} (h : Complete ns) : ∀ n ∈ ns, 0 < tag n := by + obtain ⟨t,rest,rfl,ht,hb⟩ := h + intro n hn + rcases List.mem_cons.mp hn with rfl | hn + · rcases ht.1 with h | h | h <;> omega + · exact body_tags hb n hn + + theorem instruction_tag (iv : Digest32) (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (i : DuplexEncoding.Instruction) (hi : i ∈ DuplexEncoding.plan q) : + 0 < i.2.toNat / 2^56 := by + let C : Compression := fun _ _ _ _ => iv + have hp := coordinateTree_plan C iv q + rw [← hp] at hi + obtain ⟨n,hn,he⟩ := List.mem_map.mp hi + have hn' := List.mem_reverse.mp hn + have ht := complete_tags (coordinateTree_complete C iv q valid.1) n hn' + have htweak := congrArg Prod.snd he + dsimp only at htweak + simpa only [tag,htweak] using ht + + theorem planCalls_origin (C : PrimitiveOracle) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) (n : Node) (d : Digest32) + (hm : (n,d) ∈ toLog (Sampling.execute C (planCalls cv xs)).2) : + ∃ i ∈ xs, n.tweak = i.2 := by + induction xs generalizing cv with + | nil => simp [planCalls,Sampling.execute,toLog] at hm + | cons i rest ih => + simp only [planCalls,Sampling.execute,toLog,List.map_cons,List.mem_cons,Prod.mk.injEq] at hm + rcases hm with ⟨he,_⟩ | hm + · exact ⟨i,List.mem_cons_self,congrArg Node.tweak he⟩ + · obtain ⟨j,hj,ht⟩ := ih _ hm + exact ⟨j,List.mem_cons_of_mem _ hj,ht⟩ + + theorem construction_tags (C : PrimitiveOracle) (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (n : Node) (d : Digest32) + (hm : (n,d) ∈ toLog (Sampling.execute C (queryCalls iv (.construction q valid))).2) : + 0 < tag n := by + obtain ⟨i,hi,ht⟩ := planCalls_origin C iv (DuplexEncoding.plan q) n d hm + simpa only [tag,ht] using instruction_tag iv q valid i hi + +/-- Direct primitive observations only; construction internals remain hidden. -/ +def publicLog {R : Type} (view : View R) : PublicMerkleLog.PublicLog := + view.observations.filterMap fun o => match o.query with + | .primitive _ n => some (n,o.answer) + | .construction _ _ => none + + theorem ordinary_public {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (h : Counts Q p) (n : Node) (d : Digest32) + (ordinary : tag n = 0) (hm : (n,d) ∈ primitiveLog C iv p Q h) : + (n,d) ∈ publicLog (runReal C iv p).view := by + induction p generalizing Q with + | done => simp [primitiveLog,compile,Sampling.execute,toLog] at hm + | ask q next ih => + simp only [primitiveLog,compile,Sampling.execute_pad,Sampling.execute_bind, + execute_mapResult,toLog,List.map_append,List.mem_append,queryCalls_eval] at hm + rcases hm with first | later + · cases q with + | primitive purpose input => + simp only [queryCalls,Sampling.execute,List.map_cons,List.map_nil, + List.mem_cons,List.not_mem_nil,or_false,Prod.mk.injEq] at first + rcases first with ⟨rfl,rfl⟩ + exact List.mem_cons_self + | construction coordinate valid => + have ht := construction_tags C iv coordinate valid n d first + omega + · have ht := ih (realAnswer C iv q) (Q-q.cost) (h.2 _) later + cases q with + | primitive => exact List.mem_cons_of_mem _ ht + | construction => exact ht + + theorem planCalls_count (C : PrimitiveOracle) (cv : Digest32) (xs : List DuplexEncoding.Instruction) : + (Sampling.execute C (planCalls cv xs)).2.length = xs.length := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => simp only [planCalls,Sampling.execute,List.length_cons,ih] + + theorem queryCalls_count (C : PrimitiveOracle) (iv : Digest32) (q : Query) : + (Sampling.execute C (queryCalls iv q)).2.length = q.cost := by + cases q with + | primitive => rfl + | construction q valid => exact planCalls_count C iv _ + + theorem primitiveLog_exact_count {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (h : Counts Q p) : + (primitiveLog C iv p Q h).length = (runReal C iv p).primitiveCost := by + induction p generalizing Q with + | done => rfl + | ask q next ih => + simp only [primitiveLog,toLog,List.length_map,compile,Sampling.execute_pad, + Sampling.execute_bind,execute_mapResult,List.length_append,queryCalls_count,queryCalls_eval, + runReal,prepend] + simpa only [primitiveLog,toLog,List.length_map] using + congrArg (q.cost + ·) (ih _ _ (h.2 _)) + +/-- Conditional #552 mode smoke, separate from baseline interactive evidence. +The repeated ordinary query is a cache hit; the construction still expands +to its two complete internal compression nodes in the full-call trace. -/ +def smoke : IO Unit := do + let iv := DuplexCompression.parameterIV + let coordinate : Coordinate := ⟨⟨iv,iv,[]⟩,.output 0⟩ + have valid : DuplexEncoding.Admissible coordinate := by + constructor + · simp [coordinate] + · decide + let ordinary := PublicMerkleLog.node iv 0 [] true + let p : Program (Digest32 × Digest32 × Digest32) := + .ask (.primitive .direct ordinary) fun first => + .ask (.construction coordinate valid) fun middle => + .ask (.primitive .direct ordinary) fun last => .done (first,middle,last) + have counts : Counts 4 p := by + simp [p,Counts,Query.cost,pathCost,DuplexEncoding.plan,coordinate] + let compiled := compile iv p 4 counts + let result := Sampling.execute blake2sOracle compiled + let reference := runReal blake2sOracle iv p + unless result.1.view.result == reference.view.result && result.1.primitiveCost == 4 do + throw (IO.userError "real-mode execution refinement failed") + let calls := toLog result.2 + unless calls.map (fun e => tag e.1) == [0,1,6,0] do + throw (IO.userError "mode compiler omitted or reordered compression nodes") + unless (publicLog result.1.view).length == 2 do + throw (IO.userError "hidden construction nodes leaked into public observations") + let memoized := Sampling.execute blake2sOracle (RawOracleCoupling.memo compiled (fun _ => none)) + unless memoized.2.length == 3 && memoized.1.1.view.result == reference.view.result do + throw (IO.userError "shared compression cache failed to reuse repeated input") + IO.println "Conditional mode: 4 full compression calls, tags [0,1,6,0], 2 public direct records, 3 fresh cached draws; exact result OK" + +end Whir.PublicCompressionProgram diff --git a/verification/whir/Whir/PublicMerkleProbability.lean b/verification/whir/Whir/PublicMerkleProbability.lean new file mode 100644 index 000000000..9b81ca1f0 --- /dev/null +++ b/verification/whir/Whir/PublicMerkleProbability.lean @@ -0,0 +1,526 @@ +import Whir.PublicMerkleBinding +import Whir.PublicCompressionProgram + +/-! Ordinary Merkle losses in the actual shared random compression game. +Every target is determined before the selected fresh compression answer. +Root announcements have their own cap: zero-cost bookkeeping is not charged +to the compression budget. No whole-hash random-oracle assumption is used. -/ +namespace Whir.PublicMerkleProbability +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicMerkleLog PublicMerkleBinding PublicCompressionProgram +open MerkleTransport MerkleTransport.Commitments TypedOracleCompiler +open scoped BigOperators + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ +private def nodeFields (n : Node) : Digest32 × Block64 × UInt64 × Bool := + (n.cv,n.block,n.tweak,n.last) +private theorem nodeFields_injective : Function.Injective nodeFields := by + intro a b h + cases a; cases b + simp_all [nodeFields] +private instance : Finite Node := Finite.of_injective nodeFields nodeFields_injective +private noncomputable instance : Fintype Node := Fintype.ofFinite _ +private noncomputable instance oracleFintype : Fintype PrimitiveOracle := inferInstance + +/-- The exact finite compression-oracle experiment used in the averages. -/ +@[instance_reducible] +noncomputable def compressionOracleFintype : Fintype PrimitiveOracle := oracleFintype + +abbrev RootPolicy := PublicLog → Finset Digest32 + +/-- This hash field is never used to decode pair children. The pair encoder is +exactly MerkleTransport.hashing's actual byte codec. -/ +def pairCodec := hashing (fun _ => DuplexCompression.parameterIV) + +noncomputable def pairChildren (log : PublicLog) : Finset Digest32 := + (recordDomain (records log)).biUnion (MerkleBinding.children pairCodec) + +def cvTargets (log : PublicLog) : Finset Digest32 := (log.map fun e => e.1.cv).toFinset +def outputTargets (log : PublicLog) : Finset Digest32 := (log.map Prod.snd).toFinset + +noncomputable def targets (roots : RootPolicy) (log : PublicLog) : Finset Digest32 := + roots log ∪ pairChildren log ∪ cvTargets log + +noncomputable def badTargets (roots : RootPolicy) (log : PublicLog) : Finset Digest32 := + outputTargets log ∪ targets roots log + + theorem records_length (log : PublicLog) : (records log).length ≤ log.length := + List.length_filterMap_le _ _ + + theorem recordDomain_card (rs : Records) : (recordDomain rs).card ≤ rs.length := by + exact (List.toFinset_card_le _).trans_eq (List.length_map ..) + +private theorem children_card {A B D : Type*} (H : MerkleBinding.Hashing A D B) (b : B) : + (MerkleBinding.children H b).card ≤ 2 := by + classical + unfold MerkleBinding.children + split + · exact Finset.card_le_two + · simp + + theorem pairChildren_card (log : PublicLog) : (pairChildren log).card ≤ 2*log.length := by + classical + have hc (bytes : List Byte) : (MerkleBinding.children pairCodec bytes).card ≤ 2 := + children_card pairCodec bytes + calc + _ ≤ ∑ bytes ∈ recordDomain (records log), (MerkleBinding.children pairCodec bytes).card := + Finset.card_biUnion_le + _ ≤ ∑ _bytes ∈ recordDomain (records log), 2 := Finset.sum_le_sum fun _ _ => hc _ + _ = 2 * (recordDomain (records log)).card := by simp [Nat.mul_comm] + _ ≤ 2 * log.length := Nat.mul_le_mul_left _ ((recordDomain_card _).trans (records_length log)) + + theorem cvTargets_card (log : PublicLog) : (cvTargets log).card ≤ log.length := by + exact (List.toFinset_card_le _).trans_eq (List.length_map ..) + + theorem outputTargets_card (log : PublicLog) : (outputTargets log).card ≤ log.length := by + exact (List.toFinset_card_le _).trans_eq (List.length_map ..) + + theorem targets_card (roots : RootPolicy) (log : PublicLog) (R : Nat) + (cap : (roots log).card ≤ R) : (targets roots log).card ≤ R+3*log.length := by + have h1 := Finset.card_union_le (roots log) (pairChildren log) + have h2 := Finset.card_union_le (roots log ∪ pairChildren log) (cvTargets log) + have hp := pairChildren_card log + have hc := cvTargets_card log + change (roots log ∪ pairChildren log ∪ cvTargets log).card ≤ _ + omega + + theorem badTargets_card (roots : RootPolicy) (log : PublicLog) (R Q : Nat) + (cap : (roots log).card ≤ R) (budget : log.length ≤ Q) : + (badTargets roots log).card ≤ R+3*Q+log.length := by + have hu := Finset.card_union_le (outputTargets log) (targets roots log) + have ho := outputTargets_card log + have ht := targets_card roots log R cap + change (outputTargets log ∪ targets roots log).card ≤ _ + omega + +/-- Causal monitor: cache hits cannot trigger a fresh-answer event. Histories +are newest first, but contain every call, including repeated/internal calls. -/ +noncomputable def alarm {T : Type} (roots : RootPolicy) (C : PrimitiveOracle) {Q : Nat} : + Computation T Q → PublicLog → Bool + | .ret _, _ => false + | .draw n next, log => + (decide (PublicMerkleLog.lookup log n = none ∧ C n ∈ badTargets roots log)) || + alarm roots C (next (C n)) ((n,C n)::log) + +noncomputable def risk {T : Type} (roots : RootPolicy) {Q : Nat} : + Computation T Q → PublicLog → ℚ + | .ret _, _ => 0 + | .draw n next, log => + match PublicMerkleLog.lookup log n with + | some d => risk roots (next d) ((n,d)::log) + | none => average (fun d => if d ∈ badTargets roots log then 1 + else risk roots (next d) ((n,d)::log)) + +/-- Exact birthday term plus the chosen conservative target term. -/ +def bound (Q R : Nat) : ℚ := + ((Q : ℚ)*(Q-1)/2 + Q*(R+3*Q)) / 2^256 + +private def remainingBound (Q R remaining previous : Nat) : ℚ := + ((remaining : ℚ)*(R+3*Q+previous) + remaining*(remaining-1)/2) / 2^256 + +private theorem remaining_nonneg (Q R n m : Nat) : 0 ≤ remainingBound Q R n m := by + cases n with + | zero => simp [remainingBound] + | succ n => + unfold remainingBound + simp only [Nat.cast_add,Nat.cast_one,add_sub_cancel_right] + positivity + +private theorem remaining_step (Q R n m : Nat) : + remainingBound Q R (n+1) m = + (R+3*Q+m : ℚ)/2^256 + remainingBound Q R n (m+1) := by + unfold remainingBound + push_cast + ring + + theorem uniform_target_probability (set : Finset Digest32) : + average (fun d => if d ∈ set then (1 : ℚ) else 0) = set.card / (2^256 : ℚ) := by + classical + simp [average]; norm_num + + theorem risk_bound {T : Type} (roots : RootPolicy) (Q R : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) + {n : Nat} (p : Computation T n) (log : PublicLog) (budget : log.length+n ≤ Q) : + risk roots p log ≤ remainingBound Q R n log.length := by + classical + induction p generalizing log with + | ret value => exact remaining_nonneg _ _ _ _ + | @draw n input next ih => + have hbudget : log.length ≤ Q := by omega + have hcap := rootCap log hbudget + have hcard := badTargets_card roots log R Q hcap hbudget + have hstep := remaining_step Q R n log.length + have hnon : (0 : ℚ) ≤ (R+3*Q+log.length : ℚ)/2^256 := by positivity + cases hit : PublicMerkleLog.lookup log input with + | some d => + simp only [risk,hit] + have htail := ih d ((input,d)::log) (by simp only [List.length_cons]; omega) + simp only [List.length_cons] at htail + rw [hstep] + linarith + | none => + simp only [risk,hit] + calc + _ ≤ average (fun d : Digest32 => + (if d ∈ badTargets roots log then (1:ℚ) else 0) + + remainingBound Q R n (log.length+1)) := by + apply average_mono + intro d + have hn := remaining_nonneg Q R n (log.length+1) + have ht := ih d ((input,d)::log) (by simp only [List.length_cons]; omega) + simp only [List.length_cons] at ht + by_cases bad : d ∈ badTargets roots log + · simp only [bad,↓reduceIte] + linarith + · simpa only [bad,↓reduceIte,zero_add] using ht + _ = (badTargets roots log).card / (2^256 : ℚ) + + remainingBound Q R n (log.length+1) := by + rw [average_add,uniform_target_probability,average_const] + _ ≤ (R+3*Q+log.length : ℚ)/2^256 + remainingBound Q R n (log.length+1) := by + apply add_le_add_left + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast hcard + _ = _ := hstep.symm + + theorem lookup_cons (log : PublicLog) (n : Node) (d : Digest32) : + PublicMerkleLog.lookup ((n,d)::log) = + TypedFiatShamirGame.put (PublicMerkleLog.lookup log) n d := by + funext m + by_cases he : m = n + · subst m; simp [PublicMerkleLog.lookup] + · simp [PublicMerkleLog.lookup,TypedFiatShamirGame.put_other,he] + + theorem lookup_cons_hit (log : PublicLog) (n : Node) (d : Digest32) + (hit : PublicMerkleLog.lookup log n = some d) : + PublicMerkleLog.lookup ((n,d)::log) = PublicMerkleLog.lookup log := by + funext m + by_cases he : m = n + · subst m; simp [PublicMerkleLog.lookup,hit] + · simp [PublicMerkleLog.lookup,he] + +/-- Exact adaptive finite-table/lazy-sampling identity. The fresh coordinate +split is the existing RawOracleCoupling proof; no answer independence axiom +or whole-hash table appears here. -/ + theorem table_alarm_eq_risk {T : Type} (roots : RootPolicy) {Q : Nat} + (p : Computation T Q) (log : PublicLog) : + average (fun C : PrimitiveOracle => + if alarm roots (RawOracleCoupling.overlay (PublicMerkleLog.lookup log) C) p log then 1 else 0) = + risk roots p log := by + classical + induction p generalizing log with + | ret value => simp [alarm,risk,average_const] + | draw n next ih => + cases hit : PublicMerkleLog.lookup log n with + | some d => + have cache := lookup_cons_hit log n d hit + simp only [risk,hit] + rw [← ih d ((n,d)::log),cache] + apply congrArg average + funext C + simp [alarm,RawOracleCoupling.overlay,hit] + | none => + rw [RawOracleCoupling.overlay_average (PublicMerkleLog.lookup log) n hit + (fun oracle => if alarm roots oracle (.draw n next) log then (1:ℚ) else 0)] + simp only [risk,hit] + apply congrArg average + funext d + have cache := lookup_cons log n d + by_cases bad : d ∈ badTargets roots log + · simp [alarm,RawOracleCoupling.overlay,hit,bad,average_const] + · rw [← ih d ((n,d)::log),cache] + simp only [bad,↓reduceIte] + apply congrArg average + funext C + simp [alarm,RawOracleCoupling.overlay,hit,bad] + + theorem random_compression_bound {T : Type} (roots : RootPolicy) (Q R : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) (p : Computation T Q) : + average (fun C : PrimitiveOracle => if alarm roots C p [] then 1 else 0) ≤ bound Q R := by + have he := table_alarm_eq_risk roots p [] + have hb := risk_bound roots Q R rootCap p [] (by simp) + calc + _ = risk roots p [] := he + _ ≤ remainingBound Q R Q 0 := hb + _ = bound Q R := by simp only [remainingBound,bound,Nat.cast_zero,add_zero]; ring + +/-- Actual mode specialization includes every internal construction node. +The independent R resource cap is not inferred from the mode C-call budget. -/ + theorem real_mode_bound {T : Type} (roots : RootPolicy) (Q R : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) + (iv : Digest32) (p : Program T) (counts : Counts Q p) : + average (fun C : PrimitiveOracle => + if alarm roots C (compile iv p Q counts) [] then 1 else 0) ≤ bound Q R := + random_compression_bound roots Q R rootCap (compile iv p Q counts) + +noncomputable def traceAlarm (roots : RootPolicy) : PublicLog → PublicLog → Bool + | _, [] => false + | history, (n,d)::rest => + decide (PublicMerkleLog.lookup history n = none ∧ d ∈ badTargets roots history) || + traceAlarm roots ((n,d)::history) rest + + theorem alarm_trace {T : Type} (roots : RootPolicy) (C : PrimitiveOracle) + {Q : Nat} (p : Computation T Q) (history : PublicLog) : + alarm roots C p history = traceAlarm roots history (toLog (Sampling.execute C p).2) := by + induction p generalizing history with + | ret => rfl + | draw n next ih => simp only [alarm,Sampling.execute,toLog,List.map_cons,traceAlarm,ih] + + theorem traceAlarm_append (roots : RootPolicy) (history before after : PublicLog) : + traceAlarm roots history (before++after) = + (traceAlarm roots history before || traceAlarm roots (before.reverse++history) after) := by + induction before generalizing history with + | nil => simp only [List.nil_append,List.reverse_nil,traceAlarm,Bool.false_or] + | cons e rest ih => + rcases e with ⟨n,d⟩ + simp only [List.cons_append,traceAlarm,ih,List.reverse_cons,List.append_assoc, + List.nil_append,Bool.or_assoc] + + theorem authentic_cons (C : PrimitiveOracle) (log : PublicLog) (auth : AuthenticLog C log) + (n : Node) : AuthenticLog C ((n,C n)::log) := by + intro m d hm + rcases List.mem_cons.mp hm with he | hm + · cases he; rfl + · exact auth m d hm + + theorem collision_mono {small large : PublicLog} + (sub : ∀ e ∈ small, e ∈ large) (h : OutputCollision small) : OutputCollision large := by + obtain ⟨a,b,d,ha,hb,hne⟩ := h + exact ⟨a,b,d,sub _ ha,sub _ hb,hne⟩ + + theorem noCollision_cons (C : PrimitiveOracle) (roots : RootPolicy) (log : PublicLog) + (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) (n : Node) + (safe : ¬ (PublicMerkleLog.lookup log n = none ∧ C n ∈ badTargets roots log)) : + ¬ OutputCollision ((n,C n)::log) := by + have oldOutput : ∀ m, (m,C n) ∈ log → m = n := by + intro m hm + cases hit : PublicMerkleLog.lookup log n with + | none => + apply False.elim + apply safe + exact ⟨hit,Finset.mem_union_left _ (List.mem_toFinset.mpr + (List.mem_map.mpr ⟨(m,C n),hm,rfl⟩))⟩ + | some d => + have hn := PublicMerkleLog.lookup_mem hit + have hd := auth n d hn + rw [← hd] at hn + by_contra ne + exact clean ⟨m,n,C n,hm,hn,ne⟩ + rintro ⟨a,b,d,ha,hb,hne⟩ + rcases List.mem_cons.mp ha with ha | ha <;> rcases List.mem_cons.mp hb with hb | hb + · cases ha; cases hb; exact hne rfl + · cases ha; exact hne (oldOutput b hb).symm + · cases hb; exact hne (oldOutput a ha) + · exact clean ⟨a,b,d,ha,hb,hne⟩ + + theorem targets_mono (C : PrimitiveOracle) (roots : RootPolicy) (old new : PublicLog) + (oldAuth : AuthenticLog C old) (newAuth : AuthenticLog C new) + (sub : ∀ e ∈ old, e ∈ new) (clean : ¬ OutputCollision new) + (rootSub : roots old ⊆ roots new) : targets roots old ⊆ targets roots new := by + intro d hd + rcases Finset.mem_union.mp hd with hp | hc + · rcases Finset.mem_union.mp hp with hr | hp + · exact Finset.mem_union_left _ (Finset.mem_union_left _ (rootSub hr)) + · apply Finset.mem_union_left + apply Finset.mem_union_right + obtain ⟨bytes,hb,hd⟩ := Finset.mem_biUnion.mp hp + apply Finset.mem_biUnion.mpr + refine ⟨bytes,?_,hd⟩ + obtain ⟨⟨x,a⟩,hm,he⟩ := List.mem_map.mp (List.mem_toFinset.mp hb) + dsimp only at he; subst x + exact List.mem_toFinset.mpr (List.mem_map.mpr + ⟨(bytes,a),records_persist C old new oldAuth newAuth sub clean _ hm,rfl⟩) + · apply Finset.mem_union_right + obtain ⟨⟨n,a⟩,hm,he⟩ := List.mem_map.mp (List.mem_toFinset.mp hc) + exact List.mem_toFinset.mpr (List.mem_map.mpr ⟨(n,a),sub _ hm,he⟩) + + theorem traceAlarm_clean (C : PrimitiveOracle) (roots : RootPolicy) + (history trace : PublicLog) (oldAuth : AuthenticLog C history) + (auth : AuthenticLog C trace) (oldClean : ¬ OutputCollision history) + (quiet : traceAlarm roots history trace = false) : + ¬ OutputCollision (trace.reverse++history) := by + induction trace generalizing history with + | nil => exact oldClean + | cons e rest ih => + rcases e with ⟨n,d⟩ + have hd := auth n d List.mem_cons_self + subst d + simp only [traceAlarm,Bool.or_eq_false_iff,decide_eq_false_iff_not] at quiet + have clean := noCollision_cons C roots history oldAuth oldClean n quiet.1 + have ht := ih ((n,C n)::history) (authentic_cons C history oldAuth n) + (fun m d hm => auth m d (List.mem_cons_of_mem _ hm)) clean quiet.2 + simpa only [List.reverse_cons,List.append_assoc,List.singleton_append] using ht + +/-- Roots persist across public-call boundaries. The cap R is independent: +announcing a root itself consumes no compression query. -/ +def RootsGrow (roots : RootPolicy) : Prop := + ∀ history entry, roots history ⊆ roots (entry::history) + + theorem traceAlarm_avoids (C : PrimitiveOracle) (roots : RootPolicy) (grow : RootsGrow roots) + (history trace : PublicLog) (oldAuth : AuthenticLog C history) + (auth : AuthenticLog C trace) (oldClean : ¬ OutputCollision history) + (quiet : traceAlarm roots history trace = false) + (n : Node) (absent : ∀ d, (n,d) ∉ history) + (present : (n,C n) ∈ trace.reverse++history) (target : C n ∈ targets roots history) : False := by + induction trace generalizing history with + | nil => exact absent _ present + | cons e rest ih => + rcases e with ⟨m,d⟩ + have hd := auth m d List.mem_cons_self + subst d + simp only [traceAlarm,Bool.or_eq_false_iff,decide_eq_false_iff_not] at quiet + by_cases eq : n = m + · subst m + have miss : PublicMerkleLog.lookup history n = none := by + cases hit : PublicMerkleLog.lookup history n with + | none => rfl + | some a => exact False.elim (absent a (PublicMerkleLog.lookup_mem hit)) + exact quiet.1 ⟨miss,Finset.mem_union_right _ target⟩ + · have newAuth := authentic_cons C history oldAuth m + have clean := noCollision_cons C roots history oldAuth oldClean m quiet.1 + apply ih ((m,C m)::history) newAuth (fun a d ha => auth a d (List.mem_cons_of_mem _ ha)) + clean quiet.2 + · intro a ha + rcases List.mem_cons.mp ha with he | ha + · exact eq (congrArg Prod.fst he) + · exact absent a ha + · simpa only [List.reverse_cons,List.append_assoc,List.singleton_append] using present + · exact targets_mono C roots history ((m,C m)::history) oldAuth newAuth + (fun e he => List.mem_cons_of_mem _ he) clean (grow _ _) target + +private theorem children_pair_mem {A B D : Type*} (H : MerkleBinding.Hashing A D B) + (l r d : D) (hd : d = l ∨ d = r) : d ∈ MerkleBinding.children H (H.pair (l,r)) := by + classical + have hex : ∃ pair, H.pair pair = H.pair (l,r) := ⟨(l,r),rfl⟩ + have he := H.pair_injective hex.choose_spec + simpa [MerkleBinding.children,dite_eq_left hex,he] using hd + + theorem snapshot_target_mem (C : PrimitiveOracle) (roots : RootPolicy) (old history : PublicLog) + (oldAuth : AuthenticLog C old) (auth : AuthenticLog C history) + (sub : ∀ e ∈ old, e ∈ history) (clean : ¬ OutputCollision history) + (root selected d : Digest32) (registered : root ∈ roots history) + (merkle : MerkleBinding.Target (hashing (hash C)) (recordDomain (records old)) root selected) + (snapshot : SnapshotTarget old selected d) : d ∈ targets roots history := by + rcases snapshot with rfl | ⟨n,a,hn,rfl⟩ + · rcases merkle with rfl | ⟨l,r,hpair,hd⟩ + · exact Finset.mem_union_left _ (Finset.mem_union_left _ registered) + · apply Finset.mem_union_left + apply Finset.mem_union_right + apply Finset.mem_biUnion.mpr + refine ⟨List.ofFn (ByteCodec.pairBytes (l,r)),?_,children_pair_mem pairCodec l r _ hd⟩ + obtain ⟨a,ha⟩ := recordLookup_exists (records old) _ hpair + have hp := records_persist C old history oldAuth auth sub clean _ + (recordLookup_mem _ _ _ ha) + exact List.mem_toFinset.mpr (List.mem_map.mpr ⟨(_,a),hp,rfl⟩) + · exact Finset.mem_union_right _ (List.mem_toFinset.mpr + (List.mem_map.mpr ⟨(n,a),sub _ hn,rfl⟩)) + +/-- Concrete terminal event, not a free bad-event cover. A freeze is an actual +prefix of the complete compression trace. Hidden earlier calls may exist, +but any ordinary tag0 call at the freeze is in its public log. Verification +has actually evaluated every ordinary plan in the accepted opening inputs. -/ +def FrozenOpeningBad (C : PrimitiveOracle) (roots : RootPolicy) (trace : PublicLog) : Prop := + ∃ before after oldLog root output, + trace = before++after ∧ + (∀ e ∈ oldLog, e ∈ before) ∧ + (∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ oldLog) ∧ + root ∈ roots before.reverse ∧ + (∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^56) ∧ + (∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), + ∀ e ∈ PublicMerkleLog.plan C bytes, e ∈ trace) ∧ + OpenPrimitiveBad C oldLog root output + + theorem opening_alarm (C : PrimitiveOracle) (roots : RootPolicy) (grow : RootsGrow roots) + (trace : PublicLog) (auth : AuthenticLog C trace) + (bad : FrozenOpeningBad C roots trace) : traceAlarm roots [] trace = true := by + classical + by_contra hn + have quiet : traceAlarm roots [] trace = false := Bool.eq_false_iff.mpr hn + obtain ⟨before,after,oldLog,root,output,rfl,sub,ordinary,registered,bounds,plans,bad⟩ := bad + rw [traceAlarm_append] at quiet + simp only [List.append_nil,Bool.or_eq_false_iff] at quiet + have beforeAuth : AuthenticLog C before := fun n d hm => auth n d (List.mem_append_left _ hm) + have afterAuth : AuthenticLog C after := fun n d hm => auth n d (List.mem_append_right _ hm) + have oldAuth : AuthenticLog C oldLog := fun n d hm => beforeAuth n d (sub _ hm) + have historyAuth : AuthenticLog C before.reverse := fun n d hm => + beforeAuth n d (List.mem_reverse.mp hm) + have emptyAuth : AuthenticLog C [] := by intro n d hm; cases hm + have emptyClean : ¬ OutputCollision [] := by rintro ⟨a,b,d,ha,_⟩; cases ha + have clean : ¬ OutputCollision before.reverse := by + simpa only [List.append_nil] using traceAlarm_clean C roots [] before emptyAuth beforeAuth emptyClean quiet.1 + have oldSub : ∀ e ∈ oldLog, e ∈ before.reverse := fun e he => List.mem_reverse.mpr (sub e he) + rcases bad with collision | ⟨p,hp,bytes,hbytes,merkle,n,hplan,absent,target⟩ + · exact clean (collision_mono oldSub collision) + · have tag0 := PublicMerkleLog.plan_tag_zero C bytes (bounds p hp bytes hbytes) n (C n) hplan + have absentBefore : ∀ d, (n,d) ∉ before.reverse := by + intro d hd + exact absent d (ordinary n d (List.mem_reverse.mp hd) tag0) + have hmem := plans p hp bytes hbytes _ hplan + have present : (n,C n) ∈ after.reverse++before.reverse := by + rcases List.mem_append.mp hmem with hb | ha + · exact List.mem_append_right _ (List.mem_reverse.mpr hb) + · exact List.mem_append_left _ (List.mem_reverse.mpr ha) + have targetMem := snapshot_target_mem C roots oldLog before.reverse oldAuth historyAuth + oldSub clean root (hash C bytes) (C n) registered merkle target + exact traceAlarm_avoids C roots grow before.reverse after historyAuth afterAuth clean quiet.2 + n absentBefore present targetMem + +noncomputable def openingProbability {T : Type} (roots : RootPolicy) {Q : Nat} + (p : Computation T Q) : ℚ := by + classical + exact average (fun C : PrimitiveOracle => + if FrozenOpeningBad C roots (toLog (Sampling.execute C p).2) then 1 else 0) + +/-- Genuine adaptive random-compression bound for the public Merkle opening +event, with all collision/fresh-target cases discharged by the causal trace +monitor. Exact constants: Q(Q-1)/2 + Q(R+3Q), over 2^256. -/ + theorem opening_probability_bound {T : Type} (roots : RootPolicy) (Q R : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) + (grow : RootsGrow roots) (p : Computation T Q) : openingProbability roots p ≤ bound Q R := by + classical + apply le_trans _ (random_compression_bound roots Q R rootCap p) + apply average_mono + intro C + by_cases bad : FrozenOpeningBad C roots (toLog (Sampling.execute C p).2) + · have ha := opening_alarm C roots grow _ (execute_authentic C p) bad + rw [← alarm_trace] at ha + simp only [bad,ha,↓reduceIte,le_refl] + · simp only [bad,↓reduceIte] + split <;> norm_num + + theorem real_mode_opening_bound {T : Type} (roots : RootPolicy) (Q R : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) (grow : RootsGrow roots) + (iv : Digest32) (p : Program T) (counts : Counts Q p) : + openingProbability roots (compile iv p Q counts) ≤ bound Q R := + opening_probability_bound roots Q R rootCap grow (compile iv p Q counts) + +/-- The monitor is itself a bounded causal sampling program: it observes +only the selected compression answers. The outer existing memo interpreter +suppresses repeated-input draws, just as in the finite-table experiment. -/ +noncomputable def audit {T : Type} (roots : RootPolicy) {Q : Nat} : + Computation T Q → PublicLog → Computation Bool Q + | .ret _, _ => .ret false + | .draw n next, history => + .draw n (fun d => mapResult + (fun later => decide (PublicMerkleLog.lookup history n = none ∧ d ∈ badTargets roots history) || later) + (audit roots (next d) ((n,d)::history))) + + theorem audit_eval {T : Type} (roots : RootPolicy) (C : PrimitiveOracle) + {Q : Nat} (p : Computation T Q) (history : PublicLog) : + Sampling.eval C (audit roots p history) = alarm roots C p history := by + induction p generalizing history with + | ret => rfl + | draw n next ih => simp only [audit,Sampling.eval,eval_mapResult,ih,alarm] + + theorem random_compression_lazy_bound {T : Type} (roots : RootPolicy) (Q R : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) (p : Computation T Q) : + Sampling.expectation (fun result => if result.1 then 1 else 0) + (RawOracleCoupling.memo (audit roots p []) (fun _ => none)) ≤ bound Q R := by + rw [← RawOracleCoupling.empty_table_eq_memo (audit roots p []) (fun b => if b then (1:ℚ) else 0)] + simpa only [audit_eval] using random_compression_bound roots Q R rootCap p + +theorem four_calls_two_roots : + bound 4 2 = (62 : ℚ) / 2^256 := by norm_num [bound] + +end Whir.PublicMerkleProbability diff --git a/verification/whir/Whir/WHIRCallerClaims.lean b/verification/whir/Whir/WHIRCallerClaims.lean new file mode 100644 index 000000000..4631aaf1e --- /dev/null +++ b/verification/whir/Whir/WHIRCallerClaims.lean @@ -0,0 +1,184 @@ +import Whir.WHIRCallerOutputs +import Whir.RingPCSGame + +/-! Claim extraction at the actual Flock-to-stack boundary. `decodeFlock` alone +is not a production `ClaimRequest` resolver: CPU additionally has +multiplicity/register rings and both callers have point claims. +`WHIRCallerSource` supplies their concrete bus/GKR, constraints/bit-column, +settled-table, placement and exit-claim interpreter and the complete request +decoder. Flock's algebraic acceptance checks are not claimed here: this extracts +the claims an accepted Flock trace returns. No serialized claim frame, +re-observation, or transcript restart is introduced here. + +The extraction was exercised against two genuine Rust `reduction::prove` / +`reduction::verify` fixtures, including matrix checks. Those fixtures use the +baseline Rust transcript; their read/sample traces were framed and their sampled +scalars supplied as prior-output blocks. This tests source claim assembly, not a +Rust implementation of conditional #552's compression mode. -/ +namespace Whir.WHIRCallerClaims +open Concrete FiatShamirGame DuplexRefinement DuplexEncoding WHIRCallerOutputs + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +/-- Public placement and dimensions, from `reduction::verify` and `Window::ring`. +Neither points nor slice values are public configuration. -/ +structure FlockLayout where + offset : Nat + kLog : Nat + instanceLog : Nat + deriving DecidableEq, Repr + +def FlockLayout.logN (l : FlockLayout) : Nat := l.kLog + l.instanceLog + +/-- Only physical outputs at strict entry prefixes are accessible. -/ +def priorAnswers (entry : FramedHistory) (answers : Coordinate → Digest32) + (q : Coordinate) : Digest32 := + if q ∈ callerOutputs entry then answers q else zeroDigest + +theorem priorAnswers_congr (entry : FramedHistory) (a b : Coordinate → Digest32) + (agree : ∀ q ∈ callerOutputs entry, a q = b q) : + priorAnswers entry a = priorAnswers entry b := by + funext q + simp only [priorAnswers] + split + next h => exact agree q h + next => rfl + +theorem priorAnswers_future (entry : FramedHistory) (answers : Coordinate → Digest32) + (q : Coordinate) (future : entry.frames.length ≤ q.history.frames.length) : + priorAnswers entry answers q = zeroDigest := by + unfold priorAnswers + split + next h => have := (callerOutputs_strict_prefix entry q h).2.2.1; omega + next => rfl + +/-- An actual absorb frame and the caller scalars consumed immediately before it. +The lengths are checked; truncated scalar encodings are not padded. -/ +structure ScalarFrame where + before : List E + sent : List E + deriving DecidableEq + +def scalarFrame (entry : FramedHistory) (answers : Coordinate → Digest32) + (index : Nat) : Option ScalarFrame := do + let .absorb consumed bytes ← entry.frames[index]? | none + if consumed % 24 ≠ 0 then none else do + let before ← WHIRHistory.parseExact (consumed / 24) + (recoveredBytes (priorAnswers entry answers) + {entry with frames := entry.frames.take index} 0 consumed) + let sent ← WHIRHistory.parseExact (bytes.length / 24) bytes + pure ⟨before,sent⟩ + +/-- Flock's real public read/sample schedule. The first vector sample and lambda +share an output run; each round transmits two of three coefficients. The last +read is 64 slices followed by one matrix value per circuit. -/ +def flockShape (layouts : List FlockLayout) : List (Nat × Nat) := + let m := (layouts.map FlockLayout.logN).foldl max 0 + let rounds := (layouts.map (fun l => l.kLog - 6)).foldl max 0 + [(m - 13 + 1,64)] ++ List.replicate (m - 6) (1,2) ++ + [(1,3 * layouts.length)] ++ List.replicate rounds (1,2) ++ + [(1,65 * layouts.length)] + +/-- Reject malformed/non-Flock suffixes, including nonce frames and mismatched +consumption cursors. Earlier caller frames are retained in every output key. -/ +def flockFrames (layouts : List FlockLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) : Option (List ScalarFrame) := do + if layouts.isEmpty || layouts.any (fun l => l.kLog < 6 || l.logN < 13) then none else do + let shape := flockShape layouts + if entry.frames.length < shape.length then none else do + let start := entry.frames.length - shape.length + let frames ← (List.range shape.length).mapM (fun i => scalarFrame entry answers (start+i)) + if frames.map (fun f => (f.before.length,f.sent.length)) = shape then some frames else none + +def scalarBefore (frames : List ScalarFrame) (i : Nat) : Option E := do + let f ← frames[i]? + match f.before with + | [x] => some x + | _ => none + +/-- The exact returned slice-claim construction in `lincheck.rs:518` and +`reduction.rs:258-263`: reverse the circuit's own lincheck rounds, then append +its zerocheck outer suffix. This does not assert either sumcheck identity. -/ +def assembleFlock (layout : FlockLayout) (zc lc slices : List E) : Option RingPCSGame.FamilyClaim := do + let rest := layout.kLog - 6 + if layout.kLog < 6 || layout.logN < 13 || lc.length < rest || + zc.length < layout.logN - 6 then none else do + if h : slices.length = 64 then + pure ⟨layout.offset, ((lc.take rest).reverse ++ + (zc.drop rest).take layout.instanceLog).toArray, + fun i => slices[i.val]'(by omega)⟩ + else none + +/-- The source's `[rest .. m-K_SKIP]` slice has exactly the public instance +dimension. This equality also fixes the direction of the lincheck reversal. -/ +theorem assembleFlock_source (layout : FlockLayout) (zc lc slices : List E) + (hk : 6 ≤ layout.kLog) (hm : 13 ≤ layout.logN) + (hlc : layout.kLog - 6 ≤ lc.length) (hzc : layout.logN - 6 ≤ zc.length) + (hs : slices.length = 64) : + assembleFlock layout zc lc slices = + some ⟨layout.offset, + ((lc.take (layout.kLog - 6)).reverse ++ + (zc.drop (layout.kLog - 6)).take + (layout.logN - 6 - (layout.kLog - 6))).toArray, + fun i => slices[i.val]'(by omega)⟩ := by + have hn : layout.logN - 6 - (layout.kLog - 6) = layout.instanceLog := by + simp only [FlockLayout.logN] + omega + simp [assembleFlock, hn, hs, Nat.not_lt.mpr hk, Nat.not_lt.mpr hm, + Nat.not_lt.mpr hlc, Nat.not_lt.mpr hzc] + +/-- Decode the Flock ring claims directly from a hypothetical complete caller +entry, before any WHIR sample. It works equally for actual and early-query +entries, and never accepts claims supplied as metadata. -/ +def decodeFlock (layouts : List FlockLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) : Option (List RingPCSGame.FamilyClaim) := do + let frames ← flockFrames layouts entry answers + let m := (layouts.map FlockLayout.logN).foldl max 0 + let rounds := (layouts.map (fun l => l.kLog - 6)).foldl max 0 + let zc ← (List.range (m-6)).mapM (fun j => scalarBefore frames (j+2)) + let lc ← (List.range rounds).mapM (fun j => scalarBefore frames (m-6+3+j)) + let terminal ← frames[m-6+rounds+2]? + layouts.zipIdx |>.mapM (fun (layout,i) => + assembleFlock layout zc lc ((terminal.sent.drop (65*i)).take 64)) + +theorem decodeFlock_prior_only (layouts : List FlockLayout) (entry : FramedHistory) + (a b : Coordinate → Digest32) + (agree : ∀ q ∈ callerOutputs entry, a q = b q) : + decodeFlock layouts entry a = decodeFlock layouts entry b := by + have h : scalarFrame entry a = scalarFrame entry b := by + funext i + simp only [scalarFrame, priorAnswers_congr entry a b agree] + simp only [decodeFlock, flockFrames, h] + +/-- Under physical output recovery, early decoding agrees with evaluation of +this same concrete Flock frame parser using the actual compression function. -/ +theorem decodeFlock_actual_outputs (layouts : List FlockLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) (c : Compression) (iv : Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) : + decodeFlock layouts entry answers = decodeFlock layouts entry (evalCoordinate c iv) := + decodeFlock_prior_only layouts entry answers (evalCoordinate c iv) observed + +/-- Full entry identity is retained, not replaced by seed identity. -/ +def identifiedFlock (layouts : List FlockLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) : + Option (FramedHistory × List RingPCSGame.FamilyClaim) := + (decodeFlock layouts entry answers).map (entry,·) + +theorem identifiedFlock_entry (layouts : List FlockLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) (other : FramedHistory) + (claims : List RingPCSGame.FamilyClaim) + (ok : identifiedFlock layouts entry answers = some (other,claims)) : entry = other := by + unfold identifiedFlock at ok + cases h : decodeFlock layouts entry answers <;> simp [h] at ok + exact ok.1 + +end Whir.WHIRCallerClaims diff --git a/verification/whir/Whir/WHIRCallerGeometry.lean b/verification/whir/Whir/WHIRCallerGeometry.lean new file mode 100644 index 000000000..30d6c1487 --- /dev/null +++ b/verification/whir/Whir/WHIRCallerGeometry.lean @@ -0,0 +1,916 @@ +import Whir.WHIRCallerSource +import Lean.Util.CollectAxioms + +/-! Static public-layout capacities imply support bounds for the actual caller +parser's successful outputs. These proofs follow its StateT recursion, shared +bus-column cache, table and settled loops, Flock construction, producer and +register rings, and final placement. The static geometry check belongs to public +configuration construction; no new verifier rejection or terminal-tail premise +is inserted into the source parser. -/ + +namespace Whir.WHIRCallerGeometry +open Concrete WHIRCallerClaims RingPCSGame +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 + +/-- A successful return of the actual state parser, with arbitrary preceding +and remaining tokens. No decoder equivalence or acceptance assumption is used. -/ +def Ensures {A : Type} (parser : CallerParser A) (post : A → Prop) : Prop := + ∀ tokens value rest, parser tokens = some (value,rest) → post value + +theorem ensures_pure {A : Type} (value : A) (post : A → Prop) (h : post value) : + Ensures (pure value) post := by + intro tokens result rest success + have equal : value = result := congrArg Prod.fst (Option.some.inj success) + exact equal ▸ h + +theorem ensures_bind {A B : Type} (parser : CallerParser A) (next : A → CallerParser B) + (pre : A → Prop) (post : B → Prop) (before : Ensures parser pre) + (after : ∀ value, pre value → Ensures (next value) post) : + Ensures (parser >>= next) post := by + intro tokens result rest success + change (parser tokens).bind (fun pair => next pair.1 pair.2) = some (result,rest) at success + cases first : parser tokens with + | none => simp [first] at success + | some pair => + exact after pair.1 (before tokens pair.1 pair.2 first) pair.2 result rest + (by simpa only [first, Option.bind_some] using success) + +theorem ensures_bind_any {A B : Type} (parser : CallerParser A) (next : A → CallerParser B) + (post : B → Prop) (after : ∀ value, Ensures (next value) post) : + Ensures (parser >>= next) post := + ensures_bind parser next (fun _ => True) post (fun _ _ _ _ => trivial) (fun value _ => after value) + +theorem ensures_failure {A : Type} (post : A → Prop) : + Ensures (fun _ => none) post := by + intro tokens value rest success + contradiction + +theorem ensures_mono {A : Type} {parser : CallerParser A} {P Q : A → Prop} + (before : Ensures parser P) (implies : ∀ value, P value → Q value) : Ensures parser Q := + fun tokens value rest success => implies value (before tokens value rest success) + +theorem ensures_forIn {A B : Type} (xs : List A) (initial : B) + (body : A → B → CallerParser (ForInStep B)) (inv : B → Prop) + (start : inv initial) + (step : ∀ x ∈ xs, ∀ value, inv value → Ensures (body x value) (fun out => inv out.value)) : + Ensures (forIn xs initial body) inv := by + induction xs generalizing initial with + | nil => exact ensures_pure initial inv start + | cons x xs ih => + rw [List.forIn_cons] + refine ensures_bind _ _ _ _ (step x List.mem_cons_self initial start) ?_ + intro out valid + cases out with + | done value => exact ensures_pure value inv valid + | yield value => + exact ih value valid (fun a ha v hv => step a (List.mem_cons_of_mem x ha) v hv) + +theorem ensures_forIn_size {A B : Type} (xs : List A) (initial : B) + (body : A → B → CallerParser (ForInStep B)) (size : B → Nat) + (step : ∀ x ∈ xs, ∀ value, Ensures (body x value) (fun out => size out.value ≤ size value + 1)) : + Ensures (forIn xs initial body) (fun out => size out ≤ size initial + xs.length) := by + induction xs generalizing initial with + | nil => exact ensures_pure initial _ (by simp) + | cons x xs ih => + rw [List.forIn_cons] + refine ensures_bind _ _ _ _ (step x List.mem_cons_self initial) ?_ + intro out bound + cases out with + | done value => + change size value ≤ size initial + 1 at bound + exact ensures_pure value _ (by simp only [List.length_cons]; omega) + | yield value => + refine ensures_mono (ih value (fun a ha v => step a (List.mem_cons_of_mem x ha) v)) ?_ + intro result hr + simp only [List.length_cons] + change size value ≤ size initial + 1 at bound + omega + +theorem ensures_mapM {A B : Type} (xs : List A) (f : A → CallerParser B) + (rel : A → B → Prop) (step : ∀ x ∈ xs, Ensures (f x) (rel x)) : + Ensures (xs.mapM f) (List.Forall₂ rel xs) := by + induction xs with + | nil => exact ensures_pure [] _ List.Forall₂.nil + | cons x xs ih => + rw [List.mapM_cons] + refine ensures_bind _ _ _ _ (step x List.mem_cons_self) ?_ + intro value valid + refine ensures_bind _ _ _ _ (ih (fun a ha => step a (List.mem_cons_of_mem x ha))) ?_ + intro rest relation + exact ensures_pure _ _ (List.Forall₂.cons valid relation) + +theorem readScalars_length (n : Nat) : + Ensures (readScalars n) (fun values => values.length = n) := by + induction n with + | zero => exact ensures_pure [] _ rfl + | succ n ih => + unfold readScalars + refine ensures_bind_any _ _ _ ?_ + intro value + refine ensures_bind _ _ _ _ ih ?_ + intro values length + exact ensures_pure _ _ (by simp [length]) + +def ColumnValid (C : Nat → Nat → Prop) (claim : ColumnClaim) : Prop := + C claim.column claim.point.length + +def Downward (C : Nat → Nat → Prop) : Prop := + ∀ index small large, small ≤ large → C index large → C index small + +def BusGeometry (C : Nat → Nat → Prop) (layout : BusLayout) : Prop := + ∀ block ∈ layout.push ++ layout.pull, block.tableOwned = false → + ∀ coord ∈ block.coords, match coord with + | .column column => C column block.kappa + | _ => True + +theorem busClaims_geometry (C : Nat → Nat → Prop) (down : Downward C) + (layout : BusLayout) (geometry : BusGeometry C layout) : + Ensures (busClaims layout) (fun result => ∀ claim ∈ result.2, ColumnValid C claim) := by + unfold busClaims + split + all_goals + try (refine ensures_bind_any (nonce _) _ _ ?_; intro ignored) + refine ensures_bind_any _ _ _ ?_ + intro draws + refine ensures_bind_any _ _ _ ?_ + intro draw + refine ensures_bind_any _ _ _ ?_ + intro point + refine ensures_bind _ _ (fun state => ∀ claim ∈ state.2, ColumnValid C claim) _ ?_ ?_ + · refine ensures_forIn _ _ _ _ (by simp) ?_ + intro block member state valid + dsimp only + refine ensures_bind_any _ _ _ ?_ + intro checked + split + · rename_i unowned + refine ensures_bind _ _ (fun state => ∀ claim ∈ state.2, ColumnValid C claim) _ ?_ ?_ + · refine ensures_forIn _ _ _ _ valid ?_ + intro coord hc state valid + cases coord with + | column column => + dsimp only + split + · refine ensures_bind_any _ _ _ ?_ + intro value + refine ensures_pure _ _ ?_ + intro claim found + rcases List.mem_append.mp found with old | fresh + · exact valid claim old + · have eq := List.mem_singleton.mp fresh + subst claim + exact down column _ block.kappa (List.length_take_le _ _) + (geometry block member (by simpa using unowned) (.column column) hc) + · exact ensures_pure _ _ valid + | publicValue => exact ensures_pure _ _ valid + | tableExpression => + intro tokens out rest success + change none = some (out,rest) at success + contradiction + · intro state valid + exact ensures_pure _ _ valid + · exact ensures_pure _ _ valid + · intro state valid + exact ensures_pure _ _ valid + +def TableGeometry (layout : AirLayout) (claims : TableClaims) : Prop := + claims.point.length ≤ layout.tau ∧ claims.evals.length ≤ layout.columns - layout.publicColumns + +theorem receiveTable_geometry (layout : AirLayout) (point : List E) : + Ensures (receiveTable layout point) (TableGeometry layout) := by + unfold receiveTable + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_bind_any _ _ _ ?_ + intro sent + refine ensures_bind_any _ _ _ ?_ + intro slices + refine ensures_bind _ _ (fun state => state.2.length ≤ layout.columns-layout.publicColumns) _ ?_ ?_ + · refine ensures_mono (ensures_forIn_size _ _ _ (fun state => state.2.length) ?_) ?_ + · intro c member state + dsimp only + split + · exact ensures_pure _ _ (by simp) + · rename_i missing + split + · exact ensures_failure _ + · exact ensures_pure _ _ (by simp) + · intro state bound + simpa only [List.length_nil, Nat.zero_add, List.length_range] using bound + · intro state bound + refine ensures_bind_any _ _ _ ?_ + intro checked + exact ensures_pure _ _ ⟨List.length_take_le _ _,bound⟩ + +theorem constraintClaims_geometry (layouts : List AirLayout) (busPoint : List E) : + Ensures (constraintClaims layouts busPoint) (List.Forall₂ TableGeometry layouts) := by + unfold constraintClaims + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_bind_any _ _ _ ?_ + intro rounds + exact ensures_mapM _ _ _ (fun layout _ => receiveTable_geometry layout rounds.reverse) + +theorem assembleFlock_geometry (layout : FlockLayout) (zc lc slices : List E) + (claim : FamilyClaim) (success : assembleFlock layout zc lc slices = some claim) : + claim.offset = layout.offset ∧ claim.point.size ≤ layout.kLog - 6 + layout.instanceLog := by + unfold assembleFlock at success + dsimp only at success + split at success + · contradiction + · split at success + · cases Option.some.inj success + constructor + · rfl + · simp only [List.size_toArray, List.length_append, List.length_reverse, List.length_take] + omega + · contradiction + +def RingValid (R : Nat → Nat → Prop) (claim : FamilyClaim) : Prop := + R claim.offset claim.point.size + +theorem forall2_mem_right {A B : Type} {rel : A → B → Prop} {xs : List A} {ys : List B} + (related : List.Forall₂ rel xs ys) {value : B} (member : value ∈ ys) : + ∃ input ∈ xs, rel input value := by + induction related with + | nil => simp at member + | @cons x y xs ys h hs ih => + rcases List.mem_cons.mp member with rfl | tail + · exact ⟨x,List.mem_cons_self,h⟩ + · obtain ⟨a,ha,hr⟩ := ih tail + exact ⟨a,List.mem_cons_of_mem x ha,hr⟩ + +theorem flockClaims_geometry (R : Nat → Nat → Prop) (down : Downward R) + (layouts : List FlockLayout) + (geometry : ∀ layout ∈ layouts, R layout.offset (layout.kLog - 6 + layout.instanceLog)) : + Ensures (flockClaims layouts) (fun claims => ∀ claim ∈ claims, RingValid R claim) := by + unfold flockClaims + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_bind_any _ _ _ ?_ + intro sampled + refine ensures_bind_any _ _ _ ?_ + intro sampled + refine ensures_bind_any _ _ _ ?_ + intro sent + refine ensures_bind_any _ _ _ ?_ + intro sampled + refine ensures_bind_any _ _ _ ?_ + intro zc + refine ensures_bind_any _ _ _ ?_ + intro sent + refine ensures_bind_any _ _ _ ?_ + intro sampled + refine ensures_bind_any _ _ _ ?_ + intro lc + refine ensures_mono (ensures_mapM _ _ (fun layout claim => + claim.offset = layout.offset ∧ claim.point.size ≤ layout.kLog - 6 + layout.instanceLog) ?_) ?_ + · intro layout member + refine ensures_bind_any _ _ _ ?_ + intro slices + refine ensures_bind_any _ _ _ ?_ + intro sent + split + · rename_i claim success + exact ensures_pure _ _ (assembleFlock_geometry layout zc lc slices claim success) + · exact ensures_failure _ + · intro claims relation claim member + obtain ⟨layout,hl,hrel⟩ := forall2_mem_right relation member + exact down claim.offset _ _ hrel.2 (hrel.1 ▸ geometry layout hl) + +theorem paddedRing_geometry (offset : Nat) (point slices : List E) (claim : FamilyClaim) + (success : paddedRing offset point slices = some claim) : + claim.offset = offset ∧ claim.point.size = point.length := by + unfold paddedRing at success + split at success + · cases Option.some.inj success + exact ⟨rfl,List.size_toArray⟩ + · contradiction + +theorem exitClaims_geometry (C : Nat → Nat → Prop) (column : Nat) (output : Fin 4 → UInt64) + (geometry : C column 6) : ∀ claim ∈ exitClaims column output, ColumnValid C claim := by + intro claim member + simp only [exitClaims, List.mem_cons, List.mem_ofFn] at member + rcases member with rfl | ⟨i,rfl⟩ <;> simpa [ColumnValid] using geometry + +theorem forall2_append {A B : Type} {rel : A → B → Prop} + {xs xs' : List A} {ys ys' : List B} + (left : List.Forall₂ rel xs ys) (right : List.Forall₂ rel xs' ys') : + List.Forall₂ rel (xs ++ xs') (ys ++ ys') := by + induction left with + | nil => exact right + | cons first rest ih => exact List.Forall₂.cons first ih + +theorem ensures_forIn_append {A B D : Type} (xs : List A) (initial : List B) + (body : A → List B → CallerParser (ForInStep (List B))) (select : A → List D) + (rel : D → B → Prop) + (step : ∀ x ∈ xs, ∀ values, Ensures (body x values) + (fun out => ∃ added, out = .yield (values ++ added) ∧ List.Forall₂ rel (select x) added)) : + Ensures (forIn xs initial body) + (fun out => ∃ added, out = initial ++ added ∧ List.Forall₂ rel (xs.flatMap select) added) := by + induction xs generalizing initial with + | nil => exact ensures_pure initial _ ⟨[],by simp,List.Forall₂.nil⟩ + | cons x xs ih => + rw [List.forIn_cons] + refine ensures_bind _ _ _ _ (step x List.mem_cons_self initial) ?_ + rintro out ⟨added,rfl,related⟩ + refine ensures_mono (ih (initial ++ added) + (fun a ha values => step a (List.mem_cons_of_mem x ha) values)) ?_ + rintro result ⟨tail,rfl,rest⟩ + exact ⟨added ++ tail,by simp [List.append_assoc],forall2_append related rest⟩ + +def SettledGeometry (layout : CpuTableLayout) (claims : TableClaims) : Prop := + claims.point.length ≤ layout.tau ∧ claims.evals.length ≤ layout.committedColumns + +theorem settledClaims_geometry (tables : List CpuTableLayout) (point : List E) : + Ensures (settledClaims tables point) + (List.Forall₂ SettledGeometry (tables.filter CpuTableLayout.settled)) := by + unfold settledClaims + refine ensures_bind _ _ (fun out => ∃ added, out = [] ++ added ∧ + List.Forall₂ SettledGeometry + (tables.flatMap fun t => if t.settled then [t] else []) added) _ ?_ ?_ + · refine ensures_forIn_append _ _ _ _ _ ?_ + intro table member values + dsimp only + split + · rename_i settled + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_bind_any _ _ _ ?_ + intro sent + refine ensures_bind _ _ (fun state => state.2.length ≤ table.committedColumns) _ ?_ ?_ + · refine ensures_mono (ensures_forIn_size _ _ _ (fun state => state.2.length) ?_) ?_ + · intro c member state + split + · exact ensures_pure _ _ (by simp) + · split + · exact ensures_failure _ + · exact ensures_pure _ _ (by simp) + · intro state bounded + simpa only [List.length_nil, Nat.zero_add, List.length_range] using bounded + · intro state bounded + refine ensures_bind_any _ _ _ ?_ + intro checked + refine ensures_pure _ _ ⟨[⟨point.take table.tau,state.2,[]⟩],rfl,?_⟩ + exact List.Forall₂.cons ⟨List.length_take_le _ _,bounded⟩ List.Forall₂.nil + · rename_i unsettled + refine ensures_pure _ _ ⟨[],by simp,?_⟩ + exact List.Forall₂.nil + · rintro result ⟨added,equal,related⟩ + have select_eq : (tables.flatMap fun t => if t.settled then [t] else []) = + tables.filter CpuTableLayout.settled := by + clear related + induction tables with + | nil => rfl + | cons t ts ih => cases h : t.settled <;> simp [h,ih] + simp only [List.nil_append] at equal + subst result + rw [select_eq] at related + exact ensures_pure _ _ related + +theorem forall2_get? {A B : Type} {rel : A → B → Prop} {xs : List A} {ys : List B} + (related : List.Forall₂ rel xs ys) (index : Nat) (value : B) + (found : ys[index]? = some value) : ∃ input, xs[index]? = some input ∧ rel input value := by + obtain ⟨bound,equal⟩ := List.getElem?_eq_some_iff.mp found + have inputBound : index < xs.length := by rw [related.length_eq]; exact bound + refine ⟨xs[index],by simp [inputBound],?_⟩ + simpa only [List.get_eq_getElem, equal] using related.get inputBound bound + +theorem tableColumns_geometry (C : Nat → Nat → Prop) (down : Downward C) + (base tau count : Nat) (claims : TableClaims) + (point : claims.point.length ≤ tau) (evals : claims.evals.length ≤ count) + (geometry : ∀ i ∈ List.range count, C (base+i) tau) : + ∀ claim ∈ tableColumns base claims, ColumnValid C claim := by + intro claim member + obtain ⟨⟨value,index⟩,found,rfl⟩ := List.mem_map.mp member + have atIndex := List.mk_mem_zipIdx_iff_getElem?.mp found + have bound := (List.getElem?_eq_some_iff.mp atIndex).1 + exact down (base+index) _ tau point + (geometry index (List.mem_range.mpr (bound.trans_le evals))) + +def TableColumnsGeometry (C : Nat → Nat → Prop) (base tau count : Nat) : Prop := + ∀ i ∈ List.range count, C (base+i) tau + +def RecGeometry (C R : Nat → Nat → Prop) (layout : RecLayout) : Prop := + BusGeometry C layout.bus ∧ + (∀ table ∈ layout.tables, TableColumnsGeometry C table.1 table.2.tau + (table.2.columns-table.2.publicColumns)) ∧ + R layout.hash.offset (layout.hash.kLog-6+layout.hash.instanceLog) + +def PointValid (C : Nat → Nat → Prop) (placements : Array Placement) (point : PointClaim) : Prop := + ∃ claim placement, placements[claim.column]? = some placement ∧ + placeClaim placement claim = some point ∧ ColumnValid C claim + +def ClaimsValid (C R : Nat → Nat → Prop) (placements : Array Placement) (claims : CallerClaims) : Prop := + (∀ ring ∈ claims.families, RingValid R ring) ∧ + (∀ point ∈ claims.points.toList, PointValid C placements point) + +theorem option_mapM_rel {A B : Type} (f : A → Option B) (xs : List A) (ys : List B) + (success : xs.mapM f = some ys) : List.Forall₂ (fun x y => f x = some y) xs ys := by + induction xs generalizing ys with + | nil => cases Option.some.inj success; exact List.Forall₂.nil + | cons x xs ih => + rw [List.mapM_cons] at success + change (f x).bind (fun y => (xs.mapM f).bind (fun ys => some (y :: ys))) = some ys at success + cases first : f x with + | none => simp only [first, Option.bind_none] at success; contradiction + | some y => + cases rest : xs.mapM f with + | none => simp only [first, Option.bind_some, rest, Option.bind_none] at success; contradiction + | some tail => + simp only [first, Option.bind_some, rest] at success + cases Option.some.inj success + exact List.Forall₂.cons first (ih tail rest) + +theorem placeClaims_geometry (C : Nat → Nat → Prop) (placements : Array Placement) + (claims : List ColumnClaim) (valid : ∀ claim ∈ claims, ColumnValid C claim) + (points : Array PointClaim) (success : placeClaims placements claims = some points) : + ∀ point ∈ points.toList, PointValid C placements point := by + change (claims.mapM (fun c => (placements[c.column]?).bind + (fun p => some (placeClaim p c)))).bind + (fun located => some ((located.filterMap id).toArray)) = some points at success + cases located : claims.mapM (fun c => (placements[c.column]?).bind + (fun p => some (placeClaim p c))) with + | none => + simp only [located, Option.bind_none] at success + contradiction + | some options => + simp only [located, Option.bind_some] at success + cases Option.some.inj success + intro point member + change point ∈ options.filterMap id at member + obtain ⟨option,member,equal⟩ := List.mem_filterMap.mp member + have related := option_mapM_rel _ _ _ located + obtain ⟨claim,hclaim,hvalue⟩ := forall2_mem_right related member + change option = some point at equal + cases hp : placements[claim.column]? with + | none => + simp only [hp, Option.bind_none] at hvalue + contradiction + | some placement => + refine ⟨claim,placement,hp,?_,valid claim hclaim⟩ + simp only [hp, Option.bind_some] at hvalue + exact (Option.some.inj hvalue).trans equal + +theorem rec_tableColumns_geometry (C : Nat → Nat → Prop) (down : Downward C) + (layouts : List (Nat × AirLayout)) (claims : List TableClaims) + (related : List.Forall₂ TableGeometry (layouts.map Prod.snd) claims) + (geometry : ∀ table ∈ layouts, TableColumnsGeometry C table.1 table.2.tau + (table.2.columns-table.2.publicColumns)) : + ∀ claim ∈ ((layouts.map Prod.fst).zip claims).flatMap + (fun (base,claims) => tableColumns base claims), ColumnValid C claim := by + induction layouts generalizing claims with + | nil => cases related; simp + | cons layout layouts ih => + cases related with + | cons first rest => + intro claim member + simp only [List.map_cons, List.zip_cons_cons, List.flatMap_cons, List.mem_append] at member + rcases member with current | later + · exact tableColumns_geometry C down layout.1 layout.2.tau _ _ first.1 first.2 + (geometry layout List.mem_cons_self) claim current + · exact ih _ rest (fun l hl => geometry l (List.mem_cons_of_mem layout hl)) claim later + +def PayloadValid (C R : Nat → Nat → Prop) (placements : Array Placement) + (payload : List FamilyClaim × Array PointClaim) : Prop := + (∀ ring ∈ payload.1, RingValid R ring) ∧ + (∀ point ∈ payload.2.toList, PointValid C placements point) + +theorem recPayload_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : RecLayout) (geometry : RecGeometry C R layout) : + Ensures (recPayload layout) (PayloadValid C R layout.placements) := by + unfold recPayload + refine ensures_bind _ _ _ _ (busClaims_geometry C columnDown layout.bus geometry.1) ?_ + rintro ⟨point,bus⟩ busValid + refine ensures_bind_any _ _ _ ?_ + intro draw + refine ensures_bind _ _ _ _ (constraintClaims_geometry _ point) ?_ + intro tables tableValid + refine ensures_bind _ _ _ _ (flockClaims_geometry R ringDown [layout.hash] (by simpa using geometry.2.2)) ?_ + intro rings ringValid + dsimp only + split + · rename_i points success + refine ensures_pure _ _ ⟨ringValid,?_⟩ + apply placeClaims_geometry C layout.placements _ _ points success + intro claim member + rcases List.mem_append.mp member with bus | table + · exact busValid claim bus + · exact rec_tableColumns_geometry C columnDown _ _ tableValid geometry.2.1 claim table + · exact ensures_failure _ + +theorem recClaims_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : RecLayout) (geometry : RecGeometry C R layout) : + Ensures (recClaims layout) (ClaimsValid C R layout.placements) := by + unfold recClaims + refine ensures_bind_any _ _ _ ?_ + intro root + refine ensures_bind _ _ _ _ (recPayload_geometry C R columnDown ringDown layout geometry) ?_ + rintro ⟨rings,points⟩ valid + exact ensures_pure _ _ valid + +theorem check_true (b : Bool) : Ensures (check b) (fun _ => b = true) := by + cases b with + | false => exact ensures_failure _ + | true => exact ensures_pure () _ rfl + +theorem filter_true {A : Type} (xs : List A) (p : A → Bool) (all : xs.all p = true) : + xs.filter p = xs := by + induction xs with + | nil => rfl + | cons x xs ih => + have h : p x = true ∧ xs.all p = true := by simpa only [List.all_cons, Bool.and_eq_true] using all + simp only [List.filter_cons, h.1, ↓reduceIte, ih h.2] + +theorem filter_false {A : Type} (xs : List A) (p : A → Bool) + (all : xs.all (fun x => !p x) = true) : xs.filter p = [] := by + induction xs with + | nil => rfl + | cons x xs ih => + have h : (!p x) = true ∧ xs.all (fun x => !p x) = true := by + simpa only [List.all_cons, Bool.and_eq_true] using all + have hx : p x = false := by simpa using h.1 + simp only [List.filter_cons, hx, Bool.false_eq_true, ↓reduceIte, ih h.2] + +theorem settled_prefix (tables : List CpuTableLayout) (n : Nat) + (before : (tables.take n).all CpuTableLayout.settled = true) + (after : (tables.drop n).all (fun t => !t.settled) = true) : + tables.filter CpuTableLayout.settled = tables.take n := by + calc + _ = (tables.take n).filter CpuTableLayout.settled ++ (tables.drop n).filter CpuTableLayout.settled := by + rw [← List.filter_append, List.take_append_drop] + _ = _ := by rw [filter_true _ _ before, filter_false _ _ after, List.append_nil] + +def CpuTableGeometry (table : CpuTableLayout) (claims : TableClaims) : Prop := + claims.point.length ≤ table.tau ∧ + claims.evals.length ≤ max table.committedColumns table.summedColumns.length + +theorem forall2_imp {A B : Type} {P Q : A → B → Prop} {xs : List A} {ys : List B} + (h : List.Forall₂ P xs ys) (imp : ∀ a b, P a b → Q a b) : List.Forall₂ Q xs ys := by + induction h with + | nil => exact .nil + | cons first rest ih => exact .cons (imp _ _ first) ih + +theorem forall2_map_left {A B D : Type} {rel : D → B → Prop} (f : A → D) {xs : List A} {ys : List B} + (h : List.Forall₂ rel (xs.map f) ys) : List.Forall₂ (fun a b => rel (f a) b) xs ys := by + induction xs generalizing ys with + | nil => cases h; exact .nil + | cons x xs ih => cases h with | cons first rest => exact .cons first (ih rest) + +theorem cpu_columns_geometry (tables : List CpuTableLayout) (producers : List AirLayout) + (settled summed : List TableClaims) + (settledValid : List.Forall₂ SettledGeometry (tables.filter CpuTableLayout.settled) settled) + (summedValid : List.Forall₂ TableGeometry (tables.map CpuTableLayout.air ++ producers) summed) + (before : (tables.take settled.length).all CpuTableLayout.settled = true) + (after : (tables.drop settled.length).all (fun t => !t.settled) = true) : + List.Forall₂ CpuTableGeometry tables + (settled ++ (summed.take tables.length).drop settled.length) := by + have first : List.Forall₂ CpuTableGeometry (tables.take settled.length) settled := by + rw [← settled_prefix tables settled.length before after] + exact forall2_imp settledValid (fun t c h => ⟨h.1,h.2.trans (Nat.le_max_left _ _)⟩) + have total : List.Forall₂ TableGeometry (tables.map CpuTableLayout.air) (summed.take tables.length) := by + have h := List.forall₂_take tables.length summedValid + simpa [List.take_append, ← List.map_take] using h + have total' := forall2_imp (forall2_map_left CpuTableLayout.air total) + (Q := CpuTableGeometry) (fun t c h => (⟨h.1, + (by simpa [CpuTableLayout.air] using h.2.trans (Nat.le_max_right t.committedColumns t.summedColumns.length))⟩)) + have last := List.forall₂_drop settled.length total' + simpa only [List.take_append_drop] using forall2_append first last + +def CpuGeometry (C R : Nat → Nat → Prop) (layout : CpuLayout) : Prop := + BusGeometry C layout.bus ∧ + (∀ table ∈ layout.tables, TableColumnsGeometry C table.base table.tau + (max table.committedColumns table.summedColumns.length)) ∧ + C layout.finalRegisterColumn 6 ∧ + (∀ flock ∈ layout.flock, R flock.offset (flock.kLog-6+flock.instanceLog)) ∧ + (∀ producer ∈ layout.bus.producers, R producer.window producer.kappa) ∧ + (∀ word ∈ layout.registers, match word.tables.head? with + | none => False + | some first => match layout.tables[first]? with + | none => False + | some table => R word.offset table.tau) + +def LayoutGeometry (C R : Nat → Nat → Prop) : CallerLayout → Prop + | .cpu layout => CpuGeometry C R layout + | .recursion layout => RecGeometry C R layout + +instance (C : Nat → Nat → Prop) [DecidableRel C] (layout : BusLayout) : + Decidable (BusGeometry C layout) := by + letI (k : Nat) : DecidablePred (fun coord : BusCoord => match coord with + | .column column => C column k + | _ => True) := fun coord => by cases coord <;> infer_instance + unfold BusGeometry + infer_instance + +instance (C : Nat → Nat → Prop) [DecidableRel C] (base tau count : Nat) : + Decidable (TableColumnsGeometry C base tau count) := + inferInstanceAs (Decidable (∀ i ∈ List.range count, C (base+i) tau)) + +instance (C R : Nat → Nat → Prop) [DecidableRel C] [DecidableRel R] (layout : RecLayout) : + Decidable (RecGeometry C R layout) := by unfold RecGeometry; infer_instance + +instance (C R : Nat → Nat → Prop) [DecidableRel C] [DecidableRel R] (layout : CpuLayout) : + Decidable (CpuGeometry C R layout) := by + letI : DecidablePred (fun word : RegisterWord => match word.tables.head? with + | none => False + | some first => match layout.tables[first]? with + | none => False + | some table => R word.offset table.tau) := fun word => by + dsimp only + split + · infer_instance + · split <;> infer_instance + unfold CpuGeometry + infer_instance + +instance (C R : Nat → Nat → Prop) [DecidableRel C] [DecidableRel R] (layout : CallerLayout) : + Decidable (LayoutGeometry C R layout) := by + cases layout <;> dsimp only [LayoutGeometry] <;> infer_instance + +theorem forall2_zip {A B : Type} {rel : A → B → Prop} {xs : List A} {ys : List B} + (related : List.Forall₂ rel xs ys) (x : A) (y : B) (member : (x,y) ∈ xs.zip ys) : + rel x y := by + induction related with + | nil => simp at member + | @cons a b as bs first rest ih => + rcases List.mem_cons.mp member with eq | tail + · rcases Prod.mk.inj eq with ⟨rfl,rfl⟩ + exact first + · exact ih tail + +theorem zip_member_left {A B : Type} {xs : List A} {ys : List B} {x : A} {y : B} + (member : (x,y) ∈ xs.zip ys) : x ∈ xs := by + induction xs generalizing ys with + | nil => simp at member + | cons a as ih => + cases ys with + | nil => simp at member + | cons b bs => + rcases List.mem_cons.mp member with equal | later + · rcases Prod.mk.inj equal with ⟨rfl,rfl⟩ + exact List.mem_cons_self + · exact List.mem_cons_of_mem a (ih later) + +theorem get?_append_left {A : Type} (xs ys : List A) (index : Nat) (value : A) + (found : xs[index]? = some value) : (xs ++ ys)[index]? = some value := by + obtain ⟨bound,equal⟩ := List.getElem?_eq_some_iff.mp found + apply List.getElem?_eq_some_iff.mpr + refine ⟨by simp only [List.length_append]; omega,?_⟩ + rw [List.getElem_append_left bound] + exact equal + +theorem cpu_tableColumns_geometry (C : Nat → Nat → Prop) (down : Downward C) + (layouts : List CpuTableLayout) (claims : List TableClaims) + (related : List.Forall₂ CpuTableGeometry layouts claims) + (geometry : ∀ table ∈ layouts, TableColumnsGeometry C table.base table.tau + (max table.committedColumns table.summedColumns.length)) : + ∀ claim ∈ ((layouts.map CpuTableLayout.base).zip claims).flatMap + (fun (base,claims) => tableColumns base claims), ColumnValid C claim := by + induction related with + | nil => simp + | @cons layout claim layouts claims first rest ih => + intro result member + simp only [List.map_cons, List.zip_cons_cons, List.flatMap_cons, List.mem_append] at member + rcases member with current | later + · exact tableColumns_geometry C down layout.base layout.tau _ _ first.1 first.2 + (geometry layout List.mem_cons_self) result current + · exact ih (fun l hl => geometry l (List.mem_cons_of_mem layout hl)) result later + +theorem cpuPayload_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : CpuLayout) (geometry : CpuGeometry C R layout) : + Ensures (cpuPayload layout) (PayloadValid C R layout.placements) := by + unfold cpuPayload + refine ensures_bind _ _ _ _ (busClaims_geometry C columnDown layout.bus geometry.1) ?_ + rintro ⟨point,bus⟩ busValid + refine ensures_bind _ _ _ _ (settledClaims_geometry layout.tables point) ?_ + intro settled settledValid + refine ensures_bind_any _ _ _ ?_ + intro draw + refine ensures_bind _ _ _ _ (constraintClaims_geometry _ point) ?_ + intro summed summedValid + refine ensures_bind _ _ _ _ (check_true _) ?_ + intro checked settledBefore + refine ensures_bind _ _ _ _ (check_true _) ?_ + intro checked settledAfter + have columnValid := cpu_columns_geometry layout.tables _ settled summed + settledValid summedValid settledBefore settledAfter + refine ensures_bind _ _ _ _ (flockClaims_geometry R ringDown layout.flock geometry.2.2.2.1) ?_ + intro packed packedValid + have producersValid : List.Forall₂ (fun (p : BusProducer) (c : TableClaims) => + c.point.length ≤ p.kappa) layout.bus.producers (summed.drop layout.tables.length) := by + have h := List.forall₂_drop layout.tables.length summedValid + have hp : List.Forall₂ TableGeometry + (layout.bus.producers.map (fun p => (⟨p.kappa,2*p.bits,p.bits,[]⟩ : AirLayout))) + (summed.drop layout.tables.length) := by + simpa [List.drop_append, ← List.map_drop] using h + exact forall2_imp (forall2_map_left _ hp) (fun _ _ valid => valid.1) + refine ensures_bind _ _ (fun rings => ∀ ring ∈ rings, RingValid R ring) _ ?_ ?_ + · refine ensures_forIn _ _ _ _ packedValid ?_ + rintro ⟨producer,claims⟩ member rings valid + dsimp only + split + · rename_i ring assembled + have h := paddedRing_geometry producer.window claims.point claims.evals ring assembled + refine ensures_pure _ _ ?_ + intro value member' + rcases List.mem_append.mp member' with old | fresh + · exact valid value old + · have eq := List.mem_singleton.mp fresh + subst value + have pointBound := forall2_zip producersValid producer claims member + have producerMember : producer ∈ layout.bus.producers := zip_member_left member + exact ringDown ring.offset _ _ (h.2 ▸ pointBound) + (h.1 ▸ geometry.2.2.2.2.1 producer producerMember) + · exact ensures_failure _ + · intro rings ringsValid + refine ensures_bind _ _ (fun state => state.1 = none ∧ ∀ ring ∈ state.2, RingValid R ring) _ ?_ ?_ + · refine ensures_forIn _ _ _ _ ⟨rfl,ringsValid⟩ ?_ + intro word member state valid + dsimp only + split + · rename_i first head + split + · rename_i firstClaims found + have register := geometry.2.2.2.2.2 word member + rw [head] at register + cases ht : layout.tables[first]? with + | none => simp only [ht] at register + | some table => + have rowBound : firstClaims.point.length ≤ table.tau := by + obtain ⟨air,atAir,valid⟩ := forall2_get? summedValid first firstClaims found + have current : (layout.tables.map CpuTableLayout.air)[first]? = some table.air := by + simp only [List.getElem?_map, ht, Option.map_some] + have same := (get?_append_left (layout.tables.map CpuTableLayout.air) _ first table.air current).symm.trans atAir + cases Option.some.inj same + exact valid.1 + have ringCapacity : R word.offset table.tau := by simpa only [ht] using register + refine ensures_bind _ _ (fun state => state.1 = none) _ ?_ ?_ + · refine ensures_forIn _ _ _ _ rfl ?_ + intro t member state valid + split + · exact ensures_pure _ _ rfl + · exact ensures_failure _ + · intro slices noReturn + rw [noReturn] + dsimp only + split + · rename_i ring assembled + have h := paddedRing_geometry word.offset firstClaims.point slices.2 ring assembled + refine ensures_pure _ _ ⟨rfl,?_⟩ + intro value member' + rcases List.mem_append.mp member' with old | fresh + · exact valid.2 value old + · have eq := List.mem_singleton.mp fresh + subst value + exact ringDown ring.offset _ _ (h.2 ▸ rowBound) (h.1 ▸ ringCapacity) + · exact ensures_failure _ + · exact ensures_failure _ + · exact ensures_failure _ + · intro state valid + dsimp only + rw [valid.1] + dsimp only + split + · rename_i points success + refine ensures_pure _ _ ⟨valid.2,?_⟩ + apply placeClaims_geometry C layout.placements _ _ points success + intro claim member + rcases List.mem_append.mp member with earlier | exit + · rcases List.mem_append.mp earlier with bus | table + · exact busValid claim bus + · exact cpu_tableColumns_geometry C columnDown _ _ columnValid geometry.2.1 claim table + · exact exitClaims_geometry C layout.finalRegisterColumn layout.output geometry.2.2.1 claim exit + · exact ensures_failure _ + +theorem cpuClaims_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : CpuLayout) (geometry : CpuGeometry C R layout) : + Ensures (cpuClaims layout) (ClaimsValid C R layout.placements) := by + unfold cpuClaims + refine ensures_bind_any _ _ _ ?_ + intro root + refine ensures_bind _ _ _ _ (cpuPayload_geometry C R columnDown ringDown layout geometry) ?_ + rintro ⟨rings,points⟩ valid + exact ensures_pure _ _ valid + +theorem sourceClaims_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : CallerLayout) (geometry : LayoutGeometry C R layout) : + Ensures (sourceClaims layout) (ClaimsValid C R (callerPlacements layout)) := by + cases layout with + | cpu layout => exact cpuClaims_geometry C R columnDown ringDown layout geometry + | recursion layout => exact recClaims_geometry C R columnDown ringDown layout geometry + +theorem interpretCaller_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : CallerLayout) (geometry : LayoutGeometry C R layout) + (tokens : List CallerToken) (claims : CallerClaims) + (success : interpretCaller layout tokens = some claims) : + ClaimsValid C R (callerPlacements layout) claims := by + unfold interpretCaller at success + split at success + · contradiction + · cases parsed : sourceClaims layout tokens with + | none => simp [parsed] at success + | some pair => + simp only [parsed] at success + change (if pair.2.isEmpty then some pair.1 else none) = some claims at success + split at success + · cases Option.some.inj success + exact sourceClaims_geometry C R columnDown ringDown layout geometry tokens pair.1 pair.2 parsed + · contradiction + +theorem decodeCaller_geometry (C R : Nat → Nat → Prop) + (columnDown : Downward C) (ringDown : Downward R) + (layout : CallerLayout) (geometry : LayoutGeometry C R layout) + (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (success : decodeCaller layout entry answers = some claims) : + ClaimsValid C R (callerPlacements layout) claims := by + cases parsed : entryTokens entry answers with + | none => simp [decodeCaller, parsed] at success + | some tokens => + apply interpretCaller_geometry C R columnDown ringDown layout geometry tokens claims + simp only [decodeCaller, parsed] at success + exact success + +private def smokeBus : BusLayout := + ⟨[⟨2,false,[.column 0,.column 1,.column 0,.publicValue]⟩], + [⟨2,false,[.column 1]⟩],[⟨2,2,0⟩],0⟩ + +private def smokePlacements : Array Placement := + (List.range 16).map (fun i => Placement.committed (64*i) 6) |>.toArray + +private def smokeCpu : CpuLayout where + bus := smokeBus + tables := (List.range 11).map fun i => + ⟨if i = 0 then 2 else 3+i,2,if i = 0 then 2 else 1,i = 0,[0],[⟨0,1⟩]⟩ + placements := smokePlacements + flock := [⟨64,7,6⟩] + registers := [⟨128,[0,1]⟩] + finalRegisterColumn := 15 + output := fun i => UInt64.ofNat (10+i.val) + logInvRate := 0 + +private def smokeRec : RecLayout := + ⟨smokeBus,[(2,⟨2,2,0,[⟨0,1⟩]⟩)],smokePlacements,⟨64,7,6⟩,0⟩ + +private def smokeTokens (layout : CallerLayout) : List CallerToken := + (callerShape layout).flatMap fun event => match event with + | .absorb bytes => List.replicate (bytes/24) (.sent 0) + | .squeeze count => List.replicate (count/24) (.draw 0) + | .nonce bits => [.nonce bits (fun _ => 0)] + +private def smoke : IO Unit := do + let C : Nat → Nat → Prop := fun column dimension => column < 16 ∧ dimension ≤ 6 + let R : Nat → Nat → Prop := fun offset dimension => offset ∈ [0,64,128] ∧ dimension ≤ 8 + unless decide (LayoutGeometry C R (.cpu smokeCpu)) && + decide (LayoutGeometry C R (.recursion smokeRec)) do + throw (IO.userError "source-derived static geometry rejected") + let cpuTokens := ((smokeTokens (.cpu smokeCpu)).zipIdx.map fun (token,index) => + if index < 11 then CallerToken.sent (E.ofK 2) + else if index = 12 then CallerToken.sent (E.ofK (UInt64.ofNat (2^40))) else token) + let some (cpu,rest) := sourceClaims (.cpu smokeCpu) cpuTokens | + throw (IO.userError "actual CPU source parser rejected smoke") + unless rest.isEmpty && cpu.points.size == 19 && + (cpu.families.map (fun ring => (ring.offset,ring.point.size))) == [(64,7),(0,2),(128,2)] do + throw (IO.userError "CPU returned dimensions/provenance mismatch") + let recTokens := smokeTokens (.recursion smokeRec) + let some (rec,rest) := sourceClaims (.recursion smokeRec) recTokens | + throw (IO.userError "actual recursion source parser rejected smoke") + unless rest.isEmpty && rec.points.size == 4 && + (rec.families.map (fun ring => (ring.offset,ring.point.size))) == [(64,7)] do + throw (IO.userError "recursion returned dimensions/provenance mismatch") + let pointDimension := fun point => match point with + | PointClaim.point _ point _ => point.size + | .strided _ _ _ point _ => point.size + unless cpu.points.toList.map pointDimension == List.replicate 14 2 ++ List.replicate 5 6 && + rec.points.toList.map pointDimension == List.replicate 4 2 do + throw (IO.userError "bus/table/exit dimensions mismatch") + unless !(decide (LayoutGeometry (fun _ d => d ≤ 1) R (.cpu smokeCpu))) do + throw (IO.userError "insufficient public capacity unexpectedly passed static check") + IO.println "caller geometry smoke: actual CPU 19 points + 3 rings; recursion 4 points + 1 ring; bus dedup, settled/summed tables, flock, producer, register, exit dimensions checked" + +#eval smoke + +open Lean in +run_cmd do + let environment ← getEnv + let mut count : Nat := 0 + for (name,info) in environment.constants.toList do + if (`Whir.WHIRCallerGeometry).isPrefixOf name then + match info with + | .thmInfo _ => + for ax in (← collectAxioms name) do + unless #[``propext,``Classical.choice,``Quot.sound].contains ax do + throwError "unexpected axiom {ax} in {name}" + count := count + 1 + | .axiomInfo _ => throwError "new axiom {name}" + | _ => pure () + logInfo m!"Audited {count} caller geometry theorems: only standard three axioms." + +end Whir.WHIRCallerGeometry diff --git a/verification/whir/Whir/WHIRCallerRegistry.lean b/verification/whir/Whir/WHIRCallerRegistry.lean new file mode 100644 index 000000000..9e11ce058 --- /dev/null +++ b/verification/whir/Whir/WHIRCallerRegistry.lean @@ -0,0 +1,399 @@ +import Whir.WHIRCallerSource +import Whir.WHIRObservableAllocations + +/-! Production stack-caller registry. A statement selects only fixed public +layout data. Profiles, frame boundaries, lanes and caller-output budgets are +computed by the concrete source interpreter. Allocation labels contribute only +actual garbage-key caller samples; absent samples never receive default bytes. +The table-backed compiler trace theorem derives their completeness and immutable +values from the shared allocation cache, including prequeries before the source +has announced its claims. `packetRoot` captures the initial physical root without +waiting for these samples; `packetRequest_root` follows from original source +semantics and exact framing, not an added root-agreement acceptance check. +Complete requests are stable under later allocation-history extension; arbitrary +future WHIR vectors also preserve malformed `none` results. -/ +namespace Whir.WHIRCallerRegistry +open FiatShamirGame DuplexModeGame TypedOracleCompiler TypedFiatShamirGame +open RawOracleCoupling RawOracleCoupling.Concrete WHIRCallerClaims +open RawWHIRKeys (Packet Context) + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +structure Public where + iv : Digest32 + domain : Digest32 + layouts : Digest32 → Option CallerLayout + callerOutputCap : Nat + +/-- Unsupported opening geometry and oversized caller programs have no catalog +entry. In particular, no supplied profile or claim data is trusted. -/ +def selection (registry : Public) (statement : Digest32) : Option (CallerLayout × ParameterBounds.Profile) := do + let layout ← registry.layouts statement + let profile ← callerProfile layout + if callerOutputCap layout ≤ registry.callerOutputCap then some (layout,profile) else none + +def context (registry : Public) : Context where + mode := .stack + iv := registry.iv + domain := registry.domain + catalog := fun statement => (selection registry statement).map Prod.snd + entryLength := fun statement => ((selection registry statement).map (callerEntryLength ∘ Prod.fst)).getD 0 + callerOutputCap := registry.callerOutputCap + +theorem selection_spec (registry : Public) (statement : Digest32) + (layout : CallerLayout) (profile : ParameterBounds.Profile) + (selected : selection registry statement = some (layout,profile)) : + registry.layouts statement = some layout ∧ callerProfile layout = some profile ∧ + callerOutputCap layout ≤ registry.callerOutputCap := by + unfold selection at selected + cases hl : registry.layouts statement with + | none => simp [hl] at selected + | some l => + rw [hl] at selected + change (Option.bind (callerProfile l) (fun p => + if callerOutputCap l ≤ registry.callerOutputCap then some (l,p) else none)) = + some (layout,profile) at selected + cases hp : callerProfile l with + | none => simp [hp] at selected + | some p => + rw [hp] at selected + change (if callerOutputCap l ≤ registry.callerOutputCap then some (l,p) else none) = + some (layout,profile) at selected + split at selected + next bound => + cases Option.some.inj selected + exact ⟨rfl,hp,bound⟩ + next => simp at selected + +/-- Every valid packet determines a concrete public source layout. -/ +def packetLayout (registry : Public) (Q : Nat) (packet : Packet (context registry) Q) : CallerLayout := + match h : selection registry packet.val.statement with + | some selected => selected.1 + | none => False.elim (by + have catalog := packet.property.1 + simp [context,h] at catalog) + +theorem packet_selection (registry : Public) (Q : Nat) (packet : Packet (context registry) Q) : + selection registry packet.val.statement = some (packetLayout registry Q packet,packet.val.profile) := by + have catalog := packet.property.1 + unfold packetLayout + split + next selected h => + simp only [context,h,Option.map_some] at catalog + rw [h] + exact congrArg (fun p => some (selected.1,p)) (Option.some.inj catalog) + next h => simp [context,h] at catalog + +theorem packet_geometry (registry : Public) (Q : Nat) (packet : Packet (context registry) Q) : + registry.layouts packet.val.statement = some (packetLayout registry Q packet) ∧ + callerProfile (packetLayout registry Q packet) = some packet.val.profile ∧ + callerOutputCap (packetLayout registry Q packet) ≤ registry.callerOutputCap ∧ + openingMatches packet.val.profile (callerLanes (packetLayout registry Q packet)) + (packetLayout registry Q packet) = true ∧ + packet.val.entryFrames.length = callerEntryLength (packetLayout registry Q packet) := by + have selected := packet_selection registry Q packet + obtain ⟨layout,profile,bounded⟩ := selection_spec registry _ _ _ selected + refine ⟨layout,profile,bounded,callerProfile_matches _ _ profile,?_⟩ + have frames := RawWHIRKeys.packet_entryLength (context registry) Q packet + simpa only [context,selected,Option.map_some,Option.getD_some,Function.comp_apply] using frames + +/-- Only garbage groups can supply caller bytes. WHIR group answers are skipped, +including later packets and current-packet sample vectors. -/ +def garbageAnswer {ctx : Context} {Q : Nat} (raw : (partition ctx Q).Garbage) : + List (Sigma (GroupAnswer ctx Q)) → Option Digest32 + | [] => none + | ⟨.inl _,_⟩ :: rest => garbageAnswer raw rest + | ⟨.inr key,value⟩ :: rest => if key = raw then some value else garbageAnswer raw rest + +def callerAnswers (ctx : Context) (Q : Nat) (packet : Packet ctx Q) + (history : List (Sigma (GroupAnswer ctx Q))) (q : Coordinate) : Option Digest32 := + if member : q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val) then + garbageAnswer (RawWHIRKeys.callerOutputKey ctx Q packet q member) history + else none + +def packetRequest (registry : Public) (Q cap : Nat) (packet : Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) : + Option (CausalBindingState.ClaimRequest cap packet.val.profile) := + decodeAvailableRequest cap packet.val.profile (callerLanes (packetLayout registry Q packet)) + (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) + (callerAnswers (context registry) Q packet history) + +/-- Cache consistency suffices even if the annotation contains repeated keys; +the first matching entry has the same immutable value as every other one. -/ +theorem garbageAnswer_cache {ctx : Context} {Q : Nat} + (raw : (partition ctx Q).Garbage) (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (history : List (Sigma (GroupAnswer ctx Q))) + (consistent : ∀ item ∈ history, cache item.1 = some item.2) + (complete : ∃ answer, (⟨.inr raw,answer⟩ : Sigma (GroupAnswer ctx Q)) ∈ history) : + garbageAnswer raw history = cache (.inr raw) := by + induction history with + | nil => obtain ⟨a,h⟩ := complete; simp at h + | cons item rest ih => + have tailConsistent : ∀ item ∈ rest, cache item.1 = some item.2 := + fun item member => consistent item (List.mem_cons_of_mem _ member) + obtain ⟨key,value⟩ := item + cases key with + | inl packet => + apply ih tailConsistent + obtain ⟨answer,member⟩ := complete + refine ⟨answer,(List.mem_cons.mp member).resolve_left ?_⟩ + intro same + have impossible := congrArg Sigma.fst same + contradiction + | inr key => + by_cases same : key = raw + · subst key + simp only [garbageAnswer,↓reduceIte] + exact (consistent ⟨.inr raw,value⟩ (List.mem_cons_self)).symm + · simp only [garbageAnswer,ite_eq_right same] + apply ih tailConsistent + obtain ⟨answer,member⟩ := complete + refine ⟨answer,(List.mem_cons.mp member).resolve_left ?_⟩ + intro equal + exact same (Sum.inr.inj (congrArg Sigma.fst equal)).symm + +theorem dependencyHistory_consistent {ctx : Context} {Q : Nat} + (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) (key : GroupKey ctx Q) : + ∀ item ∈ dependencyHistory (dependencyKeys ctx Q) cache key, + cache item.1 = some item.2 := by + intro item member + obtain ⟨k,_,hit⟩ := List.mem_filterMap.mp member + cases h : cache k with + | none => simp [h] at hit + | some value => + simp only [h,Option.map_some,Option.some.injEq] at hit + cases hit + exact h + +theorem callerAnswers_compile {ctx : Context} {Q : Nat} {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (program : Sampling (RawKey Q) (fun _ => Digest32) R K) + {trace result} (run : Sampling.Runs (compile ctx Q final program) trace result) + (allocation : Sigma (AllocationAnswer ctx Q)) (member : allocation ∈ trace) + (packet : Packet ctx Q) (key : allocation.1.1 = .inl packet) + (q : Coordinate) (prior : q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val)) : + callerAnswers ctx Q packet allocation.1.2 q = + result.2 (.inr (RawWHIRKeys.callerOutputKey ctx Q packet q prior)) := by + let raw := RawWHIRKeys.callerOutputKey ctx Q packet q prior + have caller : raw ∈ RawWHIRKeys.callerGroups ctx Q packet := by + exact List.mem_map.mpr ⟨⟨q,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨answer,present,_⟩ := compile_caller_history ctx Q final program run allocation member packet key raw caller + simp only [callerAnswers,dite_eq_left prior] + apply garbageAnswer_cache _ result.2 allocation.1.2 + · rw [compile_trace_history ctx Q final program run allocation member] + exact dependencyHistory_consistent result.2 allocation.1.1 + · exact ⟨answer,present⟩ + +/-- Raw-table values are read at the exact physical caller coordinates. -/ +def tableCallerAnswers (ctx : Context) (Q : Nat) (packet : Packet ctx Q) + (table : RawKey Q → Digest32) (q : Coordinate) : Option Digest32 := + if prior : q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val) then + some (table (RawWHIRKeys.callerOutputKey ctx Q packet q prior).val) + else none + +theorem callerAnswers_table_compile {ctx : Context} {Q : Nat} {R : Type} {K : Nat} + (final : R → Option (Packet ctx Q)) (program : Sampling (RawKey Q) (fun _ => Digest32) R K) + (table : RawKey Q → Digest32) + (allocation : Sigma (AllocationAnswer ctx Q)) + (member : allocation ∈ (Sampling.execute + (WHIRObservableAllocations.allocationOracle ctx Q table) (compile ctx Q final program)).2) + (packet : Packet ctx Q) (key : allocation.1.1 = .inl packet) : + callerAnswers ctx Q packet allocation.1.2 = tableCallerAnswers ctx Q packet table := by + have run := Sampling.execute_runs (WHIRObservableAllocations.allocationOracle ctx Q table) + (compile ctx Q final program) + rw [WHIRObservableAllocations.compile_cache] at run + funext q + by_cases prior : q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val) + · rw [callerAnswers_compile final program run allocation member packet key q prior] + let raw := RawWHIRKeys.callerOutputKey ctx Q packet q prior + have caller : raw ∈ RawWHIRKeys.callerGroups ctx Q packet := + List.mem_map.mpr ⟨⟨q,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨answer,_,hit⟩ := + compile_caller_history ctx Q final program run allocation member packet key raw caller + have value := tableExecution_cache ctx Q final program table (.inr raw) answer hit + change table raw.val = answer at value + simp only [tableCallerAnswers,dite_eq_left prior] + change (tableExecution ctx Q final program table).2 (.inr raw) = some (table raw.val) + rw [value] + exact hit + · simp only [callerAnswers,tableCallerAnswers,dite_eq_right prior] + +theorem packetRequest_table_compile (registry : Public) (Q cap : Nat) {R : Type} {K : Nat} + (final : R → Option (Packet (context registry) Q)) + (program : Sampling (RawKey Q) (fun _ => Digest32) R K) (table : RawKey Q → Digest32) + (allocation : Sigma (AllocationAnswer (context registry) Q)) + (member : allocation ∈ (Sampling.execute + (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q final program)).2) + (packet : Packet (context registry) Q) (key : allocation.1.1 = .inl packet) : + packetRequest registry Q cap packet allocation.1.2 = + decodeAvailableRequest cap packet.val.profile (callerLanes (packetLayout registry Q packet)) + (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) + (tableCallerAnswers (context registry) Q packet table) := by + unfold packetRequest + rw [callerAnswers_table_compile final program table allocation member packet key] + +theorem garbageAnswer_missing {ctx : Context} {Q : Nat} + (raw : (partition ctx Q).Garbage) (history : List (Sigma (GroupAnswer ctx Q))) + (missing : ∀ item ∈ history, item.1 ≠ .inr raw) : + garbageAnswer raw history = none := by + induction history with + | nil => rfl + | cons item rest ih => + have tailMissing : ∀ item ∈ rest, item.1 ≠ .inr raw := + fun item member => missing item (List.mem_cons_of_mem _ member) + obtain ⟨key,value⟩ := item + cases key with + | inl packet => exact ih tailMissing + | inr key => + have different : key ≠ raw := fun equal => + missing ⟨.inr key,value⟩ List.mem_cons_self (congrArg Sum.inr equal) + simpa only [garbageAnswer,ite_eq_right different] using ih tailMissing + +theorem garbageAnswer_append_irrelevant {ctx : Context} {Q : Nat} + (raw : (partition ctx Q).Garbage) (history extra : List (Sigma (GroupAnswer ctx Q))) + (irrelevant : ∀ item ∈ extra, item.1 ≠ .inr raw) : + garbageAnswer raw (history ++ extra) = garbageAnswer raw history := by + induction history with + | nil => exact garbageAnswer_missing raw extra irrelevant + | cons item rest ih => + obtain ⟨key,value⟩ := item + cases key with + | inl packet => exact ih + | inr key => simp only [List.cons_append,garbageAnswer,ih] + +theorem packetRequest_prior_only (registry : Public) (Q cap : Nat) + (packet : Packet (context registry) Q) + (a b : List (Sigma (GroupAnswer (context registry) Q))) + (agree : ∀ q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry (context registry) packet.val), + callerAnswers (context registry) Q packet a q = callerAnswers (context registry) Q packet b q) : + packetRequest registry Q cap packet a = packetRequest registry Q cap packet b := + decodeAvailableRequest_prior_only _ _ _ _ _ _ _ agree + +theorem packetRequest_append_irrelevant (registry : Public) (Q cap : Nat) + (packet : Packet (context registry) Q) + (history extra : List (Sigma (GroupAnswer (context registry) Q))) + (irrelevant : ∀ q (prior : q ∈ WHIRCallerOutputs.callerOutputs + (RawWHIRKeys.entry (context registry) packet.val)), ∀ item ∈ extra, + item.1 ≠ .inr (RawWHIRKeys.callerOutputKey (context registry) Q packet q prior)) : + packetRequest registry Q cap packet (history ++ extra) = packetRequest registry Q cap packet history := by + apply packetRequest_prior_only + intro q prior + simp only [callerAnswers,dite_eq_left prior] + exact garbageAnswer_append_irrelevant _ history extra (irrelevant q prior) + +/-- In particular, appending any future WHIR vectors cannot affect a request, +including a malformed entry whose request is `none`. -/ +theorem packetRequest_append_whir (registry : Public) (Q cap : Nat) + (packet : Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (extra : List ((p : Packet (context registry) Q) × (Fin (RawWHIRKeys.blocks (context registry) p.val) → Digest32))) : + packetRequest registry Q cap packet + (history ++ extra.map (fun item => ⟨.inl item.1,item.2⟩)) = + packetRequest registry Q cap packet history := by + apply packetRequest_append_irrelevant + intro q prior item member + obtain ⟨item,_,rfl⟩ := List.mem_map.mp member + intro impossible + contradiction + +theorem packetRequest_missing (registry : Public) (Q cap : Nat) + (packet : Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (q : Coordinate) (prior : q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry (context registry) packet.val)) + (missing : ∀ item ∈ history, + item.1 ≠ .inr (RawWHIRKeys.callerOutputKey (context registry) Q packet q prior)) : + packetRequest registry Q cap packet history = none := by + apply decodeAvailableRequest_missing _ _ _ _ _ _ q prior + simp only [callerAnswers,dite_eq_left prior] + exact garbageAnswer_missing _ history missing + +/-- Packet suffixes need not agree. Complete entry identity and the same prior +caller samples already determine the entire optional request, not merely its +successful cases. -/ +theorem packetRequest_same_entry (registry : Public) (Q cap : Nat) + (a b : Packet (context registry) Q) + (ha hb : List (Sigma (GroupAnswer (context registry) Q))) + (same : RawWHIRKeys.entry (context registry) a.val = RawWHIRKeys.entry (context registry) b.val) + (answers : ∀ q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry (context registry) a.val), + callerAnswers (context registry) Q a ha q = callerAnswers (context registry) Q b hb q) : + HEq (packetRequest registry Q cap a ha) (packetRequest registry Q cap b hb) := by + have statement : a.val.statement = b.val.statement := congrArg FramedHistory.statement same + have profile : a.val.profile = b.val.profile := by + apply Option.some.inj + exact a.property.1.symm.trans (statement.symm ▸ b.property.1) + have layout : packetLayout registry Q a = packetLayout registry Q b := by + have first := packet_selection registry Q a + have second := packet_selection registry Q b + rw [statement,second] at first + exact (congrArg Prod.fst (Option.some.inj first)).symm + unfold packetRequest + rw [layout] + rw [profile] + apply heq_of_eq + rw [← same] + exact decodeAvailableRequest_prior_only _ _ _ _ _ _ _ answers + +theorem garbageAnswer_append_hit {ctx : Context} {Q : Nat} + (raw : (partition ctx Q).Garbage) (history extra : List (Sigma (GroupAnswer ctx Q))) + (answer : Digest32) (hit : garbageAnswer raw history = some answer) : + garbageAnswer raw (history ++ extra) = some answer := by + induction history with + | nil => cases hit + | cons item rest ih => + obtain ⟨key,value⟩ := item + cases key with + | inl packet => exact ih hit + | inr key => + by_cases same : key = raw + · simpa only [List.cons_append,garbageAnswer,ite_eq_left same] using hit + · simp only [garbageAnswer,ite_eq_right same] at hit + simpa only [List.cons_append,garbageAnswer,ite_eq_right same] using ih hit + +/-- Once a valid request is available, arbitrary later allocations cannot +overwrite its caller samples, even if a malformed supplied history repeats a +key with a different later value. The compiler's actual histories additionally +satisfy the stronger cache-consistency theorem above. -/ +theorem packetRequest_append_of_some (registry : Public) (Q cap : Nat) + (packet : Packet (context registry) Q) + (history extra : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (accepted : packetRequest registry Q cap packet history = some request) : + packetRequest registry Q cap packet (history ++ extra) = some request := by + have available : ∀ q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry (context registry) packet.val), + (callerAnswers (context registry) Q packet history q).isSome = true := by + unfold packetRequest decodeAvailableRequest at accepted + split at accepted + next complete => exact List.all_eq_true.mp complete + next => simp at accepted + rw [← accepted] + apply packetRequest_prior_only + intro q prior + have present := available q prior + simp only [callerAnswers,dite_eq_left prior] at present ⊢ + cases hit : garbageAnswer (RawWHIRKeys.callerOutputKey (context registry) Q packet q prior) history with + | none => simp [hit] at present + | some answer => + exact garbageAnswer_append_hit _ history extra answer hit + +/-- Commitment capture is available before warming any caller-output groups. -/ +def packetRoot (registry : Public) (Q : Nat) (packet : Packet (context registry) Q) : Option Digest32 := + initialRoot (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) + +theorem packetRequest_root (registry : Public) (Q cap : Nat) + (packet : Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (accepted : packetRequest registry Q cap packet history = some request) : + packetRoot registry Q packet = some request.root := + decodeAvailableRequest_initialRoot _ _ _ _ _ _ request accepted + +end Whir.WHIRCallerRegistry diff --git a/verification/whir/Whir/WHIRCallerSource.lean b/verification/whir/Whir/WHIRCallerSource.lean new file mode 100644 index 000000000..0e317dbe6 --- /dev/null +++ b/verification/whir/Whir/WHIRCallerSource.lean @@ -0,0 +1,1285 @@ +import Whir.WHIRCallerClaims +import Whir.CausalBindingState + +/-! Executable claim-producing projection of the two production fresh-stack +callers: `cpu/reduce.rs::verify_core` and `rec/proof.rs::verify_core`. Recursive +verifier rows call those same routines. Direct PCS users and Flock benchmarks +retain their separate caller-bound public-claims contract. + +The public configuration contains layout/shape data and public outputs, not +returned claims, a user instruction tape, or a decoder. The concrete program +covers GKR's radix-four/binary point order, shared framework-column deduplication, +table sumcheck point reversal, ordered bit-field reconstruction, settled-table +merging, Flock/producer/register rings, and point/port/sliced/exit placement. +`callerShape`, `callerProfile`, `callerLanes`, `callerEntryLength`, and +`callerOutputCap` compute public metadata. The decoder checks supplied opening +geometry against it. `decodeAvailableRequest` additionally rejects missing +preceding output samples instead of substituting arbitrary values. + +This is a claim projection, not a proof of the enclosing caller's arithmetic +soundness. Arithmetic acceptance checks which do not alter transcript control +or returned claims remain obligations of successful source verification. +`decodeRequest_physical_source` connects the concrete interpreter's returned +claims to actual framed bytes and preceding physical streams, without a generic +decoder correctness hypothesis or any announcement of claims. + +`initialRoot` reads only the initial absorb-zero frame, before any caller draw +or proof-of-work step. `sourceClaims_initialPrefix` and +`interpretCaller_initialRoot` prove that the original token-only source parser +returns that same root: scalar-prefix replay followed by normalized framing +establishes agreement, without adding an acceptance guard. The CPU announcement +factoring is equated to its original loop by `readAnnouncements_loop`. + +Source assembly was exercised against fully verified baseline Rust CPU and +recursion proofs, including all returned point and ring claims. Their read/sample +traces are transported through the conditional framing model using the recorded +caller outputs. This does not claim baseline Rust implements conditional #552's +compression mode; that mode's physical recovery is the separate checked theorem. +No claims are observed again and no sampler is restarted. -/ +namespace Whir.WHIRCallerClaims +open Concrete FiatShamirGame DuplexRefinement DuplexEncoding WHIRCallerOutputs ParameterBounds +inductive CallerToken where + | sent (value : E) + | draw (value : E) + | nonce (bits : Nat) (value : Scalar24) + deriving DecidableEq + +def tokenOperation : CallerToken → WHIRCallerShape.Operation + | .sent x => .absorb (WHIRHistory.scalarBytes [x]) + | .draw _ => .squeeze 24 + | .nonce bits value => .nonce bits value + +/-- Pure framing check. This neither evaluates a fresh transcript nor draws any +randomness: output values come only from physical prior-output coordinates. -/ +def tokenHistory (domain statement : Digest32) (tokens : List CallerToken) : FramedHistory := + (closeRun (WHIRCallerShape.runOperations + (WHIRCallerShape.seedModel domain statement) (tokens.map tokenOperation))).history + +def tokensFromFrame (f : Frame) (output : List Byte) : Option (List CallerToken) := do + let n := previousConsumed f + if n % 24 ≠ 0 then none else do + let draws ← WHIRHistory.parseExact (n / 24) output + let suffix ← match f with + | .absorb _ bytes => do + let sent ← WHIRHistory.parseExact (bytes.length / 24) bytes + pure (sent.map CallerToken.sent) + | .nonce _ bits value => pure [.nonce bits value] + pure (draws.map CallerToken.draw ++ suffix) + +def frameTokens (entry : FramedHistory) (answers : Coordinate → Digest32) + (i : Nat) (f : Frame) : Option (List CallerToken) := + tokensFromFrame f (recoveredBytes (priorAnswers entry answers) + {entry with frames := entry.frames.take i} 0 (previousConsumed f)) + +/-- The actual caller interpreter obtains preceding challenge bytes by replaying +the physical stream, independently of the decoder's output-answer cache. -/ +def sourceFrameTokens (c : Compression) (iv : Digest32) (entry : FramedHistory) + (i : Nat) (f : Frame) : Option (List CallerToken) := + tokensFromFrame f (stream c (evalHistory c iv {entry with frames := entry.frames.take i}) + 0 (previousConsumed f)) + +theorem frameTokens_source (c : Compression) (iv : Digest32) (entry : FramedHistory) + (answers : Coordinate → Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) + (i : Nat) (f : Frame) (atFrame : entry.frames[i]? = some f) : + frameTokens entry answers i f = sourceFrameTokens c iv entry i f := by + obtain ⟨hi,hf⟩ := List.getElem?_eq_some_iff.mp atFrame + have split : entry.frames = entry.frames.take i ++ f :: entry.frames.drop (i+1) := by + rw [← hf, ← List.drop_eq_getElem_cons hi, List.take_append_drop] + have observed' : ∀ q ∈ callerOutputs entry, + priorAnswers entry answers q = evalCoordinate c iv q := by + intro q hq + simpa [priorAnswers, hq] using observed q hq + unfold frameTokens sourceFrameTokens + rw [callerBytes_recovery c iv entry (priorAnswers entry answers) observed' + (entry.frames.take i) f (entry.frames.drop (i+1)) split 0 (previousConsumed f) (by omega)] + +private theorem option_mapM_congr {α β : Type} (xs : List α) (f g : α → Option β) + (agree : ∀ x ∈ xs, f x = g x) : xs.mapM f = xs.mapM g := by + induction xs with + | nil => rfl + | cons x xs ih => + have hx := agree x (by simp) + have ht := ih (fun y hy => agree y (by simp [hy])) + simp [List.mapM_cons, hx, ht] + +def entryTokens (entry : FramedHistory) (answers : Coordinate → Digest32) : Option (List CallerToken) := do + let frames ← entry.frames.zipIdx.mapM (fun (f,i) => frameTokens entry answers i f) + let tokens := frames.flatten + if tokenHistory entry.domain entry.statement tokens = entry then some tokens else none + +theorem entryTokens_prior_only (entry : FramedHistory) (a b : Coordinate → Digest32) + (agree : ∀ q ∈ callerOutputs entry, a q = b q) : + entryTokens entry a = entryTokens entry b := by + simp only [entryTokens, frameTokens, priorAnswers_congr entry a b agree] + +theorem entryTokens_history (entry : FramedHistory) (answers : Coordinate → Digest32) + (tokens : List CallerToken) (ok : entryTokens entry answers = some tokens) : + tokenHistory entry.domain entry.statement tokens = entry := by + unfold entryTokens at ok + cases h : entry.frames.zipIdx.mapM (fun (f,i) => frameTokens entry answers i f) with + | none => simp [h] at ok + | some frames => + simp only [h] at ok + by_cases hh : tokenHistory entry.domain entry.statement frames.flatten = entry + · have ht : frames.flatten = tokens := by simpa [hh] using ok + simpa [← ht] using hh + · simp [hh] at ok + +def sourceTokens (c : Compression) (iv : Digest32) (entry : FramedHistory) : + Option (List CallerToken) := do + let frames ← entry.frames.zipIdx.mapM (fun (f,i) => sourceFrameTokens c iv entry i f) + let tokens := frames.flatten + if tokenHistory entry.domain entry.statement tokens = entry then some tokens else none + +theorem entryTokens_source (c : Compression) (iv : Digest32) (entry : FramedHistory) + (answers : Coordinate → Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) : + entryTokens entry answers = sourceTokens c iv entry := by + have h := option_mapM_congr entry.frames.zipIdx + (fun (f,i) => frameTokens entry answers i f) + (fun (f,i) => sourceFrameTokens c iv entry i f) (by + intro x hx + exact frameTokens_source c iv entry answers observed x.2 x.1 + (List.mem_zipIdx_iff_getElem?.mp hx)) + simp only [entryTokens, sourceTokens, h] + +abbrev CallerParser := StateT (List CallerToken) Option + +def readScalar : CallerParser E + | .sent x :: rest => some (x,rest) + | _ => none + +def drawScalar : CallerParser E + | .draw x :: rest => some (x,rest) + | _ => none + +def readScalars : Nat → CallerParser (List E) + | 0 => pure [] + | n+1 => do + let x ← readScalar + let xs ← readScalars n + pure (x :: xs) + +def drawScalars : Nat → CallerParser (List E) + | 0 => pure [] + | n+1 => do + let x ← drawScalar + let xs ← drawScalars n + pure (x :: xs) + +theorem readScalars_sent (xs : List E) (rest : List CallerToken) : + readScalars xs.length (xs.map CallerToken.sent ++ rest) = some (xs,rest) := by + induction xs with + | nil => rfl + | cons x xs ih => + change (readScalars xs.length (xs.map CallerToken.sent ++ rest)).bind + (fun (ys,tail) => some (x :: ys,tail)) = _ + rw [ih] + rfl + +theorem drawScalars_draw (xs : List E) (rest : List CallerToken) : + drawScalars xs.length (xs.map CallerToken.draw ++ rest) = some (xs,rest) := by + induction xs with + | nil => rfl + | cons x xs ih => + change (drawScalars xs.length (xs.map CallerToken.draw ++ rest)).bind + (fun (ys,tail) => some (x :: ys,tail)) = _ + rw [ih] + rfl + +def check (ok : Bool) : CallerParser Unit := + if ok then pure () else fun _ => none + +def nonce (bits : Nat) : CallerParser Unit + | .nonce actual _ :: rest => if actual = bits then some ((),rest) else none + | _ => none + +/-- Only layout attributes affecting `Side::decompose`'s claim-producing branch. +Owned table coordinates are never read here. Complex framework coordinates are +invalid in Rust and rejected rather than silently converted to column reads. -/ +inductive BusCoord where + | column (index : Nat) + | publicValue + | tableExpression + deriving DecidableEq, Repr + +structure BusBlock where + kappa : Nat + tableOwned : Bool + coords : List BusCoord + deriving DecidableEq, Repr + +structure BusProducer where + kappa : Nat + bits : Nat + window : Nat + deriving DecidableEq, Repr + +structure BusLayout where + push : List BusBlock + pull : List BusBlock + producers : List BusProducer + grinding : Nat + deriving DecidableEq, Repr + +/-- `BusSetup::new`: each side is stacked independently; producers are push-only. -/ +def BusLayout.mu (l : BusLayout) : Nat := + let push := (l.push.map (fun b => 2^b.kappa)).sum + + (l.producers.map (fun p => p.bits * 2^p.kappa)).sum + let pull := (l.pull.map (fun b => 2^b.kappa)).sum + Nat.log2 (max (max push pull) 1 - 1) + if max push pull ≤ 1 then 0 else 1 + +structure ColumnClaim where + column : Nat + point : List E + value : E + deriving DecidableEq + +/-- Exact radix-four GKR challenge ordering from `gkr::verify_products`. +Coefficients and child values do not enter the returned point. -/ +def gkrPoint (mu : Nat) : CallerParser (List E) := do + let _ ← readScalar + let _ ← drawScalar + let mut point := [] + if mu % 2 = 1 then + let _ ← readScalars 4 + let x ← drawScalar + let _ ← drawScalar + point := [x] + for _ in List.range (mu / 2) do + let rounds ← (List.range point.length).mapM (fun _ => do + let _ ← readScalars 4 + drawScalar) + let _ ← readScalars 8 + let low ← drawScalar + let high ← drawScalar + let _ ← drawScalar + point := low :: high :: rounds + pure point + +/-- The shared `(column,kappa)` cache preserves first occurrence in push/pull, +block, coordinate order. Producer bits and owned tables cause no column reads. -/ +def busClaims (layout : BusLayout) : CallerParser (List E × List ColumnClaim) := do + if layout.grinding > 0 then nonce layout.grinding + let _ ← drawScalars 4 + let _ ← drawScalar + let point ← gkrPoint layout.mu + let mut known : List (Nat × Nat) := [] + let mut claims := [] + for block in layout.push ++ layout.pull do + check (block.kappa ≤ point.length) + if !block.tableOwned then + for coord in block.coords do + match coord with + | .column col => + if (col,block.kappa) ∉ known then + let value ← readScalar + known := known ++ [(col,block.kappa)] + claims := claims ++ [⟨col,point.take block.kappa,value⟩] + | .publicValue => pure () + | .tableExpression => check false + pure (point,claims) + +structure BitField where + column : Nat + width : Nat + deriving DecidableEq, Repr + +structure AirLayout where + tau : Nat + columns : Nat + publicColumns : Nat + fields : List BitField + deriving DecidableEq, Repr + +structure TableClaims where + point : List E + evals : List E + slices : List E + deriving DecidableEq + +/-- `BitColumns::field_of`: field order determines slice offsets. -/ +def fieldOf (column : Nat) : List BitField → Nat → Option (BitField × Nat) + | [], _ => none + | f :: fs, offset => if f.column = column then some (f,offset) + else fieldOf column fs (offset+f.width) + +/-- `BitColumns::combine` uses polynomial-basis words, not E powers of two. -/ +def combineBits (bits : List E) : E := + (bits.zipIdx.map (fun (x,b) => x * E.ofK (UInt64.ofNat (2^b)))).foldl (· + ·) 0 + +def receiveTable (layout : AirLayout) (point : List E) : CallerParser TableClaims := do + check (layout.publicColumns ≤ layout.columns && layout.tau ≤ point.length) + let n := layout.columns - layout.publicColumns + check (layout.fields.all (fun f => f.column < n && f.width ≤ 64)) + check ((layout.fields.map BitField.column).eraseDups.length == layout.fields.length) + let sent ← readScalars (n-layout.fields.length) + let slices ← readScalars ((layout.fields.map BitField.width).sum) + let mut cursor := sent + let mut evals := [] + for c in List.range n do + match fieldOf c layout.fields 0 with + | some (f,start) => + evals := evals ++ [combineBits ((slices.drop start).take f.width)] + | none => + match cursor with + | [] => check false + | x :: xs => evals := evals ++ [x]; cursor := xs + check cursor.isEmpty + pure ⟨point.take layout.tau,evals,slices⟩ + +/-- `constraints::verify` binds high coordinates first and stores them in reverse +round order, then receives each table's ordinary values and bit slices. -/ +def constraintClaims (layouts : List AirLayout) (busPoint : List E) : + CallerParser (List TableClaims) := do + let n := (layouts.map AirLayout.tau).foldl max 0 + check (n ≤ busPoint.length) + let rounds ← (List.range n).mapM (fun _ => do + let _ ← readScalars 3 + drawScalar) + layouts.mapM (fun l => receiveTable l rounds.reverse) + +/-- Direct statement-producing projection of `reduction::verify`. +Its wire reads and sampled coordinates are not supplied by configuration. -/ +def flockClaims (layouts : List FlockLayout) : CallerParser (List RingPCSGame.FamilyClaim) := do + check (!layouts.isEmpty && layouts.all (fun l => 6 ≤ l.kLog && 13 ≤ l.logN)) + let m := (layouts.map FlockLayout.logN).foldl max 0 + let rounds := (layouts.map (fun l => l.kLog-6)).foldl max 0 + let _ ← drawScalars (m-13) + let _ ← drawScalar + let _ ← readScalars 64 + let _ ← drawScalar + let zc ← (List.range (m-6)).mapM (fun _ => do + let _ ← readScalars 2 + drawScalar) + let _ ← readScalars (3*layouts.length) + let _ ← drawScalar + let lc ← (List.range rounds).mapM (fun _ => do + let _ ← readScalars 2 + drawScalar) + layouts.mapM (fun layout => do + let slices ← readScalars 64 + let _ ← readScalar + match assembleFlock layout zc lc slices with + | some claim => pure claim + | none => fun _ => none) + +inductive Placement where + | committed (offset dimension : Nat) + | port (offset slot strideLog : Nat) + | sliced + deriving DecidableEq, Repr + +def placeClaim (p : Placement) (c : ColumnClaim) : Option RingPCSGame.PointClaim := + match p with + | .committed offset _ => some (.point offset c.point.toArray c.value) + | .port offset slot stride => some (.strided offset slot stride c.point.toArray c.value) + | .sliced => none + +def placeClaims (placements : Array Placement) (claims : List ColumnClaim) : + Option (Array RingPCSGame.PointClaim) := do + let located ← claims.mapM (fun c => do + let p ← placements[c.column]? + pure (placeClaim p c)) + pure ((located.filterMap id).toArray) + +def tableColumns (base : Nat) (claims : TableClaims) : List ColumnClaim := + claims.evals.zipIdx.map (fun (x,i) => ⟨base+i,claims.point,x⟩) + +/-- `SliceClaim::zero_padded`, without accepting more than 64 slices. -/ +def paddedRing (offset : Nat) (point slices : List E) : Option RingPCSGame.FamilyClaim := + if slices.length ≤ 64 then some ⟨offset,point.toArray,fun i => slices[i.val]?.getD 0⟩ else none + +structure RecLayout where + bus : BusLayout + tables : List (Nat × AirLayout) + placements : Array Placement + hash : FlockLayout + logInvRate : Nat + +structure CpuTableLayout where + base : Nat + tau : Nat + committedColumns : Nat + settled : Bool + summedColumns : List Nat + summedBits : List BitField + deriving DecidableEq, Repr + +def CpuTableLayout.air (t : CpuTableLayout) : AirLayout := + ⟨t.tau,t.summedColumns.length,0,t.summedBits⟩ + +structure RegisterWord where + offset : Nat + tables : List Nat + deriving DecidableEq, Repr + +structure CpuLayout where + bus : BusLayout + tables : List CpuTableLayout + placements : Array Placement + flock : List FlockLayout + registers : List RegisterWord + finalRegisterColumn : Nat + output : Fin 4 → UInt64 + logInvRate : Nat + +structure CallerClaims where + root : Digest32 + families : List RingPCSGame.FamilyClaim + points : Array RingPCSGame.PointClaim + +def readRoot : CallerParser Digest32 := do + let a ← readScalar + let b ← readScalar + match ByteCodec.scalarsToHash (a,b) with + | some root => pure root + | none => fun _ => none + +@[inline] def recPayload (layout : RecLayout) : + CallerParser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) := do + let (point,bus) ← busClaims layout.bus + let _ ← drawScalar + let tables ← constraintClaims (layout.tables.map Prod.snd) point + let rings ← flockClaims [layout.hash] + let columns := bus ++ ((layout.tables.map Prod.fst).zip tables).flatMap + (fun (base,claims) => tableColumns base claims) + match placeClaims layout.placements columns with + | some points => pure (rings,points) + | none => fun _ => none + +def recClaims (layout : RecLayout) : CallerParser CallerClaims := do + let root ← readRoot + let (rings,points) ← recPayload layout + pure ⟨root,rings,points⟩ + +def settledClaims (tables : List CpuTableLayout) (point : List E) : CallerParser (List TableClaims) := do + let mut claims := [] + for table in tables do + if table.settled then + check (table.summedColumns.all (· < table.committedColumns)) + check (table.summedColumns.eraseDups.length == table.summedColumns.length) + let sent ← readScalars (table.committedColumns-table.summedColumns.length) + let mut remaining := sent + let mut evals := [] + for c in List.range table.committedColumns do + if c ∈ table.summedColumns then evals := evals ++ [0] + else + match remaining with + | [] => check false + | x :: xs => evals := evals ++ [x]; remaining := xs + check (table.tau ≤ point.length && remaining.isEmpty) + claims := claims ++ [⟨point.take table.tau,evals,[]⟩] + pure claims + +def exitClaims (column : Nat) (output : Fin 4 → UInt64) : List ColumnClaim := + let claim := fun reg value => (⟨column, + (List.range 6).map (fun b => if reg.testBit b then 1 else 0),value⟩ : ColumnClaim) + claim 17 (E.ofK 93) :: List.ofFn (fun i : Fin 4 => claim (10+i.val) (E.ofK (output i))) + +def readAnnouncements : List Nat → CallerParser Unit + | [] => pure () + | height :: rest => do + let sent ← readScalar + check (sent == E.ofK (UInt64.ofNat height)) + readAnnouncements rest + +/-- The CPU announcement, clock and commitment are read before bus grinding or +any caller challenge. Shared by the early physical-root and full-token parsers. -/ +def cpuRoot (layout : CpuLayout) : CallerParser Digest32 := do + check (layout.tables.length == 11) + -- `Announcement::read`: dimensions and rate are fixed public family data. + readAnnouncements (layout.tables.map CpuTableLayout.tau ++ [layout.logInvRate]) + let clock ← readScalar + check (clock.c1 == 0 && clock.c2 == 0 && clock.c0.toNat / 2^40 == 1 && clock.c0.toNat % 32 == 0) + readRoot + +@[inline] def cpuPayload (layout : CpuLayout) : + CallerParser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) := do + let (point,bus) ← busClaims layout.bus + let settled ← settledClaims layout.tables point + let _ ← drawScalar + let producerAirs := layout.bus.producers.map (fun p => (⟨p.kappa,2*p.bits,p.bits,[]⟩ : AirLayout)) + let summed ← constraintClaims (layout.tables.map CpuTableLayout.air ++ producerAirs) point + -- `TableClaims::new`: settled tables form the initial table segment. + check (layout.tables.take settled.length |>.all (·.settled)) + check (layout.tables.drop settled.length |>.all (! ·.settled)) + let columns := settled ++ (summed.take layout.tables.length).drop settled.length + let packed ← flockClaims layout.flock + let producers := summed.drop layout.tables.length + let mut rings := packed + for (p,c) in layout.bus.producers.zip producers do + match paddedRing p.window c.point c.evals with + | some ring => rings := rings ++ [ring] + | none => check false + for word in layout.registers do + let some first := word.tables.head? | return ← (fun _ => none) + let some firstClaims := summed[first]? | return ← (fun _ => none) + let mut slices := [] + for t in word.tables do + let some claims := summed[t]? | return ← (fun _ => none) + slices := slices ++ claims.slices + match paddedRing word.offset firstClaims.point slices with + | some ring => rings := rings ++ [ring] + | none => check false + let columnClaims := bus ++ ((layout.tables.map CpuTableLayout.base).zip columns).flatMap + (fun (base,claims) => tableColumns base claims) ++ exitClaims layout.finalRegisterColumn layout.output + match placeClaims layout.placements columnClaims with + | some points => pure (rings,points) + | none => fun _ => none + +def cpuClaims (layout : CpuLayout) : CallerParser CallerClaims := do + let root ← cpuRoot layout + let (rings,points) ← cpuPayload layout + pure ⟨root,rings,points⟩ + +inductive CallerLayout where + | cpu (layout : CpuLayout) + | recursion (layout : RecLayout) + +def callerRoot : CallerLayout → CallerParser Digest32 + | .cpu layout => cpuRoot layout + | .recursion _ => readRoot + +def rootScalarCount : CallerLayout → Nat + | .cpu _ => 15 + | .recursion _ => 2 + +/-- The actual pre-challenge commitment, solely from the initial absorb-zero +frame. CPU contributes twelve public heights/rate scalars, clock and two root +scalars; recursion contributes only the two root scalars. No sampled output, +PoW result, future claim registration or fresh transcript is consulted. -/ +def initialRoot (layout : CallerLayout) (entry : FramedHistory) : Option Digest32 := do + match entry.frames with + | .absorb 0 bytes :: _ => + let values ← WHIRHistory.parseExact (rootScalarCount layout) bytes + let (root,rest) ← callerRoot layout (values.map CallerToken.sent) + if rest.isEmpty then some root else none + | _ => none + +def callerPlacements : CallerLayout → Array Placement + | .cpu l => l.placements + | .recursion l => l.placements + +def callerWords (layout : CallerLayout) : Nat := + (callerPlacements layout).foldl (fun n p => match p with + | .committed _ dimension => n + 2^dimension + | _ => n) 0 + +/-- Exact `witness::placements_of` rounding, including the production floor. -/ +def callerMu (layout : CallerLayout) : Nat := + let words := callerWords layout + max 15 (Nat.log2 (max words 1 - 1) + if words ≤ 1 then 0 else 1) + +def callerLanes (layout : CallerLayout) : Nat := + let laneWords := 2^(callerMu layout - 6) + max 1 ((callerWords layout + laneWords - 1) / laneWords) + +def callerRate : CallerLayout → Nat + | .cpu l => l.logInvRate + | .recursion l => l.logInvRate + +def callerProfile (layout : CallerLayout) : Option Profile := + if hm : 15 ≤ callerMu layout ∧ callerMu layout ≤ 28 then + if hr : 1 ≤ callerRate layout ∧ callerRate layout ≤ 4 then + some (⟨callerMu layout-15,by omega⟩,⟨callerRate layout-1,by omega⟩) + else none + else none + +def openingMatches (profile : Profile) (lanes : Nat) (layout : CallerLayout) : Bool := + lanes == callerLanes layout && profile.1.val+15 == callerMu layout && + profile.2.val+1 == callerRate layout + +theorem callerProfile_matches (layout : CallerLayout) (profile : Profile) + (ok : callerProfile layout = some profile) : + openingMatches profile (callerLanes layout) layout = true := by + unfold callerProfile at ok + split at ok + next hm => + split at ok + next hr => + have hp := Option.some.inj ok + subst profile + simp [openingMatches, Nat.sub_add_cancel hm.1, Nat.sub_add_cancel hr.1] + next => simp at ok + next => simp at ok + +def sourceClaims : CallerLayout → CallerParser CallerClaims + | .cpu layout => cpuClaims layout + | .recursion layout => recClaims layout + +private def reads (n : Nat) : List WHIRCallerShape.EventShape := + List.replicate n (.absorb 24) + +private def draws (n : Nat) : List WHIRCallerShape.EventShape := + List.replicate n (.squeeze 24) + +def gkrShape (mu : Nat) : List WHIRCallerShape.EventShape := + reads 1 ++ draws 1 ++ (if mu % 2 = 1 then reads 4 ++ draws 2 else []) ++ + (List.range (mu/2)).flatMap (fun i => + (List.replicate (mu%2+2*i) (reads 4 ++ draws 1)).flatten ++ reads 8 ++ draws 3) + +def frameworkKeys (layout : BusLayout) : List (Nat × Nat) := + ((layout.push ++ layout.pull).flatMap (fun block => + if block.tableOwned then [] else block.coords.filterMap (fun coord => + match coord with + | .column col => some (col,block.kappa) + | _ => none))).eraseDups + +def busShape (layout : BusLayout) : List WHIRCallerShape.EventShape := + (if layout.grinding > 0 then [.nonce layout.grinding] else []) ++ draws 5 ++ + gkrShape layout.mu ++ reads (frameworkKeys layout).length + +def constraintsShape (layouts : List AirLayout) : List WHIRCallerShape.EventShape := + (List.replicate ((layouts.map AirLayout.tau).foldl max 0) (reads 3 ++ draws 1)).flatten ++ + layouts.flatMap (fun l => reads (l.columns-l.publicColumns-l.fields.length) ++ + reads ((l.fields.map BitField.width).sum)) + +def flockProgramShape (layouts : List FlockLayout) : List WHIRCallerShape.EventShape := + let m := (layouts.map FlockLayout.logN).foldl max 0 + let rounds := (layouts.map (fun l => l.kLog-6)).foldl max 0 + draws (m-13+1) ++ reads 64 ++ draws 1 ++ + (List.replicate (m-6) (reads 2 ++ draws 1)).flatten ++ + reads (3*layouts.length) ++ draws 1 ++ + (List.replicate rounds (reads 2 ++ draws 1)).flatten ++ + layouts.flatMap (fun _ => reads 64 ++ reads 1) + +/-- The actual public CPU/recursion source program's scalar-level operation +shape, not a configurable instruction tape. Adjacent reads remain coalescible +by the checked `WHIRCallerShape` framing model. -/ +def callerShape : CallerLayout → List WHIRCallerShape.EventShape + | .recursion l => reads 2 ++ busShape l.bus ++ draws 1 ++ + constraintsShape (l.tables.map Prod.snd) ++ flockProgramShape [l.hash] + | .cpu l => + let airs := l.tables.map CpuTableLayout.air ++ + l.bus.producers.map (fun p => ⟨p.kappa,2*p.bits,p.bits,[]⟩) + reads (l.tables.length+2) ++ reads 2 ++ busShape l.bus ++ + l.tables.flatMap (fun t => if t.settled then reads (t.committedColumns-t.summedColumns.length) else []) ++ + draws 1 ++ constraintsShape airs ++ flockProgramShape l.flock + +def tokensShape (tokens : List CallerToken) : List WHIRCallerShape.EventShape := + tokens.map (WHIRCallerShape.operationShape ∘ tokenOperation) + +def callerEntryLength (layout : CallerLayout) : Nat := + WHIRCallerShape.entryCount (callerShape layout) + +def callerOutputCap (layout : CallerLayout) : Nat := + WHIRCallerShape.callerOutputCap (callerShape layout) + +/-- Exact source parser, finishing at the stack entry rather than accepting a +prefix and discarding extra caller events. -/ +def interpretCaller (layout : CallerLayout) (tokens : List CallerToken) : Option CallerClaims := do + if tokensShape tokens ≠ callerShape layout then none else do + let (claims,rest) ← sourceClaims layout tokens + if rest.isEmpty then some claims else none + +theorem interpretCaller_shape (layout : CallerLayout) (tokens : List CallerToken) + (claims : CallerClaims) (ok : interpretCaller layout tokens = some claims) : + tokensShape tokens = callerShape layout := by + unfold interpretCaller at ok + by_contra h + simp [h] at ok + +def decodeCaller (layout : CallerLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) : Option CallerClaims := do + let tokens ← entryTokens entry answers + interpretCaller layout tokens + +/-- Concrete source caller interpreter, including its actual preceding physical +streams. No cache resolver or decoder is a parameter of this definition. -/ +def interpretPhysicalCaller (c : Compression) (iv : Digest32) (layout : CallerLayout) + (entry : FramedHistory) : Option CallerClaims := do + let tokens ← sourceTokens c iv entry + interpretCaller layout tokens + +theorem decodeCaller_physical_source (c : Compression) (iv : Digest32) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) : + decodeCaller layout entry answers = interpretPhysicalCaller c iv layout entry := by + simp only [decodeCaller, interpretPhysicalCaller, entryTokens_source c iv entry answers observed] + +theorem decodeCaller_prior_only (layout : CallerLayout) (entry : FramedHistory) + (a b : Coordinate → Digest32) + (agree : ∀ q ∈ callerOutputs entry, a q = b q) : + decodeCaller layout entry a = decodeCaller layout entry b := by + simp only [decodeCaller, entryTokens_prior_only entry a b agree] + +/-- The decoder returns exactly the concrete source interpreter's claims when +its accepted parse reaches this stack entry. No claim-decoder argument occurs. -/ +theorem decodeCaller_source (layout : CallerLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) (tokens : List CallerToken) (claims : CallerClaims) + (trace : entryTokens entry answers = some tokens) + (accepted : interpretCaller layout tokens = some claims) : + decodeCaller layout entry answers = some claims := by + simp [decodeCaller, trace, accepted] + +theorem decodeCaller_public_shape (layout : CallerLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) (claims : CallerClaims) + (ok : decodeCaller layout entry answers = some claims) : + entry.frames.length = WHIRCallerShape.entryCount (callerShape layout) ∧ + callerOutputCount entry.frames = WHIRCallerShape.callerOutputCap (callerShape layout) := by + cases ht : entryTokens entry answers with + | none => simp [decodeCaller, ht] at ok + | some tokens => + have accepted : interpretCaller layout tokens = some claims := by + simpa [decodeCaller, ht] using ok + have hh := entryTokens_history entry answers tokens ht + have hs := interpretCaller_shape layout tokens claims accepted + have hc := WHIRCallerShape.normalized_entry_count entry.domain entry.statement + (tokens.map tokenOperation) + have ho := WHIRCallerShape.normalized_callerOutputCount entry.domain entry.statement + (tokens.map tokenOperation) + change (tokenHistory entry.domain entry.statement tokens).frames.length = _ at hc + change callerOutputCount (tokenHistory entry.domain entry.statement tokens).frames = _ at ho + unfold tokensShape at hs + simp only [List.map_map, hh, hs] at hc ho + exact ⟨hc,ho⟩ + +/-- Commitment metadata is public; original claims are produced by the caller +interpreter above. Oversized claim families reject instead of being truncated. -/ +def decodeRequest (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) : + Option (CausalBindingState.ClaimRequest cap profile) := do + if !openingMatches profile lanes layout then none else do + let claims ← decodeCaller layout entry answers + if hl : lanes ≤ 2 ^ (config profile).folds[0]! then + if hf : claims.families.length ≤ cap then + if hp : claims.points.size + 1 ≤ 2^64 then + some ⟨claims.root,lanes,hl, + ⟨claims.families.length,fun i => claims.families[i],hf,claims.points,hp⟩⟩ + else none + else none + else none + +theorem decodeRequest_prior_only (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (a b : Coordinate → Digest32) + (agree : ∀ q ∈ callerOutputs entry, a q = b q) : + decodeRequest cap profile lanes layout entry a = decodeRequest cap profile lanes layout entry b := by + simp only [decodeRequest, decodeCaller_prior_only layout entry a b agree] + +theorem decodeRequest_actual_outputs (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) + (c : Compression) (iv : Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) : + decodeRequest cap profile lanes layout entry answers = + decodeRequest cap profile lanes layout entry (evalCoordinate c iv) := + decodeRequest_prior_only cap profile lanes layout entry answers (evalCoordinate c iv) observed + +theorem decodeRequest_future_irrelevant (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (a b : Coordinate → Digest32) + (agree : ∀ q, q.history.domain = entry.domain → q.history.statement = entry.statement → + q.history.frames.length < entry.frames.length → + q.history.frames = entry.frames.take q.history.frames.length → a q = b q) : + decodeRequest cap profile lanes layout entry a = decodeRequest cap profile lanes layout entry b := by + apply decodeRequest_prior_only + intro q h + obtain ⟨hd,hs,hlen,hpre⟩ := callerOutputs_strict_prefix entry q h + exact agree q hd hs hlen hpre + +theorem decodeRequest_source (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) + (tokens : List CallerToken) (claims : CallerClaims) + (trace : entryTokens entry answers = some tokens) + (accepted : interpretCaller layout tokens = some claims) + (metadata : openingMatches profile lanes layout = true) + (hl : lanes ≤ 2 ^ (config profile).folds[0]!) + (hf : claims.families.length ≤ cap) (hp : claims.points.size + 1 ≤ 2^64) : + decodeRequest cap profile lanes layout entry answers = + some ⟨claims.root,lanes,hl, + ⟨claims.families.length,fun i => claims.families[i],hf,claims.points,hp⟩⟩ := by + simp [decodeRequest, metadata, + decodeCaller_source layout entry answers tokens claims trace accepted, hl, hf] + omega + +/-- Physical source agreement, without assuming a decoder equation for its +trace or announcing any claims to the decoder. -/ +theorem decodeRequest_physical_source (cap : Nat) (profile : Profile) (lanes : Nat) + (c : Compression) (iv : Digest32) (layout : CallerLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) + (claims : CallerClaims) (accepted : interpretPhysicalCaller c iv layout entry = some claims) + (metadata : openingMatches profile lanes layout = true) + (hl : lanes ≤ 2 ^ (config profile).folds[0]!) + (hf : claims.families.length ≤ cap) (hp : claims.points.size + 1 ≤ 2^64) : + decodeRequest cap profile lanes layout entry answers = + some ⟨claims.root,lanes,hl, + ⟨claims.families.length,fun i => claims.families[i],hf,claims.points,hp⟩⟩ := by + simp [decodeRequest, decodeCaller_physical_source c iv layout entry answers observed, + accepted, metadata, hl, hf] + omega + +def identifiedRequest (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) : + Option (FramedHistory × CausalBindingState.ClaimRequest cap profile) := + (decodeRequest cap profile lanes layout entry answers).map (entry,·) + +theorem identifiedRequest_entry (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry other : FramedHistory) (answers : Coordinate → Digest32) + (request : CausalBindingState.ClaimRequest cap profile) + (ok : identifiedRequest cap profile lanes layout entry answers = some (other,request)) : + entry = other := by + unfold identifiedRequest at ok + cases h : decodeRequest cap profile lanes layout entry answers <;> simp [h] at ok + exact ok.1 + +theorem decodeRequest_public_shape (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) + (request : CausalBindingState.ClaimRequest cap profile) + (ok : decodeRequest cap profile lanes layout entry answers = some request) : + entry.frames.length = callerEntryLength layout ∧ + callerOutputCount entry.frames = callerOutputCap layout := by + cases hc : decodeCaller layout entry answers with + | none => simp [decodeRequest, hc] at ok + | some claims => exact decodeCaller_public_shape layout entry answers claims hc + +theorem decodeRequest_wrong_metadata (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) + (wrong : openingMatches profile lanes layout = false) : + decodeRequest cap profile lanes layout entry answers = none := by + simp [decodeRequest, wrong] + +/-- Raw dependency histories can be incomplete. Such an entry rejects before +any fallback bytes are used. The total-answer endpoint above is for a cache +whose preceding caller outputs have already been proved complete. -/ +def decodeAvailableRequest (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Option Digest32) : + Option (CausalBindingState.ClaimRequest cap profile) := + if (callerOutputs entry).all (fun q => (answers q).isSome) then + decodeRequest cap profile lanes layout entry (fun q => (answers q).getD zeroDigest) + else none + +theorem decodeAvailableRequest_missing (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (q : Coordinate) (prior : q ∈ callerOutputs entry) (missing : answers q = none) : + decodeAvailableRequest cap profile lanes layout entry answers = none := by + cases h : (callerOutputs entry).all (fun q => (answers q).isSome) with + | false => simp [decodeAvailableRequest, h] + | true => + have hq := List.all_eq_true.mp h q prior + simp [missing] at hq + +theorem decodeAvailableRequest_malformed (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (malformed : entryTokens entry (fun q => (answers q).getD zeroDigest) = none) : + decodeAvailableRequest cap profile lanes layout entry answers = none := by + simp [decodeAvailableRequest, decodeRequest, decodeCaller, malformed] + +theorem decodeAvailableRequest_prior_only (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (a b : Coordinate → Option Digest32) + (agree : ∀ q ∈ callerOutputs entry, a q = b q) : + decodeAvailableRequest cap profile lanes layout entry a = + decodeAvailableRequest cap profile lanes layout entry b := by + have complete : (callerOutputs entry).all (fun q => (a q).isSome) = + (callerOutputs entry).all (fun q => (b q).isSome) := by + apply Bool.eq_iff_iff.mpr + simp only [List.all_eq_true] + constructor + · intro h q hq + rw [← agree q hq] + exact h q hq + · intro h q hq + rw [agree q hq] + exact h q hq + have values := decodeRequest_prior_only cap profile lanes layout entry + (fun q => (a q).getD zeroDigest) (fun q => (b q).getD zeroDigest) + (fun q hq => congrArg (fun o => o.getD zeroDigest) (agree q hq)) + simp only [decodeAvailableRequest, complete, values] + +theorem decodeAvailableRequest_physical_source (cap : Nat) (profile : Profile) (lanes : Nat) + (c : Compression) (iv : Digest32) (layout : CallerLayout) (entry : FramedHistory) + (answers : Coordinate → Option Digest32) + (observed : ∀ q ∈ callerOutputs entry, answers q = some (evalCoordinate c iv q)) + (claims : CallerClaims) (accepted : interpretPhysicalCaller c iv layout entry = some claims) + (metadata : openingMatches profile lanes layout = true) + (hl : lanes ≤ 2 ^ (config profile).folds[0]!) + (hf : claims.families.length ≤ cap) (hp : claims.points.size + 1 ≤ 2^64) : + decodeAvailableRequest cap profile lanes layout entry answers = + some ⟨claims.root,lanes,hl, + ⟨claims.families.length,fun i => claims.families[i],hf,claims.points,hp⟩⟩ := by + have available : (callerOutputs entry).all (fun q => (answers q).isSome) = true := + List.all_eq_true.mpr (fun q hq => by rw [observed q hq]; rfl) + simp only [decodeAvailableRequest, available, ↓reduceIte] + exact decodeRequest_physical_source cap profile lanes c iv layout entry + (fun q => (answers q).getD zeroDigest) + (fun q hq => by rw [observed q hq]; rfl) claims accepted metadata hl hf hp + +theorem decodeAvailableRequest_public_shape (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (request : CausalBindingState.ClaimRequest cap profile) + (ok : decodeAvailableRequest cap profile lanes layout entry answers = some request) : + entry.frames.length = callerEntryLength layout ∧ + callerOutputCount entry.frames = callerOutputCap layout := by + unfold decodeAvailableRequest at ok + split at ok + next => + exact decodeRequest_public_shape cap profile lanes layout entry + (fun q => (answers q).getD zeroDigest) request ok + next => simp at ok + + +set_option maxRecDepth 32768 +set_option maxHeartbeats 1000000 + +theorem parser_bind_apply {α β : Type} (p : CallerParser α) (f : α → CallerParser β) + (tokens : List CallerToken) : + (p >>= f) tokens = (p tokens).bind (fun x => f x.1 x.2) := rfl + +theorem parser_bind_inv {α β : Type} (p : CallerParser α) (f : α → CallerParser β) + (tokens rest : List CallerToken) (value : β) + (accepted : (do let x ← p; f x) tokens = some (value,rest)) : + ∃ x middle, p tokens = some (x,middle) ∧ f x middle = some (value,rest) := by + change (p tokens).bind (fun x => f x.1 x.2) = some (value,rest) at accepted + obtain ⟨pair,first,last⟩ := Option.bind_eq_some_iff.mp accepted + exact ⟨pair.1,pair.2,first,last⟩ + +/-- A successful scalar-only parser consumes a fixed number of sent scalars +and can replay that exact prefix before any arbitrary continuation. -/ +def SentPrefix {α : Type} (n : Nat) (parser : CallerParser α) : Prop := + ∀ tokens value rest, parser tokens = some (value,rest) → + ∃ values : List E, values.length = n ∧ tokens = values.map CallerToken.sent ++ rest ∧ + ∀ tail, parser (values.map CallerToken.sent ++ tail) = some (value,tail) + +theorem sentPrefix_pure {α : Type} (value : α) : SentPrefix 0 (pure value) := by + intro tokens result rest accepted + change some (value,tokens) = some (result,rest) at accepted + cases Option.some.inj accepted + exact ⟨[],rfl,rfl,fun _ => rfl⟩ + +theorem sentPrefix_fail {α : Type} (n : Nat) : SentPrefix n (fun _ => (none : Option (α × List CallerToken))) := by + intro tokens value rest accepted + cases accepted + +theorem sentPrefix_bind {α β : Type} (n m : Nat) (p : CallerParser α) (f : α → CallerParser β) + (first : SentPrefix n p) (last : ∀ x, SentPrefix m (f x)) : + SentPrefix (n+m) (do let x ← p; f x) := by + intro tokens result rest accepted + obtain ⟨value,middle,hp,hf⟩ := parser_bind_inv p f tokens rest result accepted + obtain ⟨left,hlen,heq,hreplay⟩ := first tokens value middle hp + obtain ⟨right,rlen,req,rreplay⟩ := last value middle result rest hf + refine ⟨left ++ right,by simp [hlen,rlen],?_,?_⟩ + · simp only [List.map_append,List.append_assoc,← req,← heq] + · intro tail + change (p ((left ++ right).map CallerToken.sent ++ tail)).bind (fun x => f x.1 x.2) = _ + rw [List.map_append,List.append_assoc,hreplay] + exact rreplay tail + +theorem sentPrefix_readScalar : SentPrefix 1 readScalar := by + intro tokens value rest accepted + cases tokens with + | nil => simp [readScalar] at accepted + | cons token tail => + cases token with + | sent x => + simp only [readScalar,Option.some.injEq,Prod.mk.injEq] at accepted + obtain ⟨equal,remaining⟩ := accepted + exact ⟨[value],rfl,by simp [equal,remaining],fun _ => rfl⟩ + | draw => simp [readScalar] at accepted + | nonce => simp [readScalar] at accepted + +theorem sentPrefix_check (ok : Bool) : SentPrefix 0 (check ok) := by + cases ok + · exact sentPrefix_fail 0 + · exact sentPrefix_pure () + +theorem sentPrefix_readRoot : SentPrefix 2 readRoot := by + unfold readRoot + apply sentPrefix_bind 1 1 _ _ sentPrefix_readScalar + intro a + apply sentPrefix_bind 1 0 _ _ sentPrefix_readScalar + intro b + cases ByteCodec.scalarsToHash (a,b) with + | none => exact sentPrefix_fail 0 + | some root => exact sentPrefix_pure root + +theorem sentPrefix_announcements (heights : List Nat) : SentPrefix heights.length (readAnnouncements heights) := by + induction heights with + | nil => exact sentPrefix_pure () + | cons height rest ih => + have after (value : E) : SentPrefix rest.length (do + check (value == E.ofK (UInt64.ofNat height)) + readAnnouncements rest) := by + simpa only [Nat.zero_add] using + sentPrefix_bind 0 rest.length (check (value == E.ofK (UInt64.ofNat height))) _ + (sentPrefix_check _) (fun _ => ih) + simpa only [readAnnouncements,List.length_cons,Nat.add_comm] using + sentPrefix_bind 1 rest.length readScalar _ sentPrefix_readScalar after + +theorem readAnnouncements_loop (heights : List Nat) : readAnnouncements heights = + (do for height in heights do + let sent ← readScalar + check (sent == E.ofK (UInt64.ofNat height)) : CallerParser Unit) := by + induction heights with + | nil => simp [readAnnouncements] + | cons height rest ih => + simp only [readAnnouncements,List.forIn_cons,bind_assoc,pure_bind,ih] + +theorem sentPrefix_cpuRoot (layout : CpuLayout) : + SentPrefix (layout.tables.length+4) (cpuRoot layout) := by + have afterClock (clock : E) : SentPrefix 2 + (do + check (clock.c1 == 0 && clock.c2 == 0 && clock.c0.toNat / 2^40 == 1 && clock.c0.toNat % 32 == 0) + readRoot) := by + exact sentPrefix_bind 0 2 _ _ (sentPrefix_check _) (fun _ => sentPrefix_readRoot) + have clockRoot : SentPrefix 3 (do + let clock ← readScalar + check (clock.c1 == 0 && clock.c2 == 0 && clock.c0.toNat / 2^40 == 1 && clock.c0.toNat % 32 == 0) + readRoot) := + sentPrefix_bind 1 2 _ _ sentPrefix_readScalar afterClock + have announced := sentPrefix_bind + (layout.tables.map CpuTableLayout.tau ++ [layout.logInvRate]).length 3 + (readAnnouncements (layout.tables.map CpuTableLayout.tau ++ [layout.logInvRate])) + (fun _ => do + let clock ← readScalar + check (clock.c1 == 0 && clock.c2 == 0 && clock.c0.toNat / 2^40 == 1 && clock.c0.toNat % 32 == 0) + readRoot) (sentPrefix_announcements _) (fun _ => clockRoot) + have result := sentPrefix_bind 0 _ (check (layout.tables.length == 11)) _ + (sentPrefix_check _) (fun _ => announced) + simpa only [cpuRoot,List.length_append,List.length_map,List.length_cons,List.length_nil, + Nat.zero_add,Nat.add_assoc] using result + +theorem cpuRoot_tables (layout : CpuLayout) (tokens rest : List CallerToken) (root : Digest32) + (accepted : cpuRoot layout tokens = some (root,rest)) : layout.tables.length = 11 := by + by_contra different + simp [cpuRoot,parser_bind_apply,check,different] at accepted + +theorem busClaims_sent (layout : BusLayout) (value : E) (rest : List CallerToken) : + busClaims layout (.sent value :: rest) = none := by + by_cases grinding : 0 < layout.grinding <;> + simp [busClaims,grinding,parser_bind_apply,nonce,drawScalars,drawScalar] + +theorem recPayload_sent (layout : RecLayout) (value : E) (rest : List CallerToken) : + recPayload layout (.sent value :: rest) = none := by + change (busClaims layout.bus (.sent value :: rest)).bind _ = none + rw [busClaims_sent] + rfl + +theorem cpuPayload_sent (layout : CpuLayout) (value : E) (rest : List CallerToken) : + cpuPayload layout (.sent value :: rest) = none := by + change (busClaims layout.bus (.sent value :: rest)).bind _ = none + rw [busClaims_sent] + rfl + +theorem rootedParser_prefix (n : Nat) (header : CallerParser Digest32) + (payload : CallerParser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim)) + (scalarOnly : SentPrefix n header) + (delimiter : ∀ value rest, payload (.sent value :: rest) = none) + (tokens rest : List CallerToken) (claims : CallerClaims) + (accepted : (do + let root ← header + let (rings,points) ← payload + pure (⟨root,rings,points⟩ : CallerClaims)) tokens = some (claims,rest)) : + ∃ (values : List E) (tail : List CallerToken), + values.length = n ∧ tokens = values.map CallerToken.sent ++ tail ∧ + header (values.map CallerToken.sent) = some (claims.root,[]) ∧ + ∀ value rest, tail ≠ .sent value :: rest := by + obtain ⟨root,middle,head,body⟩ := parser_bind_inv _ _ _ _ _ accepted + obtain ⟨pair,remaining,parsed,finished⟩ := parser_bind_inv _ _ _ _ _ body + change some (⟨root,pair.1,pair.2⟩,remaining) = some (claims,rest) at finished + cases Option.some.inj finished + obtain ⟨values,count,hpref,replay⟩ := scalarOnly _ _ _ head + refine ⟨values,middle,count,hpref,?_,?_⟩ + · simpa only [List.append_nil] using replay [] + · intro value rest same + rw [same,delimiter] at parsed + cases parsed + +theorem sourceClaims_initialPrefix (layout : CallerLayout) (tokens rest : List CallerToken) + (claims : CallerClaims) (accepted : sourceClaims layout tokens = some (claims,rest)) : + ∃ (values : List E) (tail : List CallerToken), values.length = rootScalarCount layout ∧ + tokens = values.map CallerToken.sent ++ tail ∧ + callerRoot layout (values.map CallerToken.sent) = some (claims.root,[]) ∧ + ∀ value rest, tail ≠ .sent value :: rest := by + cases layout with + | cpu layout => + obtain ⟨values,tail,count,hpref,header,delimiter⟩ := + rootedParser_prefix _ (cpuRoot layout) (cpuPayload layout) + (sentPrefix_cpuRoot layout) (cpuPayload_sent layout) tokens rest claims accepted + have eleven := cpuRoot_tables layout _ _ _ header + exact ⟨values,tail,by simpa only [rootScalarCount,eleven] using count,hpref,header,delimiter⟩ + | recursion layout => + exact rootedParser_prefix 2 readRoot (recPayload layout) sentPrefix_readRoot + (recPayload_sent layout) tokens rest claims accepted + +theorem modelAbsorb_concat (model : Model) (left right : List Byte) : + modelAbsorb (modelAbsorb model left) right = modelAbsorb model (left ++ right) := by + by_cases hl : left = [] + · simp [hl,modelAbsorb] + · by_cases hr : right = [] + · simp [hr,modelAbsorb] + · simp [modelAbsorb,hl,hr,List.append_assoc] + +theorem run_sent_tokens (model : Model) (values : List E) : + WHIRCallerShape.runOperations model ((values.map CallerToken.sent).map tokenOperation) = + modelAbsorb model (WHIRHistory.scalarBytes values) := by + induction values generalizing model with + | nil => simp [WHIRCallerShape.runOperations,WHIRHistory.scalarBytes,modelAbsorb] + | cons value rest ih => + simp only [List.map_cons,WHIRCallerShape.runOperations,List.foldl_cons, + tokenOperation,WHIRCallerShape.applyOperation] + change WHIRCallerShape.runOperations (modelAbsorb model (WHIRHistory.scalarBytes [value])) + ((rest.map CallerToken.sent).map tokenOperation) = _ + rw [ih,modelAbsorb_concat] + rfl + +theorem runOperations_prepend (frames : List Frame) (model : Model) + (operations : List WHIRCallerShape.Operation) : + WHIRCallerShape.runOperations (WHIRCallerPrefix.prepend frames model) operations = + WHIRCallerPrefix.prepend frames (WHIRCallerShape.runOperations model operations) := by + induction operations generalizing model with + | nil => rfl + | cons operation rest ih => + cases operation <;> + simp only [WHIRCallerShape.runOperations,List.foldl_cons,WHIRCallerShape.applyOperation, + WHIRCallerPrefix.prepend_modelAbsorb,WHIRCallerPrefix.prepend_modelSqueeze, + WHIRCallerPrefix.prepend_modelNonce] <;> exact ih _ + +theorem runOperations_append (model : Model) (left right : List WHIRCallerShape.Operation) : + WHIRCallerShape.runOperations model (left ++ right) = + WHIRCallerShape.runOperations (WHIRCallerShape.runOperations model left) right := by + simp only [WHIRCallerShape.runOperations,List.foldl_append] + +theorem tokenHistory_initialFrame (domain statement : Digest32) (values : List E) + (tail : List CallerToken) (nonempty : values ≠ []) + (delimiter : ∀ value rest, tail ≠ .sent value :: rest) : + (tokenHistory domain statement (values.map CallerToken.sent ++ tail)).frames.head? = + some (.absorb 0 (WHIRHistory.scalarBytes values)) := by + have bytes : WHIRHistory.scalarBytes values ≠ [] := fun empty => + nonempty ((WHIRHistory.scalarBytes_empty _).mp empty) + unfold tokenHistory + rw [List.map_append,runOperations_append,run_sent_tokens] + cases tail with + | nil => simp [WHIRCallerShape.runOperations,WHIRCallerShape.seedModel,modelAbsorb,closeRun,bytes] + | cons token rest => + cases token with + | sent value => exact False.elim (delimiter value rest rfl) + | draw value => + have first : + modelSqueeze (modelAbsorb (WHIRCallerShape.seedModel domain statement) + (WHIRHistory.scalarBytes values)) 24 = + WHIRCallerPrefix.prepend [.absorb 0 (WHIRHistory.scalarBytes values)] + (⟨⟨domain,statement,[]⟩,[],0,24⟩ : Model) := by + simp [WHIRCallerShape.seedModel,modelAbsorb,modelSqueeze,closeRun,bytes,WHIRCallerPrefix.prepend] + change (closeRun (WHIRCallerShape.runOperations + (modelSqueeze (modelAbsorb (WHIRCallerShape.seedModel domain statement) + (WHIRHistory.scalarBytes values)) 24) (rest.map tokenOperation))).history.frames.head? = _ + rw [first,runOperations_prepend,WHIRCallerPrefix.prepend_closeRun] + rfl + | nonce bits value => + have first : + modelNonce (modelAbsorb (WHIRCallerShape.seedModel domain statement) + (WHIRHistory.scalarBytes values)) value bits = + WHIRCallerPrefix.prepend [.absorb 0 (WHIRHistory.scalarBytes values)] + (⟨⟨domain,statement,[.nonce 0 bits value]⟩,[],0,0⟩ : Model) := by + simp [WHIRCallerShape.seedModel,modelAbsorb,modelNonce,closeRun,bytes,WHIRCallerPrefix.prepend] + change (closeRun (WHIRCallerShape.runOperations + (modelNonce (modelAbsorb (WHIRCallerShape.seedModel domain statement) + (WHIRHistory.scalarBytes values)) value bits) (rest.map tokenOperation))).history.frames.head? = _ + rw [first,runOperations_prepend,WHIRCallerPrefix.prepend_closeRun] + rfl + +theorem initialRoot_frame (layout : CallerLayout) (entry : FramedHistory) (values : List E) + (root : Digest32) (count : values.length = rootScalarCount layout) + (first : entry.frames.head? = some (.absorb 0 (WHIRHistory.scalarBytes values))) + (header : callerRoot layout (values.map CallerToken.sent) = some (root,[])) : + initialRoot layout entry = some root := by + cases frames : entry.frames with + | nil => simp [frames] at first + | cons frame rest => + simp only [frames,List.head?_cons,Option.some.injEq] at first + subst frame + simp only [initialRoot,frames,← count,WHIRHistory.parseExact_roundtrip] + dsimp only [Bind.bind,Option.bind] + rw [header] + rfl + +theorem interpretCaller_sourceRun (layout : CallerLayout) (tokens : List CallerToken) + (claims : CallerClaims) (accepted : interpretCaller layout tokens = some claims) : + ∃ rest, sourceClaims layout tokens = some (claims,rest) := by + unfold interpretCaller at accepted + split at accepted + next => simp at accepted + next => + cases run : sourceClaims layout tokens with + | none => simp [run] at accepted + | some pair => + simp only [run] at accepted + dsimp only [Bind.bind,Option.bind] at accepted + split at accepted + next => + have same := Option.some.inj accepted + exact ⟨pair.2,by rw [← same]⟩ + next => simp at accepted + +/-- The original unguarded token source already fixes the root in the initial +physical frame. This is a refinement theorem, not a new acceptance condition. -/ +theorem interpretCaller_initialRoot (layout : CallerLayout) (domain statement : Digest32) + (tokens : List CallerToken) (claims : CallerClaims) + (accepted : interpretCaller layout tokens = some claims) : + initialRoot layout (tokenHistory domain statement tokens) = some claims.root := by + obtain ⟨rest,run⟩ := interpretCaller_sourceRun layout tokens claims accepted + obtain ⟨values,tail,count,hpref,header,delimiter⟩ := + sourceClaims_initialPrefix layout tokens rest claims run + apply initialRoot_frame layout _ values claims.root count + · rw [hpref] + apply tokenHistory_initialFrame domain statement values tail _ delimiter + intro empty + rw [empty] at count + cases layout <;> simp [rootScalarCount] at count + · exact header + +theorem decodeCaller_initialRoot (layout : CallerLayout) (entry : FramedHistory) + (answers : Coordinate → Digest32) (claims : CallerClaims) + (accepted : decodeCaller layout entry answers = some claims) : + initialRoot layout entry = some claims.root := by + cases ht : entryTokens entry answers with + | none => simp [decodeCaller,ht] at accepted + | some tokens => + have source : interpretCaller layout tokens = some claims := by + simpa [decodeCaller,ht] using accepted + have root := interpretCaller_initialRoot layout entry.domain entry.statement tokens claims source + rw [entryTokens_history entry answers tokens ht] at root + exact root + +theorem decodeRequest_initialRoot (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Digest32) + (request : CausalBindingState.ClaimRequest cap profile) + (accepted : decodeRequest cap profile lanes layout entry answers = some request) : + initialRoot layout entry = some request.root := by + cases hc : decodeCaller layout entry answers with + | none => simp [decodeRequest,hc] at accepted + | some claims => + have root := decodeCaller_initialRoot layout entry answers claims hc + unfold decodeRequest at accepted + split at accepted + next => simp at accepted + next => + simp only [hc] at accepted + split at accepted + next => + dsimp only [Bind.bind,Option.bind] at accepted + split at accepted + next => + split at accepted + next => + cases Option.some.inj accepted + exact root + next => simp at accepted + next => simp at accepted + next => simp at accepted + +/-- Any recovered request has precisely the root read before all draws. The +proof uses original source parsing and normalized frame grammar, not a guard. -/ +theorem decodeAvailableRequest_initialRoot (cap : Nat) (profile : Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (request : CausalBindingState.ClaimRequest cap profile) + (accepted : decodeAvailableRequest cap profile lanes layout entry answers = some request) : + initialRoot layout entry = some request.root := by + unfold decodeAvailableRequest at accepted + split at accepted + next => + exact decodeRequest_initialRoot cap profile lanes layout entry + (fun q => (answers q).getD zeroDigest) request accepted + next => simp at accepted + +end Whir.WHIRCallerClaims diff --git a/verification/whir/Whir/WHIRCallerSupport.lean b/verification/whir/Whir/WHIRCallerSupport.lean new file mode 100644 index 000000000..57ffd0724 --- /dev/null +++ b/verification/whir/Whir/WHIRCallerSupport.lean @@ -0,0 +1,910 @@ +import Whir.WHIRCallerGeometry +import Whir.InitialBatching +import Whir.SuccinctRingWeight + +/-! Production witness placement and the support of caller weights. The public +construction follows `witness::stack_offsets` / `placements_of`: committed +columns are sorted largest-first with index tie breaking; ports refer to their +packed committed column rather than occupying a second window. Public layouts +are constructed and checked once, before any transcript is decoded. The final +theorems derive each decoded claim's shape and the batched shape from that +construction; no terminal-support premise or extra native rejection is used. -/ +namespace Whir.WHIRCallerSupport +open Concrete ArrayLayout WHIRCallerClaims RingPCSGame +open scoped BigOperators +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 + +inductive Source where + | committed (dimension : Nat) + | port (column slot strideLog : Nat) + | sliced + deriving DecidableEq, Repr + +structure Window where + column : Nat + offset : Nat + dimension : Nat + deriving DecidableEq, Repr + +/-- The source comparator: decreasing dimension, then increasing source index. -/ +def before (a b : Nat × Nat) : Bool := + a.2 > b.2 || (a.2 == b.2 && a.1 ≤ b.1) + +def committedItems (sources : Array Source) : List (Nat × Nat) := + sources.toList.zipIdx.filterMap fun (s,i) => match s with + | .committed d => some (i,d) + | _ => none + +def sortedItems (sources : Array Source) : List (Nat × Nat) := + (committedItems sources).mergeSort before + +/-- Executable offset loop; only committed columns advance the cursor. -/ +def stackWindows (offset : Nat) : List (Nat × Nat) → List Window + | [] => [] + | (column,dimension) :: rest => + ⟨column,offset,dimension⟩ :: stackWindows (offset + 2^dimension) rest + +def windows (sources : Array Source) : List Window := stackWindows 0 (sortedItems sources) + +def placedWords (sources : Array Source) : Nat := + ((sortedItems sources).map fun p => 2^p.2).sum + +def lookupWindow (sources : Array Source) (column : Nat) : Option Window := + (windows sources).find? (fun w => w.column == column) + +/-- Literal source placement projection; only a committed reference can back a port. -/ +def placement (sources : Array Source) (column : Nat) : Option Placement := do + match ← sources[column]? with + | .committed dimension => + let w ← lookupWindow sources column + pure (.committed w.offset dimension) + | .port packed slot stride => + let w ← lookupWindow sources packed + pure (.port w.offset slot stride) + | .sliced => pure .sliced + +def placementsOf (sources : Array Source) : Option (Array Placement) := + if sources.all (fun s => match s with | .committed d => d < 64 | _ => true) then + (List.range sources.size).toArray.mapM (placement sources) + else none + +/-- The production constructor owns placements; raw caller metadata cannot +choose arbitrary offsets for ordinary or strided column claims. -/ +def installPlacements (ps : Array Placement) : CallerLayout → CallerLayout + | .cpu l => .cpu { l with placements := ps } + | .recursion l => .recursion { l with placements := ps } + +@[simp] theorem callerPlacements_install (ps : Array Placement) (layout : CallerLayout) : + callerPlacements (installPlacements ps layout) = ps := by + cases layout <;> rfl + +/-- Rows addressed by a port are derived from its actual packed dimension. A +stride larger than that dimension is malformed production metadata, not a +condition on a terminal weight. -/ +def columnDimension (sources : Array Source) (column : Nat) : Option Nat := do + match ← sources[column]? with + | .committed d => pure d + | .port packed _ stride => + let w ← lookupWindow sources packed + if stride ≤ w.dimension then pure (w.dimension - stride) else none + | .sliced => pure 0 + +theorem stackWindows_bounds (offset : Nat) (items : List (Nat × Nat)) + (w : Window) (hw : w ∈ stackWindows offset items) : + offset ≤ w.offset ∧ w.offset + 2^w.dimension ≤ + offset + (items.map fun p => 2^p.2).sum := by + induction items generalizing offset with + | nil => simp [stackWindows] at hw + | cons p ps ih => + rcases p with ⟨col,dim⟩ + simp only [stackWindows, List.mem_cons] at hw + rcases hw with rfl | hw + · simp only [List.map_cons, List.sum_cons] + constructor <;> omega + · obtain ⟨lo,hi⟩ := ih (offset + 2^dim) hw + simp only [List.map_cons, List.sum_cons] + constructor + · exact (Nat.le_add_right offset (2^dim)).trans lo + · simpa only [Nat.add_assoc] using hi + +theorem before_trans (a b c : Nat × Nat) (hab : before a b) (hbc : before b c) : + before a c := by + simp only [before,Bool.or_eq_true,Bool.and_eq_true,decide_eq_true_eq,beq_iff_eq] at * + omega + +theorem before_total (a b : Nat × Nat) : before a b || before b a := by + simp only [before,Bool.or_eq_true,Bool.and_eq_true,decide_eq_true_eq,beq_iff_eq] + omega + +theorem sorted_dimensions (sources : Array Source) : + (sortedItems sources).Pairwise (fun a b => b.2 ≤ a.2) := by + have h := List.pairwise_mergeSort before_trans before_total (committedItems sources) + apply h.imp + intro a b hab + simp only [before,Bool.or_eq_true,Bool.and_eq_true,decide_eq_true_eq,beq_iff_eq] at hab + omega + +theorem stackWindows_aligned (items : List (Nat × Nat)) + (sorted : items.Pairwise (fun a b => b.2 ≤ a.2)) (offset : Nat) + (aligned : ∀ p ∈ items, 2^p.2 ∣ offset) (w : Window) + (mem : w ∈ stackWindows offset items) : 2^w.dimension ∣ w.offset := by + induction items generalizing offset with + | nil => simp [stackWindows] at mem + | cons p ps ih => + rcases p with ⟨col,dim⟩ + rw [List.pairwise_cons] at sorted + simp only [stackWindows,List.mem_cons] at mem + rcases mem with rfl | mem + · exact aligned _ List.mem_cons_self + · apply ih sorted.2 (offset + 2^dim) ?_ mem + intro p hp + exact dvd_add (aligned p (List.mem_cons_of_mem _ hp)) + (Nat.pow_dvd_pow 2 (sorted.1 p hp)) + +theorem windows_aligned (sources : Array Source) (w : Window) (mem : w ∈ windows sources) : + 2^w.dimension ∣ w.offset := + stackWindows_aligned (sortedItems sources) (sorted_dimensions sources) 0 + (fun _ _ => dvd_zero _) w mem + +theorem lookupWindow_bounds (sources : Array Source) (column : Nat) (w : Window) + (found : lookupWindow sources column = some w) : + w.offset + 2^w.dimension ≤ placedWords sources := by + have hw : w ∈ windows sources := List.mem_of_find?_eq_some found + simpa [windows, placedWords] using + (stackWindows_bounds 0 (sortedItems sources) w hw).2 + +theorem stackWindows_member (offset : Nat) (items : List (Nat × Nat)) + (w : Window) (hw : w ∈ stackWindows offset items) : + (w.column,w.dimension) ∈ items := by + induction items generalizing offset with + | nil => simp [stackWindows] at hw + | cons p ps ih => + rcases p with ⟨col,dim⟩ + simp only [stackWindows, List.mem_cons] at hw + rcases hw with rfl | hw + · exact List.mem_cons_self + · exact List.mem_cons_of_mem _ (ih _ hw) + +theorem lookupWindow_source (sources : Array Source) (column : Nat) (w : Window) + (found : lookupWindow sources column = some w) : + w.column = column ∧ sources[column]? = some (.committed w.dimension) := by + have hcol : w.column = column := by + simpa using List.find?_some found + have hm := stackWindows_member 0 (sortedItems sources) w + (List.mem_of_find?_eq_some found) + have hm' : (w.column,w.dimension) ∈ committedItems sources := + (List.mergeSort_perm (committedItems sources) before).mem_iff.mp hm + simp only [committedItems, List.mem_filterMap] at hm' + obtain ⟨⟨s,i⟩, hi, hs⟩ := hm' + cases s with + | committed d => + simp only [Option.some.injEq, Prod.mk.injEq] at hs + obtain ⟨rfl,rfl⟩ := hs + exact ⟨hcol, by simpa [hcol] using (List.mk_mem_zipIdx_iff_getElem?.mp hi)⟩ + | port _ _ _ => simp at hs + | sliced => simp at hs + +/-- The exact source placement has no support beyond its committed packed window. -/ +def PlacementExtent (p : Placement) (rows : Nat) (bound : Nat) : Prop := + match p with + | .committed offset dimension => rows ≤ dimension ∧ offset + 2^dimension ≤ bound + | .port offset _ stride => offset + 2^(stride+rows) ≤ bound + | .sliced => True + +/-- The production constructor derives the interval bound, including a port's +stride, from its referenced committed column. -/ +theorem placement_extent (sources : Array Source) (column rows : Nat) (p : Placement) + (placed : placement sources column = some p) + (dimension : columnDimension sources column = some rows) : + PlacementExtent p rows (placedWords sources) := by + unfold placement at placed + unfold columnDimension at dimension + cases hs : sources[column]? with + | none => simp [hs] at placed + | some s => + cases s with + | committed d => + cases hw : lookupWindow sources column with + | none => simp [hs,hw] at placed + | some w => + have hh := (lookupWindow_source sources column w hw).2 + rw [hs] at hh + have hd : d = w.dimension := by simpa using hh + simp [hs,hw] at placed dimension + subst p + subst rows + exact ⟨le_rfl, hd ▸ lookupWindow_bounds sources column w hw⟩ + | port packed slot stride => + cases hw : lookupWindow sources packed with + | none => simp [hs,hw] at placed + | some w => + simp [hs,hw] at placed dimension + obtain ⟨h,hr⟩ := dimension + subst p + subst rows + simpa only [PlacementExtent, Nat.add_sub_of_le h] using + lookupWindow_bounds sources packed w hw + | sliced => + simp [hs] at placed + subst p + trivial + +theorem mapM_some_rel {α β : Type} (f : α → Option β) (xs : List α) (ys : List β) + (ok : xs.mapM f = some ys) : List.Forall₂ (fun x y => f x = some y) xs ys := by + induction xs generalizing ys with + | nil => simpa using ok + | cons x xs ih => + cases hx : f x with + | none => simp [List.mapM_cons,hx] at ok + | some y => + cases hy : xs.mapM f with + | none => simp [List.mapM_cons,hx,hy] at ok + | some zs => + simp [List.mapM_cons,hx,hy] at ok + subst ys + exact .cons hx (ih zs hy) + +theorem placementsOf_rel (sources : Array Source) (ps : Array Placement) + (ok : placementsOf sources = some ps) : + List.Forall₂ (fun i p => placement sources i = some p) (List.range sources.size) ps.toList := by + unfold placementsOf at ok + split at ok <;> try { simp at ok } + rw [Array.mapM_eq_mapM_toList] at ok + cases h : (List.range sources.size).mapM (placement sources) with + | none => simp [h] at ok + | some ys => + simp only [h,Functor.map,Option.map,Option.some.injEq] at ok + subst ps + simpa using mapM_some_rel (placement sources) _ ys h + +theorem placementsOf_get (sources : Array Source) (ps : Array Placement) + (ok : placementsOf sources = some ps) (column : Nat) (p : Placement) + (atColumn : ps[column]? = some p) : placement sources column = some p := by + have rel := placementsOf_rel sources ps ok + have hlen := rel.length_eq + have hp := (Array.getElem?_eq_some_iff.mp atColumn) + have hi : column < sources.size := by simpa using hp.1.trans_eq hlen.symm + have h := rel.get (i := column) (by simpa using hi) (by simpa using hp.1) + simpa [getElem!_pos, List.getElem_range, hp.2] using h + +def sourceWords : Source → Nat + | .committed d => 2^d + | _ => 0 + +def placementWords : Placement → Nat + | .committed _ d => 2^d + | _ => 0 + +theorem placedWords_eq (sources : Array Source) : + placedWords sources = (sources.toList.map sourceWords).sum := by + unfold placedWords sortedItems + rw [((List.mergeSort_perm (committedItems sources) before).map + (fun p => 2^p.2)).sum_eq] + suffices ∀ (xs : List Source) (start : Nat), + (((xs.zipIdx start).filterMap (fun (s,i) => match s with + | .committed d => some (i,d) + | _ => none)).map (fun p => 2^p.2)).sum = (xs.map sourceWords).sum by + exact this sources.toList 0 + intro xs + induction xs with + | nil => simp + | cons s xs ih => + intro start + cases s <;> simp [ih,sourceWords] + +theorem placement_words (sources : Array Source) (i : Nat) (p : Placement) + (ok : placement sources i = some p) : + some (placementWords p) = (sources[i]?).map sourceWords := by + unfold placement at ok + cases hs : sources[i]? with + | none => simp [hs] at ok + | some s => + cases s with + | committed d => + cases hw : lookupWindow sources i with + | none => simp [hs,hw] at ok + | some w => + simp [hs,hw] at ok + subst p + simp [placementWords,sourceWords] + | port col slot stride => + cases hw : lookupWindow sources col with + | none => simp [hs,hw] at ok + | some w => + simp [hs,hw] at ok + subst p + simp [placementWords,sourceWords] + | sliced => + simp [hs] at ok + subst p + simp [placementWords,sourceWords] + +theorem placementsOf_words (sources : Array Source) (ps : Array Placement) + (ok : placementsOf sources = some ps) : + (ps.toList.map placementWords).sum = placedWords sources := by + rw [placedWords_eq] + have hlen := (placementsOf_rel sources ps ok).length_eq + have he : ps.toList.map placementWords = sources.toList.map sourceWords := by + apply List.ext_getElem + · simpa using hlen.symm + · intro i hi hj + have hip : i < ps.size := by simpa using hi + have his : i < sources.size := by simpa using hj + have h := placement_words sources i ps[i] + (placementsOf_get sources ps ok i ps[i] (by simp [hip])) + simpa [his] using h + rw [he] + +theorem callerWords_placementsOf (sources : Array Source) (layout : CallerLayout) + (ok : placementsOf sources = some (callerPlacements layout)) : + callerWords layout = placedWords sources := by + rw [callerWords, ← Array.foldl_toList] + have he : + (callerPlacements layout).toList.foldl (fun n p => match p with + | .committed _ d => n + 2^d + | _ => n) 0 = + (callerPlacements layout).toList.foldl (fun n p => n + placementWords p) 0 := by + congr 1 + funext n p + cases p <;> simp [placementWords] + trans (callerPlacements layout).toList.foldl (fun n p => n + placementWords p) 0 + · convert he using 1 + rw [← List.foldl_map, ← List.sum_eq_foldl] + exact placementsOf_words sources (callerPlacements layout) ok + +/-- Production rounds occupied columns to a whole lane, with at least one lane. -/ +theorem callerWords_le_occupied (layout : CallerLayout) : + callerWords layout ≤ callerLanes layout * 2^(callerMu layout - 6) := by + let block := 2^(callerMu layout-6) + have hb : 0 < block := by positivity + have h : callerWords layout ≤ ((callerWords layout + block - 1) / block) * block := by + have hr := Nat.mod_lt (callerWords layout + block - 1) hb + have he := Nat.mod_add_div (callerWords layout + block - 1) block + rw [Nat.mul_comm block] at he + omega + exact h.trans (Nat.mul_le_mul_right block (Nat.le_max_right 1 _)) + +/-- Production ports are positions within one packed circuit instance. This +public source-schema condition is separate from any verifier acceptance guard. -/ +def portSlotFits (sources : Array Source) (column : Nat) : Bool := + match sources[column]? with + | some (.port _ slot stride) => slot < 2^stride + | _ => true + +/-- A column incidence check against production source dimensions. Sliced +columns emit no point claim and therefore impose no point-dimension condition. -/ +def columnFits (sources : Array Source) (column rows : Nat) : Bool := + portSlotFits sources column && + match sources[column]? with + | some .sliced => true + | _ => match columnDimension sources column with + | some dimension => rows ≤ dimension + | none => false + +/-- Family metadata must name a window actually emitted by the placement +constructor, not merely an arbitrary interval below a numeric bound. -/ +def ringFits (sources : Array Source) (offset rows : Nat) : Bool := + (windows sources).any (fun w => w.offset == offset && rows ≤ w.dimension) + +theorem columnFits_mono (sources : Array Source) (column small large : Nat) + (h : small ≤ large) (fits : columnFits sources column large = true) : + columnFits sources column small = true := by + unfold columnFits at * + simp only [Bool.and_eq_true] at fits ⊢ + obtain ⟨slot,fits⟩ := fits + refine ⟨slot,?_⟩ + split at fits <;> simp_all + split at fits <;> simp_all + omega + +theorem ringFits_mono (sources : Array Source) (offset small large : Nat) + (h : small ≤ large) (fits : ringFits sources offset large = true) : + ringFits sources offset small = true := by + simp only [ringFits, List.any_eq_true, Bool.and_eq_true, beq_iff_eq, + decide_eq_true_eq] at * + obtain ⟨w,hw,ho,hd⟩ := fits + exact ⟨w,hw,ho,h.trans hd⟩ + +theorem ringFits_bound (sources : Array Source) (offset rows : Nat) + (fits : ringFits sources offset rows = true) : + offset + 2^rows ≤ placedWords sources := by + simp only [ringFits,List.any_eq_true,Bool.and_eq_true,beq_iff_eq, + decide_eq_true_eq] at fits + obtain ⟨w,hw,rfl,hd⟩ := fits + have hb := (stackWindows_bounds 0 (sortedItems sources) w hw).2 + have hp : 2^rows ≤ 2^w.dimension := Nat.pow_le_pow_right (by decide) hd + simp only [Nat.zero_add] at hb + change w.offset + 2^w.dimension ≤ placedWords sources at hb + omega + +theorem window_nativeShape (sources : Array Source) (w : Window) + (mem : w ∈ windows sources) (n rows : Nat) (dimension : rows ≤ w.dimension) + (bound : placedWords sources ≤ 2^n) : + rows ≤ n ∧ w.offset % 2^rows = 0 ∧ w.offset + 2^rows ≤ 2^n := by + have hi := (stackWindows_bounds 0 (sortedItems sources) w mem).2 + have hp : 2^rows ≤ 2^w.dimension := Nat.pow_le_pow_right (by decide) dimension + have hb : w.offset + 2^rows ≤ 2^n := by + change w.offset + 2^w.dimension ≤ 0 + placedWords sources at hi + omega + refine ⟨(Nat.pow_le_pow_iff_right (by decide : 1 < 2)).mp (by omega), ?_, hb⟩ + exact Nat.mod_eq_zero_of_dvd ((Nat.pow_dvd_pow 2 dimension).trans (windows_aligned sources w mem)) + +theorem ringFits_nativeShape (sources : Array Source) (offset rows n : Nat) + (fits : ringFits sources offset rows = true) (bound : placedWords sources ≤ 2^n) : + rows ≤ n ∧ offset % 2^rows = 0 ∧ offset + 2^rows ≤ 2^n := by + simp only [ringFits,List.any_eq_true,Bool.and_eq_true,beq_iff_eq,decide_eq_true_eq] at fits + obtain ⟨w,hw,rfl,hd⟩ := fits + exact window_nativeShape sources w hw n rows hd bound + +theorem production_point_nativeShape (sources : Array Source) (ps : Array Placement) + (built : placementsOf sources = some ps) (c : ColumnClaim) (p : Placement) + (atColumn : ps[c.column]? = some p) + (fits : columnFits sources c.column c.point.length = true) + (claim : PointClaim) (placed : placeClaim p c = some claim) + (n : Nat) (bound : placedWords sources ≤ 2^n) : + SuccinctPointWeight.Shape n claim := by + have hp := placementsOf_get sources ps built c.column p atColumn + unfold placement at hp + cases hs : sources[c.column]? with + | none => simp [hs] at hp + | some source => + cases source with + | committed d => + cases hw : lookupWindow sources c.column with + | none => simp [hs,hw] at hp + | some w => + have hh := (lookupWindow_source sources c.column w hw).2 + rw [hs] at hh + have hd : d = w.dimension := by simpa using hh + have hl : c.point.length ≤ w.dimension := by + simpa [columnFits,portSlotFits,columnDimension,hs,hd] using fits + simp [hs,hw] at hp + subst p + simp only [placeClaim,Option.some.injEq] at placed + subst claim + simpa only [SuccinctPointWeight.Shape,List.size_toArray] using + window_nativeShape sources w (List.mem_of_find?_eq_some hw) n c.point.length hl bound + | port packed slot stride => + cases hw : lookupWindow sources packed with + | none => simp [hs,hw] at hp + | some w => + by_cases hd : stride ≤ w.dimension + · have hf : slot < 2^stride ∧ c.point.length ≤ w.dimension - stride := by + simpa [columnFits,portSlotFits,columnDimension,hs,hw,hd] using fits + have hl : stride + c.point.length ≤ w.dimension := by omega + have hshape := window_nativeShape sources w (List.mem_of_find?_eq_some hw) + n (stride + c.point.length) hl bound + simp [hs,hw] at hp + subst p + simp only [placeClaim,Option.some.injEq] at placed + subst claim + exact ⟨hshape.1,hshape.2.1,hshape.2.2,hf.1⟩ + · simp [columnFits,portSlotFits,columnDimension,hs,hw,hd] at fits + | sliced => + simp [hs] at hp + subst p + simp [placeClaim] at placed + +/-- Geometric support of plain and strided source claims, including short points. -/ +theorem placeClaim_support (p : Placement) (c : ColumnClaim) (rows bound : Nat) + (extent : PlacementExtent p rows bound) (length : c.point.length ≤ rows) + (claim : PointClaim) (placed : placeClaim p c = some claim) + (v : Nat) (hv : bound ≤ v) : pointWeight claim v = 0 := by + cases p with + | committed offset dimension => + simp only [placeClaim, Option.some.injEq] at placed + subst claim + change rows ≤ dimension ∧ offset + 2^dimension ≤ bound at extent + have hpow : 2^c.point.length ≤ 2^dimension := + Nat.pow_le_pow_right (by decide) (length.trans extent.1) + simp only [pointWeight, regionWeight, List.size_toArray] + split_ifs with h + · omega + · rfl + | port offset slot stride => + simp only [placeClaim, Option.some.injEq] at placed + subst claim + have hpow : 2^(stride+c.point.length) ≤ 2^(stride+rows) := + Nat.pow_le_pow_right (by decide) (Nat.add_le_add_left length stride) + simp only [pointWeight, List.size_toArray] + split_ifs with h + · change offset + 2^(stride+rows) ≤ bound at extent + omega + · rfl + | sliced => simp [placeClaim] at placed +/-- Concrete source placement provenance suffices; there is no supplied +point-weight correctness or support premise. -/ +theorem production_point_support (sources : Array Source) (ps : Array Placement) + (built : placementsOf sources = some ps) (c : ColumnClaim) (p : Placement) + (atColumn : ps[c.column]? = some p) + (fits : columnFits sources c.column c.point.length = true) + (claim : PointClaim) (placed : placeClaim p c = some claim) + (v : Nat) (hv : placedWords sources ≤ v) : pointWeight claim v = 0 := by + have hp := placementsOf_get sources ps built c.column p atColumn + by_cases hs : sources[c.column]? = some .sliced + · simp [placement,hs] at hp + subst p + simp [placeClaim] at placed + · have hf : ∃ rows, columnDimension sources c.column = some rows ∧ c.point.length ≤ rows := by + have hrows : (match columnDimension sources c.column with + | some rows => decide (c.point.length ≤ rows) + | none => false) = true := by + unfold columnFits at fits + simp only [Bool.and_eq_true] at fits + have rowFits := fits.2 + cases hsource : sources[c.column]? with + | none => simpa only [hsource] using rowFits + | some source => + cases source with + | committed _ => simpa only [hsource] using rowFits + | port _ _ _ => simpa only [hsource] using rowFits + | sliced => exact False.elim (hs hsource) + cases hd : columnDimension sources c.column with + | none => simp [hd] at hrows + | some rows => exact ⟨rows,rfl,by simpa [hd] using hrows⟩ + obtain ⟨rows,hd,hl⟩ := hf + exact placeClaim_support p c rows (placedWords sources) + (placement_extent sources c.column rows p hp hd) hl claim placed v hv + + +/-- Ring switching preserves literal support: its Frobenius map sends zero to +zero, regardless of slices, gamma, or the six ring-switch challenges. -/ +theorem family_support {m : Nat} (family : Fin m → FamilyClaim) + (r : RingPCSGame.Prefix) (bound : Nat) + (fits : ∀ j, (family j).offset + 2^(family j).point.size ≤ bound) + (v : Nat) (hv : bound ≤ v) : transparentWeight family r v = 0 := by + apply Finset.sum_eq_zero + intro j _ + have hf : ¬ ((family j).offset ≤ v ∧ + v < (family j).offset + 2^(family j).point.size) := by + have := fits j + omega + simp [regionWeight, hf] + +theorem transformed_claim_size {m : Nat} (width : Nat) + (family : Fin m → FamilyClaim) (points : Array PointClaim) (r : RingPCSGame.Prefix) + (claim : CausalGame.Claim) (mem : claim ∈ (transformedClaims width family points r).toList) : + claim.weight.size = width := by + simp only [transformedClaims,Array.toList_append,Array.toList_map] at mem + change claim ∈ [familyPublic width family r] ++ points.toList.map (publicPoint width) at mem + simp only [List.mem_append,List.mem_singleton,List.mem_map] at mem + rcases mem with rfl | ⟨p,hp,rfl⟩ <;> simp [familyPublic,publicPoint] + +theorem transformed_claim_support {m : Nat} (width bound : Nat) + (family : Fin m → FamilyClaim) (points : Array PointClaim) (r : RingPCSGame.Prefix) + (families : ∀ j, (family j).offset + 2^(family j).point.size ≤ bound) + (pointSupport : ∀ p ∈ points.toList, ∀ v, bound ≤ v → pointWeight p v = 0) + (claim : CausalGame.Claim) (mem : claim ∈ (transformedClaims width family points r).toList) + (v : Nat) (hv : bound ≤ v) (hwidth : v < width) : claim.weight[v]! = 0 := by + simp only [transformedClaims,Array.toList_append,Array.toList_map] at mem + change claim ∈ [familyPublic width family r] ++ points.toList.map (publicPoint width) at mem + simp only [List.mem_append,List.mem_singleton,List.mem_map] at mem + rcases mem with rfl | ⟨p,hp,rfl⟩ + · simpa [familyPublic,getElem!_tab _ _ _ hwidth] using family_support family r bound families v hv + · simpa [publicPoint,getElem!_tab _ _ _ hwidth] using pointSupport p hp v hv + +/-- The actual transformed array and actual lambda batching retain the proven +occupied-word support; no terminal evaluator identity is assumed. -/ +theorem transformed_batch_support {m : Nat} (width bound : Nat) + (family : Fin m → FamilyClaim) (points : Array PointClaim) + (r : RingPCSGame.Prefix) (lambda : E) + (families : ∀ j, (family j).offset + 2^(family j).point.size ≤ bound) + (pointSupport : ∀ p ∈ points.toList, ∀ v, bound ≤ v → pointWeight p v = 0) : + ∀ v, bound ≤ v → v < width → + (CausalGame.batchClaims width (transformedClaims width family points r) lambda).weight[v]! = 0 := by + apply InitialBatching.batchClaims_zero_tail + intro j v hv hwidth + exact transformed_claim_support width bound family points r families pointSupport + _ (by simp) v hv hwidth + +/-- These are finite facts about the production configuration constructor. -/ +theorem config_initial_geometry : ∀ p : ParameterBounds.Profile, + (ParameterBounds.config p).logN = p.1.val + 15 ∧ + (ParameterBounds.config p).folds[0]! = 6 := by + decide +kernel + +theorem openingMatches_occupied (layout : CallerLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes layout = true) : + callerWords layout ≤ lanes * + 2^((ParameterBounds.config p).logN - (ParameterBounds.config p).folds[0]!) := by + simp only [openingMatches, Bool.and_eq_true, beq_iff_eq] at metadata + rw [(config_initial_geometry p).1, (config_initial_geometry p).2, + metadata.1.1, metadata.1.2] + exact callerWords_le_occupied layout + +theorem openingMatches_positive (layout : CallerLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes layout = true) : 0 < lanes := by + simp only [openingMatches,Bool.and_eq_true,beq_iff_eq] at metadata + rw [metadata.1.1] + exact lt_of_lt_of_le (by decide : 0 < 1) (Nat.le_max_left 1 _) + +theorem shapeValid_of_support (c : Protocol.Config) (lanes : Nat) (b : Array E) + (valid : c.valid = true) (positive : 0 < lanes) (laneBound : lanes ≤ 2^c.folds[0]!) + (size : b.size = 2^c.logN) + (support : ∀ i, lanes * 2^(c.logN-c.folds[0]!) ≤ i → i < b.size → b[i]! = 0) : + Protocol.shapeValid c lanes b = true := by + simp only [Protocol.shapeValid,valid,positive,laneBound,size,Bool.true_and, + decide_true,beq_self_eq_true] + apply Array.all_eq_true.mpr + intro i hi + simp only [beq_iff_eq] + rw [Array.getElem_extract] + have hbound : lanes * 2^(c.logN-c.folds[0]!) + i < b.size := by + simp only [Array.size_extract] at hi + omega + have h := support (lanes * 2^(c.logN-c.folds[0]!) + i) (by omega) hbound + rw [_root_.getElem!_pos b _ hbound] at h + exact h + +/-- A decoded request is traced back to the unchanged concrete caller parser, +not to an externally supplied list of claims. -/ +theorem decodeCaller_source_run (layout : CallerLayout) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (accepted : decodeCaller layout entry answers = some claims) : + ∃ tokens rest, sourceClaims layout tokens = some (claims,rest) := by + cases ht : entryTokens entry answers with + | none => simp [decodeCaller,ht] at accepted + | some tokens => + have hi : interpretCaller layout tokens = some claims := by + simpa [decodeCaller,ht] using accepted + unfold interpretCaller at hi + split at hi + next h => simp at hi + next h => + cases hs : sourceClaims layout tokens with + | none => simp [hs] at hi + | some result => + rcases result with ⟨actual,rest⟩ + simp only [hs,bind,Option.bind] at hi + split at hi + next empty => + have he : actual = claims := by simpa using hi + subst actual + exact ⟨tokens,rest,hs⟩ + next nonempty => simp at hi + +/-- Public production metadata, with offsets generated rather than trusted. +The geometry field checks finite source incidences/dimensions only. -/ +structure ProductionLayout where + sources : Array Source + layout : CallerLayout + constructed : placementsOf sources = some (callerPlacements layout) + geometry : WHIRCallerGeometry.LayoutGeometry + (fun i d => columnFits sources i d = true) + (fun o d => ringFits sources o d = true) layout + +/-- Checked public constructor. This is not a verifier acceptance test: the +result is the fixed caller layout used to configure the source decoder. -/ +def productionLayout (sources : Array Source) (raw : CallerLayout) : Option ProductionLayout := + match h : placementsOf sources with + | none => none + | some ps => + let layout := installPlacements ps raw + if geometry : WHIRCallerGeometry.LayoutGeometry + (fun i d => columnFits sources i d = true) + (fun o d => ringFits sources o d = true) layout then + some ⟨sources,layout,by simpa [layout] using h,geometry⟩ + else none + +/-- The parser theorem is instantiated with the actual production sources. -/ +theorem decoded_geometry (model : ProductionLayout) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (accepted : decodeCaller model.layout entry answers = some claims) : + WHIRCallerGeometry.ClaimsValid + (fun i d => columnFits model.sources i d = true) + (fun o d => ringFits model.sources o d = true) (callerPlacements model.layout) claims := by + obtain ⟨tokens,rest,trace⟩ := decodeCaller_source_run model.layout entry answers claims accepted + exact WHIRCallerGeometry.sourceClaims_geometry _ _ + (columnFits_mono model.sources) (ringFits_mono model.sources) + model.layout model.geometry tokens claims rest trace + +/-- Support of every actual decoded family/plain/strided claim is a consequence +of production placement and parser provenance, not a decoder-correctness axiom. -/ +theorem decoded_support (model : ProductionLayout) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (accepted : decodeCaller model.layout entry answers = some claims) : + (∀ ring ∈ claims.families, + ring.offset + 2^ring.point.size ≤ callerWords model.layout) ∧ + (∀ point ∈ claims.points.toList, ∀ v, callerWords model.layout ≤ v → + pointWeight point v = 0) := by + obtain ⟨rings,points⟩ := decoded_geometry model entry answers claims accepted + rw [callerWords_placementsOf model.sources model.layout model.constructed] + constructor + · intro ring mem + exact ringFits_bound model.sources ring.offset ring.point.size (rings ring mem) + · intro point mem v hv + obtain ⟨column,placed,atColumn,claimed,fits⟩ := points point mem + exact production_point_support model.sources (callerPlacements model.layout) + model.constructed column placed atColumn fits point claimed v hv + +/-- Each original transformed claim passes the actual causal experiment's +shape check, including the unencoded lane tail. -/ +theorem decoded_claim_shape (model : ProductionLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (accepted : decodeCaller model.layout entry answers = some claims) (r : RingPCSGame.Prefix) + (claim : CausalGame.Claim) + (mem : claim ∈ (transformedClaims (2^(ParameterBounds.config p).logN) + (fun i : Fin claims.families.length => claims.families[i]) claims.points r).toList) : + Protocol.shapeValid (ParameterBounds.config p) lanes claim.weight = true := by + obtain ⟨rings,points⟩ := decoded_support model entry answers claims accepted + have occupied := openingMatches_occupied model.layout p lanes metadata + have hs := transformed_claim_size _ _ _ _ claim mem + apply shapeValid_of_support _ _ _ (ParameterBounds.production_config_valid p).1 + (openingMatches_positive model.layout p lanes metadata) laneBound hs + intro v hv hi + rw [hs] at hi + exact transformed_claim_support _ (callerWords model.layout) _ _ r + (fun j => rings _ (by simp)) points claim mem v (occupied.trans hv) hi + +/-- The actual initial lambda batch has the physical verifier's required shape, +with no `tailZero` or `regionsFit` hypothesis. -/ +theorem decoded_batch_shape (model : ProductionLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (accepted : decodeCaller model.layout entry answers = some claims) + (r : RingPCSGame.Prefix) (lambda : E) : + Protocol.shapeValid (ParameterBounds.config p) lanes + (CausalGame.batchClaims (2^(ParameterBounds.config p).logN) + (transformedClaims (2^(ParameterBounds.config p).logN) + (fun i : Fin claims.families.length => claims.families[i]) claims.points r) lambda).weight = true := by + obtain ⟨rings,points⟩ := decoded_support model entry answers claims accepted + have occupied := openingMatches_occupied model.layout p lanes metadata + apply shapeValid_of_support _ _ _ (ParameterBounds.production_config_valid p).1 + (openingMatches_positive model.layout p lanes metadata) laneBound (InitialBatching.batchClaims_size _ _ _) + intro v hv hi + rw [InitialBatching.batchClaims_size] at hi + exact transformed_batch_support _ (callerWords model.layout) _ _ r lambda + (fun j => rings _ (by simp)) points v (occupied.trans hv) hi + +/-- Successful source request decoding supplies all metadata guards. The +occupied-tail obligation is derived from the production construction above. -/ +theorem decodeRequest_shapes (model : ProductionLayout) (cap : Nat) + (p : ParameterBounds.Profile) (lanes : Nat) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) + (request : CausalBindingState.ClaimRequest cap p) + (accepted : decodeRequest cap p lanes model.layout entry answers = some request) + (r : RingPCSGame.Prefix) (lambda : E) : + let claims := transformedClaims (2^(ParameterBounds.config p).logN) + request.claims.family request.claims.points r + (claims.all (fun claim => Protocol.shapeValid (ParameterBounds.config p) request.lanes claim.weight) = true) ∧ + Protocol.shapeValid (ParameterBounds.config p) request.lanes + (CausalGame.batchClaims (2^(ParameterBounds.config p).logN) claims lambda).weight = true := by + unfold decodeRequest at accepted + split at accepted + next rejected => simp at accepted + next allowed => + have metadata : openingMatches p lanes model.layout = true := by simpa using allowed + cases hc : decodeCaller model.layout entry answers with + | none => simp [hc] at accepted + | some claims => + simp only [hc,bind,Option.bind] at accepted + split at accepted + next laneBound => + split at accepted + next familyBound => + split at accepted + next claimBound => + have he := Option.some.inj accepted + subst request + constructor + · apply Array.all_eq_true'.mpr + intro claim mem + exact decoded_claim_shape model p lanes metadata laneBound entry answers claims hc r claim + (by simpa using mem) + · exact decoded_batch_shape model p lanes metadata laneBound entry answers claims hc r lambda + next tooMany => simp at accepted + next tooMany => simp at accepted + next tooMany => simp at accepted + +/-- The physical partial-cache decoder uses the same constructed-layout shape +theorem; cache availability neither supplies nor assumes support. -/ +theorem decodeAvailableRequest_shapes (model : ProductionLayout) (cap : Nat) + (p : ParameterBounds.Profile) (lanes : Nat) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → Option FiatShamirGame.Digest32) + (request : CausalBindingState.ClaimRequest cap p) + (accepted : decodeAvailableRequest cap p lanes model.layout entry answers = some request) + (r : RingPCSGame.Prefix) (lambda : E) : + let claims := transformedClaims (2^(ParameterBounds.config p).logN) + request.claims.family request.claims.points r + (claims.all (fun claim => Protocol.shapeValid (ParameterBounds.config p) request.lanes claim.weight) = true) ∧ + Protocol.shapeValid (ParameterBounds.config p) request.lanes + (CausalGame.batchClaims (2^(ParameterBounds.config p).logN) claims lambda).weight = true := by + unfold decodeAvailableRequest at accepted + split at accepted + next present => + exact decodeRequest_shapes model cap p lanes entry _ request accepted r lambda + next missing => simp at accepted + +theorem openingMatches_words_bound (layout : CallerLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) : + callerWords layout ≤ 2^(ParameterBounds.config p).logN := by + have occupied := openingMatches_occupied layout p lanes metadata + have hn : (ParameterBounds.config p).folds[0]! ≤ (ParameterBounds.config p).logN := by + rw [(config_initial_geometry p).1,(config_initial_geometry p).2] + omega + have hb := Nat.mul_le_mul_right + (2^((ParameterBounds.config p).logN-(ParameterBounds.config p).folds[0]!)) laneBound + rw [← Nat.pow_add, Nat.add_sub_of_le hn] at hb + exact occupied.trans hb + +/-- Every source-decoded selector has the dimension, alignment, cube range, +and port-slot bounds needed by the native caller-weight equality. -/ +theorem decoded_nativeShapes (model : ProductionLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (accepted : decodeCaller model.layout entry answers = some claims) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN + (fun i : Fin claims.families.length => claims.families[i]) ∧ + (∀ point ∈ claims.points.toList, SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by + obtain ⟨rings,points⟩ := decoded_geometry model entry answers claims accepted + have bound : placedWords model.sources ≤ 2^(ParameterBounds.config p).logN := by + rw [← callerWords_placementsOf model.sources model.layout model.constructed] + exact openingMatches_words_bound model.layout p lanes metadata laneBound + constructor + · intro j + exact ringFits_nativeShape model.sources _ _ _ (rings _ (by simp)) bound + · intro point mem + obtain ⟨column,placed,atColumn,claimed,fits⟩ := points point mem + exact production_point_nativeShape model.sources (callerPlacements model.layout) + model.constructed column placed atColumn fits point claimed _ bound + +theorem decodeRequest_nativeShapes (model : ProductionLayout) (cap : Nat) + (p : ParameterBounds.Profile) (lanes : Nat) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) + (request : CausalBindingState.ClaimRequest cap p) + (accepted : decodeRequest cap p lanes model.layout entry answers = some request) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN request.claims.family ∧ + (∀ point ∈ request.claims.points.toList, + SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by + unfold decodeRequest at accepted + split at accepted + next rejected => simp at accepted + next allowed => + have metadata : openingMatches p lanes model.layout = true := by simpa using allowed + cases hc : decodeCaller model.layout entry answers with + | none => simp [hc] at accepted + | some claims => + simp only [hc,bind,Option.bind] at accepted + split at accepted + next laneBound => + split at accepted + next familyBound => + split at accepted + next claimBound => + have he := Option.some.inj accepted + subst request + exact decoded_nativeShapes model p lanes metadata laneBound entry answers claims hc + next tooMany => simp at accepted + next tooMany => simp at accepted + next tooMany => simp at accepted + +theorem decodeAvailableRequest_nativeShapes (model : ProductionLayout) (cap : Nat) + (p : ParameterBounds.Profile) (lanes : Nat) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → Option FiatShamirGame.Digest32) + (request : CausalBindingState.ClaimRequest cap p) + (accepted : decodeAvailableRequest cap p lanes model.layout entry answers = some request) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN request.claims.family ∧ + (∀ point ∈ request.claims.points.toList, + SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by + unfold decodeAvailableRequest at accepted + split at accepted + next present => exact decodeRequest_nativeShapes model cap p lanes entry _ request accepted + next missing => simp at accepted + +#print axioms decodeAvailableRequest_nativeShapes + +#print axioms placementsOf_words +#print axioms production_point_support +#print axioms decoded_support +#print axioms decodeAvailableRequest_shapes + +end Whir.WHIRCallerSupport diff --git a/verification/whir/Whir/WHIRHeaderRoots.lean b/verification/whir/Whir/WHIRHeaderRoots.lean new file mode 100644 index 000000000..7f56a5aa9 --- /dev/null +++ b/verification/whir/Whir/WHIRHeaderRoots.lean @@ -0,0 +1,287 @@ +import Whir.WHIRCallerRegistry + +/-! Header roots are extracted before an allocation receives its fresh answer. In particular, caller-output garbage keys are decoded as exact bounded mode keys, not as final WHIR packets. The immutable public registry selects the caller layout and profile; no caller output is consulted to parse the header. -/ +namespace Whir.WHIRHeaderRoots +open FiatShamirGame DuplexFraming DuplexModeGame +open RawOracleCoupling RawOracleCoupling.Concrete + +/-- `extractedPlan` alone forgets raw bits. Exact reconstruction checks the IV, flags, holes, lengths and complete template before any header is used. -/ +def decodeRaw {Q : Nat} (iv : Digest32) (raw : RawKey Q) : Option Coordinate := + match DuplexEncoding.decode (extractedPlan (expandKey raw)) with + | none => none + | some q => + if bound : pathCost q ≤ Q then + if constructionKey Q iv q bound = raw then some q else none + else none + +theorem decodeRaw_construction {Q : Nat} (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (bound : pathCost q ≤ Q) : + decodeRaw iv (constructionKey Q iv q bound) = some q := by + simp [decodeRaw, expand_constructionKey, RawWHIRKeys.extractedPlan_modeKey, + DuplexEncoding.decode_plan q valid, bound] + +theorem decodeRaw_sound {Q : Nat} (iv : Digest32) (raw : RawKey Q) (q : Coordinate) + (decoded : decodeRaw iv raw = some q) : + ∃ bound : pathCost q ≤ Q, DuplexEncoding.Admissible q ∧ constructionKey Q iv q bound = raw := by + unfold decodeRaw at decoded + split at decoded + · contradiction + · rename_i parsed found + split at decoded + · rename_i bound + split at decoded + · rename_i exactRaw + cases Option.some.inj decoded + exact ⟨bound,(DuplexEncoding.decode_sound found).1,exactRaw⟩ + · contradiction + · contradiction + +theorem decodeRaw_iff {Q : Nat} (iv : Digest32) (raw : RawKey Q) (q : Coordinate) : + decodeRaw iv raw = some q ↔ + ∃ bound : pathCost q ≤ Q, DuplexEncoding.Admissible q ∧ constructionKey Q iv q bound = raw := by + constructor + · exact decodeRaw_sound iv raw q + · rintro ⟨bound,valid,rfl⟩ + exact decodeRaw_construction iv q valid bound + +/-- No caller output is drawn before the initial absorb-zero frame: its preceding cursor is zero, so enumeration contributes no output block at the empty history. -/ +theorem callerOutput_header (entry : FramedHistory) (bytes : List Byte) (rest : List Frame) + (header : entry.frames = .absorb 0 bytes :: rest) (q : Coordinate) + (member : q ∈ WHIRCallerOutputs.callerOutputs entry) : + ∃ later, q.history.frames = .absorb 0 bytes :: later := by + obtain ⟨pre,f,suffix,block,split,bound,rfl⟩ := WHIRCallerOutputs.callerOutputs_mem entry q member + rw [header] at split + cases pre with + | nil => + simp only [List.nil_append,List.cons.injEq] at split + rw [← split.1] at bound + simp [WHIRCallerOutputs.previousConsumed,WHIRCallerOutputs.outputBlocks] at bound + | cons first pre => + simp only [List.cons_append,List.cons.injEq] at split + exact ⟨pre,by rw [← split.1]⟩ + +/-- The complete first absorb run is already present in every source caller output key. Later samples are not needed to read it. -/ +def initialBytes (history : FramedHistory) : Option (List Byte) := + match history.frames with + | .absorb 0 bytes :: _ => some bytes + | _ => none + +theorem callerOutput_initialBytes (entry : FramedHistory) (bytes : List Byte) (rest : List Frame) + (header : entry.frames = .absorb 0 bytes :: rest) (q : Coordinate) + (member : q ∈ WHIRCallerOutputs.callerOutputs entry) : + initialBytes q.history = some bytes := by + obtain ⟨later,head⟩ := callerOutput_header entry bytes rest header q member + simp [initialBytes,head] + +theorem decodeRaw_callerOutputKey (ctx : RawWHIRKeys.Context) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (q : Coordinate) + (member : q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val)) : + decodeRaw ctx.iv (RawWHIRKeys.callerOutputKey ctx Q packet q member).val = some q := + decodeRaw_construction ctx.iv q (RawWHIRKeys.callerOutput_admissible ctx Q packet q member) + (RawWHIRKeys.callerOutput_pathBound ctx Q packet q member) + +theorem callerGroup_header (ctx : RawWHIRKeys.Context) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (bytes : List Byte) (rest : List Frame) + (header : packet.val.entryFrames = .absorb 0 bytes :: rest) + (raw : {raw : RawKey Q // RawWHIRKeys.Garbage ctx Q raw}) + (member : raw ∈ RawWHIRKeys.callerGroups ctx Q packet) : + ∃ q, decodeRaw ctx.iv raw.val = some q ∧ initialBytes q.history = some bytes ∧ + q.history.domain = ctx.domain ∧ q.history.statement = packet.val.statement := by + obtain ⟨⟨q,hq⟩,_,rfl⟩ := List.mem_map.mp member + have same := WHIRCallerOutputs.callerOutputs_strict_prefix (RawWHIRKeys.entry ctx packet.val) q hq + exact ⟨q,decodeRaw_callerOutputKey ctx Q packet q hq, + callerOutput_initialBytes _ bytes rest header q hq,same.1,same.2.1⟩ + +open WHIRCallerClaims WHIRCallerRegistry + +structure Header where + statement : Digest32 + profile : ParameterBounds.Profile + root : Digest32 + +/-- Public layout selection and exact concrete CPU/recursion header parsing. -/ +def fromHistory (registry : Public) (history : FramedHistory) : Option Header := + if history.domain = registry.domain then + match selection registry history.statement with + | none => none + | some (layout,profile) => + (initialRoot layout history).map (fun root => ⟨history.statement,profile,root⟩) + else none + +def rawHeader (registry : Public) {Q : Nat} (raw : RawKey Q) : Option Header := + (decodeRaw registry.iv raw).bind (fun q => fromHistory registry q.history) + +def packetHeader (registry : Public) (Q : Nat) (packet : RawWHIRKeys.Packet (context registry) Q) : + Option Header := fromHistory registry (RawWHIRKeys.entry (context registry) packet.val) + +/-- Only the allocation key is inspected. Neither its new answer nor its old answer annotation is an input to header parsing. -/ +def allocationHeader (registry : Public) (Q : Nat) (key : AllocationKey (context registry) Q) : Option Header := + match key.1 with + | .inl packet => packetHeader registry Q packet + | .inr raw => rawHeader registry raw.val + +def rawRoot (registry : Public) {Q : Nat} (raw : RawKey Q) : Option Digest32 := + (rawHeader registry raw).map Header.root + +def allocationRoot (registry : Public) (Q : Nat) (key : AllocationKey (context registry) Q) : Option Digest32 := + (allocationHeader registry Q key).map Header.root + +def allocationRoots (registry : Public) (Q : Nat) (key : AllocationKey (context registry) Q) : List Digest32 := + (allocationRoot registry Q key).toList + +theorem allocationHeader_prior_irrelevant (registry : Public) (Q : Nat) + (key : GroupKey (context registry) Q) + (a b : List (Sigma (GroupAnswer (context registry) Q))) : + allocationHeader registry Q (key,a) = allocationHeader registry Q (key,b) := rfl + +theorem fromHistory_selected (registry : Public) (history : FramedHistory) + (layout : CallerLayout) (profile : ParameterBounds.Profile) (root : Digest32) + (domain : history.domain = registry.domain) + (selected : selection registry history.statement = some (layout,profile)) + (parsed : initialRoot layout history = some root) : + fromHistory registry history = some ⟨history.statement,profile,root⟩ := by + simp [fromHistory,domain,selected,parsed] + +theorem fromHistory_sound (registry : Public) (history : FramedHistory) (header : Header) + (parsed : fromHistory registry history = some header) : + history.domain = registry.domain ∧ header.statement = history.statement ∧ + ∃ layout, selection registry history.statement = some (layout,header.profile) ∧ + initialRoot layout history = some header.root := by + unfold fromHistory at parsed + split at parsed + · rename_i domain + split at parsed + · contradiction + · rename_i layout profile selected + cases root : initialRoot layout history with + | none => simp [root] at parsed + | some value => + simp only [root,Option.map_some,Option.some.injEq] at parsed + subst header + exact ⟨domain,rfl,layout,selected,root⟩ + · contradiction + +/-- Any accepted raw header comes from an exact valid bounded mode key and a real public-layout header parse, even when the key is garbage for the WHIR packet partition. -/ +theorem rawHeader_sound (registry : Public) {Q : Nat} (raw : RawKey Q) (header : Header) + (parsed : rawHeader registry raw = some header) : + ∃ q, decodeRaw registry.iv raw = some q ∧ + (∃ bound : pathCost q ≤ Q, DuplexEncoding.Admissible q ∧ constructionKey Q registry.iv q bound = raw) ∧ + fromHistory registry q.history = some header := by + cases decoded : decodeRaw registry.iv raw with + | none => simp [rawHeader,decoded] at parsed + | some q => + have hp : fromHistory registry q.history = some header := by simpa [rawHeader,decoded] using parsed + exact ⟨q,rfl,decodeRaw_sound registry.iv raw q decoded,hp⟩ + +theorem initialRoot_header (layout : CallerLayout) (entry : FramedHistory) (root : Digest32) + (parsed : initialRoot layout entry = some root) : + ∃ bytes rest, entry.frames = .absorb 0 bytes :: rest := by + cases frames : entry.frames with + | nil => simp [initialRoot,frames] at parsed + | cons frame rest => + cases frame with + | nonce consumed bits value => simp [initialRoot,frames] at parsed + | absorb previous bytes => + cases previous with + | zero => exact ⟨bytes,rest,rfl⟩ + | succ previous => simp [initialRoot,frames] at parsed + +theorem callerOutput_initialRoot (layout : CallerLayout) (entry : FramedHistory) (root : Digest32) + (parsed : initialRoot layout entry = some root) (q : Coordinate) + (member : q ∈ WHIRCallerOutputs.callerOutputs entry) : + initialRoot layout q.history = some root := by + obtain ⟨bytes,rest,header⟩ := initialRoot_header layout entry root parsed + obtain ⟨later,qheader⟩ := callerOutput_header entry bytes rest header q member + simpa only [initialRoot,header,qheader] using parsed + +theorem initialRoot_append (layout : CallerLayout) (entry : FramedHistory) (root : Digest32) + (parsed : initialRoot layout entry = some root) (suffix : List Frame) : + initialRoot layout {entry with frames := entry.frames ++ suffix} = some root := by + obtain ⟨bytes,rest,header⟩ := initialRoot_header layout entry root parsed + simpa only [initialRoot,header,List.cons_append] using parsed + +theorem rawHeader_construction (registry : Public) {Q : Nat} (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (bound : pathCost q ≤ Q) + (header : Header) (parsed : fromHistory registry q.history = some header) : + rawHeader registry (constructionKey Q registry.iv q bound) = some header := by + simp [rawHeader,decodeRaw_construction registry.iv q valid bound,parsed] + +theorem packetRequest_initialRoot (registry : Public) (Q cap : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (decoded : packetRequest registry Q cap packet history = some request) : + initialRoot (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) = + some request.root := + decodeAvailableRequest_initialRoot cap packet.val.profile + (callerLanes (packetLayout registry Q packet)) (packetLayout registry Q packet) + (RawWHIRKeys.entry (context registry) packet.val) + (callerAnswers (context registry) Q packet history) request decoded + +theorem packetHeader_request (registry : Public) (Q cap : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (decoded : packetRequest registry Q cap packet history = some request) : + packetHeader registry Q packet = some ⟨packet.val.statement,packet.val.profile,request.root⟩ := + fromHistory_selected registry _ (packetLayout registry Q packet) packet.val.profile request.root + rfl (packet_selection registry Q packet) (packetRequest_initialRoot registry Q cap packet history request decoded) + +theorem callerOutputKey_header (registry : Public) (Q cap : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (decoded : packetRequest registry Q cap packet history = some request) + (q : Coordinate) (member : q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry (context registry) packet.val)) : + rawHeader registry (RawWHIRKeys.callerOutputKey (context registry) Q packet q member).val = + some ⟨packet.val.statement,packet.val.profile,request.root⟩ := by + have same := WHIRCallerOutputs.callerOutputs_strict_prefix (RawWHIRKeys.entry (context registry) packet.val) q member + have hs : q.history.statement = packet.val.statement := same.2.1 + have hd : q.history.domain = registry.domain := same.1 + have root := callerOutput_initialRoot (packetLayout registry Q packet) _ request.root + (packetRequest_initialRoot registry Q cap packet history request decoded) q member + have selected : selection registry q.history.statement = + some (packetLayout registry Q packet,packet.val.profile) := by + rw [hs] + exact packet_selection registry Q packet + have result := fromHistory_selected registry q.history _ _ _ hd selected root + unfold rawHeader + rw [show decodeRaw registry.iv (RawWHIRKeys.callerOutputKey (context registry) Q packet q member).val = + some q from decodeRaw_callerOutputKey (context registry) Q packet q member] + simpa only [Option.bind_some,hs] using result + +theorem callerGroup_header_request (registry : Public) (Q cap : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (decoded : packetRequest registry Q cap packet history = some request) + (raw : {raw : RawKey Q // RawWHIRKeys.Garbage (context registry) Q raw}) + (member : raw ∈ RawWHIRKeys.callerGroups (context registry) Q packet) : + rawHeader registry raw.val = some ⟨packet.val.statement,packet.val.profile,request.root⟩ := by + obtain ⟨⟨q,hq⟩,_,rfl⟩ := List.mem_map.mp member + exact callerOutputKey_header registry Q cap packet history request decoded q hq + +/-- This conclusion holds for every old annotation, including an empty cache before the very first fresh caller answer. -/ +theorem allocation_caller_root (registry : Public) (Q cap : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (decoded : packetRequest registry Q cap packet history = some request) + (raw : {raw : RawKey Q // RawWHIRKeys.Garbage (context registry) Q raw}) + (member : raw ∈ RawWHIRKeys.callerGroups (context registry) Q packet) + (prior : List (Sigma (GroupAnswer (context registry) Q))) : + allocationRoots registry Q (.inr raw,prior) = [request.root] := by + simp [allocationRoots,allocationRoot,allocationHeader, + callerGroup_header_request registry Q cap packet history request decoded raw member] + +theorem allocation_packet_root (registry : Public) (Q cap : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (history : List (Sigma (GroupAnswer (context registry) Q))) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (decoded : packetRequest registry Q cap packet history = some request) + (prior : List (Sigma (GroupAnswer (context registry) Q))) : + allocationRoots registry Q (.inl packet,prior) = [request.root] := by + simp [allocationRoots,allocationRoot,allocationHeader, + packetHeader_request registry Q cap packet history request decoded] + +end Whir.WHIRHeaderRoots diff --git a/verification/whir/Whir/WHIRNativeEvent.lean b/verification/whir/Whir/WHIRNativeEvent.lean new file mode 100644 index 000000000..26e521a97 --- /dev/null +++ b/verification/whir/Whir/WHIRNativeEvent.lean @@ -0,0 +1,28 @@ +import Whir.WHIRPhysicalDriver +import Whir.WHIRObservableSource + +namespace Whir.WHIRNativeEvent +open DuplexModeGame WHIRPhysicalDriver + +abbrev Output (registry : ProductionRegistry) (Q cap : Nat) := + WHIRPublicBackfill.Completed (WHIRCallerRegistry.context registry.publicRegistry) Q + (WHIRSourceChronology.Result cap (Option (Accepted registry.context Q cap))) + +/-- The native event sees only the completed public result and reconstructs its first-frozen candidate list from public records. It never receives a source program, private coins, a simulator seed, or a total compression oracle. -/ +def Failure (registry : ProductionRegistry) (Q : Nat) {cap : Nat} (output : Output registry Q cap) : Prop := + ∃ observed, WHIRObservableSource.observe registry.publicRegistry Q select output = some observed ∧ + nativeWrong observed.state output.result.value + +noncomputable def distinguisher (registry : ProductionRegistry) (Q cap : Nat) : + View (Output registry Q cap) → Bool := by + classical + exact fun view => decide (Failure registry Q view.result) + +/-- Rejection is not a false acceptance, even if reconstruction encounters malformed public records. -/ +theorem rejected (registry : ProductionRegistry) (Q cap : Nat) (output : Output registry Q cap) + (none : output.result.value = Option.none) : ¬ Failure registry Q output := by + rintro ⟨observed,_,wrong⟩ + rw [none] at wrong + exact wrong + +end Whir.WHIRNativeEvent diff --git a/verification/whir/Whir/WHIRNativeRestoration.lean b/verification/whir/Whir/WHIRNativeRestoration.lean new file mode 100644 index 000000000..78030e565 --- /dev/null +++ b/verification/whir/Whir/WHIRNativeRestoration.lean @@ -0,0 +1,38 @@ +import Whir.WHIRNativeErasure + +namespace Whir.WHIRNativeErasure +open Concrete Protocol WHIRPhysicalErasure WHIRNativeArithmetic + +/-- Proof-only restoration changes present ghost oracles, never their presence or any physical payload. The table is indexed by the next code level. -/ +def restoreOracles (proof : Opening) (lookup : Nat → Oracle) : Opening := + {proof with levels := Array.ofFn fun i : Fin proof.levels.size => + {proof.levels[i] with nextOracle := proof.levels[i].nextOracle.map fun _ => lookup (i.val + 1)}} + +theorem eraseOracles_restore (proof : Opening) (lookup : Nat → Oracle) : + eraseOracles (restoreOracles proof lookup) = eraseOracles proof := by + cases proof with + | mk initial levels residual tailMessages => + simp only [restoreOracles, eraseOracles, Array.map_ofFn, Function.comp_def, eraseLevel, + Option.map_map] + congr 1 + apply Array.ext + · simp + · intro i hi hj + simp [eraseLevel] + +theorem nativeVerify_restored (c : Config) (ch : Challenges) (lanes : Nat) (initialClaim : E) + (callerAt : Array E → E) (proof : Opening) (lookup : Nat → Oracle) : + nativeVerify c ch lanes initialClaim callerAt (restoreOracles proof lookup) = + nativeVerify c ch lanes initialClaim callerAt proof := by + rw [← nativeVerify_erased c ch lanes initialClaim callerAt (restoreOracles proof lookup), + eraseOracles_restore, nativeVerify_erased] + +theorem sourceVerify_restored {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (ch : Challenges) (lanes : Nat) (proof : Opening) (lookup : Nat → Oracle) : + sourceVerify family points seed lambda c ch lanes (restoreOracles proof lookup) = + sourceVerify family points seed lambda c ch lanes proof := + nativeVerify_restored c ch lanes (initialClaim family points seed lambda) + (SuccinctRingGroups.sourceStackWeightAt family points seed lambda) proof lookup + +end Whir.WHIRNativeErasure diff --git a/verification/whir/Whir/WHIRNativeSecurity.lean b/verification/whir/Whir/WHIRNativeSecurity.lean new file mode 100644 index 000000000..1e3488592 --- /dev/null +++ b/verification/whir/Whir/WHIRNativeSecurity.lean @@ -0,0 +1,187 @@ +import Whir.WHIRNativeEvent +import Whir.WHIRObservableSecurity +import Whir.WHIRSourceMerkleSecurity +import Whir.WHIRPhysicalBinding + +namespace Whir.WHIRNativeSecurity +open FiatShamirGame DuplexModeGame WHIRPhysicalDriver WHIRSourceChronology +open RawOracleCoupling.Concrete TypedOracleCompiler +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 + +variable {Coins : Type} {cap : Nat} + +noncomputable local instance : Fintype PrimitiveOracle := PublicMerkleProbability.compressionOracleFintype + +def sources (registry : ProductionRegistry) (Q : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) := + fun coins => verifyAfter cap registry Q (attackers coins) + +def adversary (registry : ProductionRegistry) (Q : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) := + WHIRObservableSecurity.adversary registry.publicRegistry Q (sources registry Q attackers) select + +/-- The physical budget includes the arbitrary attacker, the actual verifier, every repeated raw completion, and the selected terminal path. Bounds range only over reachable attacker outputs. -/ +theorem counted (registry : ProductionRegistry) (Q a b Mf : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) + (before : ∀ coins, Counts a (attackers coins)) + (verifierBudget : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget registry.context Q input.packet ≤ b) + (erase (attackers coins))) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => DuplexFraming.pathCost (RawWHIRKeys.coordinate registry.context input.packet.val 0) ≤ Mf) + (erase (attackers coins))) + (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) : + ∀ coins, DuplexModeGame.Counts Q (adversary registry Q attackers coins) := + WHIRObservableSecurity.adversary_counted registry.publicRegistry Q (a+b) Mf + (sources registry Q attackers) select + (fun coins => verifyAfter_counted cap registry Q (attackers coins) a b (before coins) (verifierBudget coins)) + (fun coins => verifyAfter_path_bound cap registry Q (attackers coins) Mf (paths coins)) envelope + +/-- The bad ordinary-Merkle event is observed on the full shared compression trace, including hidden construction calls. It is used only in the random-compression world, never as the concrete primitive distinguisher. -/ +def MerkleFailure (registry : ProductionRegistry) (Q : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) + (whole : ∀ coins, DuplexModeGame.Counts Q (adversary registry Q attackers coins)) + (C : PrimitiveOracle) (coins : Coins) : Prop := + PublicMerkleProbability.FrozenOpeningBad C + (WHIRSourceRootPolicy.policy registry.publicRegistry Q select (sources registry Q attackers coins)) + (PublicCompressionProgram.toLog (Sampling.execute C + (PublicCompressionProgram.compile registry.iv (adversary registry Q attackers coins) Q (whole coins))).2) + +private theorem real_union_bound [Fintype Coins] [Nonempty Coins] + (registry : ProductionRegistry) (Q : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) + (whole : ∀ coins, DuplexModeGame.Counts Q (adversary registry Q attackers coins)) + (reduction : ∀ C coins, + WHIRNativeEvent.Failure registry Q (runReal C registry.iv (adversary registry Q attackers coins)).view.result → + WHIRObservableSource.Failure registry.publicRegistry Q select + (runReal C registry.iv (adversary registry Q attackers coins)).view.result ∨ + MerkleFailure registry Q attackers whole C coins) : + realProbability registry.iv (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ + realProbability registry.iv (adversary registry Q attackers) + (WHIRObservableSecurity.distinguisher registry.publicRegistry Q select) + + WHIRSourceMerkleSecurity.probability registry.publicRegistry Q (sources registry Q attackers) select whole := by + classical + unfold realProbability + rw [WHIRObservableSecurity.distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins)), + WHIRObservableSecurity.distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins))] + simp only [WHIRObservableSecurity.average_product (X := PrimitiveOracle) (Y := Coins)] + rw [RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins), + RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins)] + unfold WHIRSourceMerkleSecurity.probability PublicMerkleProbability.openingProbability + rw [← average_add] + apply average_mono + intro coins + rw [← average_add] + apply average_mono + intro C + simp only [WHIRNativeEvent.distinguisher,WHIRObservableSecurity.distinguisher,decide_eq_true_eq] + change (if WHIRNativeEvent.Failure registry Q + (runReal C registry.iv (adversary registry Q attackers coins)).view.result then (1 : ℚ) else 0) ≤ + (if WHIRObservableSource.Failure registry.publicRegistry Q select + (runReal C registry.iv (adversary registry Q attackers coins)).view.result then 1 else 0) + + (if MerkleFailure registry Q attackers whole C coins then 1 else 0) + by_cases wrong : WHIRNativeEvent.Failure registry Q + (runReal C registry.iv (adversary registry Q attackers coins)).view.result + · rcases reduction C coins wrong with raw | merkle + · simp only [wrong,raw,↓reduceIte] + split <;> norm_num + · simp only [wrong,merkle,↓reduceIte] + split <;> norm_num + · simp only [wrong,↓reduceIte] + split <;> split <;> norm_num + +private theorem random_of_reduction [Fintype Coins] [Nonempty Coins] + [Fintype DuplexPublicSimulator.Seed] + (registry : ProductionRegistry) (Q a b Mf free : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) + (before : ∀ coins, Counts a (attackers coins)) + (verifierBudget : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget registry.context Q input.packet ≤ b) + (erase (attackers coins))) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => DuplexFraming.pathCost (RawWHIRKeys.coordinate registry.context input.packet.val 0) ≤ Mf) + (erase (attackers coins))) + (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (sources registry Q attackers coins)) + (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) + (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State + (DuplexPublicSimulator.simulator Q) registry.iv) + (reduction : ∀ (whole : ∀ coins, DuplexModeGame.Counts Q (adversary registry Q attackers coins)) C coins, + WHIRNativeEvent.Failure registry Q (runReal C registry.iv (adversary registry Q attackers coins)).view.result → + WHIRObservableSource.Failure registry.publicRegistry Q select + (runReal C registry.iv (adversary registry Q attackers coins)).view.result ∨ + MerkleFailure registry Q attackers whole C coins) : + realProbability registry.iv (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ + WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + dmvLoss Q + + WHIRSourceMerkleSecurity.loss Q free := by + have sourceA : ∀ coins, Counts (a+b) (sources registry Q attackers coins) := + fun coins => verifyAfter_counted cap registry Q (attackers coins) a b (before coins) (verifierBudget coins) + have sourceQ : ∀ coins, Counts Q (sources registry Q attackers coins) := + fun coins => WHIRObservableSecurity.source_counted registry.publicRegistry Q (a+b) Mf + (sources registry Q attackers coins) (sourceA coins) envelope + have finalPaths := fun coins => verifyAfter_path_bound cap registry Q (attackers coins) Mf (paths coins) + have whole := counted registry Q a b Mf attackers before verifierBudget paths envelope + have unionBound := real_union_bound registry Q attackers whole (reduction whole) + have rawBound := WHIRObservableSecurity.random_compression_list_binding registry.publicRegistry Q (a+b) Mf + (sources registry Q attackers) select sourceA finalPaths envelope security + have merkleBound := WHIRSourceMerkleSecurity.probability_bound registry.publicRegistry Q free + (sources registry Q attackers) select sourceQ announcements whole + exact unionBound.trans (add_le_add rawBound merkleBound) + +/-- Actual native verification, original CPU/recursion decoding, first-frozen candidates, adaptive public Fiat-Shamir, and ordinary Merkle transport compose in the shared random-compression experiment. The only cryptographic premise is DMV for the pinned public mode; the remaining premises are source-only resource budgets. -/ +theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] + [Fintype DuplexPublicSimulator.Seed] + (registry : ProductionRegistry) (Q a b Mf free : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) + (before : ∀ coins, Counts a (attackers coins)) + (verifierBudget : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget registry.context Q input.packet ≤ b) + (erase (attackers coins))) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => DuplexFraming.pathCost (RawWHIRKeys.coordinate registry.context input.packet.val 0) ≤ Mf) + (erase (attackers coins))) + (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (sources registry Q attackers coins)) + (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) + (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State + (DuplexPublicSimulator.simulator Q) registry.iv) : + realProbability registry.iv (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ + WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + dmvLoss Q + + WHIRSourceMerkleSecurity.loss Q free := by + apply random_of_reduction registry Q a b Mf free attackers before verifierBudget paths announcements envelope security + intro whole C coins failed + have sourceA := verifyAfter_counted cap registry Q (attackers coins) a b (before coins) (verifierBudget coins) + have sourceQ := WHIRObservableSecurity.source_counted registry.publicRegistry Q (a+b) Mf + (verifyAfter cap registry Q (attackers coins)) sourceA envelope + exact WHIRPhysicalBinding.nativeFailure_or_frozen registry Q cap C (attackers coins) sourceQ (whole coins) failed + +/-- Deterministic BLAKE2s adds one separate primitive replacement gap for the final public native-acceptance event. No replacement assumption is made for the unobservable full-compression Merkle event, and no correctness/coverage premise is delegated to a cryptographic assumption. -/ +theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] + [Fintype DuplexPublicSimulator.Seed] + (registry : ProductionRegistry) (Q a b Mf free : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) + (before : ∀ coins, Counts a (attackers coins)) + (verifierBudget : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget registry.context Q input.packet ≤ b) + (erase (attackers coins))) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => DuplexFraming.pathCost (RawWHIRKeys.coordinate registry.context input.packet.val 0) ≤ Mf) + (erase (attackers coins))) + (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (sources registry Q attackers coins)) + (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) + (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State + (DuplexPublicSimulator.simulator Q) registry.iv) + (Allowed : (C : Type) → [Fintype C] → (Output : Type) → + (C → Program Output) → (View Output → Bool) → Prop) + (primitiveLoss : ℚ) (primitive : ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed) + (permitted : Allowed Coins _ (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap)) : + concreteProbability registry.iv (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ + WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + dmvLoss Q + + WHIRSourceMerkleSecurity.loss Q free + primitiveLoss := by + have randomBound := random_compression_list_binding registry Q a b Mf free attackers + before verifierBudget paths announcements envelope security + have replaced := (abs_le.mp (primitive Coins _ (adversary registry Q attackers) + (WHIRNativeEvent.distinguisher registry Q cap) permitted + (counted registry Q a b Mf attackers before verifierBudget paths envelope))).2 + linarith + +end Whir.WHIRNativeSecurity diff --git a/verification/whir/Whir/WHIRObservableSecurity.lean b/verification/whir/Whir/WHIRObservableSecurity.lean new file mode 100644 index 000000000..3e2df5c36 --- /dev/null +++ b/verification/whir/Whir/WHIRObservableSecurity.lean @@ -0,0 +1,150 @@ +import Whir.WHIRObservableSource +import Whir.WHIRRealSimulator + +namespace Whir.WHIRObservableSecurity +open FiatShamirGame DuplexModeGame RawOracleCoupling.Concrete +open WHIRCallerRegistry WHIRSourceChronology WHIRObservableSource +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 + +variable {cap : Nat} {R Coins : Type} + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ + +/-- The public event never receives the adversary program, adversary coins, simulator seed, or a total raw oracle. -/ +noncomputable def distinguisher (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + View (WHIRPublicBackfill.Completed (context registry) Q (Result cap R)) → Bool := by + classical + exact fun view => decide (Failure registry Q select view.result) + +def adversary (registry : Public) (Q : Nat) (sources : Coins → Source cap R) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + Coins → Program (WHIRPublicBackfill.Completed (context registry) Q (Result cap R)) := + fun coins => WHIRSourceBackfill.instrument (context registry) Q (sources coins) select + +def romBound (registry : Public) (A cap : Nat) : ℚ := + min 1 (((allocationBudget (context registry) * (A+1) : Nat) : ℚ) * WHIRRawROM.epsilon cap) + +theorem source_counted (registry : Public) (Q A Mf : Nat) (source : Source cap R) + (before : Counts A source) (envelope : WHIRSourceBackfill.budget (context registry) A Mf ≤ Q) : + Counts Q source := by + apply (compile_counted source Q).mp + apply WHIRModeFinal.counts_mono ((compile_counted source A).mpr before) + unfold WHIRSourceBackfill.budget at envelope + omega + +/-- Physical accounting is source-only and noncircular, including every repeated completion occurrence. -/ +theorem adversary_counted (registry : Public) (Q A Mf : Nat) (sources : Coins → Source cap R) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (before : ∀ coins, Counts A (sources coins)) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun result => ∀ packet, select result = some packet → + DuplexFraming.pathCost (RawWHIRKeys.coordinate (context registry) packet.val 0) ≤ Mf) + (erase (sources coins))) + (envelope : WHIRSourceBackfill.budget (context registry) A Mf ≤ Q) : + ∀ coins, DuplexModeGame.Counts Q (adversary registry Q sources select coins) := by + intro coins + exact WHIRModeFinal.counts_mono + (WHIRSourceBackfill.counted_reachable (context registry) Q A Mf (sources coins) select + (before coins) (paths coins)) envelope + +theorem distinguish_average {C V : Type} {old : Fintype C} (new : Fintype C) + (experiment : C → V) (D : V → Bool) : + @distinguishProbability C V old experiment D = + @average C new (fun coin => if D (experiment coin) = true then 1 else 0) := by + classical + cases Subsingleton.elim old new + simp only [distinguishProbability,Soundness.uniformProb,average,Finset.sum_boole] + +theorem average_product {X Y : Type} [Fintype X] [Fintype Y] (f : X × Y → ℚ) : + average f = average (fun x => average (fun y => f (x,y))) := by + classical + simp only [average,Fintype.sum_prod_type,Finset.sum_div,Fintype.card_prod,Nat.cast_mul,div_div] + rw [mul_comm] + +/-- Averaging over independent raw tables, simulator coins and adversary coins preserves the checked source-budgeted ROM bound. -/ +theorem ideal_list_binding [Fintype Coins] [Nonempty Coins] [Fintype DuplexPublicSimulator.Seed] + (registry : Public) (Q A : Nat) (sources : Coins → Source cap R) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (sourceQ : ∀ coins, Counts Q (sources coins)) (before : ∀ coins, Counts A (sources coins)) + (whole : ∀ coins, DuplexModeGame.Counts Q (adversary registry Q sources select coins)) : + idealProbability (DuplexPublicSimulator.simulator Q) registry.iv + (adversary registry Q sources select) whole (distinguisher registry Q select) ≤ romBound registry A cap := by + classical + unfold idealProbability + rw [distinguish_average (inferInstance : Fintype ((RawKey Q → Digest32) × DuplexPublicSimulator.Seed × Coins))] + rw [average_product (X := RawKey Q → Digest32) (Y := DuplexPublicSimulator.Seed × Coins)] + rw [RawOracleCoupling.average_comm + (X := RawKey Q → Digest32) (Y := DuplexPublicSimulator.Seed × Coins)] + calc + _ ≤ average (fun _ : DuplexPublicSimulator.Seed × Coins => romBound registry A cap) := by + apply average_mono + intro coins + simp only [distinguisher,adversary] + simp_rw [ideal_output registry Q _ coins.1 (sources coins.2) (sourceQ coins.2) select (whole coins.2)] + simpa only [decide_eq_true_eq,romBound] using + public_table_list_binding registry Q coins.1 (sources coins.2) (sourceQ coins.2) + A (before coins.2) select + _ = _ := average_const _ + +/-- This conditional statement is only about the pinned #552 public-compression mode. It does not apply DMV to the older keyed transcript. -/ +theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] + [Fintype DuplexPublicSimulator.Seed] + (registry : Public) (Q A Mf : Nat) (sources : Coins → Source cap R) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (before : ∀ coins, Counts A (sources coins)) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun result => ∀ packet, select result = some packet → + DuplexFraming.pathCost (RawWHIRKeys.coordinate (context registry) packet.val 0) ≤ Mf) + (erase (sources coins))) + (envelope : WHIRSourceBackfill.budget (context registry) A Mf ≤ Q) + (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State + (DuplexPublicSimulator.simulator Q) registry.iv) : + realProbability registry.iv (adversary registry Q sources select) (distinguisher registry Q select) ≤ + romBound registry A cap + dmvLoss Q := by + apply randomCompression_transfer (DuplexPublicSimulator.simulator Q) registry.iv security + (adversary registry Q sources select) (adversary_counted registry Q A Mf sources select before paths envelope) + (distinguisher registry Q select) + exact ideal_list_binding registry Q A sources select + (fun coins => source_counted registry Q A Mf (sources coins) (before coins) envelope) before _ + +/-- Concrete BLAKE2s requires its own explicit replacement gap for this actual public event, separate from DMV and the algebraic ROM bound. -/ +theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] [Fintype DuplexPublicSimulator.Seed] + (registry : Public) (Q A Mf : Nat) (sources : Coins → Source cap R) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (before : ∀ coins, Counts A (sources coins)) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun result => ∀ packet, select result = some packet → + DuplexFraming.pathCost (RawWHIRKeys.coordinate (context registry) packet.val 0) ≤ Mf) + (erase (sources coins))) + (envelope : WHIRSourceBackfill.budget (context registry) A Mf ≤ Q) + (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State + (DuplexPublicSimulator.simulator Q) registry.iv) + (Allowed : (C : Type) → [Fintype C] → (Output : Type) → + (C → Program Output) → (View Output → Bool) → Prop) + (primitiveLoss : ℚ) (primitive : ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed) + (permitted : Allowed Coins _ (adversary registry Q sources select) (distinguisher registry Q select)) : + concreteProbability registry.iv (adversary registry Q sources select) (distinguisher registry Q select) ≤ + romBound registry A cap + dmvLoss Q + primitiveLoss := by + apply concrete_transfer (DuplexPublicSimulator.simulator Q) registry.iv security Allowed primitive + (adversary registry Q sources select) (adversary_counted registry Q A Mf sources select before paths envelope) + (distinguisher registry Q select) permitted + exact ideal_list_binding registry Q A sources select + (fun coins => source_counted registry Q A Mf (sources coins) (before coins) envelope) before _ + +/-- Real-world reconstruction uses the deterministic selected-simulator realization only here, never as an independence premise in the probability proof. -/ +theorem observe_real (registry : Public) (Q : Nat) (C : PrimitiveOracle) + (source : Source cap R) (counted : Counts Q source) (A : Nat) (before : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (whole : DuplexModeGame.Counts Q (WHIRSourceBackfill.instrument (context registry) Q source select)) : + observe registry Q select (runReal C registry.iv + (WHIRSourceBackfill.instrument (context registry) Q source select)).view.result = + some (tableObservation registry Q (WHIRRealSimulator.rawTable Q C) C source counted A before select) := by + rw [WHIRRealSimulator.real_ideal_view C registry.iv + (WHIRSourceBackfill.instrument (context registry) Q source select) whole] + exact observe_ideal registry Q _ C source counted A before select whole + +end Whir.WHIRObservableSecurity diff --git a/verification/whir/Whir/WHIRObservableSource.lean b/verification/whir/Whir/WHIRObservableSource.lean new file mode 100644 index 000000000..6bd611f93 --- /dev/null +++ b/verification/whir/Whir/WHIRObservableSource.lean @@ -0,0 +1,246 @@ +import Whir.WHIRSourceResolver +import Whir.WHIRSourceRawProgram +import Whir.WHIRSourceBackfill + +namespace Whir.WHIRObservableSource +open FiatShamirGame DuplexModeGame TypedOracleCompiler +open RawOracleCoupling.Concrete WHIRCallerRegistry WHIRSourceChronology +open WHIRSourceResolver WHIRPublicBackfill + +variable {cap : Nat} {R : Type} + +/-- Only compiler-owned public events supply source answers. Completion-only observations cannot advance the source cutoff. -/ +def answers (registry : Public) (Q : Nat) (result : Result cap R) : List (RawKey Q × Digest32) := + DuplexPublicSimulator.replayAnswers Q registry.iv [] (sourceView result).observations + +structure Observed (registry : Public) (Q cap : Nat) where + cache : PublicCache (context registry) Q + labels : List (Sigma (fun label : WHIRCausalRawROM.Label (context registry) rfl Q cap => + WHIRCausalRawROM.Answer label)) + state : CausalBindingState.State cap + +/-- Reconstruction consumes only the actual public source result and physical completion records. It has no source-program, private-coin, or total-oracle parameter. -/ +noncomputable def observe (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (output : Completed (context registry) Q (Result cap R)) : Option (Observed registry Q cap) := + (WHIRObservableAllocations.observe (context registry) Q (answers registry Q output.result) + (select output.result.value) output.records).map fun reconstructed => + let labeled := (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (publicResolver registry Q output.result)).traceRecode (CausalBindingState.empty cap) reconstructed.2 + ⟨reconstructed.1,labeled.1,labeled.2⟩ + +def selection (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + Option (View (Result cap R)) → Option (RawWHIRKeys.Packet (context registry) Q) := + fun result => result.bind (fun view => select view.result.value) + +def rawProgram (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : Counts Q source) (A : Nat) (sourceCounted : Counts A source) := + WHIRSourceRawProgram.bounded Q registry.iv ((DuplexPublicSimulator.simulator Q).initial seed) + (compile source) Q (Nat.le_refl Q) ((compile_counted source Q).mpr counted) + A ((compile_counted source A).mpr sourceCounted) + +def execution (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) := + runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (Nat.le_refl Q) + ((compile_counted source Q).mpr counted) + +theorem rawProgram_eval (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) : + Sampling.eval ro (rawProgram registry Q seed source counted A sourceCounted) = + some (execution registry Q ro seed source counted).view := + WHIRSourceRawProgram.bounded_eval .. + +theorem rawProgram_answers (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) : + WHIRObservableAllocations.rawAnswers Q ro (rawProgram registry Q seed source counted A sourceCounted) = + answers registry Q (execution registry Q ro seed source counted).view.result := by + unfold rawProgram + rw [WHIRSourceRawProgram.bounded_rawAnswers] + unfold answers execution + rw [sourceView_ideal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) source Q (Nat.le_refl Q) counted] + rfl + +def tableOutput (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + Completed (context registry) Q (Result cap R) := + let result := (execution registry Q ro seed source counted).view.result + ⟨result,idealRecords (context registry) Q ro + (selections (context registry) Q ((answers registry Q result).map Prod.fst) (select result.value))⟩ + +def allocationTrace (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) := + (Sampling.execute (WHIRObservableAllocations.allocationOracle (context registry) Q ro) + (RawOracleCoupling.Concrete.compile (context registry) Q (selection registry Q select) + (rawProgram registry Q seed source counted A sourceCounted))).2 + +theorem allocationTrace_agrees (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + TraceAgrees registry Q ro (allocationTrace registry Q ro seed source counted A sourceCounted select) := by + intro entry member + exact (WHIRObservableAllocations.execute_answers _ _ entry member).symm + +noncomputable def tableObservation (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : Observed registry Q cap := + let result := tableExecution (context registry) Q (selection registry Q select) + (rawProgram registry Q seed source counted A sourceCounted) ro + let labeled := (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (privateResolver registry Q seed source counted)).traceRecode (CausalBindingState.empty cap) + (allocationTrace registry Q ro seed source counted A sourceCounted select) + ⟨result.2,labeled.1,labeled.2⟩ + +/-- Every reconstructed allocation answer, chronological binding label, and final immutable catalog equals the actual causal experiment. Cache coverage and consistency are consequences of executed physical completion, not hypotheses. -/ +theorem observe_table (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + observe registry Q select (tableOutput registry Q ro seed source counted select) = + some (tableObservation registry Q ro seed source counted A sourceCounted select) := by + have reconstruction := WHIRObservableAllocations.observe_tableExecution (context registry) Q ro + (selection registry Q select) (rawProgram registry Q seed source counted A sourceCounted) + rw [rawProgram_answers,rawProgram_eval] at reconstruction + simp only [selection,Option.bind_some] at reconstruction + unfold observe tableOutput + rw [reconstruction] + simp only [Option.map_some] + have recoding := traceRecode_actual registry Q ro seed source counted (CausalBindingState.empty cap) + (by intro entry member; cases member) + (allocationTrace registry Q ro seed source counted A sourceCounted select) + (allocationTrace_agrees registry Q ro seed source counted A sourceCounted select) + exact congrArg (fun labeled => some + (⟨(tableExecution (context registry) Q (selection registry Q select) + (rawProgram registry Q seed source counted A sourceCounted) ro).2,labeled.1,labeled.2⟩ : + Observed registry Q cap)) recoding + +theorem tableObservation_state (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + (tableObservation registry Q ro seed source counted A sourceCounted select).state = + WHIRCausalRawROM.stateOfResult (context registry) rfl Q cap + (privateResolver registry Q seed source counted) (CausalBindingState.empty cap) + (selection registry Q select) (rawProgram registry Q seed source counted A sourceCounted) + (tableExecution (context registry) Q (selection registry Q select) + (rawProgram registry Q seed source counted A sourceCounted) ro) := by + have run := Sampling.execute_runs (WHIRObservableAllocations.allocationOracle (context registry) Q ro) + (RawOracleCoupling.Concrete.compile (context registry) Q (selection registry Q select) + (rawProgram registry Q seed source counted A sourceCounted)) + rw [WHIRObservableAllocations.compile_cache] at run + have reconstruction := compile_reconstruct (context registry) Q (selection registry Q select) + (rawProgram registry Q seed source counted A sourceCounted) run + unfold WHIRCausalRawROM.stateOfResult + rw [reconstruction] + rfl + +/-- The physical wrapper returns exactly the original source result and the actual completion suffix records. -/ +theorem ideal_output (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (whole : DuplexModeGame.Counts Q (WHIRSourceBackfill.instrument (context registry) Q source select)) : + (runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (WHIRSourceBackfill.instrument (context registry) Q source select) Q (Nat.le_refl Q) whole).view.result = + tableOutput registry Q ro seed source counted select := by + change (runIdeal (DuplexPublicSimulator.simulator Q) ro (context registry).iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (WHIRSourceBackfill.instrument (context registry) Q source select) Q (Nat.le_refl Q) whole).view.result = _ + rw [WHIRSourceBackfill.ideal_result (context registry) Q (DuplexPublicSimulator.simulator Q) + ro ((DuplexPublicSimulator.simulator Q).initial seed) source select Q (Nat.le_refl Q) whole] + have same : WHIRSourceBackfill.requests (context registry) Q + (execution registry Q ro seed source counted).view.result = + (answers registry Q (execution registry Q ro seed source counted).view.result).map Prod.fst := + (DuplexPublicSimulator.replayAnswers_keys Q registry.iv [] + (sourceView (execution registry Q ro seed source counted).view.result).observations).symm + change (⟨(execution registry Q ro seed source counted).view.result, + idealRecords (context registry) Q ro (selections (context registry) Q + (WHIRSourceBackfill.requests (context registry) Q + (execution registry Q ro seed source counted).view.result) + (select (execution registry Q ro seed source counted).view.result.value))⟩ : + Completed (context registry) Q (Result cap R)) = _ + rw [same] + rfl + +/-- Every label and catalog in the public observer is coupled to the actual causal game on the physically executed wrapper. -/ +theorem observe_ideal (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (whole : DuplexModeGame.Counts Q (WHIRSourceBackfill.instrument (context registry) Q source select)) : + observe registry Q select (runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (WHIRSourceBackfill.instrument (context registry) Q source select) Q (Nat.le_refl Q) whole).view.result = + some (tableObservation registry Q ro seed source counted A sourceCounted select) := by + rw [ideal_output registry Q ro seed source counted select whole] + exact observe_table registry Q ro seed source counted A sourceCounted select + +/-- This event is determined by the public completed view alone. Missing or malformed completion data is not replaced by invented raw answers. -/ +def Failure (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (output : Completed (context registry) Q (Result cap R)) : Prop := + ∃ observed, observe registry Q select output = some observed ∧ + WHIRRawROM.Failure (context registry) rfl Q cap observed.state.catalog + (CausalBindingState.roots observed.state) (select output.result.value) observed.cache + +theorem failure_table_iff (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + Failure registry Q select (tableOutput registry Q ro seed source counted select) ↔ + WHIRRawROM.Failure (context registry) rfl Q cap + (tableObservation registry Q ro seed source counted A sourceCounted select).state.catalog + (CausalBindingState.roots + (tableObservation registry Q ro seed source counted A sourceCounted select).state) + (select (execution registry Q ro seed source counted).view.result.value) + (tableObservation registry Q ro seed source counted A sourceCounted select).cache := by + unfold Failure + rw [observe_table registry Q ro seed source counted A sourceCounted select] + simp only [Option.some.injEq] + constructor + · rintro ⟨observed,equal,bad⟩ + cases equal + exact bad + · intro bad + exact ⟨_,rfl,bad⟩ + +private instance : Finite UInt64 := + Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective +private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ + +open Classical in +/-- A public reconstructed-view event has the original causal ROM bound, for every fixed simulator seed. The raw allocation charge uses source budget A, not the larger physical key-domain bound Q. -/ +theorem public_table_list_binding (registry : Public) (Q : Nat) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (A : Nat) (sourceCounted : Counts A source) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : + average (fun ro : RawKey Q → Digest32 => + if Failure registry Q select (tableOutput registry Q ro seed source counted select) then 1 else 0) ≤ + min 1 (((allocationBudget (context registry) * (A+1) : Nat) : ℚ) * WHIRRawROM.epsilon cap) := by + have bound := WHIRCausalRawROM.raw_table_list_binding (context registry) rfl Q cap + (privateResolver registry Q seed source counted) (CausalBindingState.empty cap) + (selection registry Q select) (rawProgram registry Q seed source counted A sourceCounted) + convert bound using 1 + apply congrArg average + funext ro + rw [failure_table_iff registry Q ro seed source counted A sourceCounted select, + tableObservation_state] + have selected : selection registry Q select + (tableExecution (context registry) Q (selection registry Q select) + (rawProgram registry Q seed source counted A sourceCounted) ro).1 = + select (execution registry Q ro seed source counted).view.result.value := by + rw [tableExecution_result,rawProgram_eval] + rfl + rw [← selected] + rfl + +end Whir.WHIRObservableSource diff --git a/verification/whir/Whir/WHIRPhysicalBinding.lean b/verification/whir/Whir/WHIRPhysicalBinding.lean new file mode 100644 index 000000000..82f7a1282 --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalBinding.lean @@ -0,0 +1,357 @@ +import Whir.WHIRPhysicalDriver +import Whir.WHIRSourceFrozenPrefix +import Whir.WHIRSourceCatalog +import Whir.WHIRNativeEvent + +namespace Whir.WHIRPhysicalBinding +open Concrete Protocol FiatShamirGame DuplexModeGame MerkleTransport +open RawOracleCoupling RawOracleCoupling.Concrete +open WHIRPhysicalVerifier WHIRPhysicalReplay WHIRPhysicalSoundness +open PublicMerkleProgram (Runs) +set_option maxHeartbeats 800000 + +/-- Every sampler reply retained by the actual reader is the answer to that +same canonical physical coordinate, even though PoW and Merkle calls intervene. -/ +theorem readPhysicalPackets_real_history {cap : Nat} {R : Type} (C : PrimitiveOracle) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (lanes : Nat) (proofs : Array PrunedMerklePaths) + (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ packet ∈ packets, packet.val.profile = p) (state : WireState p) + (next : WireState p → List (Sigma (GroupAnswer ctx Q)) → WHIRSourceChronology.Source cap (Option R)) + (observations : List Observation) (result : R) + (answers : ∀ observation ∈ observations, observation.answer = realAnswer C ctx.iv observation.query) + (run : Runs (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q p lanes proofs none packets profiles state next)) observations (some result)) : + ∃ final suffix, Runs (WHIRSourceChronology.erase + (next final (WHIRModeFinal.realHistory ctx Q C packets))) suffix (some result) := by + induction packets generalizing state next observations with + | nil => exact ⟨state,observations,run⟩ + | cons packet packets ih => + simp only [readPhysicalPackets] at run + cases parsed : absorbResponse state (packet.val.messages.headD ⟨[],none⟩) with + | none => simp only [parsed,WHIRSourceChronology.erase] at run; cases run + | some value => + obtain ⟨absorbed,root⟩ := value + simp only [parsed] at run + split at run + · rw [announce_erase,sourceLift_erase] at run + obtain ⟨before,nonce,after,trace,_,continued⟩ := (Runs.bind_iff _ _).mp run + have afterAnswers : ∀ observation ∈ after, + observation.answer = realAnswer C ctx.iv observation.query := by + intro observation member + apply answers observation + rw [trace] + exact List.mem_append_right before member + cases boundNonce : afterNonce absorbed nonce with + | none => simp only [boundNonce,WHIRSourceChronology.erase] at continued; cases continued + | some bound => + simp only [boundNonce] at continued + split at continued + · rw [sourceLift_erase] at continued + obtain ⟨beforeRaw,raw,afterRaw,traceRaw,sampled,read⟩ := (Runs.bind_iff _ _).mp continued + have rawAnswers : ∀ observation ∈ beforeRaw, + observation.answer = realAnswer C ctx.iv observation.query := by + intro observation member + apply afterAnswers observation + rw [traceRaw] + exact List.mem_append_left afterRaw member + have actual := (PublicMerkleProgram.Runs.real_result_trace sampled C ctx.iv rawAnswers).1 + rw [readPacket_eq,WHIRModeProgram.readPacket_result] at actual + have sampleEq : raw = WHIRModeFinal.realPacket ctx Q C packet := actual.symm + rw [sourceLift_erase] at read + obtain ⟨beforeOpen,opened,afterOpen,traceOpen,_,rest⟩ := (Runs.bind_iff _ _).mp read + cases opened with + | none => cases rest + | some checked => + have restAnswers : ∀ observation ∈ afterOpen, + observation.answer = realAnswer C ctx.iv observation.query := by + intro observation member + apply afterAnswers observation + rw [traceRaw,traceOpen] + exact List.mem_append_right beforeRaw (List.mem_append_right beforeOpen member) + obtain ⟨final,suffix,last⟩ := ih _ _ _ _ restAnswers rest + refine ⟨final,suffix,?_⟩ + simpa only [WHIRModeFinal.realHistory,List.map_cons,sampleEq] using last + · cases continued + · cases run + +private theorem done_result {R : Type} (left right : R) (trace : List Observation) + (run : Runs (.done left) trace right) : left = right := by + cases run + rfl + +theorem verifySource_real_history (C : PrimitiveOracle) (cap : Nat) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q lanes : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (proofs : Array PrunedMerklePaths) (observations : List Observation) (v : Verified ctx Q cap packet) + (answers : ∀ observation ∈ observations, observation.answer = realAnswer C ctx.iv observation.query) + (run : Runs (WHIRSourceChronology.erase (verifySource cap model ctx stack Q lanes packet proofs)) + observations (some v)) : + v.history = WHIRModeFinal.realHistory ctx Q C (completion ctx Q packet) := by + obtain ⟨root,before,after,request,_,_,trace,_,_,decoded,physical⟩ := + WHIRPhysicalCaller.verifySource_success cap model ctx stack Q lanes packet proofs observations v run + have afterAnswers : ∀ observation ∈ after, + observation.answer = realAnswer C ctx.iv observation.query := by + intro observation member + apply answers observation + rw [trace] + exact List.mem_append_right before member + obtain ⟨wire,suffix,last⟩ := readPhysicalPackets_real_history C ctx stack Q packet.val.profile + request.lanes proofs (completion ctx Q packet) (completion_profiles ctx Q packet) + (initialWireState packet.val.profile root) _ after v afterAnswers physical + exact (WHIRPhysicalCaller.finish_success ctx Q cap packet request wire _ _ _ v + (done_result _ _ suffix last)).2.2 + +theorem local_realCompletion (C : PrimitiveOracle) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) : + localHistory ctx stack Q packet.val.profile + (WHIRModeFinal.realHistory ctx Q C (completion ctx Q packet)) = + WHIRModeReplay.history ctx stack Q packet (WHIRModeFinal.realCompletion ctx Q C (some packet)) := by + have callers : (WHIRModeFinal.realCallers ctx Q C packet + (WHIRModeFinal.callerPositions ctx Q packet)).filterMap (WHIRRawReplay.decodeEntry ctx stack Q) = [] := by + apply List.filterMap_eq_nil_iff.mpr + intro entry member + obtain ⟨position,_,equal⟩ := List.mem_map.mp member + subst entry + rfl + simp only [WHIRModeReplay.history,WHIRModeFinal.realCompletion,localHistory, + WHIRRawReplay.decodeHistory,List.filterMap_append,callers,List.nil_append] + rfl + +theorem verifySource_completed_history (C : PrimitiveOracle) (cap : Nat) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q lanes : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (proofs : Array PrunedMerklePaths) (observations : List Observation) (v : Verified ctx Q cap packet) + (answers : ∀ observation ∈ observations, observation.answer = realAnswer C ctx.iv observation.query) + (run : Runs (WHIRSourceChronology.erase (verifySource cap model ctx stack Q lanes packet proofs)) + observations (some v)) : + localHistory ctx stack Q packet.val.profile v.history = + WHIRModeReplay.history ctx stack Q packet (WHIRModeFinal.realCompletion ctx Q C (some packet)) := by + rw [verifySource_real_history C cap model ctx stack Q lanes packet proofs observations v answers run] + exact local_realCompletion C ctx stack Q packet + +/-- The accepted payload carries exactly the request decoded after the actual +caller prefix, not a second interpretation or an attacker-chosen claim object. -/ +theorem verifySource_decoded_request (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q lanes : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (v : Verified ctx Q cap packet) + (run : Runs (WHIRSourceChronology.erase (verifySource cap model ctx stack Q lanes packet proofs)) + observations (some v)) : + ∃ before after, observations = before ++ after ∧ + before.map Observation.query = (WHIRModeFinal.callerPositions ctx Q packet).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property)) ∧ + WHIRCallerClaims.decodeAvailableRequest cap packet.val.profile lanes model.layout + (RawWHIRKeys.entry ctx packet.val) (WHIRPhysicalCaller.latestAnswers before) = some v.request := by + obtain ⟨root,before,after,request,_,_,trace,_,queries,decoded,physical⟩ := + WHIRPhysicalCaller.verifySource_success cap model ctx stack Q lanes packet proofs observations v run + obtain ⟨wire,history,suffix,_,last⟩ := readPhysicalPackets_trace ctx stack Q packet.val.profile + request.lanes proofs (completion ctx Q packet) (completion_profiles ctx Q packet) + (initialWireState packet.val.profile root) _ after v physical + have same := (WHIRPhysicalCaller.finish_success ctx Q cap packet request wire history _ _ v + (done_result _ _ suffix last)).1 + exact ⟨before,after,trace,queries,by rw [same]; exact decoded⟩ + +theorem real_observation {cap : Nat} {R : Type} (registry : WHIRCallerRegistry.Public) (Q : Nat) + (C : PrimitiveOracle) (source : WHIRSourceChronology.Source cap R) + (counted : WHIRSourceChronology.Counts Q source) + (select : R → Option (RawWHIRKeys.Packet (WHIRCallerRegistry.context registry) Q)) + (whole : Counts Q (WHIRSourceBackfill.instrument (WHIRCallerRegistry.context registry) Q source select)) : + WHIRObservableSource.observe registry Q select + (runReal C registry.iv (WHIRSourceBackfill.instrument (WHIRCallerRegistry.context registry) Q source select)).view.result = + some (WHIRObservableSource.tableObservation registry Q (WHIRRealSimulator.rawTable Q C) C source + counted Q counted select) := by + rw [WHIRRealSimulator.real_ideal_view C registry.iv _ whole] + exact WHIRObservableSource.observe_ideal registry Q (WHIRRealSimulator.rawTable Q C) C source + counted Q counted select whole + +theorem real_observation_state {cap : Nat} {R : Type} (registry : WHIRCallerRegistry.Public) (Q : Nat) + (C : PrimitiveOracle) (source : WHIRSourceChronology.Source cap R) + (counted : WHIRSourceChronology.Counts Q source) + (select : R → Option (RawWHIRKeys.Packet (WHIRCallerRegistry.context registry) Q)) : + (WHIRObservableSource.tableObservation registry Q (WHIRRealSimulator.rawTable Q C) C source + counted Q counted select).state = + WHIRSourceFrozenPrefix.replayState registry Q C source counted + (WHIRSourceFrozenPrefix.allocationTrace registry Q select C source) := by + change WHIRSourceFrozenPrefix.replayState registry Q C source counted + (WHIRObservableSource.allocationTrace registry Q (WHIRRealSimulator.rawTable Q C) C source + counted Q counted select) = _ + rw [show WHIRObservableSource.allocationTrace registry Q (WHIRRealSimulator.rawTable Q C) C source + counted Q counted select = WHIRSourceFrozenPrefix.allocationTrace registry Q select C source from + WHIRSourceFrozenPrefix.allocationTrace_compiler registry Q select C source counted Q counted] + +/-- Canonical real completion and actual compiler cache completion describe the +same public failure event. No total oracle is added to the public observer. -/ +theorem real_mode_failure_public {cap : Nat} {R : Type} + (registry : WHIRCallerRegistry.Public) (Q : Nat) (C : PrimitiveOracle) + (source : WHIRSourceChronology.Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (select : R → Option (RawWHIRKeys.Packet (WHIRCallerRegistry.context registry) Q)) + (whole : Counts Q (WHIRSourceBackfill.instrument (WHIRCallerRegistry.context registry) Q source select)) + (failed : + let observed := WHIRObservableSource.tableObservation registry Q (WHIRRealSimulator.rawTable Q C) + C source counted Q counted select + let selected := select (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value + WHIRModeReplay.Failure (WHIRCallerRegistry.context registry) rfl Q cap observed.state.catalog + (CausalBindingState.roots observed.state) selected + (WHIRModeFinal.realCompletion (WHIRCallerRegistry.context registry) Q C selected)) : + WHIRObservableSource.Failure registry Q select + (runReal C registry.iv (WHIRSourceBackfill.instrument (WHIRCallerRegistry.context registry) Q source select)).view.result := by + let observed := WHIRObservableSource.tableObservation registry Q (WHIRRealSimulator.rawTable Q C) + C source counted Q counted select + have selected : + WHIRObservableSource.selection registry Q select + (tableExecution (WHIRCallerRegistry.context registry) Q (WHIRObservableSource.selection registry Q select) + (WHIRObservableSource.rawProgram registry Q C source counted Q counted) + (WHIRRealSimulator.rawTable Q C)).1 = + select (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value := by + rw [tableExecution_result,WHIRObservableSource.rawProgram_eval] + change select (WHIRObservableSource.execution registry Q (WHIRRealSimulator.rawTable Q C) + C source counted).view.result.value = _ + unfold WHIRObservableSource.execution + rw [← WHIRRealSimulator.real_ideal_view C registry.iv _ + ((WHIRSourceChronology.compile_counted source Q).mpr counted)] + have cached := (WHIRModeReplay.failure_iff_cache (WHIRCallerRegistry.context registry) rfl Q cap + observed.state.catalog (CausalBindingState.roots observed.state) + (WHIRObservableSource.selection registry Q select) + (WHIRObservableSource.rawProgram registry Q C source counted Q counted) + (WHIRRealSimulator.rawTable Q C)).mp (by + rw [selected,← WHIRRealSimulator.realCompletion_ideal] + exact failed) + refine ⟨observed,real_observation registry Q C source counted select whole,?_⟩ + erw [WHIRSourceBackfill.real_result (WHIRCallerRegistry.context registry) Q C source select,← selected] + exact cached + +/-- End-to-end deterministic native coverage for the public production driver. +The attacker supplies only input bytes/proofs; the trusted native verifier runs +once. Its accepted false fixed-list claim forces either the public ROM failure +or an explicitly witnessed ordinary Merkle failure on the same full-C trace. -/ +theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistry) (Q cap : Nat) + (C : PrimitiveOracle) (attacker : WHIRSourceChronology.Source cap (WHIRPhysicalDriver.Input registry.context Q)) + (counted : WHIRSourceChronology.Counts Q (WHIRPhysicalDriver.verifyAfter cap registry Q attacker)) + (whole : Counts Q (WHIRSourceBackfill.instrument registry.context Q + (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select)) + (failed : WHIRNativeEvent.Failure registry Q + (runReal C registry.iv (WHIRSourceBackfill.instrument registry.context Q + (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select)).view.result) : + WHIRObservableSource.Failure registry.publicRegistry Q WHIRPhysicalDriver.select + (runReal C registry.iv (WHIRSourceBackfill.instrument registry.context Q + (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select)).view.result ∨ + PublicMerkleProbability.FrozenOpeningBad C + (WHIRSourceRootPolicy.policy registry.publicRegistry Q WHIRPhysicalDriver.select + (WHIRPhysicalDriver.verifyAfter cap registry Q attacker)) + (PublicCompressionProgram.primitiveLog C registry.iv (WHIRSourceBackfill.instrument registry.context Q + (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select) Q whole) := by + let source := WHIRPhysicalDriver.verifyAfter cap registry Q attacker + let state := WHIRSourceFrozenPrefix.replayState registry.publicRegistry Q C source counted + (WHIRSourceFrozenPrefix.allocationTrace registry.publicRegistry Q WHIRPhysicalDriver.select C source) + have sourceResultEq := congrArg (fun output : WHIRNativeEvent.Output registry Q cap => output.result) + (WHIRSourceBackfill.real_result registry.context Q C source WHIRPhysicalDriver.select) + have observedEq := real_observation registry.publicRegistry Q C source counted WHIRPhysicalDriver.select whole + obtain ⟨observed,seen,wrong⟩ := failed + have same := Option.some.inj (seen.symm.trans observedEq) + subst observed + erw [real_observation_state,sourceResultEq] at wrong + change WHIRPhysicalDriver.nativeWrong state + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value at wrong + cases returned : (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value with + | none => + rw [returned] at wrong + exact False.elim wrong + | some accepted => + rw [returned] at wrong + obtain ⟨input,v,chosen,nativeReturned,acceptedEq,events⟩ := + WHIRPhysicalDriver.real_native_segment C registry.iv cap registry Q attacker accepted returned + cases acceptedEq + let nativeSource := verifySource cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs + let nativeObs := WHIRSourceChronology.observations + (runReal C registry.iv (WHIRSourceChronology.compile nativeSource)).view.result.events + have nativeRun : Runs (WHIRSourceChronology.erase nativeSource) nativeObs (some v) := by + have run := WHIRPhysicalCaller.real_source_runs C registry.iv nativeSource + rw [nativeReturned] at run + exact run + have nativeAnswers : ∀ observation ∈ nativeObs, + observation.answer = realAnswer C registry.iv observation.query := by + intro observation member + apply PublicMerkleProgram.runReal_answers C registry.iv (WHIRSourceChronology.compile nativeSource) observation + rw [← WHIRSourceChronology.real_source_trace] + exact member + have nativeCounted : WHIRSourceChronology.Counts Q nativeSource := by + have prefixRun := WHIRPhysicalCaller.real_source_runs C registry.iv attacker + rw [← chosen] at prefixRun + apply (WHIRSourceChronology.Source.map_counted nativeSource _ Q).mp + exact WHIRSourceChronology.Source.bind_suffix_counted attacker + (WHIRPhysicalDriver.verifier cap registry Q) Q _ input prefixRun counted + have selected : WHIRPhysicalDriver.select + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value = some input.packet := by + rw [returned] + rfl + obtain ⟨before,after,callerTrace,queries,decoded⟩ := verifySource_decoded_request cap + (registry.packetModel Q input.packet) registry.context rfl Q (registry.packetLanes Q input.packet) + input.packet input.proofs nativeObs v nativeRun + have registeredDecode : WHIRCallerClaims.decodeAvailableRequest cap input.packet.val.profile + (WHIRCallerClaims.callerLanes (WHIRCallerRegistry.packetLayout registry.publicRegistry Q input.packet)) + (WHIRCallerRegistry.packetLayout registry.publicRegistry Q input.packet) + (WHIRRawReplay.callerEntry registry.context Q input.packet) (WHIRPhysicalCaller.latestAnswers before) = some v.request := by + simpa only [WHIRPhysicalDriver.ProductionRegistry.packetLanes,registry.packetModel_layout, + WHIRRawReplay.callerEntry] using decoded + have captured := WHIRSourceCatalog.final_catalog_real registry.publicRegistry Q cap C source counted + input.packet WHIRPhysicalDriver.select selected nativeSource nativeCounted before after callerTrace queries + v.request registeredDecode + have prepared := WHIRSourceCatalog.final_prepared_real registry.publicRegistry Q cap C source counted + input.packet WHIRPhysicalDriver.select selected [] + obtain ⟨past,cursor,_⟩ := WHIRSourceFrozenPrefix.allocation_prefix_cursor registry.publicRegistry Q + WHIRPhysicalDriver.select C source counted + (WHIRSourceFrozenPrefix.allocationTrace registry.publicRegistry Q WHIRPhysicalDriver.select C source) [] + (by simp) + have execution := verifySource_execution cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs nativeObs v nativeRun + rcases trace_boundRows_or_bad C registry.iv input.packet input.proofs v nativeObs nativeAnswers + execution.2 execution.1 state cursor.physical captured.2 prepared with bound | bad + · left + have found : WHIRRawROM.localCatalog state.catalog input.packet.val.profile + (WHIRRawReplay.callerEntry registry.context Q input.packet) input.packet.val.statement = + some (committedStatement v state) := by + simp only [WHIRRawROM.localCatalog,WHIRRawReplay.callerEntry,RawWHIRKeys.entry,ite_true] + exact captured.1 + have nativeFailed := verifySource_native_historyFailure cap (registry.packetModel Q input.packet) + registry.context rfl Q (registry.packetLanes Q input.packet) input.packet input.proofs nativeObs v nativeRun + state _ found bound wrong + rw [verifySource_completed_history C cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs nativeObs v nativeAnswers nativeRun] at nativeFailed + apply real_mode_failure_public registry.publicRegistry Q C source counted WHIRPhysicalDriver.select whole + dsimp only + erw [real_observation_state,selected] + exact ⟨input.packet,rfl,nativeFailed⟩ + · right + obtain ⟨opening,member,oldLog,frozen,bad⟩ := bad + obtain ⟨snapshot,known⟩ := trace_opening_registered input.packet v.request.root + (completion_chain registry.context Q input.packet) execution.1 state captured.2 prepared opening member + obtain ⟨_,newLog,before,after,_,newFrozen,freeze,prior,ordinary,registered,_⟩ := + WHIRSourceFrozenPrefix.actual_backfill_retained registry.publicRegistry Q WHIRPhysicalDriver.select + C source counted Q whole opening.root snapshot known + have logs : oldLog = newLog := Option.some.inj (frozen.symm.trans newFrozen) + subst newLog + have nativeSubset : ∀ observation ∈ nativeObs, + observation ∈ (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations := by + intro observation present + rw [← WHIRSourceChronology.real_source_trace,events,WHIRSourceChronology.observations_append] + exact List.mem_append_right _ present + have executed : ∀ n d, (⟨.primitive .verification n,d⟩ : Observation) ∈ nativeObs → + (n,d) ∈ PublicCompressionProgram.primitiveLog C registry.iv + (WHIRSourceBackfill.instrument registry.context Q source WHIRPhysicalDriver.select) Q whole := by + intro n d present + have expanded := WHIRSourceFrozenPrefix.primitive_expand C registry.iv + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations + (PublicMerkleProgram.runReal_answers C registry.iv (WHIRSourceChronology.compile source)) + .verification n d (nativeSubset _ present) + rw [WHIRSourceFrozenPrefix.expand_real C registry.iv (WHIRSourceChronology.compile source) Q + ((WHIRSourceChronology.compile_counted source Q).mpr counted)] at expanded + obtain ⟨suffix,equal⟩ := WHIRSourceFrozenPrefix.backfill_prefix registry.publicRegistry Q + WHIRPhysicalDriver.select C source counted Q whole + erw [← equal] + exact List.mem_append_left suffix expanded + exact observed_frozen_bad (execution.2 opening member) C registry.iv nativeAnswers _ _ before after oldLog + freeze prior ordinary registered executed bad + +end Whir.WHIRPhysicalBinding diff --git a/verification/whir/Whir/WHIRPhysicalCaller.lean b/verification/whir/Whir/WHIRPhysicalCaller.lean new file mode 100644 index 000000000..2a7c6cf82 --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalCaller.lean @@ -0,0 +1,536 @@ +import Whir.WHIRPhysicalVerifier +import Whir.WHIRSourceResolver + +/-! Operational caller-input provenance for the actual physical verifier. +Only the source-owned `Result.events` observations are used; mode-completion +queries are not part of this prefix. The caller reader's finite answers are +exactly its latest matching construction observations, and are transported to +the concrete public-layout registry without a decoder-correctness premise. + +`callerHistory` is a finite provenance projection, not a replacement decoder. +`packetRequest_compiled_prefix` connects the original source prefix to the +actual raw allocation compiler's dependency history, even for early prequeries. +Production resolver claims continue to use `packetRequest` on that history: +neither source announcements nor future WHIR samples enter its decoder. -/ +namespace Whir.WHIRPhysicalCaller +open Concrete Protocol FiatShamirGame DuplexModeGame PublicMerkleProgram +open RawOracleCoupling RawOracleCoupling.Concrete WHIRPhysicalVerifier +open WHIRCallerClaims WHIRCallerRegistry +open RawWHIRKeys (Context Packet) +set_option maxHeartbeats 800000 + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +/-- One observed construction updates only its literal full coordinate. Public +primitive calls and different caller-entry clones cannot supply its answer. -/ +def observeAt (wanted : Coordinate) (previous : Option Digest32) (observation : Observation) : Option Digest32 := + match observation.query with + | .primitive _ _ => previous + | .construction coordinate _ => if wanted = coordinate then some observation.answer else previous + +def observedAnswers (trace : List Observation) (initial : Coordinate → Option Digest32) : + Coordinate → Option Digest32 := + fun wanted => trace.foldl (observeAt wanted) (initial wanted) + +def latestAnswers (trace : List Observation) : Coordinate → Option Digest32 := + observedAnswers trace (fun _ => none) + +theorem observedAnswers_cons (observation : Observation) (rest : List Observation) + (initial : Coordinate → Option Digest32) : + observedAnswers (observation :: rest) initial = + observedAnswers rest (fun wanted => observeAt wanted (initial wanted) observation) := rfl + +theorem observedAnswers_append (before after : List Observation) (initial : Coordinate → Option Digest32) : + observedAnswers (before ++ after) initial = observedAnswers after (observedAnswers before initial) := by + funext wanted + simp only [observedAnswers,List.foldl_append] + +theorem observedAnswers_unchanged (trace : List Observation) (initial : Coordinate → Option Digest32) + (wanted : Coordinate) + (absent : ∀ observation ∈ trace, ∀ valid, + observation.query ≠ .construction wanted valid) : + observedAnswers trace initial wanted = initial wanted := by + induction trace generalizing initial with + | nil => rfl + | cons observation rest ih => + rw [observedAnswers_cons,ih _ (fun observation member => absent observation (List.mem_cons_of_mem _ member))] + cases observation with + | mk query answer => + cases query with + | primitive => rfl + | construction coordinate valid => + have different : wanted ≠ coordinate := by + intro same + subst coordinate + exact absent ⟨.construction wanted valid,answer⟩ List.mem_cons_self valid rfl + exact ite_eq_right different + +/-- This characterizes the answer by the latest matching construction, rather +than merely asserting membership in an unstructured list of replies. -/ +theorem observedAnswers_latest (before after : List Observation) + (initial : Coordinate → Option Digest32) (wanted : Coordinate) + (valid : DuplexEncoding.Admissible wanted) (answer : Digest32) + (last : ∀ observation ∈ after, ∀ proof, + observation.query ≠ .construction wanted proof) : + observedAnswers (before ++ ⟨.construction wanted valid,answer⟩ :: after) initial wanted = some answer := by + rw [observedAnswers_append,observedAnswers_cons,observedAnswers_unchanged _ _ wanted last] + simp [observeAt] + +/-- Exact continuation inversion for arbitrary operational runs. Queries are +not inferred from a claimed transcript: they are forced by `readCallerInputs`. -/ +theorem readCallerInputs_run {cap : Nat} {R : Type} (ctx : Context) (Q : Nat) + (packet : Packet ctx Q) (positions : List (WHIRModeFinal.CallerPosition ctx Q packet)) + (initial : Coordinate → Option Digest32) + (next : (Coordinate → Option Digest32) → WHIRSourceChronology.Source cap R) + (trace : List Observation) (result : R) + (run : Runs (WHIRSourceChronology.erase (readCallerInputs ctx Q packet positions initial next)) trace result) : + ∃ before after, trace = before ++ after ∧ before.length = positions.length ∧ + before.map Observation.query = positions.map (fun q => Query.construction q.val + (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property)) ∧ + Runs (WHIRSourceChronology.erase (next (observedAnswers before initial))) after result := by + induction positions generalizing initial trace with + | nil => exact ⟨[],trace,rfl,rfl,rfl,run⟩ + | cons q qs ih => + change Runs (.ask (.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property)) + (fun answer => WHIRSourceChronology.erase (readCallerInputs ctx Q packet qs + (fun key => if key = q.val then some answer else initial key) next))) trace result at run + cases run with + | ask answer continued => + obtain ⟨before,after,traceEq,count,queries,last⟩ := ih _ _ continued + refine ⟨⟨.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property),answer⟩ :: before, + after,by simp [traceEq],by simp [count],by simp [queries],?_⟩ + exact last + +private theorem map_run {R S : Type} (f : R → S) (program : Program R) + (trace : List Observation) (result : S) + (run : Runs (WHIRSourceChronology.map f program) trace result) : + ∃ value, Runs program trace value ∧ f value = result := by + induction program generalizing trace result with + | done value => + cases run + exact ⟨value,.done value,rfl⟩ + | ask query next ih => + cases run with + | ask answer continued => + obtain ⟨value,run,equal⟩ := ih answer _ _ continued + exact ⟨value,.ask answer run,equal⟩ + +/-- Compiling source annotations neither invents observations nor changes the +operational result. This applies to arbitrary finite runs, including ideal +executions, without referring to a simulator's backfilled mode view. -/ +theorem compile_run {cap : Nat} {R : Type} (source : WHIRSourceChronology.Source cap R) + (trace : List Observation) (result : WHIRSourceChronology.Result cap R) + (run : Runs (WHIRSourceChronology.compile source) trace result) : + Runs (WHIRSourceChronology.erase source) trace result.value ∧ + WHIRSourceChronology.observations result.events = trace := by + induction source generalizing trace result with + | done value => + cases run + exact ⟨.done value,rfl⟩ + | ask query next ih => + cases run with + | ask answer continued => + obtain ⟨value,continuedRun,rfl⟩ := map_run + (WHIRSourceChronology.prepend (.answer query answer)) (WHIRSourceChronology.compile (next answer)) _ _ continued + obtain ⟨erased,observed⟩ := ih answer _ _ continuedRun + exact ⟨.ask answer erased,congrArg (List.cons (⟨query,answer⟩ : Observation)) observed⟩ + | commit root next ih => + obtain ⟨value,continuedRun,rfl⟩ := map_run + (WHIRSourceChronology.prepend (.commit root)) (WHIRSourceChronology.compile next) _ _ run + exact ih trace value continuedRun + | claims profile entry request next ih => + obtain ⟨value,continuedRun,rfl⟩ := map_run + (WHIRSourceChronology.prepend (.claims profile entry request)) (WHIRSourceChronology.compile next) _ _ run + exact ih trace value continuedRun + +theorem ideal_source_runs {Q cap : Nat} {Seed State R : Type} (sim : Simulator Q Seed State) + (table : RawKey Q → Digest32) (iv : Digest32) (state : State) + (source : WHIRSourceChronology.Source cap R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : WHIRSourceChronology.Counts remaining source) : + let result := (runIdeal sim table iv state (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted)).view.result + Runs (WHIRSourceChronology.erase source) (WHIRSourceChronology.observations result.events) result.value := by + dsimp only + obtain ⟨run,observed⟩ := compile_run source _ _ + (runIdeal_runs sim table iv state (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted)) + rw [observed] + exact run + +/-- Runs of the source-owned result use precisely `Result.events`, excluding +any backfilled completion records appended by an outer mode experiment. -/ +theorem real_source_runs {cap : Nat} {R : Type} (oracle : PrimitiveOracle) (iv : Digest32) + (source : WHIRSourceChronology.Source cap R) : + Runs (WHIRSourceChronology.erase source) + (WHIRSourceChronology.observations (runReal oracle iv (WHIRSourceChronology.compile source)).view.result.events) + (runReal oracle iv (WHIRSourceChronology.compile source)).view.result.value := by + have erase := congrArg Execution.view (WHIRSourceChronology.real_source_erasure oracle iv source) + have observations := congrArg View.observations erase + have value := congrArg View.result erase + change (runReal oracle iv (WHIRSourceChronology.compile source)).view.observations = _ at observations + change (runReal oracle iv (WHIRSourceChronology.compile source)).view.result.value = _ at value + rw [WHIRSourceChronology.real_source_trace,observations,value] + exact runReal_runs oracle iv (WHIRSourceChronology.erase source) + +/-- Concrete keys for distinct prior caller coordinates cannot alias. -/ +theorem caller_key_injective (ctx : Context) (Q : Nat) (packet : Packet ctx Q) + (a b : WHIRModeFinal.CallerPosition ctx Q packet) + (same : RawWHIRKeys.callerOutputKey ctx Q packet a.val a.property = + RawWHIRKeys.callerOutputKey ctx Q packet b.val b.property) : a.val = b.val := by + apply constructionKey_injective Q ctx.iv + (RawWHIRKeys.callerOutput_admissible ctx Q packet a.val a.property) + (RawWHIRKeys.callerOutput_admissible ctx Q packet b.val b.property) + (RawWHIRKeys.callerOutput_pathBound ctx Q packet a.val a.property) + (RawWHIRKeys.callerOutput_pathBound ctx Q packet b.val b.property) + exact congrArg Subtype.val same + +/-- The finite caller history recovered from actual observations is newest +first, matching the last-write semantics of the source reader. -/ +def addCallerObservation (ctx : Context) (Q : Nat) (packet : Packet ctx Q) + (history : List (Sigma (GroupAnswer ctx Q))) (observation : Observation) : + List (Sigma (GroupAnswer ctx Q)) := + match observation.query with + | .primitive _ _ => history + | .construction coordinate _ => + if prior : coordinate ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val) then + ⟨.inr (RawWHIRKeys.callerOutputKey ctx Q packet coordinate prior),observation.answer⟩ :: history + else history + +def callerHistory (ctx : Context) (Q : Nat) (packet : Packet ctx Q) (trace : List Observation) : + List (Sigma (GroupAnswer ctx Q)) := + trace.foldl (addCallerObservation ctx Q packet) [] + +theorem callerAnswers_addObservation (ctx : Context) (Q : Nat) (packet : Packet ctx Q) + (history : List (Sigma (GroupAnswer ctx Q))) (observation : Observation) + (wanted : Coordinate) (prior : wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val)) : + callerAnswers ctx Q packet (addCallerObservation ctx Q packet history observation) wanted = + observeAt wanted (callerAnswers ctx Q packet history wanted) observation := by + cases observation with + | mk query answer => + cases query with + | primitive => rfl + | construction coordinate valid => + by_cases known : coordinate ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val) + · simp only [addCallerObservation,dite_eq_left known,callerAnswers,dite_eq_left prior,garbageAnswer,observeAt] + by_cases same : wanted = coordinate + · subst coordinate + split + · simp + · rename_i different + exact False.elim (different rfl) + · have keys : RawWHIRKeys.callerOutputKey ctx Q packet coordinate known ≠ + RawWHIRKeys.callerOutputKey ctx Q packet wanted prior := by + intro equal + exact same (caller_key_injective ctx Q packet ⟨coordinate,known⟩ ⟨wanted,prior⟩ equal).symm + split + · rename_i equal + exact False.elim (keys equal) + · rfl + · have different : wanted ≠ coordinate := fun equal => known (equal ▸ prior) + simp only [addCallerObservation,dite_eq_right known,observeAt,ite_eq_right different] + +theorem callerAnswers_foldObservations (ctx : Context) (Q : Nat) (packet : Packet ctx Q) + (trace : List Observation) (history : List (Sigma (GroupAnswer ctx Q))) + (wanted : Coordinate) (prior : wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val)) : + callerAnswers ctx Q packet (trace.foldl (addCallerObservation ctx Q packet) history) wanted = + observedAnswers trace (callerAnswers ctx Q packet history) wanted := by + induction trace generalizing history with + | nil => rfl + | cons observation rest ih => + rw [List.foldl_cons,ih] + change rest.foldl (observeAt wanted) + (callerAnswers ctx Q packet (addCallerObservation ctx Q packet history observation) wanted) = _ + rw [callerAnswers_addObservation ctx Q packet history observation wanted prior] + rfl + +theorem callerAnswers_history (ctx : Context) (Q : Nat) (packet : Packet ctx Q) + (trace : List Observation) (wanted : Coordinate) + (prior : wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val)) : + callerAnswers ctx Q packet (callerHistory ctx Q packet trace) wanted = latestAnswers trace wanted := by + rw [callerHistory,callerAnswers_foldObservations ctx Q packet trace [] wanted prior] + change trace.foldl (observeAt wanted) (callerAnswers ctx Q packet [] wanted) = _ + simp only [callerAnswers,dite_eq_left prior,garbageAnswer] + rfl + +theorem packetRequest_observations (registry : Public) (Q cap : Nat) + (packet : Packet (context registry) Q) (trace : List Observation) : + packetRequest registry Q cap packet (callerHistory (context registry) Q packet trace) = + decodeAvailableRequest cap packet.val.profile (callerLanes (packetLayout registry Q packet)) + (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) (latestAnswers trace) := by + apply decodeAvailableRequest_prior_only + exact callerAnswers_history (context registry) Q packet trace + +/-- Accepted physical decoding fixes lanes from the same public source layout. -/ +theorem decoded_lanes (cap : Nat) (profile : ParameterBounds.Profile) (lanes : Nat) + (layout : CallerLayout) (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (request : CausalBindingState.ClaimRequest cap profile) + (accepted : decodeAvailableRequest cap profile lanes layout entry answers = some request) : + lanes = callerLanes layout := by + have metadata : openingMatches profile lanes layout = true := by + cases h : openingMatches profile lanes layout with + | false => + simp [decodeAvailableRequest,decodeRequest_wrong_metadata cap profile lanes layout entry + (fun q => (answers q).getD DuplexRefinement.zeroDigest) h] at accepted + | true => rfl + simp only [openingMatches,Bool.and_eq_true,beq_iff_eq] at metadata + exact metadata.1.1 + +/-- The physical caller's decoder is the concrete registry decoder for this +publicly registered production model; no future source announcement is read. -/ +theorem decoded_packetRequest (registry : Public) (Q cap lanes : Nat) + (model : WHIRCallerSupport.ProductionLayout) (packet : Packet (context registry) Q) + (registered : registry.layouts packet.val.statement = some model.layout) + (trace : List Observation) (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (accepted : decodeAvailableRequest cap packet.val.profile lanes model.layout + (RawWHIRKeys.entry (context registry) packet.val) (latestAnswers trace) = some request) : + packetRequest registry Q cap packet (callerHistory (context registry) Q packet trace) = some request := by + have layout : model.layout = packetLayout registry Q packet := + Option.some.inj (registered.symm.trans (packet_geometry registry Q packet).1) + have lanesEq := decoded_lanes cap packet.val.profile lanes model.layout + (RawWHIRKeys.entry (context registry) packet.val) (latestAnswers trace) request accepted + rw [packetRequest_observations,← layout,← lanesEq] + exact accepted + +/-- Successful arithmetic completion preserves exactly the computed request, +wire state and packet-answer history supplied to `finish`. -/ +theorem finish_success (ctx : Context) (Q cap : Nat) (packet : Packet ctx Q) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) (state : WireState packet.val.profile) + (history : List (Sigma (GroupAnswer ctx Q))) + (nativeShapes : SuccinctRingWeight.FamilyShape (ParameterBounds.config packet.val.profile).logN request.claims.family ∧ + ∀ point ∈ request.claims.points.toList, SuccinctPointWeight.Shape (ParameterBounds.config packet.val.profile).logN point) + (claimShapes : ∀ (seed : RingPCSGame.Prefix) (lambda : E), + let c := ParameterBounds.config packet.val.profile + let claims := RingPCSGame.transformedClaims (2^c.logN) request.claims.family request.claims.points seed + (claims.all (fun claim => Protocol.shapeValid c request.lanes claim.weight) = true) ∧ + Protocol.shapeValid c request.lanes (CausalGame.batchClaims (2^c.logN) claims lambda).weight = true) + (verified : Verified ctx Q cap packet) + (accepted : finish ctx Q cap packet request state history nativeShapes claimShapes = some verified) : + verified.request = request ∧ verified.wire = state ∧ verified.history = history := by + unfold finish at accepted + split at accepted + · cases accepted + · dsimp only at accepted + split at accepted + · cases accepted + · split at accepted + · cases accepted + · cases Option.some.inj accepted + exact ⟨rfl,rfl,rfl⟩ + +/-- Success in the actual source forces its initial-root read, the complete +caller query prefix, original source decoding, and the actual physical reader. +The shape witnesses below are computed from the decoder equation, not premises. -/ +theorem verifySource_success (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : Context) (stack : ctx.mode = .stack) (Q lanes : Nat) + (packet : Packet ctx Q) (proofs : Array MerkleTransport.PrunedMerklePaths) + (trace : List Observation) (verified : Verified ctx Q cap packet) + (run : Runs (WHIRSourceChronology.erase (verifySource cap model ctx stack Q lanes packet proofs)) + trace (some verified)) : + ∃ (root : Digest32) (before after : List Observation) (request : CausalBindingState.ClaimRequest cap packet.val.profile), + initialRoot model.layout (RawWHIRKeys.entry ctx packet.val) = some root ∧ + root = request.root ∧ trace = before ++ after ∧ + before.length = (WHIRModeFinal.callerPositions ctx Q packet).length ∧ + before.map Observation.query = (WHIRModeFinal.callerPositions ctx Q packet).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property)) ∧ + ∃ decoded : decodeAvailableRequest cap packet.val.profile lanes model.layout + (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) = some request, + Runs (WHIRSourceChronology.erase + (readPhysicalPackets (cap := cap) ctx stack Q packet.val.profile request.lanes proofs none + (completion ctx Q packet) (completion_profiles ctx Q packet) + (initialWireState packet.val.profile root) + (fun state history => .done (finish ctx Q cap packet request state history + (WHIRCallerSupport.decodeAvailableRequest_nativeShapes model cap packet.val.profile lanes + (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) request decoded) + (WHIRCallerSupport.decodeAvailableRequest_shapes model cap packet.val.profile lanes + (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) request decoded))))) + after (some verified) := by + unfold verifySource at run + cases rootRead : initialRoot model.layout (RawWHIRKeys.entry ctx packet.val) with + | none => + simp only [rootRead,WHIRSourceChronology.erase] at run + cases run + | some root => + simp only [rootRead,WHIRSourceChronology.erase] at run + obtain ⟨before,after,traceEq,count,queries,continued⟩ := readCallerInputs_run ctx Q packet + (WHIRModeFinal.callerPositions ctx Q packet) (fun _ => none) _ trace (some verified) run + split at continued + · cases continued + · rename_i request decoded + have rootEq : root = request.root := Option.some.inj (rootRead.symm.trans + (decodeAvailableRequest_initialRoot cap packet.val.profile lanes model.layout + (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) request decoded)) + exact ⟨root,before,after,request,rfl,rootEq,traceEq,count,queries,decoded,continued⟩ + +/-- The concrete public resolver uses the same decoded claims, independently +of its source annotations and pre-registration state. -/ +theorem publicResolver_observations {R : Type} (registry : Public) (Q cap : Nat) + (result : WHIRSourceChronology.Result cap R) (state : CausalBindingState.State cap) + (packet : Packet (context registry) Q) (trace : List Observation) : + (WHIRSourceResolver.publicResolver registry Q result).claims state packet + (callerHistory (context registry) Q packet trace) = + decodeAvailableRequest cap packet.val.profile (callerLanes (packetLayout registry Q packet)) + (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) (latestAnswers trace) := + packetRequest_observations registry Q cap packet trace + +theorem privateResolver_observations {R : Type} (registry : Public) (Q cap : Nat) + (seed : DuplexPublicSimulator.Seed) (source : WHIRSourceChronology.Source cap R) + (counted : WHIRSourceChronology.Counts Q source) (state : CausalBindingState.State cap) + (packet : Packet (context registry) Q) (trace : List Observation) : + (WHIRSourceResolver.privateResolver registry Q seed source counted).claims state packet + (callerHistory (context registry) Q packet trace) = + decodeAvailableRequest cap packet.val.profile (callerLanes (packetLayout registry Q packet)) + (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) (latestAnswers trace) := + packetRequest_observations registry Q cap packet trace + +/-- Construction observations in a genuine ideal execution have their literal +raw-table values, even when arbitrary primitive simulator calls intervene. -/ +theorem ideal_construction_answers {Q : Nat} {Seed State R : Type} (sim : Simulator Q Seed State) + (table : RawKey Q → Digest32) (iv : Digest32) (state : State) (program : Program R) + (remaining : Nat) (limit : remaining ≤ Q) (counted : DuplexModeGame.Counts remaining program) : + ∀ observation ∈ (runIdeal sim table iv state program remaining limit counted).view.observations, + ∀ (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (bound : DuplexFraming.pathCost coordinate ≤ Q), + observation.query = .construction coordinate valid → + observation.answer = table (constructionKey Q iv coordinate bound) := by + induction program generalizing state remaining with + | done value => simp only [runIdeal,List.not_mem_nil,false_implies,implies_true] + | ask query next ih => + cases query with + | primitive purpose input => + intro observation member coordinate valid bound equal + simp only [runIdeal,DuplexModeGame.prepend,List.mem_cons] at member + rcases member with head | member + · subst observation + cases equal + · exact ih (runRO table (sim.answer state input)).1.2 + (runRO table (sim.answer state input)).1.1 (remaining-1) (by omega) + (counted.2 _) observation member coordinate valid bound equal + | construction query validQuery => + intro observation member coordinate valid bound equal + simp only [runIdeal,DuplexModeGame.prepend,List.mem_cons] at member + rcases member with head | member + · subst observation + cases equal + rfl + · exact ih (table (constructionKey Q iv query (counted.1.trans limit))) state + (remaining-DuplexFraming.pathCost query) (by omega) + (counted.2 _) observation member coordinate valid bound equal + +private theorem observedAnswers_stable (trace : List Observation) (wanted : Coordinate) + (answer : Digest32) + (consistent : ∀ observation ∈ trace, ∀ valid, + observation.query = .construction wanted valid → observation.answer = answer) : + trace.foldl (observeAt wanted) (some answer) = some answer := by + induction trace with + | nil => rfl + | cons observation rest ih => + have stable : observeAt wanted (some answer) observation = some answer := by + cases observation with + | mk query value => + cases query with + | primitive => rfl + | construction coordinate valid => + by_cases equal : wanted = coordinate + · subst coordinate + have valueEq : value = answer := + consistent ⟨.construction wanted valid,value⟩ List.mem_cons_self valid rfl + subst value + simp [observeAt] + · simp only [observeAt,ite_eq_right equal] + rw [List.foldl_cons,stable] + exact ih (fun observation member => consistent observation (List.mem_cons_of_mem _ member)) + +theorem latestAnswers_consistent (trace : List Observation) (wanted : Coordinate) + (valid : DuplexEncoding.Admissible wanted) (answer : Digest32) + (present : ∃ observation ∈ trace, observation.query = .construction wanted valid) + (consistent : ∀ observation ∈ trace, ∀ proof, + observation.query = .construction wanted proof → observation.answer = answer) : + latestAnswers trace wanted = some answer := by + obtain ⟨observation,member,query⟩ := present + have value := consistent observation member valid query + obtain ⟨before,after,traceEq⟩ := List.append_of_mem member + subst trace + unfold latestAnswers + rw [observedAnswers_append,observedAnswers_cons] + change after.foldl (observeAt wanted) (observeAt wanted _ observation) = _ + have observed : observeAt wanted (observedAnswers before (fun _ => none) wanted) observation = some answer := by + simp [observeAt,query,value] + rw [observed] + exact observedAnswers_stable after wanted answer + (fun observation member => consistent observation (List.mem_append_right _ (List.mem_cons_of_mem _ member))) + +/-- The source-owned ideal prefix gives all and only the earlier caller table +answers needed by the production decoder. The full source's future observations +are used only to prove consistency of this already-fixed finite prefix. -/ +theorem ideal_caller_prefix {Q cap : Nat} {Seed State R : Type} + (ctx : Context) (packet : Packet ctx Q) (sim : Simulator Q Seed State) + (table : RawKey Q → Digest32) (state : State) + (source : WHIRSourceChronology.Source cap R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : WHIRSourceChronology.Counts remaining source) + (before after : List Observation) + (sourcePrefix : WHIRSourceChronology.observations + (runIdeal sim table ctx.iv state (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted)).view.result.events = before ++ after) + (queries : before.map Observation.query = (WHIRModeFinal.callerPositions ctx Q packet).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property))) : + ∀ wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val), + latestAnswers before wanted = tableCallerAnswers ctx Q packet table wanted := by + intro wanted prior + have queried : Query.construction wanted (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) ∈ + before.map Observation.query := by + rw [queries] + exact List.mem_map.mpr ⟨⟨wanted,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨observation,member,equal⟩ := List.mem_map.mp queried + simp only [tableCallerAnswers,dite_eq_left prior] + apply latestAnswers_consistent before wanted + (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) _ + ⟨observation,member,equal⟩ + intro observation member valid equal + have inRun : observation ∈ + (runIdeal sim table ctx.iv state (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted)).view.observations := by + rw [← WHIRSourceResolver.ideal_source_trace sim table ctx.iv state source remaining limit counted,sourcePrefix] + exact List.mem_append_left _ member + exact ideal_construction_answers sim table ctx.iv state (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted) observation inRun wanted valid + (RawWHIRKeys.callerOutput_pathBound ctx Q packet wanted prior) equal + +/-- The *actual allocation compiler dependency history*, including early raw +prequeries before source claim announcements, decodes the same request as the +actual caller's source-owned prefix. Both provenances are obtained from their +executions against the same immutable table, not assumed decoder agreement. -/ +theorem packetRequest_compiled_prefix {R S Seed State : Type} {K : Nat} + (registry : Public) (Q cap : Nat) (packet : Packet (context registry) Q) + (final : R → Option (Packet (context registry) Q)) + (program : TypedOracleCompiler.Sampling (RawKey Q) (fun _ => Digest32) R K) + (table : RawKey Q → Digest32) (allocation : Sigma (AllocationAnswer (context registry) Q)) + (member : allocation ∈ (TypedOracleCompiler.Sampling.execute + (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (RawOracleCoupling.Concrete.compile (context registry) Q final program)).2) + (key : allocation.1.1 = .inl packet) + (sim : Simulator Q Seed State) (state : State) (source : WHIRSourceChronology.Source cap S) + (remaining : Nat) (limit : remaining ≤ Q) (counted : WHIRSourceChronology.Counts remaining source) + (before after : List Observation) + (sourcePrefix : WHIRSourceChronology.observations + (runIdeal sim table (context registry).iv state (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted)).view.result.events = before ++ after) + (queries : before.map Observation.query = (WHIRModeFinal.callerPositions (context registry) Q packet).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible (context registry) Q packet q.val q.property))) : + packetRequest registry Q cap packet allocation.1.2 = + decodeAvailableRequest cap packet.val.profile (callerLanes (packetLayout registry Q packet)) + (packetLayout registry Q packet) (RawWHIRKeys.entry (context registry) packet.val) (latestAnswers before) := by + rw [packetRequest_table_compile registry Q cap final program table allocation member packet key] + apply decodeAvailableRequest_prior_only + intro wanted prior + exact (ideal_caller_prefix (context registry) packet sim table state source remaining limit counted + before after sourcePrefix queries wanted prior).symm + +end Whir.WHIRPhysicalCaller diff --git a/verification/whir/Whir/WHIRPhysicalDriver.lean b/verification/whir/Whir/WHIRPhysicalDriver.lean new file mode 100644 index 000000000..b974fa1ec --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalDriver.lean @@ -0,0 +1,222 @@ +import Whir.WHIRPhysicalSoundness +import Whir.WHIRSourceComposition +import Whir.WHIRSourceBackfill + +namespace Whir.WHIRPhysicalDriver +open Concrete Protocol FiatShamirGame DuplexModeGame +open MerkleTransport WHIRSourceChronology WHIRPhysicalVerifier +open PublicMerkleProgram (Runs) +open WHIRSourceBackfill (AllResults) + +/-- The physical parser and logical caller registry share this one public +production model. Neither the attacker nor a successful result chooses lanes. -/ +structure ProductionRegistry where + iv : Digest32 + domain : Digest32 + models : Digest32 → Option WHIRCallerSupport.ProductionLayout + callerOutputCap : Nat + +def ProductionRegistry.publicRegistry (registry : ProductionRegistry) : WHIRCallerRegistry.Public where + iv := registry.iv + domain := registry.domain + layouts := fun statement => (registry.models statement).map WHIRCallerSupport.ProductionLayout.layout + callerOutputCap := registry.callerOutputCap + +def ProductionRegistry.context (registry : ProductionRegistry) : RawWHIRKeys.Context := + WHIRCallerRegistry.context registry.publicRegistry + +def ProductionRegistry.packetModel (registry : ProductionRegistry) (Q : Nat) + (packet : RawWHIRKeys.Packet registry.context Q) : WHIRCallerSupport.ProductionLayout := + match found : registry.models packet.val.statement with + | some model => model + | none => False.elim (by + have registered := (WHIRCallerRegistry.selection_spec registry.publicRegistry _ _ _ + (WHIRCallerRegistry.packet_selection registry.publicRegistry Q packet)).1 + simp only [publicRegistry,found,Option.map_none] at registered + cases registered) + +theorem ProductionRegistry.packetModel_layout (registry : ProductionRegistry) (Q : Nat) + (packet : RawWHIRKeys.Packet registry.context Q) : + (registry.packetModel Q packet).layout = WHIRCallerRegistry.packetLayout registry.publicRegistry Q packet := by + have registered := (WHIRCallerRegistry.selection_spec registry.publicRegistry _ _ _ + (WHIRCallerRegistry.packet_selection registry.publicRegistry Q packet)).1 + unfold packetModel + split + · rename_i model found + change (registry.models packet.val.statement).map WHIRCallerSupport.ProductionLayout.layout = _ at registered + rw [found] at registered + exact Option.some.inj registered + · rename_i found + simp only [publicRegistry,found,Option.map_none] at registered + cases registered + +theorem ProductionRegistry.packetModel_registered (registry : ProductionRegistry) (Q : Nat) + (packet : RawWHIRKeys.Packet registry.context Q) : + registry.publicRegistry.layouts packet.val.statement = some (registry.packetModel Q packet).layout := by + rw [registry.packetModel_layout Q packet] + exact (WHIRCallerRegistry.selection_spec registry.publicRegistry _ _ _ + (WHIRCallerRegistry.packet_selection registry.publicRegistry Q packet)).1 + +def ProductionRegistry.packetLanes (registry : ProductionRegistry) (Q : Nat) + (packet : RawWHIRKeys.Packet registry.context Q) : Nat := + WHIRCallerClaims.callerLanes (registry.packetModel Q packet).layout + +/-- An attacker chooses transport bytes and opening proofs, not a verifier +result or its acceptance evidence. -/ +structure Input (ctx : RawWHIRKeys.Context) (Q : Nat) where + packet : RawWHIRKeys.Packet ctx Q + proofs : Array PrunedMerklePaths + +structure Accepted (ctx : RawWHIRKeys.Context) (Q cap : Nat) where + packet : RawWHIRKeys.Packet ctx Q + verified : Verified ctx Q cap packet + +def select {ctx : RawWHIRKeys.Context} {Q cap : Nat} : + Option (Accepted ctx Q cap) → Option (RawWHIRKeys.Packet ctx Q) := + Option.map Accepted.packet + +def verifier (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (input : Input registry.context Q) : + Source cap (Option (Accepted registry.context Q cap)) := + (verifySource cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs).map + (Option.map (fun verified => ⟨input.packet,verified⟩)) + +/-- Exactly one final native verifier follows the arbitrary attacker-input +source. Rejection is literal none; successful payloads only come from verifier. -/ +def verifyAfter (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) : Source cap (Option (Accepted registry.context Q cap)) := + attacker.bind (verifier cap registry Q) + +/-- A public completed-result/observer event. The fixed list is reconstructed +only from the first frozen public records, and the claims are those the native +caller actually decoded. No source program, coins, or primitive oracle occurs. -/ +def nativeWrong {ctx : RawWHIRKeys.Context} {Q cap : Nat} (state : CausalBindingState.State cap) : + Option (Accepted ctx Q cap) → Prop + | none => False + | some accepted => + let original := WHIRPhysicalSoundness.committedStatement accepted.verified state + ¬ ∃ witness ∈ InitialCandidates.witnesses (ParameterBounds.config accepted.packet.val.profile) + original.lanes original.root, + RingPCSGame.Honest (ParameterBounds.config accepted.packet.val.profile) + original.lanes original.family original.points witness + +theorem native_list_bound {ctx : RawWHIRKeys.Context} {Q cap : Nat} + (state : CausalBindingState.State cap) (accepted : Accepted ctx Q cap) : + (InitialCandidates.witnesses (ParameterBounds.config accepted.packet.val.profile) + (WHIRPhysicalSoundness.committedStatement accepted.verified state).lanes + (WHIRPhysicalSoundness.committedStatement accepted.verified state).root).card ≤ 2^32 := + InitialCandidates.production_witnesses_card _ _ _ + +theorem verifier_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (input : Input registry.context Q) : + Counts (sourceBudget registry.context Q input.packet) (verifier cap registry Q input) := by + apply (Source.map_counted _ _ _).mpr + exact verifySource_counted cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs + +/-- Only packets the attacker can actually return require a native-verifier +budget. This includes every answer branch, not only a chosen oracle execution. -/ +theorem verifyAfter_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) (a b : Nat) (before : Counts a attacker) + (budget : AllResults (fun input => sourceBudget registry.context Q input.packet ≤ b) (erase attacker)) : + Counts (a+b) (verifyAfter cap registry Q attacker) := by + apply (erase_counted _ _).mp + rw [verifyAfter,Source.erase_bind] + apply WHIRSourceBackfill.bind_counted_reachable _ _ _ a b + ((erase_counted _ _).mpr before) budget + intro input bounded + exact (erase_counted _ _).mpr (Source.counts_mono (verifier_counted cap registry Q input) bounded) + +private theorem allResults_bind (program : Program R) (next : R → Program S) (post : S → Prop) : + AllResults post (WHIRModeFinal.bind program next) = + AllResults (fun result => AllResults post (next result)) program := by + induction program with + | done => rfl + | ask query cont ih => simp only [WHIRModeFinal.bind,AllResults,ih] + +theorem verifier_selected (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (input : Input registry.context Q) (post : RawWHIRKeys.Packet registry.context Q → Prop) + (valid : post input.packet) : + AllResults (fun result => ∀ packet, select result = some packet → post packet) + (erase (verifier cap registry Q input)) := by + rw [verifier,Source.map,Source.erase_bind,allResults_bind] + apply WHIRSourceBackfill.allResults_of_forall + intro result packet selected + cases result with + | none => cases selected + | some verified => + cases Option.some.inj selected + exact valid + +/-- Successful native verification preserves the attacker's chosen packet. +In particular a reachable path budget needs no guard or result clipping. -/ +theorem verifyAfter_selected (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) (post : RawWHIRKeys.Packet registry.context Q → Prop) + (reachable : AllResults (fun input => post input.packet) (erase attacker)) : + AllResults (fun result => ∀ packet, select result = some packet → post packet) + (erase (verifyAfter cap registry Q attacker)) := by + rw [verifyAfter,Source.erase_bind,allResults_bind] + exact WHIRSourceBackfill.allResults_mono _ _ _ reachable + (fun input valid => verifier_selected cap registry Q input post valid) + +theorem verifyAfter_path_bound (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) (Mf : Nat) + (reachable : AllResults + (fun input => DuplexFraming.pathCost (RawWHIRKeys.coordinate registry.context input.packet.val 0) ≤ Mf) (erase attacker)) : + AllResults (fun result => ∀ packet, select result = some packet → + DuplexFraming.pathCost (RawWHIRKeys.coordinate registry.context packet.val 0) ≤ Mf) + (erase (verifyAfter cap registry Q attacker)) := + verifyAfter_selected cap registry Q attacker _ reachable + +/-- Every accepted wrapper result has an actual native verifier suffix. An +arbitrary attacker prefix cannot supply a fabricated Verified payload. -/ +theorem native_segment (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) (observations : List Observation) + (accepted : Accepted registry.context Q cap) + (run : Runs (erase (verifyAfter cap registry Q attacker)) observations (some accepted)) : + ∃ (input : Input registry.context Q) (before after : List Observation) + (verified : Verified registry.context Q cap input.packet), + observations = before ++ after ∧ Runs (erase attacker) before input ∧ + Runs (erase (verifySource cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs)) after (some verified) ∧ + accepted = ⟨input.packet,verified⟩ := by + obtain ⟨before,input,after,trace,first,last⟩ := + (Source.erased_bind_runs attacker _ observations (some accepted)).mp run + obtain ⟨result,native,mapped⟩ := (Source.erased_map_runs _ _ after (some accepted)).mp last + obtain ⟨verified,returned,equal⟩ := Option.map_eq_some_iff.mp mapped + rw [returned] at native + exact ⟨input,before,after,verified,trace,first,native,equal.symm⟩ + +/-- The event-segment equation is about the real compiler result itself, +including both the attacker's events and the trusted native continuation. -/ +theorem real_result (C : PrimitiveOracle) (iv : Digest32) (cap : Nat) + (registry : ProductionRegistry) (Q : Nat) (attacker : Source cap (Input registry.context Q)) : + (runReal C iv (compile (verifyAfter cap registry Q attacker))).view.result = + let chosen := (runReal C iv (compile attacker)).view.result + let native := (runReal C iv (compile (verifySource cap (registry.packetModel Q chosen.value.packet) + registry.context rfl Q (registry.packetLanes Q chosen.value.packet) + chosen.value.packet chosen.value.proofs))).view.result + ⟨native.value.map (fun verified => ⟨chosen.value.packet,verified⟩),chosen.events ++ native.events⟩ := by + rw [verifyAfter,Source.real_bind] + simp only [verifier,Source.real_map] + +theorem real_native_segment (C : PrimitiveOracle) (iv : Digest32) (cap : Nat) + (registry : ProductionRegistry) (Q : Nat) (attacker : Source cap (Input registry.context Q)) + (accepted : Accepted registry.context Q cap) + (returned : (runReal C iv (compile (verifyAfter cap registry Q attacker))).view.result.value = some accepted) : + ∃ (input : Input registry.context Q) (verified : Verified registry.context Q cap input.packet), + input = (runReal C iv (compile attacker)).view.result.value ∧ + (runReal C iv (compile (verifySource cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs))).view.result.value = some verified ∧ + accepted = ⟨input.packet,verified⟩ ∧ + (runReal C iv (compile (verifyAfter cap registry Q attacker))).view.result.events = + (runReal C iv (compile attacker)).view.result.events ++ + (runReal C iv (compile (verifySource cap (registry.packetModel Q input.packet) registry.context rfl Q + (registry.packetLanes Q input.packet) input.packet input.proofs))).view.result.events := by + have whole := real_result C iv cap registry Q attacker + have value := congrArg Result.value whole + rw [value] at returned + obtain ⟨verified,native,equal⟩ := Option.map_eq_some_iff.mp returned + exact ⟨_,verified,rfl,native,equal.symm,congrArg Result.events whole⟩ + +end Whir.WHIRPhysicalDriver diff --git a/verification/whir/Whir/WHIRPhysicalOpeningRuns.lean b/verification/whir/Whir/WHIRPhysicalOpeningRuns.lean new file mode 100644 index 000000000..c4659efbb --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalOpeningRuns.lean @@ -0,0 +1,225 @@ +import Whir.WHIRPhysicalReplay + +/-! Every retained physical opening is an actual subexecution of the counted packet reader. Its primitive observations are included in the reader's public trace, including repeated calls. -/ +namespace Whir.WHIRPhysicalOpeningRuns +open Concrete Protocol FiatShamirGame DuplexModeGame PublicMerkleProgram MerkleTransport +open RawOracleCoupling RawOracleCoupling.Concrete WHIRPhysicalVerifier WHIRPhysicalReplay + +/-- The proof comes from the indexed physical proof array and the sample/root actually retained by the source interpreter. -/ +def ObservedOpening {p : ParameterBounds.Profile} (lanes : Nat) (proofs : Array PrunedMerklePaths) + (outer : List Observation) (opening : QueryOpening p) : Prop := + ∃ proof trace, proofs[opening.level.val]? = some proof ∧ + Runs (openQuery p opening.level lanes proof opening.root opening.sample) trace (some opening.result) ∧ + ∀ o ∈ trace, o ∈ outer + +theorem ObservedOpening.mono {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {before after : List Observation} {opening : QueryOpening p} + (observed : ObservedOpening lanes proofs before opening) + (included : ∀ o ∈ before, o ∈ after) : ObservedOpening lanes proofs after opening := by + obtain ⟨proof,trace,index,run,subset⟩ := observed + exact ⟨proof,trace,index,run,fun o member => included o (subset o member)⟩ + +theorem absorbResponse_openings {p : ParameterBounds.Profile} (state out : WireState p) + (pending : WHIRHistory.Pending) (root : Option Digest32) + (ok : absorbResponse state pending = some (out,root)) : out.openings = state.openings := by + unfold absorbResponse at ok + cases previous : state.previous with + | none => + simp only [previous] at ok + split at ok + · cases Option.some.inj ok + rfl + · contradiction + | some q => + simp only [previous] at ok + change (WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending).bind _ = + some (out,root) at ok + cases parsed : WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending with + | none => simp [parsed] at ok + | some response => + simp only [parsed,Option.bind_some,Option.some.injEq,Prod.mk.injEq] at ok + cases ok.1 + rfl + +theorem afterNonce_openings {p : ParameterBounds.Profile} {ctx : RawWHIRKeys.Context} {Q : Nat} + {packet : RawWHIRKeys.Packet ctx Q} (state out : WireState p) + (nonce : WHIRPowProgram.Outcome ctx Q packet) (ok : afterNonce state nonce = some out) : + out.openings = state.openings := by + unfold afterNonce at ok + split at ok + · cases Option.some.inj ok + rfl + · cases cached : state.outputCache with + | none => simp [cached] at ok + | some digest => + simp only [cached,Option.map_some,Option.some.injEq] at ok + subst out + rfl + +theorem takeSample_openings {p : ParameterBounds.Profile} (lanes : Nat) + (proofs : Array PrunedMerklePaths) (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : Runs (takeSample lanes proofs state q x) trace (some out)) : + ∀ opening ∈ out.openings, opening ∈ state.openings ∨ ObservedOpening lanes proofs trace opening := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · cases hp : proofs[i.val]? with + | none => cases hr : state.roots[i.val]? <;> simp only [hp,hr] at run <;> cases run + | some proof => + cases hr : state.roots[i.val]? with + | none => simp only [hp,hr] at run; cases run + | some root => + simp only [hp,hr] at run + obtain ⟨before,opened,after,equal,openingRun,continued⟩ := (Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + intro opening member + rcases List.mem_cons.mp member with same | old + · subst opening + refine Or.inr ⟨proof,before,hp,openingRun,?_⟩ + intro o member + rw [equal] + exact List.mem_append_left _ member + · exact Or.inl old + · cases run + | initial => + cases run + intro opening member + exact Or.inl member + | fold i j => + cases run + intro opening member + exact Or.inl member + | ood i j => + cases run + intro opening member + exact Or.inl member + | tail j => + cases run + intro opening member + exact Or.inl member + +/-- The same successful continuation is retained while all reader-created openings are tied to the outer public observations. -/ +theorem readPhysicalPackets_openings {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (p : ParameterBounds.Profile) (lanes : Nat) + (proofs : Array PrunedMerklePaths) (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ packet ∈ packets, packet.val.profile = p) (state : WireState p) + (next : WireState p → List (Sigma (GroupAnswer ctx Q)) → WHIRSourceChronology.Source cap (Option R)) + (observations : List Observation) (result : R) + (run : Runs (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q p lanes proofs none packets profiles state next)) observations (some result)) : + ∃ final history suffix, Runs (WHIRSourceChronology.erase (next final history)) suffix (some result) ∧ + (∀ o ∈ suffix, o ∈ observations) ∧ + ∀ opening ∈ final.openings, opening ∈ state.openings ∨ ObservedOpening lanes proofs observations opening := by + induction packets generalizing state next observations with + | nil => exact ⟨state,[],observations,run,fun _ h => h,fun _ h => Or.inl h⟩ + | cons packet packets ih => + simp only [readPhysicalPackets] at run + cases parsed : absorbResponse state (packet.val.messages.headD ⟨[],none⟩) with + | none => simp only [parsed,WHIRSourceChronology.erase] at run; cases run + | some pair => + obtain ⟨absorbed,root⟩ := pair + simp only [parsed] at run + split at run + · rename_i guards + rw [announce_erase,sourceLift_erase] at run + obtain ⟨beforeNonce,nonce,afterNonceTrace,nonceEq,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases boundNonce : afterNonce absorbed nonce with + | none => simp only [boundNonce,WHIRSourceChronology.erase] at continued; cases continued + | some bound => + simp only [boundNonce] at continued + split at continued + · rw [sourceLift_erase] at continued + obtain ⟨beforeRaw,raw,afterRaw,rawEq,_,read⟩ := (Runs.bind_iff _ _).mp continued + rw [sourceLift_erase] at read + obtain ⟨beforeOpen,opened,afterOpen,openEq,openingRun,rest⟩ := (Runs.bind_iff _ _).mp read + cases opened with + | none => cases rest + | some checked => + have beforeSubset : ∀ o ∈ beforeOpen, o ∈ observations := by + intro o member + rw [nonceEq,rawEq,openEq] + exact List.mem_append_right _ (List.mem_append_right _ (List.mem_append_left _ member)) + have afterSubset : ∀ o ∈ afterOpen, o ∈ observations := by + intro o member + rw [nonceEq,rawEq,openEq] + exact List.mem_append_right _ (List.mem_append_right _ (List.mem_append_right _ member)) + obtain ⟨final,history,suffix,last,suffixSubset,retained⟩ := ih _ _ _ _ rest + refine ⟨final,⟨.inl packet,raw⟩::history,suffix,last, + fun o member => afterSubset o (suffixSubset o member),?_⟩ + intro opening member + rcases retained opening member with old | observed + · have opened := takeSample_openings _ _ _ _ _ _ _ openingRun opening old + rcases opened with old | observed + · have kept := (afterNonce_openings _ _ _ boundNonce).trans + (absorbResponse_openings _ _ _ _ parsed) + exact Or.inl (kept ▸ old) + · exact Or.inr (observed.mono beforeSubset) + · exact Or.inr (observed.mono afterSubset) + · cases continued + · cases run + +/-- Initial wire state has no old opening records, so every returned record is covered by the actual source trace. -/ +theorem readPhysicalCompletion_openings {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (lanes : Nat) + (proofs : Array PrunedMerklePaths) (root : Digest32) + (next : WireState packet.val.profile → List (Sigma (GroupAnswer ctx Q)) → WHIRSourceChronology.Source cap (Option R)) + (observations : List Observation) (result : R) + (run : Runs (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q packet.val.profile lanes proofs none (completion ctx Q packet) + (completion_profiles ctx Q packet) (initialWireState packet.val.profile root) next)) observations (some result)) : + ∃ state history suffix, Runs (WHIRSourceChronology.erase (next state history)) suffix (some result) ∧ + (∀ o ∈ suffix, o ∈ observations) ∧ + ∀ opening ∈ state.openings, ObservedOpening lanes proofs observations opening := by + obtain ⟨state,history,suffix,last,subset,retained⟩ := + readPhysicalPackets_openings ctx stack Q packet.val.profile lanes proofs _ _ _ next observations result run + refine ⟨state,history,suffix,last,subset,?_⟩ + intro opening member + rcases retained opening member with old | observed + · simp [initialWireState] at old + · exact observed + +/-- Real-answer consistency is obtained from actual real execution, not from a guessed opening certificate. It transfers the retained operational subrun to the concrete ordinary-hash computation. -/ +theorem ObservedOpening.real {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {observations : List Observation} {opening : QueryOpening p} + (observed : ObservedOpening lanes proofs observations opening) (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) : + ∃ proof, proofs[opening.level.val]? = some proof ∧ + (runReal C iv (openQuery p opening.level lanes proof opening.root opening.sample)).view.result = some opening.result ∧ + ∀ o ∈ (runReal C iv (openQuery p opening.level lanes proof opening.root opening.sample)).view.observations, + o ∈ observations := by + obtain ⟨proof,trace,index,run,subset⟩ := observed + have actual := run.real_result_trace C iv (fun o member => answers o (subset o member)) + exact ⟨proof,index,actual.1,fun o member => subset o (actual.2 ▸ member)⟩ + +/-- Direct real-game corollary. Its only success premise is the actual reader execution result. -/ +theorem readPhysicalCompletion_real_openings {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (lanes : Nat) + (proofs : Array PrunedMerklePaths) (root : Digest32) + (next : WireState packet.val.profile → List (Sigma (GroupAnswer ctx Q)) → WHIRSourceChronology.Source cap (Option R)) + (C : PrimitiveOracle) (iv : Digest32) (result : R) + (accepted : (runReal C iv (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q packet.val.profile lanes proofs none (completion ctx Q packet) + (completion_profiles ctx Q packet) (initialWireState packet.val.profile root) next))).view.result = some result) : + ∃ state history suffix, Runs (WHIRSourceChronology.erase (next state history)) suffix (some result) ∧ + ∀ opening ∈ state.openings, ∃ proof, proofs[opening.level.val]? = some proof ∧ + (runReal C iv (openQuery packet.val.profile opening.level lanes proof opening.root opening.sample)).view.result = + some opening.result ∧ + ∀ o ∈ (runReal C iv (openQuery packet.val.profile opening.level lanes proof opening.root opening.sample)).view.observations, + o ∈ (runReal C iv (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q packet.val.profile lanes proofs none (completion ctx Q packet) + (completion_profiles ctx Q packet) (initialWireState packet.val.profile root) next))).view.observations := by + have run := runReal_runs C iv (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q packet.val.profile lanes proofs none (completion ctx Q packet) + (completion_profiles ctx Q packet) (initialWireState packet.val.profile root) next)) + rw [accepted] at run + obtain ⟨state,history,suffix,last,_,retained⟩ := + readPhysicalCompletion_openings ctx stack Q packet lanes proofs root next _ result run + exact ⟨state,history,suffix,last,fun opening member => + (retained opening member).real C iv (runReal_answers C iv _)⟩ + +end Whir.WHIRPhysicalOpeningRuns diff --git a/verification/whir/Whir/WHIRPhysicalReplay.lean b/verification/whir/Whir/WHIRPhysicalReplay.lean new file mode 100644 index 000000000..1a6b2767b --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalReplay.lean @@ -0,0 +1,622 @@ +import Whir.WHIRPhysicalVerifier +import Whir.WHIRPhysicalHistory + +/-! Operational replay of the actual counted physical packet reader. The source program, not a replay-correctness premise, supplies its scalar responses, query rows and complete challenge vectors. -/ +namespace Whir.WHIRPhysicalReplay +open Concrete Protocol FiatShamirGame DuplexModeGame PublicMerkleProgram MerkleTransport +open RawOracleCoupling RawOracleCoupling.Concrete WHIRPhysicalVerifier + +/-- Later query openings may append rows, but cannot change a previously opened row array. -/ +def ExtendsRows {p : ParameterBounds.Profile} (before after : WireState p) : Prop := + ∃ suffix, after.rows = before.rows ++ suffix + +theorem ExtendsRows.refl {p : ParameterBounds.Profile} (state : WireState p) : ExtendsRows state state := + ⟨#[],by simp⟩ + +theorem ExtendsRows.trans {p : ParameterBounds.Profile} {a b c : WireState p} + (ab : ExtendsRows a b) (bc : ExtendsRows b c) : ExtendsRows a c := by + obtain ⟨first,hfirst⟩ := ab + obtain ⟨second,hsecond⟩ := bc + exact ⟨first ++ second,by simp [hsecond,hfirst,Array.append_assoc]⟩ + +theorem ExtendsRows.get {p : ParameterBounds.Profile} {before after : WireState p} + (extended : ExtendsRows before after) (i : Nat) (bound : i < before.rows.size) : + after.rows[i]! = before.rows[i]! := by + obtain ⟨suffix,extended⟩ := extended + rw [extended] + rw [getElem!_pos (before.rows ++ suffix) i (by simp; omega), + getElem!_pos before.rows i bound,Array.getElem_append_left bound] + +/-- A query answer is opened before the next scalar response can consume its rows. -/ +def PreviousCovered {p : ParameterBounds.Profile} (state : WireState p) : Prop := + ∀ i, state.previous = some (.query i) → i.val < state.rows.size + +theorem nonceMatches_shape {c : Config} (q : CausalProbability.Coordinate c) + (pending : WHIRHistory.Pending) (matched : nonceMatches q pending = true) : + WHIRReplay.nonceShape q pending = true := by + cases q <;> cases hn : pending.nonce <;> simp [nonceMatches,WHIRReplay.nonceShape,hn] at matched ⊢ + +theorem afterNonce_fields {p : ParameterBounds.Profile} {ctx : RawWHIRKeys.Context} {Q : Nat} + {packet : RawWHIRKeys.Packet ctx Q} (state out : WireState p) + (nonce : WHIRPowProgram.Outcome ctx Q packet) (ok : afterNonce state nonce = some out) : + out.tape = state.tape ∧ out.previous = state.previous ∧ out.replies = state.replies ∧ + out.rows = state.rows ∧ out.initial = state.initial := by + unfold afterNonce at ok + split at ok + · cases Option.some.inj ok + exact ⟨rfl,rfl,rfl,rfl,rfl⟩ + · cases cached : state.outputCache with + | none => simp [cached] at ok + | some digest => + simp only [cached,Option.map_some,Option.some.injEq] at ok + subst out + exact ⟨rfl,rfl,rfl,rfl,rfl⟩ + +theorem announce_erase {cap : Nat} {R : Type} (root : Option Digest32) + (next : WHIRSourceChronology.Source cap R) : + WHIRSourceChronology.erase (announce root next) = WHIRSourceChronology.erase next := by + cases root <;> rfl + +theorem takeSample_fields {p : ParameterBounds.Profile} (lanes : Nat) + (proofs : Array PrunedMerklePaths) (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : Runs (takeSample lanes proofs state q x) trace (some out)) : + out.replies = state.replies ∧ out.tape = (recordSample state q x).tape ∧ + out.previous = some q ∧ out.initial = (recordSample state q x).initial ∧ + ExtendsRows state out ∧ PreviousCovered out := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · rename_i index + cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · simp only [hp,hr] at run + cases run + · simp only [hp,hr] at run + cases run + · simp only [hp,hr] at run + cases run + · simp only [hp,hr] at run + obtain ⟨before,opened,after,_,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + refine ⟨rfl,rfl,rfl,rfl,⟨#[opened.rows],by simp⟩,?_⟩ + intro j same + have equal : i = j := by + exact CausalProbability.Coordinate.query.inj (Option.some.inj same) + subst j + simp only [Array.size_push] + omega + · cases run + | initial => + cases run + exact ⟨rfl,rfl,rfl,rfl,ExtendsRows.refl _,by simp [PreviousCovered,recordSample]⟩ + | fold i j => + cases run + exact ⟨rfl,rfl,rfl,rfl,ExtendsRows.refl _,by simp [PreviousCovered,recordSample]⟩ + | ood i j => + cases run + exact ⟨rfl,rfl,rfl,rfl,ExtendsRows.refl _,by simp [PreviousCovered,recordSample]⟩ + | tail j => + cases run + exact ⟨rfl,rfl,rfl,rfl,ExtendsRows.refl _,by simp [PreviousCovered,recordSample]⟩ + +theorem absorbResponse_rows {p : ParameterBounds.Profile} (state out : WireState p) + (pending : WHIRHistory.Pending) (root : Option Digest32) + (ok : absorbResponse state pending = some (out,root)) : + out.rows = state.rows ∧ out.tape = state.tape ∧ out.previous = state.previous ∧ + out.initial = state.initial := by + unfold absorbResponse at ok + cases previous : state.previous with + | none => + simp only [previous] at ok + split at ok + · cases Option.some.inj ok + exact ⟨rfl,rfl,previous,rfl⟩ + · contradiction + | some q => + simp only [previous] at ok + change (WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending).bind _ = + some (out,root) at ok + cases parsed : WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending with + | none => simp [parsed] at ok + | some response => + simp only [parsed,Option.bind_some,Option.some.injEq,Prod.mk.injEq] at ok + cases ok.1 + exact ⟨rfl,rfl,rfl,rfl⟩ + +/-- The transition relation retains the real scalar parse and physical opening run. It is derived below from source execution, not supplied as a cryptographic premise. -/ +inductive Step (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (p : ParameterBounds.Profile) (lanes : Nat) (proofs : Array PrunedMerklePaths) + (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) : + WireState p → GroupAnswer ctx Q (.inl packet) → WireState p → Prop where + | run {state absorbed root bound raw checked trace} {nonce : WHIRPowProgram.Outcome ctx Q packet} + (parsed : absorbResponse state (packet.val.messages.headD ⟨[],none⟩) = some (absorbed,root)) + (size : packet.val.messages.length = absorbed.replies.size + 1) + (shape : nonceMatches (packetQuery ctx Q p packet profile) (packet.val.messages.headD ⟨[],none⟩) = true) + (boundNonce : afterNonce absorbed nonce = some bound) + (accepted : nonce.accepted = true) + (opened : Runs (takeSample lanes proofs bound (packetQuery ctx Q p packet profile) + (packetSample ctx stack Q p packet profile raw)) trace (some checked)) : + Step ctx stack Q p lanes proofs packet profile state raw (withOutput ctx Q packet raw checked) + +inductive Trace (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (p : ParameterBounds.Profile) (lanes : Nat) (proofs : Array PrunedMerklePaths) : + List (RawWHIRKeys.Packet ctx Q) → WireState p → WireState p → + List (Sigma (GroupAnswer ctx Q)) → Prop where + | nil (state) : Trace ctx stack Q p lanes proofs [] state state [] + | cons {packet packets state next final raw history} (profile : packet.val.profile = p) + (step : Step ctx stack Q p lanes proofs packet profile state raw next) + (rest : Trace ctx stack Q p lanes proofs packets next final history) : + Trace ctx stack Q p lanes proofs (packet::packets) state final (⟨.inl packet,raw⟩::history) + +theorem readPhysicalPackets_trace {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (p : ParameterBounds.Profile) (lanes : Nat) + (proofs : Array PrunedMerklePaths) (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ packet ∈ packets, packet.val.profile = p) (state : WireState p) + (next : WireState p → List (Sigma (GroupAnswer ctx Q)) → WHIRSourceChronology.Source cap (Option R)) + (observations : List Observation) (result : R) + (run : Runs (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q p lanes proofs none packets profiles state next)) observations (some result)) : + ∃ final history suffix, Trace ctx stack Q p lanes proofs packets state final history ∧ + Runs (WHIRSourceChronology.erase (next final history)) suffix (some result) := by + induction packets generalizing state next observations with + | nil => exact ⟨state,[],observations,.nil state,run⟩ + | cons packet packets ih => + simp only [readPhysicalPackets] at run + cases parsed : absorbResponse state (packet.val.messages.headD ⟨[],none⟩) with + | none => simp only [parsed,WHIRSourceChronology.erase] at run; cases run + | some value => + obtain ⟨absorbed,root⟩ := value + simp only [parsed] at run + split at run + · rename_i guards + rw [announce_erase,sourceLift_erase] at run + obtain ⟨before,nonce,after,_,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases boundNonce : afterNonce absorbed nonce with + | none => simp only [boundNonce,WHIRSourceChronology.erase] at continued; cases continued + | some bound => + simp only [boundNonce] at continued + split at continued + · rename_i accepted + rw [sourceLift_erase] at continued + obtain ⟨beforeRaw,raw,afterRaw,_,_,read⟩ := (Runs.bind_iff _ _).mp continued + rw [sourceLift_erase] at read + obtain ⟨beforeOpen,opened,afterOpen,_,opening,rest⟩ := (Runs.bind_iff _ _).mp read + cases opened with + | none => cases rest + | some checked => + obtain ⟨final,history,suffix,traced,last⟩ := ih _ _ _ _ rest + exact ⟨final,⟨.inl packet,raw⟩::history,suffix, + .cons (profiles packet (by simp)) + (.run parsed guards.1 guards.2 boundNonce accepted opening) traced,last⟩ + · cases continued + · cases run + +theorem packetQuery_eq (ctx : RawWHIRKeys.Context) (Q : Nat) (p : ParameterBounds.Profile) + (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) (statement : Digest32) : + packetQuery ctx Q p packet profile = WHIRReplay.query p (statement,packet.val.messages) := by + cases profile + rfl + +theorem packetQuery_position (ctx : RawWHIRKeys.Context) (Q : Nat) (p : ParameterBounds.Profile) + (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) : + CausalProbability.position (packetQuery ctx Q p packet profile) = packet.val.messages.length - 1 := by + cases profile + have bound := WHIRHistory.scheduledAdmissible_depth _ _ packet.property.2.2.1 + have positive := List.length_pos_iff.mpr packet.property.2.1 + have lt : packet.val.messages.length - 1 < WHIRHistory.depth (ParameterBounds.config packet.val.profile) := by omega + rw [packetQuery_eq _ _ _ _ rfl packet.val.statement] + change CausalProbability.position (WHIRHistory.queryFor _ (packet.val.statement,packet.val.messages)) = _ + rw [WHIRHistory.queryFor_at _ _ _ ⟨_,lt⟩ (by change _ = packet.val.messages.length - 1 + 1; omega)] + exact WHIRHistory.position_schedule_get _ _ + +theorem packetQuery_initial (ctx : RawWHIRKeys.Context) (Q : Nat) (p : ParameterBounds.Profile) + (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) + (single : packet.val.messages.length = 1) : + packetQuery ctx Q p packet profile = .initial := by + apply CausalPrefix.position_injective + rw [packetQuery_position, single] + simp [CausalProbability.position,CausalProbability.visibleCoordinates] + +theorem packet_singleton (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (single : packet.val.messages.length = 1) : + packet.val.messages = [WHIRHistoryKey.initialPending] := by + have normal := WHIRHistoryKey.scheduled_normal _ _ packet.property.2.1 packet.property.2.2.1 + have empty : packet.val.messages.dropLast = [] := List.length_eq_zero_iff.mp (by simp [single]) + have restore := normal.restore + simpa only [empty,List.nil_append] using restore.symm + +/-- Public syntax of the actual oldest-first completion, independently of its answers. -/ +inductive Chain (ctx : RawWHIRKeys.Context) (Q : Nat) : + RawWHIRKeys.Packet ctx Q → List (RawWHIRKeys.Packet ctx Q) → Prop where + | initial (packet) (single : packet.val.messages = [WHIRHistoryKey.initialPending]) : + Chain ctx Q packet [packet] + | next {packet previous packets} (head : WHIRHistory.Pending) + (prior : Chain ctx Q previous packets) + (messages : packet.val.messages = head :: previous.val.messages) + (statement : previous.val.statement = packet.val.statement) + (profile : previous.val.profile = packet.val.profile) : + Chain ctx Q packet (packets ++ [packet]) + +theorem completion_chain (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) : + Chain ctx Q packet (completion ctx Q packet) := by + generalize length : packet.val.messages.length = n + induction n using Nat.strong_induction_on generalizing packet with + | h n ih => + by_cases empty : packet.val.messages.drop 1 = [] + · have positive := List.length_pos_iff.mpr packet.property.2.1 + have bound := congrArg List.length empty + simp only [List.length_drop,List.length_nil] at bound + have one : packet.val.messages.length = 1 := by omega + rw [completion,RawWHIRKeys.ancestors_singleton ctx Q packet one] + exact .initial packet (packet_singleton ctx Q packet one) + · let previous := RawWHIRKeys.dropPacket ctx Q packet 1 empty + have smaller : previous.val.messages.length < n := by + simp only [previous,RawWHIRKeys.dropPacket,List.length_drop] + have positive := List.length_pos_iff.mpr packet.property.2.1 + omega + have prior := ih previous.val.messages.length smaller previous rfl + rw [completion,RawWHIRKeys.ancestors_drop_one ctx Q packet empty] + apply Chain.next (packet.val.messages.headD ⟨[],none⟩) prior + · cases messages : packet.val.messages with + | nil => exact False.elim (packet.property.2.1 messages) + | cons head tail => simp [previous,RawWHIRKeys.dropPacket,messages] + · rfl + · rfl + +def localEntry (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) + (raw : GroupAnswer ctx Q (.inl packet)) : WHIRRawReplay.LocalEntry p := + (packet.val.messages.headD ⟨[],none⟩, + ⟨packetQuery ctx Q p packet profile,packetSample ctx stack Q p packet profile raw⟩) + +def localHistory (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (history : List (Sigma (GroupAnswer ctx Q))) : List (WHIRRawReplay.LocalEntry p) := + (WHIRRawReplay.decodeHistory ctx stack Q history).filterMap (WHIRRawReplay.restrictEntry p) + +theorem localEntry_eq (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) + (raw : GroupAnswer ctx Q (.inl packet)) : + WHIRRawReplay.restrictEntry p (WHIRRawReplay.packetEntry ctx stack Q packet raw) = + some (localEntry ctx stack Q p packet profile raw) := by + cases profile + simp [WHIRRawReplay.packetEntry,localEntry,packetQuery,packetSample] + +theorem localHistory_append (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) + (raw : GroupAnswer ctx Q (.inl packet)) (history : List (Sigma (GroupAnswer ctx Q))) : + localHistory ctx stack Q p (history ++ [⟨.inl packet,raw⟩]) = + localEntry ctx stack Q p packet profile raw :: localHistory ctx stack Q p history := by + simp [localHistory,WHIRRawReplay.decodeHistory,WHIRRawReplay.decodeEntry, + List.filterMap_append,List.reverse_append,localEntry_eq ctx stack Q p packet profile raw] + +theorem Step.extends {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p lanes proofs packet profile state raw out) : + ExtendsRows state out ∧ PreviousCovered out := by + cases step with + | run parsed size shape boundNonce accepted opened => + obtain ⟨rows,_,_,_⟩ := absorbResponse_rows _ _ _ _ parsed + obtain ⟨_,_,_,nonceRows,_⟩ := afterNonce_fields _ _ _ boundNonce + obtain ⟨_,_,_,_,extended,covered⟩ := takeSample_fields _ _ _ _ _ _ _ opened + constructor + · obtain ⟨suffix,extended⟩ := extended + refine ⟨suffix,?_⟩ + dsimp only [withOutput] + rw [extended,nonceRows,rows] + · exact covered + +theorem Trace.extends {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs packets state out history) : ExtendsRows state out := by + induction trace with + | nil => exact ExtendsRows.refl _ + | cons profile step rest ih => exact ExtendsRows.trans step.extends.1 ih + +theorem Trace.append_inv {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + (left right : List (RawWHIRKeys.Packet ctx Q)) {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs (left ++ right) state out history) : + ∃ middle before after, history = before ++ after ∧ + Trace ctx stack Q p lanes proofs left state middle before ∧ + Trace ctx stack Q p lanes proofs right middle out after := by + induction left generalizing state history with + | nil => exact ⟨state,[],history,rfl,.nil state,trace⟩ + | cons packet left ih => + cases trace with + | cons profile step rest => + obtain ⟨middle,before,after,equal,first,last⟩ := ih rest + exact ⟨middle,_::before,after,by simp [equal],.cons profile step first,last⟩ + +def RowTable {p : ParameterBounds.Profile} (state : WireState p) (rows : WHIRPhysicalHistory.Rows) : Prop := + ∀ i, i < state.rows.size → rows i = state.rows[i]! + +theorem RowTable.of_extends {p : ParameterBounds.Profile} {before after : WireState p} + {rows : WHIRPhysicalHistory.Rows} (extended : ExtendsRows before after) (table : RowTable after rows) : + RowTable before rows := by + intro i bound + have size : before.rows.size ≤ after.rows.size := by + obtain ⟨suffix,extended⟩ := extended + simp [extended] + rw [table i (by omega),extended.get i bound] + +/-- The invariant is a theorem conclusion derived from execution. Every larger physical row table may be used to replay every already consumed response. -/ +def Completed {ctx : RawWHIRKeys.Context} (stack : ctx.mode = .stack) {Q : Nat} + {p : ParameterBounds.Profile} (packet : RawWHIRKeys.Packet ctx Q) (state : WireState p) + (history : List (Sigma (GroupAnswer ctx Q))) : Prop := + ∃ (profile : packet.val.profile = p) (raw : GroupAnswer ctx Q (.inl packet)) + (past : List (WHIRRawReplay.LocalEntry p)) (before : CausalGame.Tape (ParameterBounds.config p)) + (initial : RingPCSGame.Prefix × E), + localHistory ctx stack Q p history = localEntry ctx stack Q p packet profile raw :: past ∧ + state.previous = some (packetQuery ctx Q p packet profile) ∧ + state.tape = CausalProbability.set (packetQuery ctx Q p packet profile) before + (StackWHIRReplay.projectSample _ (packetSample ctx stack Q p packet profile raw)) ∧ + state.initial = some initial ∧ + StackWHIRReplay.initialSeed (localHistory ctx stack Q p history) = some initial ∧ + state.replies.size + 1 = packet.val.messages.length ∧ + PreviousCovered state ∧ + ∀ (statement : WHIRFiatShamir.Statement p) (rows : WHIRPhysicalHistory.Rows), RowTable state rows → + WHIRPhysicalHistory.decodeHistory p (fun _ => some statement) (fun _ _ => #[]) rows + packet.val.statement packet.val.messages (past.map StackWHIRReplay.projectEntry) = + some ⟨statement,before,state.replies⟩ + +theorem recordSample_tape {p : ParameterBounds.Profile} (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) : + (recordSample state q x).tape = + CausalProbability.set q state.tape (StackWHIRReplay.projectSample q x) := by + cases q <;> rfl + +theorem recordSample_initial {p : ParameterBounds.Profile} (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (first : q = .initial) : + ∃ seed, (recordSample state q x).initial = some seed ∧ + StackWHIRReplay.seedValue ⟨q,x⟩ = some seed := by + subst q + exact ⟨x,rfl,rfl⟩ + +theorem recordSample_noninitial {p : ParameterBounds.Profile} (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (later : q ≠ .initial) : (recordSample state q x).initial = state.initial := by + cases q <;> simp_all [recordSample] + +theorem absorbResponse_some {p : ParameterBounds.Profile} (state out : WireState p) + (pending : WHIRHistory.Pending) (root : Option Digest32) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) + (previous : state.previous = some q) + (ok : absorbResponse state pending = some (out,root)) : + ∃ response, WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending = + some response ∧ out.replies = state.replies.push response := by + simp only [absorbResponse,previous] at ok + change (WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending).bind _ = + some (out,root) at ok + cases parsed : WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending with + | none => simp [parsed] at ok + | some response => + simp only [parsed,Option.bind_some,Option.some.injEq,Prod.mk.injEq] at ok + cases ok.1 + exact ⟨response,rfl,rfl⟩ + +theorem reply_rowTable {p : ParameterBounds.Profile} (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (pending : WHIRHistory.Pending) + (rows : WHIRPhysicalHistory.Rows) (table : RowTable state rows) + (covered : PreviousCovered state) (previous : state.previous = some q) : + WHIRPhysicalHistory.reply (fun _ _ => #[]) rows q pending = + WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending := by + cases q with + | query i => simp only [WHIRPhysicalHistory.reply_query,table i (covered i previous)] + | initial => rfl + | fold i j => rfl + | ood i j => rfl + | tail j => rfl + +theorem completed_initial {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} (root : Digest32) + (single : packet.val.messages = [WHIRHistoryKey.initialPending]) + (step : Step ctx stack Q p lanes proofs packet profile (initialWireState p root) raw out) : + Completed stack packet out [⟨.inl packet,raw⟩] := by + have first := packetQuery_initial ctx Q p packet profile (by simp [single]) + cases step with + | run parsed size shape boundNonce accepted opened => + simp only [single,List.headD_cons,WHIRHistoryKey.initialPending,initialWireState, + absorbResponse,List.isEmpty_nil,ite_true,Option.some.injEq,Prod.mk.injEq] at parsed + obtain ⟨rfl,rfl⟩ := parsed + obtain ⟨nonceTape,noncePrevious,nonceReplies,nonceRows,nonceInitial⟩ := + afterNonce_fields _ _ _ boundNonce + obtain ⟨replies,tape,previous,initial,extended,covered⟩ := + takeSample_fields _ _ _ _ _ _ _ opened + obtain ⟨seed,seedState,seedEntry⟩ := recordSample_initial _ _ _ first + have history : localHistory ctx stack Q p [⟨.inl packet,raw⟩] = + [localEntry ctx stack Q p packet profile raw] := by + simpa [localHistory,WHIRRawReplay.decodeHistory] using + localHistory_append ctx stack Q p packet profile raw [] + refine ⟨profile,raw,[],WHIRReplay.zeroTape p,seed,history,previous,?_,?_,?_,?_,covered,?_⟩ + · dsimp only [withOutput] + rw [tape,recordSample_tape,nonceTape] + · exact initial.trans seedState + · rw [history] + exact seedEntry + · dsimp only [withOutput] + rw [replies,nonceReplies] + exact size.symm + · intro statement rows table + dsimp only [withOutput] + rw [replies,nonceReplies,single] + rfl + +theorem completed_next {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet priorPacket : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + {history : List (Sigma (GroupAnswer ctx Q))} (head : WHIRHistory.Pending) + (messages : packet.val.messages = head :: priorPacket.val.messages) + (statement : priorPacket.val.statement = packet.val.statement) + (prior : Completed stack priorPacket state history) + (step : Step ctx stack Q p lanes proofs packet profile state raw out) : + Completed stack packet out (history ++ [⟨.inl packet,raw⟩]) := by + obtain ⟨priorProfile,priorRaw,past,before,seed,priorHistory,priorPrevious,priorTape, + priorInitial,priorSeed,priorSize,priorCovered,priorDecoded⟩ := prior + have later : packetQuery ctx Q p packet profile ≠ .initial := by + intro first + have position := packetQuery_position ctx Q p packet profile + rw [first] at position + have positive := List.length_pos_iff.mpr priorPacket.property.2.1 + simp only [messages,List.length_cons] at position + simp [CausalProbability.position,CausalProbability.visibleCoordinates] at position + omega + have tables := step.extends + cases step with + | run parsed size shape boundNonce accepted opened => + have headEq : packet.val.messages.headD ⟨[],none⟩ = head := by simp [messages] + rw [headEq] at parsed shape + obtain ⟨response,responseParsed,responseReplies⟩ := + absorbResponse_some _ _ _ _ _ priorPrevious parsed + obtain ⟨absorbedRows,absorbedTape,absorbedPrevious,absorbedInitial⟩ := + absorbResponse_rows _ _ _ _ parsed + obtain ⟨nonceTape,noncePrevious,nonceReplies,nonceRows,nonceInitial⟩ := + afterNonce_fields _ _ _ boundNonce + obtain ⟨replies,tape,previous,initial,extended,covered⟩ := + takeSample_fields _ _ _ _ _ _ _ opened + refine ⟨profile,raw,localEntry ctx stack Q p priorPacket priorProfile priorRaw :: past, + state.tape,seed,?_,previous,?_,?_,?_,?_,covered,?_⟩ + · rw [localHistory_append,priorHistory] + · dsimp only [withOutput] + rw [tape,recordSample_tape,nonceTape,absorbedTape] + · dsimp only [withOutput] + rw [initial,recordSample_noninitial _ _ _ later,nonceInitial,absorbedInitial,priorInitial] + · rw [localHistory_append ctx stack Q p packet profile raw history] + have nonempty : localHistory ctx stack Q p history ≠ [] := by rw [priorHistory]; simp + simpa only [StackWHIRReplay.initialSeed,List.getLast?_cons_of_ne_nil nonempty] using priorSeed + · dsimp only [withOutput] + rw [replies,nonceReplies] + exact size.symm + · intro replayStatement rows table + have priorTable := table.of_extends tables.1 + have parsedBefore := priorDecoded replayStatement rows priorTable + have responseAtRows := (reply_rowTable state _ head rows priorTable priorCovered priorPrevious).trans responseParsed + have priorPosition := packetQuery_position ctx Q p priorPacket priorProfile + have currentPosition := packetQuery_position ctx Q p packet profile + have priorQuery := packetQuery_eq ctx Q p priorPacket priorProfile packet.val.statement + have currentQuery := packetQuery_eq ctx Q p packet profile packet.val.statement + have nonceShape := nonceMatches_shape _ _ shape + cases priorMessages : priorPacket.val.messages with + | nil => exact False.elim (priorPacket.property.2.1 priorMessages) + | cons pending older => + rw [messages,priorMessages] + simp only [localEntry,StackWHIRReplay.projectEntry,List.map_cons,List.headD_cons,priorMessages] + simp only [messages,priorMessages,List.length_cons,Nat.add_sub_cancel] at priorPosition currentPosition + rw [messages,priorMessages] at currentQuery + rw [priorMessages] at priorQuery + rw [statement,priorMessages] at parsedBefore + simp only [WHIRPhysicalHistory.decodeHistory,← priorQuery,priorPosition,← currentQuery, + currentPosition,nonceShape,ite_true,parsedBefore, + WHIRPhysicalHistory.step,responseAtRows,Option.map_some] + dsimp only [withOutput] + rw [replies,nonceReplies,responseReplies,priorTape] + rfl + +theorem trace_completed {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history : List (Sigma (GroupAnswer ctx Q))} (root : Digest32) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) : + Completed stack packet out history := by + induction chain generalizing out history with + | initial packet single => + cases trace with + | cons profile step rest => + cases rest + exact completed_initial root single step + | next head prior messages statement profile ih => + obtain ⟨middle,before,after,hist,first,last⟩ := Trace.append_inv _ _ trace + cases last with + | cons finalProfile step rest => + cases rest + subst history + exact completed_next head messages statement (ih first) step + +theorem initialSeed_cons_noninitial {c : Config} (q : CausalProbability.Coordinate c) + (x : StackWHIRReplay.Sample q) (pending : WHIRHistory.Pending) + (past : List (WHIRHistory.Pending × Sigma (@StackWHIRReplay.Sample c))) (later : q ≠ .initial) : + StackWHIRReplay.initialSeed ((pending,⟨q,x⟩)::past) = StackWHIRReplay.initialSeed past := by + cases past with + | nil => cases q <;> simp_all [StackWHIRReplay.initialSeed,StackWHIRReplay.seedValue] + | cons entry past => + unfold StackWHIRReplay.initialSeed + rw [List.getLast?_cons_of_ne_nil (show entry::past ≠ [] from by simp)] + +/-- Actual completed physical rows, not an ideal-row agreement assumption, make the stack decoder succeed. The nonempty reply condition is derived separately from the native verifier's opening acceptance. -/ +theorem Completed.decodeStack {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (packet : RawWHIRKeys.Packet ctx Q) (state : WireState packet.val.profile) + (history : List (Sigma (GroupAnswer ctx Q))) + (catalog : StackWHIRReplay.Catalog packet.val.profile cap) + (original : WHIRFiatShamir.StackInitial packet.val.profile cap) + (found : catalog packet.val.statement = some original) + (complete : Completed stack packet state history) (nonempty : state.replies ≠ #[]) : + ∃ head past, ∃ (x : StackWHIRReplay.Sample (WHIRReplay.query packet.val.profile + (packet.val.statement,packet.val.messages))) (replay : StackWHIRReplay.Replay packet.val.profile cap), + localHistory ctx stack Q packet.val.profile history = + (head,⟨WHIRReplay.query packet.val.profile (packet.val.statement,packet.val.messages),x⟩)::past ∧ + WHIRPhysicalHistory.decodeStack packet.val.profile cap catalog (fun _ _ => #[]) + (fun i => state.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ = some replay ∧ + replay.original = original ∧ state.initial = some replay.initial ∧ + replay.whir.statement = StackWHIRReplay.transformedStatement original replay.initial.1 ∧ + (StackWHIRReplay.finish ⟨packet.val.statement,packet.val.messages,past⟩ replay x).whir.tape = state.tape ∧ + (StackWHIRReplay.finish ⟨packet.val.statement,packet.val.messages,past⟩ replay x).whir.replies = state.replies := by + obtain ⟨profile,raw,past,before,seed,historyEq,previous,tape,initial,initialSeed,size,covered,decoded⟩ := complete + have positive : 0 < state.replies.size := by + by_contra notPositive + have empty : state.replies.toList = [] := List.length_eq_zero_iff.mp (by + change state.replies.size = 0 + omega) + apply nonempty + simpa using congrArg List.toArray empty + have later : packetQuery ctx Q packet.val.profile packet profile ≠ .initial := by + intro first + have position := packetQuery_position ctx Q packet.val.profile packet profile + rw [first] at position + simp [CausalProbability.position,CausalProbability.visibleCoordinates] at position + omega + rw [historyEq] at initialSeed + have pastSeed : StackWHIRReplay.initialSeed past = some seed := + (initialSeed_cons_noninitial _ _ _ _ later).symm.trans initialSeed + let replay : StackWHIRReplay.Replay packet.val.profile cap := + ⟨original,seed,⟨StackWHIRReplay.transformedStatement original seed.1,before,state.replies⟩⟩ + refine ⟨packet.val.messages.headD ⟨[],none⟩,past, + packetSample ctx stack Q packet.val.profile packet profile raw,replay,historyEq,?_,rfl,initial,rfl,?_,rfl⟩ + · have parsed := decoded (StackWHIRReplay.transformedStatement original seed.1) + (fun i => state.rows[i]!) (fun _ _ => rfl) + simp only [WHIRPhysicalHistory.decodeStack,found,pastSeed, + WHIRPhysicalHistory.decode,StackWHIRReplay.projectKey] + change (WHIRPhysicalHistory.decodeHistory packet.val.profile + (fun _ => some (StackWHIRReplay.transformedStatement original seed.1)) (fun _ _ => #[]) + (fun i => state.rows[i]!) packet.val.statement packet.val.messages + (past.map StackWHIRReplay.projectEntry)).bind _ = some replay + rw [parsed] + rfl + · exact tape.symm + +/-- The actual source reader produces the replay invariant for its canonical packet completion. No future oracle table occurs in this statement or its proof. -/ +theorem readPhysicalCompletion_completed {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (lanes : Nat) + (proofs : Array PrunedMerklePaths) (root : Digest32) + (next : WireState packet.val.profile → List (Sigma (GroupAnswer ctx Q)) → WHIRSourceChronology.Source cap (Option R)) + (observations : List Observation) (result : R) + (run : Runs (WHIRSourceChronology.erase + (readPhysicalPackets ctx stack Q packet.val.profile lanes proofs none (completion ctx Q packet) + (completion_profiles ctx Q packet) (initialWireState packet.val.profile root) next)) observations (some result)) : + ∃ state history suffix, Completed stack packet state history ∧ + Runs (WHIRSourceChronology.erase (next state history)) suffix (some result) := by + obtain ⟨state,history,suffix,trace,last⟩ := + readPhysicalPackets_trace ctx stack Q packet.val.profile lanes proofs _ _ _ next observations result run + exact ⟨state,history,suffix,trace_completed root (completion_chain ctx Q packet) trace,last⟩ + +end Whir.WHIRPhysicalReplay diff --git a/verification/whir/Whir/WHIRPhysicalRoots.lean b/verification/whir/Whir/WHIRPhysicalRoots.lean new file mode 100644 index 000000000..5136d1999 --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalRoots.lean @@ -0,0 +1,742 @@ +import Whir.WHIRPhysicalReplay +import Whir.WHIRNativeRestoration +import Whir.WHIRQueryOracleRecurrence + +/-! Actual physical traces determine the immutable digest log, query payload slots, and sampled query coordinates. Canonical scalar decoding connects that log to the proof-only commitment replay, deriving stack row agreement from per-opening Merkle binding without replacing source rows or assuming a root-position association. -/ + +namespace Whir.WHIRPhysicalRoots +open Concrete Protocol FiatShamirGame DuplexModeGame PublicMerkleProgram MerkleTransport +open RawOracleCoupling RawOracleCoupling.Concrete WHIRPhysicalVerifier WHIRPhysicalReplay + +/-- The root carried in this physical response, interpreted at its preceding canonical coordinate. -/ +def packetRoot {ctx : RawWHIRKeys.Context} {Q : Nat} (packet : RawWHIRKeys.Packet ctx Q) : Option Digest32 := + absorbedRoot (WHIRReplay.query packet.val.profile (packet.val.statement,packet.val.messages.tail)) + (packet.val.messages.headD ⟨[],none⟩).scalars + +private theorem afterNonce_roots {p : ParameterBounds.Profile} {ctx : RawWHIRKeys.Context} {Q : Nat} + {packet : RawWHIRKeys.Packet ctx Q} (state out : WireState p) + (nonce : WHIRPowProgram.Outcome ctx Q packet) (ok : afterNonce state nonce = some out) : + out.roots = state.roots ∧ out.openings = state.openings := by + unfold afterNonce at ok + split at ok + · cases Option.some.inj ok + exact ⟨rfl,rfl⟩ + · cases cached : state.outputCache with + | none => simp [cached] at ok + | some digest => + simp only [cached,Option.map_some,Option.some.injEq] at ok + subst out + exact ⟨rfl,rfl⟩ + +theorem takeSample_roots {p : ParameterBounds.Profile} (lanes : Nat) + (proofs : Array PrunedMerklePaths) (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : Runs (takeSample lanes proofs state q x) trace (some out)) : + out.roots = state.roots ∧ ∀ opened ∈ state.openings, opened ∈ out.openings := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run + obtain ⟨before,opened,after,_,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + exact ⟨rfl,fun _ h => List.mem_cons_of_mem _ h⟩ + · cases run + | initial => cases run; exact ⟨rfl,fun _ h => h⟩ + | fold i j => cases run; exact ⟨rfl,fun _ h => h⟩ + | ood i j => cases run; exact ⟨rfl,fun _ h => h⟩ + | tail j => cases run; exact ⟨rfl,fun _ h => h⟩ + +theorem absorbResponse_roots {p : ParameterBounds.Profile} (state out : WireState p) + (pending : WHIRHistory.Pending) (root : Option Digest32) + (ok : absorbResponse state pending = some (out,root)) : + out.roots = state.roots ++ root.toArray ∧ out.openings = state.openings ∧ + root = state.previous.bind (fun q => absorbedRoot q pending.scalars) := by + unfold absorbResponse at ok + cases previous : state.previous with + | none => + simp only [previous] at ok + split at ok + · cases Option.some.inj ok + simp + · contradiction + | some q => + simp only [previous] at ok + change (WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending).bind _ = + some (out,root) at ok + cases parsed : WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending with + | none => simp [parsed] at ok + | some response => + simp only [parsed,Option.bind_some,Option.some.injEq,Prod.mk.injEq] at ok + obtain ⟨rfl,rfl⟩ := ok + cases hroot : absorbedRoot q pending.scalars <;> simp [hroot] + +theorem Step.roots {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p lanes proofs packet profile state raw out) : + out.roots = state.roots ++ + (state.previous.bind (fun q => absorbedRoot q (packet.val.messages.headD ⟨[],none⟩).scalars)).toArray ∧ + ∀ opened ∈ state.openings, opened ∈ out.openings := by + cases step with + | run parsed size shape boundNonce accepted opened => + obtain ⟨roots,openings,root⟩ := absorbResponse_roots _ _ _ _ parsed + obtain ⟨nonceRoots,nonceOpenings⟩ := afterNonce_roots _ _ _ boundNonce + obtain ⟨sampleRoots,sampleOpenings⟩ := takeSample_roots _ _ _ _ _ _ _ opened + constructor + · dsimp only [withOutput] + rw [sampleRoots,nonceRoots,roots,root] + · intro opening member + apply sampleOpenings + rwa [nonceOpenings,openings] + +theorem packetRoot_next {ctx : RawWHIRKeys.Context} {Q : Nat} {p : ParameterBounds.Profile} + (packet prior : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) + (priorProfile : prior.val.profile = p) (head : WHIRHistory.Pending) + (messages : packet.val.messages = head :: prior.val.messages) + (_statement : prior.val.statement = packet.val.statement) : + packetRoot packet = absorbedRoot (packetQuery ctx Q p prior priorProfile) head.scalars := by + rw [packetQuery_eq ctx Q p prior priorProfile packet.val.statement] + cases profile + simp only [packetRoot,messages,List.tail_cons,List.headD_cons] + +theorem absorbedRoot_empty {c : Config} (q : CausalProbability.Coordinate c) : + absorbedRoot q [] = none := by + cases q <;> simp [absorbedRoot] + +/-- A completed canonical source trace has exactly its transmitted final-fold roots, in arrival order. -/ +theorem trace_roots {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history : List (Sigma (GroupAnswer ctx Q))} (root : Digest32) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) : + out.roots = #[root] ++ (packets.filterMap packetRoot).toArray := by + induction chain generalizing out history with + | initial packet single => + cases trace with + | cons profile step rest => + cases rest + rw [(Step.roots step).1] + simp [initialWireState,packetRoot,single,WHIRHistoryKey.initialPending,absorbedRoot_empty] + | @next packet previousPacket packets head prior messages statement profile ih => + obtain ⟨middle,before,after,hist,first,last⟩ := Trace.append_inv _ _ trace + cases last with + | cons finalProfile step rest => + cases rest + obtain ⟨priorProfile,priorRaw,past,tape,seed,priorHistory,previous,rest⟩ := + trace_completed root prior first + rw [(Step.roots step).1,previous,Option.bind_some, + show (packet.val.messages.headD ⟨[],none⟩).scalars = head.scalars by simp [messages], + ← packetRoot_next packet _ finalProfile priorProfile head messages statement,ih first] + cases found : packetRoot packet <;> simp [List.filterMap_append,found] + +/-- Every retained opening names the actual root and actual row-array slot used by the physical source. -/ +def RootedOpenings {p : ParameterBounds.Profile} (state : WireState p) : Prop := + ∀ opened ∈ state.openings, + state.roots[opened.level.val]? = some opened.root ∧ + state.rows[opened.level.val]? = some opened.result.rows + +private theorem append_preserves {α : Type} (a b : Array α) (i : Nat) (v : α) + (found : a[i]? = some v) : (a ++ b)[i]? = some v := by + obtain ⟨bound,equal⟩ := Array.getElem?_eq_some_iff.mp found + apply Array.getElem?_eq_some_iff.mpr + refine ⟨by simp; omega,?_⟩ + rw [Array.getElem_append_left bound] + exact equal + +theorem takeSample_rooted {p : ParameterBounds.Profile} (lanes : Nat) + (proofs : Array PrunedMerklePaths) (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : Runs (takeSample lanes proofs state q x) trace (some out)) + (rooted : RootedOpenings state) : RootedOpenings out := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · rename_i index + cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run + obtain ⟨before,opened,after,_,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + intro old member + rcases List.mem_cons.mp member with same | member + · subst old + exact ⟨hr,by simp [index]⟩ + · obtain ⟨root,row⟩ := rooted old member + refine ⟨root,?_⟩ + exact append_preserves state.rows #[opened.rows] old.level.val old.result.rows row + · cases run + | initial => cases run; exact rooted + | fold i j => cases run; exact rooted + | ood i j => cases run; exact rooted + | tail j => cases run; exact rooted + +theorem Step.rooted {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p lanes proofs packet profile state raw out) + (rooted : RootedOpenings state) : RootedOpenings out := by + cases step with + | run parsed size shape boundNonce accepted opened => + obtain ⟨roots,openings,_⟩ := absorbResponse_roots _ _ _ _ parsed + obtain ⟨rows,_,_,_⟩ := absorbResponse_rows _ _ _ _ parsed + obtain ⟨nonceRoots,nonceOpenings⟩ := afterNonce_roots _ _ _ boundNonce + obtain ⟨_,_,_,nonceRows,_⟩ := afterNonce_fields _ _ _ boundNonce + apply takeSample_rooted _ _ _ _ _ _ _ opened + intro opening member + rw [nonceOpenings,openings] at member + obtain ⟨root,row⟩ := rooted opening member + constructor + · rw [nonceRoots,roots] + exact append_preserves _ _ _ _ root + · rwa [nonceRows,rows] + +theorem Trace.rooted {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs packets state out history) + (rooted : RootedOpenings state) : RootedOpenings out := by + induction trace with + | nil => exact rooted + | cons profile step rest ih => exact ih (Step.rooted step rooted) + +theorem trace_rooted {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {out : WireState p} {history} + (root : Digest32) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) : + RootedOpenings out := + Trace.rooted trace (by simp [RootedOpenings,initialWireState]) + +/-- Retained query answers are exactly the coordinates in the current tape, all strictly before the next allocation position. -/ +def OpeningSamples {p : ParameterBounds.Profile} (bound : Nat) (state : WireState p) : Prop := + ∀ opened ∈ state.openings, + CausalProbability.position (.query opened.level) < bound ∧ + CausalProbability.get (.query opened.level) state.tape = opened.sample + +private theorem sampled_old {p : ParameterBounds.Profile} (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (samples : OpeningSamples (CausalProbability.position q) state) (opened : QueryOpening p) + (member : opened ∈ state.openings) : + CausalProbability.position (.query opened.level) < CausalProbability.position q + 1 ∧ + CausalProbability.get (.query opened.level) (recordSample state q x).tape = opened.sample := by + obtain ⟨bound,sample⟩ := samples opened member + constructor + · omega + · rw [recordSample_tape,CausalProbability.get_set_ne] + · exact sample + · intro same + have := congrArg CausalProbability.position same + omega + +theorem takeSample_samples {p : ParameterBounds.Profile} (lanes : Nat) + (proofs : Array PrunedMerklePaths) (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : Runs (takeSample lanes proofs state q x) trace (some out)) + (samples : OpeningSamples (CausalProbability.position q) state) : + OpeningSamples (CausalProbability.position q + 1) out := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run + obtain ⟨before,opened,after,_,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + intro old member + rcases List.mem_cons.mp member with same | member + · subst old + constructor + · exact Nat.lt_succ_self _ + · exact CausalProbability.get_set _ _ _ + · exact sampled_old state (.query i) x samples old member + · cases run + | initial => cases run; exact sampled_old state .initial x samples + | fold i j => cases run; exact sampled_old state (.fold i j) x samples + | ood i j => cases run; exact sampled_old state (.ood i j) x samples + | tail j => cases run; exact sampled_old state (.tail j) x samples + +theorem Step.samples {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p lanes proofs packet profile state raw out) + (samples : OpeningSamples (CausalProbability.position (packetQuery ctx Q p packet profile)) state) : + OpeningSamples (CausalProbability.position (packetQuery ctx Q p packet profile) + 1) out := by + cases step with + | run parsed size shape boundNonce accepted opened => + obtain ⟨_,openings,_⟩ := absorbResponse_roots _ _ _ _ parsed + obtain ⟨_,tape,_,_⟩ := absorbResponse_rows _ _ _ _ parsed + obtain ⟨_,nonceOpenings⟩ := afterNonce_roots _ _ _ boundNonce + obtain ⟨nonceTape,_,_,_,_⟩ := afterNonce_fields _ _ _ boundNonce + apply takeSample_samples _ _ _ _ _ _ _ opened + intro opening member + rw [nonceOpenings,openings] at member + simpa only [nonceTape,tape] using samples opening member + +theorem trace_samples {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history : List (Sigma (GroupAnswer ctx Q))} (root : Digest32) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) : + OpeningSamples packet.val.messages.length out := by + induction chain generalizing out history with + | initial packet single => + cases trace with + | cons profile step rest => + cases rest + have h := Step.samples step (by simp [OpeningSamples,initialWireState]) + rwa [packetQuery_position,show packet.val.messages.length - 1 + 1 = packet.val.messages.length by + have := List.length_pos_iff.mpr packet.property.2.1; omega] at h + | @next packet previousPacket packets head prior messages statement profile ih => + obtain ⟨middle,before,after,hist,first,last⟩ := Trace.append_inv _ _ trace + cases last with + | cons finalProfile step rest => + cases rest + have samples := ih first + have qpos := packetQuery_position ctx Q p packet finalProfile + rw [messages,List.length_cons,Nat.add_sub_cancel] at qpos + have h := Step.samples step (by rwa [qpos]) + simpa only [qpos,messages,List.length_cons] using h + +def RecordedQuery {p : ParameterBounds.Profile} (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) : Prop := + match q,x with + | .query i,x => ∃ opened ∈ state.openings, opened.level = i ∧ HEq opened.sample x + | _,_ => True + +theorem takeSample_recorded {p : ParameterBounds.Profile} (lanes : Nat) + (proofs : Array PrunedMerklePaths) (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : Runs (takeSample lanes proofs state q x) trace (some out)) : + RecordedQuery out q x := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run + obtain ⟨before,opened,after,_,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + exact ⟨_,List.mem_cons_self, rfl, HEq.rfl⟩ + · cases run + | initial => trivial + | fold i j => trivial + | ood i j => trivial + | tail j => trivial + +theorem Trace.openings_mono {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs packets state out history) : + ∀ opened ∈ state.openings, opened ∈ out.openings := by + induction trace with + | nil => exact fun _ h => h + | cons profile step rest ih => exact fun opened h => ih opened ((Step.roots step).2 opened h) + +theorem Step.recorded {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p lanes proofs packet profile state raw out) : + RecordedQuery out (packetQuery ctx Q p packet profile) (packetSample ctx stack Q p packet profile raw) := by + cases step with + | run parsed size shape boundNonce accepted opened => + simpa only [RecordedQuery,withOutput] using takeSample_recorded _ _ _ _ _ _ _ opened + +theorem RecordedQuery.mono {p : ParameterBounds.Profile} {state out : WireState p} + {q : CausalProbability.Coordinate (ParameterBounds.config p)} {x : StackWHIRReplay.Sample q} + (recorded : RecordedQuery state q x) + (mono : ∀ opened ∈ state.openings, opened ∈ out.openings) : RecordedQuery out q x := by + cases q with + | query i => + obtain ⟨opened,member,level,sample⟩ := recorded + exact ⟨opened,mono opened member,level,sample⟩ + | initial => trivial + | fold i j => trivial + | ood i j => trivial + | tail j => trivial + +theorem localHistory_cons (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) + (raw : GroupAnswer ctx Q (.inl packet)) (history : List (Sigma (GroupAnswer ctx Q))) : + localHistory ctx stack Q p (⟨.inl packet,raw⟩::history) = + localHistory ctx stack Q p history ++ [localEntry ctx stack Q p packet profile raw] := by + simp [localHistory,WHIRRawReplay.decodeHistory,WHIRRawReplay.decodeEntry, + List.filterMap_append,localEntry_eq ctx stack Q p packet profile raw] + +theorem trace_recorded {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs packets state out history) : + ∀ entry ∈ localHistory ctx stack Q p history, RecordedQuery out entry.2.1 entry.2.2 := by + induction trace with + | nil => simp [localHistory,WHIRRawReplay.decodeHistory] + | @cons packet packets state next final raw history profile step rest ih => + rw [localHistory_cons ctx stack Q p packet profile raw] + intro entry member + rcases List.mem_append.mp member with member | member + · exact ih entry member + · have equal := List.mem_singleton.mp member + subst entry + exact (Step.recorded step).mono (Trace.openings_mono rest) + +/-- Per-opening binding obtained from the counted Merkle program, retaining its actual payload. -/ +def BoundRows {p : ParameterBounds.Profile} (base : CausalGame.BaseOracle) + (roots : WHIRReplay.Roots) (state : WireState p) : Prop := + ∀ opened ∈ state.openings, opened.result.rows = + atQueries (if opened.level.val = 0 then CausalGame.liftRoot base else roots opened.root opened.level.val) + (queryIndices p opened.level opened.sample) + +theorem trace_query_rows {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {out : WireState p} {history} + (root : Digest32) (base : CausalGame.BaseOracle) (roots : WHIRReplay.Roots) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) + (bound : BoundRows base roots out) (pending : WHIRHistory.Pending) + (i : Fin (ParameterBounds.config p).folds.size) (x : CausalProbability.Sample (.query i)) + (member : (pending,⟨.query i,x⟩) ∈ localHistory ctx stack Q p history) : + out.rows[i.val]! = + atQueries (if i.val = 0 then CausalGame.liftRoot base else roots out.roots[i.val]! i.val) + (queryIndices p i x) := by + obtain ⟨opened,openedMember,level,sample⟩ := trace_recorded trace _ member + obtain ⟨rootFound,rowFound⟩ := trace_rooted root trace opened openedMember + have binding := bound opened openedMember + cases opened with + | mk level' digest sample' result => + dsimp only at level sample rootFound rowFound binding + subst level' + have sampleEq := eq_of_heq sample + subst sample' + obtain ⟨rootBound,rootValue⟩ := Array.getElem?_eq_some_iff.mp rootFound + obtain ⟨rowBound,rowValue⟩ := Array.getElem?_eq_some_iff.mp rowFound + rw [getElem!_pos out.rows i.val rowBound,rowValue, + getElem!_pos out.roots i.val rootBound,rootValue] + exact binding + +theorem Trace.roots_prefix {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs packets state out history) : + ∃ suffix, out.roots = state.roots ++ suffix := by + induction trace with + | nil => exact ⟨#[],by simp⟩ + | cons profile step rest ih => + obtain ⟨suffix,equal⟩ := ih + rw [equal,(Step.roots step).1,Array.append_assoc] + exact ⟨_,rfl⟩ + +theorem trace_query_sample {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history} (root : Digest32) (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) + (pending : WHIRHistory.Pending) (i : Fin (ParameterBounds.config p).folds.size) + (x : CausalProbability.Sample (.query i)) + (member : (pending,⟨.query i,x⟩) ∈ localHistory ctx stack Q p history) : + CausalProbability.get (.query i) out.tape = x := by + obtain ⟨opened,openedMember,level,sample⟩ := trace_recorded trace _ member + have value := (trace_samples root chain trace opened openedMember).2 + cases opened with + | mk level' digest sample' result => + dsimp only at level sample value + subst level' + exact value.trans (eq_of_heq sample) + +theorem projectEntry_query_mem {p : ParameterBounds.Profile} + (past : List (WHIRRawReplay.LocalEntry p)) (pending : WHIRHistory.Pending) + (i : Fin (ParameterBounds.config p).folds.size) (x : CausalProbability.Sample (.query i)) + (member : (pending,⟨.query i,x⟩) ∈ past.map StackWHIRReplay.projectEntry) : + (pending,⟨.query i,x⟩) ∈ past := by + obtain ⟨⟨pending',⟨q,y⟩⟩,inPast,equal⟩ := List.mem_map.mp member + cases q <;> simp_all [StackWHIRReplay.projectEntry,StackWHIRReplay.projectSample] + rcases equal with ⟨_,rfl,heq⟩ + have same := eq_of_heq heq + subst y + exact inPast + +theorem restored_rootShapes (c : Config) (proof : Opening) (lookup : Nat → Oracle) + (shapes : ∀ i, i < c.folds.size → i + 1 < c.folds.size → + oracleValid (lookup (i+1)) (2^(CausalGame.remaining c i-c.folds[i+1]!+c.rates[i+1]!)) + (2^c.folds[i+1]!) = true) : + WHIRNativeArithmetic.RootShapes c (WHIRNativeErasure.restoreOracles proof lookup) := by + intro i hi nextLevel next found + by_cases bound : i < proof.levels.size + · have slot : (WHIRNativeErasure.restoreOracles proof lookup).levels[i]! = + {proof.levels[i] with nextOracle := proof.levels[i].nextOracle.map fun _ => lookup (i+1)} := by + simp [WHIRNativeErasure.restoreOracles,getElem!_pos,bound] + rw [slot] at found + cases present : proof.levels[i].nextOracle with + | none => simp [present] at found + | some oracle => + simp only [present,Option.map_some,Option.some.injEq] at found + rw [← found] + exact shapes i hi nextLevel + · have absent : ¬ i < (WHIRNativeErasure.restoreOracles proof lookup).levels.size := by + simpa [WHIRNativeErasure.restoreOracles] using bound + rw [getElem!_neg (WHIRNativeErasure.restoreOracles proof lookup).levels i absent] at found + cases found + +theorem decodeHistory_statement (p : ParameterBounds.Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List WHIRHistory.Pending) + (ancestors : List (WHIRHistory.Pending × Sigma (@CausalProbability.Sample (ParameterBounds.config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) : + catalog s = some out.statement := by + induction messages generalizing ancestors out with + | nil => cases parsed + | cons m messages ih => + cases messages with + | nil => + cases ancestors with + | cons a ancestors => cases parsed + | nil => + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · cases found : catalog s with + | none => simp [found] at parsed + | some statement => + simp [found] at parsed + subst out + rfl + · cases parsed + | cons previous older => + cases ancestors with + | nil => cases parsed + | cons a past => + rcases a with ⟨previous',q,x⟩ + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · split at parsed + · split at parsed + · split at parsed + · split at parsed + · cases prior : WHIRPhysicalHistory.decodeHistory p catalog roots rows s + (previous :: older) past with + | none => simp [prior] at parsed + | some before => + simp only [prior,WHIRPhysicalHistory.step] at parsed + obtain ⟨response,decoded,rfl⟩ := Option.map_eq_some_iff.mp parsed + exact ih past before prior + · cases parsed + · cases parsed + · cases parsed + · cases parsed + · cases parsed + +theorem decodeHistory_ancestor_query (p : ParameterBounds.Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List WHIRHistory.Pending) + (ancestors : List (WHIRHistory.Pending × Sigma (@CausalProbability.Sample (ParameterBounds.config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) + (k : Nat) (q : CausalProbability.Coordinate (ParameterBounds.config p)) + (atQuery : (ancestors[k]?).map (fun e => e.2.1) = some q) : + q = WHIRReplay.query p (s,messages.drop (k+1)) := by + induction messages generalizing ancestors out k with + | nil => cases parsed + | cons m messages ih => + cases messages with + | nil => + cases ancestors with + | cons a ancestors => cases parsed + | nil => simp at atQuery + | cons previous older => + cases ancestors with + | nil => cases parsed + | cons a past => + rcases a with ⟨previous',current,x⟩ + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · split at parsed + · rename_i phase + split at parsed + · split at parsed + · split at parsed + · cases prior : WHIRPhysicalHistory.decodeHistory p catalog roots rows s + (previous :: older) past with + | none => simp [prior] at parsed + | some before => + cases k with + | zero => + simp only [List.getElem?_cons_zero,Option.map_some,Option.some.injEq] at atQuery + subst q + simpa using phase + | succ k => + have h := ih past before prior k (by simpa using atQuery) + simpa only [List.drop_succ_cons] using h + · cases parsed + · cases parsed + · cases parsed + · cases parsed + · cases parsed + +theorem chain_rootLog {ctx : RawWHIRKeys.Context} {Q : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + (chain : Chain ctx Q packet packets) : + packets.filterMap packetRoot = + WHIRQueryOracleRecurrence.rootLog packet.val.profile packet.val.statement packet.val.messages := by + induction chain with + | initial packet single => + simp [packetRoot,single,WHIRHistoryKey.initialPending,absorbedRoot_empty, + WHIRQueryOracleRecurrence.rootLog,WHIRQueryOracleRecurrence.digestSlots] + | @next packet previous packets head prior messages statement profile ih => + rw [List.filterMap_append,ih,profile,statement,messages] + cases before : previous.val.messages with + | nil => exact False.elim (previous.property.2.1 before) + | cons pending older => + rw [WHIRQueryOracleRecurrence.rootLog_cons] + simp only [List.filterMap_cons,List.filterMap_nil,packetRoot,messages,before, + List.headD_cons,List.tail_cons] + cases absorbedRoot (WHIRReplay.query packet.val.profile + (packet.val.statement,pending::older)) head.scalars <;> rfl + +theorem trace_roots_log {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history} (root : Digest32) (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) : + out.roots = #[root] ++ + (WHIRQueryOracleRecurrence.rootLog packet.val.profile packet.val.statement packet.val.messages).toArray := by + rw [trace_roots root chain trace,chain_rootLog chain] + +theorem rootLog_drop_prefix (p : ParameterBounds.Profile) (s : Digest32) + (messages : List WHIRHistory.Pending) (k : Nat) : + ∃ suffix, WHIRQueryOracleRecurrence.rootLog p s messages = + WHIRQueryOracleRecurrence.rootLog p s (messages.drop k) ++ suffix := by + induction k generalizing messages with + | zero => exact ⟨[],by simp⟩ + | succ k ih => + cases messages with + | nil => exact ⟨[],by simp⟩ + | cons m messages => + cases messages with + | nil => + exact ⟨[],by simp [WHIRQueryOracleRecurrence.rootLog,WHIRQueryOracleRecurrence.digestSlots]⟩ + | cons previous older => + obtain ⟨suffix,equal⟩ := ih (previous::older) + rw [WHIRQueryOracleRecurrence.rootLog_cons,equal,List.drop_succ_cons,List.append_assoc] + exact ⟨_,rfl⟩ + +theorem rootLog_drop_get (p : ParameterBounds.Profile) (s : Digest32) + (messages : List WHIRHistory.Pending) (k j : Nat) (digest : Digest32) + (found : (WHIRQueryOracleRecurrence.rootLog p s (messages.drop k))[j]? = some digest) : + (WHIRQueryOracleRecurrence.rootLog p s messages)[j]? = some digest := by + obtain ⟨suffix,equal⟩ := rootLog_drop_prefix p s messages k + obtain ⟨bound,value⟩ := List.getElem?_eq_some_iff.mp found + rw [equal,List.getElem?_append_left bound] + exact found + +theorem trace_digest_from_prefix {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history} (root : Digest32) (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) + (k j : Nat) (digest : Digest32) + (found : (WHIRQueryOracleRecurrence.rootLog packet.val.profile packet.val.statement + (packet.val.messages.drop k))[j]? = some digest) : + out.roots[j+1]? = some digest := by + have full := rootLog_drop_get _ _ _ k j digest found + rw [trace_roots_log root chain trace] + simpa using full + +/-- The complete physical trace discharges row agreement from actual per-opening Merkle binding. No ideal rows are supplied to the physical decoder. -/ +theorem trace_rowsAgree {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + (packet : RawWHIRKeys.Packet ctx Q) {packets : List (RawWHIRKeys.Packet ctx Q)} + {lanes : Nat} {proofs : Array PrunedMerklePaths} {out : WireState packet.val.profile} {history} + (root : Digest32) (statement : WHIRFiatShamir.Statement packet.val.profile) (roots : WHIRReplay.Roots) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q packet.val.profile lanes proofs packets + (initialWireState packet.val.profile root) out history) + (bound : BoundRows statement.root roots out) : + WHIRPhysicalHistory.RowsAgree packet.val.profile (fun _ => some statement) roots + (fun i => out.rows[i]!) packet.val.statement packet.val.messages + ((localHistory ctx stack Q packet.val.profile history).tail.map StackWHIRReplay.projectEntry) := by + obtain ⟨profile,raw,past,before,seed,historyEq,previous,tape,initial,initialSeed,size,covered,decoded⟩ := + trace_completed root chain trace + have zeroParsed := decoded statement (fun i => out.rows[i]!) (fun _ _ => rfl) + have pastEq : (localHistory ctx stack Q packet.val.profile history).tail = past := by + rw [historyEq] + rfl + intro k pending i x replay atQuery parsed + change out.rows[i.val]! = WHIRReplay.queryRows replay i x + have inProjected : (pending,⟨.query i,x⟩) ∈ + (localHistory ctx stack Q packet.val.profile history).tail.map StackWHIRReplay.projectEntry := + List.mem_of_getElem? atQuery + have inPast := projectEntry_query_mem _ pending i x inProjected + have inHistory := List.mem_of_mem_tail inPast + have actual := trace_query_rows root statement.root roots trace bound pending i x inHistory + have phase := decodeHistory_ancestor_query packet.val.profile (fun _ => some statement) + (fun _ _ => #[]) (fun i => out.rows[i]!) packet.val.statement packet.val.messages + (past.map StackWHIRReplay.projectEntry) _ zeroParsed k (.query i) + (by rw [← pastEq,atQuery]; rfl) + by_cases first : i.val = 0 + · have origin := decodeHistory_statement packet.val.profile (fun _ => some statement) + roots (fun i => out.rows[i]!) packet.val.statement _ _ replay parsed + have same : replay.statement = statement := (Option.some.inj origin).symm + rw [actual,ite_eq_left first,WHIRQueryOracleRecurrence.queryRows_zero replay i first x] + simp [atQueries,queryIndices,same,← Array.toList_map] + · have later : 0 < i.val := by omega + obtain ⟨digest,digestFound,ideal⟩ := WHIRQueryOracleRecurrence.queryRows_decoded_rootLog + packet.val.profile (fun _ => some statement) roots (fun i => out.rows[i]!) packet.val.statement + (packet.val.messages.drop (k+1)) + (((localHistory ctx stack Q packet.val.profile history).tail.map StackWHIRReplay.projectEntry).drop (k+1)) + replay parsed + (WHIRHistory.scheduledAdmissible_drop _ _ _ packet.property.2.2.1) i phase.symm later x + have found := trace_digest_from_prefix root chain trace (k+1) (i.val-1) digest digestFound + have index : i.val - 1 + 1 = i.val := by omega + rw [index] at found + obtain ⟨rootBound,rootValue⟩ := Array.getElem?_eq_some_iff.mp found + rw [actual,ite_eq_right first,getElem!_pos out.roots i.val rootBound,rootValue,ideal] + simp [atQueries,queryIndices,← Array.toList_map] + +/-- Exact stack-history bridge for the key extracted from the actual completed local history. The only authentication premise is the opened-row equality. -/ +theorem trace_stackRowsAgree {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (packet : RawWHIRKeys.Packet ctx Q) {packets : List (RawWHIRKeys.Packet ctx Q)} + {lanes : Nat} {proofs : Array PrunedMerklePaths} {out : WireState packet.val.profile} {history} + (root : Digest32) (catalog : StackWHIRReplay.Catalog packet.val.profile cap) + (original : WHIRFiatShamir.StackInitial packet.val.profile cap) (roots : WHIRReplay.Roots) + (found : catalog packet.val.statement = some original) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q packet.val.profile lanes proofs packets + (initialWireState packet.val.profile root) out history) + (bound : BoundRows original.root roots out) : + WHIRPhysicalHistory.StackRowsAgree packet.val.profile cap catalog roots (fun i => out.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile history).tail⟩ := by + intro other initial foundOther seed + have same : other = original := Option.some.inj (foundOther.symm.trans found) + subst other + exact trace_rowsAgree packet root (StackWHIRReplay.transformedStatement original initial.1) roots + chain trace bound + +end Whir.WHIRPhysicalRoots diff --git a/verification/whir/Whir/WHIRPhysicalRowsRegression.lean b/verification/whir/Whir/WHIRPhysicalRowsRegression.lean new file mode 100644 index 000000000..dcd50eeff --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalRowsRegression.lean @@ -0,0 +1,114 @@ +import Whir.WHIRPhysicalVerifier + +namespace Whir.WHIRPhysicalRowsRegression +open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments MerkleBinding + +private def padded : List K := List.replicate 63 0 ++ [7] +private def snapshot : Snapshot := ⟨{ByteCodec.wordsBytes padded},[]⟩ +private def root : Digest32 := PublicMerkleLog.hashBlake2s (ByteCodec.wordsBytes padded) + +private theorem single_leaf_extracted (hash : Primitive) (stored : List K) : + row hash ⟨{ByteCodec.wordsBytes stored},[]⟩ (hash (ByteCodec.wordsBytes stored)) 0 0 = stored := by + classical + let H := hashing hash + have existsPath : ∃ path : Opening (List K) Digest32 [], + path.inputs H ⊆ {ByteCodec.wordsBytes stored} ∧ + path.digest H = hash (ByteCodec.wordsBytes stored) := + ⟨.leaf stored,by simp [Opening.inputs,H,hashing],rfl⟩ + change idealRow H {ByteCodec.wordsBytes stored} (hash (ByteCodec.wordsBytes stored)) [] [] = stored + unfold idealRow + rw [dite_eq_left existsPath] + have recorded := existsPath.choose_spec.1 + cases chosen : existsPath.choose with + | leaf words => + have member : ByteCodec.wordsBytes words ∈ ({ByteCodec.wordsBytes stored} : Finset (List Byte)) := + recorded (by rw [chosen]; simp [Opening.inputs,H,hashing]) + exact ByteCodec.wordsBytes_injective (Finset.mem_singleton.mp member) + +private theorem extracted : row PublicMerkleLog.hashBlake2s snapshot root 0 0 = padded := + single_leaf_extracted _ _ + +/-- An occupied nonzero lane must survive the full padded leaf extraction. -/ +example : WHIRPhysicalRows.compactBaseRow PublicMerkleLog.hashBlake2s snapshot root 0 0 64 1 = [7] := by + rw [WHIRPhysicalRows.compactBaseRow,baseRow,extracted] + norm_num [padded] + +/-- The old caller supplied the occupied width to a full-leaf normalizer. -/ +example : baseRow PublicMerkleLog.hashBlake2s snapshot root 0 0 1 = [0] := by + rw [baseRow,extracted] + norm_num [padded] + +private def fullWords : List K := [9,4,2,7] +private def fullSnapshot : Snapshot := ⟨{ByteCodec.wordsBytes fullWords},[]⟩ +private def fullRoot : Digest32 := PublicMerkleLog.hashBlake2s (ByteCodec.wordsBytes fullWords) + +private theorem full_width_row : + WHIRPhysicalRows.compactBaseRow PublicMerkleLog.hashBlake2s fullSnapshot fullRoot 0 0 4 4 = + [9,4,2,7] := by + have h : row PublicMerkleLog.hashBlake2s fullSnapshot fullRoot 0 0 = fullWords := + single_leaf_extracted _ _ + rw [WHIRPhysicalRows.compactBaseRow,baseRow,h] + norm_num [fullWords] + +/-- Raw full-width rows are not reversed by extraction; the consumer reverses once. -/ +example : + (WHIRPhysicalRows.compactBaseRow PublicMerkleLog.hashBlake2s fullSnapshot fullRoot 0 0 4 4).reverse = + [7,2,4,9] := by + rw [full_width_row] + rfl + +/-- Expected leaf values and digests are independent fixtures. Digests were +cross-checked with Python hashlib.blake2s, not generated by the verifier. -/ +def smoke : IO Unit := do + let fixtures : List (List K × Nat × List K × List K × List Nat) := + [([7],64,List.replicate 63 0 ++ [7],[7], + [0x2d,0xc2,0x41,0xa9,0x1b,0xcd,0xd5,0x13,0x9f,0xcd,0x55,0xd3,0xe9,0x31,0xb4,0xc3, + 0x23,0xe6,0x61,0x93,0x16,0x22,0xc4,0xf8,0x93,0x69,0xc2,0x78,0x08,0xc1,0xa6,0xb2]), + ([9,4,2,7],4,[9,4,2,7],[7,2,4,9], + [0x3a,0x6d,0x57,0x71,0xfd,0xb1,0xea,0x1e,0x22,0x70,0x3a,0x54,0xbb,0xb3,0x42,0x12, + 0x74,0x28,0x86,0x56,0x16,0x74,0x18,0x31,0x0c,0xf4,0x85,0x0f,0xd0,0x9c,0x49,0x58])] + for (stored,width,expectedImage,expectedFold,digest) in fixtures do + let committed := PublicMerkleLog.hashBlake2s (ByteCodec.wordsBytes expectedImage) + unless (List.ofFn committed).map Fin.val == digest do + throw (IO.userError "ordinary BLAKE2s leaf digest differs from independent fixture") + let proof : PrunedMerklePaths := ⟨[stored],[]⟩ + match proof.open PublicMerkleLog.hashBlake2s committed 1 [0,0] stored.length width with + | none => throw (IO.userError "actual pruned leaf parser rejected a valid occupied row") + | some paths => + unless paths.length == 2 do throw (IO.userError "duplicate query refanout changed") + for path in paths do + unless path.leafData == expectedImage do + throw (IO.userError "padded leaf image differs from explicit fixture") + let occupied := path.leafData.drop (width-stored.length) + unless occupied == stored && occupied.reverse == expectedFold do + throw (IO.userError "occupied row trimming or single reversal is incorrect") + let execution := DuplexModeGame.runReal DuplexModeGame.blake2sOracle DuplexCompression.parameterIV + (WHIRPhysicalVerifier.openRows proof committed 1 [0,0] stored.length width true) + unless execution.primitiveCost == (if width == 64 then 8 else 1) do + throw (IO.userError "physical base verifier hid or duplicated a primitive call") + match execution.view.result with + | none => throw (IO.userError "counted physical base verifier rejected fixture") + | some out => + unless out.rows == #[stored.toArray.map E.ofK,stored.toArray.map E.ofK] do + throw (IO.userError "physical base decoder changed occupied lane order") + unless Protocol.enforced out.rows (Array.replicate width.log2 0) #[1,0] true == E.ofK 7 do + throw (IO.userError "actual base fold consumer did not reverse the occupied row exactly once") + let extensionWords : List K := [1,2,3,4,5,6] + let extensionRoot := PublicMerkleLog.hashBlake2s (ByteCodec.wordsBytes extensionWords) + unless (List.ofFn extensionRoot).map Fin.val == + [0x3f,0xea,0x0b,0x3a,0x10,0x71,0x4c,0x40,0x9f,0x45,0xe2,0x01,0x9e,0xdf,0xd8,0x9f, + 0x72,0x49,0x8c,0x61,0xe8,0x45,0x55,0x94,0x52,0x55,0x1e,0x7c,0xec,0x1b,0xed,0xea] do + throw (IO.userError "extension leaf differs from independent hashlib fixture") + let extension := DuplexModeGame.runReal DuplexModeGame.blake2sOracle DuplexCompression.parameterIV + (WHIRPhysicalVerifier.openRows ⟨[extensionWords],[]⟩ extensionRoot 1 [0,0] 6 6 false) + unless extension.primitiveCost == 1 do throw (IO.userError "extension leaf compression was not counted once") + match extension.view.result with + | none => throw (IO.userError "physical extension decoder rejected a valid row") + | some out => + let row : Array E := #[⟨1,2,3⟩,⟨4,5,6⟩] + unless out.rows == #[row,row] do throw (IO.userError "extension limbs were reordered or reversed") + IO.println "padded64/full4 base and E2 extension: independent BLAKE2s roots, actual counted physical verification, duplicate queries, single base reversal passed" + +#eval smoke + +end Whir.WHIRPhysicalRowsRegression diff --git a/verification/whir/Whir/WHIRPhysicalSnapshots.lean b/verification/whir/Whir/WHIRPhysicalSnapshots.lean new file mode 100644 index 000000000..e9e1458f7 --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalSnapshots.lean @@ -0,0 +1,498 @@ +import Whir.WHIRSourceObserver +import Whir.PublicMerkleBinding +import Whir.PrunedMerkleCoverage + +namespace Whir.WHIRPhysicalSnapshots +open FiatShamirGame DuplexModeGame WHIRSourceChronology WHIRSourceObserver +open MerkleTransport.Commitments CausalBindingState + +variable {cap : Nat} + +/-- A retained whole-hash record was parsed at an actual earlier log prefix. +It need not remain parseable after an output collision changes a predecessor. -/ +def Historical (log : PublicMerkleLog.PublicLog) (retained : Records) : Prop := + ∀ e ∈ retained, ∃ earlier : PublicMerkleLog.PublicLog, + earlier.IsPrefix log ∧ e ∈ PublicMerkleLog.records earlier + +/-- Collection keeps a first answer for every currently recognized input. -/ +def Saturated (log : PublicMerkleLog.PublicLog) (retained : Records) : Prop := + ∀ bytes d, (bytes,d) ∈ PublicMerkleLog.records log → ∃ first, (bytes,first) ∈ retained + +structure Invariant (C : PrimitiveOracle) (state : CausalBindingState.State cap) : Prop where + logAuthentic : PublicMerkleLog.AuthenticLog C state.publicLog + historical : Historical state.publicLog state.records + saturated : Saturated state.publicLog state.records + authentic : AuthenticState (PublicMerkleLog.hash C) state + snapshots : ∀ root snap, lookup root state.registry = some snap → + ∃ retained log, state.frozen root = some retained ∧ state.frozenLog root = some log ∧ + PublicMerkleLog.AuthenticLog C log ∧ Historical log retained ∧ Saturated log retained ∧ + snap.table = recordDomain retained ∧ log.IsPrefix state.publicLog + +theorem prefix_mem {A : Type} {a b : List A} (hp : a.IsPrefix b) {e : A} (member : e ∈ a) : e ∈ b := by + obtain ⟨suffix,rfl⟩ := hp + exact List.mem_append_left _ member + +theorem Historical.weaken {old next : PublicMerkleLog.PublicLog} {retained : Records} + (history : Historical old retained) (hp : old.IsPrefix next) : Historical next retained := by + intro e member + obtain ⟨earlier,he,hm⟩ := history e member + exact ⟨earlier,he.trans hp,hm⟩ + +theorem insert_prefix (log : PublicMerkleLog.PublicLog) (node : DuplexFraming.Node) (answer : Digest32) : + log.IsPrefix (PublicMerkleLog.insert log node answer) := by + unfold PublicMerkleLog.insert + split + · exact ⟨[],by simp⟩ + · exact ⟨[(node,answer)],rfl⟩ + +theorem empty_invariant (C : PrimitiveOracle) (cap : Nat) : Invariant C (empty cap) := by + refine ⟨?_,?_,?_,empty_authentic _ _,?_⟩ + · simp [PublicMerkleLog.AuthenticLog,empty] + · simp [Historical,empty] + · simp [Saturated,empty,PublicMerkleLog.records] + · intro root snap found + simp [empty,lookup] at found + +theorem observeRecords_fields (state : CausalBindingState.State cap) (added : Records) : + (observeRecords state added).registry = state.registry ∧ + (observeRecords state added).frozen = state.frozen ∧ + (observeRecords state added).frozenLog = state.frozenLog ∧ + (observeRecords state added).publicLog = state.publicLog := by + induction added generalizing state with + | nil => exact ⟨rfl,rfl,rfl,rfl⟩ + | cons record rest ih => + have h := ih (CausalBindingState.observe state record.1 record.2) + cases found : recordLookup record.1 state.records <;> + simpa only [observeRecords,List.foldl_cons,CausalBindingState.observe,found] using h + +theorem observeRecords_registry (state : CausalBindingState.State cap) (added : Records) : + (observeRecords state added).registry = state.registry := (observeRecords_fields state added).1 + +theorem observeRecords_frozen (state : CausalBindingState.State cap) (added : Records) : + (observeRecords state added).frozen = state.frozen := (observeRecords_fields state added).2.1 + +theorem observeRecords_frozenLog (state : CausalBindingState.State cap) (added : Records) : + (observeRecords state added).frozenLog = state.frozenLog := (observeRecords_fields state added).2.2.1 + +theorem observeRecords_publicLog (state : CausalBindingState.State cap) (added : Records) : + (observeRecords state added).publicLog = state.publicLog := (observeRecords_fields state added).2.2.2 + +theorem observe_record_origin (state : CausalBindingState.State cap) (bytes : List Byte) (digest : Digest32) + (e : List Byte × Digest32) (member : e ∈ (CausalBindingState.observe state bytes digest).records) : + e ∈ state.records ∨ e = (bytes,digest) := by + unfold CausalBindingState.observe at member + cases found : recordLookup bytes state.records with + | some first => exact Or.inl (by simpa only [found] using member) + | none => + simp only [found,List.mem_cons] at member + exact member.symm + +theorem observeRecords_origin (state : CausalBindingState.State cap) (added : Records) + (e : List Byte × Digest32) (member : e ∈ (observeRecords state added).records) : + e ∈ state.records ∨ e ∈ added := by + induction added generalizing state with + | nil => exact Or.inl member + | cons record rest ih => + change e ∈ (observeRecords (CausalBindingState.observe state record.1 record.2) rest).records at member + rcases ih _ member with old | new + · rcases observe_record_origin state record.1 record.2 e old with old | same + · exact Or.inl old + · exact Or.inr (List.mem_cons.mpr (Or.inl (by simpa using same))) + · exact Or.inr (List.mem_cons_of_mem _ new) + +theorem observe_has (state : CausalBindingState.State cap) (bytes : List Byte) (digest : Digest32) : + ∃ first, recordLookup bytes (CausalBindingState.observe state bytes digest).records = some first := by + unfold CausalBindingState.observe + cases found : recordLookup bytes state.records with + | some first => exact ⟨first,found⟩ + | none => exact ⟨digest,by simp [recordLookup]⟩ + +theorem observeRecords_contains (state : CausalBindingState.State cap) (added : Records) + (bytes : List Byte) (digest : Digest32) (member : (bytes,digest) ∈ added) : + ∃ first, (bytes,first) ∈ (observeRecords state added).records := by + induction added generalizing state with + | nil => simp at member + | cons record rest ih => + rcases List.mem_cons.mp member with same | tail + · cases same + obtain ⟨first,hfirst⟩ := observe_has state bytes digest + exact ⟨first,recordLookup_mem _ bytes first ((observeRecords_extends _ rest).records bytes first hfirst)⟩ + · exact ih (CausalBindingState.observe state record.1 record.2) tail + +theorem observePublic_invariant (C : PrimitiveOracle) (state : CausalBindingState.State cap) + (node : DuplexFraming.Node) (old : Invariant C state) : + Invariant C (observePublic state node (C node)) := by + let log := PublicMerkleLog.insert state.publicLog node (C node) + have hp : state.publicLog.IsPrefix log := insert_prefix _ _ _ + have auth : PublicMerkleLog.AuthenticLog C log := PublicMerkleLog.insert_authentic C _ old.logAuthentic node + refine ⟨?_,?_,?_,observePublic_authentic C state node old.authentic old.logAuthentic,?_⟩ + · simpa only [observePublic,PublicMerkleLog.observe,observeRecords_publicLog] using auth + · change Historical (observeRecords _ _).publicLog (observeRecords _ _).records + rw [observeRecords_publicLog] + intro e member + rcases observeRecords_origin _ _ e member with prior | fresh + · exact old.historical.weaken hp e prior + · exact ⟨log,⟨[],by simp [log,PublicMerkleLog.observe]⟩,fresh⟩ + · change Saturated (observeRecords _ _).publicLog (observeRecords _ _).records + rw [observeRecords_publicLog] + exact observeRecords_contains _ _ + · intro root snap found + have prior : lookup root state.registry = some snap := by + simpa only [observePublic,PublicMerkleLog.observe,observeRecords_registry] using found + obtain ⟨retained,frozen,hf,hl,ha,hh,hs,ht,hprefix⟩ := old.snapshots root snap prior + refine ⟨retained,frozen,?_,?_,ha,hh,hs,ht,?_⟩ + · simpa only [observePublic,PublicMerkleLog.observe,observeRecords_frozen] using hf + · simpa only [observePublic,PublicMerkleLog.observe,observeRecords_frozenLog] using hl + · simpa only [observePublic,PublicMerkleLog.observe,observeRecords_publicLog] using hprefix.trans hp + +theorem registerRoot_invariant (C : PrimitiveOracle) (state : CausalBindingState.State cap) + (root : Digest32) (old : Invariant C state) : Invariant C (registerRoot state root) := by + unfold registerRoot + cases found : lookup root state.registry with + | some snap => exact old + | none => + refine ⟨old.logAuthentic,old.historical,old.saturated,?_,?_⟩ + · simpa only [registerRoot,found] using registerRoot_authentic (PublicMerkleLog.hash C) state root old.authentic + · intro r snap known + by_cases same : r = root + · subst r + have hs : snap = snapshot state.records := by + simpa [register,found,lookup] using known.symm + subst snap + exact ⟨state.records,state.publicLog,by simp,by simp,old.logAuthentic, + old.historical,old.saturated,rfl,⟨[],by simp⟩⟩ + · have prior : lookup r state.registry = some snap := by + simpa [register,found,lookup,same] using known + obtain ⟨retained,log,hf,hl,ha,hh,hs,ht,hprefix⟩ := old.snapshots r snap prior + exact ⟨retained,log,by simpa [Function.update_of_ne same] using hf, + by simpa [Function.update_of_ne same] using hl,ha,hh,hs,ht,hprefix⟩ + +theorem Invariant.covered {C : PrimitiveOracle} {state : CausalBindingState.State cap} + (sound : Invariant C state) : Covered state := by + intro root snap known + obtain ⟨retained,log,hf,hl,ha,hh,hs,ht,hprefix⟩ := sound.snapshots root snap known + simp only [hf,Option.getD_some,ht] + exact Finset.Subset.refl _ + +def RealEvent (C : PrimitiveOracle) (iv : Digest32) : Event cap → Prop + | .answer query value => value = realAnswer C iv query + | .commit _ => True + | .claims _ _ _ => True + +theorem step_invariant (C : PrimitiveOracle) (iv : Digest32) + (state next : CausalBindingState.State cap) (event : Event cap) + (old : Invariant C state) (real : RealEvent C iv event) (stepped : step state event = .ok next) : + Invariant C next := by + cases event with + | answer query value => + cases query with + | primitive purpose node => + change value = C node at real + subst value + cases stepped + exact observePublic_invariant C state node old + | construction coordinate valid => cases stepped; exact old + | commit root => cases stepped; exact registerRoot_invariant C state root old + | claims profile entry request => + unfold step at stepped + cases known : lookup request.root state.registry <;> simp only [known] at stepped + · cases stepped + · cases stepped; exact old + +theorem error_invariant (C : PrimitiveOracle) (state : CausalBindingState.State cap) + (error : Option Digest32) (old : Invariant C state) : Invariant C {state with sourceError := error} := + ⟨old.logAuthentic,old.historical,old.saturated,old.authentic,old.snapshots⟩ + +theorem replayTracked_invariant (C : PrimitiveOracle) (iv : Digest32) + (state : CausalBindingState.State cap) (events : List (Event cap)) (old : Invariant C state) + (real : ∀ e ∈ events, RealEvent C iv e) : Invariant C (replayTracked state events) := by + induction events generalizing state with + | nil => exact old + | cons event rest ih => + unfold replayTracked + cases progress : step state event with + | error root => + exact ih _ (error_invariant C state (state.sourceError.or (some root)) old) + (fun e he => real e (List.mem_cons_of_mem _ he)) + | ok next => + exact ih next (step_invariant C iv state next event old (real event (by simp)) progress) + (fun e he => real e (List.mem_cons_of_mem _ he)) + +theorem replayTracked_empty_invariant (C : PrimitiveOracle) (iv : Digest32) + (events : List (Event cap)) (real : ∀ e ∈ events, RealEvent C iv e) : + Invariant C (replayTracked (empty cap) events) := + replayTracked_invariant C iv _ events (empty_invariant C cap) real + +theorem answer_mem_observations (events : List (Event cap)) (q : Query) (d : Digest32) + (member : Event.answer q d ∈ events) : (⟨q,d⟩ : Observation) ∈ WHIRSourceChronology.observations events := by + induction events with + | nil => simp at member + | cons event rest ih => + rcases List.mem_cons.mp member with same | tail + · cases same; exact List.mem_cons_self + · cases event <;> simp only [WHIRSourceChronology.observations] + · exact List.mem_cons_of_mem _ (ih tail) + · exact ih tail + · exact ih tail + +theorem real_source_events (C : PrimitiveOracle) (iv : Digest32) (source : Source cap R) : + ∀ e ∈ (runReal C iv (compile source)).view.result.events, RealEvent C iv e := by + intro e member + cases e with + | commit => trivial + | claims => trivial + | answer q d => + have observed := answer_mem_observations _ q d member + rw [real_source_trace] at observed + exact PublicMerkleProgram.runReal_answers C iv (compile source) ⟨q,d⟩ observed + +theorem real_source_invariant (C : PrimitiveOracle) (iv : Digest32) (source : Source cap R) : + Invariant C (replayTracked (empty cap) (runReal C iv (compile source)).view.result.events) := + replayTracked_empty_invariant C iv _ (real_source_events C iv source) + +/-- The exact retained-table hypotheses consumed by `openQuery_retained`, +including provenance and saturation derived from source transitions. -/ +theorem Invariant.retained {C : PrimitiveOracle} {state : CausalBindingState.State cap} + (sound : Invariant C state) (root : Digest32) (snap : Snapshot) + (known : lookup root state.registry = some snap) : + ∃ retained log, state.frozen root = some retained ∧ state.frozenLog root = some log ∧ + PublicMerkleLog.AuthenticLog C log ∧ + (∀ e ∈ retained, ∃ earlier : PublicMerkleLog.PublicLog, + (∀ q ∈ earlier, q ∈ log) ∧ e ∈ PublicMerkleLog.records earlier) ∧ + Saturated log retained ∧ snap.table = recordDomain retained := by + obtain ⟨retained,log,hf,hl,ha,hh,hs,ht,hprefix⟩ := sound.snapshots root snap known + refine ⟨retained,log,hf,hl,ha,?_,hs,ht⟩ + intro e member + obtain ⟨earlier,he,hm⟩ := hh e member + exact ⟨earlier,fun _ hq => prefix_mem he hq,hm⟩ + +theorem first_capture_immutable (state : CausalBindingState.State cap) (root : Digest32) (snap : Snapshot) + (known : lookup root state.registry = some snap) (events : List (Event cap)) : + lookup root (replayTracked state events).registry = some snap ∧ + (replayTracked state events).frozen root = state.frozen root ∧ + (replayTracked state events).frozenLog root = state.frozenLog root := by + have growth := replayTracked_extends state events + exact ⟨growth.registry root snap known,(growth.frozen root snap known).symm, + (growth.frozenLog root snap known).symm⟩ + +theorem first_capture (state : CausalBindingState.State cap) (root : Digest32) + (unknown : lookup root state.registry = none) : + lookup root (registerRoot state root).registry = some (snapshot state.records) ∧ + (registerRoot state root).frozen root = some state.records ∧ + (registerRoot state root).frozenLog root = some state.publicLog := by + simp [registerRoot,unknown,register,lookup] + +theorem missing_claim_sticky (state : CausalBindingState.State cap) (profile : ParameterBounds.Profile) + (entry : FramedHistory) (request : ClaimRequest cap profile) (rest : List (Event cap)) + (ready : state.sourceError = none) (unknown : lookup request.root state.registry = none) : + (replayTracked state (.claims profile entry request :: rest)).sourceError = some request.root := by + simp only [replayTracked,step,unknown] + apply replayTracked_error_sticky + simp [ready] + +theorem insert_mem_iff (C : PrimitiveOracle) (log : PublicMerkleLog.PublicLog) + (auth : PublicMerkleLog.AuthenticLog C log) (node : DuplexFraming.Node) + (e : DuplexFraming.Node × Digest32) : + e ∈ PublicMerkleLog.insert log node (C node) ↔ e ∈ log ∨ e = (node,C node) := by + cases found : PublicMerkleLog.lookup log node with + | none => simp [PublicMerkleLog.insert,found] + | some d => + have present := PublicMerkleLog.lookup_mem found + have same := auth node d present + have current : (node,C node) ∈ log := by simpa only [same] using present + simp only [PublicMerkleLog.insert,found,Option.isSome_some,ite_true] + constructor + · exact Or.inl + · rintro (old | rfl) + · exact old + · exact current + +theorem registerRoot_publicLog (state : CausalBindingState.State cap) (root : Digest32) : + (registerRoot state root).publicLog = state.publicLog := by + unfold registerRoot + split <;> rfl + +theorem step_publicLog (state next : CausalBindingState.State cap) (event : Event cap) + (progress : step state event = .ok next) : + next.publicLog = match event with + | .answer (.primitive _ node) value => PublicMerkleLog.insert state.publicLog node value + | _ => state.publicLog := by + cases event with + | answer query value => + cases query with + | primitive purpose node => + cases progress + simp only [observePublic,PublicMerkleLog.observe,observeRecords_publicLog] + | construction coordinate valid => cases progress; rfl + | commit root => cases progress; exact registerRoot_publicLog state root + | claims profile entry request => + unfold step at progress + cases known : lookup request.root state.registry <;> simp only [known] at progress + · cases progress + · cases progress; rfl + +theorem step_publicLog_prefix (state next : CausalBindingState.State cap) (event : Event cap) + (progress : step state event = .ok next) : state.publicLog.IsPrefix next.publicLog := by + rw [step_publicLog state next event progress] + cases event with + | answer query value => + cases query with + | primitive purpose node => exact insert_prefix _ _ _ + | construction coordinate valid => exact ⟨[],by simp⟩ + | commit => exact ⟨[],by simp⟩ + | claims => exact ⟨[],by simp⟩ + +theorem replayTracked_publicLog_prefix (state : CausalBindingState.State cap) (events : List (Event cap)) : + state.publicLog.IsPrefix (replayTracked state events).publicLog := by + induction events generalizing state with + | nil => exact ⟨[],by simp [replayTracked]⟩ + | cons event rest ih => + unfold replayTracked + cases progress : step state event with + | error root => exact ih {state with sourceError := state.sourceError.or (some root)} + | ok next => exact (step_publicLog_prefix state next event progress).trans (ih next) + +theorem step_publicLog_authentic (C : PrimitiveOracle) (iv : Digest32) + (state next : CausalBindingState.State cap) (event : Event cap) + (auth : PublicMerkleLog.AuthenticLog C state.publicLog) (real : RealEvent C iv event) + (progress : step state event = .ok next) : PublicMerkleLog.AuthenticLog C next.publicLog := by + rw [step_publicLog state next event progress] + cases event with + | answer query value => + cases query with + | primitive purpose node => + change value = C node at real + subst value + exact PublicMerkleLog.insert_authentic C _ auth node + | construction => exact auth + | commit => exact auth + | claims => exact auth + +theorem step_publicLog_mem_iff (C : PrimitiveOracle) (iv : Digest32) + (state next : CausalBindingState.State cap) (event : Event cap) + (auth : PublicMerkleLog.AuthenticLog C state.publicLog) (real : RealEvent C iv event) + (progress : step state event = .ok next) (node : DuplexFraming.Node) (digest : Digest32) : + (node,digest) ∈ next.publicLog ↔ (node,digest) ∈ state.publicLog ∨ + ∃ purpose, event = .answer (.primitive purpose node) digest := by + rw [step_publicLog state next event progress] + cases event with + | answer query value => + cases query with + | primitive purpose input => + change value = C input at real + subst value + rw [insert_mem_iff C _ auth input] + constructor + · rintro (old | same) + · exact Or.inl old + · obtain ⟨rfl,rfl⟩ := Prod.mk.inj same + exact Or.inr ⟨purpose,rfl⟩ + · rintro (old | ⟨p,same⟩) + · exact Or.inl old + · cases same + exact Or.inr rfl + | construction coordinate valid => simp + | commit => simp + | claims => simp + +theorem step_error_not_primitive (state : CausalBindingState.State cap) (event : Event cap) + (root : Digest32) (progress : step state event = .error root) + (purpose : Purpose) (node : DuplexFraming.Node) (digest : Digest32) : + event ≠ .answer (.primitive purpose node) digest := by + intro same + cases same + cases progress + +/-- Exact membership, including after chronology errors. First-answer +deduplication is harmless here because state and event answers are authentic. +No saturation or all-C-prefix coverage hypothesis is supplied. -/ +theorem replayTracked_publicLog_mem_iff (C : PrimitiveOracle) (iv : Digest32) + (state : CausalBindingState.State cap) (events : List (Event cap)) + (auth : PublicMerkleLog.AuthenticLog C state.publicLog) + (real : ∀ e ∈ events, RealEvent C iv e) (node : DuplexFraming.Node) (digest : Digest32) : + (node,digest) ∈ (replayTracked state events).publicLog ↔ + (node,digest) ∈ state.publicLog ∨ ∃ purpose, Event.answer (.primitive purpose node) digest ∈ events := by + induction events generalizing state with + | nil => simp [replayTracked] + | cons event rest ih => + have tailReal : ∀ e ∈ rest, RealEvent C iv e := fun e he => real e (List.mem_cons_of_mem _ he) + unfold replayTracked + cases progress : step state event with + | error root => + rw [ih {state with sourceError := state.sourceError.or (some root)} auth tailReal] + constructor + · rintro (old | ⟨purpose,member⟩) + · exact Or.inl old + · exact Or.inr ⟨purpose,List.mem_cons_of_mem _ member⟩ + · rintro (old | ⟨purpose,member⟩) + · exact Or.inl old + · rcases List.mem_cons.mp member with same | tail + · exact False.elim (step_error_not_primitive state event root progress purpose node digest same.symm) + · exact Or.inr ⟨purpose,tail⟩ + | ok next => + rw [ih next (step_publicLog_authentic C iv state next event auth (real event (by simp)) progress) tailReal, + step_publicLog_mem_iff C iv state next event auth (real event (by simp)) progress node digest] + simp only [List.mem_cons,exists_or,or_assoc,eq_comm] + +theorem observePublic_settled_fields (state : CausalBindingState.State cap) + (node : DuplexFraming.Node) (digest : Digest32) (known : (node,digest) ∈ state.publicLog) : + (observePublic state node digest).registry = state.registry ∧ + (observePublic state node digest).frozen = state.frozen ∧ + (observePublic state node digest).frozenLog = state.frozenLog ∧ + (observePublic state node digest).publicLog = state.publicLog := by + obtain ⟨first,found⟩ := PublicMerkleLog.lookup_exists known + have unchanged : PublicMerkleLog.insert state.publicLog node digest = state.publicLog := by + simp [PublicMerkleLog.insert,found] + simpa only [observePublic,PublicMerkleLog.observe,unchanged] using + observeRecords_fields state (PublicMerkleLog.records state.publicLog) + +/-- Replaying an already settled prefix cannot move a root's first capture. +No authenticity premise is needed for these four fields. The error flag may +change, and this theorem deliberately makes no equality claim about records. -/ +theorem replayTracked_settled_fields (state : CausalBindingState.State cap) (events : List (Event cap)) + (answers : ∀ purpose node digest, Event.answer (.primitive purpose node) digest ∈ events → + (node,digest) ∈ state.publicLog) + (commits : ∀ root, Event.commit root ∈ events → ∃ snap, lookup root state.registry = some snap) : + (replayTracked state events).registry = state.registry ∧ + (replayTracked state events).frozen = state.frozen ∧ + (replayTracked state events).frozenLog = state.frozenLog ∧ + (replayTracked state events).publicLog = state.publicLog := by + induction events generalizing state with + | nil => exact ⟨rfl,rfl,rfl,rfl⟩ + | cons event rest ih => + have resume (next : CausalBindingState.State cap) + (fields : next.registry = state.registry ∧ next.frozen = state.frozen ∧ + next.frozenLog = state.frozenLog ∧ next.publicLog = state.publicLog) : + (replayTracked next rest).registry = state.registry ∧ + (replayTracked next rest).frozen = state.frozen ∧ + (replayTracked next rest).frozenLog = state.frozenLog ∧ + (replayTracked next rest).publicLog = state.publicLog := by + have ha : ∀ purpose node digest, Event.answer (.primitive purpose node) digest ∈ rest → + (node,digest) ∈ next.publicLog := by + intro purpose node digest member + rw [fields.2.2.2] + exact answers purpose node digest (List.mem_cons_of_mem _ member) + have hc : ∀ root, Event.commit root ∈ rest → ∃ snap, lookup root next.registry = some snap := by + intro root member + rw [fields.1] + exact commits root (List.mem_cons_of_mem _ member) + have done := ih next ha hc + exact ⟨done.1.trans fields.1,done.2.1.trans fields.2.1, + done.2.2.1.trans fields.2.2.1,done.2.2.2.trans fields.2.2.2⟩ + unfold replayTracked + cases event with + | answer query digest => + cases query with + | primitive purpose node => + exact resume _ (observePublic_settled_fields state node digest (answers purpose node digest (by simp))) + | construction coordinate valid => exact resume state ⟨rfl,rfl,rfl,rfl⟩ + | commit root => + obtain ⟨snap,known⟩ := commits root (by simp) + simpa only [step,registerRoot,known] using resume state ⟨rfl,rfl,rfl,rfl⟩ + | claims profile entry request => + simp only [step] + cases known : lookup request.root state.registry with + | none => exact resume {state with sourceError := state.sourceError.or (some request.root)} ⟨rfl,rfl,rfl,rfl⟩ + | some snap => exact resume state ⟨rfl,rfl,rfl,rfl⟩ + +end Whir.WHIRPhysicalSnapshots diff --git a/verification/whir/Whir/WHIRPhysicalSoundness.lean b/verification/whir/Whir/WHIRPhysicalSoundness.lean new file mode 100644 index 000000000..a20308c34 --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalSoundness.lean @@ -0,0 +1,884 @@ +import Whir.WHIRPhysicalCaller +import Whir.WHIRPhysicalOpeningRuns +import Whir.PublicMerkleProbability +import Whir.WHIRPhysicalRoots +import Whir.WHIRPhysicalSnapshots + +namespace Whir.WHIRPhysicalSoundness +open Concrete Protocol FiatShamirGame DuplexModeGame +open MerkleTransport MerkleTransport.Commitments +open WHIRPhysicalVerifier WHIRPhysicalReplay WHIRPhysicalOpeningRuns +open PublicMerkleProgram (Runs) +set_option maxHeartbeats 800000 + +private theorem bind_done_observations {R S : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (finish : R → S) : + (runReal C iv (WHIRModeFinal.bind program (fun value => .done (finish value)))).view.observations = + (runReal C iv program).view.observations := by + induction program with + | done value => rfl + | ask query next ih => + simpa only [WHIRModeFinal.bind,runReal,prepend] using + congrArg (List.cons ⟨query,realAnswer C iv query⟩) (ih (realAnswer C iv query)) + +theorem openRows_observations (C : PrimitiveOracle) (iv : Digest32) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) : + (runReal C iv (openRows proof root numLeaves queries rowWords leafWords base)).view.observations = + (runReal C iv (PrunedMerkleProgram.verify proof root numLeaves queries rowWords leafWords)).view.observations := + bind_done_observations C iv _ _ + +/-- Every compression event in every returned Merkle path was executed by the +actual counted opener. Reconstructing the logical path adds no oracle call. -/ +theorem openRows_plan_coverage (C : PrimitiveOracle) (iv : Digest32) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) (out : Opened) + (accepted : (runReal C iv (openRows proof root numLeaves queries rowWords leafWords base)).view.result = some out) + (path : RawPath) (member : path ∈ out.paths) (bytes : List Byte) + (input : bytes ∈ path.opening.inputs (hashing (PublicMerkleLog.hash C))) + (event : DuplexFraming.Node × Digest32) (present : event ∈ PublicMerkleLog.plan C bytes) : + (⟨.primitive .verification event.1,event.2⟩ : Observation) ∈ + (runReal C iv (openRows proof root numLeaves queries rowWords leafWords base)).view.observations := by + rw [openRows_observations] + apply PrunedMerkleProgram.verify_opening_primitive_coverage C iv proof root numLeaves queries rowWords leafWords + out.paths _ path member bytes input event present + rw [PrunedMerkleProgram.verify_real_result] + exact (openRows_real_accepted C iv proof root numLeaves queries rowWords leafWords base out accepted).1 + +theorem openQuery_evaluated (C : PrimitiveOracle) (iv : Digest32) + (p : ParameterBounds.Profile) (i : Fin (ParameterBounds.config p).folds.size) + (lanes : Nat) (proof : PrunedMerklePaths) (root : Digest32) + (sample : CausalProbability.Sample (.query i)) (out : Opened) + (accepted : (runReal C iv (openQuery p i lanes proof root sample)).view.result = some out) : + ∀ path ∈ out.paths, ∀ bytes ∈ path.opening.inputs (hashing (PublicMerkleLog.hash C)), + bytes.length < 2^56 ∧ ∀ event ∈ PublicMerkleLog.plan C bytes, + (⟨.primitive .verification event.1,event.2⟩ : Observation) ∈ + (runReal C iv (openQuery p i lanes proof root sample)).view.observations := by + have opened := (openRows_real_accepted C iv proof root + (ParameterBounds.length (ParameterBounds.config p) i.val) (queryIndices p i sample) + (if i.val = 0 then lanes else leafWords p i.val) (leafWords p i.val) (i.val == 0) out accepted).1 + have bounded := path_input_bounds_lt C proof root + (ParameterBounds.length (ParameterBounds.config p) i.val) (queryIndices p i sample) + (if i.val = 0 then lanes else leafWords p i.val) (leafWords p i.val) (2^56) + out.paths opened (production_leaf_byte_tag_zero p i) (by decide) + intro path member bytes input + refine ⟨bounded path member bytes input,?_⟩ + intro event present + exact openRows_plan_coverage C iv proof root _ _ _ _ _ out accepted path member bytes input event present + +/-- The stored source opening record carries an actual indexed subrun, not a +caller-provided certificate linking ideal rows to a claimed transcript. -/ +theorem observed_evaluated {p : ParameterBounds.Profile} {lanes : Nat} + {proofs : Array PrunedMerklePaths} {observations : List Observation} {opening : QueryOpening p} + (observed : ObservedOpening lanes proofs observations opening) (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) : + ∀ path ∈ opening.result.paths, ∀ bytes ∈ path.opening.inputs (hashing (PublicMerkleLog.hash C)), + bytes.length < 2^56 ∧ ∀ event ∈ PublicMerkleLog.plan C bytes, + (⟨.primitive .verification event.1,event.2⟩ : Observation) ∈ observations := by + obtain ⟨proof,_,accepted,covered⟩ := observed.real C iv answers + intro path member bytes input + obtain ⟨bound,executed⟩ := openQuery_evaluated C iv p opening.level lanes proof opening.root + opening.sample opening.result accepted path member bytes input + exact ⟨bound,fun event present => covered _ (executed event present)⟩ + +theorem observed_binding {p : ParameterBounds.Profile} {lanes : Nat} + {proofs : Array PrunedMerklePaths} {observations : List Observation} {opening : QueryOpening p} + (observed : ObservedOpening lanes proofs observations opening) (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (oldLog : PublicMerkleLog.PublicLog) (authentic : PublicMerkleLog.AuthenticLog C oldLog) + (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicMerkleLog.PublicLog, + (∀ q ∈ earlier, q ∈ oldLog) ∧ e ∈ PublicMerkleLog.records earlier) + (saturated : ∀ bytes d, (bytes,d) ∈ PublicMerkleLog.records oldLog → ∃ first, (bytes,first) ∈ retained) + (snapshot : Snapshot) (table : snapshot.table = recordDomain retained) : + opening.result.rows = atQueries + (frozenQueryOracle (PublicMerkleLog.hash C) snapshot opening.root p opening.level.val lanes) + (queryIndices p opening.level opening.sample) ∨ + PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths := by + obtain ⟨proof,_,accepted,_⟩ := observed.real C iv answers + exact openQuery_retained C iv oldLog authentic retained history saturated snapshot table + p opening.level lanes proof opening.root opening.sample opening.result accepted + +/-- The resulting primitive witness is the existing causal compression-game +terminal event, with its path coverage and tag-zero limits already proved. -/ +theorem observed_frozen_bad {p : ParameterBounds.Profile} {lanes : Nat} + {proofs : Array PrunedMerklePaths} {observations : List Observation} {opening : QueryOpening p} + (observed : ObservedOpening lanes proofs observations opening) (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (roots : PublicMerkleProbability.RootPolicy) (trace before after oldLog : PublicMerkleLog.PublicLog) + (freeze : trace = before ++ after) (prior : ∀ e ∈ oldLog, e ∈ before) + (ordinary : ∀ n d, (n,d) ∈ before → DuplexFraming.tag n = 0 → (n,d) ∈ oldLog) + (registered : opening.root ∈ roots before.reverse) + (executed : ∀ n d, (⟨.primitive .verification n,d⟩ : Observation) ∈ observations → (n,d) ∈ trace) + (bad : PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + PublicMerkleProbability.FrozenOpeningBad C roots trace := by + have evaluated := observed_evaluated observed C iv answers + exact ⟨before,after,oldLog,opening.root,opening.result.paths,freeze,prior,ordinary,registered, + fun path member bytes input => (evaluated path member bytes input).1, + fun path member bytes input event present => executed _ _ ((evaluated path member bytes input).2 event present),bad⟩ + +private def QueryRowsAt (p : ParameterBounds.Profile) (rows : WHIRPhysicalHistory.Rows) + (replies : Array CausalGame.Reply) : Prop := + ∀ i : Fin (ParameterBounds.config p).folds.size, + CausalProbability.position (.query i) < replies.size → + CausalGame.rowsField replies[CausalProbability.position (.query i)]! = rows i.val + +private theorem coordinate_position_injective {c : Config} : + Function.Injective (@CausalProbability.position c) := by + intro a b equal + apply Option.some.inj + rw [← WHIRHistory.schedule_get_position a,← WHIRHistory.schedule_get_position b,equal] + +private theorem queryRowsAt_push (p : ParameterBounds.Profile) (rows : WHIRPhysicalHistory.Rows) + (roots : WHIRReplay.Roots) (replies : Array CausalGame.Reply) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (pending : WHIRHistory.Pending) + (response : CausalGame.Reply) (prior : QueryRowsAt p rows replies) + (position : CausalProbability.position q = replies.size) + (parsed : WHIRPhysicalHistory.reply roots rows q pending = some response) : + QueryRowsAt p rows (replies.push response) := by + intro i covered + by_cases before : CausalProbability.position (.query i) < replies.size + · rw [getElem!_pos (replies.push response) _ covered,Array.getElem_push_lt before, + ← getElem!_pos replies _ before] + exact prior i before + · have equal : CausalProbability.position (.query i) = replies.size := by + simp only [Array.size_push] at covered + omega + have phase : q = .query i := coordinate_position_injective (position.trans equal.symm) + subst q + rw [WHIRPhysicalHistory.reply_query] at parsed + obtain ⟨message,_,rfl⟩ := Option.map_eq_some_iff.mp parsed + rw [equal,getElem!_pos (replies.push (.query (rows i.val) message)) replies.size (by simp), + Array.getElem_push_eq] + rfl + +/-- Every covered query response position contains the actual physical row +table. The decoder itself supplies both position alignment and reply count. -/ +theorem decodeHistory_queryRows (p : ParameterBounds.Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (statement : Digest32) + (messages : List WHIRHistory.Pending) + (ancestors : List (WHIRHistory.Pending × Sigma (@CausalProbability.Sample (ParameterBounds.config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows statement messages ancestors = some out) : + out.replies.size = messages.length - 1 ∧ QueryRowsAt p rows out.replies ∧ + ∀ i : Fin (ParameterBounds.config p).folds.size, + CausalProbability.position (.query i) < out.replies.size → + ∃ pending sample, (pending,⟨CausalProbability.Coordinate.query i,sample⟩) ∈ ancestors := by + induction messages generalizing ancestors out with + | nil => cases parsed + | cons pending messages ih => + cases messages with + | nil => + cases ancestors with + | cons a rest => cases parsed + | nil => + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · cases found : catalog statement with + | none => simp [found] at parsed + | some originalStatement => + simp [found] at parsed + subst out + refine ⟨rfl,?_,?_⟩ <;> intro i covered <;> simp at covered + · cases parsed + | cons previous older => + cases ancestors with + | nil => cases parsed + | cons entry past => + obtain ⟨previous',q,sample⟩ := entry + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · split at parsed + · split at parsed + · rename_i position + split at parsed + · split at parsed + · cases decoded : WHIRPhysicalHistory.decodeHistory p catalog roots rows statement + (previous::older) past with + | none => simp [decoded] at parsed + | some before => + obtain ⟨size,prior,history⟩ := ih past before decoded + simp only [List.length_cons,Nat.add_sub_cancel] at size + simp only [decoded,WHIRPhysicalHistory.step] at parsed + obtain ⟨response,reply,rfl⟩ := Option.map_eq_some_iff.mp parsed + constructor + · simp only [Array.size_push,List.length_cons] + omega + · constructor + · exact queryRowsAt_push p rows roots before.replies q pending response + prior (position.trans size.symm) reply + · intro i covered + by_cases earlier : CausalProbability.position (.query i) < before.replies.size + · obtain ⟨message,value,member⟩ := history i earlier + exact ⟨message,value,List.mem_cons_of_mem _ member⟩ + · have equal : CausalProbability.position (.query i) = before.replies.size := by + simp only [Array.size_push] at covered + omega + have phase : q = .query i := + coordinate_position_injective (position.trans (size.symm.trans equal.symm)) + cases phase + exact ⟨previous',sample,List.mem_cons_self⟩ + · cases parsed + · cases parsed + · cases parsed + · cases parsed + · cases parsed + +private theorem query_position_lt_replies (c : Config) (tape : CausalGame.Tape c) + (replies : Array CausalGame.Reply) (proof : Opening) + (accepted : CausalGame.opening c (CausalGame.challenges c tape) replies = .ok proof) + (i : Fin c.folds.size) : CausalProbability.position (.query i) < replies.size := by + have checked := (CausalRefinement.opening_ok_iff c _ replies proof).mp accepted |>.1 + have count := CausalRefinement.checkReplies_length _ _ checked + have stream := congrArg List.length (CausalProbability.visibleCoordinates_map c tape) + simp only [List.length_map] at stream + have size : replies.size = (CausalProbability.visibleCoordinates c).length := by + calc + replies.size = (CausalGame.visibleBatches c E.zero (CausalGame.challenges c tape)).length := count + _ = (CausalGame.visibleBatches c tape.1 (CausalGame.challenges c tape)).length := by + simp only [CausalGame.visibleBatches,List.length_append,List.length_singleton] + _ = _ := stream.symm + rw [size] + apply List.idxOf_lt_length_of_mem + simp only [CausalProbability.visibleCoordinates,List.mem_append] + left + right + apply List.mem_flatMap.mpr + exact ⟨i.val,List.mem_range.mpr i.isLt,by simp [CausalProbability.levelCoordinates,i.isLt]⟩ + +theorem decodeHistory_opening_rows (p : ParameterBounds.Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (statement : Digest32) + (messages : List WHIRHistory.Pending) + (ancestors : List (WHIRHistory.Pending × Sigma (@CausalProbability.Sample (ParameterBounds.config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows statement messages ancestors = some out) + (tape : CausalGame.Tape (ParameterBounds.config p)) (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) out.replies = .ok proof) : + ∀ i : Fin (ParameterBounds.config p).folds.size, proof.levels[i.val]!.rows = rows i.val := by + intro i + have position := query_position_lt_replies _ tape out.replies proof accepted i + have field := (decodeHistory_queryRows p catalog roots rows statement messages ancestors out parsed).2.1 i position + rw [CausalRefinement.opening_eq_decoded _ _ _ _ accepted] + change (Array.ofFn (fun j : Fin (ParameterBounds.config p).folds.size => + CausalGame.decodedLevel _ (CausalGame.challenges _ tape) out.replies j.val))[i.val]!.rows = _ + rw [getElem!_pos _ i.val (by simpa only [Array.size_ofFn] using i.isLt),Array.getElem_ofFn] + dsimp only [CausalGame.decodedLevel] + simp only [CausalStateCausality.challenge_folds_size,CausalStateCausality.challenge_oods_size] + rw [← CausalPositions.position_query i tape] + exact field + +theorem decodeStack_opening_rows (p : ParameterBounds.Profile) (cap : Nat) + (catalog : StackWHIRReplay.Catalog p cap) (roots : WHIRReplay.Roots) + (rows : WHIRPhysicalHistory.Rows) (key : StackWHIRReplay.Key p) + (out : StackWHIRReplay.Replay p cap) + (parsed : WHIRPhysicalHistory.decodeStack p cap catalog roots rows key = some out) + (tape : CausalGame.Tape (ParameterBounds.config p)) (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) out.whir.replies = .ok proof) : + ∀ i : Fin (ParameterBounds.config p).folds.size, proof.levels[i.val]!.rows = rows i.val := by + unfold WHIRPhysicalHistory.decodeStack at parsed + obtain ⟨original,_,parsed⟩ := Option.bind_eq_some_iff.mp parsed + obtain ⟨seed,_,parsed⟩ := Option.bind_eq_some_iff.mp parsed + obtain ⟨whir,decoded,parsed⟩ := Option.bind_eq_some_iff.mp parsed + cases Option.some.inj parsed + exact decodeHistory_opening_rows p _ roots rows key.statement key.messages _ + whir decoded tape proof accepted + +theorem decodeHistory_opening_nextOracle (p : ParameterBounds.Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (statement : Digest32) + (messages : List WHIRHistory.Pending) + (ancestors : List (WHIRHistory.Pending × Sigma (@CausalProbability.Sample (ParameterBounds.config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows statement messages ancestors = some out) + (tape : CausalGame.Tape (ParameterBounds.config p)) (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) out.replies = .ok proof) + (i : Fin (ParameterBounds.config p).folds.size) (hasNext : i.val+1 < (ParameterBounds.config p).folds.size) : + ∃ digest, (WHIRQueryOracleRecurrence.rootLog p statement messages)[i.val]? = some digest ∧ + proof.levels[i.val]!.nextOracle = some (roots digest (i.val+1)) := by + have positive := WHIRQueryOracleRecurrence.production_folds_positive p i + let j : Fin (ParameterBounds.config p).folds[i.val]! := + ⟨(ParameterBounds.config p).folds[i.val]! - 1,by omega⟩ + have last : j.val+1 = (ParameterBounds.config p).folds[i.val]! := by dsimp [j]; omega + have count := (decodeHistory_queryRows p catalog roots rows statement messages ancestors out parsed).1 + have covered := query_position_lt_replies _ tape out.replies proof accepted i + have available : CausalProbability.position (.fold i j) < messages.length-1 := by + rw [← count] + apply Nat.lt_trans _ covered + rw [CausalPositions.position_fold i j tape,CausalPositions.position_query i tape] + have bound := j.isLt + omega + obtain ⟨digest,logged,slot⟩ := WHIRQueryOracleRecurrence.decoded_rootLog_slot + p catalog roots rows statement messages ancestors out parsed i j last hasNext + (fun k hk => WHIRQueryOracleRecurrence.production_folds_positive p ⟨k,by omega⟩) available + refine ⟨digest,logged,?_⟩ + rw [CausalRefinement.opening_eq_decoded _ _ _ _ accepted] + change (Array.ofFn (fun k : Fin (ParameterBounds.config p).folds.size => + CausalGame.decodedLevel _ (CausalGame.challenges _ tape) out.replies k.val))[i.val]!.nextOracle = _ + rw [getElem!_pos _ i.val (by simpa only [Array.size_ofFn] using i.isLt),Array.getElem_ofFn] + dsimp only [CausalGame.decodedLevel] + simp only [CausalStateCausality.challenge_folds_size] + rw [ite_eq_left ⟨hasNext,positive⟩] + have index : CausalProbability.position (.fold i j) = + CausalGame.levelStart (CausalGame.challenges (ParameterBounds.config p) tape) i.val + + (ParameterBounds.config p).folds[i.val]! - 1 := by + rw [CausalPositions.position_fold i j tape] + omega + rw [← index] + exact slot + +theorem decodeStack_opening_nextOracle (p : ParameterBounds.Profile) (cap : Nat) + (catalog : StackWHIRReplay.Catalog p cap) (roots : WHIRReplay.Roots) + (rows : WHIRPhysicalHistory.Rows) (key : StackWHIRReplay.Key p) + (out : StackWHIRReplay.Replay p cap) + (parsed : WHIRPhysicalHistory.decodeStack p cap catalog roots rows key = some out) + (tape : CausalGame.Tape (ParameterBounds.config p)) (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) out.whir.replies = .ok proof) + (i : Fin (ParameterBounds.config p).folds.size) (hasNext : i.val+1 < (ParameterBounds.config p).folds.size) : + ∃ digest, (WHIRQueryOracleRecurrence.rootLog p key.statement key.messages)[i.val]? = some digest ∧ + proof.levels[i.val]!.nextOracle = some (roots digest (i.val+1)) := by + unfold WHIRPhysicalHistory.decodeStack at parsed + obtain ⟨original,_,parsed⟩ := Option.bind_eq_some_iff.mp parsed + obtain ⟨seed,_,parsed⟩ := Option.bind_eq_some_iff.mp parsed + obtain ⟨whir,decoded,parsed⟩ := Option.bind_eq_some_iff.mp parsed + cases Option.some.inj parsed + exact decodeHistory_opening_nextOracle p _ roots rows key.statement key.messages _ + whir decoded tape proof accepted i hasNext + +theorem decodeStack_query_mem (p : ParameterBounds.Profile) (cap : Nat) + (catalog : StackWHIRReplay.Catalog p cap) (roots : WHIRReplay.Roots) + (rows : WHIRPhysicalHistory.Rows) (key : StackWHIRReplay.Key p) + (out : StackWHIRReplay.Replay p cap) + (parsed : WHIRPhysicalHistory.decodeStack p cap catalog roots rows key = some out) + (tape : CausalGame.Tape (ParameterBounds.config p)) (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) out.whir.replies = .ok proof) + (i : Fin (ParameterBounds.config p).folds.size) : + ∃ pending sample, (pending,⟨CausalProbability.Coordinate.query i,sample⟩) ∈ key.ancestors := by + unfold WHIRPhysicalHistory.decodeStack at parsed + obtain ⟨original,_,parsed⟩ := Option.bind_eq_some_iff.mp parsed + obtain ⟨seed,_,parsed⟩ := Option.bind_eq_some_iff.mp parsed + obtain ⟨whir,decoded,parsed⟩ := Option.bind_eq_some_iff.mp parsed + cases Option.some.inj parsed + obtain ⟨pending,sample,member⟩ := (decodeHistory_queryRows p _ roots rows key.statement key.messages _ + whir decoded).2.2 i (query_position_lt_replies _ tape whir.replies proof accepted i) + exact ⟨pending,sample,WHIRPhysicalRoots.projectEntry_query_mem key.ancestors pending i sample member⟩ + +theorem decodeStack_rootShapes (p : ParameterBounds.Profile) (cap : Nat) + (state : CausalBindingState.State cap) (catalog : StackWHIRReplay.Catalog p cap) + (rows : WHIRPhysicalHistory.Rows) (key : StackWHIRReplay.Key p) + (out : StackWHIRReplay.Replay p cap) + (parsed : WHIRPhysicalHistory.decodeStack p cap catalog (CausalBindingState.roots state p) rows key = some out) + (tape : CausalGame.Tape (ParameterBounds.config p)) (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) out.whir.replies = .ok proof) : + WHIRNativeArithmetic.RootShapes (ParameterBounds.config p) proof := by + intro i bound hasNext next found + obtain ⟨digest,_,value⟩ := decodeStack_opening_nextOracle p cap catalog + (CausalBindingState.roots state p) rows key out parsed tape proof accepted ⟨i,bound⟩ hasNext + have equal := Option.some.inj (found.symm.trans value) + subst next + have shape : oracleValid (CausalBindingState.roots state p digest (i+1)) + (ParameterBounds.length (ParameterBounds.config p) (i+1)) + (2^(ParameterBounds.config p).folds[i+1]!) = true := by + unfold CausalBindingState.roots + exact intermediateOracle_valid _ _ _ _ _ _ + have dimensions := ((CausalBoundary.production_boundary_facts p ⟨i,bound⟩).2.2 hasNext).1 + change CausalGame.remaining (ParameterBounds.config p) (i+1) + + (ParameterBounds.config p).folds[i+1]! = CausalGame.remaining (ParameterBounds.config p) i at dimensions + have remaining : CausalGame.remaining (ParameterBounds.config p) (i+1) = + CausalGame.remaining (ParameterBounds.config p) i - (ParameterBounds.config p).folds[i+1]! := by + omega + simpa only [ParameterBounds.length,remaining] using shape + +theorem trace_opening_oracleBefore {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (packet : RawWHIRKeys.Packet ctx Q) {packets : List (RawWHIRKeys.Packet ctx Q)} + {lanes : Nat} {proofs : Array PrunedMerklePaths} {wire : WireState packet.val.profile} {history} + (root : Digest32) (base : CausalGame.BaseOracle) (roots : WHIRReplay.Roots) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q packet.val.profile lanes proofs packets + (initialWireState packet.val.profile root) wire history) + (catalog : StackWHIRReplay.Catalog packet.val.profile cap) + (past : List (WHIRRawReplay.LocalEntry packet.val.profile)) + (out : StackWHIRReplay.Replay packet.val.profile cap) + (parsed : WHIRPhysicalHistory.decodeStack packet.val.profile cap catalog roots (fun i => wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,past⟩ = some out) + (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) wire.tape) out.whir.replies = .ok proof) + (i : Fin (ParameterBounds.config packet.val.profile).folds.size) : + WHIRNativeArithmetic.oracleBefore proof (CausalGame.liftRoot base) i.val = + if i.val = 0 then CausalGame.liftRoot base else roots wire.roots[i.val]! i.val := by + by_cases first : i.val = 0 + · simp only [WHIRNativeArithmetic.oracleBefore,first,ite_true] + · let previous : Fin (ParameterBounds.config packet.val.profile).folds.size := ⟨i.val-1,by omega⟩ + have succ : previous.val+1 = i.val := by dsimp [previous]; omega + obtain ⟨digest,logged,next⟩ := decodeStack_opening_nextOracle packet.val.profile cap catalog roots + (fun i => wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ out parsed + wire.tape proof accepted previous (by omega) + have recorded := WHIRPhysicalRoots.trace_digest_from_prefix root chain trace 0 previous.val digest + (by simpa using logged) + rw [succ] at recorded next + obtain ⟨rootBound,rootValue⟩ := Array.getElem?_eq_some_iff.mp recorded + simp only [WHIRNativeArithmetic.oracleBefore,ite_eq_right first] + rw [show i.val-1 = previous.val from rfl,next,Option.getD_some, + getElem!_pos wire.roots i.val rootBound,rootValue] + +private theorem atQueries_get (oracle : Oracle) (queries : Array Nat) (i : Nat) (bound : i < queries.size) : + (atQueries oracle queries.toList)[i]! = oracle[queries[i]!]! := by + have mapped : atQueries oracle queries.toList = queries.map (fun j => oracle[j]!) := by + simp [atQueries,← Array.toList_map] + rw [mapped,getElem!_pos _ i (by simpa only [Array.size_map] using bound), + Array.getElem_map,getElem!_pos queries i bound] + +/-- Native authentication is supplied by the actual retained openings and +their actual tape coordinates. No authentication certificate is assumed. -/ +theorem trace_authenticatedRows {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (packet : RawWHIRKeys.Packet ctx Q) {packets : List (RawWHIRKeys.Packet ctx Q)} + {lanes : Nat} {proofs : Array PrunedMerklePaths} {wire : WireState packet.val.profile} {history} + (root : Digest32) (base : CausalGame.BaseOracle) (roots : WHIRReplay.Roots) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q packet.val.profile lanes proofs packets + (initialWireState packet.val.profile root) wire history) + (bound : WHIRPhysicalRoots.BoundRows base roots wire) + (catalog : StackWHIRReplay.Catalog packet.val.profile cap) + (out : StackWHIRReplay.Replay packet.val.profile cap) + (parsed : WHIRPhysicalHistory.decodeStack packet.val.profile cap catalog roots (fun i => wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile history).tail⟩ = some out) + (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) wire.tape) out.whir.replies = .ok proof) : + WHIRNativeArithmetic.AuthenticatedRows (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) wire.tape) proof (CausalGame.liftRoot base) := by + intro i index qs queried j jBound + let level : Fin (ParameterBounds.config packet.val.profile).folds.size := ⟨i,index⟩ + obtain ⟨pending,sample,member⟩ := decodeStack_query_mem packet.val.profile cap catalog roots + (fun i => wire.rows[i]!) _ out parsed wire.tape proof accepted level + have present := List.mem_of_mem_tail member + have sampleAt := WHIRPhysicalRoots.trace_query_sample root chain trace pending level sample present + have actualRows := WHIRPhysicalRoots.trace_query_rows root base roots trace bound pending level sample present + have actualSample := (CausalStateCausality.challenge_query (ParameterBounds.config packet.val.profile) + wire.tape level).1 + rw [sampleAt] at actualSample + rw [actualSample] at queried + have depths := CausalBoundary.production_boundary_facts packet.val.profile level + have actualQueries := QueryBatchSoundness.queries_actual _ _ sample.1 depths.1 depths.2.1 + have equal := Option.some.inj (queried.symm.trans actualQueries) + subst qs + have rows := decodeStack_opening_rows packet.val.profile cap catalog roots (fun i => wire.rows[i]!) + _ out parsed wire.tape proof accepted level + have incoming := trace_opening_oracleBefore packet root base roots chain trace catalog _ out parsed proof accepted level + rw [rows,actualRows,incoming] + exact atQueries_get _ _ j jBound + +private theorem run_indexed_replies (input : CausalGame.Public) (tape : CausalGame.Tape input.config) + (replies : Array CausalGame.Reply) (proof : Opening) + (parsed : CausalGame.opening input.config (CausalGame.challenges input.config tape) replies = .ok proof) : + CausalGame.run (CausalStrategy.indexedStrategy replies) input [] + (CausalGame.visibleBatches input.config tape.1 (CausalGame.challenges input.config tape)) = replies.toList := by + have count := CausalRefinement.checkReplies_length _ _ + ((CausalRefinement.opening_ok_iff _ _ _ _).mp parsed).1 + have length : replies.toList.length = + (CausalGame.visibleBatches input.config tape.1 (CausalGame.challenges input.config tape)).length := by + simpa only [CausalGame.visibleBatches,List.length_append,List.length_singleton] using count + apply List.ext_getElem! (by rw [CausalStrategy.run_length,length]) + intro i + by_cases covered : i < replies.toList.length + · rw [CausalStrategy.indexed_response replies input [] _ i (by omega)] + simp only [List.length_nil,Nat.zero_add] + rw [getElem!_pos replies i covered,getElem!_pos replies.toList i covered] + rfl + · have gone : ¬i < (CausalGame.run (CausalStrategy.indexedStrategy replies) input [] + (CausalGame.visibleBatches input.config tape.1 (CausalGame.challenges input.config tape))).length := by + rw [CausalStrategy.run_length,← length] + exact covered + rw [getElem!_neg (CausalGame.run (CausalStrategy.indexedStrategy replies) input [] + (CausalGame.visibleBatches input.config tape.1 (CausalGame.challenges input.config tape))) i gone, + getElem!_neg replies.toList i covered] + +theorem experiment_indexed_accepts (input : CausalGame.Public) (tape : CausalGame.Tape input.config) + (replies : Array CausalGame.Reply) (proof : Opening) + (parsed : CausalGame.opening input.config (CausalGame.challenges input.config tape) replies = .ok proof) + (shapes : input.claims.all (fun claim => shapeValid input.config input.lanes claim.weight) = true) + (verified : let claim := CausalGame.batchClaims (2^input.config.logN) input.claims tape.1 + Protocol.verify input.config (CausalGame.challenges input.config tape) input.lanes + (CausalGame.liftRoot input.root) claim.weight claim.value proof = .ok ()) : + CausalGame.experiment input (CausalStrategy.indexedStrategy replies) tape = true := by + unfold CausalGame.experiment + dsimp only + rw [shapes,run_indexed_replies input tape replies proof parsed] + simp only [Bool.not_true,Bool.false_eq_true,ite_false,Array.toArray_toList,parsed, + verified,Except.isOk] + rfl + +theorem capture_base_shape {cap : Nat} (state : CausalBindingState.State cap) + (p : ParameterBounds.Profile) (root : Digest32) (lanes : Nat) + (bound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) : + oracleValid (CausalGame.liftRoot (CausalBindingState.capture state p root lanes bound).base) + (2^((ParameterBounds.config p).logN-(ParameterBounds.config p).folds[0]!+ + (ParameterBounds.config p).rates[0]!)) lanes = true := by + have shape := compactBaseOracle_valid + (recordedHash (CausalBindingState.capture state p root lanes bound).records (fun _ => 0)) + (CausalBindingState.capture state p root lanes bound).snapshot root + (CausalGame.remaining (ParameterBounds.config p) 0+(ParameterBounds.config p).rates[0]!) + (ParameterBounds.length (ParameterBounds.config p) 0) + (2^(ParameterBounds.config p).folds[0]!) lanes bound + simpa only [CausalBindingState.Commitment.base,CausalBindingState.capture,ParameterBounds.length, + (InitialCandidates.production_initial_facts p).1] using shape + +theorem accepted_completed_depth {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} (v : Verified ctx Q cap packet) + (complete : Completed stack packet v.wire v.history) : + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) := by + obtain ⟨_,_,_,_,_,_,_,_,_,_,size,_,_⟩ := complete + obtain ⟨_,proof,_,parsed,_⟩ := v.acceptance + have count := CausalRefinement.checkReplies_length _ _ + ((CausalRefinement.opening_ok_iff _ _ _ _).mp parsed).1 + have stream := congrArg List.length + (CausalProbability.visibleCoordinates_map (ParameterBounds.config packet.val.profile) v.wire.tape) + simp only [List.length_map] at stream + have length : v.wire.replies.size = + (CausalProbability.visibleCoordinates (ParameterBounds.config packet.val.profile)).length := by + calc + v.wire.replies.size = (CausalGame.visibleBatches (ParameterBounds.config packet.val.profile) + E.zero (CausalGame.challenges (ParameterBounds.config packet.val.profile) v.wire.tape)).length := count + _ = (CausalGame.visibleBatches (ParameterBounds.config packet.val.profile) + v.wire.tape.1 (CausalGame.challenges (ParameterBounds.config packet.val.profile) v.wire.tape)).length := by + simp only [CausalGame.visibleBatches,List.length_append,List.length_singleton] + _ = _ := stream.symm + have max := RawWHIRKeys.packet_depth ctx Q packet + have hidden : (WHIRHistory.hiddenTail (ParameterBounds.config packet.val.profile)).length ≤ 1 := by + unfold WHIRHistory.hiddenTail + split <;> simp + simp only [WHIRHistory.depth,WHIRHistory.schedule,List.length_append] at max ⊢ + omega + +private theorem runs_done_eq {R : Type} {left right : R} {trace : List Observation} + (run : Runs (.done left) trace right) : left = right := by + cases run + rfl + +/-- Both canonical causal replay and every retained actual Merkle subrun are +derived from acceptance of the real physical source, not provided as interfaces. -/ +theorem verifySource_execution (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q lanes : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (v : Verified ctx Q cap packet) + (run : Runs (WHIRSourceChronology.erase (verifySource cap model ctx stack Q lanes packet proofs)) + observations (some v)) : + Trace ctx stack Q packet.val.profile v.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile v.request.root) v.wire v.history ∧ + ∀ opening ∈ v.wire.openings, ObservedOpening v.request.lanes proofs observations opening := by + obtain ⟨root,before,after,request,_,rootEq,traceEq,_,_,decoded,physical⟩ := + WHIRPhysicalCaller.verifySource_success cap model ctx stack Q lanes packet proofs observations v run + obtain ⟨final,history,suffix,trace,last⟩ := readPhysicalPackets_trace ctx stack Q packet.val.profile + request.lanes proofs _ _ _ _ after v physical + obtain ⟨requestEq,wireEq,historyEq⟩ := + WHIRPhysicalCaller.finish_success ctx Q cap packet request final history _ _ v (runs_done_eq last) + constructor + · simpa only [← requestEq,rootEq,← wireEq,← historyEq] using trace + · obtain ⟨state,log,remaining,last,_,opened⟩ := + readPhysicalCompletion_openings ctx stack Q packet request.lanes proofs root _ after v physical + obtain ⟨_,wireEq',_⟩ := + WHIRPhysicalCaller.finish_success ctx Q cap packet request state log _ _ v (runs_done_eq last) + intro opening member + rw [wireEq'] at member + have retained := opened opening member + rw [requestEq] + apply retained.mono + intro event present + rw [traceEq] + exact List.mem_append_right _ present + +/-- The actual caller's original claims, bound to the first captured physical +commitment. Re-reading the final state cannot replace that frozen capture. -/ +noncomputable def committedStatement {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} (v : Verified ctx Q cap packet) + (state : CausalBindingState.State cap) : WHIRFiatShamir.StackInitial packet.val.profile cap := + CausalBindingState.bindClaims + (CausalBindingState.capture state packet.val.profile v.request.root v.request.lanes v.request.lane_bound) + v.request.claims + +private theorem opening_unerase (c : Config) (challenges : Challenges) + (replies : Array CausalGame.Reply) (erased : Opening) + (accepted : CausalGame.opening c challenges (replies.map WHIRPhysicalErasure.eraseReply) = .ok erased) : + ∃ proof, CausalGame.opening c challenges replies = .ok proof ∧ + WHIRPhysicalErasure.eraseOracles proof = erased := by + rw [WHIRPhysicalErasure.opening_erase] at accepted + cases parsed : CausalGame.opening c challenges replies with + | error message => simp [parsed,Except.map] at accepted + | ok proof => + simp [parsed,Except.map] at accepted + exact ⟨proof,rfl,accepted⟩ + +private theorem sourceVerify_erased {m : Nat} (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (challenges : Challenges) (lanes : Nat) (proof : Opening) : + WHIRNativeArithmetic.sourceVerify family points seed lambda c challenges lanes + (WHIRPhysicalErasure.eraseOracles proof) = + WHIRNativeArithmetic.sourceVerify family points seed lambda c challenges lanes proof := + WHIRNativeErasure.nativeVerify_erased c challenges lanes + (WHIRNativeArithmetic.initialClaim family points seed lambda) + (SuccinctRingGroups.sourceStackWeightAt family points seed lambda) proof + +/-- Actual native acceptance plus physical opening binding implies the exact +stack-history failure. All scalar parsing, source caller shapes, ghost-root +restoration, query authentication, sample identity, and native-to-protocol +refinement are discharged here. -/ +theorem trace_native_historyFailure {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (packet : RawWHIRKeys.Packet ctx Q) (proofs : Array PrunedMerklePaths) + (v : Verified ctx Q cap packet) (state : CausalBindingState.State cap) + (catalog : StackWHIRReplay.Catalog packet.val.profile cap) + (found : catalog packet.val.statement = some (committedStatement v state)) + (trace : Trace ctx stack Q packet.val.profile v.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile v.request.root) v.wire v.history) + (bound : WHIRPhysicalRoots.BoundRows (committedStatement v state).root + (CausalBindingState.roots state packet.val.profile) v.wire) + (falseClaims : ¬ ∃ witness ∈ InitialCandidates.witnesses (ParameterBounds.config packet.val.profile) + (committedStatement v state).lanes (committedStatement v state).root, + RingPCSGame.Honest (ParameterBounds.config packet.val.profile) (committedStatement v state).lanes + (committedStatement v state).family (committedStatement v state).points witness) : + StackWHIRROM.HistoryFailure packet.val.profile cap catalog (CausalBindingState.roots state packet.val.profile) + packet.val.statement packet.val.messages (localHistory ctx stack Q packet.val.profile v.history) := by + let original := committedStatement v state + let roots := CausalBindingState.roots state packet.val.profile + have chain := completion_chain ctx Q packet + have complete := trace_completed v.request.root chain trace + have depth := accepted_completed_depth v complete + obtain ⟨head,past,sample,erased,history,decoded,originalEq,initial,statement,tape,replies⟩ := + Completed.decodeStack packet v.wire v.history catalog original found complete v.replies_nonempty + have tail : (localHistory ctx stack Q packet.val.profile v.history).tail = past := by rw [history]; rfl + have full := decoded + change WHIRPhysicalHistory.decodeStack packet.val.profile cap catalog WHIRPhysicalErasure.zeroRoots + (fun i => v.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ = some erased at full + rw [WHIRPhysicalErasure.decodeStack_zero packet.val.profile cap catalog roots + (fun i => v.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩] at full + obtain ⟨replay,physical,erasedEq⟩ := Option.map_eq_some_iff.mp full + subst erased + change replay.original = original at originalEq + change v.wire.initial = some replay.initial at initial + change replay.whir.statement = StackWHIRReplay.transformedStatement original replay.initial.1 at statement + change (StackWHIRReplay.finish ⟨packet.val.statement,packet.val.messages,past⟩ replay sample).whir.tape = + v.wire.tape at tape + change replay.whir.replies.map WHIRPhysicalErasure.eraseReply = v.wire.replies at replies + have agreement := WHIRPhysicalRoots.trace_stackRowsAgree packet v.request.root catalog original roots + found chain trace bound + rw [tail] at agreement + have ideal := WHIRPhysicalHistory.decodeStack_success packet.val.profile cap catalog roots + (fun i => v.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ replay agreement physical + have lambda := StackWHIRReplay.decode_initial_lambda catalog roots + ⟨packet.val.statement,packet.val.messages,past⟩ replay ideal sample + rw [tape] at lambda + change v.wire.tape.1 = replay.initial.2 at lambda + obtain ⟨seed,nativeProof,seedFound,parsed,native,shapes⟩ := v.acceptance + have sameSeed : seed = replay.initial := Option.some.inj (seedFound.symm.trans initial) + subst seed + rw [← replies] at parsed + obtain ⟨proof,parsedFull,erasedProof⟩ := opening_unerase _ _ replay.whir.replies nativeProof parsed + have nativeFull : WHIRNativeArithmetic.sourceVerify v.request.claims.family v.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) v.wire.tape) + v.request.lanes proof = .ok () := by + rw [← sourceVerify_erased,erasedProof] + exact native + have rootsShape := decodeStack_rootShapes packet.val.profile cap state catalog + (fun i => v.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ replay physical + v.wire.tape proof parsedFull + have authenticated := trace_authenticatedRows packet v.request.root original.root roots chain trace bound + catalog replay (by rw [tail]; exact physical) proof parsedFull + have verified := WHIRNativeArithmetic.sourceVerify_refines v.request.claims.family v.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) _ + v.request.lanes proof (CausalGame.liftRoot original.root) v.nativeShapes.1 + (fun i => v.nativeShapes.2 _ (by simp)) shapes.2 + (capture_base_shape state packet.val.profile v.request.root v.request.lanes v.request.lane_bound) + rootsShape authenticated nativeFull + refine ⟨head,past,sample,replay,history,depth,ideal,?_,?_⟩ + · change CausalGame.experiment replay.whir.statement.input + (CausalStrategy.indexedStrategy replay.whir.replies) + (StackWHIRReplay.finish ⟨packet.val.statement,packet.val.messages,past⟩ replay sample).whir.tape = true + rw [tape,statement] + apply experiment_indexed_accepts (StackWHIRReplay.transformedStatement original replay.initial.1).input + v.wire.tape replay.whir.replies proof parsedFull + · exact shapes.1 + · change Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) v.wire.tape) v.request.lanes + (CausalGame.liftRoot original.root) + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (RingPCSGame.transformedClaims (2^(ParameterBounds.config packet.val.profile).logN) + v.request.claims.family v.request.claims.points replay.initial.1) v.wire.tape.1).weight + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (RingPCSGame.transformedClaims (2^(ParameterBounds.config packet.val.profile).logN) + v.request.claims.family v.request.claims.points replay.initial.1) v.wire.tape.1).value proof = .ok () + rw [lambda] + exact verified + · change ¬ ∃ witness ∈ InitialCandidates.witnesses (ParameterBounds.config packet.val.profile) + replay.original.lanes replay.original.root, + RingPCSGame.Honest (ParameterBounds.config packet.val.profile) replay.original.lanes + replay.original.family replay.original.points witness + rw [originalEq] + exact falseClaims + +theorem verifySource_native_historyFailure (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q lanes : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (v : Verified ctx Q cap packet) + (run : Runs (WHIRSourceChronology.erase (verifySource cap model ctx stack Q lanes packet proofs)) + observations (some v)) + (state : CausalBindingState.State cap) (catalog : StackWHIRReplay.Catalog packet.val.profile cap) + (found : catalog packet.val.statement = some (committedStatement v state)) + (bound : WHIRPhysicalRoots.BoundRows (committedStatement v state).root + (CausalBindingState.roots state packet.val.profile) v.wire) + (falseClaims : ¬ ∃ witness ∈ InitialCandidates.witnesses (ParameterBounds.config packet.val.profile) + (committedStatement v state).lanes (committedStatement v state).root, + RingPCSGame.Honest (ParameterBounds.config packet.val.profile) (committedStatement v state).lanes + (committedStatement v state).family (committedStatement v state).points witness) : + StackWHIRROM.HistoryFailure packet.val.profile cap catalog (CausalBindingState.roots state packet.val.profile) + packet.val.statement packet.val.messages (localHistory ctx stack Q packet.val.profile v.history) := + trace_native_historyFailure packet proofs v state catalog found + (verifySource_execution cap model ctx stack Q lanes packet proofs observations v run).1 bound falseClaims + +private theorem replyFootprint_roots {c : Config} (q : CausalProbability.Coordinate c) (scalars : List E) : + (WHIRSnapshotReplay.replyFootprint q scalars).map Prod.fst = (absorbedRoot q scalars).toList := by + cases q with + | initial => rfl + | ood => rfl + | query => rfl + | tail => rfl + | fold i j => + by_cases last : j.val+1 = c.folds[i.val]! <;> by_cases next : i.val+1 < c.folds.size + all_goals + rcases scalars with (_ | ⟨a,(_ | ⟨b,(_ | ⟨r,(_ | ⟨s,(_ | ⟨extra,rest⟩)⟩)⟩)⟩)⟩) + all_goals simp_all [WHIRSnapshotReplay.replyFootprint,absorbedRoot,Function.comp_def] + all_goals split_ifs <;> simp_all [Function.comp_def] + +theorem rootLog_footprint (p : ParameterBounds.Profile) (statement : Digest32) + (messages : List WHIRHistory.Pending) : + WHIRQueryOracleRecurrence.rootLog p statement messages = + (WHIRSnapshotReplay.historyFootprint p statement messages).map Prod.fst := by + induction messages with + | nil => rfl + | cons pending messages ih => + cases messages with + | nil => rfl + | cons previous older => + rw [WHIRQueryOracleRecurrence.rootLog_cons,WHIRSnapshotReplay.historyFootprint, + List.map_append,replyFootprint_roots,ih] + +theorem trace_opening_origin {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + (packet : RawWHIRKeys.Packet ctx Q) {packets : List (RawWHIRKeys.Packet ctx Q)} + {lanes : Nat} {proofs : Array PrunedMerklePaths} {wire : WireState packet.val.profile} {history} + (root : Digest32) (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q packet.val.profile lanes proofs packets + (initialWireState packet.val.profile root) wire history) + (opening : QueryOpening packet.val.profile) (member : opening ∈ wire.openings) : + opening.root = root ∨ ∃ ref ∈ WHIRSnapshotReplay.historyFootprint packet.val.profile + packet.val.statement packet.val.messages, ref.1 = opening.root := by + have registered := (WHIRPhysicalRoots.trace_rooted root trace opening member).1 + have present := Array.mem_of_getElem? registered + rw [WHIRPhysicalRoots.trace_roots_log root chain trace] at present + have alternatives : opening.root = root ∨ opening.root ∈ + WHIRQueryOracleRecurrence.rootLog packet.val.profile packet.val.statement packet.val.messages := by + simpa using present + rcases alternatives with first | later + · exact Or.inl first + · right + rw [rootLog_footprint] at later + exact List.mem_map.mp later + +theorem trace_opening_registered {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (packet : RawWHIRKeys.Packet ctx Q) {packets : List (RawWHIRKeys.Packet ctx Q)} + {lanes : Nat} {proofs : Array PrunedMerklePaths} {wire : WireState packet.val.profile} {history} + (root : Digest32) (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q packet.val.profile lanes proofs packets + (initialWireState packet.val.profile root) wire history) + (state : CausalBindingState.State cap) + (initial : ∃ snap, lookup root state.registry = some snap) + (prepared : CausalBindingState.Prepared state packet.val.profile + ⟨packet.val.statement,packet.val.messages,[]⟩) + (opening : QueryOpening packet.val.profile) (member : opening ∈ wire.openings) : + ∃ snap, lookup opening.root state.registry = some snap := by + rcases trace_opening_origin packet root chain trace opening member with first | ⟨ref,present,equal⟩ + · simpa only [first] using initial + · obtain ⟨snap,known⟩ := prepared ref present + exact ⟨snap,equal ▸ known⟩ + +theorem trace_base_opening_root {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + (packet : RawWHIRKeys.Packet ctx Q) {packets : List (RawWHIRKeys.Packet ctx Q)} + {lanes : Nat} {proofs : Array PrunedMerklePaths} {wire : WireState packet.val.profile} {history} + (root : Digest32) (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q packet.val.profile lanes proofs packets + (initialWireState packet.val.profile root) wire history) + (opening : QueryOpening packet.val.profile) (member : opening ∈ wire.openings) + (base : opening.level.val = 0) : opening.root = root := by + have found := (WHIRPhysicalRoots.trace_rooted root trace opening member).1 + rw [base,WHIRPhysicalRoots.trace_roots_log root chain trace] at found + have equal : root = opening.root := by simpa using found + exact equal.symm + +theorem frozenQueryOracle_state {cap : Nat} (C : PrimitiveOracle) (state : CausalBindingState.State cap) + (invariant : WHIRPhysicalSnapshots.Invariant C state) (p : ParameterBounds.Profile) + (root : Digest32) (snapshot : Snapshot) (known : lookup root state.registry = some snapshot) + (level lanes : Nat) (bound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) : + frozenQueryOracle (PublicMerkleLog.hash C) snapshot root p level lanes = + if level = 0 then + CausalGame.liftRoot (CausalBindingState.capture state p root lanes bound).base + else CausalBindingState.roots state p root level := by + by_cases base : level = 0 + · subst level + rw [ite_eq_left rfl,CausalBindingState.capture_base_actual (PublicMerkleLog.hash C) state p root lanes bound + invariant.covered invariant.authentic] + simp only [frozenQueryOracle,leafWords,ite_true,CausalBindingState.capture,known,Option.getD_some, + ParameterBounds.length,Nat.log2_two_pow] + · rw [ite_eq_right base,CausalBindingState.roots_actual (PublicMerkleLog.hash C) state p root level + snapshot known invariant.covered invariant.authentic] + simp only [frozenQueryOracle,ite_eq_right base,ParameterBounds.length,Nat.log2_two_pow] + +/-- A failure of the fixed actual row tables has a witnessed compression-game +failure at one of the real retained openings and its exact first-frozen log. -/ +theorem trace_boundRows_or_bad {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (C : PrimitiveOracle) (iv : Digest32) (packet : RawWHIRKeys.Packet ctx Q) + (proofs : Array PrunedMerklePaths) (v : Verified ctx Q cap packet) + (observations : List Observation) (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (observed : ∀ opening ∈ v.wire.openings, ObservedOpening v.request.lanes proofs observations opening) + (trace : Trace ctx stack Q packet.val.profile v.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile v.request.root) v.wire v.history) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, lookup v.request.root state.registry = some snap) + (prepared : CausalBindingState.Prepared state packet.val.profile + ⟨packet.val.statement,packet.val.messages,[]⟩) : + WHIRPhysicalRoots.BoundRows (committedStatement v state).root + (CausalBindingState.roots state packet.val.profile) v.wire ∨ + ∃ opening ∈ v.wire.openings, ∃ oldLog, + state.frozenLog opening.root = some oldLog ∧ + PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths := by + classical + by_cases good : WHIRPhysicalRoots.BoundRows (committedStatement v state).root + (CausalBindingState.roots state packet.val.profile) v.wire + · exact Or.inl good + · right + unfold WHIRPhysicalRoots.BoundRows at good + push Not at good + obtain ⟨opening,member,different⟩ := good + have chain := completion_chain ctx Q packet + obtain ⟨snapshot,known⟩ := trace_opening_registered packet v.request.root chain trace state + initial prepared opening member + obtain ⟨retained,oldLog,_,frozen,authentic,history,saturated,table⟩ := + invariant.retained opening.root snapshot known + rcases observed_binding (observed opening member) C iv answers oldLog authentic + retained history saturated snapshot table with bound | bad + · exfalso + apply different + rw [frozenQueryOracle_state C state invariant packet.val.profile opening.root snapshot known + opening.level.val v.request.lanes v.request.lane_bound] at bound + by_cases base : opening.level.val = 0 + · have rootEq := trace_base_opening_root packet v.request.root chain trace opening member base + simpa only [base,ite_true,rootEq,committedStatement,CausalBindingState.bindClaims] using bound + · simpa only [ite_eq_right base] using bound + · exact ⟨opening,member,oldLog,frozen,bad⟩ + +end Whir.WHIRPhysicalSoundness diff --git a/verification/whir/Whir/WHIRPhysicalVerifier.lean b/verification/whir/Whir/WHIRPhysicalVerifier.lean new file mode 100644 index 000000000..df44b1c95 --- /dev/null +++ b/verification/whir/Whir/WHIRPhysicalVerifier.lean @@ -0,0 +1,925 @@ +import Whir.PrunedMerkleProgram +import Whir.PrunedMerkleCoverage +import Whir.PublicMerkleBinding +import Whir.WHIRPhysicalRows +import Whir.WHIRModeReplay +import Whir.WHIRSourceChronology +import Whir.WHIRPowProgram +import Whir.WHIRCallerSupport +import Whir.WHIRNativeArithmetic + +namespace Whir.WHIRPhysicalVerifier +open Concrete Protocol FiatShamirGame DuplexModeGame +open MerkleTransport MerkleTransport.Commitments +open WHIRPhysicalRows +set_option maxHeartbeats 800000 + +structure Opened where + paths : List RawPath + rows : Oracle + +/-- Native `open_rows` removes absent base lanes. The later WHIR base-row +fold, not this decoder, reverses them. Extension limbs are grouped once. -/ +def decodeRows (base : Bool) (rowWords leafWords : Nat) (paths : List RawPath) : Option Oracle := + if base then + some ((paths.map (fun p => ((p.leafData.drop (leafWords-rowWords)).map E.ofK).toArray)).toArray) + else + (collect (fun p => ByteCodec.wordsToFields p.leafData) paths).map + (fun rows => (rows.map List.toArray).toArray) + +def finishRows (base : Bool) (rowWords leafWords : Nat) (result : Option (List RawPath)) : Option Opened := + result.bind fun paths => (decodeRows base rowWords leafWords paths).map (fun rows => ⟨paths,rows⟩) + +/-- Every hash is an ordinary verification-purpose public primitive program. +The returned rows originate in the untrusted pruned proof, never in an ideal oracle. -/ +def openRows (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) : Program (Option Opened) := + WHIRModeFinal.bind (PrunedMerkleProgram.verify proof root numLeaves queries rowWords leafWords) + (fun result => .done (finishRows base rowWords leafWords result)) + +theorem openRows_counted (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) : + Counts (PrunedMerkleProgram.budget proof numLeaves leafWords) + (openRows proof root numLeaves queries rowWords leafWords base) := by + unfold openRows + rw [← Nat.add_zero (PrunedMerkleProgram.budget proof numLeaves leafWords)] + apply WHIRModeFinal.bind_counted + · exact PrunedMerkleProgram.verify_counted proof root numLeaves queries rowWords leafWords + · intro; trivial + +theorem openRows_real (C : PrimitiveOracle) (iv : Digest32) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) : + (runReal C iv (openRows proof root numLeaves queries rowWords leafWords base)).view.result = + (proof.open (PublicMerkleLog.hash C) root numLeaves queries rowWords leafWords).bind + (fun paths => (decodeRows base rowWords leafWords paths).map (fun rows => ⟨paths,rows⟩)) := by + rw [openRows,WHIRModeFinal.bind_real_result,PrunedMerkleProgram.verify_real_result] + rfl + +theorem openRows_real_accepted (C : PrimitiveOracle) (iv : Digest32) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) (out : Opened) + (accepted : (runReal C iv (openRows proof root numLeaves queries rowWords leafWords base)).view.result = some out) : + proof.open (PublicMerkleLog.hash C) root numLeaves queries rowWords leafWords = some out.paths ∧ + decodeRows base rowWords leafWords out.paths = some out.rows := by + rw [openRows_real] at accepted + cases opened : proof.open (PublicMerkleLog.hash C) root numLeaves queries rowWords leafWords with + | none => simp [opened] at accepted + | some paths => + cases decoded : decodeRows base rowWords leafWords paths with + | none => simp [opened,decoded] at accepted + | some rows => + simp only [opened,Option.bind_some,decoded,Option.map_some,Option.some.injEq] at accepted + subst out + exact ⟨rfl,decoded⟩ + +private theorem wordsBytes_length (words : List K) : (ByteCodec.wordsBytes words).length = 8 * words.length := by + induction words with + | nil => rfl + | cons x xs ih => + simp only [ByteCodec.wordsBytes,List.flatMap_cons,List.length_append,List.length_ofFn,List.length_cons] at * + omega + +private theorem opening_input_bounds (C : PrimitiveOracle) {address : List Bool} + (path : MerkleBinding.Opening (List K) Digest32 address) (leafWords limit : Nat) + (rowLength : path.row.length = leafWords) (size : 8 * leafWords < limit) (pairSize : 64 < limit) : + ∀ bytes ∈ path.inputs (hashing (PublicMerkleLog.hash C)), bytes.length < limit := by + induction path with + | leaf words => + intro bytes h + simp only [MerkleBinding.Opening.inputs,Finset.mem_singleton] at h + subst bytes + change words.length = leafWords at rowLength + simpa only [hashing,wordsBytes_length,rowLength] using size + | node right sibling child ih => + intro bytes h + simp only [MerkleBinding.Opening.inputs,Finset.mem_insert] at h + rcases h with equal | member + · subst bytes + simpa [hashing] using pairSize + · exact ih rowLength bytes member + +theorem path_input_bounds_lt (C : PrimitiveOracle) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) (rowWords leafWords limit : Nat) + (paths : List RawPath) + (accepted : proof.open (PublicMerkleLog.hash C) root numLeaves queries rowWords leafWords = some paths) + (size : 8 * leafWords < limit) (pairSize : 64 < limit) : + ∀ p ∈ paths, ∀ bytes ∈ p.opening.inputs (hashing (PublicMerkleLog.hash C)), bytes.length < limit := by + have refined := open_refines _ _ _ _ _ _ _ _ accepted + intro p member + obtain ⟨q,_,hp⟩ := forall₂_mem_right refined member + obtain ⟨stored,_,_,_,_,length,_,_⟩ := hp + have rowLength : p.opening.row.length = leafWords := by simpa only [RawPath.opening_row] using length + exact opening_input_bounds C p.opening leafWords limit rowLength size pairSize + +theorem path_input_bounds (C : PrimitiveOracle) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) (rowWords leafWords : Nat) + (paths : List RawPath) + (accepted : proof.open (PublicMerkleLog.hash C) root numLeaves queries rowWords leafWords = some paths) + (size : 8 * leafWords < 2^64) : + ∀ p ∈ paths, ∀ bytes ∈ p.opening.inputs (hashing (PublicMerkleLog.hash C)), bytes.length < 2^64 := + path_input_bounds_lt C proof root numLeaves queries rowWords leafWords (2^64) paths accepted size (by decide) + +private theorem maps_of_forall₂ {A B D : Type} (left : A → D) (right : B → D) + {xs : List A} {ys : List B} (same : List.Forall₂ (fun x y => left x = right y) xs ys) : + xs.map left = ys.map right := by + induction same with + | nil => rfl + | cons equal rest ih => simp only [List.map_cons,equal,ih] + +def atQueries (oracle : Oracle) (queries : List Nat) : Oracle := + (queries.map (fun q => oracle[q]!)).toArray + +private theorem liftRoot_get (root : CausalGame.BaseOracle) (q : Nat) (h : q < root.size) : + (CausalGame.liftRoot root)[q]! = root[q]!.map E.ofK := by + simp [CausalGame.liftRoot,getElem!_pos,h] + +theorem decode_base_bound (hash : Primitive) (snapshot : Snapshot) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (lanes leafWords : Nat) (paths : List RawPath) + (accepted : proof.open hash root numLeaves queries lanes leafWords = some paths) + (bound : ∀ p ∈ paths, p.leafData = row hash snapshot root numLeaves.log2 p.leafIndex) : + decodeRows true lanes leafWords paths = some (atQueries + (CausalGame.liftRoot (compactBaseOracle hash snapshot root numLeaves.log2 numLeaves leafWords lanes)) queries) := by + have good := open_compact_rows hash snapshot proof root numLeaves queries lanes leafWords paths accepted bound + have conditions := ((open_spec _ _ _ _ _ _ _ _).mp accepted).1 + let oracle := CausalGame.liftRoot (compactBaseOracle hash snapshot root numLeaves.log2 numLeaves leafWords lanes) + have mapped : List.Forall₂ (fun q p => + oracle[q]! = ((p.leafData.drop (leafWords-lanes)).map E.ofK).toArray) queries paths := by + apply List.forall₂_of_length_eq_of_get good.length_eq + intro i hi hp + have hq := conditions.range (queries.get ⟨i,hi⟩) (List.get_mem _ _) + rw [show oracle = CausalGame.liftRoot (compactBaseOracle hash snapshot root numLeaves.log2 numLeaves leafWords lanes) from rfl, + liftRoot_get _ _ (by simpa only [compactBaseOracle_size] using hq)] + simpa using (congrArg (fun a : Array K => a.map E.ofK) (good.get hi hp)).symm + have same := maps_of_forall₂ (fun q => oracle[q]!) + (fun p : RawPath => ((p.leafData.drop (leafWords-lanes)).map E.ofK).toArray) mapped + simpa [decodeRows,atQueries,oracle] using congrArg (fun xs => some xs.toArray) same.symm + +/-- A real accepted physical base opening either supplies exactly the frozen +occupied lanes, or supplies a concrete ordinary-compression bad witness. -/ +theorem openRows_base_binding (C : PrimitiveOracle) (iv : Digest32) + (oldLog : PublicMerkleLog.PublicLog) (auth : PublicMerkleLog.AuthenticLog C oldLog) + (snapshot : Snapshot) (table : snapshot.table = recordDomain (PublicMerkleLog.records oldLog)) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (lanes leafWords : Nat) (size : 8 * leafWords < 2^64) (out : Opened) + (accepted : (runReal C iv (openRows proof root numLeaves queries lanes leafWords true)).view.result = some out) : + out.rows = atQueries (CausalGame.liftRoot + (compactBaseOracle (PublicMerkleLog.hash C) snapshot root numLeaves.log2 numLeaves leafWords lanes)) queries ∨ + PublicMerkleBinding.OpenPrimitiveBad C oldLog root out.paths := by + obtain ⟨opened,decoded⟩ := openRows_real_accepted C iv proof root numLeaves queries lanes leafWords true out accepted + have frozen := (PublicMerkleBinding.open_frozen_public C oldLog auth [(root,snapshot)] [] + root snapshot table (by simp [Commitments.lookup]) proof numLeaves queries lanes leafWords out.paths + (path_input_bounds C proof root numLeaves queries lanes leafWords out.paths opened size) opened).2 + rcases frozen with good | bad + · exact Or.inl (Option.some.inj (decoded.symm.trans + (decode_base_bound _ snapshot proof root numLeaves queries lanes leafWords out.paths opened good))) + · exact Or.inr bad + +private theorem collect_right {A B D : Type} (f : B → Option D) (g : A → D) + {qs : List A} {ps : List B} (same : List.Forall₂ (fun q p => f p = some (g q)) qs ps) : + collect f ps = some (qs.map g) := by + induction same with + | nil => rfl + | cons equal rest ih => simp [collect,equal,ih] + +theorem openRows_extension_binding (C : PrimitiveOracle) (iv : Digest32) + (oldLog : PublicMerkleLog.PublicLog) (auth : PublicMerkleLog.AuthenticLog C oldLog) + (snapshot : Snapshot) (table : snapshot.table = recordDomain (PublicMerkleLog.records oldLog)) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (width : Nat) (size : 8 * (3*width) < 2^64) (out : Opened) + (accepted : (runReal C iv (openRows proof root numLeaves queries (3*width) (3*width) false)).view.result = some out) : + out.rows = atQueries + (intermediateOracle (PublicMerkleLog.hash C) snapshot root numLeaves.log2 numLeaves width) queries ∨ + PublicMerkleBinding.OpenPrimitiveBad C oldLog root out.paths := by + obtain ⟨opened,decoded⟩ := openRows_real_accepted C iv proof root numLeaves queries (3*width) (3*width) false out accepted + rcases open_intermediate_rows (PublicMerkleLog.hash C) snapshot proof root numLeaves queries width out.paths opened with good | bad + · have collected := collect_right _ _ good + have rows : decodeRows false (3*width) (3*width) out.paths = some (atQueries + (intermediateOracle (PublicMerkleLog.hash C) snapshot root numLeaves.log2 numLeaves width) queries) := by + simp [decodeRows,collected,atQueries,List.map_map,Function.comp_def] + exact Or.inl (Option.some.inj (decoded.symm.trans rows)) + · exact Or.inr (PublicMerkleBinding.openBad_primitive C oldLog auth snapshot table root out.paths + (path_input_bounds C proof root numLeaves queries (3*width) (3*width) out.paths opened size) bad) + +/-- Historical first-record tables may retain entries reconstructed at earlier +public prefixes. No decoder coverage assumption is needed: absence of an +observed primitive collision makes their saturated domain exact. -/ +theorem openRows_base_retained (C : PrimitiveOracle) (iv : Digest32) + (oldLog : PublicMerkleLog.PublicLog) (auth : PublicMerkleLog.AuthenticLog C oldLog) + (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicMerkleLog.PublicLog, + (∀ q ∈ earlier, q ∈ oldLog) ∧ e ∈ PublicMerkleLog.records earlier) + (saturated : ∀ bytes d, (bytes,d) ∈ PublicMerkleLog.records oldLog → ∃ first, (bytes,first) ∈ retained) + (snapshot : Snapshot) (table : snapshot.table = recordDomain retained) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (lanes leafWords : Nat) (size : 8 * leafWords < 2^64) (out : Opened) + (accepted : (runReal C iv (openRows proof root numLeaves queries lanes leafWords true)).view.result = some out) : + out.rows = atQueries (CausalGame.liftRoot + (compactBaseOracle (PublicMerkleLog.hash C) snapshot root numLeaves.log2 numLeaves leafWords lanes)) queries ∨ + PublicMerkleBinding.OpenPrimitiveBad C oldLog root out.paths := by + classical + by_cases collision : PublicMerkleLog.OutputCollision oldLog + · exact Or.inr (Or.inl collision) + · exact openRows_base_binding C iv oldLog auth snapshot + (table.trans (PublicMerkleBinding.historical_domain_eq C oldLog auth collision retained history saturated)) + proof root numLeaves queries lanes leafWords size out accepted + +theorem openRows_extension_retained (C : PrimitiveOracle) (iv : Digest32) + (oldLog : PublicMerkleLog.PublicLog) (auth : PublicMerkleLog.AuthenticLog C oldLog) + (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicMerkleLog.PublicLog, + (∀ q ∈ earlier, q ∈ oldLog) ∧ e ∈ PublicMerkleLog.records earlier) + (saturated : ∀ bytes d, (bytes,d) ∈ PublicMerkleLog.records oldLog → ∃ first, (bytes,first) ∈ retained) + (snapshot : Snapshot) (table : snapshot.table = recordDomain retained) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (width : Nat) (size : 8 * (3*width) < 2^64) (out : Opened) + (accepted : (runReal C iv (openRows proof root numLeaves queries (3*width) (3*width) false)).view.result = some out) : + out.rows = atQueries + (intermediateOracle (PublicMerkleLog.hash C) snapshot root numLeaves.log2 numLeaves width) queries ∨ + PublicMerkleBinding.OpenPrimitiveBad C oldLog root out.paths := by + classical + by_cases collision : PublicMerkleLog.OutputCollision oldLog + · exact Or.inr (Or.inl collision) + · exact openRows_extension_binding C iv oldLog auth snapshot + (table.trans (PublicMerkleBinding.historical_domain_eq C oldLog auth collision retained history saturated)) + proof root numLeaves queries width size out accepted + +/-- The public geometry, not adversarially sized proof buffers, bounds all +real and arbitrary ideal branches, including hashes preceding rejection. -/ +theorem openRows_counted_uniform (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) : + Counts (PrunedMerkleProgram.uniformBudget numLeaves queries leafWords) + (openRows proof root numLeaves queries rowWords leafWords base) := by + unfold openRows + rw [← Nat.add_zero (PrunedMerkleProgram.uniformBudget numLeaves queries leafWords)] + apply WHIRModeFinal.bind_counted + · exact PrunedMerkleProgram.verify_counted_uniform proof root numLeaves queries rowWords leafWords + · intro; trivial + +def replayOpenRows (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) (trace : List Observation) : + Option (Option Opened × List Observation) := + ((PrunedMerkleProgram.plan proof root numLeaves queries rowWords leafWords).replay trace).map + (fun result => (finishRows base rowWords leafWords result.1,result.2)) + +/-- Public chronological reconstruction is valid even when a stateful ideal +simulator gives different replies to repeated identical primitive inputs. -/ +theorem openRows_replay (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) + (trace suffix : List Observation) (result : Option Opened) + (runs : PublicMerkleProgram.Runs (openRows proof root numLeaves queries rowWords leafWords base) trace result) : + replayOpenRows proof root numLeaves queries rowWords leafWords base (trace++suffix) = some (result,suffix) := by + obtain ⟨before,value,after,joined,prior,last⟩ := + (PublicMerkleProgram.Runs.bind_iff _ _).mp runs + cases last + simp only [List.append_nil] at joined + subst trace + simp only [replayOpenRows,PrunedMerkleProgram.verify_replay _ _ _ _ _ _ _ _ _ prior,Option.map_some] + +theorem openRows_ideal_replay {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) + (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (base : Bool) + (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (openRows proof root numLeaves queries rowWords leafWords base)) + (suffix : List Observation) : + replayOpenRows proof root numLeaves queries rowWords leafWords base + ((runIdeal sim ro iv state _ remaining cap counted).view.observations++suffix) = + some ((runIdeal sim ro iv state _ remaining cap counted).view.result,suffix) := + openRows_replay proof root numLeaves queries rowWords leafWords base _ suffix _ + (PublicMerkleProgram.runIdeal_runs sim ro iv state _ remaining cap counted) + +/-- Embed the physical queries in source chronology without adding hashes, +preimages, root announcements, or logical catalog metadata. -/ +def sourceLift {cap : Nat} {R S : Type} : + Program R → (R → WHIRSourceChronology.Source cap S) → WHIRSourceChronology.Source cap S + | .done r, next => next r + | .ask q cont, next => .ask q (fun answer => sourceLift (cont answer) next) + +theorem sourceLift_erase {cap : Nat} {R S : Type} (p : Program R) + (next : R → WHIRSourceChronology.Source cap S) : + WHIRSourceChronology.erase (sourceLift p next) = + WHIRModeFinal.bind p (fun r => WHIRSourceChronology.erase (next r)) := by + induction p with + | done => rfl + | ask q cont ih => + simp only [sourceLift,WHIRSourceChronology.erase,WHIRModeFinal.bind] + congr 1 + funext answer + exact ih answer + +theorem sourceLift_counted {cap : Nat} {R S : Type} (p : Program R) + (next : R → WHIRSourceChronology.Source cap S) (a b : Nat) + (before : Counts a p) (after : ∀ r, WHIRSourceChronology.Counts b (next r)) : + WHIRSourceChronology.Counts (a+b) (sourceLift p next) := by + have eraseCounts (s : WHIRSourceChronology.Source cap S) (n : Nat) : + Counts n (WHIRSourceChronology.erase s) ↔ WHIRSourceChronology.Counts n s := by + induction s generalizing n with + | done => rfl + | ask q cont ih => simp only [WHIRSourceChronology.erase,Counts,WHIRSourceChronology.Counts,ih] + | commit _ _ ih => exact ih n + | claims _ _ _ _ ih => exact ih n + apply (eraseCounts _ _).mp + rw [sourceLift_erase] + exact WHIRModeFinal.bind_counted p _ a b before (fun r => (eraseCounts _ _).mpr (after r)) + +def leafWords (p : ParameterBounds.Profile) (i : Nat) : Nat := + if i = 0 then 2^(ParameterBounds.config p).folds[0]! + else 3 * 2^(ParameterBounds.config p).folds[i]! + +def queryIndices (p : ParameterBounds.Profile) (i : Fin (ParameterBounds.config p).folds.size) + (x : CausalProbability.Sample (.query i)) : List Nat := + (QueryBatchSoundness.queries + (CausalGame.remaining (ParameterBounds.config p) i.val + (ParameterBounds.config p).rates[i.val]!) + (ParameterBounds.config p).queries[i.val]! x.1).toList + +def openQuery (p : ParameterBounds.Profile) (i : Fin (ParameterBounds.config p).folds.size) + (lanes : Nat) (proof : PrunedMerklePaths) (root : Digest32) + (x : CausalProbability.Sample (.query i)) : Program (Option Opened) := + openRows proof root (ParameterBounds.length (ParameterBounds.config p) i.val) + (queryIndices p i x) (if i.val = 0 then lanes else leafWords p i.val) + (leafWords p i.val) (i.val == 0) + +def queryBudget (p : ParameterBounds.Profile) (i : Nat) : Nat := + (PrunedMerkleProgram.leafChunkCost (leafWords p i) + + (ParameterBounds.length (ParameterBounds.config p) i).log2) * + (ParameterBounds.config p).queries[i]! + +theorem openQuery_counted (p : ParameterBounds.Profile) (i : Fin (ParameterBounds.config p).folds.size) + (lanes : Nat) (proof : PrunedMerklePaths) (root : Digest32) + (x : CausalProbability.Sample (.query i)) : + Counts (queryBudget p i.val) (openQuery p i lanes proof root x) := by + have size : (queryIndices p i x).length = (ParameterBounds.config p).queries[i.val]! := by + unfold queryIndices + rw [Array.length_toList] + exact QueryBatchSoundness.queries_size _ _ _ + simpa only [openQuery,queryBudget,PrunedMerkleProgram.uniformBudget,size] using + openRows_counted_uniform proof root (ParameterBounds.length (ParameterBounds.config p) i.val) + (queryIndices p i x) (if i.val = 0 then lanes else leafWords p i.val) + (leafWords p i.val) (i.val == 0) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_leaf_byte_tag_zero : ∀ p : ParameterBounds.Profile, + ∀ i : Fin (ParameterBounds.config p).folds.size, 8 * leafWords p i.val < 2^56 := by + decide +kernel + +theorem production_leaf_byte_limit (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) : 8 * leafWords p i.val < 2^64 := + lt_trans (production_leaf_byte_tag_zero p i) (by decide) + +structure QueryOpening (p : ParameterBounds.Profile) where + level : Fin (ParameterBounds.config p).folds.size + root : Digest32 + sample : CausalProbability.Sample (.query level) + result : Opened + +/-- Scalar state carries only physical proof rows and raw roots. No extracted +oracle occurs in the executable source state. Root fields in `Reply` are +shape markers; the actual digest is retained separately at its read point. -/ +structure WireState (p : ParameterBounds.Profile) where + tape : CausalGame.Tape (ParameterBounds.config p) + previous : Option (CausalProbability.Coordinate (ParameterBounds.config p)) + replies : Array CausalGame.Reply + rows : Array Oracle + roots : Array Digest32 + openings : List (QueryOpening p) + outputCache : Option Digest32 + lastNonceState : Option DuplexRefinement.State + initial : Option (RingPCSGame.Prefix × E) + +def initialWireState (p : ParameterBounds.Profile) (root : Digest32) : WireState p := + ⟨WHIRReplay.zeroTape p,none,#[],#[],#[root],[],none,none,none⟩ + +def absorbedRoot {c : Config} (q : CausalProbability.Coordinate c) (xs : List E) : Option Digest32 := + match q with + | .fold i j => + if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size then + match xs with | [_,_,a,b] => ByteCodec.scalarsToHash (a,b) | _ => none + else none + | _ => none + +/-- Read the transmitted scalar response before issuing its following squeeze. +Only an actually parsed final-fold root generates a commitment instruction. -/ +def absorbResponse {p : ParameterBounds.Profile} (state : WireState p) (pending : WHIRHistory.Pending) : + Option (WireState p × Option Digest32) := + match state.previous with + | none => if pending.scalars.isEmpty then some (state,none) else none + | some q => do + let rows := match q with | .query i => state.rows[i.val]! | _ => #[] + let response ← WHIRHistory.decodeReplyScalars q (fun _ => #[]) rows pending.scalars + let root := absorbedRoot q pending.scalars + let roots := match root with | none => state.roots | some d => state.roots.push d + some ({state with replies := state.replies.push response, roots},root) + +def recordSample {p : ParameterBounds.Profile} (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) : WireState p := + let sampled := {state with + previous := some q + tape := CausalProbability.set q state.tape (StackWHIRReplay.projectSample q x)} + match q, x with + | .initial, x => {sampled with initial := some x} + | _, _ => sampled + +theorem absorbedRoot_nonfold {c : Config} (q : CausalProbability.Coordinate c) + (xs : List E) (notFold : ∀ i j, q ≠ .fold i j) : absorbedRoot q xs = none := by + cases q with + | fold i j => exact False.elim (notFold i j rfl) + | _ => rfl + +def sampleBudget (p : ParameterBounds.Profile) : CausalProbability.Coordinate (ParameterBounds.config p) → Nat + | .query i => queryBudget p i.val + | _ => 0 + +/-- A query sample immediately consumes its actual flat proof, before the +following intro coefficients are read. Other samples do not inspect Merkle data. -/ +def takeSample {p : ParameterBounds.Profile} (lanes : Nat) (proofs : Array PrunedMerklePaths) + (state : WireState p) (q : CausalProbability.Coordinate (ParameterBounds.config p)) + (x : StackWHIRReplay.Sample q) : Program (Option (WireState p)) := + match q, x with + | .query i, x => + if i.val = state.rows.size then + match proofs[i.val]?, state.roots[i.val]? with + | some proof, some root => + WHIRModeFinal.bind (openQuery p i lanes proof root x) fun opened => + .done (opened.map fun out => + {recordSample state (.query i) x with + rows := state.rows.push out.rows, + openings := ⟨i,root,x,out⟩ :: state.openings}) + | _, _ => .done none + else .done none + | q, x => .done (some (recordSample state q x)) + +theorem takeSample_counted {p : ParameterBounds.Profile} (lanes : Nat) + (proofs : Array PrunedMerklePaths) (state : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) : + Counts (sampleBudget p q) (takeSample lanes proofs state q x) := by + cases q with + | query i => + simp only [takeSample,sampleBudget] + split + · cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · trivial + · trivial + · trivial + · rw [← Nat.add_zero (queryBudget p i.val)] + apply WHIRModeFinal.bind_counted + · exact openQuery_counted p i lanes _ _ x + · intro; trivial + · trivial + | _ => trivial + +theorem takeSample_query_accepted {p : ParameterBounds.Profile} (C : PrimitiveOracle) (iv : Digest32) + (lanes : Nat) (proofs : Array PrunedMerklePaths) (state out : WireState p) + (i : Fin (ParameterBounds.config p).folds.size) (x : CausalProbability.Sample (.query i)) + (accepted : (runReal C iv (takeSample lanes proofs state (.query i) x)).view.result = some out) : + ∃ proof root opened, proofs[i.val]? = some proof ∧ state.roots[i.val]? = some root ∧ + i.val = state.rows.size ∧ + (runReal C iv (openQuery p i lanes proof root x)).view.result = some opened ∧ + out = {recordSample state (.query i) x with + rows := state.rows.push opened.rows + openings := ⟨i,root,x,opened⟩ :: state.openings} := by + simp only [takeSample] at accepted + split at accepted + next shape => + cases hp : proofs[i.val]? with + | none => simp [hp,runReal] at accepted + | some proof => + cases hr : state.roots[i.val]? with + | none => simp [hp,hr,runReal] at accepted + | some root => + simp only [hp,hr] at accepted + rw [WHIRModeFinal.bind_real_result] at accepted + change ((runReal C iv (openQuery p i lanes proof root x)).view.result.map _) = some out at accepted + cases result : (runReal C iv (openQuery p i lanes proof root x)).view.result with + | none => simp [result] at accepted + | some opened => + simp only [result,Option.map_some,Option.some.injEq] at accepted + exact ⟨proof,root,opened,rfl,rfl,shape,result,accepted.symm⟩ + next => cases accepted + +noncomputable def frozenQueryOracle (hash : Primitive) (snapshot : Snapshot) + (root : Digest32) (p : ParameterBounds.Profile) (level lanes : Nat) : Oracle := + let rows := ParameterBounds.length (ParameterBounds.config p) level + if level = 0 then + CausalGame.liftRoot (compactBaseOracle hash snapshot root rows.log2 rows (leafWords p level) lanes) + else + intermediateOracle hash snapshot root rows.log2 rows (2^(ParameterBounds.config p).folds[level]!) + +theorem compactBaseOracle_valid (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows leafWords lanes : Nat) (fits : lanes ≤ leafWords) : + oracleValid (CausalGame.liftRoot + (compactBaseOracle hash snapshot root height numRows leafWords lanes)) numRows lanes = true := by + simp only [oracleValid,Bool.and_eq_true,beq_iff_eq,Array.all_eq_true] + constructor + · simp only [CausalGame.liftRoot,Array.size_map,compactBaseOracle_size] + · intro j hj + have bound : j < (compactBaseOracle hash snapshot root height numRows leafWords lanes).size := by + simpa only [CausalGame.liftRoot,Array.size_map] using hj + have index : j < numRows := by simpa only [compactBaseOracle_size] using bound + have size := compactBaseOracle_row_size hash snapshot root height numRows leafWords lanes j fits index + simpa only [getElem!_pos (compactBaseOracle hash snapshot root height numRows leafWords lanes) j bound, + CausalGame.liftRoot,Array.getElem_map,Array.size_map] using size + +theorem intermediateOracle_valid (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (height numRows width : Nat) : + oracleValid (intermediateOracle hash snapshot root height numRows width) numRows width = true := by + simp only [oracleValid,Bool.and_eq_true,beq_iff_eq,Array.all_eq_true] + constructor + · exact intermediateOracle_size hash snapshot root height numRows width + · intro j hj + have index : j < numRows := by simpa only [intermediateOracle_size] using hj + simpa only [getElem!_pos (intermediateOracle hash snapshot root height numRows width) j hj] using + intermediateOracle_row_size hash snapshot root height numRows width j index + +/-- Geometry is fixed by the extractor, including its missing-preimage branch; +it is not a shape assumption on a virtual commitment supplied by a caller. -/ +theorem frozenQueryOracle_valid (hash : Primitive) (snapshot : Snapshot) (root : Digest32) + (p : ParameterBounds.Profile) (level lanes : Nat) + (fits : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) : + oracleValid (frozenQueryOracle hash snapshot root p level lanes) + (ParameterBounds.length (ParameterBounds.config p) level) + (if level = 0 then lanes else 2^(ParameterBounds.config p).folds[level]!) = true := by + by_cases base : level = 0 + · subst level + simpa only [frozenQueryOracle,leafWords,ite_true] using + compactBaseOracle_valid hash snapshot root + (ParameterBounds.length (ParameterBounds.config p) 0).log2 + (ParameterBounds.length (ParameterBounds.config p) 0) + (2^(ParameterBounds.config p).folds[0]!) lanes fits + · simpa only [frozenQueryOracle,ite_eq_right base] using + intermediateOracle_valid hash snapshot root + (ParameterBounds.length (ParameterBounds.config p) level).log2 + (ParameterBounds.length (ParameterBounds.config p) level) + (2^(ParameterBounds.config p).folds[level]!) + +theorem openQuery_binding (C : PrimitiveOracle) (iv : Digest32) + (oldLog : PublicMerkleLog.PublicLog) (auth : PublicMerkleLog.AuthenticLog C oldLog) + (snapshot : Snapshot) (table : snapshot.table = recordDomain (PublicMerkleLog.records oldLog)) + (p : ParameterBounds.Profile) (i : Fin (ParameterBounds.config p).folds.size) + (lanes : Nat) (proof : PrunedMerklePaths) (root : Digest32) + (x : CausalProbability.Sample (.query i)) (out : Opened) + (accepted : (runReal C iv (openQuery p i lanes proof root x)).view.result = some out) : + out.rows = atQueries (frozenQueryOracle (PublicMerkleLog.hash C) snapshot root p i.val lanes) + (queryIndices p i x) ∨ PublicMerkleBinding.OpenPrimitiveBad C oldLog root out.paths := by + by_cases base : i.val = 0 + · have phase : (i.val == 0) = true := by simp [base] + have opened := openRows_base_binding C iv oldLog auth snapshot table proof root + (ParameterBounds.length (ParameterBounds.config p) i.val) (queryIndices p i x) + lanes (leafWords p i.val) (production_leaf_byte_limit p i) out + (by simpa only [openQuery,ite_eq_left base,phase] using accepted) + simpa only [frozenQueryOracle,ite_eq_left base] using opened + · have phase : (i.val == 0) = false := by simp [base] + have words : leafWords p i.val = 3 * 2^(ParameterBounds.config p).folds[i.val]! := by + rw [leafWords,ite_eq_right base] + have opened := openRows_extension_binding C iv oldLog auth snapshot table proof root + (ParameterBounds.length (ParameterBounds.config p) i.val) (queryIndices p i x) + (2^(ParameterBounds.config p).folds[i.val]!) + (by simpa only [words] using production_leaf_byte_limit p i) out + (by simpa only [openQuery,ite_eq_right base,phase,words] using accepted) + simpa only [frozenQueryOracle,ite_eq_right base] using opened + +theorem openQuery_retained (C : PrimitiveOracle) (iv : Digest32) + (oldLog : PublicMerkleLog.PublicLog) (auth : PublicMerkleLog.AuthenticLog C oldLog) + (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicMerkleLog.PublicLog, + (∀ q ∈ earlier, q ∈ oldLog) ∧ e ∈ PublicMerkleLog.records earlier) + (saturated : ∀ bytes d, (bytes,d) ∈ PublicMerkleLog.records oldLog → ∃ first, (bytes,first) ∈ retained) + (snapshot : Snapshot) (table : snapshot.table = recordDomain retained) + (p : ParameterBounds.Profile) (i : Fin (ParameterBounds.config p).folds.size) + (lanes : Nat) (proof : PrunedMerklePaths) (root : Digest32) + (x : CausalProbability.Sample (.query i)) (out : Opened) + (accepted : (runReal C iv (openQuery p i lanes proof root x)).view.result = some out) : + out.rows = atQueries (frozenQueryOracle (PublicMerkleLog.hash C) snapshot root p i.val lanes) + (queryIndices p i x) ∨ PublicMerkleBinding.OpenPrimitiveBad C oldLog root out.paths := by + classical + by_cases collision : PublicMerkleLog.OutputCollision oldLog + · exact Or.inr (Or.inl collision) + · exact openQuery_binding C iv oldLog auth snapshot + (table.trans (PublicMerkleBinding.historical_domain_eq C oldLog auth collision retained history saturated)) + p i lanes proof root x out accepted + +def packetQuery (ctx : RawWHIRKeys.Context) (Q : Nat) (p : ParameterBounds.Profile) + (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) : + CausalProbability.Coordinate (ParameterBounds.config p) := + profile ▸ WHIRReplay.query packet.val.profile (packet.val.statement,packet.val.messages) + +def packetSample (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (packet : RawWHIRKeys.Packet ctx Q) + (profile : packet.val.profile = p) (raw : RawOracleCoupling.Concrete.GroupAnswer ctx Q (.inl packet)) : + StackWHIRReplay.Sample (packetQuery ctx Q p packet profile) := by + subst p + exact WHIRRawReplay.decodePacket ctx stack Q packet raw + +/-- All requested output coordinates are the nonce interpreter's returned +normalized history, whose equality and admissibility are carried by the result. -/ +def readPacket (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (nonce : WHIRPowProgram.Outcome ctx Q packet) : + Program (RawOracleCoupling.Concrete.GroupAnswer ctx Q (.inl packet)) := + WHIRModeProgram.readPacket (RawWHIRKeys.blocks ctx packet.val) + (fun i => .construction (nonce.coordinate i.val) (nonce.coordinate_admissible i)) Program.done + +theorem readPacket_eq (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (nonce : WHIRPowProgram.Outcome ctx Q packet) : + readPacket ctx Q packet nonce = + WHIRModeProgram.readPacket (RawWHIRKeys.blocks ctx packet.val) + (WHIRModeFinal.request ctx Q packet) Program.done := by + unfold readPacket + congr 1 + funext i + simp only [WHIRModeFinal.request,WHIRPowProgram.Outcome.coordinate_eq] + +theorem readPacket_counted (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (nonce : WHIRPowProgram.Outcome ctx Q packet) : + Counts (WHIRModeFinal.packetCost ctx Q packet) (readPacket ctx Q packet nonce) := by + rw [readPacket_eq] + simpa only [Nat.add_zero,WHIRModeFinal.packetCost,WHIRModeFinal.request,Query.cost] using + WHIRModeProgram.readPacket_counted (RawWHIRKeys.blocks ctx packet.val) + (WHIRModeFinal.request ctx Q packet) Program.done 0 (fun _ => True.intro) + +/-- #552 production query phases use the public constant17. Difficulty is +not an adversarial scalar field and earns no soundness amplification here. -/ +def nonceMatches {c : Config} (q : CausalProbability.Coordinate c) (pending : WHIRHistory.Pending) : Bool := + match q, pending.nonce with + | .query _, some (bits,_) => bits == 17 + | .query _, none => false + | _, nonce => nonce.isNone + +def afterNonce {p : ParameterBounds.Profile} {ctx Q packet} + (state : WireState p) (nonce : WHIRPowProgram.Outcome ctx Q packet) : Option (WireState p) := + match nonce.boundCV with + | none => some state + | some _ => state.outputCache.map (fun old => + {state with lastNonceState := nonce.state old}) + +def withOutput {p : ParameterBounds.Profile} (ctx : RawWHIRKeys.Context) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (raw : RawOracleCoupling.Concrete.GroupAnswer ctx Q (.inl packet)) + (state : WireState p) : WireState p := + {state with outputCache := some (raw ⟨RawWHIRKeys.blocks ctx packet.val-1,by + have := RawWHIRKeys.blocks_positive ctx packet.val + omega⟩)} + +def announce {cap : Nat} {R : Type} (root : Option Digest32) + (next : WHIRSourceChronology.Source cap R) : WHIRSourceChronology.Source cap R := + match root with | none => next | some d => .commit d next + +def packetBudget (ctx : RawWHIRKeys.Context) (Q : Nat) (p : ParameterBounds.Profile) + (packet : RawWHIRKeys.Packet ctx Q) (profile : packet.val.profile = p) : Nat := + WHIRPowProgram.packetCost ctx packet.val + WHIRModeFinal.packetCost ctx Q packet + + sampleBudget p (packetQuery ctx Q p packet profile) + +def packetsBudget (ctx : RawWHIRKeys.Context) (Q : Nat) (p : ParameterBounds.Profile) + (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ packet ∈ packets, packet.val.profile = p) : Nat := + (packets.attach.map (fun packet => packetBudget ctx Q p packet.val (profiles _ packet.property))).sum + +/-- Native final replay interleaves scalar reads, root announcements, complete +nonce verification/binding, output reads and actual pruned openings. Rejection +stops at its source boundary; no future row or message is consulted. -/ +def readPhysicalPackets {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (p : ParameterBounds.Profile) + (lanes : Nat) (proofs : Array PrunedMerklePaths) (reject : R) : + (packets : List (RawWHIRKeys.Packet ctx Q)) → + (∀ packet ∈ packets, packet.val.profile = p) → WireState p → + (WireState p → List (Sigma (RawOracleCoupling.Concrete.GroupAnswer ctx Q)) → + WHIRSourceChronology.Source cap R) → WHIRSourceChronology.Source cap R + | [], _, state, next => next state [] + | packet :: packets, profiles, state, next => + let profile := profiles packet (by simp) + let pending := packet.val.messages.headD ⟨[],none⟩ + match absorbResponse state pending with + | none => .done reject + | some (absorbed,root) => + if packet.val.messages.length = absorbed.replies.size+1 ∧ + nonceMatches (packetQuery ctx Q p packet profile) pending then + announce root (sourceLift (WHIRPowProgram.verifyPacket ctx Q packet) fun nonce => + match afterNonce absorbed nonce with + | none => .done reject + | some bound => + if nonce.accepted then + sourceLift (readPacket ctx Q packet nonce) fun raw => + sourceLift (takeSample lanes proofs bound (packetQuery ctx Q p packet profile) + (packetSample ctx stack Q p packet profile raw)) fun result => + match result with + | none => .done reject + | some checked => + readPhysicalPackets ctx stack Q p lanes proofs reject packets + (fun a ha => profiles a (by simp [ha])) (withOutput ctx Q packet raw checked) + (fun final history => next final (⟨.inl packet,raw⟩ :: history)) + else .done reject) + else .done reject + +theorem announce_counted {cap : Nat} {R : Type} (root : Option Digest32) + (next : WHIRSourceChronology.Source cap R) (budget : Nat) : + WHIRSourceChronology.Counts budget (announce root next) ↔ WHIRSourceChronology.Counts budget next := by + cases root <;> rfl + +theorem packetsBudget_cons (ctx : RawWHIRKeys.Context) (Q : Nat) (p : ParameterBounds.Profile) + (packet : RawWHIRKeys.Packet ctx Q) (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ a ∈ packet::packets, a.val.profile = p) : + packetsBudget ctx Q p (packet::packets) profiles = + packetBudget ctx Q p packet (profiles packet (by simp)) + + packetsBudget ctx Q p packets (fun a ha => profiles a (by simp [ha])) := by + simp [packetsBudget,List.attach_cons,List.map_map,Function.comp_def] + +/-- One public bound covers every arbitrary primitive/construction answer, +all malformed proof arrays, failed nonce predicates, and early-reject paths. -/ +theorem readPhysicalPackets_counted {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (p : ParameterBounds.Profile) + (lanes : Nat) (proofs : Array PrunedMerklePaths) (reject : R) + (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ packet ∈ packets, packet.val.profile = p) (state : WireState p) + (next : WireState p → List (Sigma (RawOracleCoupling.Concrete.GroupAnswer ctx Q)) → + WHIRSourceChronology.Source cap R) (budget : Nat) + (after : ∀ state history, WHIRSourceChronology.Counts budget (next state history)) : + WHIRSourceChronology.Counts (packetsBudget ctx Q p packets profiles + budget) + (readPhysicalPackets ctx stack Q p lanes proofs reject packets profiles state next) := by + induction packets generalizing state next with + | nil => simpa only [packetsBudget,List.attach_nil,List.map_nil,List.sum_nil,Nat.zero_add,readPhysicalPackets] using after state [] + | cons packet packets ih => + rw [packetsBudget_cons] + simp only [packetBudget,Nat.add_assoc,readPhysicalPackets] + cases ha : absorbResponse state (packet.val.messages.headD ⟨[],none⟩) with + | none => trivial + | some pair => + rcases pair with ⟨absorbed,root⟩ + dsimp only + split + · rw [announce_counted] + apply sourceLift_counted + · exact WHIRPowProgram.verifyPacket_counted ctx Q packet + · intro nonce + cases hn : afterNonce absorbed nonce with + | none => trivial + | some bound => + dsimp only + split + · apply sourceLift_counted + · exact readPacket_counted ctx Q packet nonce + · intro raw + apply sourceLift_counted + · exact takeSample_counted lanes proofs bound _ _ + · intro result + cases result with + | none => trivial + | some checked => + exact ih _ _ _ (fun final history => after final (⟨.inl packet,raw⟩ :: history)) + · trivial + · trivial + +local instance : DecidableEq FiatShamirGame.Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq FiatShamirGame.Coordinate := by + intro a b + cases a + cases b + simp only [FiatShamirGame.Coordinate.mk.injEq] + infer_instance + +/-- Prior caller outputs are read from their exact physical coordinates. The +decoder receives only replies already returned by those public requests. -/ +def readCallerInputs {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) : + List (WHIRModeFinal.CallerPosition ctx Q packet) → + (FiatShamirGame.Coordinate → Option Digest32) → + ((FiatShamirGame.Coordinate → Option Digest32) → WHIRSourceChronology.Source cap R) → + WHIRSourceChronology.Source cap R + | [], answers, next => next answers + | q :: qs, answers, next => + .ask (.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property)) + (fun answer => readCallerInputs ctx Q packet qs + (fun key => if key = q.val then some answer else answers key) next) + +theorem readCallerInputs_counted {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (qs : List (WHIRModeFinal.CallerPosition ctx Q packet)) + (answers : FiatShamirGame.Coordinate → Option Digest32) + (next : (FiatShamirGame.Coordinate → Option Digest32) → WHIRSourceChronology.Source cap R) + (budget : Nat) (after : ∀ answers, WHIRSourceChronology.Counts budget (next answers)) : + WHIRSourceChronology.Counts (WHIRModeFinal.callerCost qs + budget) + (readCallerInputs ctx Q packet qs answers next) := by + induction qs generalizing answers with + | nil => simpa only [WHIRModeFinal.callerCost,List.map_nil,List.sum_nil,Nat.zero_add,readCallerInputs] using after answers + | cons q qs ih => + simp only [readCallerInputs,WHIRSourceChronology.Counts,WHIRModeFinal.callerCost,List.map_cons,List.sum_cons,Query.cost] + refine ⟨by omega,fun answer => ?_⟩ + simpa only [WHIRModeFinal.callerCost,Nat.add_assoc,Nat.add_sub_cancel_left] using + ih (fun key => if key = q.val then some answer else answers key) + +theorem completion_profiles (ctx : RawWHIRKeys.Context) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) : + ∀ a ∈ RawOracleCoupling.Concrete.completion ctx Q packet, a.val.profile = packet.val.profile := by + intro a member + simp only [RawOracleCoupling.Concrete.completion,List.mem_append,List.mem_singleton] at member + rcases member with prior | same + · obtain ⟨i,rfl⟩ := List.mem_ofFn.mp prior + rfl + · subst a + rfl + +structure Verified (ctx : RawWHIRKeys.Context) (Q cap : Nat) (packet : RawWHIRKeys.Packet ctx Q) where + request : CausalBindingState.ClaimRequest cap packet.val.profile + wire : WireState packet.val.profile + history : List (Sigma (RawOracleCoupling.Concrete.GroupAnswer ctx Q)) + nativeShapes : SuccinctRingWeight.FamilyShape (ParameterBounds.config packet.val.profile).logN request.claims.family ∧ + ∀ point ∈ request.claims.points.toList, SuccinctPointWeight.Shape (ParameterBounds.config packet.val.profile).logN point + acceptance : ∃ (seedBatch : RingPCSGame.Prefix × E) (proof : Opening), + wire.initial = some seedBatch ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) wire.tape) wire.replies = .ok proof ∧ + WHIRNativeArithmetic.sourceVerify request.claims.family request.claims.points seedBatch.1 seedBatch.2 + (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) wire.tape) request.lanes proof = .ok () ∧ + let c := ParameterBounds.config packet.val.profile + let claims := RingPCSGame.transformedClaims (2^c.logN) request.claims.family request.claims.points seedBatch.1 + (claims.all (fun claim => Protocol.shapeValid c request.lanes claim.weight) = true) ∧ + Protocol.shapeValid c request.lanes (CausalGame.batchClaims (2^c.logN) claims seedBatch.2).weight = true + +theorem Verified.replies_nonempty {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} (v : Verified ctx Q cap packet) : v.wire.replies ≠ #[] := by + intro empty + obtain ⟨_,_,_,parsed,_⟩ := v.acceptance + rw [empty] at parsed + simp [CausalGame.opening,CausalGame.visibleBatches,CausalGame.checkReplies] at parsed + +/-- The only acceptance computation: actual parsed rows, literal transmitted +sumcheck coefficients, native caller weight/target and native saved contexts. +No extracted oracle, dense weight table, or unmetered hash is evaluated here. -/ +def finish (ctx : RawWHIRKeys.Context) (Q cap : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) (state : WireState packet.val.profile) + (history : List (Sigma (RawOracleCoupling.Concrete.GroupAnswer ctx Q))) + (nativeShapes : SuccinctRingWeight.FamilyShape (ParameterBounds.config packet.val.profile).logN request.claims.family ∧ + ∀ point ∈ request.claims.points.toList, SuccinctPointWeight.Shape (ParameterBounds.config packet.val.profile).logN point) + (claimShapes : ∀ (seed : RingPCSGame.Prefix) (lambda : E), + let c := ParameterBounds.config packet.val.profile + let claims := RingPCSGame.transformedClaims (2^c.logN) request.claims.family request.claims.points seed + (claims.all (fun claim => Protocol.shapeValid c request.lanes claim.weight) = true) ∧ + Protocol.shapeValid c request.lanes (CausalGame.batchClaims (2^c.logN) claims lambda).weight = true) : + Option (Verified ctx Q cap packet) := + match initial : state.initial with + | none => none + | some (seed,lambda) => + let c := ParameterBounds.config packet.val.profile + let ch := CausalGame.challenges c state.tape + match parsed : CausalGame.opening c ch state.replies with + | .error _ => none + | .ok proof => + match accepted : WHIRNativeArithmetic.sourceVerify request.claims.family request.claims.points seed lambda + c ch request.lanes proof with + | .error _ => none + | .ok () => some ⟨request,state,history,nativeShapes, + ⟨(seed,lambda),proof,initial,parsed,accepted,claimShapes seed lambda⟩⟩ + +def sourceBudget (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) : Nat := + WHIRModeFinal.callerCost (WHIRModeFinal.callerPositions ctx Q packet) + + packetsBudget ctx Q packet.val.profile (RawOracleCoupling.Concrete.completion ctx Q packet) + (completion_profiles ctx Q packet) + +/-- One complete honest PCS verification. The base root is announced before +caller outputs; original claims are decoded only after those outputs; each +later commitment is announced at its scalar read. Merkle and nonce calls are +part of this same interaction and this same all-path resource certificate. -/ +def verifySource (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q lanes : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (proofs : Array PrunedMerklePaths) : + WHIRSourceChronology.Source cap (Option (Verified ctx Q cap packet)) := + let entry := RawWHIRKeys.entry ctx packet.val + match WHIRCallerClaims.initialRoot model.layout entry with + | none => .done none + | some root => + .commit root (readCallerInputs ctx Q packet (WHIRModeFinal.callerPositions ctx Q packet) (fun _ => none) + (fun answers => + match decoded : WHIRCallerClaims.decodeAvailableRequest cap packet.val.profile lanes model.layout entry answers with + | none => .done none + | some request => + .claims packet.val.profile entry request + (readPhysicalPackets ctx stack Q packet.val.profile request.lanes proofs none + (RawOracleCoupling.Concrete.completion ctx Q packet) (completion_profiles ctx Q packet) + (initialWireState packet.val.profile root) + (fun state history => .done (finish ctx Q cap packet request state history + (WHIRCallerSupport.decodeAvailableRequest_nativeShapes model cap packet.val.profile lanes entry answers request decoded) + (WHIRCallerSupport.decodeAvailableRequest_shapes model cap packet.val.profile lanes entry answers request decoded)))))) + +theorem verifySource_counted (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q lanes : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (proofs : Array PrunedMerklePaths) : + WHIRSourceChronology.Counts (sourceBudget ctx Q packet) + (verifySource cap model ctx stack Q lanes packet proofs) := by + unfold verifySource + dsimp only + split + · trivial + · change WHIRSourceChronology.Counts _ (readCallerInputs _ _ _ _ _ _) + apply readCallerInputs_counted + intro answers + split + · trivial + · change WHIRSourceChronology.Counts _ (readPhysicalPackets _ _ _ _ _ _ _ _ _ _ _) + apply readPhysicalPackets_counted ctx stack Q packet.val.profile + _ proofs none _ (completion_profiles ctx Q packet) _ _ 0 + intro state history + trivial + +end Whir.WHIRPhysicalVerifier diff --git a/verification/whir/Whir/WHIRQueryOracleRecurrence.lean b/verification/whir/Whir/WHIRQueryOracleRecurrence.lean new file mode 100644 index 000000000..659821653 --- /dev/null +++ b/verification/whir/Whir/WHIRQueryOracleRecurrence.lean @@ -0,0 +1,638 @@ +import Whir.WHIRPhysicalHistory +import Whir.WHIRPhysicalVerifier + +/-! Exact query-oracle provenance. Query authentication reads the incoming raw +commitment, not a weight-batched or folded replacement. Its folded interpretation +uses the actual challenge prefix, reversing/padding only the initial top lanes. +Root slots are extracted from the actual scalar decoder, including its failures; +no row-agreement or decoder-correctness certificate is an input. + +Consumers use `queryRows_zero` for the original root and +`queryRows_decoded_rootLog` for later levels. The latter derives the digest at +compressed chronological index `i-1` from successful physical scalar parsing and +scheduled syntax, including its availability. `rootLog_cons` connects this pure +log to a physical commitment trace; `foldedOracle_step` gives its separate +challenge-by-challenge algebraic interpretation. -/ +namespace Whir.WHIRQueryOracleRecurrence +open Concrete Protocol CausalGame CausalProbability CausalExecution +open CausalStateCausality CausalPositions ParameterBounds +open FiatShamirGame (Digest32) +open WHIRHistory (Pending) + +/-- Folding updates only the algebraic state; authentication retains the root. -/ +theorem foldStep_oracle (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (j : Nat) (s : CheckedState) : (foldStep block cs p j s).oracle = s.oracle := rfl + +theorem foldSteps_oracle (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (count start : Nat) (s : CheckedState) : + (runSteps (foldStep block cs p) count start s).oracle = s.oracle := by + induction count generalizing start s with + | zero => rfl + | succ count ih => exact ih (start + 1) (foldStep block cs p start s) + +theorem foldAt_oracle (input : Public) (strategy : Strategy) (t : Tape input.config) + (i j : Nat) : (foldAt input strategy t i j).oracle = (levelAt input strategy t i).oracle := + foldSteps_oracle _ _ _ _ _ _ + +/-- OOD and query weight batching cannot affect the next commitment projection, +even when query derivation fails and the total kernel uses its empty default. -/ +theorem next_oracle (c : Config) (ch : Challenges) (p : Opening) + (i : Nat) (s : CheckedState) : + (next c ch p i s).oracle = p.levels[i]!.nextOracle.getD #[] := rfl + +theorem levelAt_zero_oracle (input : Public) (strategy : Strategy) (t : Tape input.config) : + (levelAt input strategy t 0).oracle = liftRoot input.root := rfl + +theorem levelAt_succ_oracle (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Nat) : (levelAt input strategy t (i + 1)).oracle = + (proof input strategy t).levels[i]!.nextOracle.getD #[] := by + rw [levelAt_succ, next_oracle] + +/-- The boundary root lives at the actual final fold response, not the OOD or +query-introduction slot. The absent/zero-fold/final-level branch is literal none. -/ +theorem proof_nextOracle_slot (input : Public) (replies : Array Reply) + (t : Tape input.config) (i : Fin input.config.folds.size) : + (proof input (CausalStrategy.indexedStrategy replies) t).levels[i.val]!.nextOracle = + if i.val + 1 < input.config.folds.size ∧ 0 < input.config.folds[i.val]! then + rootField replies[levelStart (challenges input.config t) i.val + input.config.folds[i.val]! - 1]! + else none := by + rw [proof_level] + dsimp only [decodedLevel] + simp only [challenge_folds_size] + split_ifs with guard + · let j : Fin input.config.folds[i.val]! := ⟨input.config.folds[i.val]! - 1, by omega⟩ + have member : Coordinate.fold i j ∈ visibleCoordinates input.config := by + apply List.mem_append_left + apply List.mem_append_right + apply List.mem_flatMap.mpr + refine ⟨i.val, List.mem_range.mpr i.isLt, ?_⟩ + unfold levelCoordinates + rw [dite_eq_left i.isLt] + exact List.mem_append_left _ (List.mem_append_left _ (List.mem_ofFn.mpr ⟨j, rfl⟩)) + have bound : position (.fold i j) < + (visibleBatches input.config t.1 (challenges input.config t)).length := by + rw [← visibleCoordinates_map, List.length_map] + exact List.idxOf_lt_length_iff.mpr member + rw [position_fold] at bound + have index : levelStart (challenges input.config t) i.val + j.val = + levelStart (challenges input.config t) i.val + input.config.folds[i.val]! - 1 := by + dsimp [j]; omega + rw [index] at bound + simp only [List.getElem!_toArray] + rw [CausalStrategy.indexed_response _ _ [] _ _ bound] + simp only [List.length_nil, Nat.zero_add] + · rfl + +theorem levelAt_succ_rootSlot (input : Public) (replies : Array Reply) + (t : Tape input.config) (i : Fin input.config.folds.size) : + (levelAt input (CausalStrategy.indexedStrategy replies) t (i.val + 1)).oracle = + (if i.val + 1 < input.config.folds.size ∧ 0 < input.config.folds[i.val]! then + rootField replies[levelStart (challenges input.config t) i.val + input.config.folds[i.val]! - 1]! + else none).getD #[] := by + rw [levelAt_succ_oracle, proof_nextOracle_slot] + +/-- Association with a typed last-fold position, independent of challenge values. -/ +theorem levelAt_succ_lastFold (input : Public) (replies : Array Reply) + (t : Tape input.config) (i : Fin input.config.folds.size) + (j : Fin input.config.folds[i.val]!) (last : j.val + 1 = input.config.folds[i.val]!) + (hasNext : i.val + 1 < input.config.folds.size) : + (levelAt input (CausalStrategy.indexedStrategy replies) t (i.val + 1)).oracle = + (rootField replies[position (.fold i j)]!).getD #[] := by + rw [levelAt_succ_rootSlot, ite_eq_left ⟨hasNext, by omega⟩, position_fold i j t] + have index : levelStart (challenges input.config t) i.val + input.config.folds[i.val]! - 1 = + levelStart (challenges input.config t) i.val + j.val := by omega + rw [index] + +/-- Query rows are sampled from the original base root at L0. -/ +theorem queryRows_zero {p : Profile} (r : WHIRReplay.Replay p) + (i : Fin (config p).folds.size) (zero : i.val = 0) (x : Sample (.query i)) : + WHIRReplay.queryRows r i x = + (QueryBatchSoundness.queries (remaining (config p) i + (config p).rates[i.val]!) + (config p).queries[i.val]! x.1).map (fun q => (liftRoot r.statement.input.root)[q]!) := by + unfold WHIRReplay.queryRows + simp only [zero, levelAt_zero_oracle] + +/-- Later query rows use exactly the previous level's decoded boundary root. -/ +theorem queryRows_succ {p : Profile} (r : WHIRReplay.Replay p) + (i previous : Fin (config p).folds.size) (succ : i.val = previous.val + 1) + (j : Fin (config p).folds[previous.val]!) + (last : j.val + 1 = (config p).folds[previous.val]!) (x : Sample (.query i)) : + WHIRReplay.queryRows r i x = + (QueryBatchSoundness.queries (remaining (config p) i + (config p).rates[i.val]!) + (config p).queries[i.val]! x.1).map + (fun q => ((rootField r.replies[position (.fold previous j)]!).getD #[])[q]!) := by + unfold WHIRReplay.queryRows + have h := levelAt_succ_lastFold r.statement.input r.replies r.tape previous j last + (show previous.val + 1 < (config p).folds.size by have := i.isLt; omega) + simp only [← succ] at h + rw [h] + +/-- Folded interpretation of an incoming commitment. L0 uses reversed padded +lanes; later commitments use low-lane folding without that reversal. -/ +def foldedOracle (input : Public) (strategy : Strategy) (t : Tape input.config) + (i j : Nat) {N : Nat} : Fin (2 ^ (input.config.folds[i]! - j)) → Fin N → E := + OracleReplay.oracleAt (i == 0) input.config.folds[i]! + (levelAt input strategy t i).oracle (challenges input.config t).levels[i]!.folds j + +theorem foldedOracle_zero (input : Public) (strategy : Strategy) (t : Tape input.config) + (j : Nat) {N : Nat} : foldedOracle input strategy t 0 j (N := N) = + OracleReplay.oracleAt true input.config.folds[0]! (liftRoot input.root) + (challenges input.config t).levels[0]!.folds j := rfl + +theorem foldedOracle_succ (input : Public) (strategy : Strategy) (t : Tape input.config) + (i j : Nat) {N : Nat} : foldedOracle input strategy t (i + 1) j (N := N) = + OracleReplay.oracleAt false input.config.folds[i + 1]! + ((proof input strategy t).levels[i]!.nextOracle.getD #[]) + (challenges input.config t).levels[i + 1]!.folds j := by + have base : (i + 1 == 0) = false := by simp + simp only [foldedOracle, base, levelAt_succ_oracle] + +theorem foldedOracle_step (input : Public) (strategy : Strategy) (t : Tape input.config) + (i j : Nat) (hj : j < input.config.folds[i]!) {N : Nat} : + foldedOracle input strategy t i (j + 1) (N := N) = + CandidateFolding.foldOracle + (OracleReplay.pairedOracle (i == 0) input.config.folds[i]! + (levelAt input strategy t i).oracle (challenges input.config t).levels[i]!.folds j hj) + (challenges input.config t).levels[i]!.folds[j]! := + OracleReplay.oracleAt_succ _ _ _ _ _ _ + +/-- Successful scalar parsing fixes the ghost root to the actual digest callback. +Every malformed scalar branch remains rejected by the premise. -/ +theorem decodeReplyScalars_root {c : Config} (q : Coordinate c) + (lookup : Digest32 → Oracle) (rows : Oracle) (xs : List E) (response : Reply) + (parsed : WHIRHistory.decodeReplyScalars q lookup rows xs = some response) : + rootField response = (WHIRPhysicalVerifier.absorbedRoot q xs).map lookup := by + cases q with + | initial => + simp only [WHIRHistory.decodeReplyScalars] at parsed + obtain ⟨m, _, rfl⟩ := Option.map_eq_some_iff.mp parsed + rfl + | query i => + simp only [WHIRHistory.decodeReplyScalars] at parsed + obtain ⟨m, _, rfl⟩ := Option.map_eq_some_iff.mp parsed + rfl + | tail j => + simp only [WHIRHistory.decodeReplyScalars] at parsed + obtain ⟨m, _, rfl⟩ := Option.map_eq_some_iff.mp parsed + rfl + | ood i j => + cases xs with + | nil => cases parsed + | cons a xs => cases xs with + | nil => cases parsed + | cons b xs => cases xs with + | nil => cases parsed + | cons d xs => cases xs with + | nil => cases parsed; rfl + | cons e xs => cases parsed + | fold i j => + cases xs with + | nil => cases parsed + | cons a xs => cases xs with + | nil => cases parsed + | cons b rest => + simp only [WHIRHistory.decodeReplyScalars] at parsed + by_cases last : j.val + 1 = c.folds[i.val]! + · by_cases hasNext : i.val + 1 < c.folds.size + · simp only [last, hasNext, ↓reduceIte] at parsed + cases rest with + | nil => cases parsed + | cons r rest => cases rest with + | nil => cases parsed + | cons s rest => cases rest with + | cons d rest => cases parsed + | nil => + obtain ⟨digest, decoded, rfl⟩ := Option.map_eq_some_iff.mp parsed + simp [WHIRPhysicalVerifier.absorbedRoot, last, hasNext, decoded, rootField] + · simp only [last, hasNext, ↓reduceIte] at parsed + split at parsed + · cases parsed + simp [rootField, WHIRPhysicalVerifier.absorbedRoot, hasNext] + · cases parsed + · simp only [last, ↓reduceIte] at parsed + split at parsed + · cases parsed + simp only [rootField, WHIRPhysicalVerifier.absorbedRoot, last, false_and, + ↓reduceIte, Option.map_none] + · cases parsed + +/-- Chronological response slots, retaining non-root slots as `none`. Each digest +is read from the scalar message at its preceding canonical challenge coordinate. -/ +def rootSlots (p : Profile) (roots : WHIRReplay.Roots) (s : Digest32) : + List Pending → Array (Option Oracle) + | m :: previous :: older => + let q := WHIRReplay.query p (s, previous :: older) + (rootSlots p roots s (previous :: older)).push + ((WHIRPhysicalVerifier.absorbedRoot q m.scalars).map + (fun digest => roots digest (WHIRHistory.coordinateLevel q + 1))) + | _ => #[] + +/-- Actual physical decoding fixes every root position independently of supplied +query rows. All syntax, phase, nonce and position checks are still executed. -/ +theorem decodeHistory_rootSlots (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) : + out.replies.map rootField = rootSlots p roots s messages := by + induction messages generalizing ancestors out with + | nil => cases parsed + | cons m messages ih => + cases messages with + | nil => + cases ancestors with + | cons a ancestors => cases parsed + | nil => + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · cases found : catalog s with + | none => simp [found] at parsed + | some statement => + simp [found] at parsed + subst out + simp [rootSlots] + · cases parsed + | cons previous older => + cases ancestors with + | nil => cases parsed + | cons a past => + rcases a with ⟨previous', q, x⟩ + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · split at parsed + · rename_i phase + split at parsed + · split at parsed + · split at parsed + · cases prior : WHIRPhysicalHistory.decodeHistory p catalog roots rows s + (previous :: older) past with + | none => simp [prior] at parsed + | some before => + simp only [prior, WHIRPhysicalHistory.step] at parsed + obtain ⟨response, decoded, rfl⟩ := Option.map_eq_some_iff.mp parsed + rw [Array.map_push, ih past before prior] + have hr := decodeReplyScalars_root q _ _ _ response decoded + simp only [rootSlots] + rw [hr, phase] + · cases parsed + · cases parsed + · cases parsed + · cases parsed + · cases parsed + +/-- Pointwise scalar root-slot association, including absent response defaults. -/ +theorem decodeHistory_rootField (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) + (n : Nat) : + rootField out.replies[n]! = (rootSlots p roots s messages)[n]! := by + have mapped := decodeHistory_rootSlots p catalog roots rows s messages ancestors out parsed + rw [← mapped] + by_cases hn : n < out.replies.size + · simp [getElem!_pos, hn] + · have hm : ¬ n < (out.replies.map rootField).size := by + simpa only [Array.size_map] using hn + rw [getElem!_neg out.replies n hn, getElem!_neg (out.replies.map rootField) n hm] + rfl + +/-- End-to-end later query projection from successful physical scalar decoding. +The physical root log only needs to identify the displayed canonical scalar slot. -/ +theorem queryRows_decoded_succ (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) + (i previous : Fin (config p).folds.size) (succ : i.val = previous.val + 1) + (j : Fin (config p).folds[previous.val]!) + (last : j.val + 1 = (config p).folds[previous.val]!) (x : Sample (.query i)) : + WHIRReplay.queryRows out i x = + (QueryBatchSoundness.queries (remaining (config p) i + (config p).rates[i.val]!) + (config p).queries[i.val]! x.1).map + (fun q => (((rootSlots p roots s messages)[position (.fold previous j)]!).getD #[])[q]!) := by + rw [queryRows_succ out i previous succ j last x, + decodeHistory_rootField p catalog roots rows s messages ancestors out parsed] + +/-- The only schedule positions carrying a next-root digest. -/ +def rootCoordinate {c : Config} : Coordinate c → Bool + | .fold i j => decide (j.val + 1 = c.folds[i.val]! ∧ i.val + 1 < c.folds.size) + | _ => false + +/-- Raw digests, in chronological response-slot order, before compression. -/ +def digestSlots (p : Profile) (s : Digest32) : List Pending → List (Option Digest32) + | m :: previous :: older => + digestSlots p s (previous :: older) ++ + [WHIRPhysicalVerifier.absorbedRoot (WHIRReplay.query p (s,previous :: older)) m.scalars] + | _ => [] + +/-- The canonical transmitted-root log excludes the original public root. -/ +def rootLog (p : Profile) (s : Digest32) (messages : List Pending) : List Digest32 := + (digestSlots p s messages).filterMap id + +theorem rootLog_cons (p : Profile) (s : Digest32) (m previous : Pending) (older : List Pending) : + rootLog p s (m :: previous :: older) = rootLog p s (previous :: older) ++ + (WHIRPhysicalVerifier.absorbedRoot (WHIRReplay.query p (s,previous :: older)) m.scalars).toList := by + simp only [rootLog, digestSlots, List.filterMap_append] + cases WHIRPhysicalVerifier.absorbedRoot (WHIRReplay.query p (s,previous :: older)) m.scalars <;> rfl + +private theorem level_root_count (c : Config) (i : Fin c.folds.size) + (positive : 0 < c.folds[i.val]!) (hasNext : i.val + 1 < c.folds.size) : + (levelCoordinates c i.val).countP rootCoordinate = 1 := by + let last : Fin c.folds[i.val]! := ⟨c.folds[i.val]! - 1, by omega⟩ + have folds : (List.ofFn (Coordinate.fold i)).countP rootCoordinate = 1 := by + rw [List.ofFn_eq_map, List.countP_map] + have same : (List.finRange c.folds[i.val]!).countP (rootCoordinate ∘ Coordinate.fold i) = + (List.finRange c.folds[i.val]!).count last := by + rw [List.count_eq_countP] + apply List.countP_congr + intro j _ + simp only [Function.comp_apply, rootCoordinate, decide_eq_true_eq, beq_iff_eq, Fin.ext_iff] + dsimp [last] + omega + rw [same] + exact List.count_eq_one_of_mem (List.nodup_finRange _) (List.mem_finRange last) + have oods : (List.ofFn (Coordinate.ood i)).countP rootCoordinate = 0 := by + apply List.countP_eq_zero.mpr + intro q hq + obtain ⟨j, rfl⟩ := List.mem_ofFn.mp hq + simp only [rootCoordinate, Bool.false_eq_true, not_false_eq_true] + unfold levelCoordinates + rw [dite_eq_left i.isLt] + simp only [List.countP_append, folds, oods, List.countP_singleton, rootCoordinate, + Bool.false_eq_true, ↓reduceIte, Nat.add_zero] + +/-- Before any fold at level i, exactly i earlier boundary digests have occurred. +Only positivity of earlier fold counts is needed; no acceptance premise is used. -/ +theorem schedule_root_count_fold (c : Config) (i : Fin c.folds.size) + (j : Fin c.folds[i.val]!) (positive : ∀ k, k < i.val → 0 < c.folds[k]!) : + ((WHIRHistory.schedule c).take (position (.fold i j))).countP rootCoordinate = i.val := by + let t : Tape c := (coordinates c).symm (fun _ => 0) + let prior := (List.range i.val).flatMap (levelCoordinates c) + let pre := [Coordinate.initial (c := c)] ++ prior + let folds := List.ofFn (Coordinate.fold i) + let rest := List.ofFn (Coordinate.ood i) ++ [.query i] ++ + ((List.range (c.folds.size - (i.val + 1))).map (fun x => i.val + 1 + x)).flatMap + (levelCoordinates c) ++ + (List.ofFn fun k : Fin (c.logN - c.folds.toList.sum - 1) => + Coordinate.tail ⟨k.val, by omega⟩) ++ WHIRHistory.hiddenTail c + have range : List.range c.folds.size = List.range i.val ++ [i.val] ++ + (List.range (c.folds.size - (i.val + 1))).map (fun x => i.val + 1 + x) := by + calc + List.range c.folds.size = + List.range ((i.val + 1) + (c.folds.size - (i.val + 1))) := + congrArg List.range (by omega) + _ = _ := by rw [List.range_add, List.range_succ] + have schedule : WHIRHistory.schedule c = pre ++ (folds ++ rest) := by + simp only [WHIRHistory.schedule, visibleCoordinates, range, List.flatMap_append, + List.flatMap_singleton, pre, prior, folds, rest, levelCoordinates, i.isLt, + dite_true, List.append_assoc] + have lengths : prior.length = ((List.range i.val).flatMap (levelBatches (challenges c t))).length := by + rw [← List.length_map (f := fun q => batch q (get q t))] + simp only [prior, List.map_flatMap] + congr 1 + apply List.flatMap_congr + intro k hk + exact levelCoordinates_map c t k (lt_trans (List.mem_range.mp hk) i.isLt) + have index : position (.fold i j) = pre.length + j.val := by + rw [position_fold i j t] + simp only [pre, List.length_append, List.length_singleton, lengths, levelStart] + have taken : (WHIRHistory.schedule c).take (position (.fold i j)) = pre ++ folds.take j.val := by + rw [schedule, index, List.take_length_add_append, + List.take_append_of_le_length (by simpa [folds] using j.isLt.le)] + have foldCount : (folds.take j.val).countP rootCoordinate = 0 := by + apply List.countP_eq_zero.mpr + intro q hq + obtain ⟨k, hk, rfl⟩ := List.mem_iff_getElem.mp hq + have before : k < j.val := lt_of_lt_of_le hk (List.length_take_le _ _) + simp only [folds, List.getElem_take, List.getElem_ofFn, rootCoordinate, decide_eq_true_eq] + omega + have priorCount : prior.countP rootCoordinate = i.val := by + dsimp only [prior] + rw [List.countP_flatMap] + have same : (List.range i.val).map (List.countP rootCoordinate ∘ levelCoordinates c) = + (List.range i.val).map (fun _ => 1) := by + apply List.map_congr_left + intro k hk + have hk' := List.mem_range.mp hk + exact level_root_count c ⟨k, by omega⟩ (positive k hk') + (show k + 1 < c.folds.size by omega) + rw [same] + simp + rw [taken, List.countP_append, foldCount] + simp only [pre, List.countP_append, List.countP_singleton, rootCoordinate, + Bool.false_eq_true, ↓reduceIte, priorCount, Nat.zero_add, Nat.add_zero] + +theorem digestSlots_length (p : Profile) (s : Digest32) (messages : List Pending) : + (digestSlots p s messages).length = messages.length - 1 := by + induction messages with + | nil => rfl + | cons m messages ih => + cases messages with + | nil => rfl + | cons previous older => simp [digestSlots, ih] + +theorem rootSlots_toList (p : Profile) (roots : WHIRReplay.Roots) (s : Digest32) + (messages : List Pending) : + (rootSlots p roots s messages).toList = + (digestSlots p s messages).mapIdx (fun n d => d.map (fun digest => + roots digest (WHIRHistory.coordinateLevel + (((WHIRHistory.schedule (config p))[n]?).getD .initial) + 1))) := by + induction messages with + | nil => rfl + | cons m messages ih => + cases messages with + | nil => rfl + | cons previous older => + simp [rootSlots, digestSlots, Array.toList_push, List.mapIdx_append, ih, + digestSlots_length, WHIRReplay.query, WHIRHistory.queryFor] + +theorem decodeReplyScalars_root_present {c : Config} (q : Coordinate c) + (lookup : Digest32 → Oracle) (rows : Oracle) (xs : List E) (response : Reply) + (parsed : WHIRHistory.decodeReplyScalars q lookup rows xs = some response) : + (WHIRPhysicalVerifier.absorbedRoot q xs).isSome = rootCoordinate q := by + cases q with + | initial => rfl + | query i => rfl + | tail j => rfl + | ood i j => rfl + | fold i j => + by_cases boundary : j.val + 1 = c.folds[i.val]! ∧ i.val + 1 < c.folds.size + · obtain ⟨last, hasNext⟩ := boundary + cases xs with + | nil => cases parsed + | cons a xs => cases xs with + | nil => cases parsed + | cons b rest => + simp only [WHIRHistory.decodeReplyScalars, last, hasNext, ↓reduceIte] at parsed + cases rest with + | nil => cases parsed + | cons r rest => cases rest with + | nil => cases parsed + | cons s rest => cases rest with + | cons d rest => cases parsed + | nil => + obtain ⟨digest, decoded, _⟩ := Option.map_eq_some_iff.mp parsed + simp [WHIRPhysicalVerifier.absorbedRoot, last, hasNext, decoded, rootCoordinate] + · simp only [WHIRPhysicalVerifier.absorbedRoot, boundary, ↓reduceIte, + Option.isSome_none, rootCoordinate, decide_false] + +/-- Successful parsing fills every scheduled boundary digest, and no other slot. +This retains rejected hash encodings rather than silently filtering failures. -/ +theorem decodeHistory_digest_shape (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) : + (digestSlots p s messages).map Option.isSome = + ((WHIRHistory.schedule (config p)).take (messages.length - 1)).map rootCoordinate := by + induction messages generalizing ancestors out with + | nil => cases parsed + | cons m messages ih => + cases messages with + | nil => simp [digestSlots] + | cons previous older => + cases ancestors with + | nil => cases parsed + | cons a past => + rcases a with ⟨previous', q, x⟩ + simp only [WHIRPhysicalHistory.decodeHistory] at parsed + split at parsed + · split at parsed + · rename_i phase + split at parsed + · rename_i previousPosition + split at parsed + · split at parsed + · cases prior : WHIRPhysicalHistory.decodeHistory p catalog roots rows s + (previous :: older) past with + | none => simp [prior] at parsed + | some before => + simp only [prior, WHIRPhysicalHistory.step] at parsed + obtain ⟨response, decoded, _⟩ := Option.map_eq_some_iff.mp parsed + have present := decodeReplyScalars_root_present q _ _ _ response decoded + have slot := WHIRHistory.schedule_get_position q + rw [previousPosition] at slot + simp only [digestSlots, List.map_append, List.map_cons, List.map_nil, + ← phase, present, ih past before prior, List.length_cons, + Nat.add_sub_cancel, List.take_add_one, slot, Option.toList_some] + · cases parsed + · cases parsed + · cases parsed + · cases parsed + · cases parsed + +private theorem filterMap_rank {A : Type*} (xs : List (Option A)) (n : Nat) (x : A) + (found : xs[n]? = some (some x)) : + (xs.filterMap id)[((xs.take n).filterMap id).length]? = some x := by + induction xs generalizing n with + | nil => cases found + | cons a xs ih => + cases n with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at found + subst a + rfl + | succ n => + simp only [List.getElem?_cons_succ] at found + have tail := ih n found + cases a <;> simpa [List.filterMap_cons, List.take_succ_cons] using tail + +/-- The canonical compressed digest at index i is precisely the last-fold root +slot of level i. Availability and positive earlier fold counts are schedule/shape +facts, not oracle-agreement premises. The conclusion also proves log availability. -/ +theorem decoded_rootLog_slot (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) + (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) + (last : j.val + 1 = (config p).folds[i.val]!) (hasNext : i.val + 1 < (config p).folds.size) + (positive : ∀ k, k < i.val → 0 < (config p).folds[k]!) + (available : position (.fold i j) < messages.length - 1) : + ∃ digest, (rootLog p s messages)[i.val]? = some digest ∧ + rootField out.replies[position (.fold i j)]! = some (roots digest (i.val + 1)) := by + let n := position (.fold i j) + have shape := decodeHistory_digest_shape p catalog roots rows s messages ancestors out parsed + have slot := WHIRHistory.schedule_get_position (Coordinate.fold i j) + have flag : ((digestSlots p s messages)[n]?).map Option.isSome = some true := by + rw [← List.getElem?_map, shape, List.getElem?_map, + List.getElem?_take_of_lt available, slot] + simp [rootCoordinate, last, hasNext] + cases found : (digestSlots p s messages)[n]? with + | none => simp [found] at flag + | some d => + cases d with + | none => simp [found] at flag + | some digest => + have rank := filterMap_rank (digestSlots p s messages) n digest found + have count : ((digestSlots p s messages).take n).countP Option.isSome = i.val := by + have taken := congrArg (List.take n) shape + rw [← List.map_take, ← List.map_take, List.take_take, Nat.min_eq_left available.le] at taken + have counts := congrArg (List.count true) taken + have hb : ∀ b : Bool, (b == true) = b := by intro b; cases b <;> rfl + simp only [List.count_eq_countP, List.countP_map, Function.comp_def, hb] at counts + rw [counts] + exact schedule_root_count_fold (config p) i j positive + simp only [List.length_filterMap_eq_countP, id_eq, count] at rank + refine ⟨digest, rank, ?_⟩ + rw [decodeHistory_rootField p catalog roots rows s messages ancestors out parsed] + have rootAt : (rootSlots p roots s messages).toList[n]? = + some (some (roots digest (i.val + 1))) := by + rw [rootSlots_toList, List.getElem?_mapIdx, found] + simp only [n, slot, Option.getD_some, WHIRHistory.coordinateLevel, Option.map_some] + simpa only [Array.getElem!_toList] using List.getElem!_of_getElem? rootAt + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- A checked finite-family shape fact, not an oracle or decoder hypothesis. -/ +theorem production_folds_positive : + ∀ p : Profile, ∀ i : Fin (config p).folds.size, 0 < (config p).folds[i.val]! := by + decide +kernel + +/-- The complete later-level query endpoint: the scalar history itself supplies +the digest at compressed log index i-1. Scheduled syntax and successful parsing +discharge phase availability; no root-position association is assumed. -/ +theorem queryRows_decoded_rootLog (p : Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (s : Digest32) + (messages : List Pending) (ancestors : List (Pending × Sigma (@Sample (config p)))) + (out : WHIRReplay.Replay p) + (parsed : WHIRPhysicalHistory.decodeHistory p catalog roots rows s messages ancestors = some out) + (scheduled : WHIRHistory.scheduledAdmissible (config p) messages = true) + (i : Fin (config p).folds.size) (phase : WHIRReplay.query p (s,messages) = .query i) + (later : 0 < i.val) (x : Sample (.query i)) : + ∃ digest, (rootLog p s messages)[i.val - 1]? = some digest ∧ + WHIRReplay.queryRows out i x = + (QueryBatchSoundness.queries (remaining (config p) i + (config p).rates[i.val]!) + (config p).queries[i.val]! x.1).map (fun q => (roots digest i.val)[q]!) := by + have nonempty : messages ≠ [] := by + intro empty + subst messages + cases parsed + have depth := WHIRHistory.scheduledAdmissible_depth (config p) messages scheduled + let cursor : Fin (WHIRHistory.depth (config p)) := + ⟨messages.length - 1, by have := List.length_pos_iff.mpr nonempty; omega⟩ + have current : position (.query i) = messages.length - 1 := by + rw [← phase] + change position (WHIRHistory.queryFor (config p) (s,messages)) = _ + rw [WHIRHistory.queryFor_at (config p) s messages cursor + (by dsimp [cursor]; have := List.length_pos_iff.mpr nonempty; omega)] + exact WHIRHistory.position_schedule_get (config p) cursor + let previous : Fin (config p).folds.size := ⟨i.val - 1, by omega⟩ + have succ : i.val = previous.val + 1 := by dsimp [previous]; omega + have positive := production_folds_positive p previous + let j : Fin (config p).folds[previous.val]! := ⟨(config p).folds[previous.val]! - 1, by omega⟩ + have last : j.val + 1 = (config p).folds[previous.val]! := by dsimp [j]; omega + have available : position (.fold previous j) < messages.length - 1 := by + rw [← current, position_fold previous j out.tape, position_query i out.tape] + have growth := CausalRefinement.levelStart_succ (challenges (config p) out.tape) previous.val + rw [← succ, challenge_folds_size] at growth + omega + obtain ⟨digest, found, root⟩ := decoded_rootLog_slot p catalog roots rows s messages ancestors + out parsed previous j last (by rw [← succ]; exact i.isLt) + (fun k hk => production_folds_positive p ⟨k, by omega⟩) available + refine ⟨digest, found, ?_⟩ + rw [queryRows_succ out i previous succ j last x, root] + simp only [Option.getD_some, ← succ] + +end Whir.WHIRQueryOracleRecurrence diff --git a/verification/whir/Whir/WHIRRealSimulator.lean b/verification/whir/Whir/WHIRRealSimulator.lean new file mode 100644 index 000000000..e18fe2633 --- /dev/null +++ b/verification/whir/Whir/WHIRRealSimulator.lean @@ -0,0 +1,192 @@ +import Whir.DuplexPublicSimulator +import Whir.WHIRModeFinal + +/-! Deterministic realization of the chosen public simulator. Both the fallback +seed and the raw table below depend on the same compression oracle. This is a +semantic bridge, not an independent-seed probabilistic coupling. The evaluator +covers arbitrary complete extracted names, including chosen seed CVs and names +outside the admissible WHIR coordinate submode. `real_ideal_view` exposes only +the existing public view; `answer_real` also supplies the private log invariant +needed for induction. Neither theorem excludes compression collisions: the +chosen predecessor's actual `Complete`/`Tree`/`extract` witness suffices. -/ +namespace Whir.WHIRRealSimulator +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator + +/-- Evaluate the terminal-first extracted representation from its leaf upward. +Malformed or mismatched tails have a fixed zero value; no parser acceptance is +changed, and the simulator still uses its existing recognition checks. -/ +def evalRaw (C : PrimitiveOracle) : + List (Option Digest32 × Block64) → List (UInt64 × Bool) → Digest32 + | (leaf, block) :: message, (tweak, last) :: template => + C ⟨leaf.getD (evalRaw C message template), block, tweak, last⟩ + | _, _ => fun _ => 0 + +/-- The canonical deterministic raw table, not a sampled random oracle. -/ +def rawTable (Q : Nat) (C : PrimitiveOracle) (key : RawKey Q) : Digest32 := + evalRaw C (expandKey key).message (expandKey key).template + +theorem evalRaw_tree (C : PrimitiveOracle) {cv : Digest32} {ns : List Node} + (tree : Tree (compressionOf C) cv ns) : + evalRaw C (ns.map payload) (ns.map (fun n => (n.tweak,n.last))) = cv := by + induction tree with + | seed n hs => simp [evalRaw, payload, hs, nodeValue, compressionOf] + | step n ns hi child ih => + have hn : ¬isSeed n := fun hs => seed_not_internal hs hi + simp [evalRaw, payload, hn, ih, nodeValue, compressionOf] + +theorem evalRaw_complete (C : PrimitiveOracle) {input : Node} {rest : List Node} + {key : Extracted} (complete : Complete (input :: rest)) + (tree : Tree (compressionOf C) input.cv rest) + (extracted : extract (input :: rest) = some key) : + evalRaw C key.message key.template = C input := by + have hc := (complete?_correct _).mpr complete + obtain ⟨t, ns, he, ht, _⟩ := complete + cases he + have hn : ¬isSeed input := terminal_not_seed ht + have hk : key = ⟨(input :: rest).map payload, + (input :: rest).map (fun n => (n.tweak,n.last))⟩ := by + simpa [extract, hc] using extracted.symm + rw [hk] + simp [evalRaw, payload, hn, evalRaw_tree C tree] + +theorem rawTable_privateKey {Q : Nat} (C : PrimitiveOracle) {log : PublicLog} + {input : Node} {key : RawKey Q} + (consistent : ∀ n d, (n,d) ∈ log → C n = d) + (recognized : privateKey Q log input = some key) : + rawTable Q C key = C input := by + obtain ⟨rest, complete, tree, extracted⟩ := + privateKey_compression recognized C consistent + exact evalRaw_complete C complete tree extracted + +theorem rawTable_construction (Q : Nat) (C : PrimitiveOracle) (iv : Digest32) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (cap : pathCost q ≤ Q) : + rawTable Q C (constructionKey Q iv q cap) = + evalCoordinate (compressionOf C) iv q := by + have he := coordinateTree_key (compressionOf C) iv q valid + have hc := coordinateTree_complete (compressionOf C) iv q valid.1 + have ht := (traceHistory_valid (compressionOf C) iv q.history valid.1).1 + have hcv : (terminalNode (traceHistory (compressionOf C) iv q.history).state.cv + q.terminal).cv = (traceHistory (compressionOf C) iv q.history).state.cv := by + cases q.terminal <;> rfl + have hv := evalRaw_complete C hc (hcv.symm ▸ ht) he + simpa [rawTable, coordinateTree, nodeValue, compressionOf, + coordinateTree_evaluates, expand_constructionKey] using + hv.trans (coordinateTree_evaluates (compressionOf C) iv q) + +/-- Log consistency is maintained even when distinct compression inputs collide. +Recognition may choose either predecessor; its actual extracted tree still +canonically evaluates to the observed terminal input's compression value. -/ +def Consistent (C : PrimitiveOracle) (state : DuplexPublicSimulator.State) : Prop := + state.seed = C ∧ ∀ n d, (n,d) ∈ state.publicLog → C n = d + +theorem answer_real (Q : Nat) (C : PrimitiveOracle) + (state : DuplexPublicSimulator.State) (input : Node) (h : Consistent C state) : + (runRO (rawTable Q C) ((simulator Q).answer state input)).1 = + (⟨C, observe state.publicLog input (C input)⟩, C input) := by + rcases h with ⟨seed, consistent⟩ + cases cached : lookup state.publicLog input with + | some d => + have hd := consistent input d (lookup_mem cached) + simp [simulator, cached, runRO, seed, hd] + | none => + cases recognized : privateKey Q state.publicLog input with + | none => simp [simulator, cached, recognized, runRO, seed] + | some key => + have hk := rawTable_privateKey C consistent recognized + simp [simulator, cached, recognized, runRO, hk, seed] + +theorem answer_consistent (Q : Nat) (C : PrimitiveOracle) + (state : DuplexPublicSimulator.State) (input : Node) (h : Consistent C state) : + Consistent C (runRO (rawTable Q C) ((simulator Q).answer state input)).1.1 := by + rw [answer_real Q C state input h] + refine ⟨rfl, ?_⟩ + intro n d member + rcases List.mem_cons.mp member with he | he + · cases he; rfl + · exact h.2 n d he + +/-- Equality of actual public views only: the ideal execution retains its own +private-query meter, which need not equal the real execution's zero meter. -/ +theorem runIdeal_view {Q : Nat} {Result : Type} (C : PrimitiveOracle) (iv : Digest32) + (state : DuplexPublicSimulator.State) (consistent : Consistent C state) + (program : Program Result) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) : + (runIdeal (simulator Q) (rawTable Q C) iv state program remaining cap counted).view = + (runReal C iv program).view := by + induction program generalizing state remaining with + | done result => rfl + | ask query next ih => + cases query with + | primitive purpose input => + have ha := answer_real Q C state input consistent + have hc := answer_consistent Q C state input consistent + have hr := ih (C input) _ hc (remaining-1) (by omega) (counted.2 _) + simp only [runIdeal, runReal, realAnswer, prepend] + simp only [ha] at hr ⊢ + exact congrArg (fun v : View Result => + View.mk (⟨.primitive purpose input,C input⟩ :: v.observations) v.result) hr + | construction q valid => + have ha := rawTable_construction Q C iv q valid (counted.1.trans cap) + have hr := ih (evalCoordinate (compressionOf C) iv q) state consistent + (remaining-pathCost q) (by omega) (counted.2 _) + simp only [runIdeal, runReal, realAnswer, prepend, ha] + exact congrArg (fun v : View Result => + View.mk (⟨.construction q valid,evalCoordinate (compressionOf C) iv q⟩ :: + v.observations) v.result) hr + +/-- Deterministic real-game realization for every counted adaptive program. +No collision-freeness or simulator-correctness premise is required. -/ +theorem real_ideal_view {Q : Nat} {Result : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program Result) (counted : Counts Q program) : + (runReal C iv program).view = + (runIdeal (simulator Q) (rawTable Q C) iv ((simulator Q).initial C) + program Q (Nat.le_refl Q) counted).view := by + exact (runIdeal_view C iv _ ⟨rfl, by simp [simulator]⟩ program Q + (Nat.le_refl Q) counted).symm + +/-- Every completed block is the same actual compression construction; this is a deterministic equality, not a uniform-table claim. -/ +theorem realPacket_ideal (ctx : RawWHIRKeys.Context) (Q : Nat) (C : PrimitiveOracle) + (packet : RawWHIRKeys.Packet ctx Q) : + WHIRModeFinal.realPacket ctx Q C packet = + WHIRModeFinal.idealPacket ctx Q (rawTable Q C) packet := by + funext block + exact (rawTable_construction Q C ctx.iv (RawWHIRKeys.coordinate ctx packet.val block.val) + (RawWHIRKeys.coordinate_admissible ctx Q ⟨packet,block⟩) + (by rw [RawWHIRKeys.pathCost_block]; exact RawWHIRKeys.packet_pathBound ctx Q packet)).symm + +theorem realHistory_ideal (ctx : RawWHIRKeys.Context) (Q : Nat) (C : PrimitiveOracle) + (packets : List (RawWHIRKeys.Packet ctx Q)) : + WHIRModeFinal.realHistory ctx Q C packets = + WHIRModeFinal.idealHistory ctx Q (rawTable Q C) packets := by + simp only [WHIRModeFinal.realHistory,WHIRModeFinal.idealHistory,realPacket_ideal] + +theorem realCallers_ideal (ctx : RawWHIRKeys.Context) (Q : Nat) (C : PrimitiveOracle) + (packet : RawWHIRKeys.Packet ctx Q) (positions : List (WHIRModeFinal.CallerPosition ctx Q packet)) : + WHIRModeFinal.realCallers ctx Q C packet positions = + WHIRModeFinal.idealCallers ctx Q (rawTable Q C) packet positions := by + unfold WHIRModeFinal.realCallers WHIRModeFinal.idealCallers + apply List.map_congr_left + intro position _ + have same := rawTable_construction Q C ctx.iv position.val + (RawWHIRKeys.callerOutput_admissible ctx Q packet position.val position.property) + (RawWHIRKeys.callerOutput_pathBound ctx Q packet position.val position.property) + change rawTable Q C (RawWHIRKeys.callerOutputKey ctx Q packet position.val position.property).val = _ at same + rw [same] + +theorem realCompletion_ideal (ctx : RawWHIRKeys.Context) (Q : Nat) (C : PrimitiveOracle) + (packet : Option (RawWHIRKeys.Packet ctx Q)) : + WHIRModeFinal.realCompletion ctx Q C packet = + WHIRModeFinal.idealCompletion ctx Q (rawTable Q C) packet := by + cases packet with + | none => rfl + | some packet => + simp only [WHIRModeFinal.realCompletion,WHIRModeFinal.idealCompletion,realCallers_ideal,realHistory_ideal] + +#print axioms evalRaw_complete +#print axioms rawTable_privateKey +#print axioms rawTable_construction +#print axioms answer_real +#print axioms answer_consistent +#print axioms runIdeal_view +#print axioms real_ideal_view +end Whir.WHIRRealSimulator diff --git a/verification/whir/Whir/WHIRSourceAllocationCache.lean b/verification/whir/Whir/WHIRSourceAllocationCache.lean new file mode 100644 index 000000000..285b8922c --- /dev/null +++ b/verification/whir/Whir/WHIRSourceAllocationCache.lean @@ -0,0 +1,145 @@ +import Whir.WHIRSourceResolver +import Whir.WHIRSourceAllocationOrigin + +namespace Whir.WHIRSourceAllocationCache +open FiatShamirGame DuplexModeGame RawOracleCoupling.Concrete +open WHIRCallerRegistry WHIRSourceChronology WHIRSourceResolver WHIRSourceRawCache +open WHIRObservableAllocations WHIRSourceAllocationOrigin + +variable {cap : Nat} {R : Type} + +private theorem recode_final_cons (registry : Public) (Q : Nat) + (resolver : WHIRCausalRawROM.Resolver (context registry) Q cap) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) + (answer : AllocationAnswer (context registry) Q key) + (rest : List (Sigma (AllocationAnswer (context registry) Q))) : + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).traceRecode state + (⟨key,answer⟩ :: rest)).2 = + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).traceRecode + ((resolver.after (WHIRCausalRawROM.prepare (context registry) rfl Q cap resolver state key).1 + key answer).state) rest).2 := by + rcases key with ⟨group,history⟩ + cases group <;> rfl + +def traceEntries (registry : Public) (Q : Nat) + (trace : List (Sigma (AllocationAnswer (context registry) Q))) : List (RawKey Q × Digest32) := + trace.reverse.flatMap (fun entry => groupEntries (context registry) Q entry.1.1 entry.2) + +/-- The finite raw cache contains exactly allocated group cells, newest allocation first. Preparing roots and claims does not add any raw reply. -/ +theorem recode_rawAnswers (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : Counts Q source) (state : CausalBindingState.State cap) + (trace : List (Sigma (AllocationAnswer (context registry) Q))) : + (((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (privateResolver registry Q seed source counted)).traceRecode state trace).2).rawAnswers Q = + traceEntries registry Q trace ++ state.rawAnswers Q := by + induction trace generalizing state with + | nil => rfl + | cons entry rest ih => + rcases entry with ⟨key,answer⟩ + rw [recode_final_cons,ih] + change traceEntries registry Q rest ++ + (addGroup (context registry) Q + (WHIRCausalRawROM.prepare (context registry) rfl Q cap + (privateResolver registry Q seed source counted) state key).1 key.1 answer).rawAnswers Q = _ + rw [addGroup_entries,privatePrepare_raw] + simp only [traceEntries,List.reverse_cons,List.flatMap_append,List.flatMap_cons, + List.flatMap_nil,List.append_nil,List.append_assoc] + +theorem traceEntries_agrees (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (trace : List (Sigma (AllocationAnswer (context registry) Q))) + (agrees : TraceAgrees registry Q ro trace) : LogAgrees ro (traceEntries registry Q trace) := by + intro raw member + obtain ⟨entry,entryMember,member⟩ := List.mem_flatMap.mp member + have answer := agrees entry (List.mem_reverse.mp entryMember) + rw [answer] at member + exact groupEntries_table (context registry) Q ro entry.1.1 raw member + +theorem recode_agrees (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) (old : LogAgrees ro (state.rawAnswers Q)) + (trace : List (Sigma (AllocationAnswer (context registry) Q))) + (agrees : TraceAgrees registry Q ro trace) : + LogAgrees ro (((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (privateResolver registry Q seed source counted)).traceRecode state trace).2.rawAnswers Q) := by + rw [recode_rawAnswers] + intro raw member + rcases List.mem_append.mp member with fresh | prior + · exact traceEntries_agrees registry Q ro trace agrees raw fresh + · exact old raw prior + +theorem recode_contains (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) (old : LogAgrees ro (state.rawAnswers Q)) + (trace : List (Sigma (AllocationAnswer (context registry) Q))) + (agrees : TraceAgrees registry Q ro trace) + (entry : Sigma (AllocationAnswer (context registry) Q)) (member : entry ∈ trace) + (raw : RawKey Q) (answer : Digest32) + (cell : (raw,answer) ∈ groupEntries (context registry) Q entry.1.1 entry.2) : + cache Q ((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (privateResolver registry Q seed source counted)).traceRecode state trace).2 raw = some answer := by + apply (cache_hit_iff Q ro _ (recode_agrees registry Q ro seed source counted state old trace agrees) + raw answer).mpr + rw [recode_rawAnswers] + exact List.mem_append_left _ (List.mem_flatMap.mpr ⟨entry,List.mem_reverse.mpr member,cell⟩) + +/-- Every answer emitted by a table replay is the actual allocated group value, independently of any inherited cache entries. -/ +theorem replay_agrees (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (keys : List (GroupKey (context registry) Q)) (cache : WHIRPublicBackfill.PublicCache (context registry) Q) : + TraceAgrees registry Q ro + (tableReplay (dependencyKeys (context registry) Q) ((partition (context registry) Q).split ro) keys cache).2 := by + induction keys generalizing cache with + | nil => intro entry member; cases member + | cons key rest ih => + cases hit : cache key with + | some answer => simpa only [tableReplay,hit] using ih cache + | none => + intro entry member + simp only [tableReplay,hit,List.mem_cons] at member + rcases member with equal | member + · subst entry; rfl + · exact ih _ entry member + +/-- Coverage of a concrete replay prefix transports to the actual finite raw cache maintained by the causal resolver, not an arbitrary supplied oracle. -/ +theorem covered_raw (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (keys : List (GroupKey (context registry) Q)) (raw : RawKey Q) + (covered : RawCovered (context registry) Q + (tableReplay (dependencyKeys (context registry) Q) ((partition (context registry) Q).split ro) + keys (fun _ => none)).1 raw) : + cache Q ((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (privateResolver registry Q seed source counted)).traceRecode (CausalBindingState.empty cap) + (tableReplay (dependencyKeys (context registry) Q) ((partition (context registry) Q).split ro) + keys (fun _ => none)).2).2 raw = some (ro raw) := by + let trace := (tableReplay (dependencyKeys (context registry) Q) + ((partition (context registry) Q).split ro) keys (fun _ => none)).2 + have agreed : TraceAgrees registry Q ro trace := replay_agrees registry Q ro keys _ + unfold RawCovered at covered + split at covered + · rename_i pos recognized + obtain ⟨answer,hit⟩ := covered + obtain ⟨history,member⟩ := replay_cached (dependencyKeys (context registry) Q) + ((partition (context registry) Q).split ro) keys _ answer hit + have value := agreed ⟨(.inl pos.1,history),answer⟩ member + change answer = (partition (context registry) Q).split ro (.inl pos.1) at value + have encoded := RawWHIRKeys.encode_recognize (context registry) Q raw pos recognized + apply recode_contains registry Q ro seed source counted _ (by intro e h; cases h) + trace agreed _ member raw (ro raw) + change (raw,ro raw) ∈ List.ofFn (fun block => + (RawWHIRKeys.encode (context registry) Q ⟨pos.1,block⟩,answer block)) + apply List.mem_ofFn.mpr + refine ⟨pos.2,?_⟩ + rw [value] + change (RawWHIRKeys.encode (context registry) Q pos, + ro (RawWHIRKeys.encode (context registry) Q pos)) = (raw,ro raw) + rw [encoded] + · rename_i recognized + obtain ⟨answer,hit⟩ := covered + obtain ⟨history,member⟩ := replay_cached (dependencyKeys (context registry) Q) + ((partition (context registry) Q).split ro) keys _ answer hit + have value := agreed ⟨(.inr ⟨raw,recognized⟩,history),answer⟩ member + change answer = ro raw at value + subst answer + exact recode_contains registry Q ro seed source counted _ (by intro e h; cases h) + trace agreed _ member raw (ro raw) (by simp [groupEntries]) + +end Whir.WHIRSourceAllocationCache diff --git a/verification/whir/Whir/WHIRSourceAllocationOrigin.lean b/verification/whir/Whir/WHIRSourceAllocationOrigin.lean new file mode 100644 index 000000000..5d360393b --- /dev/null +++ b/verification/whir/Whir/WHIRSourceAllocationOrigin.lean @@ -0,0 +1,427 @@ +import Whir.WHIRObservableAllocations + +/-! Causal origins of the actual allocation compiler's emitted trace. + +`compile_origin` associates every fresh allocation with the first uncovered +query on the executed raw path, or with final completion after that path is +covered. Its witness is the exact replay prefix, including cache hits. +`compile_prefix_recorded` derives dependency closure at that prefix, while +`replay_cached` locates every cached answer in the already-emitted trace. +No source coverage or allocation-origin certificate is an input. The generic +source path can be instantiated with `WHIRSourceRawProgram.bounded_rawAnswers`; +the resolver's finite raw-cache transport is deliberately a separate layer. +-/ + +namespace Whir.WHIRSourceAllocationOrigin +open TypedOracleCompiler TypedFiatShamirGame RawOracleCoupling +open RawOracleCoupling.Concrete FiatShamirGame DuplexModeGame +open RawWHIRKeys (Context Packet) +open WHIRObservableAllocations WHIRPublicBackfill + +section Replay +universe u +variable {Key : Type u} {Answer : Key → Type u} [DecidableEq Key] +variable (deps : Key → List Key) (table : (key : Key) → Answer key) + +theorem replay_growth (keys : List Key) (cache : Cache Key Answer) : + Growth cache (tableReplay deps table keys cache).1 := by + induction keys generalizing cache with + | nil => exact growth_refl _ + | cons key keys ih => + cases hit : cache key with + | some answer => simpa only [tableReplay, hit] using ih cache + | none => + simpa only [tableReplay, hit] using + growth_trans (growth_put cache key (table key) hit) (ih (put cache key (table key))) + +theorem replay_covered (keys : List Key) (cache : Cache Key Answer) : + ∀ key ∈ keys, ∃ answer, (tableReplay deps table keys cache).1 key = some answer := by + induction keys generalizing cache with + | nil => intro key member; cases member + | cons key keys ih => + intro wanted member + cases hit : cache key with + | some answer => + simp only [tableReplay, hit] + rcases List.mem_cons.mp member with rfl | member + · exact ⟨answer, replay_growth deps table keys cache wanted answer hit⟩ + · exact ih cache wanted member + | none => + simp only [tableReplay, hit] + rcases List.mem_cons.mp member with rfl | member + · exact ⟨table wanted, replay_growth deps table keys (put cache wanted (table wanted)) + wanted (table wanted) (put_self _ _ _)⟩ + · exact ih (put cache key (table key)) wanted member + +theorem replay_append (left right : List Key) (cache : Cache Key Answer) : + tableReplay deps table (left ++ right) cache = + let a := tableReplay deps table left cache + let b := tableReplay deps table right a.1 + (b.1, a.2 ++ b.2) := by + induction left generalizing cache with + | nil => rfl + | cons key keys ih => + cases hit : cache key with + | some answer => simpa only [List.cons_append, tableReplay, hit] using ih cache + | none => simp only [List.cons_append, tableReplay, hit, ih, List.cons_append] + +/-- A concrete allocation determines an exact request prefix and the actual +memo-cache just before the allocation, including all preceding cache hits. -/ +theorem replay_origin (keys : List Key) (cache : Cache Key Answer) + (before after : List (Sigma (AnnotatedAnswer (Answer := Answer)))) + (entry : Sigma (AnnotatedAnswer (Answer := Answer))) + (trace : (tableReplay deps table keys cache).2 = before ++ entry :: after) : + ∃ left right, keys = left ++ entry.1.1 :: right ∧ + (tableReplay deps table left cache).2 = before ∧ + (tableReplay deps table left cache).1 entry.1.1 = none ∧ + entry.1.2 = dependencyHistory deps (tableReplay deps table left cache).1 entry.1.1 ∧ + entry.2 = table entry.1.1 := by + induction keys generalizing cache before with + | nil => simp [tableReplay] at trace + | cons key keys ih => + cases hit : cache key with + | some answer => + simp only [tableReplay, hit] at trace + obtain ⟨left,right,split,hprefix,miss,history,value⟩ := ih cache before trace + refine ⟨key :: left,right,?_,?_,?_,?_,value⟩ + · simp only [List.cons_append, split] + · simpa only [tableReplay, hit] using hprefix + · simpa only [tableReplay, hit] using miss + · simpa only [tableReplay, hit] using history + | none => + simp only [tableReplay, hit] at trace + cases before with + | nil => + simp only [List.nil_append, List.cons.injEq] at trace + have he := trace.1 + subst entry + exact ⟨[],keys,rfl,rfl,hit,rfl,rfl⟩ + | cons first before => + simp only [List.cons_append, List.cons.injEq] at trace + obtain ⟨left,right,split,hprefix,miss,history,value⟩ := + ih (put cache key (table key)) before trace.2 + refine ⟨key :: left,right,?_,?_,?_,?_,value⟩ + · simp only [List.cons_append, split] + · simp only [tableReplay, hit, hprefix, trace.1] + · simpa only [tableReplay, hit] using miss + · simpa only [tableReplay, hit] using history + +/-- Executed scheduling invariant: every fresh draw has its dependencies ready. -/ +def SafeKeys : List Key → Cache Key Answer → Prop + | [], _ => True + | key :: rest, cache => + match cache key with + | some _ => SafeKeys rest cache + | none => Ready deps cache key ∧ SafeKeys rest (put cache key (table key)) + +theorem safeKeys_execute {R : Type u} {n} (p : Sampling Key Answer R n) + (cache : Cache Key Answer) (consistent : Consistent table cache) + {post : R × Cache Key Answer → Prop} (safe : Safe deps post p cache) : + SafeKeys deps table ((Sampling.execute table p).2.map Sigma.fst) cache := by + induction p generalizing cache with + | ret => trivial + | draw key next ih => + simp only [Sampling.execute, List.map_cons, SafeKeys] + cases hit : cache key with + | some answer => + have equal := consistent key answer hit + rw [equal] + exact ih answer cache consistent (by simpa only [Safe,hit] using safe) + | none => + have hs : Ready deps cache key ∧ + ∀ answer, Safe deps post (next answer) (put cache key answer) := by + simpa only [Safe,hit] using safe + exact ⟨hs.1,ih (table key) _ (consistent.put key) (hs.2 (table key))⟩ + +theorem safeKeys_prefix (left right : List Key) (cache : Cache Key Answer) + (safe : SafeKeys deps table (left ++ right) cache) : + SafeKeys deps table left cache := by + induction left generalizing cache with + | nil => trivial + | cons key keys ih => + cases hit : cache key with + | some answer => + simp only [List.cons_append, SafeKeys, hit] at safe ⊢ + exact ih cache safe + | none => + simp only [List.cons_append, SafeKeys, hit] at safe ⊢ + exact ⟨safe.1,ih _ safe.2⟩ + +theorem replay_recorded (keys : List Key) (cache : Cache Key Answer) + (before : List (Sigma (AnnotatedAnswer (Answer := Answer)))) + (recorded : Recorded deps cache before) (safe : SafeKeys deps table keys cache) : + Recorded deps (tableReplay deps table keys cache).1 + (before ++ (tableReplay deps table keys cache).2) := by + induction keys generalizing cache before with + | nil => simpa only [tableReplay,List.append_nil] using recorded + | cons key keys ih => + cases hit : cache key with + | some answer => + simp only [tableReplay,hit] + exact ih cache before recorded (by simpa only [SafeKeys,hit] using safe) + | none => + have hs : Ready deps cache key ∧ SafeKeys deps table keys (put cache key (table key)) := by + simpa only [SafeKeys,hit] using safe + have step := ih (put cache key (table key)) + (before ++ [⟨(key,dependencyHistory deps cache key),table key⟩]) + (Recorded.insert deps recorded hs.1 hit (table key)) hs.2 + simpa only [tableReplay,hit,List.append_assoc,List.singleton_append] using step + +/-- Every cache hit is either inherited or emitted by this exact replay. -/ +theorem replay_cache_origin (keys : List Key) (cache : Cache Key Answer) + (key : Key) (answer : Answer key) + (hit : (tableReplay deps table keys cache).1 key = some answer) : + cache key = some answer ∨ ∃ history, + (⟨(key,history),answer⟩ : Sigma (AnnotatedAnswer (Answer := Answer))) ∈ + (tableReplay deps table keys cache).2 := by + induction keys generalizing cache with + | nil => exact Or.inl hit + | cons current keys ih => + cases known : cache current with + | some value => + simp only [tableReplay,known] at hit ⊢ + exact ih cache hit + | none => + simp only [tableReplay,known] at hit ⊢ + rcases ih (put cache current (table current)) hit with inherited | ⟨history,member⟩ + · by_cases equal : key = current + · subst current + have equalAnswer : table key = answer := by simpa only [put_self,Option.some.injEq] using inherited + right + exact ⟨dependencyHistory deps cache key,by simp [equalAnswer]⟩ + · left + simpa only [put_other _ _ _ _ equal] using inherited + · exact Or.inr ⟨history,List.mem_cons_of_mem _ member⟩ + +theorem replay_cached (keys : List Key) (key : Key) (answer : Answer key) + (hit : (tableReplay deps table keys (fun _ => none)).1 key = some answer) : + ∃ history, (⟨(key,history),answer⟩ : Sigma (AnnotatedAnswer (Answer := Answer))) ∈ + (tableReplay deps table keys (fun _ => none)).2 := by + rcases replay_cache_origin deps table keys (fun _ => none) key answer hit with impossible | member + · cases impossible + · exact member +end Replay + +/-- Split an occurrence in the flattened compiler schedule without deduplicating +the initiating raw path. The prefix statement records chronological coverage. -/ +theorem flatMap_origin {A B : Type} (f : A → List B) (raws : List A) + (terminal before after : List B) (key : B) + (split : raws.flatMap f ++ terminal = before ++ key :: after) : + (∃ prior current rest, raws = prior ++ current :: rest ∧ key ∈ f current ∧ + (prior.flatMap f).IsPrefix before) ∨ + (key ∈ terminal ∧ (raws.flatMap f).IsPrefix before) := by + induction raws generalizing before with + | nil => + right + refine ⟨?_,⟨before,rfl⟩⟩ + simp only [List.flatMap_nil, List.nil_append] at split + rw [split] + simp + | cons raw raws ih => + simp only [List.flatMap_cons, List.append_assoc] at split + rcases List.append_eq_append_iff.mp split with ⟨middle,front,back⟩ | ⟨middle,front,back⟩ + · rcases ih middle back with ⟨prior,current,rest,path,member,hprior⟩ | ⟨member,hprior⟩ + · left + refine ⟨raw :: prior,current,rest,?_,member,?_⟩ + · simp [path] + · obtain ⟨suffix,hsuffix⟩ := hprior + exact ⟨suffix,by simp only [List.flatMap_cons, List.append_assoc, hsuffix, front]⟩ + · right + refine ⟨member,?_⟩ + obtain ⟨suffix,hsuffix⟩ := hprior + exact ⟨suffix,by simp only [List.flatMap_cons, List.append_assoc, hsuffix, front]⟩ + · cases middle with + | nil => + simp only [List.append_nil] at front + simp only [List.nil_append] at back + rcases ih [] back.symm with ⟨prior,current,rest,path,member,hprior⟩ | ⟨member,hprior⟩ + · left + refine ⟨raw :: prior,current,rest,by simp [path],member,?_⟩ + obtain ⟨suffix,hsuffix⟩ := hprior + exact ⟨suffix,by simp only [List.flatMap_cons, List.append_assoc, hsuffix, + List.append_nil, front]⟩ + · right + obtain ⟨suffix,hsuffix⟩ := hprior + exact ⟨member, suffix,by simp only [List.flatMap_cons, List.append_assoc, + hsuffix, List.append_nil, front]⟩ + | cons head middle => + simp only [List.cons_append, List.cons.injEq] at back + left + refine ⟨[],raw,raws,rfl,?_,⟨before,rfl⟩⟩ + rw [front,← back.1] + simp + +private instance (ctx : Context) (Q : Nat) : DecidableEq (GroupKey ctx Q) := inferInstance + +/-- Compiler-owned causal stage for every concrete fresh allocation. Earlier +raw requests are covered by the actual memo cache, not by a supplied certificate. -/ +theorem allocation_origin (ctx : Context) (Q : Nat) + (table : RawKey Q → Digest32) (raws : List (RawKey Q)) (final : Option (Packet ctx Q)) + (before after : List (Sigma (AllocationAnswer ctx Q))) (entry : Sigma (AllocationAnswer ctx Q)) + (trace : (tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) + (allocationRequests ctx Q raws final) (fun _ => none)).2 = before ++ entry :: after) : + ∃ keys, let cache := (tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) + keys (fun _ => none)).1 + (tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) keys + (fun _ => none)).2 = before ∧ cache entry.1.1 = none ∧ + entry.1.2 = dependencyHistory (dependencyKeys ctx Q) cache entry.1.1 ∧ + entry.2 = (partition ctx Q).split table entry.1.1 ∧ + ((∃ prior current rest, raws = prior ++ current :: rest ∧ + entry.1.1 ∈ requestKeys ctx Q current ∧ + ∀ raw ∈ prior, ∀ key ∈ requestKeys ctx Q raw, ∃ answer, cache key = some answer) ∨ + (entry.1.1 ∈ finalKeys ctx Q final ∧ + ∀ raw ∈ raws, ∀ key ∈ requestKeys ctx Q raw, ∃ answer, cache key = some answer)) := by + obtain ⟨keys,suffix,split,hprefix,miss,history,value⟩ := + replay_origin (dependencyKeys ctx Q) ((partition ctx Q).split table) _ (fun _ => none) + before after entry trace + refine ⟨keys,hprefix,miss,history,value,?_⟩ + rcases flatMap_origin (requestKeys ctx Q) raws (finalKeys ctx Q final) keys suffix + entry.1.1 split with ⟨prior,current,rest,path,member,hprior⟩ | ⟨member,hprior⟩ + · left + refine ⟨prior,current,rest,path,member,?_⟩ + intro raw hraw key hkey + exact replay_covered _ _ keys _ key + (List.IsPrefix.mem (List.mem_flatMap.mpr ⟨raw,hraw,hkey⟩) hprior) + · right + refine ⟨member,?_⟩ + intro raw hraw key hkey + exact replay_covered _ _ keys _ key + (List.IsPrefix.mem (List.mem_flatMap.mpr ⟨raw,hraw,hkey⟩) hprior) + +/-- Dependency closure holds at every actual request prefix, not just at the +end of compilation. In particular, a cached packet cannot introduce new +dependencies when another block or a repeated request warms that packet. -/ +theorem compile_prefix_recorded (ctx : Context) (Q : Nat) {R : Type} {n} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) + (keys suffix : List (GroupKey ctx Q)) + (split : allocationRequests ctx Q ((Sampling.execute table p).2.map Sigma.fst) + (final (Sampling.eval table p)) = keys ++ suffix) : + Recorded (dependencyKeys ctx Q) + (tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) keys (fun _ => none)).1 + (tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) keys (fun _ => none)).2 := by + have safe := safeKeys_execute (dependencyKeys ctx Q) ((partition ctx Q).split table) + ((partition ctx Q).program (schedule ctx Q) (callerPlan ctx Q) final p) (fun _ => none) + (by intro key answer hit; cases hit) + ((partition ctx Q).safe_program (schedule ctx Q) (callerPlan ctx Q) + (schedule_ordered ctx Q) (caller_coherent ctx Q) final p (fun _ => none)) + rw [program_keys,split] at safe + exact replay_recorded _ _ keys (fun _ => none) [] (recorded_empty _) + (safeKeys_prefix _ _ keys suffix _ safe) + +/-- Cached recognized packets cover their entire real dependency/caller +completion; cache hits never cause a novel dependency allocation. -/ +theorem cached_completion (ctx : Context) (Q : Nat) + (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (trace : List (Sigma (AllocationAnswer ctx Q))) + (recorded : Recorded (dependencyKeys ctx Q) cache trace) + (packet : Packet ctx Q) (answer : GroupAnswer ctx Q (.inl packet)) + (hit : cache (.inl packet) = some answer) : + ∀ key ∈ completionKeys ctx Q packet, ∃ value, cache key = some value := by + intro key member + rcases List.mem_append.mp member with dependency | self + · exact (recorded (.inl packet) answer hit).1 key dependency + · have equal : key = .inl packet := List.mem_singleton.mp self + subst key + exact ⟨answer,hit⟩ + + +/-- A source query is covered precisely when its actual partition group is +available. This definition preserves repeated raw requests and block indices. -/ +def RawCovered (ctx : Context) (Q : Nat) + (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) (raw : RawKey Q) : Prop := + match recognized : RawWHIRKeys.recognize ctx Q raw with + | some pos => ∃ answer, cache (.inl pos.1) = some answer + | none => ∃ answer, cache (.inr ⟨raw,recognized⟩) = some answer + +theorem request_covered (ctx : Context) (Q : Nat) + (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) (raw : RawKey Q) + (covered : ∀ key ∈ requestKeys ctx Q raw, ∃ answer, cache key = some answer) : + RawCovered ctx Q cache raw := by + unfold RawCovered + split + · rename_i pos recognized + apply covered (.inl pos.1) + rw [requestKeys_some ctx Q raw pos recognized] + simp [completionKeys] + · rename_i recognized + apply covered (.inr ⟨raw,recognized⟩) + rw [requestKeys_none ctx Q raw recognized] + simp + +theorem fresh_request_uncovered (ctx : Context) (Q : Nat) + (cache : Cache (GroupKey ctx Q) (GroupAnswer ctx Q)) + (trace : List (Sigma (AllocationAnswer ctx Q))) + (recorded : Recorded (dependencyKeys ctx Q) cache trace) + (raw : RawKey Q) (key : GroupKey ctx Q) + (member : key ∈ requestKeys ctx Q raw) (miss : cache key = none) : + ¬ RawCovered ctx Q cache raw := by + unfold RawCovered + split + · rename_i pos recognized + intro ⟨answer,hit⟩ + rw [requestKeys_some ctx Q raw pos recognized] at member + obtain ⟨value,hvalue⟩ := cached_completion ctx Q cache trace recorded pos.1 answer hit key member + rw [miss] at hvalue + cases hvalue + · rename_i recognized + rw [requestKeys_none ctx Q raw recognized] at member + have equal : key = .inr ⟨raw,recognized⟩ := List.mem_singleton.mp member + subst key + intro ⟨answer,hit⟩ + rw [miss] at hit + cases hit + +/-- Exact all-table compiler provenance. Its stage is the first still-uncovered +raw request, or the selected final completion after all source requests. -/ +theorem compile_origin (ctx : Context) (Q : Nat) {R : Type} {n} + (table : RawKey Q → Digest32) (final : R → Option (Packet ctx Q)) + (p : Sampling (RawKey Q) (fun _ => Digest32) R n) + (before after : List (Sigma (AllocationAnswer ctx Q))) (entry : Sigma (AllocationAnswer ctx Q)) + (trace : (Sampling.execute (WHIRObservableAllocations.allocationOracle ctx Q table) + (RawOracleCoupling.Concrete.compile ctx Q final p)).2 = before ++ entry :: after) : + ∃ keys suffix, let cache := (tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) + keys (fun _ => none)).1 + allocationRequests ctx Q ((Sampling.execute table p).2.map Sigma.fst) + (final (Sampling.eval table p)) = keys ++ entry.1.1 :: suffix ∧ + (tableReplay (dependencyKeys ctx Q) ((partition ctx Q).split table) keys + (fun _ => none)).2 = before ∧ cache entry.1.1 = none ∧ + entry.1.2 = dependencyHistory (dependencyKeys ctx Q) cache entry.1.1 ∧ + entry.2 = (partition ctx Q).split table entry.1.1 ∧ + Recorded (dependencyKeys ctx Q) cache before ∧ + ((∃ prior current rest, (Sampling.execute table p).2.map Sigma.fst = prior ++ current :: rest ∧ + entry.1.1 ∈ requestKeys ctx Q current ∧ ¬ RawCovered ctx Q cache current ∧ + ∀ raw ∈ prior, RawCovered ctx Q cache raw) ∨ + (entry.1.1 ∈ finalKeys ctx Q (final (Sampling.eval table p)) ∧ + ∀ raw ∈ (Sampling.execute table p).2.map Sigma.fst, RawCovered ctx Q cache raw)) := by + rw [compile_execution] at trace + have path : (WHIRObservableAllocations.rawAnswers Q table p).map Prod.fst = + (Sampling.execute table p).2.map Sigma.fst := by + simp [WHIRObservableAllocations.rawAnswers,List.map_map] + simp only [path] at trace + obtain ⟨keys,suffix,split,hprefix,miss,history,value⟩ := + replay_origin (dependencyKeys ctx Q) ((partition ctx Q).split table) _ (fun _ => none) + before after entry trace + have recorded := compile_prefix_recorded ctx Q table final p keys (entry.1.1 :: suffix) split + rw [hprefix] at recorded + refine ⟨keys,suffix,split,hprefix,miss,history,value,recorded,?_⟩ + rcases flatMap_origin (requestKeys ctx Q) ((Sampling.execute table p).2.map Sigma.fst) + (finalKeys ctx Q (final (Sampling.eval table p))) keys suffix entry.1.1 split with + ⟨prior,current,rest,hpath,member,hprior⟩ | ⟨member,hprior⟩ + · left + refine ⟨prior,current,rest,hpath,member, + fresh_request_uncovered ctx Q _ before recorded current entry.1.1 member miss,?_⟩ + intro raw hraw + apply request_covered ctx Q _ raw + intro key hkey + exact replay_covered _ _ keys _ key + (List.IsPrefix.mem (List.mem_flatMap.mpr ⟨raw,hraw,hkey⟩) hprior) + · right + refine ⟨member,?_⟩ + intro raw hraw + apply request_covered ctx Q _ raw + intro key hkey + exact replay_covered _ _ keys _ key + (List.IsPrefix.mem (List.mem_flatMap.mpr ⟨raw,hraw,hkey⟩) hprior) + +end Whir.WHIRSourceAllocationOrigin diff --git a/verification/whir/Whir/WHIRSourceBackfill.lean b/verification/whir/Whir/WHIRSourceBackfill.lean new file mode 100644 index 000000000..8d175d54a --- /dev/null +++ b/verification/whir/Whir/WHIRSourceBackfill.lean @@ -0,0 +1,352 @@ +import Whir.WHIRSourceResolver +import Whir.WHIRPublicBackfill + +/-! The physical public completion of a source retains compiler-owned metadata. +Its budget is derived only on reachable compiler outputs, never on forged event +lists. Every repeated completion is charged; root metadata remains free. -/ +namespace Whir.WHIRSourceBackfill +open FiatShamirGame DuplexFraming DuplexModeGame +open RawWHIRKeys (Context Packet) +open WHIRModeFinal WHIRPublicBackfill + +variable {cap : Nat} {R S : Type} + +/-- Public requests depend only on source-owned observations. -/ +def requests (ctx : Context) (Q : Nat) (result : WHIRSourceChronology.Result cap R) : List (RawKey Q) := + DuplexPublicSimulator.replay Q ctx.iv [] (WHIRSourceChronology.observations result.events) + +/-- The executable wrapper returns no simulator state, seed, or oracle. -/ +def instrument (ctx : Context) (Q : Nat) (source : WHIRSourceChronology.Source cap R) + (select : R → Option (Packet ctx Q)) : + Program (WHIRPublicBackfill.Completed ctx Q (WHIRSourceChronology.Result cap R)) := + bind (WHIRSourceChronology.compile source) + (fun result => backfill ctx Q result (requests ctx Q result) (select result.value)) + +/-- Universal over actual continuation branches, not arbitrary result values. -/ +def AllResults (post : R → Prop) : Program R → Prop + | .done r => post r + | .ask _ next => ∀ answer, AllResults post (next answer) + +theorem allResults_mono (p : Program R) (post next : R → Prop) + (h : AllResults post p) (imp : ∀ r, post r → next r) : AllResults next p := by + induction p with + | done r => exact imp r h + | ask q cont ih => exact fun d => ih d (h d) + +theorem allResults_map (p : Program R) (f : R → S) (post : S → Prop) : + AllResults post (WHIRSourceChronology.map f p) = AllResults (fun r => post (f r)) p := by + induction p with + | done => rfl + | ask q next ih => simp only [WHIRSourceChronology.map, AllResults, ih] + +theorem allResults_of_forall (p : Program R) (post : R → Prop) (all : ∀ result, post result) : + AllResults post p := by + induction p with + | done result => exact all result + | ask _ _ ih => exact ih + +theorem allResults_and (p : Program R) (left right : R → Prop) + (hl : AllResults left p) (hr : AllResults right p) : AllResults (fun result => left result ∧ right result) p := by + induction p with + | done => exact ⟨hl,hr⟩ + | ask _ _ ih => exact fun answer => ih answer (hl answer) (hr answer) + +/-- Instrumentation preserves exactly which public values can be returned; metadata cannot manufacture a verifier result. -/ +theorem compile_value_outputs (source : WHIRSourceChronology.Source cap R) (post : R → Prop) : + AllResults (fun result => post result.value) (WHIRSourceChronology.compile source) ↔ + AllResults post (WHIRSourceChronology.erase source) := by + induction source with + | done => rfl + | ask query next ih => + simp only [WHIRSourceChronology.compile,WHIRSourceChronology.erase,AllResults,allResults_map, + WHIRSourceChronology.prepend] + exact forall_congr' ih + | commit root next ih => + simpa only [WHIRSourceChronology.compile,WHIRSourceChronology.erase,allResults_map, + WHIRSourceChronology.prepend] using ih + | claims profile entry request next ih => + simpa only [WHIRSourceChronology.compile,WHIRSourceChronology.erase,allResults_map, + WHIRSourceChronology.prepend] using ih + +theorem bind_counted_reachable (p : Program R) (next : R → Program S) (post : R → Prop) + (a b : Nat) (before : Counts a p) (reachable : AllResults post p) + (after : ∀ r, post r → Counts b (next r)) : Counts (a+b) (bind p next) := by + induction p generalizing a with + | done r => exact counts_mono (after r reachable) (by omega) + | ask q cont ih => + refine ⟨by have := before.1; omega, fun d => ?_⟩ + have h := ih d (a-q.cost) (before.2 d) (reachable d) + exact counts_mono h (by have := before.1; omega) + +def observationCost (observations : List Observation) : Nat := + (observations.map (fun o => o.query.cost)).sum + +theorem compile_outputs (source : WHIRSourceChronology.Source cap R) (A : Nat) + (counted : WHIRSourceChronology.Counts A source) : + AllResults (fun r => observationCost (WHIRSourceChronology.observations r.events) ≤ A) + (WHIRSourceChronology.compile source) := by + induction source generalizing A with + | done r => simp [WHIRSourceChronology.compile, AllResults, WHIRSourceChronology.observations, observationCost] + | ask q next ih => + intro answer + rw [allResults_map] + apply allResults_mono _ _ _ (ih answer (A-q.cost) (counted.2 answer)) + intro r hr + change q.cost + observationCost (WHIRSourceChronology.observations r.events) ≤ A + have := counted.1 + omega + | commit root next ih => + simpa only [WHIRSourceChronology.compile, allResults_map, + WHIRSourceChronology.prepend, WHIRSourceChronology.observations] using ih A counted + | claims profile entry request next ih => + simpa only [WHIRSourceChronology.compile, allResults_map, + WHIRSourceChronology.prepend, WHIRSourceChronology.observations] using ih A counted + +/-- Even adversarial answer lists are bounded by their source instruction costs. +The primitive recognizer's fuel is the finite source log, not ambient Q. -/ +theorem replay_bounds (Q : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (obs : List Observation) : + (DuplexPublicSimulator.replay Q iv log obs).length ≤ observationCost obs ∧ + ∀ raw ∈ DuplexPublicSimulator.replay Q iv log obs, + raw.1.1.val ≤ log.length + observationCost obs := by + induction obs generalizing log with + | nil => simp [DuplexPublicSimulator.replay, observationCost] + | cons observation rest ih => + rcases observation with ⟨query,answer⟩ + cases query with + | primitive purpose input => + have tail := ih (DuplexPublicSimulator.observe log input answer) + have len : (DuplexPublicSimulator.privateKey Q log input).toList.length ≤ 1 := by + cases DuplexPublicSimulator.privateKey Q log input <;> simp + simp only [DuplexPublicSimulator.replay, List.length_append] + constructor + · simp only [observationCost, List.map_cons, List.sum_cons, Query.cost] at * + omega + · intro raw member + rcases List.mem_append.mp member with member | member + · have key : DuplexPublicSimulator.privateKey Q log input = some raw := by + simpa only [Option.mem_toList, Option.mem_def] using member + have h := (DuplexPublicSimulator.privateKey_lengths_log key).1 + simp only [observationCost, List.map_cons, List.sum_cons, Query.cost] + omega + · have h := tail.2 raw member + simp only [DuplexPublicSimulator.observe, List.length_cons, + observationCost, List.map_cons, List.sum_cons, Query.cost] at * + omega + | construction coordinate valid => + have tail := ih log + have positive : 1 ≤ pathCost coordinate := by + simp [pathCost, DuplexEncoding.plan] + by_cases h : pathCost coordinate ≤ Q + · simp only [DuplexPublicSimulator.replay, h, ↓reduceDIte, List.length_cons] + constructor + · simp only [observationCost, List.map_cons, List.sum_cons, Query.cost] at * + omega + · intro raw member + rcases List.mem_cons.mp member with rfl | member + · simp only [constructionKey, restrictKey, shortList, (modeKey_lengths iv coordinate).1, + observationCost, List.map_cons, List.sum_cons, Query.cost] + omega + · have := tail.2 raw member + simp only [observationCost, List.map_cons, List.sum_cons, Query.cost] at * + omega + · simp only [DuplexPublicSimulator.replay, h, ↓reduceDIte] + constructor + · simp only [observationCost, List.map_cons, List.sum_cons, Query.cost] at * + omega + · intro raw member + have := tail.2 raw member + simp only [observationCost, List.map_cons, List.sum_cons, Query.cost] at * + omega + +def budget (ctx : Context) (A Mf : Nat) : Nat := + A + (A * (pathFactor ctx * A) + pathFactor ctx * Mf) + +/-- A final path cap is needed only for reachable public outputs, so an arbitrary attacker cannot supply a fabricated accepted result merely to satisfy accounting. -/ +theorem counted_reachable (ctx : Context) (Q A Mf : Nat) (source : WHIRSourceChronology.Source cap R) + (select : R → Option (Packet ctx Q)) (before : WHIRSourceChronology.Counts A source) + (finalPaths : AllResults + (fun result => ∀ packet, select result = some packet → + pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ Mf) + (WHIRSourceChronology.erase source)) : + Counts (budget ctx A Mf) (instrument ctx Q source select) := by + have outputs := (compile_value_outputs source _).mpr finalPaths + apply bind_counted_reachable _ _ + (fun result => observationCost (WHIRSourceChronology.observations result.events) ≤ A ∧ + ∀ packet, select result.value = some packet → + pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ Mf) A _ + ((WHIRSourceChronology.compile_counted source A).mpr before) + (allResults_and _ _ _ (compile_outputs source A before) outputs) + intro result reachable + apply counts_mono (backfill_counted ctx Q result _ _) + have bounds := replay_bounds Q ctx.iv [] (WHIRSourceChronology.observations result.events) + have paths : ∀ raw ∈ requests ctx Q result, raw.1.1.val ≤ A := by + intro raw member + exact (bounds.2 raw member).trans (by simpa using reachable.1) + exact (cost_bound_pathCaps ctx Q A Mf (requests ctx Q result) (select result.value) + paths reachable.2).trans + (Nat.add_le_add_right (Nat.mul_le_mul_right _ (bounds.1.trans reachable.1)) _) + +/-- Source-only, noncircular physical accounting. Q is only a key-domain index; +the caller separately requires `budget ctx A Mf ≤ Q` to run the ideal mode. -/ +theorem counted (ctx : Context) (Q A Mf : Nat) (source : WHIRSourceChronology.Source cap R) + (select : R → Option (Packet ctx Q)) (before : WHIRSourceChronology.Counts A source) + (finalPaths : ∀ r p, select r = some p → pathCost (RawWHIRKeys.coordinate ctx p.val 0) ≤ Mf) : + Counts (budget ctx A Mf) (instrument ctx Q source select) := by + exact counted_reachable ctx Q A Mf source select before + (allResults_of_forall _ _ finalPaths) + +/-- State-independent continuation results permit exact physical suffix composition. -/ +theorem bind_ideal_result {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) + (p : Program R) (next : R → Program S) (value : R → S) + (after : ∀ r state rem (hc : rem ≤ Q) (hn : Counts rem (next r)), + (runIdeal sim ro iv state (next r) rem hc hn).view.result = value r) + (remaining : Nat) (limit : remaining ≤ Q) (before : Counts remaining p) + (whole : Counts remaining (bind p next)) : + (runIdeal sim ro iv state (bind p next) remaining limit whole).view.result = + value (runIdeal sim ro iv state p remaining limit before).view.result := by + induction p generalizing state remaining with + | done r => exact after r state remaining limit whole + | ask query cont ih => + cases query with + | primitive purpose input => + exact ih (runRO ro (sim.answer state input)).1.2 + (runRO ro (sim.answer state input)).1.1 (remaining-1) (by omega) (before.2 _) (whole.2 _) + | construction coordinate valid => + exact ih (ro (constructionKey Q iv coordinate (before.1.trans limit))) state + (remaining-pathCost coordinate) (by omega) (before.2 _) (whole.2 _) + +theorem ideal_result (ctx : Context) (Q : Nat) {Seed State : Type} + (sim : Simulator Q Seed State) (ro : RawKey Q → Digest32) (state : State) + (source : WHIRSourceChronology.Source cap R) (select : R → Option (Packet ctx Q)) + (remaining : Nat) (limit : remaining ≤ Q) + (whole : Counts remaining (instrument ctx Q source select)) : + (runIdeal sim ro ctx.iv state (instrument ctx Q source select) remaining limit whole).view.result = + let result := (runIdeal sim ro ctx.iv state (WHIRSourceChronology.compile source) remaining limit + (bind_prefix_counted _ (fun r => backfill ctx Q r (requests ctx Q r) (select r.value)) + remaining whole)).view.result + ⟨result, idealRecords ctx Q ro (selections ctx Q (requests ctx Q result) (select result.value))⟩ := + bind_ideal_result sim ro ctx.iv state _ _ _ + (fun r state rem hc hn => backfill_ideal_result ctx Q sim ro state r _ _ rem hc hn) + remaining limit (bind_prefix_counted _ _ remaining whole) whole + +theorem real_result (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (source : WHIRSourceChronology.Source cap R) (select : R → Option (Packet ctx Q)) : + (runReal oracle ctx.iv (instrument ctx Q source select)).view.result = + let result := (runReal oracle ctx.iv (WHIRSourceChronology.compile source)).view.result + ⟨result, realRecords ctx Q oracle (selections ctx Q (requests ctx Q result) (select result.value))⟩ := by + rw [instrument, bind_real_result, backfill_real_result] + +/-- The public replay is exactly the original source's actual private requests, +for every chosen initial seed. Completion queries cannot enter this replay. -/ +theorem requests_actual (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : WHIRSourceChronology.Source cap R) + (remaining : Nat) (limit : remaining ≤ Q) + (before : Counts remaining (WHIRSourceChronology.compile source)) : + requests ctx Q (runIdeal (DuplexPublicSimulator.simulator Q) ro ctx.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (WHIRSourceChronology.compile source) remaining limit before).view.result = + DuplexPublicSimulator.actualRequests ro ctx.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (WHIRSourceChronology.compile source) remaining limit before := by + unfold requests + rw [WHIRSourceResolver.ideal_source_trace _ _ _ _ source remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mp before)] + exact DuplexPublicSimulator.replay_actual ro ctx.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (WHIRSourceChronology.compile source) remaining limit before + +theorem ideal_actual_result (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : WHIRSourceChronology.Source cap R) + (select : R → Option (Packet ctx Q)) (remaining : Nat) (limit : remaining ≤ Q) + (whole : Counts remaining (instrument ctx Q source select)) : + (runIdeal (DuplexPublicSimulator.simulator Q) ro ctx.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (instrument ctx Q source select) remaining limit whole).view.result = + let before := bind_prefix_counted (WHIRSourceChronology.compile source) + (fun r => backfill ctx Q r (requests ctx Q r) (select r.value)) remaining whole + let state := (DuplexPublicSimulator.simulator Q).initial seed + let result := (runIdeal (DuplexPublicSimulator.simulator Q) ro ctx.iv state + (WHIRSourceChronology.compile source) remaining limit before).view.result + ⟨result, idealRecords ctx Q ro (selections ctx Q + (DuplexPublicSimulator.actualRequests ro ctx.iv state + (WHIRSourceChronology.compile source) remaining limit before) (select result.value))⟩ := by + rw [ideal_result] + dsimp only + rw [requests_actual] + +theorem requests_replayAnswers (ctx : Context) (Q : Nat) (result : WHIRSourceChronology.Result cap R) : + requests ctx Q result = + (DuplexPublicSimulator.replayAnswers Q ctx.iv [] + (WHIRSourceChronology.observations result.events)).map Prod.fst := + (DuplexPublicSimulator.replayAnswers_keys ..).symm + +private def smokeContext : Context := + ⟨.stack,fun _ => 0,fun _ => 1,fun _ => some (0,0),fun _ => 1,1⟩ + +/-- Runs the actual source compiler, public simulator, and physical wrapper. +The source performs a raw-request-producing primitive chain, a repeat, and +interleaved free commitment metadata; no final packet is selected. -/ +private def smoke : IO Unit := do + let seedNode : Node := ⟨fun _ => 41,fun _ => 0,UInt64.ofNat (2^56),true⟩ + let terminal : Node := ⟨fun _ => 7,fun _ => 0,UInt64.ofNat (6*2^56),true⟩ + let source : WHIRSourceChronology.Source 0 Digest32 := + .commit (fun _ => 41) (.ask (.primitive .direct seedNode) (fun _ => + .ask (.primitive .auxiliary terminal) (fun d => + .commit d (.ask (.primitive .verification terminal) (fun repeated => .done repeated))))) + let Q := budget smokeContext 3 0 + 4096 + let select : Digest32 → Option (Packet smokeContext Q) := fun _ => none + have sourceCounted : WHIRSourceChronology.Counts 3 source := by + simp [source, WHIRSourceChronology.Counts, Query.cost] + have finalPaths : ∀ r p, select r = some p → + pathCost (RawWHIRKeys.coordinate smokeContext p.val 0) ≤ 0 := by + intro r p h + cases h + let total := budget smokeContext 3 0 + if limit : total ≤ Q then + let ro : RawKey Q → Digest32 := fun _ _ => 99 + let seed : DuplexPublicSimulator.Seed := fun _ _ => 7 + let ideal := runIdeal (DuplexPublicSimulator.simulator Q) ro smokeContext.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (instrument smokeContext Q source select) total limit + (counted smokeContext Q 3 0 source select sourceCounted finalPaths) + let real := runReal (fun n _ => if n.tweak = terminal.tweak then 99 else 7) + smokeContext.iv (instrument smokeContext Q source select) + let raw := requests smokeContext Q ideal.view.result.result + unless decide (ideal.view.result.result.value = fun _ => 99) && + decide (real.view.result.result.value = ideal.view.result.result.value) && + ideal.view.result.result.events.length == 5 && + ideal.view.observations.length == 3 && ideal.primitiveCost == 3 && + real.primitiveCost == 3 && ideal.simulatorQueries == 1 && + raw.length == 1 && raw.all (fun key => key.1.1.val == 2) && + (ideal.view.result.records.map (fun record => record.history.length)) == [0,0] && + (real.view.result.records.map (fun record => record.history.length)) == [0,0] do + throw (IO.userError "source backfill raw-path/repeat/metadata diagram failed") + let fallback : WHIRSourceChronology.Source 0 Digest32 := + .ask (.primitive .pow terminal) WHIRSourceChronology.Source.done + have fallbackCounted : WHIRSourceChronology.Counts 1 fallback := by + simp [fallback, WHIRSourceChronology.Counts, Query.cost] + have small : budget smokeContext 1 0 ≤ total := by + dsimp [total, budget] + omega + let fallbackRun := runIdeal (DuplexPublicSimulator.simulator Q) ro smokeContext.iv + ((DuplexPublicSimulator.simulator Q).initial seed) + (instrument smokeContext Q fallback select) total limit + (counts_mono (counted smokeContext Q 1 0 fallback select fallbackCounted finalPaths) small) + unless decide (fallbackRun.view.result.result.value = fun _ => 7) && + fallbackRun.simulatorQueries == 0 && fallbackRun.primitiveCost == 1 && + (requests smokeContext Q fallbackRun.view.result.result).isEmpty && + (fallbackRun.view.result.records.map (fun record => record.history.length)) == [0] do + throw (IO.userError "source backfill exact no-final fallback failed") + IO.println s!"source backfill smoke: metadata=5, source calls=3, raw calls=1, raw path=2, repeat charged, empty final; source-only budget={total}, domain={Q}; fallback=7, raw calls=0" + else + throw (IO.userError "source-only smoke budget exceeds key domain") + +#eval smoke + +#print axioms counted +#print axioms ideal_actual_result +#print axioms real_result + +end Whir.WHIRSourceBackfill diff --git a/verification/whir/Whir/WHIRSourceCatalog.lean b/verification/whir/Whir/WHIRSourceCatalog.lean new file mode 100644 index 000000000..11f9bf313 --- /dev/null +++ b/verification/whir/Whir/WHIRSourceCatalog.lean @@ -0,0 +1,470 @@ +import Whir.WHIRPhysicalCaller +import Whir.WHIRSourceFrozenPrefix +import Whir.WHIRObservableSource + +/-! The concrete source resolver's immutable catalog is obtained from actual +compiler allocations, including allocations caused by early raw prequeries. +Source annotations never install claims. A successful original caller forces +all allocations at its entry to decode the same request; consequently its first +registration cannot be a permanent rejection. -/ +namespace Whir.WHIRSourceCatalog +open FiatShamirGame DuplexModeGame RawOracleCoupling RawOracleCoupling.Concrete +open WHIRCallerRegistry WHIRRawReplay CausalBindingState +open TypedOracleCompiler +open RawWHIRKeys (Packet) +set_option maxHeartbeats 1600000 + +variable {cap : Nat} + +@[simp] theorem registerRoot_entries (s : State cap) (root : Digest32) : + (registerRoot s root).entries = s.entries := by + unfold registerRoot + split <;> rfl + +@[simp] theorem registerRoots_entries (s : State cap) (roots : List Digest32) : + (registerRoots s roots).entries = s.entries := by + induction roots generalizing s with + | nil => rfl + | cons root rest ih => exact (ih _).trans (registerRoot_entries s root) + +@[simp] theorem observe_entries (s : State cap) (input : List Byte) (value : Digest32) : + (observe s input value).entries = s.entries := by + unfold observe + split <;> rfl + +@[simp] theorem observeRecords_entries (s : State cap) (records : MerkleTransport.Commitments.Records) : + (WHIRSourceChronology.observeRecords s records).entries = s.entries := by + induction records generalizing s with + | nil => rfl + | cons record rest ih => exact (ih _).trans (observe_entries _ _ _) + +@[simp] theorem replayTracked_entries (s : State cap) (events : List (WHIRSourceChronology.Event cap)) : + (WHIRSourceObserver.replayTracked s events).entries = s.entries := by + induction events generalizing s with + | nil => rfl + | cons event rest ih => + unfold WHIRSourceObserver.replayTracked + cases event with + | answer query answer => + cases query with + | primitive purpose input => + simp only [WHIRSourceChronology.step,ih,WHIRSourceChronology.observePublic,observeRecords_entries] + | construction coordinate valid => exact ih s + | commit root => + simp only [WHIRSourceChronology.step,ih,registerRoot_entries] + | claims profile entry request => + cases h : MerkleTransport.Commitments.lookup request.root s.registry <;> + simp only [WHIRSourceChronology.step,h,ih] + +@[simp] theorem publicBefore_entries {R : Type} (registry : Public) (Q : Nat) + (result : WHIRSourceChronology.Result cap R) (s : State cap) (key : AllocationKey (context registry) Q) : + (WHIRSourceResolver.publicBefore registry Q result s key).state.entries = s.entries := by + simp [WHIRSourceResolver.publicBefore,WHIRSourceObserver.publicReplay] + +@[simp] theorem privateBefore_entries {R : Type} (registry : Public) (Q : Nat) + (seed : DuplexPublicSimulator.Seed) (source : WHIRSourceChronology.Source cap R) + (counted : WHIRSourceChronology.Counts Q source) (s : State cap) (key : AllocationKey (context registry) Q) : + (WHIRSourceResolver.privateBefore registry Q seed source counted s key).state.entries = s.entries := by + simp [WHIRSourceResolver.privateBefore,WHIRSourceObserver.privateReplay] + +@[simp] theorem after_entries (registry : Public) (Q : Nat) (s : State cap) + (key : AllocationKey (context registry) Q) (answer : AllocationAnswer (context registry) Q key) : + (WHIRSourceResolver.after registry Q s key answer).state.entries = s.entries := rfl + +/-- A conditional invariant, proved below from the empty state rather than +assumed of a catalog. Its commitment is the original immutable root capture. -/ +private def EntryCorrect (s : State cap) (p : ParameterBounds.Profile) (entry : FramedHistory) + (request : ClaimRequest cap p) : Prop := + ∀ data, s.entries p entry = some data → + data = some (bindClaims (capture s p request.root request.lanes request.lane_bound) request.claims) ∧ + ∃ snap, MerkleTransport.Commitments.lookup request.root s.registry = some snap + +private theorem correct_transport {s t : State cap} (growth : Extends s t) + (p : ParameterBounds.Profile) (entry : FramedHistory) (request : ClaimRequest cap p) + (same : t.entries p entry = s.entries p entry) (correct : EntryCorrect s p entry request) : + EntryCorrect t p entry request := by + intro data found + obtain ⟨equal,snap,known⟩ := correct data (same ▸ found) + refine ⟨?_,snap,growth.registry _ _ known⟩ + rw [equal,capture_stable growth p request.root request.lanes request.lane_bound snap known] + +private theorem prepareClaims_other (s : State cap) (p q : ParameterBounds.Profile) + (entry other : FramedHistory) (key : StackWHIRReplay.Key q) (request : Option (ClaimRequest cap q)) + (different : q ≠ p ∨ other ≠ entry) : + (prepareClaims s q other key request).1.entries p entry = s.entries p entry := by + have registered (s : State cap) (data : Option (WHIRFiatShamir.StackInitial q cap)) : + (registerStatement s q other data).entries p entry = s.entries p entry := by + unfold registerStatement + split + · rfl + · rcases different with profile | entered + · simp [Function.update_of_ne (Ne.symm profile)] + · by_cases profile : p = q + · subst q + simp [Function.update_of_ne (Ne.symm entered)] + · simp [Function.update_of_ne profile] + cases request <;> + simp only [prepareClaims,prepare,registerFootprint,registerRoots_entries,registered, + commit,registerRoot_entries] + +private theorem prepareClaims_correct (s : State cap) (p : ParameterBounds.Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (request : ClaimRequest cap p) + (correct : EntryCorrect s p entry request) : + EntryCorrect (prepareClaims s p entry key (some request)).1 p entry request := by + let committed := commit s p request.root request.lanes request.lane_bound + let next := (prepareClaims s p entry key (some request)).1 + have growth : Extends committed.1 next := prepare_extends _ _ _ _ _ + have captureEq : committed.2 = capture next p request.root request.lanes request.lane_bound := + commit_persists s p request.root request.lanes request.lane_bound next growth + have same : next.entries p entry = some (selected committed.1 p entry + (some (bindClaims committed.2 request.claims))) := + (prepare committed.1 p entry key (some (bindClaims committed.2 request.claims))).2.found + intro data found + have dataEq := Option.some.inj (found.symm.trans same) + cases old : s.entries p entry with + | none => + have fresh : committed.1.entries p entry = none := by simpa [committed,commit] using old + rw [dataEq,selected,fresh,Option.getD_none,captureEq] + obtain ⟨snap,known⟩ := registerRoot_known s request.root + exact ⟨rfl,snap,growth.registry _ _ known⟩ + | some previous => + have oldNext := (prepareClaims_extends s p entry key (some request)).entries p entry previous old + have equal : previous = data := Option.some.inj (oldNext.symm.trans found) + obtain ⟨value,snap,known⟩ := correct previous old + rw [← equal] + exact ⟨value.trans (congrArg (fun c => some (bindClaims c request.claims)) + (capture_stable (prepareClaims_extends s p entry key (some request)) p request.root + request.lanes request.lane_bound snap known)), + snap,(prepareClaims_extends s p entry key (some request)).registry _ _ known⟩ + +private theorem prepare_correct {R : Type} (registry : Public) (Q : Nat) + (result : WHIRSourceChronology.Result cap R) (s : State cap) + (p : ParameterBounds.Profile) (entry : FramedHistory) (request : ClaimRequest cap p) + (key : AllocationKey (context registry) Q) + (agrees : ∀ packet, key.1 = .inl packet → packet.val.profile = p → + callerEntry (context registry) Q packet = entry → + HEq (packetRequest registry Q cap packet key.2) (some request)) + (correct : EntryCorrect s p entry request) : + EntryCorrect (WHIRCausalRawROM.prepare (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result) s key).1 p entry request := by + let prior := (WHIRSourceResolver.publicBefore registry Q result s key).state + have priorCorrect : EntryCorrect prior p entry request := + correct_transport (WHIRSourceResolver.publicBefore registry Q result s key).growth p entry request + (congrFun (congrFun (publicBefore_entries registry Q result s key) p) entry) correct + rcases key with ⟨group,history⟩ + cases group with + | inr raw => exact priorCorrect + | inl packet => + change EntryCorrect (prepareClaims prior packet.val.profile (callerEntry (context registry) Q packet) + (localKey (allocationKey (context registry) rfl Q packet history)) + (packetRequest registry Q cap packet history)).1 p entry request + by_cases profile : packet.val.profile = p + · subst p + by_cases entered : callerEntry (context registry) Q packet = entry + · have equal := eq_of_heq (agrees packet rfl rfl entered) + rw [equal,entered] + exact prepareClaims_correct prior _ entry _ request priorCorrect + · exact correct_transport (prepareClaims_extends ..) _ _ _ + (prepareClaims_other _ _ _ _ _ _ _ (Or.inr entered)) priorCorrect + · exact correct_transport (prepareClaims_extends ..) _ _ _ + (prepareClaims_other _ _ _ _ _ _ _ (Or.inl profile)) priorCorrect + +private theorem evolution_correct {R : Type} (registry : Public) (Q : Nat) + (result : WHIRSourceChronology.Result cap R) + (p : ParameterBounds.Profile) (entry : FramedHistory) (request : ClaimRequest cap p) + {s final : State cap} {raw labeled} + (evolution : (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).Evolves s raw labeled final) + (agrees : ∀ allocation ∈ raw, ∀ packet, allocation.1.1 = .inl packet → packet.val.profile = p → + callerEntry (context registry) Q packet = entry → + HEq (packetRequest registry Q cap packet allocation.1.2) (some request)) + (correct : EntryCorrect s p entry request) : EntryCorrect final p entry request := by + induction evolution with + | nil => exact correct + | cons s key answer tail ih => + apply ih (fun allocation member => agrees allocation (List.mem_cons_of_mem _ member)) + have prepared := prepare_correct registry Q result s p entry request key + (agrees ⟨key,answer⟩ List.mem_cons_self) correct + rcases key with ⟨group,history⟩ + cases group <;> exact prepared + +private theorem prepareClaims_registered (s : State cap) (p : ParameterBounds.Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) : + ∃ data, (prepareClaims s p entry key request).1.entries p entry = some data := by + cases request with + | none => exact ⟨_,(prepare s p entry key none).2.found⟩ + | some request => exact ⟨_,(prepare (commit s p request.root request.lanes request.lane_bound).1 + p entry key (some (bindClaims (commit s p request.root request.lanes request.lane_bound).2 request.claims))).2.found⟩ + +private theorem evolution_registered {R : Type} (registry : Public) (Q : Nat) + (result : WHIRSourceChronology.Result cap R) {s final : State cap} {raw labeled} + (evolution : (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).Evolves s raw labeled final) + (allocation : Sigma (AllocationAnswer (context registry) Q)) (member : allocation ∈ raw) + (packet : Packet (context registry) Q) (packetKey : allocation.1.1 = .inl packet) : + ∃ data, final.entries packet.val.profile (callerEntry (context registry) Q packet) = some data := by + induction evolution with + | nil => cases member + | cons s key answer tail ih => + rcases List.mem_cons.mp member with equal | member + · subst allocation + rcases key with ⟨group,history⟩ + dsimp only at packetKey + subst group + let built := WHIRCausalRawROM.prepare (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result) s (.inl packet,history) + have growth := (WHIRSourceResolver.after registry Q built.1 (.inl packet,history) answer).growth.trans + (WHIRCausalRawROM.evolution_extends (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result) tail) + obtain ⟨data,found⟩ := prepareClaims_registered + (WHIRSourceResolver.publicBefore registry Q result s (.inl packet,history)).state + packet.val.profile (callerEntry (context registry) Q packet) + (localKey (allocationKey (context registry) rfl Q packet history)) + (packetRequest registry Q cap packet history) + exact ⟨data,growth.entries _ _ _ found⟩ + · exact ih member + +/-- Every actual allocation at the same entry uses the same complete warmed +caller dependencies, even if an early raw prequery caused its allocation. -/ +theorem allocation_request {R : Type} {K : Nat} + (registry : Public) (Q cap : Nat) (target packet : Packet (context registry) Q) + (select : R → Option (Packet (context registry) Q)) + (program : Sampling (RawKey Q) (fun _ => Digest32) R K) (table : RawKey Q → Digest32) + (allocation : Sigma (AllocationAnswer (context registry) Q)) + (member : allocation ∈ (Sampling.execute (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q select program)).2) + (key : allocation.1.1 = .inl packet) + (same : callerEntry (context registry) Q packet = callerEntry (context registry) Q target) + (original : Sigma (AllocationAnswer (context registry) Q)) + (originalMember : original ∈ (Sampling.execute + (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q select program)).2) + (originalKey : original.1.1 = .inl target) + (request : ClaimRequest cap target.val.profile) + (decoded : packetRequest registry Q cap target original.1.2 = some request) : + HEq (packetRequest registry Q cap packet allocation.1.2) (some request) := by + have equal := packetRequest_same_entry registry Q cap packet target allocation.1.2 original.1.2 same (by + intro q prior + rw [callerAnswers_table_compile select program table allocation member packet key, + callerAnswers_table_compile select program table original originalMember target originalKey] + have targetPrior : q ∈ WHIRCallerOutputs.callerOutputs (callerEntry (context registry) Q target) := same ▸ prior + change q ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry (context registry) target.val) at targetPrior + simp only [tableCallerAnswers,dite_eq_left prior,dite_eq_left targetPrior] + rfl) + rw [decoded] at equal + exact equal + +/-- Final-catalog existence and unchanged original claims, derived from the +actual compiler's recorded selected packet and causal execution from empty. +No first-registration, catalog consistency, or decoder agreement is assumed. -/ +theorem final_catalog {R S T Seed SimState : Type} {K : Nat} + (registry : Public) (Q cap : Nat) (result : WHIRSourceChronology.Result cap T) + (target : Packet (context registry) Q) (select : R → Option (Packet (context registry) Q)) + (program : Sampling (RawKey Q) (fun _ => Digest32) R K) (table : RawKey Q → Digest32) + (selected : select (tableExecution (context registry) Q select program table).1 = some target) + (sim : Simulator Q Seed SimState) (state : SimState) (source : WHIRSourceChronology.Source cap S) + (remaining : Nat) (limit : remaining ≤ Q) (counted : WHIRSourceChronology.Counts remaining source) + (before after : List Observation) + (sourcePrefix : WHIRSourceChronology.observations + (runIdeal sim table (context registry).iv state (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted)).view.result.events = before ++ after) + (queries : before.map Observation.query = (WHIRModeFinal.callerPositions (context registry) Q target).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible (context registry) Q target q.val q.property))) + (request : ClaimRequest cap target.val.profile) + (decoded : WHIRCallerClaims.decodeAvailableRequest cap target.val.profile + (WHIRCallerClaims.callerLanes (packetLayout registry Q target)) (packetLayout registry Q target) + (callerEntry (context registry) Q target) (WHIRPhysicalCaller.latestAnswers before) = some request) : + let trace := (Sampling.execute (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q select program)).2 + let final := ((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).traceRecode (empty cap) trace).2 + final.catalog target.val.profile (callerEntry (context registry) Q target) = + some (bindClaims (capture final target.val.profile request.root request.lanes request.lane_bound) request.claims) ∧ + ∃ snap, MerkleTransport.Commitments.lookup request.root final.registry = some snap := by + dsimp only + let trace := (Sampling.execute (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q select program)).2 + have run := Sampling.execute_runs (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q select program) + rw [WHIRObservableAllocations.compile_cache] at run + obtain ⟨cached,recorded⟩ := recorded (context registry) Q select program run + rw [selected] at cached + obtain ⟨answer,hit⟩ := cached target (by simp [terminalCompletion,completion]) + have member := (recorded (.inl target) answer hit).2 + have selectedRequest := (WHIRPhysicalCaller.packetRequest_compiled_prefix registry Q cap target + select program table _ member rfl sim state source remaining limit counted before after sourcePrefix queries).trans decoded + have evolution := (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).traceRecode_evolves (empty cap) trace + obtain ⟨data,found⟩ := evolution_registered registry Q result evolution _ member target rfl + have correct := evolution_correct registry Q result target.val.profile + (callerEntry (context registry) Q target) request evolution (by + intro allocation member packet key _ same + exact allocation_request registry Q cap target packet select program table allocation member key same + _ (recorded (.inl target) answer hit).2 rfl request selectedRequest) + (by intro data found; cases found) + obtain ⟨equal,known⟩ := correct data found + refine ⟨?_,known⟩ + change (((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).traceRecode (empty cap) trace).2.entries + target.val.profile (callerEntry (context registry) Q target)).getD none = _ + rw [found,Option.getD_some,equal] + +private theorem prepareClaims_prepared (s : State cap) (p : ParameterBounds.Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) (request : Option (ClaimRequest cap p)) : + Prepared (prepareClaims s p entry key request).1 p key := by + cases request with + | none => exact (prepare s p entry key none).2.prepared + | some request => exact (prepare (commit s p request.root request.lanes request.lane_bound).1 + p entry key (some (bindClaims (commit s p request.root request.lanes request.lane_bound).2 request.claims))).2.prepared + +private theorem evolution_prepared {R : Type} (registry : Public) (Q : Nat) + (result : WHIRSourceChronology.Result cap R) {s final : State cap} {raw labeled} + (evolution : (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).Evolves s raw labeled final) + (allocation : Sigma (AllocationAnswer (context registry) Q)) (member : allocation ∈ raw) + (packet : Packet (context registry) Q) (packetKey : allocation.1.1 = .inl packet) + (past : List (LocalEntry packet.val.profile)) : + Prepared final packet.val.profile ⟨packet.val.statement,packet.val.messages,past⟩ := by + induction evolution with + | nil => cases member + | cons s key answer tail ih => + rcases List.mem_cons.mp member with equal | member + · subst allocation + rcases key with ⟨group,history⟩ + dsimp only at packetKey + subst group + let built := WHIRCausalRawROM.prepare (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result) s (.inl packet,history) + have growth := (WHIRSourceResolver.after registry Q built.1 (.inl packet,history) answer).growth.trans + (WHIRCausalRawROM.evolution_extends (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result) tail) + have prepared := prepareClaims_prepared + (WHIRSourceResolver.publicBefore registry Q result s (.inl packet,history)).state + packet.val.profile (callerEntry (context registry) Q packet) + (localKey (allocationKey (context registry) rfl Q packet history)) + (packetRequest registry Q cap packet history) + intro ref member + obtain ⟨snap,known⟩ := prepared ref member + exact ⟨snap,growth.registry _ _ known⟩ + · exact ih member + +/-- Every root in the selected packet's actual history footprint is registered +in the final causal state. Compiler completion and recorded allocation supply +the witness; neither accepted-catalog nor root-coverage assumptions are needed. +Past answers are arbitrary because preparation depends only on the original +statement and messages, not the supplied replay ancestors. -/ +theorem final_prepared {R T : Type} {K : Nat} + (registry : Public) (Q cap : Nat) (result : WHIRSourceChronology.Result cap T) + (target : Packet (context registry) Q) (select : R → Option (Packet (context registry) Q)) + (program : Sampling (RawKey Q) (fun _ => Digest32) R K) (table : RawKey Q → Digest32) + (selected : select (tableExecution (context registry) Q select program table).1 = some target) + (past : List (LocalEntry target.val.profile)) : + let trace := (Sampling.execute (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q select program)).2 + let final := ((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).traceRecode (empty cap) trace).2 + Prepared final target.val.profile ⟨target.val.statement,target.val.messages,past⟩ := by + have run := Sampling.execute_runs (WHIRObservableAllocations.allocationOracle (context registry) Q table) + (compile (context registry) Q select program) + rw [WHIRObservableAllocations.compile_cache] at run + obtain ⟨cached,recorded⟩ := recorded (context registry) Q select program run + rw [selected] at cached + obtain ⟨answer,hit⟩ := cached target (by simp [terminalCompletion,completion]) + exact evolution_prepared registry Q result + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q result)).traceRecode_evolves (empty cap) _) + _ (recorded (.inl target) answer hit).2 target rfl past + +private theorem real_selected {R : Type} (registry : Public) (Q cap : Nat) + (C : PrimitiveOracle) (source : WHIRSourceChronology.Source cap R) + (counted : WHIRSourceChronology.Counts Q source) + (target : Packet (context registry) Q) (select : R → Option (Packet (context registry) Q)) + (selected : select (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value = some target) : + WHIRObservableSource.selection registry Q select + (tableExecution (context registry) Q (WHIRObservableSource.selection registry Q select) + (WHIRObservableSource.rawProgram registry Q C source counted Q counted) + (WHIRRealSimulator.rawTable Q C)).1 = some target := by + rw [tableExecution_result,WHIRObservableSource.rawProgram_eval] + change select (WHIRObservableSource.execution registry Q (WHIRRealSimulator.rawTable Q C) + C source counted).view.result.value = some target + unfold WHIRObservableSource.execution + rw [← WHIRRealSimulator.real_ideal_view C registry.iv _ ((WHIRSourceChronology.compile_counted source Q).mpr counted)] + exact selected + +/-- Real-execution catalog specialization. The original native caller prefix +and decoder equation are operational certificates; the actual full source +determines the allocation path and selected packet without catalog assumptions. -/ +theorem final_catalog_real {R S : Type} + (registry : Public) (Q cap : Nat) (C : PrimitiveOracle) + (fullSource : WHIRSourceChronology.Source cap R) + (counted : WHIRSourceChronology.Counts Q fullSource) + (target : Packet (context registry) Q) (select : R → Option (Packet (context registry) Q)) + (selected : select (runReal C registry.iv (WHIRSourceChronology.compile fullSource)).view.result.value = some target) + (nativeSource : WHIRSourceChronology.Source cap S) + (nativeCounted : WHIRSourceChronology.Counts Q nativeSource) + (before after : List Observation) + (sourcePrefix : WHIRSourceChronology.observations + (runReal C registry.iv (WHIRSourceChronology.compile nativeSource)).view.result.events = before ++ after) + (queries : before.map Observation.query = (WHIRModeFinal.callerPositions (context registry) Q target).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible (context registry) Q target q.val q.property))) + (request : ClaimRequest cap target.val.profile) + (decoded : WHIRCallerClaims.decodeAvailableRequest cap target.val.profile + (WHIRCallerClaims.callerLanes (packetLayout registry Q target)) (packetLayout registry Q target) + (callerEntry (context registry) Q target) (WHIRPhysicalCaller.latestAnswers before) = some request) : + let final := WHIRSourceFrozenPrefix.replayState registry Q C fullSource counted + (WHIRSourceFrozenPrefix.allocationTrace registry Q select C fullSource) + final.catalog target.val.profile (callerEntry (context registry) Q target) = + some (bindClaims (capture final target.val.profile request.root request.lanes request.lane_bound) request.claims) ∧ + ∃ snap, MerkleTransport.Commitments.lookup request.root final.registry = some snap := by + have idealPrefix : WHIRSourceChronology.observations + (runIdeal (DuplexPublicSimulator.simulator Q) (WHIRRealSimulator.rawTable Q C) (context registry).iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile nativeSource) + Q (Nat.le_refl Q) ((WHIRSourceChronology.compile_counted nativeSource Q).mpr nativeCounted)).view.result.events = + before ++ after := by + rw [← WHIRRealSimulator.real_ideal_view C (context registry).iv _ ((WHIRSourceChronology.compile_counted nativeSource Q).mpr nativeCounted)] + exact sourcePrefix + have result := final_catalog registry Q cap + (runReal C registry.iv (WHIRSourceChronology.compile fullSource)).view.result target + (WHIRObservableSource.selection registry Q select) + (WHIRObservableSource.rawProgram registry Q C fullSource counted Q counted) + (WHIRRealSimulator.rawTable Q C) (real_selected registry Q cap C fullSource counted target select selected) + (DuplexPublicSimulator.simulator Q) ((DuplexPublicSimulator.simulator Q).initial C) + nativeSource Q (Nat.le_refl Q) nativeCounted before after idealPrefix queries request decoded + have traceEq : + (Sampling.execute (WHIRObservableAllocations.allocationOracle (context registry) Q (WHIRRealSimulator.rawTable Q C)) + (compile (context registry) Q (WHIRObservableSource.selection registry Q select) + (WHIRObservableSource.rawProgram registry Q C fullSource counted Q counted))).2 = + WHIRSourceFrozenPrefix.allocationTrace registry Q select C fullSource := + WHIRSourceFrozenPrefix.allocationTrace_compiler registry Q select C fullSource counted Q counted + dsimp only at result + rw [traceEq,WHIRSourceFrozenPrefix.public_replayState] at result + exact result + +/-- Real full-source execution registers the entire selected packet footprint; +the lookup witnesses come from compiler preparation, even for early prequeries. -/ +theorem final_prepared_real {R : Type} + (registry : Public) (Q cap : Nat) (C : PrimitiveOracle) + (fullSource : WHIRSourceChronology.Source cap R) + (counted : WHIRSourceChronology.Counts Q fullSource) + (target : Packet (context registry) Q) (select : R → Option (Packet (context registry) Q)) + (selected : select (runReal C registry.iv (WHIRSourceChronology.compile fullSource)).view.result.value = some target) + (past : List (LocalEntry target.val.profile)) : + let final := WHIRSourceFrozenPrefix.replayState registry Q C fullSource counted + (WHIRSourceFrozenPrefix.allocationTrace registry Q select C fullSource) + Prepared final target.val.profile ⟨target.val.statement,target.val.messages,past⟩ := by + have result := final_prepared registry Q cap + (runReal C registry.iv (WHIRSourceChronology.compile fullSource)).view.result target + (WHIRObservableSource.selection registry Q select) + (WHIRObservableSource.rawProgram registry Q C fullSource counted Q counted) + (WHIRRealSimulator.rawTable Q C) (real_selected registry Q cap C fullSource counted target select selected) past + have traceEq : + (Sampling.execute (WHIRObservableAllocations.allocationOracle (context registry) Q (WHIRRealSimulator.rawTable Q C)) + (compile (context registry) Q (WHIRObservableSource.selection registry Q select) + (WHIRObservableSource.rawProgram registry Q C fullSource counted Q counted))).2 = + WHIRSourceFrozenPrefix.allocationTrace registry Q select C fullSource := + WHIRSourceFrozenPrefix.allocationTrace_compiler registry Q select C fullSource counted Q counted + dsimp only at result + rw [traceEq,WHIRSourceFrozenPrefix.public_replayState] at result + exact result + +end Whir.WHIRSourceCatalog diff --git a/verification/whir/Whir/WHIRSourceComposition.lean b/verification/whir/Whir/WHIRSourceComposition.lean new file mode 100644 index 000000000..a7c689b6d --- /dev/null +++ b/verification/whir/Whir/WHIRSourceComposition.lean @@ -0,0 +1,131 @@ +import Whir.WHIRSourceChronology +import Whir.PrunedMerkleProgram + +namespace Whir.WHIRSourceChronology +open FiatShamirGame DuplexModeGame +open PublicMerkleProgram (Runs) + +/-- Append a trusted continuation without replacing or inventing source events. -/ +def Source.bind : Source cap R → (R → Source cap S) → Source cap S + | .done value, next => next value + | .ask query cont, next => .ask query (fun answer => (cont answer).bind next) + | .commit root cont, next => .commit root (cont.bind next) + | .claims profile entry request cont, next => .claims profile entry request (cont.bind next) + +def Source.map (source : Source cap R) (f : R → S) : Source cap S := + source.bind (fun value => .done (f value)) + +theorem Source.erase_bind (source : Source cap R) (next : R → Source cap S) : + erase (source.bind next) = WHIRModeFinal.bind (erase source) (fun value => erase (next value)) := by + induction source with + | done => rfl + | ask query cont ih => + simp only [Source.bind,erase,WHIRModeFinal.bind] + congr 1 + funext answer + exact ih answer + | commit root cont ih => exact ih + | claims profile entry request cont ih => exact ih + +theorem Source.counts_mono {source : Source cap R} {a b : Nat} + (counted : Counts a source) (bound : a ≤ b) : Counts b source := + (erase_counted source b).mp (WHIRModeFinal.counts_mono ((erase_counted source a).mpr counted) bound) + +theorem Source.bind_counted (source : Source cap R) (next : R → Source cap S) (a b : Nat) + (before : Counts a source) (after : ∀ value, Counts b (next value)) : Counts (a+b) (source.bind next) := by + apply (erase_counted _ _).mp + rw [Source.erase_bind] + exact WHIRModeFinal.bind_counted _ _ a b ((erase_counted _ _).mpr before) + (fun value => (erase_counted _ _).mpr (after value)) + +theorem Source.bind_prefix_counted (source : Source cap R) (next : R → Source cap S) (budget : Nat) + (counted : Counts budget (source.bind next)) : Counts budget source := by + apply (erase_counted _ _).mp + apply WHIRModeFinal.bind_prefix_counted (erase source) (fun value => erase (next value)) budget + rw [← Source.erase_bind] + exact (erase_counted _ _).mpr counted + +/-- A real branch of a counted bind inherits the same upper bound for its +trusted continuation; no bound on unreachable result values is required. -/ +theorem Source.bind_suffix_counted (source : Source cap R) (next : R → Source cap S) + (budget : Nat) (trace : List Observation) (value : R) + (run : Runs (erase source) trace value) (counted : Counts budget (source.bind next)) : + Counts budget (next value) := by + induction source generalizing budget trace with + | done result => + cases run + exact counted + | ask query cont ih => + cases run with + | ask answer later => + exact Source.counts_mono (ih answer (budget-query.cost) _ later (counted.2 answer)) + (Nat.sub_le budget query.cost) + | commit root cont ih => exact ih budget trace run counted + | claims profile entry request cont ih => exact ih budget trace run counted + +theorem observations_append (before after : List (Event cap)) : + observations (before ++ after) = observations before ++ observations after := by + induction before with + | nil => rfl + | cons event rest ih => cases event <;> simp only [List.cons_append,observations,ih] + +theorem Source.map_counted (source : Source cap R) (f : R → S) (budget : Nat) : + Counts budget (source.map f) ↔ Counts budget source := by + constructor + · exact Source.bind_prefix_counted source _ budget + · intro counted + exact Source.bind_counted source (fun value => .done (f value)) budget 0 counted (fun _ => trivial) + +/-- An arbitrary prefix can choose inputs, but a successful continuation must +execute as a genuine suffix of the same public observation trace. -/ +theorem Source.erased_bind_runs (source : Source cap R) (next : R → Source cap S) + (trace : List Observation) (result : S) : + Runs (erase (source.bind next)) trace result ↔ + ∃ before value after, trace = before ++ after ∧ + Runs (erase source) before value ∧ Runs (erase (next value)) after result := by + rw [Source.erase_bind] + exact Runs.bind_iff _ _ + +/-- The successful real continuation is also a literal compiler-owned source +event segment, including commitment announcements and claim-read events. -/ +theorem Source.real_bind (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap R) (next : R → Source cap S) : + (runReal C iv (compile (source.bind next))).view.result = + let before := (runReal C iv (compile source)).view.result + let after := (runReal C iv (compile (next before.value))).view.result + ⟨after.value,before.events ++ after.events⟩ := by + induction source with + | done => rfl + | ask query cont ih => + simpa only [Source.bind,compile,runReal,map_real,mapExecution,DuplexModeGame.prepend,prepend,List.cons_append] + using congrArg (prepend (.answer query (realAnswer C iv query))) (ih (realAnswer C iv query)) + | commit root cont ih => + simpa only [Source.bind,compile,map_real,mapExecution,prepend,List.cons_append] + using congrArg (prepend (.commit root)) ih + | claims profile entry request cont ih => + simpa only [Source.bind,compile,map_real,mapExecution,prepend,List.cons_append] + using congrArg (prepend (.claims profile entry request)) ih + +theorem Source.erased_map_runs (source : Source cap R) (f : R → S) + (trace : List Observation) (result : S) : + Runs (erase (source.map f)) trace result ↔ + ∃ value, Runs (erase source) trace value ∧ f value = result := by + rw [Source.map,Source.erased_bind_runs] + constructor + · rintro ⟨before,value,after,equal,first,last⟩ + cases last + simp only [List.append_nil] at equal + subst trace + exact ⟨value,first,rfl⟩ + · rintro ⟨value,first,rfl⟩ + exact ⟨trace,value,[],by simp,first,.done _⟩ + +theorem Source.real_map (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap R) (f : R → S) : + (runReal C iv (compile (source.map f))).view.result = + let before := (runReal C iv (compile source)).view.result + ⟨f before.value,before.events⟩ := by + rw [Source.map,Source.real_bind] + simp only [compile,runReal,List.append_nil] + +end Whir.WHIRSourceChronology diff --git a/verification/whir/Whir/WHIRSourceFrozenPrefix.lean b/verification/whir/Whir/WHIRSourceFrozenPrefix.lean new file mode 100644 index 000000000..27b6d4ea9 --- /dev/null +++ b/verification/whir/Whir/WHIRSourceFrozenPrefix.lean @@ -0,0 +1,1411 @@ +import Whir.WHIRSourceRootPolicy +import Whir.WHIRPhysicalSnapshots +import Whir.WHIRSourceResolver +import Whir.WHIRRealSimulator +import Whir.WHIRObservableAllocations +import Whir.WHIRSourcePartialMonotone +import Whir.WHIRSourceAllocationOrigin +import Whir.WHIRSourceAllocationCache +import Whir.WHIRSourceBackfill +import Whir.WHIRSourceRawProgram + +/-! Actual-source first-freeze provenance for the shared compression experiment. + +`actual_backfill_retained` constructs the historical/full-C-prefix, ordinary +tag-zero saturation, root-policy membership, retained-record authenticity and +table-domain fields needed by `PublicMerkleProbability.FrozenOpeningBad`. +No root-cover or verifier-correctness premise is introduced. + +`allocationTrace_compiler` identifies the analyzed allocation path with the +source-budgeted raw compiler, including caller/ancestor warming and selected +final backfill. `public_replayState` identifies its chosen real seed/raw-table +resolver state with the public event-only resolver. The first-freeze induction +skips settled repeated prefixes before appending newly observed source events; +it never recaptures an old root at a later cursor. Pending roots come from input +headers and encoded footprints, never the fresh reply. Source errors remain +recorded but do not suppress later C observations. + +Full-C expansion retains repeated calls and hidden construction internals. +Public-log transport uses membership, not equality with the observer log. +This is deterministic provenance, not an additional probability assumption. -/ +namespace Whir.WHIRSourceFrozenPrefix +open FiatShamirGame DuplexModeGame DuplexFraming PublicCompressionProgram +open WHIRSourceChronology WHIRSourceRootPolicy WHIRCallerRegistry +open PublicMerkleLog + +variable {cap : Nat} {R : Type} + +/-- Every answered mode observation contributes its complete actual C execution. -/ +def expand (C : PrimitiveOracle) (iv : Digest32) (seen : List Observation) : PublicLog := + seen.flatMap fun o => toLog (TypedOracleCompiler.Sampling.execute C (queryCalls iv o.query)).2 + +theorem expand_append (C : PrimitiveOracle) (iv : Digest32) (a b : List Observation) : + expand C iv (a ++ b) = expand C iv a ++ expand C iv b := by + simp [expand] + +theorem expand_real (C : PrimitiveOracle) (iv : Digest32) (p : Program R) + (Q : Nat) (counted : DuplexModeGame.Counts Q p) : + expand C iv (runReal C iv p).view.observations = primitiveLog C iv p Q counted := by + induction p generalizing Q with + | done => rfl + | ask q next ih => + simp only [runReal,DuplexModeGame.prepend,expand,List.flatMap_cons, + primitiveLog,PublicCompressionProgram.compile,TypedOracleCompiler.Sampling.execute_pad, + TypedOracleCompiler.Sampling.execute_bind,execute_mapResult,toLog,List.map_append, + queryCalls_eval] + exact congrArg (_ ++ ·) (ih (realAnswer C iv q) (Q-q.cost) (counted.2 _)) + +/-- An actual partial raw replay ends at a mode-query boundary, hence before +all C calls of the still unanswered mode query. No query answer is invented. -/ +theorem observation_prefix (C : PrimitiveOracle) (iv : Digest32) (p : Program R) + (Q : Nat) (counted : DuplexModeGame.Counts Q p) (seen : List Observation) + (initial : seen.IsPrefix (runReal C iv p).view.observations) : + (expand C iv seen).IsPrefix (primitiveLog C iv p Q counted) := by + obtain ⟨suffix,eq⟩ := initial + refine ⟨expand C iv suffix,?_⟩ + rw [← expand_append,eq,expand_real] + +theorem private_observation_prefix (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap R) (Q : Nat) (counted : WHIRSourceChronology.Counts Q source) + (cache : RawKey Q → Option Digest32) + (agrees : DuplexPublicSimulator.CacheAgrees cache (WHIRRealSimulator.rawTable Q C)) : + (DuplexPublicSimulator.runPartial cache iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (Nat.le_refl Q) ((compile_counted source Q).mpr counted)).observations.IsPrefix + (runReal C iv (WHIRSourceChronology.compile source)).view.observations := by + obtain ⟨suffix,eq⟩ := DuplexPublicSimulator.runPartial_prefix cache + (WHIRRealSimulator.rawTable Q C) agrees iv ((DuplexPublicSimulator.simulator Q).initial C) + (WHIRSourceChronology.compile source) Q (Nat.le_refl Q) ((compile_counted source Q).mpr counted) + rw [WHIRRealSimulator.real_ideal_view C iv _ ((compile_counted source Q).mpr counted)] + exact ⟨suffix,eq.symm⟩ + +theorem private_fullC_prefix (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap R) (Q : Nat) (counted : WHIRSourceChronology.Counts Q source) + (cache : RawKey Q → Option Digest32) + (agrees : DuplexPublicSimulator.CacheAgrees cache (WHIRRealSimulator.rawTable Q C)) : + (expand C iv (DuplexPublicSimulator.runPartial cache iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (Nat.le_refl Q) ((compile_counted source Q).mpr counted)).observations).IsPrefix + (primitiveLog C iv (WHIRSourceChronology.compile source) Q + ((compile_counted source Q).mpr counted)) := + observation_prefix C iv _ Q _ _ (private_observation_prefix C iv source Q counted cache agrees) + +/-- All tag-zero calls in the expanded prefix are actual visible primitive +observations. Hidden construction calls cannot contribute an ordinary node. -/ +theorem ordinary_expand (C : PrimitiveOracle) (iv : Digest32) (seen : List Observation) + (real : ∀ o ∈ seen, o.answer = realAnswer C iv o.query) + (n : Node) (d : Digest32) (member : (n,d) ∈ expand C iv seen) (ordinary : tag n = 0) : + ∃ purpose, (⟨.primitive purpose n,d⟩ : Observation) ∈ seen := by + obtain ⟨o,ho,hm⟩ := List.mem_flatMap.mp member + cases o with + | mk q answer => + cases q with + | primitive purpose input => + simp only [queryCalls,TypedOracleCompiler.Sampling.execute,toLog,List.map_cons, + List.map_nil,List.mem_cons,List.not_mem_nil,or_false,Prod.mk.injEq] at hm + rcases hm with ⟨rfl,rfl⟩ + have ha := real ⟨.primitive purpose n,answer⟩ ho + change answer = C n at ha + subst answer + exact ⟨purpose,ho⟩ + | construction q valid => + have positive := construction_tags C iv q valid n d hm + omega + +/-- Public observations are not fabricated by expansion, even with repeated inputs. -/ +theorem primitive_expand (C : PrimitiveOracle) (iv : Digest32) (seen : List Observation) + (real : ∀ o ∈ seen, o.answer = realAnswer C iv o.query) + (purpose : Purpose) (n : Node) (d : Digest32) + (member : (⟨.primitive purpose n,d⟩ : Observation) ∈ seen) : + (n,d) ∈ expand C iv seen := by + have hd := real ⟨.primitive purpose n,d⟩ member + change d = C n at hd + subst d + apply List.mem_flatMap.mpr + exact ⟨⟨.primitive purpose n,C n⟩,member,by simp [queryCalls,TypedOracleCompiler.Sampling.execute,toLog]⟩ + +/-- Finite C replay may run farther than a mode prefix when queries repeat. +Membership, unlike equality of recovered event lists, remains valid. -/ +theorem recover_capture (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (seen : List Observation) + (initial : seen.IsPrefix (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations) + (log : PublicLog) (auth : AuthenticLog C log) + (available : ∀ e ∈ expand C registry.iv seen, e ∈ log) + (visible : PublicLog) : + ∀ root ∈ capture registry Q select (recover source seen) visible, + root ∈ scan registry Q select log source visible := by + induction source generalizing seen visible with + | done value => + simp [WHIRSourceChronology.recover,capture,eventRoots,visibleAfter,scan] + | commit root next ih => + have initial' : seen.IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile next)).view.observations := by + simpa only [WHIRSourceChronology.compile,map_real,mapExecution] using initial + intro r member + simp only [WHIRSourceChronology.recover,prependPrefix,capture,eventRoots,visibleAfter, + List.cons_append,List.mem_cons] at member + change r ∈ root :: scan registry Q select log next visible + rcases member with same | later + · exact List.mem_cons.mpr (Or.inl same) + · exact List.mem_cons_of_mem _ (ih seen initial' available visible r later) + | claims p entry request next ih => + have initial' : seen.IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile next)).view.observations := by + simpa only [WHIRSourceChronology.compile,map_real,mapExecution] using initial + simpa only [WHIRSourceChronology.recover,prependPrefix,capture,eventRoots,visibleAfter,scan] using + ih seen initial' available visible + | ask q next ih => + cases seen with + | nil => + intro root member + have hm : root ∈ queryRoots registry Q visible q := by + simpa [WHIRSourceChronology.recover,capture,eventRoots,visibleAfter] using member + simp only [scan] + exact List.mem_append_left _ hm + | cons o rest => + obtain ⟨suffix,eq⟩ := initial + have split : o = ⟨q,realAnswer C registry.iv q⟩ ∧ + rest ++ suffix = (runReal C registry.iv + (WHIRSourceChronology.compile (next (realAnswer C registry.iv q)))).view.observations := by + simpa only [WHIRSourceChronology.compile,runReal,map_real,mapExecution, + DuplexModeGame.prepend,List.cons_append,List.cons.injEq] using eq + rcases split with ⟨rfl,tail⟩ + have answer : queryReply registry.iv log q = some (realAnswer C registry.iv q) := by + rw [queryReply,← queryCalls_eval C registry.iv q] + apply partialEval_complete C log auth + intro e he + exact available e (List.mem_append_left _ he) + have recur := ih (realAnswer C registry.iv q) rest ⟨suffix,tail⟩ + (fun e he => available e (List.mem_append_right _ he)) + (advance visible q (realAnswer C registry.iv q)) + intro root member + have hm : root ∈ queryRoots registry Q visible q ++ + capture registry Q select (recover (next (realAnswer C registry.iv q)) rest) + (advance visible q (realAnswer C registry.iv q)) := by + simpa only [WHIRSourceChronology.recover,prependPrefix,capture,eventRoots,visibleAfter,List.append_assoc] using member + simp only [scan,answer] + rcases List.mem_append.mp hm with first | later + · exact List.mem_append_left _ first + · exact List.mem_append_right _ (recur root later) + +/-- Concrete root capture at the actual all-C prefix, including zero-cost +commits, the pending request input, and final selection before backfill. -/ +theorem source_prefix_captured (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (seen : List Observation) + (initial : seen.IsPrefix (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations) + (root : Digest32) (member : root ∈ capture registry Q select (recover source seen) []) : + root ∈ policy registry Q select source (expand C registry.iv seen).reverse := by + have hp := observation_prefix C registry.iv _ Q ((compile_counted source Q).mpr counted) seen initial + have authentic : AuthenticLog C (expand C registry.iv seen).reverse := by + intro n d hd + exact primitiveLog_authentic C registry.iv _ Q ((compile_counted source Q).mpr counted) + n d (WHIRPhysicalSnapshots.prefix_mem hp (List.mem_reverse.mp hd)) + apply scan_captured + exact recover_capture registry Q select C source seen initial _ authentic + (fun _ he => List.mem_reverse.mpr he) [] root member + +/-- A successfully parsed first header is unchanged by appending later frames. -/ +theorem header_append (registry : Public) (entry : FramedHistory) + (header : WHIRHeaderRoots.Header) + (parsed : WHIRHeaderRoots.fromHistory registry entry = some header) + (suffix : List Frame) : + WHIRHeaderRoots.fromHistory registry {entry with frames := entry.frames ++ suffix} = + some header := by + obtain ⟨domain,statement,layout,selected,root⟩ := + WHIRHeaderRoots.fromHistory_sound registry entry header parsed + have extended := WHIRHeaderRoots.initialRoot_append layout entry header.root root suffix + simpa only [← statement] using WHIRHeaderRoots.fromHistory_selected registry + {entry with frames := entry.frames ++ suffix} layout header.profile header.root domain selected extended + +/-- Every warmed caller's parsed header was already present in the packet input, +not in the answer subsequently assigned to that caller group. -/ +theorem caller_header_packet (registry : Public) (Q : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (raw : {raw : RawKey Q // RawWHIRKeys.Garbage (context registry) Q raw}) + (member : raw ∈ RawWHIRKeys.callerGroups (context registry) Q packet) + (header : WHIRHeaderRoots.Header) + (parsed : WHIRHeaderRoots.rawHeader registry raw.val = some header) : + WHIRHeaderRoots.packetHeader registry Q packet = some header := by + obtain ⟨⟨q,hq⟩,_,rfl⟩ := List.mem_map.mp member + have decoded := WHIRHeaderRoots.decodeRaw_callerOutputKey (context registry) Q packet q hq + change WHIRHeaderRoots.decodeRaw registry.iv + (RawWHIRKeys.callerOutputKey (context registry) Q packet q hq).val = some q at decoded + have first : WHIRHeaderRoots.fromHistory registry q.history = some header := by + simpa only [WHIRHeaderRoots.rawHeader,decoded,Option.bind_some] using parsed + obtain ⟨pre,f,suffix,block,split,_,rfl⟩ := + WHIRCallerOutputs.callerOutputs_mem (RawWHIRKeys.entry (context registry) packet.val) q hq + have extended := header_append registry _ header first (f :: suffix) + simpa only [WHIRHeaderRoots.packetHeader,← split] using extended + +theorem ancestor_header_packet (registry : Public) (Q : Nat) + (packet ancestor : RawWHIRKeys.Packet (context registry) Q) + (member : ancestor ∈ RawWHIRKeys.ancestors (context registry) Q packet) : + WHIRHeaderRoots.packetHeader registry Q ancestor = WHIRHeaderRoots.packetHeader registry Q packet := by + obtain ⟨i,rfl⟩ := List.mem_ofFn.mp member + rfl + +/-- A header frozen by any dependency allocation is an input root of its initiating +packet, including caller-output and ancestor allocations. -/ +theorem completion_header_member (registry : Public) (Q : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (key : RawOracleCoupling.Concrete.AllocationKey (context registry) Q) + (member : key.1 ∈ WHIRPublicBackfill.completionKeys (context registry) Q packet) + (root : Digest32) (captured : root ∈ WHIRHeaderRoots.allocationRoots registry Q key) : + root ∈ packetRoots registry Q packet := by + rcases key with ⟨group,history⟩ + cases group with + | inl allocated => + have packets : allocated ∈ RawWHIRKeys.ancestors (context registry) Q packet ∨ allocated = packet := by + let callers : List (RawOracleCoupling.Concrete.partition (context registry) Q).Garbage := + RawWHIRKeys.callerGroups (context registry) Q packet + change Sum.inl allocated ∈ + (callers.map Sum.inr ++ + (RawWHIRKeys.ancestors (context registry) Q packet).map Sum.inl) ++ [Sum.inl packet] at member + rcases List.mem_append.mp member with deps | self + · rcases List.mem_append.mp deps with caller | ancestor + · obtain ⟨raw,_,equal⟩ := List.mem_map.mp caller + cases equal + · obtain ⟨a,ha,equal⟩ := List.mem_map.mp ancestor + cases Sum.inl.inj equal + exact Or.inl ha + · exact Or.inr (Sum.inl.inj (List.mem_singleton.mp self)) + have same : WHIRHeaderRoots.packetHeader registry Q allocated = + WHIRHeaderRoots.packetHeader registry Q packet := by + rcases packets with ancestor | rfl + · exact ancestor_header_packet registry Q packet allocated ancestor + · rfl + apply List.mem_append_left + simpa only [WHIRHeaderRoots.allocationRoots,WHIRHeaderRoots.allocationRoot, + WHIRHeaderRoots.allocationHeader,same,Option.toList_map] using captured + | inr raw => + have caller : raw ∈ RawWHIRKeys.callerGroups (context registry) Q packet := by + let callers : List (RawOracleCoupling.Concrete.partition (context registry) Q).Garbage := + RawWHIRKeys.callerGroups (context registry) Q packet + have hm : (Sum.inr raw : RawOracleCoupling.Concrete.GroupKey (context registry) Q) ∈ + callers.map Sum.inr := by + simpa [WHIRPublicBackfill.completionKeys,RawOracleCoupling.Concrete.dependencyKeys, + RawOracleCoupling.Partition.dependencies,RawOracleCoupling.Concrete.schedule, + RawOracleCoupling.Concrete.callerPlan,callers,RawWHIRKeys.Garbage] using member + obtain ⟨other,member,equal⟩ := List.mem_map.mp hm + cases Sum.inr.inj equal + exact member + have parsed : ∃ header, WHIRHeaderRoots.rawHeader registry raw.val = some header ∧ header.root = root := by + simpa [WHIRHeaderRoots.allocationRoots,WHIRHeaderRoots.allocationRoot, + WHIRHeaderRoots.allocationHeader,Option.mem_toList,Option.map_eq_some_iff] using captured + obtain ⟨header,parsed,rfl⟩ := parsed + exact packet_header_member registry Q packet header + (caller_header_packet registry Q packet raw caller header parsed) + +/-- A recognized raw packet already contains its caller header before the raw +compression answer; completed dependencies never introduce a reply-derived root. -/ +theorem recognized_header_member (registry : Public) (Q : Nat) + (raw : RawKey Q) (pos : RawWHIRKeys.Position (context registry) Q) + (recognized : RawWHIRKeys.recognize (context registry) Q raw = some pos) + (header : WHIRHeaderRoots.Header) + (parsed : WHIRHeaderRoots.packetHeader registry Q pos.1 = some header) : + header.root ∈ rawRoots registry Q raw := by + apply raw_header_member + rw [← RawWHIRKeys.encode_recognize (context registry) Q raw pos recognized] + have extended := header_append registry (RawWHIRKeys.entry (context registry) pos.1.val) + header parsed (WHIRHistoryKey.canonicalFrames (RawWHIRKeys.width (context registry).mode pos.1.val.profile) + pos.1.val.messages) + have whole : WHIRHeaderRoots.fromHistory registry + (RawWHIRKeys.coordinate (context registry) pos.1.val pos.2.val).history = some header := extended + change Option.map WHIRHeaderRoots.Header.root + (WHIRHeaderRoots.rawHeader registry + (constructionKey Q registry.iv (RawWHIRKeys.coordinate (context registry) pos.1.val pos.2.val) _)) = + some header.root + rw [WHIRHeaderRoots.rawHeader_construction registry + (RawWHIRKeys.coordinate (context registry) pos.1.val pos.2.val) + (RawWHIRKeys.coordinate_admissible (context registry) Q pos) _ header whole] + rfl + +theorem observations_append (a b : List (Event cap)) : + observations (a ++ b) = observations a ++ observations b := by + induction a with + | nil => rfl + | cons event rest ih => + cases event <;> simp only [List.cons_append,observations,ih,List.cons_append] + +/-- Source commitments are captured at their own event position, not at the +end of the repeated observer replay that happens to discover them. -/ +theorem commit_event_capture (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) + (past future : List (Event cap)) (root : Digest32) + (split : (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events = + past ++ .commit root :: future) (visible : PublicLog) : + root ∈ capture registry Q select (recover source (observations past)) visible := by + induction source generalizing past visible with + | done value => + have empty : ([] : List (Event cap)) = past ++ .commit root :: future := split + have := congrArg List.length empty + simp only [List.length_nil,List.length_append,List.length_cons] at this + omega + | commit announced next ih => + simp only [WHIRSourceChronology.compile,map_real,mapExecution,WHIRSourceChronology.prepend] at split + cases past with + | nil => + have head : (Event.commit announced : Event cap) = Event.commit root := by + exact (List.cons.inj split).1 + cases Event.commit.inj head + simp [WHIRSourceChronology.recover,prependPrefix,capture,eventRoots] + | cons event past => + have head : Event.commit announced = event := (List.cons.inj split).1 + subst event + have tail : (runReal C registry.iv (WHIRSourceChronology.compile next)).view.result.events = + past ++ .commit root :: future := (List.cons.inj split).2 + have member := ih past tail visible + simpa only [observations,WHIRSourceChronology.recover,prependPrefix,capture,eventRoots, + visibleAfter,List.cons_append,List.mem_cons] using Or.inr member + | claims profile entry request next ih => + simp only [WHIRSourceChronology.compile,map_real,mapExecution,WHIRSourceChronology.prepend] at split + cases past with + | nil => cases (List.cons.inj split).1 + | cons event past => + have head : Event.claims profile entry request = event := (List.cons.inj split).1 + subst event + have tail : (runReal C registry.iv (WHIRSourceChronology.compile next)).view.result.events = + past ++ .commit root :: future := (List.cons.inj split).2 + simpa only [observations,WHIRSourceChronology.recover,prependPrefix,capture,eventRoots, + visibleAfter] using ih past tail visible + | ask q next ih => + simp only [WHIRSourceChronology.compile,runReal,map_real,mapExecution, + WHIRSourceChronology.prepend,DuplexModeGame.prepend] at split + cases past with + | nil => cases (List.cons.inj split).1 + | cons event past => + have head : Event.answer q (realAnswer C registry.iv q) = event := (List.cons.inj split).1 + subst event + have tail : (runReal C registry.iv + (WHIRSourceChronology.compile (next (realAnswer C registry.iv q)))).view.result.events = + past ++ .commit root :: future := (List.cons.inj split).2 + have member := ih (realAnswer C registry.iv q) past tail + (advance visible q (realAnswer C registry.iv q)) + simpa only [observations,WHIRSourceChronology.recover,prependPrefix,capture,eventRoots, + visibleAfter,List.append_assoc,List.mem_append] using Or.inr member + +theorem event_observation_prefix (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap R) (past : List (Event cap)) + (initial : past.IsPrefix (runReal C iv (WHIRSourceChronology.compile source)).view.result.events) : + (observations past).IsPrefix (runReal C iv (WHIRSourceChronology.compile source)).view.observations := by + obtain ⟨suffix,eq⟩ := initial + refine ⟨observations suffix,?_⟩ + rw [← observations_append,eq,real_source_trace] + +theorem commit_event_policy (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (past future : List (Event cap)) (root : Digest32) + (split : (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events = + past ++ .commit root :: future) : + root ∈ policy registry Q select source (expand C registry.iv (observations past)).reverse := + source_prefix_captured registry Q select C source counted (observations past) + (event_observation_prefix C registry.iv source past ⟨.commit root :: future,split.symm⟩) + root (commit_event_capture registry Q select C source past future root split []) + +/-- Advancing the actual observer cursor never removes a pending input root: +it becomes the corresponding answered event's input root. -/ +theorem capture_mono (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap R) (before after : List Observation) + (initial : before.IsPrefix after) (visible : PublicLog) : + ∀ root ∈ capture registry Q select (recover source before) visible, + root ∈ capture registry Q select (recover source after) visible := by + induction source generalizing before after visible with + | done value => exact fun _ h => h + | commit root next ih => + intro r member + simp only [WHIRSourceChronology.recover,prependPrefix,capture,eventRoots,visibleAfter, + List.cons_append,List.mem_cons] at member ⊢ + exact member.elim Or.inl (fun hm => Or.inr (ih before after initial visible r hm)) + | claims p entry request next ih => + simpa only [WHIRSourceChronology.recover,prependPrefix,capture,eventRoots,visibleAfter] using + ih before after initial visible + | ask q next ih => + cases before with + | nil => + intro root member + have hm : root ∈ queryRoots registry Q visible q := by + simpa [WHIRSourceChronology.recover,capture,eventRoots,visibleAfter] using member + cases after with + | nil => exact member + | cons o rest => + simp only [WHIRSourceChronology.recover,prependPrefix,capture,eventRoots,visibleAfter, + List.append_assoc] + exact List.mem_append_left _ hm + | cons o rest => + obtain ⟨suffix,eq⟩ := initial + subst after + intro root member + simp only [List.cons_append,WHIRSourceChronology.recover,prependPrefix,capture,eventRoots, + visibleAfter,List.append_assoc,List.mem_append] at member ⊢ + have recur := ih o.answer rest (rest ++ suffix) ⟨suffix,rfl⟩ (advance visible q o.answer) root + simp only [capture,List.mem_append] at recur + exact member.elim Or.inl (fun hm => Or.inr (recur hm)) + +/-- All roots registered by preparation of a warmed ancestor are already in +the initiating packet's encoded history footprint. -/ +theorem ancestor_footprint_member (registry : Public) (Q : Nat) + (packet ancestor : RawWHIRKeys.Packet (context registry) Q) + (ancestry : ancestor ∈ RawWHIRKeys.ancestors (context registry) Q packet) + (ref : WHIRSnapshotReplay.RootRef) + (member : ref ∈ WHIRSnapshotReplay.historyFootprint ancestor.val.profile + ancestor.val.statement ancestor.val.messages) : + ref ∈ WHIRSnapshotReplay.historyFootprint packet.val.profile packet.val.statement packet.val.messages := by + obtain ⟨i,rfl⟩ := List.mem_ofFn.mp ancestry + exact WHIRSnapshotReplay.historyFootprint_drop _ _ _ _ ref member + +/-- The historical prefix fields required by `FrozenOpeningBad`. This is an +internal induction invariant; concrete execution theorems construct it from empty. -/ +def Frozen (roots : PublicMerkleProbability.RootPolicy) (trace : PublicLog) + (state : CausalBindingState.State cap) : Prop := + ∀ root snap, MerkleTransport.Commitments.lookup root state.registry = some snap → + ∃ oldLog before after, + state.frozenLog root = some oldLog ∧ trace = before ++ after ∧ + (∀ e ∈ oldLog, e ∈ before) ∧ + (∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ oldLog) ∧ + root ∈ roots before.reverse + +def PublicAt (state : CausalBindingState.State cap) (events : List (Event cap)) : Prop := + ∀ n d, (n,d) ∈ state.publicLog ↔ + ∃ purpose, Event.answer (.primitive purpose n) d ∈ events + +def Committed (state : CausalBindingState.State cap) (events : List (Event cap)) : Prop := + ∀ root, Event.commit root ∈ events → + ∃ snap, MerkleTransport.Commitments.lookup root state.registry = some snap + +theorem frozen_empty (roots : PublicMerkleProbability.RootPolicy) (trace : PublicLog) : + Frozen roots trace (CausalBindingState.empty cap) := by + intro root snap found + simp [CausalBindingState.empty,MerkleTransport.Commitments.lookup] at found + +theorem frozen_fields (roots : PublicMerkleProbability.RootPolicy) (trace : PublicLog) + (state next : CausalBindingState.State cap) (old : Frozen roots trace state) + (registry : next.registry = state.registry) (logs : next.frozenLog = state.frozenLog) : + Frozen roots trace next := by + intro root snap known + obtain ⟨log,before,after,hlog,eq,sub,saturated,captured⟩ := old root snap (registry ▸ known) + exact ⟨log,before,after,logs.symm ▸ hlog,eq,sub,saturated,captured⟩ + +theorem registerRoot_frozen (roots : PublicMerkleProbability.RootPolicy) (trace : PublicLog) + (state : CausalBindingState.State cap) (old : Frozen roots trace state) + (root : Digest32) (before after : PublicLog) (split : trace = before ++ after) + (sub : ∀ e ∈ state.publicLog, e ∈ before) + (saturated : ∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ state.publicLog) + (captured : root ∈ roots before.reverse) : + Frozen roots trace (CausalBindingState.registerRoot state root) := by + unfold CausalBindingState.registerRoot + cases found : MerkleTransport.Commitments.lookup root state.registry with + | some snap => exact old + | none => + intro r snap known + by_cases same : r = root + · subst r + exact ⟨state.publicLog,before,after,by simp,split,sub,saturated,captured⟩ + · have prior : MerkleTransport.Commitments.lookup r state.registry = some snap := by + simpa [MerkleTransport.Commitments.register,found,MerkleTransport.Commitments.lookup,same] using known + obtain ⟨log,earlier,later,hl,eq,hs,ht,hr⟩ := old r snap prior + exact ⟨log,earlier,later,by simpa [Function.update_of_ne same] using hl,eq,hs,ht,hr⟩ + +theorem observation_mem_events (events : List (Event cap)) (q : Query) (d : Digest32) : + (⟨q,d⟩ : Observation) ∈ observations events ↔ Event.answer q d ∈ events := by + induction events with + | nil => simp [observations] + | cons event rest ih => + cases event <;> simp [observations,ih,Observation.mk.injEq] + +theorem publicAt_fullC (C : PrimitiveOracle) (iv : Digest32) + (state : CausalBindingState.State cap) (events : List (Event cap)) + (current : PublicAt state events) (real : ∀ e ∈ events, WHIRPhysicalSnapshots.RealEvent C iv e) : + (∀ e ∈ state.publicLog, e ∈ expand C iv (observations events)) ∧ + (∀ n d, (n,d) ∈ expand C iv (observations events) → tag n = 0 → (n,d) ∈ state.publicLog) := by + have answers : ∀ o ∈ observations events, o.answer = realAnswer C iv o.query := by + intro o ho + exact real (.answer o.query o.answer) ((observation_mem_events events o.query o.answer).mp ho) + constructor + · intro ⟨n,d⟩ member + obtain ⟨purpose,he⟩ := (current n d).mp member + exact primitive_expand C iv _ answers purpose n d + ((observation_mem_events events _ _).mpr he) + · intro n d member ordinary + obtain ⟨purpose,ho⟩ := ordinary_expand C iv _ answers n d member ordinary + exact (current n d).mpr ⟨purpose,(observation_mem_events events _ _).mp ho⟩ + +structure Cursor (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) : Prop where + initial : past.IsPrefix (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events + physical : WHIRPhysicalSnapshots.Invariant C state + publicAt : PublicAt state past + committed : Committed state past + frozen : Frozen (policy registry Q select source) + (primitiveLog C registry.iv (WHIRSourceChronology.compile source) Q ((compile_counted source Q).mpr counted)) state + +theorem cursor_empty (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) : + Cursor registry Q select C source counted (CausalBindingState.empty cap) [] := by + refine ⟨⟨_,rfl⟩,WHIRPhysicalSnapshots.empty_invariant C cap,?_,?_,frozen_empty _ _⟩ + · intro n d; simp [CausalBindingState.empty] + · intro root member; cases member + +theorem cursor_registerRoot (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) (root : Digest32) + (captured : root ∈ policy registry Q select source (expand C registry.iv (observations past)).reverse) : + Cursor registry Q select C source counted (CausalBindingState.registerRoot state root) past := by + have real : ∀ e ∈ past, WHIRPhysicalSnapshots.RealEvent C registry.iv e := + fun e he => WHIRPhysicalSnapshots.real_source_events C registry.iv source e + (WHIRPhysicalSnapshots.prefix_mem old.initial he) + have hp := observation_prefix C registry.iv (WHIRSourceChronology.compile source) Q + ((compile_counted source Q).mpr counted) _ (event_observation_prefix C registry.iv source past old.initial) + obtain ⟨after,eq⟩ := hp + obtain ⟨sub,saturated⟩ := publicAt_fullC C registry.iv state past old.publicAt real + refine ⟨old.initial,WHIRPhysicalSnapshots.registerRoot_invariant C state root old.physical, + ?_,?_,registerRoot_frozen _ _ state old.frozen root _ after eq.symm sub saturated captured⟩ + · intro n d + rw [WHIRPhysicalSnapshots.registerRoot_publicLog] + exact old.publicAt n d + · intro r member + obtain ⟨snap,known⟩ := old.committed r member + exact ⟨snap,(CausalBindingState.registerRoot_extends state root).registry r snap known⟩ + +theorem cursor_step (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) (event : Event cap) + (initial : (past ++ [event]).IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events) : + Cursor registry Q select C source counted (WHIRSourceObserver.replayTracked state [event]) (past ++ [event]) := by + have real : ∀ e ∈ [event], WHIRPhysicalSnapshots.RealEvent C registry.iv e := + fun e he => WHIRPhysicalSnapshots.real_source_events C registry.iv source e + (WHIRPhysicalSnapshots.prefix_mem initial (List.mem_append_right _ he)) + have growth := WHIRSourceObserver.replayTracked_extends state [event] + refine ⟨initial,WHIRPhysicalSnapshots.replayTracked_invariant C registry.iv state [event] old.physical real, + ?_,?_,?_⟩ + · intro n d + rw [WHIRPhysicalSnapshots.replayTracked_publicLog_mem_iff C registry.iv state [event] + old.physical.logAuthentic real n d,old.publicAt] + simp only [List.mem_append,exists_or] + · intro root member + rcases List.mem_append.mp member with prior | fresh + · obtain ⟨snap,known⟩ := old.committed root prior + exact ⟨snap,growth.registry root snap known⟩ + · have same : Event.commit root = event := List.mem_singleton.mp fresh + subst event + change ∃ snap, MerkleTransport.Commitments.lookup root + (CausalBindingState.registerRoot state root).registry = some snap + cases known : MerkleTransport.Commitments.lookup root state.registry with + | some snap => exact ⟨snap,by simp only [CausalBindingState.registerRoot,known]⟩ + | none => exact ⟨CausalBindingState.snapshot state.records, + (WHIRPhysicalSnapshots.first_capture state root known).1⟩ + · cases event with + | answer q d => + cases q with + | primitive purpose n => + apply frozen_fields _ _ state _ old.frozen + · simp only [WHIRSourceObserver.replayTracked,step,observePublic,PublicMerkleLog.observe, + WHIRPhysicalSnapshots.observeRecords_registry] + · simp only [WHIRSourceObserver.replayTracked,step,observePublic,PublicMerkleLog.observe, + WHIRPhysicalSnapshots.observeRecords_frozenLog] + | construction coordinate valid => exact old.frozen + | commit root => + obtain ⟨future,eq⟩ := initial + have split : (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events = + past ++ .commit root :: future := by simpa only [List.append_assoc,List.singleton_append] using eq.symm + exact (cursor_registerRoot registry Q select C source counted state past old root + (commit_event_policy registry Q select C source counted past future root split)).frozen + | claims profile entry request => + unfold WHIRSourceObserver.replayTracked step + cases known : MerkleTransport.Commitments.lookup request.root state.registry <;> + simp only [known,WHIRSourceObserver.replayTracked] + · exact frozen_fields _ _ state _ old.frozen rfl rfl + · exact old.frozen + +theorem replayTracked_append (state : CausalBindingState.State cap) (a b : List (Event cap)) : + WHIRSourceObserver.replayTracked state (a ++ b) = + WHIRSourceObserver.replayTracked (WHIRSourceObserver.replayTracked state a) b := by + induction a generalizing state with + | nil => rfl + | cons event rest ih => + simp only [List.cons_append,WHIRSourceObserver.replayTracked] + cases step state event <;> exact ih _ + +/-- Fresh source events extend the chronological C cursor one event at a time; +an error annotation never suppresses the subsequent public observations. -/ +theorem cursor_replay_suffix (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past extra : List (Event cap)) + (old : Cursor registry Q select C source counted state past) + (initial : (past ++ extra).IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events) : + Cursor registry Q select C source counted (WHIRSourceObserver.replayTracked state extra) (past ++ extra) := by + induction extra generalizing state past with + | nil => simpa only [WHIRSourceObserver.replayTracked,List.append_nil] using old + | cons event rest ih => + have stepInitial : (past ++ [event]).IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events := + (show (past ++ [event]).IsPrefix (past ++ event :: rest) from + ⟨rest,by simp only [List.append_assoc,List.singleton_append]⟩).trans initial + have next := cursor_step registry Q select C source counted state past old event stepInitial + have more : ((past ++ [event]) ++ rest).IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events := by + simpa only [List.append_assoc,List.singleton_append] using initial + have result := ih (WHIRSourceObserver.replayTracked state [event]) (past ++ [event]) next more + rw [← replayTracked_append] at result + simpa only [List.append_assoc,List.singleton_append] using result + +/-- Replaying an already-observed source prefix cannot recapture a root. New +source events are therefore appended after the old cursor, not before it. -/ +theorem cursor_replay (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past events : List (Event cap)) + (old : Cursor registry Q select C source counted state past) + (grows : past.IsPrefix events) + (initial : events.IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events) : + Cursor registry Q select C source counted (WHIRSourceObserver.replayTracked state events) events := by + have real : ∀ e ∈ past, WHIRPhysicalSnapshots.RealEvent C registry.iv e := + fun e he => WHIRPhysicalSnapshots.real_source_events C registry.iv source e + (WHIRPhysicalSnapshots.prefix_mem old.initial he) + have fields := WHIRPhysicalSnapshots.replayTracked_settled_fields state past + (fun purpose n d he => (old.publicAt n d).mpr ⟨purpose,he⟩) old.committed + have unchanged : Cursor registry Q select C source counted + (WHIRSourceObserver.replayTracked state past) past := by + refine ⟨old.initial,WHIRPhysicalSnapshots.replayTracked_invariant C registry.iv state past old.physical real, + ?_,?_,frozen_fields _ _ state _ old.frozen fields.1 fields.2.2.1⟩ + · intro n d + rw [fields.2.2.2] + exact old.publicAt n d + · intro root member + rw [fields.1] + exact old.committed root member + obtain ⟨extra,rfl⟩ := grows + rw [replayTracked_append] + exact cursor_replay_suffix registry Q select C source counted _ past extra unchanged initial + +theorem cursor_registerRoots (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) (roots : List Digest32) + (captured : ∀ root ∈ roots, + root ∈ policy registry Q select source (expand C registry.iv (observations past)).reverse) : + Cursor registry Q select C source counted (CausalBindingState.registerRoots state roots) past := by + induction roots generalizing state with + | nil => exact old + | cons root rest ih => + exact ih (CausalBindingState.registerRoot state root) + (cursor_registerRoot registry Q select C source counted state past old root (captured root (by simp))) + (fun r hr => captured r (List.mem_cons_of_mem _ hr)) + +/-- The consumer receives the exact retained records and frozen log from the +actual state, alongside a chronological full-C freeze witness. -/ +theorem Cursor.retained (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (current : Cursor registry Q select C source counted state past) + (root : Digest32) (snap : MerkleTransport.Commitments.Snapshot) + (known : MerkleTransport.Commitments.lookup root state.registry = some snap) : + ∃ retained oldLog before after, + state.frozen root = some retained ∧ state.frozenLog root = some oldLog ∧ + primitiveLog C registry.iv (WHIRSourceChronology.compile source) Q + ((compile_counted source Q).mpr counted) = before ++ after ∧ + (∀ e ∈ oldLog, e ∈ before) ∧ + (∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ oldLog) ∧ + root ∈ policy registry Q select source before.reverse ∧ + AuthenticLog C oldLog ∧ WHIRPhysicalSnapshots.Historical oldLog retained ∧ + WHIRPhysicalSnapshots.Saturated oldLog retained ∧ snap.table = MerkleTransport.Commitments.recordDomain retained := by + obtain ⟨oldLog,before,after,hl,eq,sub,saturated,captured⟩ := current.frozen root snap known + obtain ⟨retained,log,hf,hl',auth,historical,complete,table,_⟩ := current.physical.snapshots root snap known + have same : log = oldLog := Option.some.inj (hl'.symm.trans hl) + subst log + exact ⟨retained,oldLog,before,after,hf,hl,eq,sub,saturated,captured,auth,historical,complete,table⟩ + +theorem visible_observations (events : List (Event cap)) (visible : PublicLog) : + visibleAfter events visible = DuplexPublicSimulator.finalLog visible (observations events) := by + induction events generalizing visible with + | nil => rfl + | cons event rest ih => + cases event with + | answer q d => + cases q <;> simpa only [visibleAfter,advance,observations,DuplexPublicSimulator.finalLog, + DuplexPublicSimulator.observe] using ih _ + | commit => exact ih visible + | claims => exact ih visible + +theorem recover_observation_prefix (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap R) (seen : List Observation) + (initial : seen.IsPrefix (runReal C iv (WHIRSourceChronology.compile source)).view.observations) : + observations (recover source seen).events = seen := by + induction source generalizing seen with + | done value => + have empty : seen = [] := List.prefix_nil.mp initial + subst seen + rfl + | commit root next ih => + apply ih + simpa only [WHIRSourceChronology.compile,map_real,mapExecution] using initial + | claims profile entry request next ih => + apply ih + simpa only [WHIRSourceChronology.compile,map_real,mapExecution] using initial + | ask q next ih => + cases seen with + | nil => rfl + | cons o rest => + have split : o = ⟨q,realAnswer C iv q⟩ ∧ + rest.IsPrefix (runReal C iv (WHIRSourceChronology.compile (next (realAnswer C iv q)))).view.observations := by + simpa only [WHIRSourceChronology.compile,runReal,map_real,mapExecution, + DuplexModeGame.prepend,List.cons_prefix_cons] using initial + rcases split with ⟨rfl,tail⟩ + exact congrArg (List.cons _) (ih (realAnswer C iv q) rest tail) + +theorem recover_pending (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap R) (before after : List Observation) (q : Query) (d : Digest32) + (split : (runReal C iv (WHIRSourceChronology.compile source)).view.observations = + before ++ ⟨q,d⟩ :: after) : + (recover source before).pending = some q := by + induction source generalizing before with + | done value => + have empty : ([] : List Observation) = before ++ ⟨q,d⟩ :: after := split + have := congrArg List.length empty + simp only [List.length_nil,List.length_append,List.length_cons] at this + omega + | commit root next ih => + exact ih before (by simpa only [WHIRSourceChronology.compile,map_real,mapExecution] using split) + | claims profile entry request next ih => + exact ih before (by simpa only [WHIRSourceChronology.compile,map_real,mapExecution] using split) + | ask current next ih => + simp only [WHIRSourceChronology.compile,runReal,map_real,mapExecution,DuplexModeGame.prepend] at split + cases before with + | nil => + have same : current = q := congrArg Observation.query (List.cons.inj split).1 + subst q + rfl + | cons o rest => + have same := (List.cons.inj split).1 + subst o + exact ih (realAnswer C iv current) rest (List.cons.inj split).2 + +theorem queryKey_roots (registry : Public) (Q : Nat) (visible : PublicLog) + (q : Query) (raw : RawKey Q) + (key : WHIRSourcePartialMonotone.queryKey Q registry.iv visible q = some raw) : + queryRoots registry Q visible q = rawRoots registry Q raw := by + cases q with + | primitive purpose n => exact primitive_roots registry Q visible purpose n raw key + | construction coordinate valid => + by_cases bounded : pathCost coordinate ≤ Q + · have same : constructionKey Q registry.iv coordinate bounded = raw := by + simpa only [WHIRSourcePartialMonotone.queryKey,bounded,↓reduceDIte,Option.some.injEq] using key + subst raw + exact construction_roots registry Q visible coordinate valid bounded + · simp only [WHIRSourcePartialMonotone.queryKey,bounded,↓reduceDIte] at key + cases key + +/-- All earlier raw requests have already been allocated. The pending request's +input roots are therefore captured by the current replay, even if warming has +also made later source queries available. -/ +theorem raw_request_captured (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (cache : RawKey Q → Option Digest32) + (prior later : List (RawKey Q)) (raw : RawKey Q) + (split : DuplexPublicSimulator.replay Q registry.iv [] + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations = prior ++ raw :: later) + (covered : ∀ key ∈ prior, cache key = some (WHIRRealSimulator.rawTable Q C key)) + (root : Digest32) (member : root ∈ rawRoots registry Q raw) : + root ∈ capture registry Q select + (recover source (DuplexPublicSimulator.runPartial cache registry.iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations) [] := by + obtain ⟨before,observation,after,events,requests,key⟩ := + WHIRSourcePartialMonotone.replay_factor registry.iv [] + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations prior raw later split + have initial : before.IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations := + ⟨observation :: after,events.symm⟩ + have past : before.IsPrefix (DuplexPublicSimulator.runPartial cache registry.iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations := by + apply WHIRSourcePartialMonotone.runPartial_covers_prefix cache (WHIRRealSimulator.rawTable Q C) + registry.iv _ _ _ _ _ before + · rw [← WHIRRealSimulator.real_ideal_view C registry.iv _ ((compile_counted source Q).mpr counted)] + exact initial + · change ∀ key ∈ DuplexPublicSimulator.replay Q registry.iv [] before, _ + rw [requests] + exact covered + apply capture_mono registry Q select source _ _ past [] root + have pending := recover_pending C registry.iv source before after observation.query observation.answer events + have visible : visibleAfter (recover source before).events [] = DuplexPublicSimulator.finalLog [] before := by + rw [visible_observations,recover_observation_prefix C registry.iv source before initial] + unfold capture + apply List.mem_append_right + apply List.mem_append_left + simpa only [pending,Option.toList_some,List.flatMap_cons,List.flatMap_nil,List.append_nil, + visible,queryKey_roots registry Q _ _ raw key] using member + +/-- Exactly the roots which concrete header and packet-footprint preparation +may register; answers and ancestor answer annotations are not inspected. -/ +def allocationRoots (registry : Public) (Q : Nat) + (key : RawOracleCoupling.Concrete.AllocationKey (context registry) Q) : List Digest32 := + WHIRHeaderRoots.allocationRoots registry Q key ++ + match key.1 with + | .inl packet => (WHIRSnapshotReplay.historyFootprint packet.val.profile + packet.val.statement packet.val.messages).map Prod.fst + | .inr _ => [] + +theorem completion_packet_member (registry : Public) (Q : Nat) + (packet allocated : RawWHIRKeys.Packet (context registry) Q) + (member : Sum.inl allocated ∈ WHIRPublicBackfill.completionKeys (context registry) Q packet) : + allocated ∈ RawWHIRKeys.ancestors (context registry) Q packet ∨ allocated = packet := by + let callers : List (RawOracleCoupling.Concrete.partition (context registry) Q).Garbage := + RawWHIRKeys.callerGroups (context registry) Q packet + change Sum.inl allocated ∈ (callers.map Sum.inr ++ + (RawWHIRKeys.ancestors (context registry) Q packet).map Sum.inl) ++ [Sum.inl packet] at member + rcases List.mem_append.mp member with deps | self + · rcases List.mem_append.mp deps with caller | ancestor + · obtain ⟨raw,_,equal⟩ := List.mem_map.mp caller + cases equal + · obtain ⟨a,ha,equal⟩ := List.mem_map.mp ancestor + cases Sum.inl.inj equal + exact Or.inl ha + · exact Or.inr (Sum.inl.inj (List.mem_singleton.mp self)) + +theorem completion_roots (registry : Public) (Q : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) + (key : RawOracleCoupling.Concrete.AllocationKey (context registry) Q) + (member : key.1 ∈ WHIRPublicBackfill.completionKeys (context registry) Q packet) : + ∀ root ∈ allocationRoots registry Q key, root ∈ packetRoots registry Q packet := by + intro root captured + rcases List.mem_append.mp captured with header | footprint + · exact completion_header_member registry Q packet key member root header + · rcases key with ⟨group,history⟩ + cases group with + | inr raw => cases footprint + | inl allocated => + obtain ⟨ref,hm,rfl⟩ := List.mem_map.mp footprint + apply packet_footprint_member + rcases completion_packet_member registry Q packet allocated member with ancestor | rfl + · exact ancestor_footprint_member registry Q packet allocated ancestor ref hm + · exact hm + +theorem packetRoots_raw (registry : Public) (Q : Nat) + (raw : RawKey Q) (pos : RawWHIRKeys.Position (context registry) Q) + (recognized : RawWHIRKeys.recognize (context registry) Q raw = some pos) : + ∀ root ∈ packetRoots registry Q pos.1, root ∈ rawRoots registry Q raw := by + intro root member + rcases List.mem_append.mp member with headerMem | footprint + · obtain ⟨header,hm,rfl⟩ := List.mem_map.mp headerMem + exact recognized_header_member registry Q raw pos recognized header (Option.mem_toList.mp hm) + · obtain ⟨ref,hm,rfl⟩ := List.mem_map.mp footprint + exact raw_footprint_member registry Q raw pos recognized ref hm + +theorem request_roots (registry : Public) (Q : Nat) (raw : RawKey Q) + (key : RawOracleCoupling.Concrete.AllocationKey (context registry) Q) + (member : key.1 ∈ WHIRObservableAllocations.requestKeys (context registry) Q raw) : + ∀ root ∈ allocationRoots registry Q key, root ∈ rawRoots registry Q raw := by + cases recognized : RawWHIRKeys.recognize (context registry) Q raw with + | some pos => + rw [WHIRObservableAllocations.requestKeys_some (context registry) Q raw pos recognized] at member + exact fun root hr => packetRoots_raw registry Q raw pos recognized root + (completion_roots registry Q pos.1 key member root hr) + | none => + rw [WHIRObservableAllocations.requestKeys_none (context registry) Q raw recognized] at member + rcases key with ⟨group,history⟩ + have same : group = .inr ⟨raw,recognized⟩ := List.mem_singleton.mp member + subst group + intro root captured + have header : WHIRHeaderRoots.rawRoot registry raw = some root := by + simpa [allocationRoots,WHIRHeaderRoots.allocationRoots,WHIRHeaderRoots.allocationRoot, + WHIRHeaderRoots.allocationHeader,WHIRHeaderRoots.rawRoot] using captured + exact raw_header_member registry Q raw root header + +theorem cursor_fields (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state next : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) + (records : next.records = state.records) (roots : next.registry = state.registry) + (frozen : next.frozen = state.frozen) (logs : next.frozenLog = state.frozenLog) + (publicLog : next.publicLog = state.publicLog) : + Cursor registry Q select C source counted next past := by + have physical : WHIRPhysicalSnapshots.Invariant C next := by + refine ⟨?_,?_,?_,?_,?_⟩ + · simpa only [publicLog] using old.physical.logAuthentic + · simpa only [publicLog,records] using old.physical.historical + · simpa only [publicLog,records] using old.physical.saturated + · simpa only [CausalBindingState.AuthenticState,records,frozen] using old.physical.authentic + · intro root snap known + simpa only [frozen,logs,publicLog] using old.physical.snapshots root snap (roots ▸ known) + refine ⟨old.initial,physical,?_,?_,frozen_fields _ _ state next old.frozen roots logs⟩ + · intro n d; rw [publicLog]; exact old.publicAt n d + · intro root member; rw [roots]; exact old.committed root member + +theorem cursor_registerStatement (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) + (profile : ParameterBounds.Profile) (entry : FramedHistory) + (data : Option (WHIRFiatShamir.StackInitial profile cap)) : + Cursor registry Q select C source counted (CausalBindingState.registerStatement state profile entry data) past := by + unfold CausalBindingState.registerStatement + split + · exact old + · exact cursor_fields registry Q select C source counted state _ past old rfl rfl rfl rfl rfl + +theorem cursor_addGroup (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) + (group : RawOracleCoupling.Concrete.GroupKey (context registry) Q) + (answer : RawOracleCoupling.Concrete.GroupAnswer (context registry) Q group) : + Cursor registry Q select C source counted (WHIRSourceRawCache.addGroup (context registry) Q state group answer) past := + cursor_fields registry Q select C source counted state _ past old rfl rfl rfl rfl rfl + +theorem final_request_captured (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (cache : RawKey Q → Option Digest32) + (covered : ∀ key ∈ DuplexPublicSimulator.replay Q registry.iv [] + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations, + cache key = some (WHIRRealSimulator.rawTable Q C key)) + (root : Digest32) + (member : root ∈ finalRoots registry Q select + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value) : + root ∈ capture registry Q select + (recover source (DuplexPublicSimulator.runPartial cache registry.iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations) [] := by + have hits : ∀ key ∈ DuplexPublicSimulator.actualRequests (WHIRRealSimulator.rawTable Q C) + registry.iv ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (by omega) ((compile_counted source Q).mpr counted), + cache key = some (WHIRRealSimulator.rawTable Q C key) := by + rw [← DuplexPublicSimulator.replay_actual] + rw [← WHIRRealSimulator.real_ideal_view C registry.iv _ ((compile_counted source Q).mpr counted)] + exact covered + rw [WHIRSourcePartialMonotone.source_complete cache (WHIRRealSimulator.rawTable Q C) registry.iv C source counted hits] + rw [← WHIRRealSimulator.real_ideal_view C registry.iv _ ((compile_counted source Q).mpr counted)] + unfold capture completedPrefix + apply List.mem_append_right + simpa only [Option.toList_none,List.flatMap_nil,List.nil_append,Option.toList_some, + List.flatMap_cons,List.append_nil] using member + +theorem cursor_prepareClaims (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) + (profile : ParameterBounds.Profile) (entry : FramedHistory) (key : StackWHIRReplay.Key profile) + (request : Option (CausalBindingState.ClaimRequest cap profile)) + (footprint : ∀ ref ∈ WHIRSnapshotReplay.historyFootprint profile key.statement key.messages, + ref.1 ∈ policy registry Q select source (expand C registry.iv (observations past)).reverse) + (header : ∀ proposed, request = some proposed → + proposed.root ∈ policy registry Q select source (expand C registry.iv (observations past)).reverse) : + Cursor registry Q select C source counted (CausalBindingState.prepareClaims state profile entry key request).1 past := by + have prepare (s : CausalBindingState.State cap) + (h : Cursor registry Q select C source counted s past) + (data : Option (WHIRFiatShamir.StackInitial profile cap)) : + Cursor registry Q select C source counted (CausalBindingState.prepare s profile entry key data).1 past := by + apply cursor_registerRoots registry Q select C source counted _ past + (cursor_registerStatement registry Q select C source counted s past h profile entry data) + intro root member + obtain ⟨ref,hr,rfl⟩ := List.mem_map.mp member + exact footprint ref hr + cases request with + | none => exact prepare state old none + | some proposed => + exact prepare (CausalBindingState.registerRoot state proposed.root) + (cursor_registerRoot registry Q select C source counted state past old proposed.root (header proposed rfl)) _ + +theorem private_events_initial (registry : Public) (Q : Nat) (C : PrimitiveOracle) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (cache : RawKey Q → Option Digest32) + (agrees : DuplexPublicSimulator.CacheAgrees cache (WHIRRealSimulator.rawTable Q C)) : + (WHIRSourceObserver.privateEvents Q registry.iv cache C source counted).IsPrefix + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.events := by + have mono := WHIRSourcePartialMonotone.recover_mono source + (private_observation_prefix C registry.iv source Q counted cache agrees) + rw [recover_real] at mono + exact mono + +theorem private_prepare_cursor (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) (past : List (Event cap)) + (old : Cursor registry Q select C source counted state past) + (agrees : WHIRSourceRawCache.LogAgrees (WHIRRealSimulator.rawTable Q C) (state.rawAnswers Q)) + (grows : past.IsPrefix (WHIRSourceObserver.privateEvents Q registry.iv (WHIRSourceRawCache.cache Q state) + C source counted)) + (key : RawOracleCoupling.Concrete.AllocationKey (context registry) Q) + (captured : ∀ root ∈ allocationRoots registry Q key, + root ∈ capture registry Q select + (recover source (DuplexPublicSimulator.runPartial (WHIRSourceRawCache.cache Q state) registry.iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations) []) : + Cursor registry Q select C source counted + (WHIRCausalRawROM.prepare (context registry) rfl Q cap + (WHIRSourceResolver.privateResolver registry Q C source counted) state key).1 + (WHIRSourceObserver.privateEvents Q registry.iv (WHIRSourceRawCache.cache Q state) C source counted) := by + let cache := WHIRSourceRawCache.cache Q state + let seen := (DuplexPublicSimulator.runPartial cache registry.iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations + let events := WHIRSourceObserver.privateEvents Q registry.iv cache C source counted + have cacheAgrees : DuplexPublicSimulator.CacheAgrees cache (WHIRRealSimulator.rawTable Q C) := + WHIRSourceRawCache.lookup_agrees Q _ _ agrees + have initial := private_observation_prefix C registry.iv source Q counted cache cacheAgrees + have obs : observations events = seen := recover_observation_prefix C registry.iv source seen initial + have roots : ∀ root ∈ allocationRoots registry Q key, + root ∈ policy registry Q select source (expand C registry.iv (observations events)).reverse := by + intro root member + rw [obs] + exact source_prefix_captured registry Q select C source counted seen initial root (captured root member) + have replayed := cursor_replay registry Q select C source counted state past events old grows + (private_events_initial registry Q C source counted cache cacheAgrees) + have headed := cursor_registerRoots registry Q select C source counted _ events replayed + (WHIRHeaderRoots.allocationRoots registry Q key) + (fun root member => roots root (List.mem_append_left _ member)) + rcases key with ⟨group,history⟩ + cases group with + | inr raw => exact headed + | inl packet => + apply cursor_prepareClaims registry Q select C source counted _ events headed + · intro ref member + exact roots ref.1 (List.mem_append_right _ (List.mem_map.mpr ⟨ref,member,rfl⟩)) + · intro proposed decoded + have parsed := WHIRHeaderRoots.allocation_packet_root registry Q cap packet history proposed decoded history + apply roots proposed.root + apply List.mem_append_left + rw [parsed] + exact List.mem_cons_self + +/-- The exact allocation path of the actual source and its selected backfill. +`compile_execution` identifies this table replay with the allocation compiler. -/ +noncomputable def allocationTrace (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) : + List (Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q)) := + (WHIRObservableAllocations.tableReplay (RawOracleCoupling.Concrete.dependencyKeys (context registry) Q) + ((RawOracleCoupling.Concrete.partition (context registry) Q).split (WHIRRealSimulator.rawTable Q C)) + (WHIRObservableAllocations.allocationRequests (context registry) Q + (DuplexPublicSimulator.replay Q registry.iv [] + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations) + (select (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value)) + (fun _ => none)).2 + +noncomputable def replayState (registry : Public) (Q : Nat) (C : PrimitiveOracle) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (trace : List (Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q))) : + CausalBindingState.State cap := + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.privateResolver registry Q C source counted)).traceRecode + (CausalBindingState.empty cap) trace).2 + +theorem recode_final_append (registry : Public) (Q : Nat) + (resolver : WHIRCausalRawROM.Resolver (context registry) Q cap) + (state : CausalBindingState.State cap) + (a b : List (Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q))) : + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).traceRecode state (a ++ b)).2 = + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).traceRecode + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).traceRecode state a).2 b).2 := by + induction a generalizing state with + | nil => rfl + | cons entry rest ih => + simp only [List.cons_append,CausalAllocationLabels.Decorator.traceRecode] + exact ih _ + +theorem replayState_snoc (registry : Public) (Q : Nat) (C : PrimitiveOracle) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (trace : List (Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q))) + (entry : Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q)) : + replayState registry Q C source counted (trace ++ [entry]) = + WHIRSourceRawCache.addGroup (context registry) Q + (WHIRCausalRawROM.prepare (context registry) rfl Q cap + (WHIRSourceResolver.privateResolver registry Q C source counted) + (replayState registry Q C source counted trace) entry.1).1 entry.1.1 entry.2 := by + unfold replayState + rw [recode_final_append] + rcases entry with ⟨⟨group,history⟩,answer⟩ + cases group <;> rfl + +theorem allocationTrace_agrees (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) : + WHIRSourceResolver.TraceAgrees registry Q (WHIRRealSimulator.rawTable Q C) + (allocationTrace registry Q select C source) := + WHIRSourceAllocationCache.replay_agrees registry Q (WHIRRealSimulator.rawTable Q C) _ _ + +theorem replayState_agrees (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (trace : List (Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q))) + (initial : trace.IsPrefix (allocationTrace registry Q select C source)) : + WHIRSourceRawCache.LogAgrees (WHIRRealSimulator.rawTable Q C) + ((replayState registry Q C source counted trace).rawAnswers Q) := + WHIRSourceAllocationCache.recode_agrees registry Q (WHIRRealSimulator.rawTable Q C) C source counted + _ (by intro e h; cases h) trace + (fun e he => allocationTrace_agrees registry Q select C source e (WHIRPhysicalSnapshots.prefix_mem initial he)) + +/-- Concrete allocation-stage provenance. No premise says that roots are covered: +the actual emitted key and the acquired earlier raw groups determine the root. -/ +theorem allocation_captured (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (before after : List (Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q))) + (entry : Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q)) + (split : allocationTrace registry Q select C source = before ++ entry :: after) : + ∀ root ∈ allocationRoots registry Q entry.1, + root ∈ capture registry Q select + (recover source (DuplexPublicSimulator.runPartial + (WHIRSourceRawCache.cache Q (replayState registry Q C source counted before)) registry.iv + ((DuplexPublicSimulator.simulator Q).initial C) (WHIRSourceChronology.compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations) [] := by + obtain ⟨keys,trace,_,_,_,origin⟩ := + WHIRSourceAllocationOrigin.allocation_origin (context registry) Q (WHIRRealSimulator.rawTable Q C) + (DuplexPublicSimulator.replay Q registry.iv [] + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations) + (select (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value) + before after entry split + have acquired (raw : RawKey Q) + (covered : ∀ key ∈ WHIRObservableAllocations.requestKeys (context registry) Q raw, + ∃ answer, (WHIRObservableAllocations.tableReplay + (RawOracleCoupling.Concrete.dependencyKeys (context registry) Q) + ((RawOracleCoupling.Concrete.partition (context registry) Q).split (WHIRRealSimulator.rawTable Q C)) + keys (fun _ => none)).1 key = some answer) : + WHIRSourceRawCache.cache Q (replayState registry Q C source counted before) raw = + some (WHIRRealSimulator.rawTable Q C raw) := by + have hit := WHIRSourceAllocationCache.covered_raw registry Q (WHIRRealSimulator.rawTable Q C) C source counted + keys raw (WHIRSourceAllocationOrigin.request_covered (context registry) Q _ raw covered) + rw [trace] at hit + exact hit + intro root member + rcases origin with sourceStage | finalStage + · obtain ⟨prior,raw,later,path,key,covered⟩ := sourceStage + exact raw_request_captured registry Q select C source counted _ prior later raw path + (fun raw hr => acquired raw (covered raw hr)) root + (request_roots registry Q raw entry.1 key root member) + · obtain ⟨key,covered⟩ := finalStage + apply final_request_captured registry Q select C source counted _ + (fun raw hr => acquired raw (covered raw hr)) root + cases selected : select (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value with + | none => simp only [selected,WHIRObservableAllocations.finalKeys,List.not_mem_nil] at key + | some packet => + have kp : entry.1.1 ∈ WHIRPublicBackfill.completionKeys (context registry) Q packet := by + simpa only [selected,WHIRObservableAllocations.finalKeys] using key + simpa only [finalRoots,selected] using completion_roots registry Q packet entry.1 kp root member + +/-- The first-freeze invariant is derived for every actual allocation prefix, +including all warmed dependencies and the selected final completion. -/ +theorem allocation_prefix_cursor (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (before after : List (Sigma (RawOracleCoupling.Concrete.AllocationAnswer (context registry) Q))) + (split : allocationTrace registry Q select C source = before ++ after) : + ∃ past, Cursor registry Q select C source counted (replayState registry Q C source counted before) past ∧ + past.IsPrefix (WHIRSourceObserver.privateEvents Q registry.iv + (WHIRSourceRawCache.cache Q (replayState registry Q C source counted before)) C source counted) := by + induction before using List.reverseRecOn generalizing after with + | nil => + exact ⟨[],cursor_empty registry Q select C source counted,List.nil_prefix⟩ + | append_singleton before entry ih => + have priorSplit : allocationTrace registry Q select C source = before ++ entry :: after := by + simpa only [List.append_assoc,List.singleton_append] using split + obtain ⟨past,old,grows⟩ := ih (entry :: after) priorSplit + have agrees := replayState_agrees registry Q select C source counted before ⟨entry :: after,priorSplit.symm⟩ + have prepared := private_prepare_cursor registry Q select C source counted + (replayState registry Q C source counted before) past old agrees grows entry.1 + (allocation_captured registry Q select C source counted before after entry priorSplit) + have next := cursor_addGroup registry Q select C source counted _ _ prepared entry.1.1 entry.2 + have value := allocationTrace_agrees registry Q select C source entry + (priorSplit.symm ▸ List.mem_append_right before (List.mem_cons_self)) + have monotone := WHIRSourcePartialMonotone.allocationEvents_mono registry + (WHIRRealSimulator.rawTable Q C) C source counted + (replayState registry Q C source counted before) agrees entry.1 + refine ⟨WHIRSourceObserver.privateEvents Q registry.iv + (WHIRSourceRawCache.cache Q (replayState registry Q C source counted before)) C source counted,?_,?_⟩ + · rw [replayState_snoc] + exact next + · rw [replayState_snoc] + simpa only [WHIRSourceResolver.after,value] using monotone + +/-- Concrete resolver/decorator endpoint. Every retained root has an actual +full-C freeze witness; there is no root-cover or verifier-correctness premise. -/ +theorem actual_retained (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (root : Digest32) (snap : MerkleTransport.Commitments.Snapshot) + (known : MerkleTransport.Commitments.lookup root + (replayState registry Q C source counted (allocationTrace registry Q select C source)).registry = some snap) : + let state := replayState registry Q C source counted (allocationTrace registry Q select C source) + ∃ retained oldLog before after, + state.frozen root = some retained ∧ state.frozenLog root = some oldLog ∧ + primitiveLog C registry.iv (WHIRSourceChronology.compile source) Q + ((compile_counted source Q).mpr counted) = before ++ after ∧ + (∀ e ∈ oldLog, e ∈ before) ∧ + (∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ oldLog) ∧ + root ∈ policy registry Q select source before.reverse ∧ + AuthenticLog C oldLog ∧ WHIRPhysicalSnapshots.Historical oldLog retained ∧ + WHIRPhysicalSnapshots.Saturated oldLog retained ∧ snap.table = MerkleTransport.Commitments.recordDomain retained := by + obtain ⟨past,current,_⟩ := allocation_prefix_cursor registry Q select C source counted + (allocationTrace registry Q select C source) [] (List.append_nil _).symm + exact current.retained registry Q select C source counted _ past root snap known + +theorem bind_observation_prefix {S : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (next : R → Program S) : + (runReal C iv program).view.observations.IsPrefix + (runReal C iv (WHIRModeFinal.bind program next)).view.observations := by + induction program with + | done => exact List.nil_prefix + | ask q cont ih => + obtain ⟨suffix,eq⟩ := ih (realAnswer C iv q) + refine ⟨suffix,?_⟩ + simpa only [WHIRModeFinal.bind,runReal,DuplexModeGame.prepend,List.cons_append] using + congrArg (List.cons (⟨q,realAnswer C iv q⟩ : Observation)) eq + +/-- The actual source full-C trace is a prefix of the actual physical +source/backfill execution, at any valid total budget. -/ +theorem backfill_prefix (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (total : Nat) (whole : DuplexModeGame.Counts total + (WHIRSourceBackfill.instrument (context registry) Q source select)) : + (primitiveLog C registry.iv (WHIRSourceChronology.compile source) Q + ((compile_counted source Q).mpr counted)).IsPrefix + (primitiveLog C registry.iv (WHIRSourceBackfill.instrument (context registry) Q source select) total whole) := by + rw [← expand_real C registry.iv (WHIRSourceChronology.compile source) Q + ((compile_counted source Q).mpr counted)] + exact observation_prefix C registry.iv _ total whole _ + (bind_observation_prefix C registry.iv (WHIRSourceChronology.compile source) _) + +/-- End-to-end frozen provenance in the actual source/backfill all-C trace. +All retained/history/saturation fields are the final concrete resolver state. -/ +theorem actual_backfill_retained (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (total : Nat) (whole : DuplexModeGame.Counts total + (WHIRSourceBackfill.instrument (context registry) Q source select)) + (root : Digest32) (snap : MerkleTransport.Commitments.Snapshot) + (known : MerkleTransport.Commitments.lookup root + (replayState registry Q C source counted (allocationTrace registry Q select C source)).registry = some snap) : + let state := replayState registry Q C source counted (allocationTrace registry Q select C source) + ∃ retained oldLog before after, + state.frozen root = some retained ∧ state.frozenLog root = some oldLog ∧ + primitiveLog C registry.iv (WHIRSourceBackfill.instrument (context registry) Q source select) + total whole = before ++ after ∧ + (∀ e ∈ oldLog, e ∈ before) ∧ + (∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ oldLog) ∧ + root ∈ policy registry Q select source before.reverse ∧ + AuthenticLog C oldLog ∧ WHIRPhysicalSnapshots.Historical oldLog retained ∧ + WHIRPhysicalSnapshots.Saturated oldLog retained ∧ snap.table = MerkleTransport.Commitments.recordDomain retained := by + obtain ⟨retained,log,before,after,hf,hl,eq,sub,saturated,captured,auth,historical,complete,table⟩ := + actual_retained registry Q select C source counted root snap known + obtain ⟨completion,physical⟩ := backfill_prefix registry Q select C source counted total whole + refine ⟨retained,log,before,after ++ completion,hf,hl,?_,sub,saturated,captured,auth,historical,complete,table⟩ + rw [← physical,eq,List.append_assoc] + +/-- The independently source-budgeted raw compiler executes exactly the +allocation path used above, including canonical dependency warming/backfill. -/ +theorem allocationTrace_compiler (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (A : Nat) (sourceCounted : WHIRSourceChronology.Counts A source) : + (TypedOracleCompiler.Sampling.execute + (WHIRObservableAllocations.allocationOracle (context registry) Q (WHIRRealSimulator.rawTable Q C)) + (RawOracleCoupling.Concrete.compile (context registry) Q + (fun result : Option (View (Result cap R)) => result.bind (fun view => select view.result.value)) + (WHIRSourceRawProgram.bounded Q registry.iv ((DuplexPublicSimulator.simulator Q).initial C) + (WHIRSourceChronology.compile source) Q (by omega) ((compile_counted source Q).mpr counted) + A ((compile_counted source A).mpr sourceCounted)))).2 = + allocationTrace registry Q select C source := by + rw [WHIRObservableAllocations.compile_execution, + WHIRSourceRawProgram.bounded_eval,WHIRSourceRawProgram.bounded_rawAnswers] + rw [← WHIRRealSimulator.real_ideal_view C registry.iv _ ((compile_counted source Q).mpr counted)] + simp only [Option.bind_some,DuplexPublicSimulator.replayAnswers_keys] + rfl + +/-- Public event-only preparation and the chosen real seed/table execution +produce identical concrete final states. -/ +theorem public_replayState (registry : Public) (Q : Nat) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (C : PrimitiveOracle) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) : + ((WHIRCausalRawROM.decorator (context registry) rfl Q cap + (WHIRSourceResolver.publicResolver registry Q + (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result)).traceRecode + (CausalBindingState.empty cap) (allocationTrace registry Q select C source)).2 = + replayState registry Q C source counted (allocationTrace registry Q select C source) := by + have eq := WHIRSourceResolver.traceRecode_actual registry Q (WHIRRealSimulator.rawTable Q C) C source counted + (CausalBindingState.empty cap) (by intro e h; cases h) (allocationTrace registry Q select C source) + (allocationTrace_agrees registry Q select C source) + rw [← WHIRRealSimulator.real_ideal_view C registry.iv _ ((compile_counted source Q).mpr counted)] at eq + exact congrArg Prod.snd eq + +/-- Exercises the chosen real seed/raw table, actual partial source recovery, +immutable first-freeze logs, duplicate replay, and ordinary/hidden C tags. -/ +def smoke : IO Unit := do + let iv := DuplexCompression.parameterIV + let early : Digest32 := fun _ => 17 + let registry : Public := ⟨iv,iv,fun _ => none,0⟩ + let ordinary := PublicMerkleLog.node iv 0 [] true + let coordinate : Coordinate := ⟨⟨iv,iv,[]⟩,.output 0⟩ + have valid : DuplexEncoding.Admissible coordinate := by + constructor + · simp [coordinate] + · decide + let source : Source 0 Unit := .commit early (.ask (.primitive .direct ordinary) fun reply => + .commit reply (.ask (.construction coordinate valid) fun _ => + .ask (.primitive .direct ordinary) fun _ => .done ())) + have counted : WHIRSourceChronology.Counts 4 source := by + simp [source,WHIRSourceChronology.Counts,Query.cost,pathCost,DuplexEncoding.plan,coordinate] + let missing : RawKey 4 → Option Digest32 := fun _ => none + let first := DuplexPublicSimulator.runPartial missing iv + ((DuplexPublicSimulator.simulator 4).initial blake2sOracle) (WHIRSourceChronology.compile source) + 4 (by omega) ((compile_counted source 4).mpr counted) + let state := WHIRSourceObserver.privateReplay 4 iv missing blake2sOracle source counted (CausalBindingState.empty 0) + let reply := blake2sOracle ordinary + unless decide (reply ≠ early) do throw (IO.userError "smoke needs distinct announced and reply roots") + unless decide (state.frozenLog early = some []) do + throw (IO.userError "input root was not frozen before first C answer") + unless decide (state.frozenLog reply = some [(ordinary,reply)]) do + throw (IO.userError "reply-derived root was captured before its producing answer") + unless decide (expand blake2sOracle iv first.observations = [(ordinary,reply)]) do + throw (IO.userError "partial raw replay crossed the unanswered construction") + let raw := constructionKey 4 iv coordinate (by decide) + let acquired : RawKey 4 → Option Digest32 := fun key => + if key = raw then some (WHIRRealSimulator.rawTable 4 blake2sOracle key) else none + let next := WHIRSourceObserver.privateReplay 4 iv acquired blake2sOracle source counted state + unless decide (next.frozenLog early = state.frozenLog early ∧ next.frozenLog reply = state.frozenLog reply) do + throw (IO.userError "replaying the source prefix replaced a first freeze") + unless decide (next.publicLog = [(ordinary,reply)]) do + throw (IO.userError "duplicate source replay changed public compression membership") + let calls := primitiveLog blake2sOracle iv (WHIRSourceChronology.compile source) 4 + ((compile_counted source 4).mpr counted) + unless decide (calls.map (fun e => tag e.1) = [0,1,6,0]) do + throw (IO.userError "ordinary tag-zero / hidden construction-tag separation failed") + let select : Unit → Option (RawWHIRKeys.Packet (context registry) 4) := fun _ => none + unless (rootList registry 4 select source []).contains early && + !((rootList registry 4 select source []).contains reply) && + (rootList registry 4 select source [(ordinary,reply)]).contains reply do + throw (IO.userError "policy did not preserve fixed-before-answer root timing") + IO.println "source-frozen-prefix smoke: input root before answer; reply root after answer; finite raw cutoff; immutable repeated replay; full C tags [0,1,6,0]" + +#print axioms actual_retained +#print axioms actual_backfill_retained +#print axioms allocation_captured +#print axioms cursor_replay +#print axioms allocationTrace_compiler +#print axioms public_replayState + +end Whir.WHIRSourceFrozenPrefix diff --git a/verification/whir/Whir/WHIRSourceMerkleSecurity.lean b/verification/whir/Whir/WHIRSourceMerkleSecurity.lean new file mode 100644 index 000000000..f98099121 --- /dev/null +++ b/verification/whir/Whir/WHIRSourceMerkleSecurity.lean @@ -0,0 +1,43 @@ +import Whir.WHIRSourceRootPolicy +import Whir.WHIRSourceBackfill + +namespace Whir.WHIRSourceMerkleSecurity +open FiatShamirGame DuplexModeGame WHIRCallerRegistry WHIRSourceChronology + +variable {cap : Nat} {R Coins : Type} + +/-- Root announcements are charged separately from public compression calls. The fixed production maximum is derived from all schedules. -/ +def rootBudget (Q free : Nat) : Nat := + (Q+1) * (free+(Q+1)*(WHIRSourceRootPolicy.productionDepth+1)) + +def loss (Q free : Nat) : ℚ := PublicMerkleProbability.bound Q (rootBudget Q free) + +/-- This is the actual shared-compression event over the source plus its physically executed completion suffix, not a whole-hash random-oracle event. -/ +noncomputable def probability [Fintype Coins] (registry : Public) (Q : Nat) + (sources : Coins → Source cap R) (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (counts : ∀ coins, DuplexModeGame.Counts Q + (WHIRSourceBackfill.instrument (context registry) Q (sources coins) select)) : ℚ := + average (fun coins => PublicMerkleProbability.openingProbability + (WHIRSourceRootPolicy.policy registry Q select (sources coins)) + (PublicCompressionProgram.compile registry.iv + (WHIRSourceBackfill.instrument (context registry) Q (sources coins) select) Q (counts coins))) + +/-- Causal root selection, all old ordinary primitive calls, and fresh-target/collision losses are handled by the actual finite compression experiment. -/ +theorem probability_bound [Fintype Coins] [Nonempty Coins] + (registry : Public) (Q free : Nat) (sources : Coins → Source cap R) + (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) + (sourceCounts : ∀ coins, Counts Q (sources coins)) + (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (sources coins)) + (counts : ∀ coins, DuplexModeGame.Counts Q + (WHIRSourceBackfill.instrument (context registry) Q (sources coins) select)) : + probability registry Q sources select counts ≤ loss Q free := by + apply le_trans (average_mono (fun coins => + PublicMerkleProbability.real_mode_opening_bound + (WHIRSourceRootPolicy.policy registry Q select (sources coins)) Q (rootBudget Q free) + (WHIRSourceRootPolicy.production_cardinality registry Q free select (sources coins) + (sourceCounts coins) (announcements coins)) + (WHIRSourceRootPolicy.rootsGrow registry Q select (sources coins)) registry.iv + (WHIRSourceBackfill.instrument (context registry) Q (sources coins) select) (counts coins))) + exact le_of_eq (average_const _) + +end Whir.WHIRSourceMerkleSecurity diff --git a/verification/whir/Whir/WHIRSourceObserver.lean b/verification/whir/Whir/WHIRSourceObserver.lean index 5ad31f462..56e556180 100644 --- a/verification/whir/Whir/WHIRSourceObserver.lean +++ b/verification/whir/Whir/WHIRSourceObserver.lean @@ -39,17 +39,14 @@ theorem publicEvents_actual (Q : Nat) (iv : Digest32) (cache : RawKey Q → Opti ((compile_counted source Q).mpr counted) exact ⟨suffix,eq.symm⟩ -/-- Failed commitment-order bookkeeping is sticky. Previously captured commitments remain available, but an invalid source chronology is never silently repaired by later announcements. -/ +/-- A failed commitment-order check records the first error, but does not stop observing later public compression calls. Otherwise a later root could capture a stale log even though the underlying source execution continued. Claims never install their purported family or point metadata. -/ def replayTracked (state : CausalBindingState.State cap) : List (Event cap) → CausalBindingState.State cap | [] => state | event :: rest => - match state.sourceError with - | some _ => state - | none => - match step state event with - | .error root => {state with sourceError := some root} - | .ok next => replayTracked next rest + match step state event with + | .error root => replayTracked {state with sourceError := state.sourceError.or (some root)} rest + | .ok next => replayTracked next rest theorem replayTracked_extends (state : CausalBindingState.State cap) (events : List (Event cap)) : CausalBindingState.Extends state (replayTracked state events) := by @@ -57,18 +54,63 @@ theorem replayTracked_extends (state : CausalBindingState.State cap) (events : L | nil => exact .refl _ | cons event rest ih => unfold replayTracked - cases failed : state.sourceError with - | some root => exact .refl _ - | none => - cases progress : step state event with - | error root => exact ⟨fun _ _ h => h,fun _ _ h => h,fun _ _ _ => rfl, - fun _ _ _ h => h,fun _ _ _ => rfl⟩ - | ok next => exact (step_extends state next event progress).trans (ih next) - -theorem replayTracked_failed (state : CausalBindingState.State cap) (events : List (Event cap)) + cases progress : step state event with + | error root => + exact (show CausalBindingState.Extends state + {state with sourceError := state.sourceError.or (some root)} from + ⟨fun _ _ h => h,fun _ _ h => h,fun _ _ _ => rfl, + fun _ _ _ h => h,fun _ _ _ => rfl⟩).trans (ih _) + | ok next => exact (step_extends state next event progress).trans (ih next) + +@[simp] theorem observeRecords_sourceError (state : CausalBindingState.State cap) + (records : MerkleTransport.Commitments.Records) : + (observeRecords state records).sourceError = state.sourceError := by + induction records generalizing state with + | nil => rfl + | cons record rest ih => + change (observeRecords (CausalBindingState.observe state record.1 record.2) rest).sourceError = _ + rw [ih] + unfold CausalBindingState.observe + split <;> rfl + +@[simp] theorem observePublic_sourceError (state : CausalBindingState.State cap) + (input : DuplexFraming.Node) (answer : Digest32) : + (observePublic state input answer).sourceError = state.sourceError := by + simp [observePublic] + +@[simp] theorem registerRoot_sourceError (state : CausalBindingState.State cap) (root : Digest32) : + (CausalBindingState.registerRoot state root).sourceError = state.sourceError := by + unfold CausalBindingState.registerRoot + split <;> rfl + +theorem step_sourceError (state next : CausalBindingState.State cap) (event : Event cap) + (success : step state event = .ok next) : next.sourceError = state.sourceError := by + cases event with + | answer query value => + cases query with + | primitive purpose input => cases success; exact observePublic_sourceError _ _ _ + | construction coordinate valid => cases success; rfl + | commit root => cases success; exact registerRoot_sourceError _ _ + | claims profile entry request => + unfold step at success + cases found : MerkleTransport.Commitments.lookup request.root state.registry with + | none => simp [found] at success + | some snapshot => + simp only [found] at success + cases success + rfl + +/-- Observing subsequent events cannot repair or replace the first chronology error. -/ +theorem replayTracked_error_sticky (state : CausalBindingState.State cap) (events : List (Event cap)) (root : Digest32) (failed : state.sourceError = some root) : - replayTracked state events = state := by - cases events <;> simp [replayTracked,failed] + (replayTracked state events).sourceError = some root := by + induction events generalizing state with + | nil => exact failed + | cons event rest ih => + unfold replayTracked + cases progress : step state event with + | error later => exact ih _ (by simp [failed]) + | ok next => exact ih next ((step_sourceError state next event progress).trans failed) def publicReplay (Q : Nat) (iv : Digest32) (cache : RawKey Q → Option Digest32) (view : View (Result cap R)) (state : CausalBindingState.State cap) : diff --git a/verification/whir/Whir/WHIRSourcePartialMonotone.lean b/verification/whir/Whir/WHIRSourcePartialMonotone.lean new file mode 100644 index 000000000..531a07307 --- /dev/null +++ b/verification/whir/Whir/WHIRSourcePartialMonotone.lean @@ -0,0 +1,385 @@ +import Whir.DuplexPublicSimulator +import Whir.WHIRSourceChronology +import Whir.WHIRSourceResolver + +/-! Finite-cache replay is monotone for a fixed source and fixed simulator coins. +A cache extension preserves answers, not just domains: overwriting a repeated raw +key with a different digest is deliberately not an extension. Metadata recovery +includes all free instructions before the first unanswered public query. + +`allocationEvents_mono` derives cursor growth from actual prepare/addGroup +operations and finite-cache consistency. `runPartial_covers_prefix` and +`replay_factor` locate the next raw allocation in the public observation stream. +`source_complete` needs only the actual finite request schedule to be cached. +The public cutoff theorem transports these private fixed-source facts through +the compiler-owned view equality; the public data contains no total oracle. -/ +namespace Whir.WHIRSourcePartialMonotone +open FiatShamirGame DuplexModeGame DuplexFraming DuplexPublicSimulator +open WHIRSourceChronology + +variable {Q cap : Nat} {R : Type} + +def CacheExtends (old new : RawKey Q → Option Digest32) : Prop := + ∀ key answer, old key = some answer → new key = some answer + +theorem CacheExtends.refl (cache : RawKey Q → Option Digest32) : CacheExtends cache cache := + fun _ _ h => h + +theorem CacheExtends.trans {a b c : RawKey Q → Option Digest32} + (ab : CacheExtends a b) (bc : CacheExtends b c) : CacheExtends a c := + fun key answer h => bc key answer (ab key answer h) + +private theorem prefix_cons {α : Type} {a b : List α} (h : a.IsPrefix b) (x : α) : + (x :: a).IsPrefix (x :: b) := by + obtain ⟨rest,rfl⟩ := h + exact ⟨rest,rfl⟩ + +theorem runPartialRO_mono {old new : RawKey Q → Option Digest32} + (growth : CacheExtends old new) (p : ROProgram Q R) (result : R) + (success : runPartialRO old p = .ok result) : runPartialRO new p = .ok result := by + induction p with + | done r => exact success + | ask key next ih => + cases h : old key with + | none => simp [runPartialRO,h] at success + | some answer => + simpa only [runPartialRO,growth key answer h] using + ih answer (by simpa only [runPartialRO,h] using success) + +/-- Fallback C calls and primitive cache hits are ordinary successful RO programs; +this theorem does not require a new raw allocation for every observation. -/ +theorem runPartial_mono {old new : RawKey Q → Option Digest32} + (growth : CacheExtends old new) (iv : Digest32) (state : State) (p : Program R) + (remaining : Nat) (limit : remaining ≤ Q) (counted : DuplexModeGame.Counts remaining p) : + (runPartial old iv state p remaining limit counted).observations.IsPrefix + (runPartial new iv state p remaining limit counted).observations := by + induction p generalizing state remaining with + | done r => exact ⟨[],rfl⟩ + | ask query next ih => + cases query with + | primitive purpose input => + cases h : runPartialRO old ((simulator Q).answer state input) with + | error key => simp [runPartial,h] + | ok answer => + have hn := runPartialRO_mono growth _ answer h + simpa only [runPartial,h,hn,prependPartial] using + prefix_cons (ih answer.2 answer.1 (remaining-1) (by omega) (counted.2 _)) _ + | construction q valid => + cases h : old (constructionKey Q iv q (counted.1.trans limit)) with + | none => simp [runPartial,h] + | some answer => + simpa only [runPartial,h,growth _ answer h,prependPartial] using + prefix_cons (ih answer state (remaining-pathCost q) (by omega) (counted.2 _)) _ + +/-- Free commits and claims before a pending query are retained at both cursors. -/ +theorem recover_mono (source : Source cap R) {old new : List Observation} + (prior : old.IsPrefix new) : (recover source old).events.IsPrefix (recover source new).events := by + induction source generalizing old new with + | done r => exact ⟨[],rfl⟩ + | ask query next ih => + cases old with + | nil => simp [recover] + | cons answer rest => + obtain ⟨suffix,hs⟩ := prior + subst new + simpa only [List.cons_append,recover,prependPrefix] using + prefix_cons (ih answer.answer (List.prefix_append rest suffix)) _ + | commit root next ih => exact prefix_cons (ih prior) _ + | claims profile entry request next ih => exact prefix_cons (ih prior) _ + +theorem sourceEvents_mono {old new : RawKey Q → Option Digest32} + (growth : CacheExtends old new) (iv : Digest32) (seed : Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) : + (recover source (runPartial old iv ((simulator Q).initial seed) (compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations).events.IsPrefix + (recover source (runPartial new iv ((simulator Q).initial seed) (compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations).events := + recover_mono source (runPartial_mono growth iv _ _ _ _ _) + +theorem runPartialRO_complete (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (p : ROProgram Q R) + (covered : ∀ key ∈ requests ro p, cache key = some (ro key)) : + runPartialRO cache p = .ok (runRO ro p).1 := by + induction p with + | done r => rfl + | ask key next ih => + have hit := covered key (by simp [requests]) + simpa only [runPartialRO,hit,runRO] using + ih (ro key) (fun k hk => covered k (by simp [requests,hk])) + +/-- Coverage refers only to the actual requested keys, not to a total cache. -/ +theorem runPartial_complete (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program R) + (remaining : Nat) (limit : remaining ≤ Q) (counted : DuplexModeGame.Counts remaining p) + (covered : ∀ key ∈ actualRequests ro iv state p remaining limit counted, + cache key = some (ro key)) : + runPartial cache iv state p remaining limit counted = + ⟨(runIdeal (simulator Q) ro iv state p remaining limit counted).view.observations, + .ok (runIdeal (simulator Q) ro iv state p remaining limit counted).view.result⟩ := by + induction p generalizing state remaining with + | done r => rfl + | ask query next ih => + cases query with + | primitive purpose input => + have hit := runPartialRO_complete cache ro ((simulator Q).answer state input) + (fun k hk => covered k (List.mem_append_left _ hk)) + have rest := ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 (remaining-1) (by omega) + (counted.2 _) (fun k hk => covered k (List.mem_append_right _ hk)) + simp only [runPartial,hit,rest,prependPartial,runIdeal,DuplexModeGame.prepend] + | construction q valid => + have hit := covered (constructionKey Q iv q (counted.1.trans limit)) (by simp [actualRequests]) + have rest := ih (ro (constructionKey Q iv q (counted.1.trans limit))) state + (remaining-pathCost q) (by omega) (counted.2 _) + (fun k hk => covered k (List.mem_cons_of_mem _ hk)) + simp only [runPartial,hit,rest,prependPartial,runIdeal,DuplexModeGame.prepend] + +theorem source_complete (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) (iv : Digest32) (seed : Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (covered : ∀ key ∈ actualRequests ro iv ((simulator Q).initial seed) (compile source) + Q (by omega) ((compile_counted source Q).mpr counted), cache key = some (ro key)) : + recover source (runPartial cache iv ((simulator Q).initial seed) (compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).observations = + completedPrefix (runIdeal (simulator Q) ro iv ((simulator Q).initial seed) (compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).view.result := by + rw [runPartial_complete cache ro iv _ _ _ _ _ covered] + exact recover_ideal (simulator Q) ro iv _ source Q (by omega) counted + +/-- Acquiring all raw requests of an actual observation prefix reaches at least +that prefix. Deterministic fallback and repeated primitive hits need no cell. -/ +theorem runPartial_covers_prefix (cache : RawKey Q → Option Digest32) + (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) + (remaining : Nat) (limit : remaining ≤ Q) (counted : DuplexModeGame.Counts remaining p) + (seen : List Observation) + (prior : seen.IsPrefix + (runIdeal (simulator Q) ro iv state p remaining limit counted).view.observations) + (covered : ∀ key ∈ DuplexPublicSimulator.replay Q iv state.publicLog seen, + cache key = some (ro key)) : + seen.IsPrefix (runPartial cache iv state p remaining limit counted).observations := by + induction p generalizing state remaining seen with + | done r => simpa only [runIdeal,runPartial] using prior + | ask query next ih => + cases seen with + | nil => exact List.nil_prefix + | cons observation rest => + cases query with + | primitive purpose input => + let answer := (runRO ro ((simulator Q).answer state input)).1 + have split : observation = ⟨.primitive purpose input,answer.2⟩ ∧ + rest.IsPrefix (runIdeal (simulator Q) ro iv answer.1 (next answer.2) + (remaining-1) (by omega) (counted.2 _)).view.observations := by + simpa only [runIdeal,DuplexModeGame.prepend,List.cons_prefix_cons] using prior + rcases split with ⟨rfl,tail⟩ + have hit := runPartialRO_complete cache ro ((simulator Q).answer state input) + (fun k hk => covered k (by + simp only [DuplexPublicSimulator.replay,answer_requests] at * + exact List.mem_append_left _ hk)) + have restHit : ∀ key ∈ DuplexPublicSimulator.replay Q iv answer.1.publicLog rest, + cache key = some (ro key) := by + intro k hk + apply covered k + simp only [DuplexPublicSimulator.replay] + apply List.mem_append_right + simpa only [answer,answer_publicLog] using hk + simpa only [runPartial,hit,prependPartial] using + prefix_cons (ih answer.2 answer.1 (remaining-1) (by omega) + (counted.2 _) rest tail restHit) _ + | construction q valid => + let key := constructionKey Q iv q (counted.1.trans limit) + have split : observation = ⟨.construction q valid,ro key⟩ ∧ + rest.IsPrefix (runIdeal (simulator Q) ro iv state (next (ro key)) + (remaining-pathCost q) (by omega) (counted.2 _)).view.observations := by + simpa only [runIdeal,DuplexModeGame.prepend,List.cons_prefix_cons] using prior + rcases split with ⟨rfl,tail⟩ + have hq : pathCost q ≤ Q := counted.1.trans limit + have hit : cache key = some (ro key) := covered key (by + simp [DuplexPublicSimulator.replay,hq,key]) + have restHit : ∀ k ∈ DuplexPublicSimulator.replay Q iv state.publicLog rest, + cache k = some (ro k) := by + intro k hk + exact covered k (by simp [DuplexPublicSimulator.replay,hq,hk]) + dsimp only [key] at hit + simpa only [runPartial,hit,prependPartial] using + prefix_cons (ih (ro key) state (remaining-pathCost q) (by omega) + (counted.2 _) rest tail restHit) _ + +theorem addGroup_cacheExtends (ctx : RawWHIRKeys.Context) (ro : RawKey Q → Digest32) + (state : CausalBindingState.State cap) + (agrees : WHIRSourceRawCache.LogAgrees ro (state.rawAnswers Q)) + (group : RawOracleCoupling.Concrete.GroupKey ctx Q) : + CacheExtends (WHIRSourceRawCache.cache Q state) + (WHIRSourceRawCache.cache Q (WHIRSourceRawCache.addGroup ctx Q state group + ((RawOracleCoupling.Concrete.partition ctx Q).split ro group))) := + WHIRSourceRawCache.cache_addGroup_preserves ctx Q ro state agrees group + +theorem cache_eq_of_raw_eq (left right : CausalBindingState.State cap) + (same : right.rawAnswers = left.rawAnswers) : + WHIRSourceRawCache.cache Q right = WHIRSourceRawCache.cache Q left := by + simp only [WHIRSourceRawCache.cache,same] + +/-- Preparation and bookkeeping replay do not allocate raw replies. -/ +theorem replay_cache (state : CausalBindingState.State cap) (events : List (Event cap)) : + WHIRSourceRawCache.cache Q (WHIRSourceObserver.replayTracked state events) = + WHIRSourceRawCache.cache Q state := + cache_eq_of_raw_eq _ _ (WHIRSourceRawCache.replayTracked_raw state events) + +theorem prepare_cache (registry : WHIRCallerRegistry.Public) (seed : Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) + (key : RawOracleCoupling.Concrete.AllocationKey (WHIRCallerRegistry.context registry) Q) : + WHIRSourceRawCache.cache Q + (WHIRCausalRawROM.prepare (WHIRCallerRegistry.context registry) rfl Q cap + (WHIRSourceResolver.privateResolver registry Q seed source counted) state key).1 = + WHIRSourceRawCache.cache Q state := + cache_eq_of_raw_eq _ _ (WHIRSourceResolver.privatePrepare_raw registry Q seed source counted state key) + +theorem privateEvents_mono {old new : RawKey Q → Option Digest32} + (growth : CacheExtends old new) (iv : Digest32) (seed : Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) : + (WHIRSourceObserver.privateEvents Q iv old seed source counted).IsPrefix + (WHIRSourceObserver.privateEvents Q iv new seed source counted) := + sourceEvents_mono growth iv seed source counted + +/-- The public cutoff inherits monotonicity on the actual compiler-owned view; +neither a source machine nor a total oracle is stored in that view. -/ +theorem publicEvents_mono {old new : RawKey Q → Option Digest32} + (growth : CacheExtends old new) (ro : RawKey Q → Digest32) + (oldAgrees : CacheAgrees old ro) (newAgrees : CacheAgrees new ro) + (iv : Digest32) (seed : Seed) (source : Source cap R) + (counted : WHIRSourceChronology.Counts Q source) : + let view := (runIdeal (simulator Q) ro iv ((simulator Q).initial seed) (compile source) + Q (by omega) ((compile_counted source Q).mpr counted)).view + (WHIRSourceObserver.publicEvents Q iv old view).IsPrefix + (WHIRSourceObserver.publicEvents Q iv new view) := by + dsimp only + rw [WHIRSourceObserver.publicEvents_actual Q iv old ro oldAgrees seed source counted, + WHIRSourceObserver.publicEvents_actual Q iv new ro newAgrees seed source counted] + exact privateEvents_mono growth iv seed source counted + +/-- At most one raw request is emitted by a public observation. -/ +def queryKey (Q : Nat) (iv : Digest32) (log : PublicLog) : Query → Option (RawKey Q) + | .primitive _ input => privateKey Q log input + | .construction q _ => if h : pathCost q ≤ Q then some (constructionKey Q iv q h) else none + +theorem replay_cons (iv : Digest32) (log : PublicLog) (observation : Observation) + (rest : List Observation) : + DuplexPublicSimulator.replay Q iv log (observation :: rest) = + (queryKey Q iv log observation.query).toList ++ + DuplexPublicSimulator.replay Q iv (finalLog log [observation]) rest := by + rcases observation with ⟨query,answer⟩ + cases query with + | primitive => rfl + | construction q valid => + by_cases h : pathCost q ≤ Q <;> + simp [DuplexPublicSimulator.replay,queryKey,finalLog,h] + +/-- Locate an actual raw request at its emitting public query, retaining every +preceding fallback/cache-hit observation even though it emitted no request. -/ +theorem replay_factor (iv : Digest32) (log : PublicLog) (observations : List Observation) + (prior : List (RawKey Q)) (current : RawKey Q) (rest : List (RawKey Q)) + (schedule : DuplexPublicSimulator.replay Q iv log observations = prior ++ current :: rest) : + ∃ before observation after, + observations = before ++ observation :: after ∧ + DuplexPublicSimulator.replay Q iv log before = prior ∧ + queryKey Q iv (finalLog log before) observation.query = some current := by + induction observations generalizing log prior with + | nil => simp [DuplexPublicSimulator.replay] at schedule + | cons observation tail ih => + rw [replay_cons] at schedule + cases key : queryKey Q iv log observation.query with + | none => + simp only [key,Option.toList_none,List.nil_append] at schedule + obtain ⟨before,emitter,after,split,replayed,origin⟩ := + ih (finalLog log [observation]) prior schedule + refine ⟨observation :: before,emitter,after,by simp [split],?_,?_⟩ + · rw [replay_cons,key] + exact replayed + · cases observation with + | mk query answer => cases query <;> exact origin + | some raw => + simp only [key,Option.toList_some,List.cons_append,List.nil_append] at schedule + cases prior with + | nil => + have equal : raw = current := (List.cons.inj schedule).1 + exact ⟨[],observation,tail,rfl,rfl,by simpa only [finalLog,equal] using key⟩ + | cons first prior => + have equal : raw = first := (List.cons.inj schedule).1 + obtain ⟨before,emitter,after,split,replayed,origin⟩ := + ih (finalLog log [observation]) prior (List.cons.inj schedule).2 + refine ⟨observation :: before,emitter,after,by simp [split],?_,?_⟩ + · rw [replay_cons,key] + simp only [Option.toList_some,List.cons_append,List.nil_append,equal,replayed] + · cases observation with + | mk query answer => cases query <;> exact origin + +/-- One actual resolver allocation advances the source cursor. The premise is +finite cache/table consistency, never an assumed cursor monotonicity invariant. -/ +theorem allocationEvents_mono (registry : WHIRCallerRegistry.Public) (ro : RawKey Q → Digest32) + (seed : Seed) (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (state : CausalBindingState.State cap) + (agrees : WHIRSourceRawCache.LogAgrees ro (state.rawAnswers Q)) + (key : RawOracleCoupling.Concrete.AllocationKey (WHIRCallerRegistry.context registry) Q) : + let prepared := (WHIRCausalRawROM.prepare (WHIRCallerRegistry.context registry) rfl Q cap + (WHIRSourceResolver.privateResolver registry Q seed source counted) state key).1 + let next := (WHIRSourceResolver.after registry Q prepared key + ((RawOracleCoupling.Concrete.partition (WHIRCallerRegistry.context registry) Q).split ro key.1)).state + (WHIRSourceObserver.privateEvents Q registry.iv (WHIRSourceRawCache.cache Q state) + seed source counted).IsPrefix + (WHIRSourceObserver.privateEvents Q registry.iv (WHIRSourceRawCache.cache Q next) + seed source counted) := by + dsimp only + apply privateEvents_mono + rw [← prepare_cache registry seed source counted state key] + apply addGroup_cacheExtends + simpa only [WHIRSourceResolver.privatePrepare_raw] using agrees + +-- Executable source progression: no total cache and no fabricated cache misses. +#eval show IO Unit from do + let digest (n : Nat) : Digest32 := fun _ => ⟨n % 256,Nat.mod_lt _ (by decide)⟩ + let block : DuplexRefinement.Block64 := fun i => ⟨i.val,by omega⟩ + let seedNode : Node := ⟨digest 41,block,UInt64.ofNat (2^56),true⟩ + let internal : Node := ⟨digest 41,block,UInt64.ofNat (2*2^56+17),true⟩ + let terminal : Node := ⟨digest 2,block,UInt64.ofNat (6*2^56+23),true⟩ + let seed : Seed := fun n => if isSeed n then n.cv else digest 2 + let coordinate : Coordinate := ⟨⟨digest 0,digest 1,[]⟩,.output 0⟩ + have valid : DuplexEncoding.Admissible coordinate := by + simp [coordinate,DuplexEncoding.Admissible,DuplexEncoding.TerminalValid] + let source : Source 0 Digest32 := + .commit (digest 10) (.ask (.primitive .direct seedNode) (fun _ => + .ask (.primitive .auxiliary internal) (fun _ => + .commit (digest 11) (.ask (.primitive .verification terminal) (fun _ => + .commit (digest 12) (.ask (.primitive .pow terminal) (fun _ => + .ask (.construction coordinate valid) (fun _ => + .commit (digest 13) (.ask (.construction coordinate valid) Source.done))))))))) + have counted : WHIRSourceChronology.Counts 16 source := by + simp [source,WHIRSourceChronology.Counts,Query.cost,pathCost,DuplexEncoding.plan,coordinate] + let ro : RawKey 16 → Digest32 := fun _ => digest 99 + let initial := (simulator 16).initial seed + let keys : List (RawKey 16) := actualRequests ro (digest 0) initial (compile source) 16 (by omega) + ((compile_counted source 16).mpr counted) + let finiteCache (n : Nat) : RawKey 16 → Option Digest32 := + fun key => if key ∈ keys.take n then some (ro key) else none + let progress (n : Nat) := runPartial (finiteCache n) (digest 0) initial (compile source) + 16 (by omega) ((compile_counted source 16).mpr counted) + let a := progress 0 + let b := progress 1 + let c := progress 2 + let commits (events : List (Event 0)) : List Nat := events.filterMap (fun (e : Event 0) => + match e with | .commit root => some (root ⟨0,by decide⟩).val | _ => none) + let checks : List (String × Bool) := [ + ("actual repeated raw schedule",keys.length == 3 && + decide ((keys[1]? : Option (RawKey 16)) = keys[2]?)), + ("fallbacks reach first missing terminal",a.observations.length == 2 && + commits (recover source a.observations).events == [10,11]), + ("primitive hit advances between raw queries",b.observations.length == 4 && + commits (recover source b.observations).events == [10,11,12]), + ("finite two-key cache completes repeated construction",c.observations.length == 6 && + commits (recover source c.observations).events == [10,11,12,13] && + decide ((recover source c.observations).value = some (digest 99)))] + for (name,ok) in checks do + if !ok then throw (IO.userError s!"source partial replay smoke failed: {name}") + IO.println s!"source partial replay: {name}: true" + +end Whir.WHIRSourcePartialMonotone diff --git a/verification/whir/Whir/WHIRSourceRawCache.lean b/verification/whir/Whir/WHIRSourceRawCache.lean new file mode 100644 index 000000000..9dac93e66 --- /dev/null +++ b/verification/whir/Whir/WHIRSourceRawCache.lean @@ -0,0 +1,205 @@ +import Whir.WHIRSourceObserver +import Whir.RawOracleProvenance + +namespace Whir.WHIRSourceRawCache +open FiatShamirGame DuplexModeGame RawOracleCoupling.Concrete +open WHIRSourceChronology WHIRSourceObserver + +variable {cap : Nat} + +private def lookup {Key : Type} [DecidableEq Key] : List (Key × Digest32) → Key → Option Digest32 + | [], _ => none + | (key,answer) :: rest, wanted => if wanted = key then some answer else lookup rest wanted + +def cache (Q : Nat) (state : CausalBindingState.State cap) : RawKey Q → Option Digest32 := + lookup (state.rawAnswers Q) + +def LogAgrees (ro : RawKey Q → Digest32) (entries : List (RawKey Q × Digest32)) : Prop := + ∀ entry ∈ entries, entry.2 = ro entry.1 + +theorem lookup_agrees (Q : Nat) (ro : RawKey Q → Digest32) + (entries : List (RawKey Q × Digest32)) (agrees : LogAgrees ro entries) : + DuplexPublicSimulator.CacheAgrees (lookup entries) ro := by + induction entries with + | nil => intro key answer found; simp [lookup] at found + | cons entry rest ih => + intro key answer found + by_cases same : key = entry.1 + · simp only [lookup,ite_eq_left same,Option.some.injEq] at found + exact found.symm.trans ((agrees entry (by simp)).trans (congrArg ro same.symm)) + · have hit : lookup rest key = some answer := by simpa [lookup,same] using found + exact ih (fun e he => agrees e (List.mem_cons_of_mem _ he)) key answer hit + +/-- A packet supplies exactly its finite output blocks; a garbage allocation supplies its single exact raw input. -/ +def groupEntries (ctx : RawWHIRKeys.Context) (Q : Nat) : + (key : GroupKey ctx Q) → GroupAnswer ctx Q key → List (RawKey Q × Digest32) + | .inl packet, answer => List.ofFn (fun block => (RawWHIRKeys.encode ctx Q ⟨packet,block⟩,answer block)) + | .inr raw, answer => [(raw.val,answer)] + +theorem groupEntries_table (ctx : RawWHIRKeys.Context) (Q : Nat) + (ro : RawKey Q → Digest32) (key : GroupKey ctx Q) : + LogAgrees ro (groupEntries ctx Q key ((partition ctx Q).split ro key)) := by + cases key with + | inl packet => + intro entry member + obtain ⟨block,rfl⟩ := List.mem_ofFn.mp member + rfl + | inr raw => + intro entry member + have equal : entry = (raw.val,ro raw.val) := by + simpa [groupEntries,RawOracleCoupling.Partition.split] using member + subst entry + rfl + +/-- Only newly supplied finite group cells are copied. On actual executions every stored answer agrees with the same raw table, including any repeated cell. -/ +def addGroup (ctx : RawWHIRKeys.Context) (Q : Nat) (state : CausalBindingState.State cap) + (key : GroupKey ctx Q) (answer : GroupAnswer ctx Q key) : CausalBindingState.State cap := + {state with rawAnswers := fun q => + if h : q = Q then + h.symm ▸ (groupEntries ctx Q key answer ++ state.rawAnswers Q) + else state.rawAnswers q} + +@[simp] theorem addGroup_entries (ctx : RawWHIRKeys.Context) (Q : Nat) + (state : CausalBindingState.State cap) (key : GroupKey ctx Q) (answer : GroupAnswer ctx Q key) : + (addGroup ctx Q state key answer).rawAnswers Q = groupEntries ctx Q key answer ++ state.rawAnswers Q := by + simp [addGroup] + +theorem addGroup_extends (ctx : RawWHIRKeys.Context) (Q : Nat) + (state : CausalBindingState.State cap) (key : GroupKey ctx Q) (answer : GroupAnswer ctx Q key) : + CausalBindingState.Extends state (addGroup ctx Q state key answer) := + ⟨fun _ _ h => h,fun _ _ h => h,fun _ _ _ => rfl,fun _ _ _ h => h,fun _ _ _ => rfl⟩ + +theorem addGroup_agrees (ctx : RawWHIRKeys.Context) (Q : Nat) + (ro : RawKey Q → Digest32) (state : CausalBindingState.State cap) + (agrees : LogAgrees ro (state.rawAnswers Q)) (key : GroupKey ctx Q) : + LogAgrees ro ((addGroup ctx Q state key ((partition ctx Q).split ro key)).rawAnswers Q) := by + rw [addGroup_entries] + intro entry member + rcases List.mem_append.mp member with fresh | old + · exact groupEntries_table ctx Q ro key entry fresh + · exact agrees entry old + +private theorem lookup_hit_iff (Q : Nat) (ro : RawKey Q → Digest32) + (entries : List (RawKey Q × Digest32)) (agrees : LogAgrees ro entries) + (key : RawKey Q) (answer : Digest32) : + lookup entries key = some answer ↔ (key,answer) ∈ entries := by + induction entries with + | nil => simp [lookup] + | cons entry rest ih => + have tail := fun e he => agrees e (List.mem_cons_of_mem _ he) + by_cases same : key = entry.1 + · simp only [lookup,same,↓reduceIte,Option.some.injEq,List.mem_cons] + constructor + · intro equal + exact Or.inl (Prod.ext rfl equal.symm) + · intro member + rcases member with equal | member + · exact (congrArg Prod.snd equal).symm + · exact (agrees entry (by simp)).trans + (tail (entry.1,answer) member).symm + · simp only [lookup,same,↓reduceIte,List.mem_cons,ih tail] + constructor + · exact Or.inr + · intro member + rcases member with equal | member + · exact (same (congrArg Prod.fst equal)).elim + · exact member + +theorem cache_hit_iff (Q : Nat) (ro : RawKey Q → Digest32) + (state : CausalBindingState.State cap) (agrees : LogAgrees ro (state.rawAnswers Q)) + (key : RawKey Q) (answer : Digest32) : + cache Q state key = some answer ↔ (key,answer) ∈ state.rawAnswers Q := + lookup_hit_iff Q ro (state.rawAnswers Q) agrees key answer + +theorem cache_addGroup_preserves (ctx : RawWHIRKeys.Context) (Q : Nat) + (ro : RawKey Q → Digest32) (state : CausalBindingState.State cap) + (agrees : LogAgrees ro (state.rawAnswers Q)) (group : GroupKey ctx Q) + (key : RawKey Q) (answer : Digest32) (hit : cache Q state key = some answer) : + cache Q (addGroup ctx Q state group ((partition ctx Q).split ro group)) key = some answer := by + apply (cache_hit_iff Q ro _ (addGroup_agrees ctx Q ro state agrees group) key answer).mpr + rw [addGroup_entries] + exact List.mem_append_right _ ((cache_hit_iff Q ro state agrees key answer).mp hit) + +theorem cache_addGroup_member (ctx : RawWHIRKeys.Context) (Q : Nat) + (ro : RawKey Q → Digest32) (state : CausalBindingState.State cap) + (agrees : LogAgrees ro (state.rawAnswers Q)) (group : GroupKey ctx Q) + (key : RawKey Q) (answer : Digest32) + (member : (key,answer) ∈ groupEntries ctx Q group ((partition ctx Q).split ro group)) : + cache Q (addGroup ctx Q state group ((partition ctx Q).split ro group)) key = some answer := by + apply (cache_hit_iff Q ro _ (addGroup_agrees ctx Q ro state agrees group) key answer).mpr + rw [addGroup_entries] + exact List.mem_append_left _ member + +@[simp] theorem observe_raw (state : CausalBindingState.State cap) (bytes : List Byte) (answer : Digest32) : + (CausalBindingState.observe state bytes answer).rawAnswers = state.rawAnswers := by + unfold CausalBindingState.observe + split <;> rfl + +@[simp] theorem registerRoot_raw (state : CausalBindingState.State cap) (root : Digest32) : + (CausalBindingState.registerRoot state root).rawAnswers = state.rawAnswers := by + unfold CausalBindingState.registerRoot + split <;> rfl + +@[simp] theorem registerRoots_raw (state : CausalBindingState.State cap) (roots : List Digest32) : + (CausalBindingState.registerRoots state roots).rawAnswers = state.rawAnswers := by + induction roots generalizing state with + | nil => rfl + | cons root rest ih => + change (CausalBindingState.registerRoots (CausalBindingState.registerRoot state root) rest).rawAnswers = _ + rw [ih,registerRoot_raw] + +@[simp] theorem registerStatement_raw (state : CausalBindingState.State cap) (p : ParameterBounds.Profile) + (entry : FramedHistory) (data : Option (WHIRFiatShamir.StackInitial p cap)) : + (CausalBindingState.registerStatement state p entry data).rawAnswers = state.rawAnswers := by + unfold CausalBindingState.registerStatement + split <;> rfl + +@[simp] theorem prepareClaims_raw (state : CausalBindingState.State cap) (p : ParameterBounds.Profile) + (entry : FramedHistory) (key : StackWHIRReplay.Key p) + (request : Option (CausalBindingState.ClaimRequest cap p)) : + (CausalBindingState.prepareClaims state p entry key request).1.rawAnswers = state.rawAnswers := by + cases request <;> simp [CausalBindingState.prepareClaims,CausalBindingState.prepare, + CausalBindingState.registerFootprint,CausalBindingState.commit] + +@[simp] theorem observeRecords_raw (state : CausalBindingState.State cap) + (records : MerkleTransport.Commitments.Records) : + (observeRecords state records).rawAnswers = state.rawAnswers := by + induction records generalizing state with + | nil => rfl + | cons record rest ih => + change (observeRecords (CausalBindingState.observe state record.1 record.2) rest).rawAnswers = _ + rw [ih,observe_raw] + +@[simp] theorem observePublic_raw (state : CausalBindingState.State cap) + (input : DuplexFraming.Node) (answer : Digest32) : + (observePublic state input answer).rawAnswers = state.rawAnswers := by + simp [observePublic] + +theorem step_raw (state next : CausalBindingState.State cap) (event : Event cap) + (success : step state event = .ok next) : next.rawAnswers = state.rawAnswers := by + cases event with + | answer query value => + cases query with + | primitive purpose input => cases success; exact observePublic_raw _ _ _ + | construction coordinate valid => cases success; rfl + | commit root => cases success; exact registerRoot_raw _ _ + | claims profile entry request => + unfold step at success + cases found : MerkleTransport.Commitments.lookup request.root state.registry with + | none => simp [found] at success + | some snapshot => + simp only [found] at success + cases success + rfl + +@[simp] theorem replayTracked_raw (state : CausalBindingState.State cap) (events : List (Event cap)) : + (replayTracked state events).rawAnswers = state.rawAnswers := by + induction events generalizing state with + | nil => rfl + | cons event rest ih => + unfold replayTracked + cases progress : step state event with + | error root => exact ih _ + | ok next => exact (ih next).trans (step_raw state next event progress) + +end Whir.WHIRSourceRawCache diff --git a/verification/whir/Whir/WHIRSourceRawProgram.lean b/verification/whir/Whir/WHIRSourceRawProgram.lean new file mode 100644 index 000000000..518f5126e --- /dev/null +++ b/verification/whir/Whir/WHIRSourceRawProgram.lean @@ -0,0 +1,208 @@ +import Whir.DuplexRawProgram +import Whir.DuplexPublicSimulator +import Whir.WHIRObservableAllocations + +/-! Source-only fuel for the actual public-log simulator. The ambient key domain +may be larger than the independently counted source. Lowering uses the existing +raw compiler and stop operation; no raw oracle is an input to the sampler. +The exact chronological trace retains repeated construction calls and omits +primitive cache hits precisely as the chosen simulator does. + +`bounded_eval` rules out exhaustion at source fuel A, while +`bounded_rawAnswers` identifies the full executed answer trace with public +replay. `source_path_length_le` and `bounded_length_le` bound public and raw +request counts by A; `bounded_key_lengths` separately bounds both components +of every raw key's physical path by A, starting from any fixed private seed. -/ +namespace Whir.WHIRSourceRawProgram +open FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open DuplexRefinement hiding State +open DuplexPublicSimulator +open DuplexRawProgram (compileIdeal stop) + +/-- The chosen simulator spends at most one raw call per primitive; a +construction spends one, charged to its positive source path cost. -/ +theorem compileIdeal_calls_le {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (A : Nat) (sourceCounted : Counts A p) : + (runRO ro (compileIdeal (simulator Q) iv state p remaining cap counted)).2 ≤ A := by + induction p generalizing state remaining A with + | done r => simp [compileIdeal, runRO] + | ask query next ih => + cases query with + | primitive purpose input => + have hr := ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 + (remaining-1) (by omega) (counted.2 _) (A-1) (sourceCounted.2 _) + have ha := answer_queries_le_one Q ro state input + have hc : 1 ≤ A := sourceCounted.1 + simp only [compileIdeal, DuplexRawProgram.ROProgram.run_bind, + DuplexRawProgram.ROProgram.run_map] at ⊢ + omega + | construction q valid => + have hr := ih (ro (constructionKey Q iv q (counted.1.trans cap))) state + (remaining-pathCost q) (by omega) (counted.2 _) + (A-pathCost q) (sourceCounted.2 _) + have hp := DuplexRawProgram.pathCost_pos q + have hc : pathCost q ≤ A := sourceCounted.1 + simp only [compileIdeal, runRO, DuplexRawProgram.ROProgram.run_map] + omega + +/-- Executable source sampler, with source fuel rather than ambient-domain fuel. +Both Counts witnesses concern the same source program. -/ +def bounded (Q : Nat) {R : Type} (iv : Digest32) (state : State) + (p : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining p) (A : Nat) (_sourceCounted : Counts A p) : + Sampling (RawKey Q) (fun _ => Digest32) (Option (View R)) A := + stop A (compileIdeal (simulator Q) iv state p remaining cap counted) + +theorem bounded_eval {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (A : Nat) (sourceCounted : Counts A p) : + Sampling.eval ro (bounded Q iv state p remaining cap counted A sourceCounted) = + some (runIdeal (simulator Q) ro iv state p remaining cap counted).view := by + unfold bounded + rw [DuplexRawProgram.stop_exact ro _ _ + (compileIdeal_calls_le ro iv state p remaining cap counted A sourceCounted)] + rw [DuplexRawProgram.run_compileIdeal] + +theorem bounded_ne_exhausted {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (A : Nat) (sourceCounted : Counts A p) : + Sampling.eval ro (bounded Q iv state p remaining cap counted A sourceCounted) ≠ none := by + rw [bounded_eval] + exact Option.some_ne_none _ + +theorem requests_bind {Q : Nat} {R S : Type} (ro : RawKey Q → Digest32) + (p : ROProgram Q R) (f : R → ROProgram Q S) : + requests ro (DuplexRawProgram.ROProgram.bind p f) = + requests ro p ++ requests ro (f (runRO ro p).1) := by + induction p with + | done r => rfl + | ask key next ih => simp [DuplexRawProgram.ROProgram.bind, requests, runRO, ih] + +theorem requests_map {Q : Nat} {R S : Type} (ro : RawKey Q → Digest32) + (f : R → S) (p : ROProgram Q R) : + requests ro (DuplexRawProgram.ROProgram.map f p) = requests ro p := by + induction p with + | done r => rfl + | ask key next ih => simp [DuplexRawProgram.ROProgram.map, requests, ih] + +theorem requests_compileIdeal {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) : + requests ro (compileIdeal (simulator Q) iv state p remaining cap counted) = + actualRequests ro iv state p remaining cap counted := by + induction p generalizing state remaining with + | done r => rfl + | ask query next ih => + cases query with + | primitive purpose input => + simp only [compileIdeal, requests_bind, requests_map, actualRequests] + exact congrArg (requests ro ((simulator Q).answer state input) ++ ·) + (ih _ _ _ _ _) + | construction q valid => + simp only [compileIdeal, requests, requests_map, actualRequests] + exact congrArg (constructionKey Q iv q (counted.1.trans cap) :: ·) + (ih _ _ _ _ _) + +/-- Generic stopping preserves the complete answer sequence whenever fuel +covers actual calls. No deduplication is performed. -/ +theorem rawAnswers_stop {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (fuel : Nat) (p : ROProgram Q R) (enough : (runRO ro p).2 ≤ fuel) : + WHIRObservableAllocations.rawAnswers Q ro (stop fuel p) = + (requests ro p).map (fun key => (key,ro key)) := by + induction fuel generalizing p with + | zero => + cases p with + | done r => rfl + | ask key next => simp [runRO] at enough + | succ fuel ih => + cases p with + | done r => rfl + | ask key next => + have h : (runRO ro (next (ro key))).2 ≤ fuel := by + simp only [runRO] at enough + omega + simpa only [WHIRObservableAllocations.rawAnswers, stop, Sampling.execute, + List.map_cons, requests] using congrArg ((key,ro key) :: ·) (ih _ h) + +/-- Exact chronological raw answers, including repeated keys and the chosen +simulator's cache behavior, reconstructed only from the actual public view. -/ +theorem bounded_rawAnswers {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (A : Nat) (sourceCounted : Counts A p) : + WHIRObservableAllocations.rawAnswers Q ro + (bounded Q iv state p remaining cap counted A sourceCounted) = + replayAnswers Q iv state.publicLog + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations := by + unfold bounded + rw [rawAnswers_stop ro _ _ + (compileIdeal_calls_le ro iv state p remaining cap counted A sourceCounted), + requests_compileIdeal, ← replay_actual, ← replayAnswers_keys, List.map_map] + trans List.map id (replayAnswers Q iv state.publicLog + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations) + · apply List.map_congr_left + intro entry member + exact Prod.ext rfl (replayAnswers_consistent ro iv state p remaining cap counted entry member).symm + · exact List.map_id _ + +/-- The number of public source observations is bounded independently of Q. -/ +theorem source_path_length_le {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (A : Nat) (sourceCounted : Counts A p) : + (runIdeal (simulator Q) ro iv state p remaining cap counted).view.observations.length ≤ A := by + induction p generalizing state remaining A with + | done r => simp [runIdeal] + | ask query next ih => + cases query with + | primitive purpose input => + have hr := ih (runRO ro ((simulator Q).answer state input)).1.2 + (runRO ro ((simulator Q).answer state input)).1.1 + (remaining-1) (by omega) (counted.2 _) (A-1) (sourceCounted.2 _) + have hc : 1 ≤ A := sourceCounted.1 + simp only [runIdeal, prepend, List.length_cons] + omega + | construction q valid => + have hr := ih (ro (constructionKey Q iv q (counted.1.trans cap))) state + (remaining-pathCost q) (by omega) (counted.2 _) + (A-pathCost q) (sourceCounted.2 _) + have hp := DuplexRawProgram.pathCost_pos q + have hc : pathCost q ≤ A := sourceCounted.1 + simp only [runIdeal, prepend, List.length_cons] + omega + +theorem bounded_length_le {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (state : State) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (A : Nat) (sourceCounted : Counts A p) : + (WHIRObservableAllocations.rawAnswers Q ro + (bounded Q iv state p remaining cap counted A sourceCounted)).length ≤ A := by + simp only [WHIRObservableAllocations.rawAnswers, List.length_map, bounded, + DuplexRawProgram.execute_stop_length] + exact Nat.min_le_left _ _ + +/-- Each actual raw key's physical path is source-bounded, even when Q includes +additional completion capacity. Initial private seeds are arbitrary. -/ +theorem bounded_key_lengths {Q : Nat} {R : Type} (ro : RawKey Q → Digest32) + (iv : Digest32) (seed : Seed) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (A : Nat) (sourceCounted : Counts A p) : + ∀ entry ∈ WHIRObservableAllocations.rawAnswers Q ro + (bounded Q iv ((simulator Q).initial seed) p remaining cap counted A sourceCounted), + entry.1.1.1.val ≤ A ∧ entry.1.2.1.val ≤ A := by + rw [bounded_rawAnswers] + exact replayAnswers_source_bound ro iv seed p remaining cap counted A sourceCounted + +#print axioms compileIdeal_calls_le +#print axioms bounded_eval +#print axioms bounded_ne_exhausted +#print axioms bounded_rawAnswers +#print axioms source_path_length_le +#print axioms bounded_length_le +#print axioms bounded_key_lengths +end Whir.WHIRSourceRawProgram diff --git a/verification/whir/Whir/WHIRSourceResolver.lean b/verification/whir/Whir/WHIRSourceResolver.lean new file mode 100644 index 000000000..3643637b7 --- /dev/null +++ b/verification/whir/Whir/WHIRSourceResolver.lean @@ -0,0 +1,276 @@ +import Whir.WHIRSourceRawCache +import Whir.WHIRHeaderRoots +import Whir.WHIRCausalRawROM + +namespace Whir.WHIRSourceResolver +open FiatShamirGame DuplexModeGame RawOracleCoupling.Concrete +open WHIRSourceChronology WHIRSourceObserver WHIRCallerRegistry + +variable {cap : Nat} {R : Type} + +/-- Source observations are recovered from the compiler-owned public result. This discards completion-only queries without inspecting the source program, its coins, or a total oracle. -/ +def sourceView (result : Result cap R) : View (Result cap R) := + ⟨observations result.events,result⟩ + +theorem ideal_source_trace {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) + (source : Source cap R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : Counts remaining source) : + observations (runIdeal sim ro iv state (compile source) remaining limit + ((compile_counted source remaining).mpr counted)).view.result.events = + (runIdeal sim ro iv state (compile source) remaining limit + ((compile_counted source remaining).mpr counted)).view.observations := by + induction source generalizing state remaining with + | done => rfl + | ask query next ih => + cases query with + | primitive purpose input => + let answer := runRO ro (sim.answer state input) + have mapped := map_ideal sim ro iv answer.1.1 + (prepend (.answer (.primitive purpose input) answer.1.2)) + (compile (next answer.1.2)) (remaining-1) (by omega) + ((compile_counted _ _).mpr (counted.2 answer.1.2)) + have whole : runIdeal sim ro iv state (compile (.ask (.primitive purpose input) next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := + congrArg (DuplexModeGame.prepend (.primitive purpose input) answer.1.2 answer.2) mapped + rw [whole] + simpa only [mapExecution, DuplexModeGame.prepend, WHIRSourceChronology.prepend, observations] using + congrArg (List.cons ⟨.primitive purpose input,answer.1.2⟩) + (ih answer.1.2 answer.1.1 (remaining-1) (by omega) (counted.2 answer.1.2)) + | construction coordinate valid => + let answer := ro (constructionKey Q iv coordinate (counted.1.trans limit)) + have mapped := map_ideal sim ro iv state + (prepend (.answer (.construction coordinate valid) answer)) + (compile (next answer)) (remaining-DuplexFraming.pathCost coordinate) (by omega) + ((compile_counted _ _).mpr (counted.2 answer)) + have whole : runIdeal sim ro iv state (compile (.ask (.construction coordinate valid) next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := + congrArg (DuplexModeGame.prepend (.construction coordinate valid) answer 0) mapped + rw [whole] + simpa only [mapExecution, DuplexModeGame.prepend, WHIRSourceChronology.prepend, observations] using + congrArg (List.cons ⟨.construction coordinate valid,answer⟩) + (ih answer state (remaining-DuplexFraming.pathCost coordinate) (by omega) (counted.2 answer)) + | commit root next ih => + have mapped := map_ideal sim ro iv state (prepend (.commit root)) (compile next) + remaining limit ((compile_counted _ _).mpr counted) + have whole : runIdeal sim ro iv state (compile (.commit root next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := mapped + rw [whole] + simpa only [mapExecution, WHIRSourceChronology.prepend, observations] using ih state remaining limit counted + | claims profile entry request next ih => + have mapped := map_ideal sim ro iv state (prepend (.claims profile entry request)) (compile next) + remaining limit ((compile_counted _ _).mpr counted) + have whole : runIdeal sim ro iv state (compile (.claims profile entry request next)) + remaining limit ((compile_counted _ _).mpr counted) = _ := mapped + rw [whole] + simpa only [mapExecution, WHIRSourceChronology.prepend, observations] using ih state remaining limit counted + +theorem sourceView_ideal {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) + (source : Source cap R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : Counts remaining source) : + sourceView (runIdeal sim ro iv state (compile source) remaining limit + ((compile_counted source remaining).mpr counted)).view.result = + (runIdeal sim ro iv state (compile source) remaining limit + ((compile_counted source remaining).mpr counted)).view := by + unfold sourceView + rw [ideal_source_trace sim ro iv state source remaining limit counted] + +theorem sourceView_real (oracle : PrimitiveOracle) (iv : Digest32) (source : Source cap R) : + sourceView (runReal oracle iv (compile source)).view.result = + (runReal oracle iv (compile source)).view := by + unfold sourceView + rw [real_source_trace] + +/-- A header seen by a direct prequery captures its root before that allocation's answer, even if the native source has not reached its own announcement yet. -/ +def publicBefore (registry : Public) (Q : Nat) (result : Result cap R) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) : + WHIRCausalRawROM.Extension state := + let prior := publicReplay Q registry.iv (WHIRSourceRawCache.cache Q state) (sourceView result) state + ⟨CausalBindingState.registerRoots prior (WHIRHeaderRoots.allocationRoots registry Q key), + (publicReplay_extends ..).trans (CausalBindingState.registerRoots_extends ..)⟩ + +def privateBefore (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) : + WHIRCausalRawROM.Extension state := + let prior := privateReplay Q registry.iv (WHIRSourceRawCache.cache Q state) seed source counted state + ⟨CausalBindingState.registerRoots prior (WHIRHeaderRoots.allocationRoots registry Q key), + (privateReplay_extends ..).trans (CausalBindingState.registerRoots_extends ..)⟩ + +def after (registry : Public) (Q : Nat) (state : CausalBindingState.State cap) + (key : AllocationKey (context registry) Q) (answer : AllocationAnswer (context registry) Q key) : + WHIRCausalRawROM.Extension state := + ⟨WHIRSourceRawCache.addGroup (context registry) Q state key.1 answer, + WHIRSourceRawCache.addGroup_extends ..⟩ + +noncomputable def publicResolver (registry : Public) (Q : Nat) (result : Result cap R) : + WHIRCausalRawROM.Resolver (context registry) Q cap where + before := publicBefore registry Q result + claims _ packet history := packetRequest registry Q cap packet history + after := after registry Q + +noncomputable def privateResolver (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : Counts Q source) : + WHIRCausalRawROM.Resolver (context registry) Q cap where + before := privateBefore registry Q seed source counted + claims _ packet history := packetRequest registry Q cap packet history + after := after registry Q + +theorem publicBefore_actual (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) + (agrees : WHIRSourceRawCache.LogAgrees ro (state.rawAnswers Q)) + (key : AllocationKey (context registry) Q) : + publicBefore registry Q (runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted)).view.result state key = + privateBefore registry Q seed source counted state key := by + unfold publicBefore privateBefore + simp only [sourceView_ideal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) source Q (by omega) counted] + have cacheAgrees := WHIRSourceRawCache.lookup_agrees Q ro (state.rawAnswers Q) agrees + change DuplexPublicSimulator.CacheAgrees (WHIRSourceRawCache.cache Q state) ro at cacheAgrees + simp only [publicReplay_actual Q registry.iv _ ro cacheAgrees seed source counted] + +@[simp] theorem privateBefore_raw (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) : + (privateBefore registry Q seed source counted state key).state.rawAnswers = state.rawAnswers := by + simp [privateBefore, privateReplay, WHIRSourceRawCache.registerRoots_raw, + WHIRSourceRawCache.replayTracked_raw] + +@[simp] theorem publicBefore_raw (registry : Public) (Q : Nat) (result : Result cap R) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) : + (publicBefore registry Q result state key).state.rawAnswers = state.rawAnswers := by + simp [publicBefore, publicReplay, WHIRSourceRawCache.registerRoots_raw, + WHIRSourceRawCache.replayTracked_raw] + +/-- The public resolver cannot inspect an arbitrary returned payload, including a hidden program or coin object: only compiler-owned events affect it. -/ +theorem publicResolver_events_only {S : Type} (registry : Public) (Q : Nat) + (left : Result cap R) (right : Result cap S) (same : left.events = right.events) : + publicResolver registry Q left = publicResolver registry Q right := by + cases left + cases right + cases same + rfl + +theorem privatePrepare_raw (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) : + (WHIRCausalRawROM.prepare (context registry) rfl Q cap + (privateResolver registry Q seed source counted) state key).1.rawAnswers = state.rawAnswers := by + rcases key with ⟨group,history⟩ + cases group with + | inl packet => + exact (WHIRSourceRawCache.prepareClaims_raw _ _ _ _ _).trans + (privateBefore_raw registry Q seed source counted state (.inl packet,history)) + | inr raw => + exact privateBefore_raw registry Q seed source counted state (.inr raw,history) + +theorem prepare_actual (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) + (agrees : WHIRSourceRawCache.LogAgrees ro (state.rawAnswers Q)) + (key : AllocationKey (context registry) Q) : + WHIRCausalRawROM.prepare (context registry) rfl Q cap + (publicResolver registry Q (runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted)).view.result) state key = + WHIRCausalRawROM.prepare (context registry) rfl Q cap + (privateResolver registry Q seed source counted) state key := by + rcases key with ⟨group,history⟩ + cases group <;> + simp only [WHIRCausalRawROM.prepare, publicResolver, privateResolver, + publicBefore_actual registry Q ro seed source counted state agrees] + +def TraceAgrees (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (trace : List (Sigma (AllocationAnswer (context registry) Q))) : Prop := + ∀ item ∈ trace, item.2 = (partition (context registry) Q).split ro item.1.1 + +private noncomputable def emitted (registry : Public) (Q : Nat) + (resolver : WHIRCausalRawROM.Resolver (context registry) Q cap) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) + (answer : AllocationAnswer (context registry) Q key) : + Sigma (@WHIRCausalRawROM.Answer (context registry) rfl Q cap) := + ⟨(WHIRCausalRawROM.prepare (context registry) rfl Q cap resolver state key).2, + (WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).answer state key answer⟩ + +private theorem recode_cons (registry : Public) (Q : Nat) + (resolver : WHIRCausalRawROM.Resolver (context registry) Q cap) + (state : CausalBindingState.State cap) (key : AllocationKey (context registry) Q) + (answer : AllocationAnswer (context registry) Q key) + (rest : List (Sigma (AllocationAnswer (context registry) Q))) : + (WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).traceRecode + state (⟨key,answer⟩ :: rest) = + let next := (resolver.after + (WHIRCausalRawROM.prepare (context registry) rfl Q cap resolver state key).1 key answer).state + let result := (WHIRCausalRawROM.decorator (context registry) rfl Q cap resolver).traceRecode next rest + (emitted registry Q resolver state key answer :: result.1,result.2) := by + rcases key with ⟨group,history⟩ + cases group <;> rfl + +private theorem emitted_actual (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) + (agrees : WHIRSourceRawCache.LogAgrees ro (state.rawAnswers Q)) + (key : AllocationKey (context registry) Q) (answer : AllocationAnswer (context registry) Q key) : + emitted registry Q + (publicResolver registry Q (runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted)).view.result) state key answer = + emitted registry Q (privateResolver registry Q seed source counted) state key answer := by + apply Sigma.ext + · exact congrArg Prod.snd (prepare_actual registry Q ro seed source counted state agrees key) + · rcases key with ⟨group,history⟩ + cases group <;> rfl + +private theorem publicResolver_after (registry : Public) (Q : Nat) (result : Result cap R) : + (publicResolver registry Q result).after = after registry Q := rfl + +private theorem privateResolver_after (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : Counts Q source) : + (privateResolver registry Q seed source counted).after = after registry Q := rfl + +theorem traceRecode_actual (registry : Public) (Q : Nat) (ro : RawKey Q → Digest32) + (seed : DuplexPublicSimulator.Seed) (source : Source cap R) (counted : Counts Q source) + (state : CausalBindingState.State cap) + (agrees : WHIRSourceRawCache.LogAgrees ro (state.rawAnswers Q)) + (trace : List (Sigma (AllocationAnswer (context registry) Q))) + (answers : TraceAgrees registry Q ro trace) : + (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (publicResolver registry Q (runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv + ((DuplexPublicSimulator.simulator Q).initial seed) (compile source) Q (by omega) + ((compile_counted source Q).mpr counted)).view.result)).traceRecode state trace = + (WHIRCausalRawROM.decorator (context registry) rfl Q cap + (privateResolver registry Q seed source counted)).traceRecode state trace := by + induction trace generalizing state with + | nil => rfl + | cons item rest ih => + rcases item with ⟨key,answer⟩ + have head := answers ⟨key,answer⟩ (by simp) + change answer = (partition (context registry) Q).split ro key.1 at head + have tail : TraceAgrees registry Q ro rest := + fun item member => answers item (List.mem_cons_of_mem _ member) + let prepared := (WHIRCausalRawROM.prepare (context registry) rfl Q cap + (privateResolver registry Q seed source counted) state key).1 + have prior : WHIRSourceRawCache.LogAgrees ro (prepared.rawAnswers Q) := by + simpa only [prepared,privatePrepare_raw] using agrees + have next : WHIRSourceRawCache.LogAgrees ro + ((after registry Q prepared key answer).state.rawAnswers Q) := by + change WHIRSourceRawCache.LogAgrees ro + ((WHIRSourceRawCache.addGroup (context registry) Q prepared key.1 answer).rawAnswers Q) + rw [head] + exact WHIRSourceRawCache.addGroup_agrees (context registry) Q ro prepared prior key.1 + have recursive := ih (after registry Q prepared key answer).state next tail + have nextEqual := congrArg + (fun built => (after registry Q built.1 key answer).state) + (prepare_actual registry Q ro seed source counted state agrees key) + simp only [recode_cons, publicResolver_after, privateResolver_after, + emitted_actual registry Q ro seed source counted state agrees key answer, + nextEqual] + exact congrArg + (fun result => (emitted registry Q (privateResolver registry Q seed source counted) + state key answer :: result.1,result.2)) recursive + +end Whir.WHIRSourceResolver diff --git a/verification/whir/Whir/WHIRSourceRootPolicy.lean b/verification/whir/Whir/WHIRSourceRootPolicy.lean new file mode 100644 index 000000000..16262f722 --- /dev/null +++ b/verification/whir/Whir/WHIRSourceRootPolicy.lean @@ -0,0 +1,675 @@ +import Whir.WHIRHeaderRoots +import Whir.WHIRSourceChronology +import Whir.PublicMerkleProbability +import Whir.DuplexPublicSimulator + +/-! Causal root announcements for a fixed source and public final-value selector. +Only finite past compression cells are inspected; a pending query contributes its +input, never its answer. Exact registry/header/packet parsers handle raw prequeries +and mode calls. Source commitments, packet footprints and the final selected packet +are captured before any final backfill. No changes to the public `View` are needed. + +Prefix-union persistence covers inconsistent logs as well as genuine oracle traces. +The independent all-branches `FreeAnnouncements R` resource accounts for zero-cost +source commits. With compression budget Q, the cap is +`(Q+1)*(R+(Q+1)*(productionDepth+1))`, where `productionDepth` is the computed maximum +of the actual 56 production schedules. Theorems connect the finite replay to both +source-owned `recover` and the actual `PublicCompressionProgram` full-C trace. +This module supplies policy/capture/resource facts, not the frozen-opening transport +or an unconditional duplex security claim. -/ +namespace Whir.WHIRSourceRootPolicy +open FiatShamirGame DuplexFraming DuplexModeGame +open WHIRSourceChronology WHIRCallerRegistry PublicCompressionProgram +open PublicMerkleLog + +variable {cap : Nat} {T : Type} + +/-- Zero-cost commitments require an independent all-branches resource. -/ +def FreeAnnouncements : Nat → Source cap T → Prop + | _, .done _ => True + | R, .ask _ next => ∀ d, FreeAnnouncements R (next d) + | R, .commit _ next => 0 < R ∧ FreeAnnouncements (R-1) next + | R, .claims _ _ _ next => FreeAnnouncements R next + +/-- A public geometry bound, not a root-cover assumption. -/ +def ProfileBound (registry : Public) (H : Nat) : Prop := + ∀ statement layout profile, selection registry statement = some (layout,profile) → + WHIRHistory.depth (ParameterBounds.config profile) ≤ H + +/-- Computable maximum of the actual 56 production schedules. -/ +def productionDepth : Nat := + Finset.univ.sup (fun p : ParameterBounds.Profile => WHIRHistory.depth (ParameterBounds.config p)) + +theorem production_profileBound (registry : Public) : ProfileBound registry productionDepth := by + intro statement layout profile _ + exact Finset.le_sup (f := fun p : ParameterBounds.Profile => + WHIRHistory.depth (ParameterBounds.config p)) (Finset.mem_univ profile) + +/-- First chronological replies are retained, including on inconsistent logs. -/ +def firstReply (log : PublicLog) (n : Node) : Option Digest32 := + PublicMerkleLog.lookup log.reverse n + +def partialEval (log : PublicLog) {N : Nat} : Computation T N → Option T + | .ret value => some value + | .draw n next => (firstReply log n).bind (fun d => partialEval log (next d)) + +def queryReply (iv : Digest32) (log : PublicLog) (q : Query) : Option Digest32 := + partialEval log (queryCalls iv q) + +/-- Header parsing includes exact raw garbage prequeries; footprint parsing uses +only the actual exact packet recognizer, never an assumed list of roots. -/ +def rawRoots (registry : Public) (Q : Nat) (raw : RawKey Q) : List Digest32 := + (WHIRHeaderRoots.rawRoot registry raw).toList ++ + match RawWHIRKeys.recognize (context registry) Q raw with + | none => [] + | some pos => (WHIRSnapshotReplay.historyFootprint pos.1.val.profile + pos.1.val.statement pos.1.val.messages).map Prod.fst + +def queryRoots (registry : Public) (Q : Nat) (visible : PublicLog) : Query → List Digest32 + | .primitive _ n => match DuplexPublicSimulator.privateKey Q visible n with + | none => [] + | some raw => rawRoots registry Q raw + | .construction q _ => + if bound : pathCost q ≤ Q then rawRoots registry Q (constructionKey Q registry.iv q bound) + else [] + +def packetRoots (registry : Public) (Q : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) : List Digest32 := + (WHIRHeaderRoots.packetHeader registry Q packet).toList.map WHIRHeaderRoots.Header.root ++ + (WHIRSnapshotReplay.historyFootprint packet.val.profile packet.val.statement + packet.val.messages).map Prod.fst + +def finalRoots (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) (value : T) : List Digest32 := + match select value with + | none => [] + | some packet => packetRoots registry Q packet + +def advance (visible : PublicLog) (q : Query) (d : Digest32) : PublicLog := + match q with + | .primitive _ n => (n,d) :: visible + | .construction _ _ => visible + +/-- Query inputs are inspected before attempting their answer. In particular the +first missing compression reply does not hide the pending query's announcements. -/ +def scan (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) (log : PublicLog) : + Source cap T → PublicLog → List Digest32 + | .done value, _ => finalRoots registry Q select value + | .commit root next, visible => root :: scan registry Q select log next visible + | .claims _ _ _ next, visible => scan registry Q select log next visible + | .ask q next, visible => queryRoots registry Q visible q ++ + match queryReply registry.iv log q with + | none => [] + | some d => scan registry Q select log (next d) (advance visible q d) + +/-- Union over chronological prefixes: adding any cell cannot revoke an earlier +announcement, even if the new cell contradicts an old reply. -/ +def rootList (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) : PublicLog → List Digest32 + | [] => scan registry Q select [] source [] + | entry :: past => scan registry Q select (entry :: past) source [] ++ rootList registry Q select source past + +noncomputable def policy (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) (source : Source cap T) : + PublicMerkleProbability.RootPolicy := fun log => (rootList registry Q select source log).toFinset + +theorem rootsGrow (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) (source : Source cap T) : + PublicMerkleProbability.RootsGrow (policy registry Q select source) := by + intro history entry root member + simp only [policy, List.mem_toFinset] at * + exact List.mem_append_right _ member + +theorem scan_captured (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) (source : Source cap T) + (log : PublicLog) (root : Digest32) (member : root ∈ scan registry Q select log source []) : + root ∈ policy registry Q select source log := by + simp only [policy, List.mem_toFinset] + cases log with + | nil => exact member + | cons entry past => exact List.mem_append_left _ member + +private theorem option_length (o : Option α) : o.toList.length ≤ 1 := by cases o <;> simp + +theorem replyFootprint_length {c : Protocol.Config} (q : CausalProbability.Coordinate c) + (xs : List Concrete.E) : (WHIRSnapshotReplay.replyFootprint q xs).length ≤ 1 := by + cases q <;> simp only [WHIRSnapshotReplay.replyFootprint] + all_goals try simp + split <;> try simp + split <;> try simp + split <;> try simp + split <;> simp [List.length_map] + +theorem historyFootprint_length (p : ParameterBounds.Profile) (s : Digest32) + (messages : List WHIRHistory.Pending) : + (WHIRSnapshotReplay.historyFootprint p s messages).length ≤ messages.length := by + induction messages with + | nil => simp [WHIRSnapshotReplay.historyFootprint] + | cons m rest ih => + cases rest with + | nil => simp [WHIRSnapshotReplay.historyFootprint] + | cons previous older => + simp only [WHIRSnapshotReplay.historyFootprint, List.length_append, List.length_cons] at * + have := replyFootprint_length (WHIRReplay.query p (s,previous :: older)) m.scalars + omega + +theorem rawRoots_length (registry : Public) (Q H : Nat) (bounded : ProfileBound registry H) + (raw : RawKey Q) : (rawRoots registry Q raw).length ≤ H+1 := by + unfold rawRoots + rw [List.length_append] + have hh := option_length (WHIRHeaderRoots.rawRoot registry raw) + cases found : RawWHIRKeys.recognize (context registry) Q raw with + | none => simpa only [List.length_nil, Nat.add_zero] using hh.trans (by omega) + | some pos => + simp only [List.length_map] + have hf := historyFootprint_length pos.1.val.profile pos.1.val.statement pos.1.val.messages + have hd := RawWHIRKeys.packet_depth (context registry) Q pos.1 + have hb := bounded _ _ _ (packet_selection registry Q pos.1) + omega + +theorem queryRoots_length (registry : Public) (Q H : Nat) (bounded : ProfileBound registry H) + (visible : PublicLog) (q : Query) : (queryRoots registry Q visible q).length ≤ H+1 := by + cases q with + | primitive purpose n => + simp only [queryRoots] + cases DuplexPublicSimulator.privateKey Q visible n with + | none => simp + | some raw => exact rawRoots_length registry Q H bounded raw + | construction q valid => + simp only [queryRoots] + split + · exact rawRoots_length registry Q H bounded _ + · simp + +private theorem query_cost_pos (q : Query) : 1 ≤ q.cost := by + cases q with + | primitive => exact Nat.le_refl _ + | construction q valid => exact DuplexRawProgram.pathCost_pos q + +theorem packetRoots_length (registry : Public) (Q H : Nat) (bounded : ProfileBound registry H) + (packet : RawWHIRKeys.Packet (context registry) Q) : + (packetRoots registry Q packet).length ≤ H+1 := by + have hh := option_length (WHIRHeaderRoots.packetHeader registry Q packet) + have hf := historyFootprint_length packet.val.profile packet.val.statement packet.val.messages + have hd := RawWHIRKeys.packet_depth (context registry) Q packet + have hb := bounded _ _ _ (packet_selection registry Q packet) + simp only [packetRoots, List.length_append, List.length_map] + omega + +theorem finalRoots_length (registry : Public) (Q H : Nat) (bounded : ProfileBound registry H) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) (value : T) : + (finalRoots registry Q select value).length ≤ H+1 := by + unfold finalRoots + cases select value with + | none => simp + | some packet => exact packetRoots_length registry Q H bounded packet + +theorem scan_length (registry : Public) (Q H R N : Nat) (bounded : ProfileBound registry H) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (counted : WHIRSourceChronology.Counts N source) + (free : FreeAnnouncements R source) (log visible : PublicLog) : + (scan registry Q select log source visible).length ≤ R + (N+1)*(H+1) := by + induction source generalizing R N visible with + | done value => + have hf := finalRoots_length registry Q H bounded select value + have hm := Nat.mul_le_mul_right (H+1) (show 1 ≤ N+1 by omega) + simp only [Nat.one_mul] at hm + exact hf.trans (by omega) + | commit root next ih => + have h := ih (R-1) N counted free.2 visible + simp only [scan, List.length_cons] + have := free.1 + omega + | claims p entry request next ih => exact ih R N counted free visible + | ask q next ih => + simp only [scan, List.length_append] + have hq := queryRoots_length registry Q H bounded visible q + cases reply : queryReply registry.iv log q with + | none => + simp only [List.length_nil] + have hm := Nat.mul_le_mul_right (H+1) (show 1 ≤ N+1 by omega) + simp only [Nat.one_mul] at hm + omega + | some d => + simp only + have h := ih d R (N-q.cost) (counted.2 d) (free d) (advance visible q d) + have hp := query_cost_pos q + have hc := counted.1 + have hm := Nat.mul_le_mul_right (H+1) (show N-q.cost+1+1 ≤ N+1 by omega) + rw [Nat.add_mul, Nat.one_mul] at hm + omega + +theorem rootList_length (registry : Public) (Q H R : Nat) (bounded : ProfileBound registry H) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (counted : WHIRSourceChronology.Counts Q source) + (free : FreeAnnouncements R source) (log : PublicLog) : + (rootList registry Q select source log).length ≤ (log.length+1)*(R+(Q+1)*(H+1)) := by + induction log with + | nil => simpa [rootList] using scan_length registry Q H R Q bounded select source counted free [] [] + | cons entry past ih => + have hs := scan_length registry Q H R Q bounded select source counted free (entry :: past) [] + simp only [rootList, List.length_append, List.length_cons] + nlinarith + +theorem cardinality (registry : Public) (Q H R : Nat) (bounded : ProfileBound registry H) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (counted : WHIRSourceChronology.Counts Q source) + (free : FreeAnnouncements R source) (log : PublicLog) (budget : log.length ≤ Q) : + (policy registry Q select source log).card ≤ (Q+1)*(R+(Q+1)*(H+1)) := by + exact (List.toFinset_card_le _).trans ((rootList_length registry Q H R bounded select source counted free log).trans + (Nat.mul_le_mul_right _ (Nat.succ_le_succ budget))) + +/-- The actual partial source interpreter stops at a missing finite compression +cell; its events have the same source-owned type as `recover`. -/ +def partialPrefix (iv : Digest32) (log : PublicLog) : Source cap T → Prefix cap T + | .done value => ⟨[],none,some value⟩ + | .commit root next => prependPrefix (.commit root) (partialPrefix iv log next) + | .claims p entry request next => + prependPrefix (.claims p entry request) (partialPrefix iv log next) + | .ask q next => match queryReply iv log q with + | none => ⟨[],some q,none⟩ + | some d => prependPrefix (.answer q d) (partialPrefix iv log (next d)) + +def visibleAfter : List (Event cap) → PublicLog → PublicLog + | [], visible => visible + | .answer q d :: rest, visible => visibleAfter rest (advance visible q d) + | .commit _ :: rest, visible => visibleAfter rest visible + | .claims _ _ _ :: rest, visible => visibleAfter rest visible + +def eventRoots (registry : Public) (Q : Nat) : List (Event cap) → PublicLog → List Digest32 + | [], _ => [] + | .answer q d :: rest, visible => + queryRoots registry Q visible q ++ eventRoots registry Q rest (advance visible q d) + | .commit root :: rest, visible => root :: eventRoots registry Q rest visible + | .claims _ _ _ :: rest, visible => eventRoots registry Q rest visible + +def capture (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (seen : Prefix cap T) (visible : PublicLog) : List Digest32 := + eventRoots registry Q seen.events visible ++ + (seen.pending.toList.flatMap (queryRoots registry Q (visibleAfter seen.events visible)) ++ + seen.value.toList.flatMap (finalRoots registry Q select)) + +theorem scan_eq_capture (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (log : PublicLog) (source : Source cap T) (visible : PublicLog) : + scan registry Q select log source visible = + capture registry Q select (partialPrefix registry.iv log source) visible := by + induction source generalizing visible with + | done => simp [scan,partialPrefix,capture,eventRoots] + | commit root next ih => + simpa [scan,partialPrefix,capture,prependPrefix,eventRoots,visibleAfter] using + congrArg (List.cons root) (ih visible) + | claims p entry request next ih => + simpa [scan,partialPrefix,capture,prependPrefix,eventRoots,visibleAfter] using ih visible + | ask q next ih => + cases answer : queryReply registry.iv log q with + | none => simp [scan,partialPrefix,answer,capture,eventRoots,visibleAfter] + | some d => + simp only [scan,partialPrefix,answer,prependPrefix] + rw [ih d] + simp [capture,eventRoots,visibleAfter,List.append_assoc] + +theorem partialPrefix_recover (iv : Digest32) (log : PublicLog) (source : Source cap T) : + recover source (observations (partialPrefix iv log source).events) = + partialPrefix iv log source := by + induction source with + | done => rfl + | commit root next ih => + simpa [partialPrefix,prependPrefix,observations,WHIRSourceChronology.recover] using congrArg (prependPrefix (.commit root)) ih + | claims p entry request next ih => + simpa [partialPrefix,prependPrefix,observations,WHIRSourceChronology.recover] using + congrArg (prependPrefix (.claims p entry request)) ih + | ask q next ih => + cases answer : queryReply iv log q with + | none => simp [partialPrefix,answer,observations,WHIRSourceChronology.recover] + | some d => + simpa [partialPrefix,answer,prependPrefix,observations,WHIRSourceChronology.recover] using + congrArg (prependPrefix (.answer q d)) (ih d) + +theorem prefix_capture (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (log : PublicLog) (root : Digest32) + (member : root ∈ capture registry Q select (partialPrefix registry.iv log source) []) : + root ∈ policy registry Q select source log := + scan_captured registry Q select source log root ((scan_eq_capture ..).symm ▸ member) + +theorem event_commit (registry : Public) (Q : Nat) (events : List (Event cap)) + (visible : PublicLog) (root : Digest32) (member : Event.commit root ∈ events) : + root ∈ eventRoots registry Q events visible := by + induction events generalizing visible with + | nil => simp at member + | cons event rest ih => + cases event with + | answer q d => exact List.mem_append_right _ (ih _ (by simpa using member)) + | commit other => + rcases List.mem_cons.mp member with same | member + · cases same; exact List.mem_cons_self + · exact List.mem_cons_of_mem _ (ih _ member) + | claims p entry request => exact ih _ (by simpa using member) + +/-- Every actual source commitment in the recovered prefix is covered, without a +separate correctness/cover hypothesis. -/ +theorem commit_captured (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (log : PublicLog) (root : Digest32) + (member : Event.commit root ∈ (partialPrefix registry.iv log source).events) : + root ∈ policy registry Q select source log := + prefix_capture registry Q select source log root + (List.mem_append_left _ (event_commit registry Q _ [] root member)) + +theorem pending_captured (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (log : PublicLog) (q : Query) (root : Digest32) + (pending : (partialPrefix registry.iv log source).pending = some q) + (member : root ∈ queryRoots registry Q + (visibleAfter (partialPrefix registry.iv log source).events []) q) : + root ∈ policy registry Q select source log := by + apply prefix_capture registry Q select source log root + unfold capture + apply List.mem_append_right + apply List.mem_append_left + simpa only [pending,Option.toList_some,List.flatMap_cons,List.flatMap_nil,List.append_nil] using member + +theorem eventRoots_append (registry : Public) (Q : Nat) (before after : List (Event cap)) + (visible : PublicLog) : + eventRoots registry Q (before ++ after) visible = + eventRoots registry Q before visible ++ eventRoots registry Q after (visibleAfter before visible) := by + induction before generalizing visible with + | nil => rfl + | cons event rest ih => + cases event <;> simp [eventRoots,visibleAfter,ih,List.append_assoc] + +theorem answered_captured (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (log : PublicLog) (before after : List (Event cap)) + (q : Query) (d root : Digest32) + (split : (partialPrefix registry.iv log source).events = before ++ .answer q d :: after) + (member : root ∈ queryRoots registry Q (visibleAfter before []) q) : + root ∈ policy registry Q select source log := by + apply prefix_capture registry Q select source log root + apply List.mem_append_left + rw [split,eventRoots_append] + exact List.mem_append_right _ (List.mem_append_left _ member) + +theorem final_captured (registry : Public) (Q : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (log : PublicLog) (value : T) + (packet : RawWHIRKeys.Packet (context registry) Q) (root : Digest32) + (done : (partialPrefix registry.iv log source).value = some value) + (selected : select value = some packet) (member : root ∈ packetRoots registry Q packet) : + root ∈ policy registry Q select source log := by + apply prefix_capture registry Q select source log root + unfold capture + apply List.mem_append_right + apply List.mem_append_right + simpa [done,finalRoots,selected] using member + +theorem raw_header_member (registry : Public) (Q : Nat) (raw : RawKey Q) (root : Digest32) + (parsed : WHIRHeaderRoots.rawRoot registry raw = some root) : + root ∈ rawRoots registry Q raw := by + apply List.mem_append_left + simp [parsed] + +theorem raw_footprint_member (registry : Public) (Q : Nat) (raw : RawKey Q) + (pos : RawWHIRKeys.Position (context registry) Q) + (recognized : RawWHIRKeys.recognize (context registry) Q raw = some pos) + (ref : WHIRSnapshotReplay.RootRef) + (member : ref ∈ WHIRSnapshotReplay.historyFootprint pos.1.val.profile + pos.1.val.statement pos.1.val.messages) : + ref.1 ∈ rawRoots registry Q raw := by + apply List.mem_append_right + simp only [recognized] + exact List.mem_map.mpr ⟨ref,member,rfl⟩ + +theorem primitive_roots (registry : Public) (Q : Nat) (visible : PublicLog) + (purpose : Purpose) (n : Node) (raw : RawKey Q) + (recognized : DuplexPublicSimulator.privateKey Q visible n = some raw) : + queryRoots registry Q visible (.primitive purpose n) = rawRoots registry Q raw := by + simp [queryRoots,recognized] + +theorem construction_roots (registry : Public) (Q : Nat) (visible : PublicLog) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (bound : pathCost q ≤ Q) : + queryRoots registry Q visible (.construction q valid) = + rawRoots registry Q (constructionKey Q registry.iv q bound) := by + simp [queryRoots,bound] + +theorem packet_header_member (registry : Public) (Q : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) (header : WHIRHeaderRoots.Header) + (parsed : WHIRHeaderRoots.packetHeader registry Q packet = some header) : + header.root ∈ packetRoots registry Q packet := by + apply List.mem_append_left + simp [parsed] + +theorem packet_footprint_member (registry : Public) (Q : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) (ref : WHIRSnapshotReplay.RootRef) + (member : ref ∈ WHIRSnapshotReplay.historyFootprint packet.val.profile + packet.val.statement packet.val.messages) : ref.1 ∈ packetRoots registry Q packet := + List.mem_append_right _ (List.mem_map.mpr ⟨ref,member,rfl⟩) + +theorem packet_ancestor_footprint_member (registry : Public) (Q : Nat) + (packet : RawWHIRKeys.Packet (context registry) Q) (i : Nat) + (ref : WHIRSnapshotReplay.RootRef) + (member : ref ∈ WHIRSnapshotReplay.historyFootprint packet.val.profile + packet.val.statement (packet.val.messages.drop i)) : ref.1 ∈ packetRoots registry Q packet := + packet_footprint_member registry Q packet ref + (WHIRSnapshotReplay.historyFootprint_drop _ _ _ i ref member) + +theorem production_cardinality (registry : Public) (Q R : Nat) + (select : T → Option (RawWHIRKeys.Packet (context registry) Q)) + (source : Source cap T) (counted : WHIRSourceChronology.Counts Q source) + (free : FreeAnnouncements R source) (log : PublicLog) (budget : log.length ≤ Q) : + (policy registry Q select source log).card ≤ (Q+1)*(R+(Q+1)*(productionDepth+1)) := + cardinality registry Q productionDepth R (production_profileBound registry) select source counted free log budget + +theorem firstReply_sound (C : PrimitiveOracle) (log : PublicLog) + (authentic : AuthenticLog C log) (n : Node) (d : Digest32) + (found : firstReply log n = some d) : C n = d := + authentic n d (List.mem_reverse.mp (PublicMerkleLog.lookup_mem found)) + +theorem firstReply_cons_preserves (log : PublicLog) (entry : Node × Digest32) + (n : Node) (d : Digest32) (found : firstReply log n = some d) : + firstReply (entry :: log) n = some d := by + unfold firstReply at * + rw [List.reverse_cons] + generalize log.reverse = past at * + induction past with + | nil => simp [PublicMerkleLog.lookup] at found + | cons e rest ih => + simp only [List.cons_append,PublicMerkleLog.lookup] at * + split at found + · rename_i same + simp [same,found] + · rename_i different + simp only [different,↓reduceIte] + exact ih found + +theorem partialEval_sound (C : PrimitiveOracle) (log : PublicLog) + (authentic : AuthenticLog C log) {N : Nat} (program : Computation T N) (value : T) + (found : partialEval log program = some value) : + TypedOracleCompiler.Sampling.eval C program = value := by + induction program with + | ret r => exact Option.some.inj found + | draw n next ih => + cases hit : firstReply log n with + | none => simp [partialEval,hit] at found + | some d => + have same := firstReply_sound C log authentic n d hit + simpa only [TypedOracleCompiler.Sampling.eval,same] using + ih d (by simpa only [partialEval,hit,Option.bind_some] using found) + +theorem queryReply_sound (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (authentic : AuthenticLog C log) (q : Query) (d : Digest32) + (found : queryReply iv log q = some d) : realAnswer C iv q = d := by + rw [← queryCalls_eval] + exact partialEval_sound C log authentic _ d found + +theorem partialEval_complete (C : PrimitiveOracle) (log : PublicLog) + (authentic : AuthenticLog C log) {N : Nat} (program : Computation T N) + (available : ∀ entry ∈ toLog (TypedOracleCompiler.Sampling.execute C program).2, entry ∈ log) : + partialEval log program = some (TypedOracleCompiler.Sampling.eval C program) := by + induction program with + | ret => rfl + | draw n next ih => + have hit : firstReply log n = some (C n) := + PublicMerkleLog.lookup_authentic_member C log.reverse + (fun m d hm => authentic m d (List.mem_reverse.mp hm)) + (List.mem_reverse.mpr (available (n,C n) (by + simp [toLog,TypedOracleCompiler.Sampling.execute]))) + simp only [partialEval,hit,Option.bind_some,TypedOracleCompiler.Sampling.eval] + apply ih + intro entry member + exact available entry (List.mem_cons_of_mem _ member) + +/-- All cells used here come from the actual all-C compiler. This completeness +lemma is useful when transporting an actual completed prefix into the policy. -/ +theorem partialPrefix_full (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (authentic : AuthenticLog C log) (source : Source cap T) (Q : Nat) + (counted : WHIRSourceChronology.Counts Q source) + (available : ∀ entry ∈ primitiveLog C iv (erase source) Q ((erase_counted source Q).mpr counted), + entry ∈ log) : + partialPrefix iv log source = + completedPrefix (runReal C iv (WHIRSourceChronology.compile source)).view.result := by + induction source generalizing Q with + | done => rfl + | commit root next ih => + have inner := ih Q counted available + simpa [partialPrefix,WHIRSourceChronology.compile,map_real,mapExecution, + WHIRSourceChronology.prepend,completedPrefix,prependPrefix] using + congrArg (prependPrefix (.commit root)) inner + | claims p entry request next ih => + have inner := ih Q counted available + simpa [partialPrefix,WHIRSourceChronology.compile,map_real,mapExecution, + WHIRSourceChronology.prepend,completedPrefix,prependPrefix] using + congrArg (prependPrefix (.claims p entry request)) inner + | ask q next ih => + simp only [erase,primitiveLog,PublicCompressionProgram.compile, + TypedOracleCompiler.Sampling.execute_pad,TypedOracleCompiler.Sampling.execute_bind, + execute_mapResult,toLog,List.map_append,queryCalls_eval] at available + have answer : queryReply iv log q = some (realAnswer C iv q) := by + rw [queryReply,← queryCalls_eval C iv q] + apply partialEval_complete C log authentic + intro entry member + exact available entry (List.mem_append_left _ member) + have inner := ih (realAnswer C iv q) (Q-q.cost) (counted.2 _) (by + intro entry member + exact available entry (List.mem_append_right _ member)) + simpa [partialPrefix,answer,WHIRSourceChronology.compile,runReal,map_real,mapExecution, + WHIRSourceChronology.prepend,DuplexModeGame.prepend,completedPrefix,prependPrefix] using + congrArg (prependPrefix (.answer q (realAnswer C iv q))) inner + +theorem primitiveLog_map (C : PrimitiveOracle) (iv : Digest32) (f : T → U) + (program : Program T) (Q : Nat) (counted : DuplexModeGame.Counts Q program) : + primitiveLog C iv (WHIRSourceChronology.map f program) Q ((map_counted f program Q).mpr counted) = + primitiveLog C iv program Q counted := by + induction program generalizing Q with + | done => rfl + | ask q next ih => + simp only [WHIRSourceChronology.map,primitiveLog,PublicCompressionProgram.compile, + TypedOracleCompiler.Sampling.execute_pad,TypedOracleCompiler.Sampling.execute_bind, + execute_mapResult,toLog,List.map_append,queryCalls_eval] + exact congrArg (_ ++ ·) (ih (realAnswer C iv q) (Q-q.cost) (counted.2 _)) + +/-- Source event instrumentation does not change a single full-C trace cell. -/ +theorem primitiveLog_source (C : PrimitiveOracle) (iv : Digest32) + (source : Source cap T) (Q : Nat) (counted : WHIRSourceChronology.Counts Q source) : + primitiveLog C iv (WHIRSourceChronology.compile source) Q ((compile_counted source Q).mpr counted) = + primitiveLog C iv (erase source) Q ((erase_counted source Q).mpr counted) := by + induction source generalizing Q with + | done => rfl + | commit root next ih => + change primitiveLog C iv (WHIRSourceChronology.map _ _) _ _ = _ + rw [primitiveLog_map] + exact ih Q counted + | claims p entry request next ih => + change primitiveLog C iv (WHIRSourceChronology.map _ _) _ _ = _ + rw [primitiveLog_map] + exact ih Q counted + | ask q next ih => + simp only [WHIRSourceChronology.compile,erase,primitiveLog,PublicCompressionProgram.compile, + TypedOracleCompiler.Sampling.execute_pad,TypedOracleCompiler.Sampling.execute_bind, + execute_mapResult,toLog,List.map_append,queryCalls_eval] + apply congrArg (_ ++ ·) + change primitiveLog C iv (WHIRSourceChronology.map _ _) _ _ = _ + rw [primitiveLog_map] + exact ih (realAnswer C iv q) (Q-q.cost) (counted.2 _) + +theorem partialPrefix_full_compiled (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (authentic : AuthenticLog C log) (source : Source cap T) (Q : Nat) + (counted : WHIRSourceChronology.Counts Q source) + (available : ∀ entry ∈ primitiveLog C iv (WHIRSourceChronology.compile source) Q + ((compile_counted source Q).mpr counted), entry ∈ log) : + partialPrefix iv log source = + completedPrefix (runReal C iv (WHIRSourceChronology.compile source)).view.result := by + rw [primitiveLog_source C iv source Q counted] at available + exact partialPrefix_full C iv log authentic source Q counted available + +/-- On any authentic finite C log, the recovered events are a genuine prefix of +the actual source execution, including zero-cost commitments and claim metadata. -/ +theorem partialPrefix_real_prefix (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (authentic : AuthenticLog C log) (source : Source cap T) : + ∃ suffix, (partialPrefix iv log source).events ++ suffix = + (runReal C iv (WHIRSourceChronology.compile source)).view.result.events := by + induction source with + | done => exact ⟨[],rfl⟩ + | commit root next ih => + obtain ⟨suffix,equal⟩ := ih + exact ⟨suffix,by simpa [partialPrefix,prependPrefix,WHIRSourceChronology.compile, + map_real,mapExecution,WHIRSourceChronology.prepend] using congrArg (List.cons (.commit root)) equal⟩ + | claims p entry request next ih => + obtain ⟨suffix,equal⟩ := ih + exact ⟨suffix,by simpa [partialPrefix,prependPrefix,WHIRSourceChronology.compile, + map_real,mapExecution,WHIRSourceChronology.prepend] using congrArg (List.cons (.claims p entry request)) equal⟩ + | ask q next ih => + cases answer : queryReply iv log q with + | none => simp [partialPrefix,answer] + | some d => + have same := queryReply_sound C iv log authentic q d answer + obtain ⟨suffix,equal⟩ := ih d + refine ⟨suffix,?_⟩ + simpa [partialPrefix,answer,prependPrefix,WHIRSourceChronology.compile, + runReal,same,map_real,mapExecution,WHIRSourceChronology.prepend,DuplexModeGame.prepend] + using congrArg (List.cons (.answer q d)) equal + +/-- Exercises actual executable lists: announcement before answer, first reply +on inconsistent repeats, and absence of a root that depends on a later answer. -/ +def smoke : IO Unit := do + let iv := DuplexCompression.parameterIV + let early : Digest32 := fun _ => 17 + let late : Digest32 := fun _ => 23 + let conflicting : Digest32 := fun _ => 42 + let registry : Public := ⟨iv,iv,fun _ => none,0⟩ + let n := PublicMerkleLog.node iv 0 [] true + let select : Unit → Option (RawWHIRKeys.Packet (context registry) 2) := fun _ => none + let source : Source 0 Unit := .commit early (.ask (.primitive .direct n) fun d => + .ask (.primitive .direct n) fun repeated => if d = repeated then .commit d (.done ()) else .done ()) + let before := rootList registry 2 select source [] + let after := rootList registry 2 select source [(n,late)] + let repeated := rootList registry 2 select source [(n,conflicting),(n,late)] + unless before.contains early && !(before.contains late) do + throw (IO.userError "root-before-answer / late-root failure") + unless after.contains early && after.contains late do + throw (IO.userError "answered commitment missing") + unless repeated.contains early && repeated.contains late && !(repeated.contains conflicting) do + throw (IO.userError "inconsistent repetition replaced first reply") + let layout : WHIRCallerClaims.CallerLayout := .recursion + ⟨⟨[],[],[],0⟩,[],#[],⟨0,6,9⟩,1⟩ + let headers : Public := ⟨iv,iv,fun _ => some layout,WHIRCallerClaims.callerOutputCap layout⟩ + let coordinate : Coordinate := ⟨⟨iv,iv,[.absorb 0 (WHIRHistory.rootBytes early)]⟩,.output 0⟩ + if valid : DuplexEncoding.Admissible coordinate then + let budget := pathCost coordinate + let noFinal : Unit → Option (RawWHIRKeys.Packet (context headers) budget) := fun _ => none + let request : Source 0 Unit := .ask (.construction coordinate valid) (fun _ => .done ()) + unless (rootList headers budget noFinal request []).contains early do + throw (IO.userError "canonical header not captured before construction answer") + let calls := toLog (TypedOracleCompiler.Sampling.execute blake2sOracle (queryCalls iv (.construction coordinate valid))).2 + let prior := (calls.take (calls.length-1)).reverse + let some terminal := calls.getLast? | throw (IO.userError "empty construction trace") + unless (queryRoots headers budget prior (.primitive .direct terminal.1)).contains early do + throw (IO.userError "canonical raw prequery header not captured before terminal answer") + else throw (IO.userError "header smoke coordinate malformed") + IO.println s!"source-root-policy smoke: before={before.length}, answered={after.length}, repeated={repeated.length}; productionDepth={productionDepth}" + +end Whir.WHIRSourceRootPolicy From 5a7edadc093831ae4153e122b05121055a46a701 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Fri, 9 Oct 2026 19:33:53 +0100 Subject: [PATCH 05/28] Strengthen WHIR finite-game bounds and correct concrete hash boundary --- verification/whir/README.md | 70 ++++++++++---- verification/whir/Whir/CausalProbability.lean | 2 +- verification/whir/Whir/DuplexModeGame.lean | 72 +++++++++++++-- .../whir/Whir/DuplexPublicSimulator.lean | 3 +- verification/whir/Whir/FiatShamirGame.lean | 8 ++ verification/whir/Whir/FieldCardinality.lean | 6 +- verification/whir/Whir/FieldTower.lean | 10 ++ .../whir/Whir/PublicMerkleProbability.lean | 49 +++++----- verification/whir/Whir/StackWHIRReplay.lean | 2 +- .../whir/Whir/SuccinctPointWeight.lean | 55 +++++++++-- verification/whir/Whir/WHIRCallerSupport.lean | 4 +- verification/whir/Whir/WHIRFiatShamir.lean | 2 +- .../whir/Whir/WHIRNativeSecurity.lean | 10 +- .../whir/Whir/WHIRObservableSecurity.lean | 8 -- verification/whir/differential/run.py | 16 +++- verification/whir/differential/src/main.rs | 91 ++++++++++++++++--- 16 files changed, 317 insertions(+), 91 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index e9ef15e45..2cf5533ae 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -1,6 +1,6 @@ # Executable WHIR model and checked list binding -This isolated Lean project models leanVM's binary-field, interleaved WHIR variant at production revision [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217). It contains an executable concrete prover/verifier, checked concrete field and encoder mathematics, a proof of adaptive interactive **list binding** for the actual Lean verifier, and ordinary random-oracle bounds for executable standalone and stacked oracle adversaries. Live Rust differential checks provide separate implementation evidence. This is not a kernel proof of Rust compilation or a proof that deterministic BLAKE2s is a random oracle. +This isolated Lean project models leanVM's binary-field, interleaved WHIR variant, originally pinned to [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217) and now integrated normally with upstream [`10266a181437019400bc93d8dfbb373301ba8aa5`](https://github.com/leanEthereum/leanVM/tree/10266a181437019400bc93d8dfbb373301ba8aa5). It contains an executable concrete prover/verifier, checked concrete field and encoder mathematics, adaptive interactive **list binding** for the actual Lean verifier, and random-oracle bounds for executable standalone and stacked adversaries. Fresh Rust differential checks are separate implementation evidence. The deployed keyed transcript, proposed #552 duplex model and unmerged #565 selector fix are distinct source pins, not one proved production protocol. ## Reproduce @@ -16,24 +16,33 @@ python3 differential/run.py The runner builds and executes `whirModel`, executes the production Rust harness in release mode, and compares newly computed records. Its query mode also feeds actual production challenge limbs to Lean. It uses `/tmp/whir-lean-target`, two Cargo jobs, and one leanVM worker. Lean execution must emit no runtime diagnostic on stderr, including on malformed public inputs. There are no accepted-output snapshots to regenerate. Lean proof checking is separate from executable differential evidence. +### Current source drift + +The live harness executes the integrated upstream crates through relative dependencies. Relevant relocated paths are `pcs/src/{ntt,stack_open,whir}/mod.rs` and `whir/{config,sumcheck}/mod.rs`. [#559 at `a956c82ac711b2f4dbb3793ef2679fa47f3d6435`](https://github.com/leanEthereum/leanVM/commit/a956c82ac711b2f4dbb3793ef2679fa47f3d6435) changed deeper commitments to retained message/NTT/Merkle data with queried rows regenerated and replayed in original order. [#550 at `f52bd991c8623894e7b03a2e50bede6c248ea1ad`](https://github.com/leanEthereum/leanVM/commit/f52bd991c8623894e7b03a2e50bede6c248ea1ad) changed optimized NTT/induced-weight execution; these kernels remain differentially checked, not universally refined. [#537 at `b735ce59975e51414b3290fce50e7a7ea10600b2`](https://github.com/leanEthereum/leanVM/commit/b735ce59975e51414b3290fce50e7a7ea10600b2) removed the Python verifier and its integrations. The Python runner here is orchestration, not a replacement verifier. + +`fiat_shamir/src/lib.rs` retains the baseline keyed step chain: two pending extension scalars and squeeze tag `2`. The native Rust opening smoke exercises that deployed implementation. The separate Lean duplex construction targets only proposed [#552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d), whose byte framing and versioned transports are incompatible with the deployed chain. Neither the upstream merge nor differential execution instantiates the proposed duplex security theorem for deployed Rust. + +[#565 at `41c140b04eb85f5cfe12c4d238d3979af7d85fbf`](https://github.com/leanEthereum/leanVM/commit/41c140b04eb85f5cfe12c4d238d3979af7d85fbf) remains unmerged. Current `stack_open/mod.rs::check_statement` checks point-claim range ends, not offset alignment or strided-slot bounds. The harness reports actual acceptance of three independently incorrect malformed selector claims as **KNOWN GAP**, outside valid-shape Lean comparisons. The mathematical native correspondence requires `SuccinctPointWeight.Shape`, established for constructed CPU/recursion placements, not for every public PCS statement accepted by that range-only check. No production Rust changes are made by this proof update. + + ## Protocol to code to theorem map -Paths below are relative to `crates/pcs/src`, except the Python mirror, `python-verifier/verifier.py`. +Paths below are relative to `crates/pcs/src` unless another crate is named. Historical Python mirrors have been removed upstream and are not current correspondence evidence. -| Protocol step | Production implementation and mirror | Lean executable/specification | Checked guarantee and boundary | +| Protocol step | Current production implementation | Lean executable/specification | Checked guarantee and boundary | | --- | --- | --- | --- | -| Shapes and rate ladder | `whir/config.rs`, Python `WhirConfig` | `Protocol.productionConfig`, `Layout`, `ParameterBounds` | Exact index arithmetic and kernel-checked error inequalities for all 56 profiles: log-size 15 through 28, rate index 1 through 4. | +| Shapes and rate ladder | `whir/config/mod.rs` | `Protocol.productionConfig`, `Layout`, `ParameterBounds` | Exact index arithmetic and kernel-checked error inequalities for all 56 profiles: log-size 15 through 28, rate index 1 through 4. | | K/E arithmetic and embedding | `primitives::field::{F64,F192}` | `Concrete`, `FieldModel`, `FieldIrreducible`, `FieldEquivalence` | Actual XOR/reduced multiplication, inverses, quotient field equivalences, exact cardinalities, embedding and distinct Frobenius conjugates are proved. No concrete field law is assumed. | | Interleaved commitment | `whir/commit.rs`, `ntt/additive_ntt_f64.rs` | `Concrete.encodeBase/encodeExt`, `AdditiveBasis`, `AdditiveColumn`, `CandidateFolding` | The actual dense Lean encoder is connected to the additive novel-basis Reed-Solomon polynomial, with injectivity, degree, agreement, reversed lanes and zero-tail geometry. Rust's optimized NTT remains differentially checked rather than universally refined. | -| Equality weights and MLE | `primitives::multilinear`, Python `eq_kernel` | `Algebra.eqWeight`, `mle`, `foldFirst` | Partition of unity, Boolean interpolation, partial evaluation, constant evaluation, batching linearity. | -| Compact quadratic round | `whir/sumcheck.rs`, `verify.rs::Quad`, Python transcript round reader | `Algebra.compactRound`, `roundConstant`, `roundQuadratic` | Characteristic-two endpoint relation, reconstruction, honest round preservation, all-round sumcheck terminal equality. | -| Lane fold and later folds | `whir/prove.rs`, `sumcheck.rs`, `commit.rs` | `Concrete.foldLane`, `foldLow`, `Completeness.foldBlock` | Generic block folding is linear; encoding commutes with multilinear folds; all sizes, including empty algebraic blocks, are handled. Production-valid schedules are a subset. | -| OOD and query claims | `verify.rs::Ood`, `LevelCtx`, `induce.rs`; Python `_induced_weight` | `QueryRefinement`, `BatchingRefinement`, `ExecutableOOD`, `CausalBoundary` | Actual authenticated-column folds and actual induced-weight dots agree; concrete MLE/OOD root bounds and adaptive query batching preserve the lost-list invariant except for bounded bad events. | -| Query sampling | `whir.rs::strata/sample_queries_ordered`, public `OpeningVerifier`; Python `strata/sample_queries` | `Concrete.deriveQueries`, `SamplingRefinement`, `SamplingProbability`, `StratifiedDensity` | Exact E-limb chunk extraction, stratified product distribution, repeated full-domain groups, unused bits and with-replacement duplicate queries; no replacement by iid whole-domain samples. | -| Pruned row authentication | `merkle.rs`, verifier `open_base` operations; Python `Transcript.merkle` | `ByteCodec`, `MerkleLevels`, `MerkleTransport` | Actual flat octopus walk, sorted unique reconstruction, duplicate/order refanout, byte codecs and pruned lanes refine fixed ideal rows, or exhibit an actual hash collision or fresh target hit. A first-registration registry freezes each root's oracle across clones and later batches. | -| Terminal point | `verify.rs::terminal`, Python `verify_whir` | `Layout.terminalPoint/levelPoint`, `Concrete.rotatePoint` | Caller weight receives the left-rotated point; per-level suffix stays in round order. Rotation length, permutation, inverse and slices are proved. | +| Equality weights and MLE | `primitives::multilinear` | `Algebra.eqWeight`, `mle`, `foldFirst` | Partition of unity, Boolean interpolation, partial evaluation, constant evaluation, batching linearity. | +| Compact quadratic round | `whir/sumcheck/mod.rs`, `verify.rs::Quad` | `Algebra.compactRound`, `roundConstant`, `roundQuadratic` | Characteristic-two endpoint relation, reconstruction, honest round preservation, all-round sumcheck terminal equality. | +| Lane fold and later folds | `whir/prove.rs`, `sumcheck/mod.rs`, `commit.rs` | `Concrete.foldLane`, `foldLow`, `Completeness.foldBlock` | Generic block folding is linear; encoding commutes with multilinear folds; all sizes, including empty algebraic blocks, are handled. Production-valid schedules are a subset. | +| OOD and query claims | `verify.rs::Ood`, `LevelCtx`, `induce.rs` | `QueryRefinement`, `BatchingRefinement`, `ExecutableOOD`, `CausalBoundary` | Actual authenticated-column folds and actual induced-weight dots agree; concrete MLE/OOD root bounds and adaptive query batching preserve the lost-list invariant except for bounded bad events. | +| Query sampling | `whir/mod.rs::strata/sample_queries_ordered`, public `OpeningVerifier` | `Concrete.deriveQueries`, `SamplingRefinement`, `SamplingProbability`, `StratifiedDensity` | Exact E-limb chunk extraction, stratified product distribution, repeated full-domain groups, unused bits and with-replacement duplicate queries; no replacement by iid whole-domain samples. | +| Pruned row authentication | `merkle.rs`, verifier `open_base` operations | `ByteCodec`, `MerkleLevels`, `MerkleTransport` | Actual flat octopus walk, sorted unique reconstruction, duplicate/order refanout, byte codecs and pruned lanes refine fixed ideal rows, or exhibit an actual hash collision or fresh target hit. A first-registration registry freezes each root's oracle across clones and later batches. | +| Terminal point | `verify.rs::terminal` | `Layout.terminalPoint/levelPoint`, `Concrete.rotatePoint` | Caller weight receives the left-rotated point; per-level suffix stays in round order. Rotation length, permutation, inverse and slices are proved. | | Last-level closure | `verify.rs::last_level/terminal` | `Protocol.verify`, `Completeness.finalWeight/finalClaim/replay` | Final consistency powers start at one, without OOD; honest residual plus query batching and all-level algebraic terminal equality are proved. | -| Ring switching and stack | `ring_switch.rs::RingFamily/RingShare`, `stack_open.rs`, Python `ring_switch` | `RingMapConcrete`, `RingMapBatchingConcrete`, `RingPCSGame` | Exact K-word packing into 64 slices, concrete six-stage map and its error, family gamma batching with scale inside the map, original family/point claims and their actual transformed public weights. | +| Ring switching and stack | `ring_switch.rs::RingFamily/RingShare`, `stack_open/mod.rs` | `RingMapConcrete`, `RingMapBatchingConcrete`, `RingPCSGame` | Exact K-word packing into 64 slices, concrete six-stage map and its error, family gamma batching with scale inside the map, original family/point claims and their actual transformed public weights. | | Interactive list binding | Annex B `thm:rbr` | `CausalGame`, `InitialCandidates`, `CausalBadEvents`, `InteractiveSoundness` | A commitment-time list of at most 2^32 K-witnesses is fixed before public claims and the causal adversarial strategy. Actual false acceptance implies one of the proved sparse events; the full finite-tape probability bound is instantiated for every production profile. | `Completeness.Schedule` remains a useful ideal algebraic completeness theorem. The security endpoint does not assume that an execution belongs to that honest schedule: `InteractiveSoundness.accepted_false_cover` reasons from acceptance by the actual checked initializer, fold loops, authenticated query/OOD batches, residual opening and terminal comparison, for arbitrary adversarial replies. @@ -85,7 +94,11 @@ The production checkout used by the main differential harness still has the olde `DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove actual framing inverses, message/template injection, canonical WHIR history encoding and the structural DMV conditions. `DuplexCompression` implements the actual BLAKE2s compression evaluator. Structural framing correctness is not a proof of the probabilistic DMV theorem. -`DuplexModeGame` defines real public-compression and ideal raw-random-oracle/simulator games for adaptive direct and construction queries, including auxiliary and verifier work. Its transfer theorems expose two separate assumptions: `PublicRandomCompressionDMV` is the universal view-distinguishing bound for the actual mode and simulator; `ConcretePrimitiveGap` is the separate restricted-adversary gap between deterministic BLAKE2s and a random compression function. These are ordinary crypto games, not a PCS false-acceptance assumption. The external stochastic DMV theorem and a small concrete BLAKE2s advantage are not kernel-proved here. +`DuplexModeGame` defines finite real public-compression and ideal raw-random-oracle/simulator games for adaptive direct and construction queries, including auxiliary and verifier work. `PublicRandomCompressionDMV` now assumes only the actual universal view-distinguishing inequality; its redundant `simulatorBound` certificate field has been removed because `DuplexPublicSimulator.simulatorBound` proves the pinned simulator's metering. Structural reconstruction and metering do **not** prove the stochastic inequality. The finite-game coupling/H-coefficient argument for the actual mode and simulator remains a mathematical proof obligation. + +`ConcretePrimitiveGap` is retained as a precisely named **full-public-view replacement premise**, not a standard computational hash-security assumption. `knownAnswerAdversary` makes one direct primitive query, and `knownAnswerDistinguisher` compares its answer with a local evaluation of public BLAKE2s. `knownAnswer_concreteProbability` is exactly `1`; `knownAnswer_realProbability` is exactly `2^-256`. The kernel-checked `concretePrimitiveGap_knownAnswer_lower_bound` therefore proves `primitiveLoss >= 1 - 2^-256` whenever `Q >= 1` and `Allowed` includes this pair. Ordinary efficient classes include this elementary observer. Efficiency, collision resistance or a stronger implementation audit cannot justify a small full-view loss. This counterexample applies to the public primitive experiment used for proposed #552 and does not refute the separate random-compression DMV claim. + +Consequently `WHIRNativeSecurity.concrete_list_binding` is a formal conditional inequality, **not a useful ordinary computational-security theorem for deterministic BLAKE2s**. Excluding the observer solely to manufacture a small gap is not a standard assumption or a completed reduction. A useful concrete theorem would need a justified, correctly scoped assumption about the actual protocol/final event or another cryptographic reduction; none is silently substituted here. No such standard-assumption reduction has been proved. ### Native source, caller and Merkle composition @@ -93,10 +106,13 @@ The production checkout used by the main differential harness still has the olde `WHIRNativeEvent.distinguisher` receives only the completed public result. `WHIRObservableSource.observe` reconstructs its chronological cache, labels and immutable first-registration state from public source events and physically returned completion records; neither receives a source program, adversary coins, simulator seed or total oracle. `WHIRSourceFrozenPrefix.actual_backfill_retained` connects every retained snapshot to its actual earlier full-compression prefix, including direct calls and hidden construction calls. The candidate list is `InitialCandidates.witnesses` of the first-frozen commitment, not a list selected after inspecting the claimed family; `bindClaims_witnesses` proves that binding claims leaves this list unchanged, and `WHIRPhysicalDriver.native_list_bound` bounds its cardinality by `2^32`. -`WHIRNativeSecurity.random_compression_list_binding` composes the actual native event with the checked adaptive raw-oracle bound, the explicit DMV game assumption, and `PublicMerkleProbability.opening_probability_bound`. Write `A = a + b` for attacker plus native-verifier source budgets, `R = (Q+1) * (free + (Q+1) * (40+1))`, and `epsilon = 2^-79 + ringCharge cap`. The bound is `min 1 ((40 + callerOutputCap) * (A+1) * epsilon) + min 1 (choose(Q,2) / 2^256) + (choose(Q,2) + Q*(R+3*Q)) / 2^256`. The physical budget is source-only and noncircular: `A + A*(pathFactor*A) + pathFactor*Mf <= Q`; verifier and final-path caps need hold only on reachable attacker outputs, and zero-cost commitment announcements have their own `FreeAnnouncements` resource. `WHIRNativeSecurity.concrete_list_binding` adds exactly one separate concrete-primitive gap for this final public native event, not an assumption about an unobservable Merkle event. No small concrete BLAKE2s gap is asserted. +`WHIRNativeSecurity.random_compression_list_binding` composes the actual native event with the checked adaptive raw-oracle bound, the explicit DMV game assumption, and `PublicMerkleProbability.opening_probability_bound`. Write `A = a + b` for attacker plus native-verifier source budgets, `R = (Q+1) * (free + (Q+1) * (40+1))`, and `epsilon = 2^-79 + ringCharge cap`. The strengthened bound is `min 1 ((40 + callerOutputCap) * (A+1) * epsilon) + min 1 (choose(Q,2) / 2^256) + (Q*R + 2*Q*(Q-1)) / 2^256`. `PublicMerkleProbability.badTargets_card` now bounds the actual causal targets by `R + 4*history.length`; `risk_bound` sums those per-step counts instead of replacing pair-child/CV targets by the final budget. This tightens the previous Merkle numerator `choose(Q,2) + Q*(R+3*Q)` without adding any premise, and flows through `WHIRSourceMerkleSecurity.loss` to both native endpoints. The physical envelope remains source-only and noncircular: `A + A*(pathFactor*A) + pathFactor*Mf <= Q`; verifier and final-path caps hold on reachable attacker outputs, and zero-cost commitment announcements have their own `FreeAnnouncements` resource. The concrete endpoint adds the explicit replacement loss subject to the impossibility boundary above. `SuccinctPointWeight.eqAt_eq_mle`, `SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle`, and `InducedTerminalRefinement.nativeBasisAt_eq_mle` connect the actual plain/strided selectors, shared-prefix ring evaluator, inverse-Frobenius coefficients, and native induced-basis recurrence to their dense meanings. `AccumulatedTerminalRefinement.stack_terminal_equivalence` composes every saved OOD/query context with the rotated original caller point. `WHIRNativeArithmetic.sourceVerify_refines` proves the complete scalar-only native-style verifier loop refines `Protocol.verify`, under explicit public shapes and authenticated-row premises; it does not assume caller-weight or terminal-evaluator equality. `WHIRNativeErasure.nativeVerify_erased` removes only ghost commitment oracles, preserving actual query rows and errors. +`SuccinctPointWeight.dimension_le_of_block_bound` derives coordinate dimension from full-block containment. `selector_lt_of_block_bound` proves the shifted high selector fits the suffix consumed by the native evaluator and is used by `region_mle`, hence the native `eqAt_eq_mle` chain. `Shape` no longer redundantly asks for dimension bounds in addition to containment; `Shape.point_iff` and `Shape.strided_iff` prove equivalence to the previous complete guard predicates. `WHIRCallerSupport.production_point_nativeShape` uses the reduced premise set. Offset alignment and strided-slot bounds remain genuine requirements, not consequences of current Rust's range-only guard. + + The model also fixes a Lean L0 extraction discrepancy: authenticate the full padded leaf, discard only its leading absent lanes, and reverse the occupied lanes exactly once at the protocol boundary. Separately executed pruned and full-width regression cases exercised the real parser and hash path. This is a model correction, distinct from the Rust guard fix below. ## Original papers and version limits @@ -119,7 +135,13 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 `Audit.lean` discovers every exported theorem in the elaborated `Whir` namespace and computes its transitive axioms. It rejects project axioms and every dependency axiom except `propext`, `Classical.choice` and `Quot.sound`. Selected principal algebra endpoints additionally retain `#print axioms` commands. No `sorry`, `admit`, `native_decide`, unsafe proof execution, or new correctness axiom is used in completed chains. Running the compiled model and Rust still trusts their compilers/runtime; differential testing is evidence for tested inputs, not a kernel proof of their correspondence. -The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, complete adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion callers, public source reconstruction, first-frozen Merkle transport, and the ordinary shared-compression collision/target-hit probability bound. The final native endpoints have resource-budget premises and the explicitly separated cryptographic game assumptions above, not verifier/source correctness, decoder agreement, row authentication or missing-cover premises. The Rust compiler, optimized Rust NTT, universal Rust-to-Lean correspondence, external DMV probability theorem and concrete BLAKE2s idealization remain outside the kernel-proved conclusions. +The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: + +- **Unproved mathematical reduction:** `PublicRandomCompressionDMV.distinguishing` for `DuplexPublicSimulator.simulator Q` and the pinned #552 mode. Framing, public-chain recognition, seed reconstruction and actual RO-query metering are proved; the adaptive real/ideal probability coupling and its DMV birthday bound are not. +- **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. +- **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. +- **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. Current Rust's selector guard is weaker than `Shape`; valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. +- **Deployment/security target:** the public-mode theorem targets proposed #552, not the deployed keyed transcript. Ground list binding is not unique binding. No grinding amplification or numerical 128-bit whole-system security conclusion is asserted. Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The concrete production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. The conditional public-mode theorem still targets only the pinned #552 source identified above, not the older keyed baseline. @@ -129,7 +151,19 @@ Verification found and fixed a Lean model evaluation-order bug: a malformed publ Further source composition exposed a second auxiliary-model bug: an invalid claim-order annotation stopped public compression observation although the underlying source program continued and later roots could still be registered. The observer now preserves its first error while continuing to record real public calls and commitments. This changes neither the native verifier nor the mode program, and claimed annotations still cannot install family or point data. An actual BLAKE2s reproduction failed before the correction with zero recorded calls and passed afterward with one recorded call and the original error unchanged. -## Exercised validation +## Current upstream refresh validation + +The final native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean`. The fresh `lake env lean -E warning Audit.lean` census reported **7488 exported theorem declarations**, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound`. This is a trust audit, not a count of independently substantive results. Explicit inspection of both native endpoint types, `PublicRandomCompressionDMV` fields and `ConcretePrimitiveGap` confirmed the hypotheses listed above; an axiom census alone would not discharge them. + +The build freshly exercised the maintained public-simulator, accumulated-terminal, scalar-native-verifier, caller-geometry, physical-row, source-backfill and partial-replay regressions. The exact known-answer game theorems and strengthened Merkle endpoint were kernel-checked in this closure. A separate executed observer smoke used actual public BLAKE2s, accepted its locally computed answer, rejected a changed digest, and charged exactly one direct primitive call; the exact random-world probability was proved, not estimated by sampling. + +Current-source release Rust `rec::verifier::tests::the_smallest_opening_holds_in_both_verifiers` passed: honest mixed ordinary/strided/ring openings hold in the native verifier and recursive rows, and tampered claims fail their terminal checks. This is a scoped runtime regression, not universal Rust or compiler correctness. + +Fresh compiled-model execution exposed a startup bug that interpreter/proof checks had not detected: even `whirModel query 8 0` was killed under the required memory scope before emitting a record. Generated `FieldCardinality` C initializers eagerly called `List.finRange` for the `2^64` base-field enumeration and constructed extension-field Cartesian products. The proof-only `FieldModel.instFintypeK` and `instFintypeE`, plus their dependent mathematical challenge-table instances, are now explicitly noncomputable. `FieldTower` supplies canonical computable superclass dictionaries directly from the already-proved `instCommRingE`, so executable ring kernels do not synthesize operations through the noncomputable field-inverse structure. No second set of arithmetic operations or laws is introduced. This removes unnecessary executable initialization without changing the finite carriers, cardinality theorems or mathematical security statements. The rebuilt compiled empty-query command emitted `queries=` successfully under the same scope. The maintained differential runner exercises the actual compiled executable, not an interpreter-only replacement. + +After the correction, fresh `python3 differential/run.py` passed **71 live record groups** and production query batches `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`. The compiled Lean multilevel opening accepted and rejected its maintained malformed/tampered cases without stderr diagnostics. The current Rust opening accepted mixed point/strided/ring claims and rejected damaged streams/scalars/authentication and source-enforced shape errors. It separately reported `accepted_incorrect_claim` for plain offset, strided offset and high strided slot, explicitly outside valid-shape refinement. The output identified `deployed_keyed_step,max_pending:2,squeeze_tag:2`; the Lean opening replay uses supplied ideal challenges, not the deployed BLAKE2s transcript. + +## Earlier scoped validation The complete native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean` and the consolidated `lake env lean -E warning Audit.lean` census of 7477 exported theorem declarations, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound` permitted. Executing `lake env lean -E warning --run Main.lean` exercised the honest multilevel opening and its malformed/tampered rejection paths. This build freshly executed the maintained physical-row, source-backfill and partial-replay regressions; it replayed cached results for the previously executed scalar-verifier, accumulated-terminal and public-simulator regressions. The live Rust differential observations below were obtained separately, not rerun during this final publication. @@ -147,6 +181,6 @@ Additional scoped executable checks exercised actual causal honest and false cla The pinned #552 duplex evaluator matched 37 independently executed Rust state/API fixture records, including the actual BLAKE2s known-answer paths. Flat Merkle transport matched 27 Rust/Lean records over 14 accepted/rejected cases and exercised 13 raw occurrence paths; separate registry checks covered immutable first registration and later batched openings. These are scoped execution observations, not universal Rust refinement theorems. -The standalone Rust harness previously passed release Clippy and rustdoc with warnings denied, and its Python runner passed Ruff and `ty`. This proof PR changes no production verifier or guest fixtures. Its original baseline includes a Python verifier; the freshly fetched upstream used for the separate fix below no longer does. +Before this upstream refresh, the standalone Rust harness passed release Clippy and rustdoc with warnings denied, and its orchestration runner passed Ruff and `ty`. Those tool checks are historical, not claimed rerun in the current proof/source update. Production verifier and guest fixtures are unchanged by this proof work. -The native-selector equivalence work also found a confirmed Rust library discrepancy, fixed separately in [PR #565](https://github.com/leanEthereum/leanVM/pull/565): malformed plain/strided offsets or an oversized strided slot were accepted with independently checked wrong slice values because the succinct selectors discarded those bits. The release regression failed for all three cases before the fix. Afterward, five stacked-opening tests, the native/recursive smallest-opening test, and an independent public-API commitment/open/verify executable passed. This is an existing public metadata-contract violation, not a demonstrated production VM proof exploit. Valid proof encodings and transcript domains are unchanged. +The selector discrepancy has a separately proposed fix in [PR #565](https://github.com/leanEthereum/leanVM/pull/565), but that source is not integrated here. Current upstream still accepts the malformed plain/strided offsets and oversized strided slot with independently incorrect slice values; the refreshed live harness makes this visible rather than silently adopting the proposed guard. This remains a public PCS metadata-contract violation, not a demonstrated production VM proof exploit. diff --git a/verification/whir/Whir/CausalProbability.lean b/verification/whir/Whir/CausalProbability.lean index 96672f0a1..e62ba4dad 100644 --- a/verification/whir/Whir/CausalProbability.lean +++ b/verification/whir/Whir/CausalProbability.lean @@ -24,7 +24,7 @@ abbrev Sample {c : Config} : Coordinate c → Type | .query i => (Fin (queryChunks c i.val) → E) × E | .tail _ => E -instance {c : Config} (q : Coordinate c) : Fintype (Sample q) := by +noncomputable instance {c : Config} (q : Coordinate c) : Fintype (Sample q) := by cases q <;> unfold Sample <;> infer_instance instance {c : Config} (q : Coordinate c) : Zero (Sample q) := by diff --git a/verification/whir/Whir/DuplexModeGame.lean b/verification/whir/Whir/DuplexModeGame.lean index 304077b44..1c0563f3d 100644 --- a/verification/whir/Whir/DuplexModeGame.lean +++ b/verification/whir/Whir/DuplexModeGame.lean @@ -239,23 +239,20 @@ noncomputable def ModeAdv {Q : Nat} {Seed State AdvCoins Result : Type} (D : View Result → Bool) : ℚ := |realProbability iv adversary D - idealProbability sim iv adversary counted D| -/-- Precise remaining DMV18 Theorem 1 boundary for the proved concrete mode. -It is universally quantified over adaptive programs and view distinguishers, -not a PCS acceptance assertion. The actual simulator's RO calls are bounded. -/ +/-- Precise remaining stochastic DMV18 Theorem 1 boundary for the proved mode. +Only the view-distinguishing inequality is assumed. The pinned simulator's +query bound is proved separately, never a cryptographic certificate field. -/ structure PublicRandomCompressionDMV (Q : Nat) (Seed State : Type) [Fintype Seed] (sim : Simulator Q Seed State) (iv : Digest32) : Prop where - simulatorBound : ∀ (AdvCoins Result : Type) [Fintype AdvCoins] - (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) - (ro : RawKey Q → Digest32) (seed : Seed) (a : AdvCoins), - (runIdeal sim ro iv (sim.initial seed) (adversary a) Q (by omega) (counted a)).simulatorQueries ≤ Q distinguishing : ∀ (AdvCoins Result : Type) [Fintype AdvCoins] (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) (D : View Result → Bool), ModeAdv sim iv adversary counted D ≤ dmvLoss Q -/-- An explicit concrete-primitive idealization game, with its own loss and -permitted computational class. No small bound for deterministic public BLAKE2s -is asserted: in particular this is not an unconditional random-oracle theorem. -/ +/-- An explicit full-public-view deterministic-primitive replacement game. +The known-answer theorem below rules out a small loss for any permitted class +containing the elementary local-evaluation observer, including ordinary +efficient classes. This is not a standard computational hash assumption. -/ def ConcretePrimitiveGap (Q : Nat) (iv : Digest32) (loss : ℚ) (Allowed : (AdvCoins : Type) → [Fintype AdvCoins] → (Result : Type) → (AdvCoins → Program Result) → (View Result → Bool) → Prop) : Prop := @@ -264,6 +261,61 @@ def ConcretePrimitiveGap (Q : Nat) (iv : Digest32) (loss : ℚ) (∀ a, Counts Q (adversary a)) → |concreteProbability iv adversary D - realProbability iv adversary D| ≤ loss +/-- One public primitive call, with no construction queries or hidden work. -/ +def knownAnswerAdversary (input : Node) : Unit → Program Digest32 := + fun _ => .ask (.primitive .direct input) .done + +/-- The observer can evaluate the same public deterministic implementation +locally. Resource bounds on oracle calls do not exclude this distinguisher. -/ +def knownAnswerDistinguisher (input : Node) (view : View Digest32) : Bool := + decide (view.result = blake2sOracle input) + +theorem knownAnswer_counted (input : Node) (Q : Nat) (budget : 1 ≤ Q) : + ∀ coins, Counts Q (knownAnswerAdversary input coins) := by + intro coins + exact ⟨budget, fun _ => trivial⟩ + +theorem knownAnswer_concreteProbability (iv : Digest32) (input : Node) : + concreteProbability iv (knownAnswerAdversary input) (knownAnswerDistinguisher input) = 1 := by + unfold concreteProbability + rw [distinguish_average (inferInstance : Fintype Unit)] + simp [knownAnswerAdversary, knownAnswerDistinguisher, runReal, realAnswer, prepend, + average] + +theorem knownAnswer_realProbability (iv : Digest32) (input : Node) : + realProbability iv (knownAnswerAdversary input) (knownAnswerDistinguisher input) = + 1 / (2^256 : ℚ) := by + classical + unfold realProbability + rw [distinguish_average (inferInstance : Fintype (PrimitiveOracle × Unit))] + simp only [knownAnswerAdversary, knownAnswerDistinguisher, runReal, realAnswer, prepend, + decide_eq_true_eq] + have product (f : PrimitiveOracle → ℚ) : + average (fun coins : PrimitiveOracle × Unit => f coins.1) = average f := by + simp [average, Fintype.sum_prod_type, Fintype.card_prod] + rw [product (fun oracle => if oracle input = blake2sOracle input then 1 else 0)] + rw [fresh_coordinate input + (fun (_ : {j : Node // j ≠ input} → Digest32) d => + if d = blake2sOracle input then (1 : ℚ) else 0)] + simp [average] + norm_num + +/-- The exact public-oracle replacement premise forces an essentially unit +loss whenever its permitted class includes the elementary known-answer +observer. This is an unconditional finite-game fact, not a hash conjecture. -/ +theorem concretePrimitiveGap_knownAnswer_lower_bound (Q : Nat) (iv : Digest32) + (input : Node) (loss : ℚ) + (Allowed : (AdvCoins : Type) → [Fintype AdvCoins] → (Result : Type) → + (AdvCoins → Program Result) → (View Result → Bool) → Prop) + (gap : ConcretePrimitiveGap Q iv loss Allowed) (budget : 1 ≤ Q) + (permitted : Allowed Unit Digest32 (knownAnswerAdversary input) + (knownAnswerDistinguisher input)) : + 1 - 1 / (2^256 : ℚ) ≤ loss := by + have h := gap Unit Digest32 (knownAnswerAdversary input) + (knownAnswerDistinguisher input) permitted (knownAnswer_counted input Q budget) + rw [knownAnswer_concreteProbability, knownAnswer_realProbability] at h + exact (le_abs_self _).trans h + /-- The structural prerequisites and executable construction equation are checked facts, never fields in either external cryptographic assumption. -/ theorem pinned_mode_structure : DMVConditions := dmv_conditions diff --git a/verification/whir/Whir/DuplexPublicSimulator.lean b/verification/whir/Whir/DuplexPublicSimulator.lean index b9bc76952..f47fff795 100644 --- a/verification/whir/Whir/DuplexPublicSimulator.lean +++ b/verification/whir/Whir/DuplexPublicSimulator.lean @@ -542,8 +542,7 @@ theorem security_of_distinguishing (Q : Nat) (iv : Digest32) letI := seedFintype PublicRandomCompressionDMV Q Seed State (simulator Q) iv := by let := seedFintype - exact ⟨fun _ _ _ adversary counted ro seed a => - simulatorBound ro iv _ (adversary a) Q (by omega) (counted a), distinguishing⟩ + exact ⟨distinguishing⟩ theorem recognized_publicBody {log : PublicLog} {input : Node} {ns : List Node} (h : recognized log input = some ns) : diff --git a/verification/whir/Whir/FiatShamirGame.lean b/verification/whir/Whir/FiatShamirGame.lean index 291f7e35a..b19c51def 100644 --- a/verification/whir/Whir/FiatShamirGame.lean +++ b/verification/whir/Whir/FiatShamirGame.lean @@ -445,6 +445,14 @@ def distinguishProbability {Coins View : Type*} [Fintype Coins] classical exact Soundness.uniformProb (Finset.univ.filter fun r => distinguisher (experiment r) = true) +theorem distinguish_average {Coins View : Type*} {old : Fintype Coins} + (new : Fintype Coins) (experiment : Coins → View) (D : View → Bool) : + @distinguishProbability Coins View old experiment D = + @average Coins new (fun coin => if D (experiment coin) = true then 1 else 0) := by + classical + cases Subsingleton.elim old new + simp only [distinguishProbability, Soundness.uniformProb, average, Finset.sum_boole] + /-- A standard distinguishing assumption, universally quantified over the permitted view distinguishers; it contains no PCS relation or FS acceptance. -/ def ModeSecure {Coins View : Type*} [Fintype Coins] (G : ModeGame Coins View) diff --git a/verification/whir/Whir/FieldCardinality.lean b/verification/whir/Whir/FieldCardinality.lean index 166f7e84a..37f7395fe 100644 --- a/verification/whir/Whir/FieldCardinality.lean +++ b/verification/whir/Whir/FieldCardinality.lean @@ -15,7 +15,9 @@ def wordEquiv : K ≃ Fin (2^64) where left_inv := by intro a; rfl right_inv := by intro a; rfl -instance : Fintype K := Fintype.ofEquiv (Fin (2^64)) wordEquiv.symm +/-- Cardinality evidence is proof-only: compiling this enumeration would +eagerly allocate all 2^64 elements during executable module initialization. -/ +noncomputable instance : Fintype K := Fintype.ofEquiv (Fin (2^64)) wordEquiv.symm /-- The extension carrier has three independent machine-word coordinates. -/ def extensionEquiv : E ≃ K × K × K where @@ -24,7 +26,7 @@ def extensionEquiv : E ≃ K × K × K where left_inv := by intro a; cases a; rfl right_inv := by intro a; rcases a with ⟨a,b,c⟩; rfl -instance : Fintype E := Fintype.ofEquiv (K × K × K) extensionEquiv.symm +noncomputable instance : Fintype E := Fintype.ofEquiv (K × K × K) extensionEquiv.symm @[simp] theorem card_K : Fintype.card K = 2^64 := by rw [Fintype.card_congr wordEquiv, Fintype.card_fin] diff --git a/verification/whir/Whir/FieldTower.lean b/verification/whir/Whir/FieldTower.lean index 5524cee32..b550144fd 100644 --- a/verification/whir/Whir/FieldTower.lean +++ b/verification/whir/Whir/FieldTower.lean @@ -74,4 +74,14 @@ theorem E_field_zero_def : (0 : E) = E.zero := rfl theorem E_field_one_def : (1 : E) = E.one := rfl end + +/-- Executable ring kernels must not synthesize their operation dictionaries +through the noncomputable finite-field inverse. These are exactly the +previously proved concrete ring's superclass dictionaries, not new operations. -/ +instance : AddZeroClass E := instCommRingE.toAddZeroClass +instance : AddCommMonoid E := instCommRingE.toAddCommMonoid +instance : CommMonoid E := instCommRingE.toCommMonoid +instance : Monoid E := instCommRingE.toMonoid +instance : Sub E := instCommRingE.toSub + end Whir.FieldModel diff --git a/verification/whir/Whir/PublicMerkleProbability.lean b/verification/whir/Whir/PublicMerkleProbability.lean index 9b81ca1f0..10e5130f8 100644 --- a/verification/whir/Whir/PublicMerkleProbability.lean +++ b/verification/whir/Whir/PublicMerkleProbability.lean @@ -86,9 +86,9 @@ private theorem children_card {A B D : Type*} (H : MerkleBinding.Hashing A D B) change (roots log ∪ pairChildren log ∪ cvTargets log).card ≤ _ omega - theorem badTargets_card (roots : RootPolicy) (log : PublicLog) (R Q : Nat) - (cap : (roots log).card ≤ R) (budget : log.length ≤ Q) : - (badTargets roots log).card ≤ R+3*Q+log.length := by + theorem badTargets_card (roots : RootPolicy) (log : PublicLog) (R : Nat) + (cap : (roots log).card ≤ R) : + (badTargets roots log).card ≤ R+4*log.length := by have hu := Finset.card_union_le (outputTargets log) (targets roots log) have ho := outputTargets_card log have ht := targets_card roots log R cap @@ -113,14 +113,15 @@ noncomputable def risk {T : Type} (roots : RootPolicy) {Q : Nat} : | none => average (fun d => if d ∈ badTargets roots log then 1 else risk roots (next d) ((n,d)::log)) -/-- Exact birthday term plus the chosen conservative target term. -/ +/-- Sum the actual causal target counts: at call i there are at most R roots +and four targets per prior call, not three targets per final-budget call. -/ def bound (Q R : Nat) : ℚ := - ((Q : ℚ)*(Q-1)/2 + Q*(R+3*Q)) / 2^256 + ((Q : ℚ)*R + 2*Q*(Q-1)) / 2^256 -private def remainingBound (Q R remaining previous : Nat) : ℚ := - ((remaining : ℚ)*(R+3*Q+previous) + remaining*(remaining-1)/2) / 2^256 +private def remainingBound (R remaining previous : Nat) : ℚ := + ((remaining : ℚ)*(R+4*previous) + 2*remaining*(remaining-1)) / 2^256 -private theorem remaining_nonneg (Q R n m : Nat) : 0 ≤ remainingBound Q R n m := by +private theorem remaining_nonneg (R n m : Nat) : 0 ≤ remainingBound R n m := by cases n with | zero => simp [remainingBound] | succ n => @@ -128,9 +129,9 @@ private theorem remaining_nonneg (Q R n m : Nat) : 0 ≤ remainingBound Q R n m simp only [Nat.cast_add,Nat.cast_one,add_sub_cancel_right] positivity -private theorem remaining_step (Q R n m : Nat) : - remainingBound Q R (n+1) m = - (R+3*Q+m : ℚ)/2^256 + remainingBound Q R n (m+1) := by +private theorem remaining_step (R n m : Nat) : + remainingBound R (n+1) m = + (R+4*m : ℚ)/2^256 + remainingBound R n (m+1) := by unfold remainingBound push_cast ring @@ -143,16 +144,16 @@ private theorem remaining_step (Q R n m : Nat) : theorem risk_bound {T : Type} (roots : RootPolicy) (Q R : Nat) (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) {n : Nat} (p : Computation T n) (log : PublicLog) (budget : log.length+n ≤ Q) : - risk roots p log ≤ remainingBound Q R n log.length := by + risk roots p log ≤ remainingBound R n log.length := by classical induction p generalizing log with - | ret value => exact remaining_nonneg _ _ _ _ + | ret value => exact remaining_nonneg _ _ _ | @draw n input next ih => have hbudget : log.length ≤ Q := by omega have hcap := rootCap log hbudget - have hcard := badTargets_card roots log R Q hcap hbudget - have hstep := remaining_step Q R n log.length - have hnon : (0 : ℚ) ≤ (R+3*Q+log.length : ℚ)/2^256 := by positivity + have hcard := badTargets_card roots log R hcap + have hstep := remaining_step R n log.length + have hnon : (0 : ℚ) ≤ (R+4*log.length : ℚ)/2^256 := by positivity cases hit : PublicMerkleLog.lookup log input with | some d => simp only [risk,hit] @@ -165,10 +166,10 @@ private theorem remaining_step (Q R n m : Nat) : calc _ ≤ average (fun d : Digest32 => (if d ∈ badTargets roots log then (1:ℚ) else 0) + - remainingBound Q R n (log.length+1)) := by + remainingBound R n (log.length+1)) := by apply average_mono intro d - have hn := remaining_nonneg Q R n (log.length+1) + have hn := remaining_nonneg R n (log.length+1) have ht := ih d ((input,d)::log) (by simp only [List.length_cons]; omega) simp only [List.length_cons] at ht by_cases bad : d ∈ badTargets roots log @@ -176,9 +177,9 @@ private theorem remaining_step (Q R n m : Nat) : linarith · simpa only [bad,↓reduceIte,zero_add] using ht _ = (badTargets roots log).card / (2^256 : ℚ) + - remainingBound Q R n (log.length+1) := by + remainingBound R n (log.length+1) := by rw [average_add,uniform_target_probability,average_const] - _ ≤ (R+3*Q+log.length : ℚ)/2^256 + remainingBound Q R n (log.length+1) := by + _ ≤ (R+4*log.length : ℚ)/2^256 + remainingBound R n (log.length+1) := by apply add_le_add_left apply div_le_div_of_nonneg_right _ (by positivity) exact_mod_cast hcard @@ -242,8 +243,8 @@ or whole-hash table appears here. -/ have hb := risk_bound roots Q R rootCap p [] (by simp) calc _ = risk roots p [] := he - _ ≤ remainingBound Q R Q 0 := hb - _ = bound Q R := by simp only [remainingBound,bound,Nat.cast_zero,add_zero]; ring + _ ≤ remainingBound R Q 0 := hb + _ = bound Q R := by simp only [remainingBound,bound,Nat.cast_zero]; ring /-- Actual mode specialization includes every internal construction node. The independent R resource cap is not inferred from the mode C-call budget. -/ @@ -474,7 +475,7 @@ noncomputable def openingProbability {T : Type} (roots : RootPolicy) {Q : Nat} /-- Genuine adaptive random-compression bound for the public Merkle opening event, with all collision/fresh-target cases discharged by the causal trace -monitor. Exact constants: Q(Q-1)/2 + Q(R+3Q), over 2^256. -/ +monitor. Exact constants: QR + 2Q(Q-1), over 2^256. -/ theorem opening_probability_bound {T : Type} (roots : RootPolicy) (Q R : Nat) (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ R) (grow : RootsGrow roots) (p : Computation T Q) : openingProbability roots p ≤ bound Q R := by @@ -521,6 +522,6 @@ noncomputable def audit {T : Type} (roots : RootPolicy) {Q : Nat} : simpa only [audit_eval] using random_compression_bound roots Q R rootCap p theorem four_calls_two_roots : - bound 4 2 = (62 : ℚ) / 2^256 := by norm_num [bound] + bound 4 2 = (32 : ℚ) / 2^256 := by norm_num [bound] end Whir.PublicMerkleProbability diff --git a/verification/whir/Whir/StackWHIRReplay.lean b/verification/whir/Whir/StackWHIRReplay.lean index d6cc74313..c0957e850 100644 --- a/verification/whir/Whir/StackWHIRReplay.lean +++ b/verification/whir/Whir/StackWHIRReplay.lean @@ -10,7 +10,7 @@ open WHIRHistory (Pending) abbrev Sample {c : Config} : Coordinate c → Type := WHIRHistory.StackSample -instance {c : Config} (q : Coordinate c) : Fintype (Sample q) := by +noncomputable instance {c : Config} (q : Coordinate c) : Fintype (Sample q) := by cases q <;> unfold Sample <;> infer_instance instance {c : Config} (q : Coordinate c) : Nonempty (Sample q) := by cases q <;> unfold Sample <;> infer_instance diff --git a/verification/whir/Whir/SuccinctPointWeight.lean b/verification/whir/Whir/SuccinctPointWeight.lean index fa3a99fc1..f5d8bb963 100644 --- a/verification/whir/Whir/SuccinctPointWeight.lean +++ b/verification/whir/Whir/SuccinctPointWeight.lean @@ -140,6 +140,28 @@ lemma alignedRegion_mle {d h : Nat} (q : Nat) (bound : q < 2^h) rw [← hchosen, eqBits_cubeIndex] exact mul_comm _ _ +/-- No coordinate-length assumption is needed: a complete block fitting inside +the cube cannot have more coordinates than the cube. This uses unbounded natural +arithmetic, not unchecked Rust `usize` shifts or additions. -/ +theorem dimension_le_of_block_bound (offset d n : Nat) + (bounded : offset + 2^d ≤ 2^n) : d ≤ n := by + exact (Nat.pow_le_pow_iff_right (by decide : 1 < 2)).mp + ((Nat.le_add_left (2^d) offset).trans bounded) + +/-- The high selector fits in precisely the suffix coordinates consumed by +`eq_bits`; no high bits are silently discarded. -/ +theorem selector_lt_of_block_bound (offset d n : Nat) + (aligned : offset % 2^d = 0) (bounded : offset + 2^d ≤ 2^n) : + offset >>> d < 2^(n-d) := by + have dimension := dimension_le_of_block_bound offset d n bounded + have positive : 0 < 2^d := by positivity + have offset_eq : offset = 2^d*(offset/2^d) := by + have h := Nat.mod_add_div offset (2^d) + omega + rw [show n = d + (n-d) by omega, pow_add, offset_eq] at bounded + rw [Nat.shiftRight_eq_div_pow] + nlinarith + /-- Arbitrary low-dimensional weights scatter onto an aligned dyadic region. The arithmetic selector and full cube bound are proved, not bridge premises. -/ theorem region_mle {d h : Nat} (offset : Nat) (f : Nat → R) @@ -147,13 +169,12 @@ theorem region_mle {d h : Nat} (offset : Nat) (f : Nat → R) (aligned : offset % 2^d = 0) (bounded : offset+2^d ≤ 2^(d+h)) : natMle (d+h) (region offset d f) (Fin.addCases lo hi) = natMle d f lo * eqBits (offset/2^d) hi := by - have positive : 0 < 2^d := by positivity have offset_eq : offset = 2^d*(offset/2^d) := by have h := Nat.mod_add_div offset (2^d) omega have bound : offset/2^d < 2^h := by - rw [pow_add, offset_eq] at bounded - nlinarith + simpa only [Nat.shiftRight_eq_div_pow, Nat.add_sub_cancel_left] using + selector_lt_of_block_bound offset d (d+h) aligned bounded conv_lhs => rw [offset_eq] exact alignedRegion_mle _ bound _ _ _ @@ -275,13 +296,33 @@ def eqAt : RingPCSGame.PointClaim → Array Concrete.E → Concrete.E (eqBitsAt slot x 0 stride * eqEval point x stride) * eqBitsAt (offset >>> (stride+point.size)) x (stride+point.size) (x.size-(stride+point.size)) +/-- Exact dyadic selector guards. The block range already implies that every +coordinate slice used by `eqAt` is in bounds; dimension is not a separate premise. -/ def Shape (n : Nat) : RingPCSGame.PointClaim → Prop | .point offset point _ => - point.size ≤ n ∧ offset % 2^point.size = 0 ∧ offset+2^point.size ≤ 2^n + offset % 2^point.size = 0 ∧ offset+2^point.size ≤ 2^n | .strided offset slot stride point _ => - stride+point.size ≤ n ∧ offset % 2^(stride+point.size) = 0 ∧ + offset % 2^(stride+point.size) = 0 ∧ offset+2^(stride+point.size) ≤ 2^n ∧ slot < 2^stride +theorem Shape.point_iff (n offset : Nat) (point : Array Concrete.E) (value : Concrete.E) : + Shape n (.point offset point value) ↔ + point.size ≤ n ∧ offset % 2^point.size = 0 ∧ offset+2^point.size ≤ 2^n := by + constructor + · intro shape + exact ⟨dimension_le_of_block_bound offset point.size n shape.2, shape⟩ + · exact fun shape => shape.2 + +theorem Shape.strided_iff (n offset slot stride : Nat) + (point : Array Concrete.E) (value : Concrete.E) : + Shape n (.strided offset slot stride point value) ↔ + stride+point.size ≤ n ∧ offset % 2^(stride+point.size) = 0 ∧ + offset+2^(stride+point.size) ≤ 2^n ∧ slot < 2^stride := by + constructor + · intro shape + exact ⟨dimension_le_of_block_bound offset (stride+point.size) n shape.2.1, shape⟩ + · exact fun shape => shape.2 + instance (n : Nat) (claim : RingPCSGame.PointClaim) : Decidable (Shape n claim) := by cases claim <;> unfold Shape <;> infer_instance @@ -357,7 +398,7 @@ theorem eqAt_eq_natMle (n : Nat) (claim : RingPCSGame.PointClaim) (x : Fin n → eqAt claim (Array.ofFn x) = natMle n (RingPCSGame.pointWeight claim) x := by cases claim with | point offset point value => - obtain ⟨dimension,aligned,bounded⟩ := shape + obtain ⟨dimension,aligned,bounded⟩ := (Shape.point_iff n offset point value).mp shape obtain ⟨h,rfl⟩ := Nat.exists_eq_add_of_le dimension have split : x = Fin.addCases (fun i => x (Fin.castAdd h i)) (fun i => x (Fin.natAdd point.size i)) := by ext i @@ -365,7 +406,7 @@ theorem eqAt_eq_natMle (n : Nat) (claim : RingPCSGame.PointClaim) (x : Fin n → rw [split] exact (point_mle offset point value _ _ aligned bounded).symm | strided offset slot stride point value => - obtain ⟨dimension,aligned,bounded,valid⟩ := shape + obtain ⟨dimension,aligned,bounded,valid⟩ := (Shape.strided_iff n offset slot stride point value).mp shape obtain ⟨h,rfl⟩ := Nat.exists_eq_add_of_le dimension let low : Fin stride → Concrete.E := fun i => x (Fin.castAdd h (Fin.castAdd point.size i)) let middle : Fin point.size → Concrete.E := fun i => x (Fin.castAdd h (Fin.natAdd stride i)) diff --git a/verification/whir/Whir/WHIRCallerSupport.lean b/verification/whir/Whir/WHIRCallerSupport.lean index 57ffd0724..2c419f766 100644 --- a/verification/whir/Whir/WHIRCallerSupport.lean +++ b/verification/whir/Whir/WHIRCallerSupport.lean @@ -464,7 +464,7 @@ theorem production_point_nativeShape (sources : Array Source) (ps : Array Placem simp only [placeClaim,Option.some.injEq] at placed subst claim simpa only [SuccinctPointWeight.Shape,List.size_toArray] using - window_nativeShape sources w (List.mem_of_find?_eq_some hw) n c.point.length hl bound + (window_nativeShape sources w (List.mem_of_find?_eq_some hw) n c.point.length hl bound).2 | port packed slot stride => cases hw : lookupWindow sources packed with | none => simp [hs,hw] at hp @@ -479,7 +479,7 @@ theorem production_point_nativeShape (sources : Array Source) (ps : Array Placem subst p simp only [placeClaim,Option.some.injEq] at placed subst claim - exact ⟨hshape.1,hshape.2.1,hshape.2.2,hf.1⟩ + exact ⟨hshape.2.1,hshape.2.2,hf.1⟩ · simp [columnFits,portSlotFits,columnDimension,hs,hw,hd] at fits | sliced => simp [hs] at hp diff --git a/verification/whir/Whir/WHIRFiatShamir.lean b/verification/whir/Whir/WHIRFiatShamir.lean index 676dc25b7..ac8e2a21c 100644 --- a/verification/whir/Whir/WHIRFiatShamir.lean +++ b/verification/whir/Whir/WHIRFiatShamir.lean @@ -395,7 +395,7 @@ abbrev StackAnswer {p : Profile} {cap : Nat} : StackRequest p cap → Type | .initial _ => RingPCSGame.Prefix × E | .later r _ => Answer r -instance {p : Profile} {cap : Nat} (r : StackRequest p cap) : Fintype (StackAnswer r) := by +noncomputable instance {p : Profile} {cap : Nat} (r : StackRequest p cap) : Fintype (StackAnswer r) := by cases r <;> unfold StackAnswer <;> infer_instance instance {p : Profile} {cap : Nat} (r : StackRequest p cap) : Nonempty (StackAnswer r) := by diff --git a/verification/whir/Whir/WHIRNativeSecurity.lean b/verification/whir/Whir/WHIRNativeSecurity.lean index 1e3488592..db38ff000 100644 --- a/verification/whir/Whir/WHIRNativeSecurity.lean +++ b/verification/whir/Whir/WHIRNativeSecurity.lean @@ -63,8 +63,8 @@ private theorem real_union_bound [Fintype Coins] [Nonempty Coins] WHIRSourceMerkleSecurity.probability registry.publicRegistry Q (sources registry Q attackers) select whole := by classical unfold realProbability - rw [WHIRObservableSecurity.distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins)), - WHIRObservableSecurity.distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins))] + rw [FiatShamirGame.distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins)), + FiatShamirGame.distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins))] simp only [WHIRObservableSecurity.average_product (X := PrimitiveOracle) (Y := Coins)] rw [RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins), RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins)] @@ -154,7 +154,11 @@ theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] (verifyAfter cap registry Q (attackers coins)) sourceA envelope exact WHIRPhysicalBinding.nativeFailure_or_frozen registry Q cap C (attackers coins) sourceQ (whole coins) failed -/-- Deterministic BLAKE2s adds one separate primitive replacement gap for the final public native-acceptance event. No replacement assumption is made for the unobservable full-compression Merkle event, and no correctness/coverage premise is delegated to a cryptographic assumption. -/ +/-- Formal conditional deterministic-BLAKE2s inequality. The full-view primitive +replacement premise is not a standard efficient-adversary hash assumption: +`DuplexModeGame.concretePrimitiveGap_knownAnswer_lower_bound` forces a nearly +unit loss when its class contains the elementary known-answer observer. +No correctness/coverage premise is delegated to this replacement game. -/ theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] [Fintype DuplexPublicSimulator.Seed] (registry : ProductionRegistry) (Q a b Mf free : Nat) diff --git a/verification/whir/Whir/WHIRObservableSecurity.lean b/verification/whir/Whir/WHIRObservableSecurity.lean index 3e2df5c36..67e5f8fcb 100644 --- a/verification/whir/Whir/WHIRObservableSecurity.lean +++ b/verification/whir/Whir/WHIRObservableSecurity.lean @@ -51,14 +51,6 @@ theorem adversary_counted (registry : Public) (Q A Mf : Nat) (sources : Coins (WHIRSourceBackfill.counted_reachable (context registry) Q A Mf (sources coins) select (before coins) (paths coins)) envelope -theorem distinguish_average {C V : Type} {old : Fintype C} (new : Fintype C) - (experiment : C → V) (D : V → Bool) : - @distinguishProbability C V old experiment D = - @average C new (fun coin => if D (experiment coin) = true then 1 else 0) := by - classical - cases Subsingleton.elim old new - simp only [distinguishProbability,Soundness.uniformProb,average,Finset.sum_boole] - theorem average_product {X Y : Type} [Fintype X] [Fintype Y] (f : X × Y → ℚ) : average f = average (fun x => average (fun y => f (x,y))) := by classical diff --git a/verification/whir/differential/run.py b/verification/whir/differential/run.py index 8268dae7e..ec17da715 100755 --- a/verification/whir/differential/run.py +++ b/verification/whir/differential/run.py @@ -1,5 +1,5 @@ #!/usr/bin/env python3 -"""Run both implementations, compare live vectors, and require both opening smokes.""" +"""Compare fresh valid-domain Rust/Lean vectors; report production-only boundaries.""" import os import subprocess @@ -8,6 +8,10 @@ HERE = Path(__file__).resolve().parent PACKAGE = HERE.parent SCOPE = ["systemd-run", "--user", "--scope", "-q", "-p", "MemoryMax=16G", "-p", "MemorySwapMax=0"] +RUST_BASELINE = "edafd396120f453de6f75013f231bfda2049f217" +INTEGRATED_UPSTREAM = "10266a181437019400bc93d8dfbb373301ba8aa5" +PROPOSED_DUPLEX_552 = "ff6a275304a3b577118b066ddcff83bfafa5998d" +UNMERGED_SELECTOR_565 = "41c140b04eb85f5cfe12c4d238d3979af7d85fbf" ENV = dict(os.environ, CARGO_TARGET_DIR="/tmp/whir-lean-target", CARGO_BUILD_JOBS="2", LEANVM_NUM_THREADS="1", LEAN_NUM_THREADS="2") @@ -32,12 +36,18 @@ def records(text): def main(): + print("Executing checkout: " + run(["git", "rev-parse", "HEAD"]).strip(), flush=True) + print(f"Rust baseline {RUST_BASELINE}; integrated upstream {INTEGRATED_UPSTREAM}", flush=True) + print(f"PR552 proposed duplex {PROPOSED_DUPLEX_552}: NOT deployed or executed here", flush=True) + print(f"PR565 selector fix {UNMERGED_SELECTOR_565}: NOT integrated at the upstream pin", flush=True) run(["lake", "build", "whirModel"]) rust = records(run(["cargo", "+1.97", "run", "--release", "--locked", "--manifest-path", str(HERE / "Cargo.toml")])) executable = str(PACKAGE / ".lake" / "build" / "bin" / "whirModel") lean = records(run([executable], clean_stderr=True)) lean_smoke = lean.pop("lean_smoke") rust_smoke = rust.pop("rust_smoke") + transcript = rust.pop("rust_transcript") + selectors = {key: rust.pop(key) for key in list(rust) if key.startswith("rust_selector_")} query_cases = [] for key in list(rust): if key.startswith("query_input_"): @@ -57,6 +67,10 @@ def main(): print(f"PASS: {len(lean)} live arithmetic/encoding/folding/weight vectors; {len(query_cases)} production query batches {query_cases}") print("Lean ideal replay: " + lean_smoke) print("Rust production opening: " + rust_smoke) + print("Rust transcript: " + transcript + "; Lean opening replay uses supplied ideal challenges, not BLAKE2s") + print("Production malformed selectors (outside valid-shape refinement): " + repr(selectors)) + if any(value.startswith("accepted") for value in selectors.values()): + print("KNOWN GAP: current Rust accepts incorrect selector claims; PASS does not establish unrestricted stack-claim refinement.") print("Boundary: differential execution is not Rust compiler correctness or an instantiation of cryptographic assumptions.") diff --git a/verification/whir/differential/src/main.rs b/verification/whir/differential/src/main.rs index 1d7401dc2..7c1080210 100644 --- a/verification/whir/differential/src/main.rs +++ b/verification/whir/differential/src/main.rs @@ -158,11 +158,22 @@ fn production_smoke() { s_hat_v: slices, }], }]; - let claims = vec![StackClaim::Point { - offset: 0, - low_point: point.clone(), - value: mle_eval(&stack, &point), - }]; + let strided_point: Vec<_> = (0..vars - 2).map(|i| fixture(i + 90)).collect(); + let strided_values: Vec<_> = stack[..1 << (vars - 1)].iter().skip(1).step_by(2).copied().collect(); + let claims = vec![ + StackClaim::Point { + offset: 0, + low_point: point[..vars - 1].to_vec(), + value: mle_eval(&stack[..1 << (vars - 1)], &point[..vars - 1]), + }, + StackClaim::Strided { + offset: 0, + slot: 1, + stride_log: 1, + point: strided_point.clone(), + value: mle_eval(&strided_values, &strided_point), + }, + ]; let (commitment, pd) = whir::commit(&stack, log_n, config.initial_k(), 1); let label = b"whir-lean-production-smoke-fixed-statement-v1"; let mut prover = ProverState::from_label(label); @@ -171,10 +182,12 @@ fn production_smoke() { for ring in &rings { prover.add_scalars(&ring.claims[0].s_hat_v); } - prover.add_scalar(claims[0].value()); + for claim in &claims { + prover.add_scalar(claim.value()); + } stack_open::open(&mut prover, log_n, &stack, &pd, &config, &claims, &rings); let proof = prover.into_proof(); - let accepts = |proof: &ProofTranscript, lanes: usize| -> bool { + let accepts_statement = |proof: &ProofTranscript, lanes: usize, point_claims: &[StackClaim], rings: &[RingSwitch]| -> bool { let mut verifier = VerifierState::from_label(label, proof); let Ok(root) = Receiver::next_root(&mut verifier) else { return false; @@ -187,12 +200,15 @@ fn production_smoke() { return false; } } - if Receiver::next_scalar(&mut verifier).ok() != Some(claims[0].value()) { - return false; + for claim in point_claims { + if Receiver::next_scalar(&mut verifier).ok() != Some(claim.value()) { + return false; + } } - stack_open::verify(&mut verifier, &config, log_n, lanes, root, &claims, &rings).is_ok() + stack_open::verify(&mut verifier, &config, log_n, lanes, root, point_claims, rings).is_ok() && verifier.finish().is_ok() }; + let accepts = |proof: &ProofTranscript, lanes: usize| accepts_statement(proof, lanes, &claims, &rings); assert!(accepts(&proof, 1), "production honest opening rejected"); let opening_start = 2 + rings[0].claims[0].s_hat_v.len() + claims.len(); let first_ood = opening_start + 2 + 2 * config.initial_k() + 2; @@ -222,12 +238,65 @@ fn production_smoke() { bad.merkle.pop(); assert!(!accepts(&bad, 1), "production missing authentication accepted"); assert!(!accepts(&proof, 0), "production zero lanes accepted"); + // Current upstream checks range ends, but eq_at drops low offset bits and + // high slot bits. PR565 adds the missing checks; it is NOT integrated here. + // Keep these observations separate from the valid-domain Lean comparison. + for (name, index) in [("point_offset", 0), ("strided_offset", 1), ("strided_slot", 1)] { + let mut malformed = claims.clone(); + let actual = match &mut malformed[index] { + StackClaim::Point { offset, low_point, .. } => { + *offset = 1; + mle_eval(&stack[*offset..*offset + (1 << low_point.len())], low_point) + } + StackClaim::Strided { offset, slot, stride_log, point, .. } => { + if name == "strided_slot" { + *slot += 1 << *stride_log; + } else { + *offset = 1; + } + let values: Vec<_> = (0..1 << point.len()) + .map(|j| stack[*offset + *slot + (j << *stride_log)]) + .collect(); + mle_eval(&values, point) + } + }; + assert_ne!(actual, malformed[index].value(), "selector fixture did not change the mathematical claim"); + let observed = if accepts_statement(&proof, 1, &malformed, &rings) { "accepted" } else { "rejected" }; + println!("rust_selector_{name}={observed}_incorrect_claim"); + } + // Exercise checks that ARE present in current production before transcript + // reads, requiring the right error instead of an unrelated later refusal. + let empty = ProofTranscript { stream: vec![], merkle: vec![] }; + let check_shape = |point_claims: &[StackClaim], rings: &[RingSwitch]| { + let mut verifier = VerifierState::from_label(label, &empty); + stack_open::verify(&mut verifier, &config, log_n, 1, commitment.root, point_claims, rings) + }; + for index in 0..claims.len() { + let mut outside = claims.clone(); + match &mut outside[index] { + StackClaim::Point { offset, .. } | StackClaim::Strided { offset, .. } => *offset = 1 << log_n, + } + assert!(matches!(check_shape(&outside, &rings), Err(whir::WhirError::PointClaim { index: i }) if i == index)); + } + let mut bad_ring = rings.clone(); + bad_ring[0].offset = 1; + assert!(matches!(check_shape(&claims, &bad_ring), Err(whir::WhirError::Region { index: 0 }))); + let mut bad_ring = rings.clone(); + bad_ring[0].claims[0].suffix_point.pop(); + assert!(matches!(check_shape(&claims, &bad_ring), Err(whir::WhirError::Region { index: 0 }))); + assert!(matches!(check_shape(&claims, &[]), Err(whir::WhirError::NoRingClaim))); println!( - "rust_smoke=honest,ring_switch,point_claim,truncated_lanes,short_stream,trailing_stream,bad_round,bad_ood,bad_final,missing_authentication,bad_layout" + "rust_smoke=honest,ring_switch,point_claim,strided_claim,truncated_lanes,short_stream,trailing_stream,bad_round,bad_ood,bad_final,missing_authentication,bad_layout,point_outside_cube,strided_outside_cube,unaligned_ring,ring_dimension,no_ring_claim" ); } fn main() { + // These deployed APIs are removed by PR552's incompatible duplex cutover. + println!( + "rust_transcript=deployed_keyed_step,max_pending:{},squeeze_tag:{}", + fiat_shamir::MAX_PENDING, + fiat_shamir::DS_SQUEEZE.0, + ); vectors(); queries(); production_smoke(); From e631ac714e10494a62dd638e9f9a4564bd0bc8e8 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 00:50:01 +0100 Subject: [PATCH 06/28] Prove immutable-anchor binding and quantify extraction limitations --- verification/whir/Main.lean | 38 +- verification/whir/README.md | 12 + verification/whir/Whir.lean | 4 + .../whir/Whir/CommitmentAmbiguity.lean | 273 +++++++++++++++ verification/whir/Whir/CommitmentAnchor.lean | 239 +++++++++++++ .../whir/Whir/ConcreteSecurityBudget.lean | 209 +++++++++++ .../whir/Whir/KnowledgeExtraction.lean | 324 ++++++++++++++++++ 7 files changed, 1098 insertions(+), 1 deletion(-) create mode 100644 verification/whir/Whir/CommitmentAmbiguity.lean create mode 100644 verification/whir/Whir/CommitmentAnchor.lean create mode 100644 verification/whir/Whir/ConcreteSecurityBudget.lean create mode 100644 verification/whir/Whir/KnowledgeExtraction.lean diff --git a/verification/whir/Main.lean b/verification/whir/Main.lean index 9192e9d74..d569c1982 100644 --- a/verification/whir/Main.lean +++ b/verification/whir/Main.lean @@ -1,5 +1,6 @@ import Whir.Protocol import Whir.CausalGame +import Whir.CommitmentAmbiguity open Whir.Concrete Whir.Protocol @@ -56,6 +57,40 @@ def smoke : IO Unit := do "malformed public claim accepted" IO.println "lean_smoke=honest,multilevel,truncated_lanes,bad_target,short_opening,short_final,bad_final,missing_query,bad_row,bad_ood,missing_ood,missing_challenge,bad_layout,malformed_public_claim" +def ambiguitySmoke : IO Unit := do + requireIO (Whir.CommitmentAmbiguity.smallSession false).isOk + "zero branch of immutable spliced commitment rejected" + requireIO (Whir.CommitmentAmbiguity.smallSession true).isOk + "one branch of immutable spliced commitment rejected" + let c := (productionConfig 15 4).getD default + let block := 2^(c.logN-c.folds[0]!) + let mixed := tab (2^(c.logN-c.folds[0]!+c.rates[0]!)) fun q => + #[if q % 2 == 0 then E.zero else E.one] + let weight := tab (2^c.logN) fun i => if i == 0 then E.one else E.zero + for branch in #[false,true] do + let ch : Challenges := ⟨tab c.folds.size (fun i => + let n := c.logN-(c.folds.toList.take (i+1)).sum + let depth := n+c.rates[i]! + let per := 192/depth + let chunks := (c.queries[i]!+per-1)/per + let raw := if i == 0 && branch then + (List.range per).foldl (fun out j => out+2^(j*depth)) 0 else 0 + let squeeze : E := ⟨UInt64.ofNat raw, UInt64.ofNat (raw/2^64), + UInt64.ofNat (raw/2^128)⟩ + ⟨tab c.folds[i]! (fun _ => fixture (i+1)), + tab (if i+1 < c.folds.size then c.oodCounts[i+1]! else 0) + (fun _ => tab n (fun j => fixture (20+i+j))), + tab chunks (fun _ => squeeze), fixture (60+i)⟩), + tab (c.logN-c.folds.toList.sum) (fun j => fixture (80+j))⟩ + let target := if branch then E.one else E.zero + let witness := tab block fun i => if branch && i == 0 then (1 : K) else 0 + let (_, proof) ← match prove c ch witness weight target with + | .ok result => pure result + | .error e => throw (IO.userError ("production splice prover: " ++ e)) + requireIO (verify c ch 1 mixed weight target proof).isOk + "production immutable splice branch rejected" + IO.println "ambiguity_smoke=same_immutable_root,incompatible_claims,small_kernel_fixture,production_15_rate4,both_sessions_accepted" + def vectors : IO Unit := do emitN "kmul" (tab 40 fun i => (kmul (seed i) (seed (i+41))).toNat) emitN "kinv" (tab 12 fun i => (kinv (seed i)).toNat) @@ -104,5 +139,6 @@ def main (args : List String) : IO Unit := do match deriveQueries depth count squeezes with | none => throw (IO.userError "malformed query challenge vector") | some qs => emitN "queries" qs + | ["ambiguity"] => ambiguitySmoke | [] => vectors; smoke - | _ => throw (IO.userError "usage: whirModel [query DEPTH COUNT LIMB ...]") + | _ => throw (IO.userError "usage: whirModel [ambiguity | query DEPTH COUNT LIMB ...]") diff --git a/verification/whir/README.md b/verification/whir/README.md index 2cf5533ae..868081c83 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -184,3 +184,15 @@ The pinned #552 duplex evaluator matched 37 independently executed Rust state/AP Before this upstream refresh, the standalone Rust harness passed release Clippy and rustdoc with warnings denied, and its orchestration runner passed Ruff and `ty`. Those tool checks are historical, not claimed rerun in the current proof/source update. Production verifier and guest fixtures are unchanged by this proof work. The selector discrepancy has a separately proposed fix in [PR #565](https://github.com/leanEthereum/leanVM/pull/565), but that source is not integrated here. Current upstream still accepts the malformed plain/strided offsets and oversized strided slot with independently incorrect slice values; the refreshed live harness makes this visible rather than silently adopting the proposed guard. This remains a public PCS metadata-contract violation, not a demonstrated production VM proof exploit. + +## Stronger binding and extraction investigation + +`CommitmentAmbiguity` checks exact root-locality of the executable verifier, including its error result, and a valid small interactive commitment with two incompatible accepting opening sessions against the same immutable oracle. It separately checks the actual production first-query parity probability. This is an ideal causal interaction result with supplied independent challenges, not a demonstrated attack on deployed Fiat-Shamir. + +`CommitmentAnchor` defines commitment identity as the complete immutable root, shape, anchor point and advertised value. The root-fixed candidate list precedes the one fresh uniform extension-field anchor point. Supported padding is injective, and the anchor weight is truncated to the occupied lane prefix while preserving the actual padded witness MLE. Outside the point-only collision event, every malicious choice of advertised value selects at most one supported candidate simultaneously across all later sessions. The actual causal verifier checks this same anchor in every opening batch; its unique-opening failure bound conditional on an unambiguous anchor is the original opening ledger with the additional anchor claim counted. + +The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `2^-124` at the proved list cap and supported production dimensions. This is only list-selection ambiguity, not whole-system security. `ConcreteSecurityBudget` separately proves a capped `2^-42` list-binding ledger for the existing conditional public-random-compression native endpoint and demonstrates why its stated caps do not yield a `2^-43` ledger. This is neither deployed BLAKE2 security nor the composed anchored endpoint; the extra commitment-time challenge still needs its Fiat-Shamir and concrete cryptographic composition. + +`KnowledgeExtraction` defines executable bounded rewind access and the actual acceptance-plus-extraction-failure experiment. Its checked record-only sparse-decoder impossibility result and exact reconstruction threshold concern the actual additive encoder. It does not provide an efficient successful knowledge extractor or a knowledge soundness theorem. Mathematical classical choice in the anchored binding selector is explicitly not an extractor. + +The authorized production anchor cutover is developed on a separate upstream-based branch, not silently substituted for this proof-only draft's source pin. It merges the separate source-only Aeneas scope/ordered-loop refactor, which does not establish Rust-to-Lean equivalence. The existing malformed selector discrepancy and unproved full concrete compression replacement remain explicit limitations. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index e1275db3c..19d941ec2 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -33,6 +33,10 @@ import Whir.CausalStrategy import Whir.CausalTerminal import Whir.CodingBounds import Whir.ConcreteCandidates +import Whir.CommitmentAmbiguity +import Whir.CommitmentAnchor +import Whir.ConcreteSecurityBudget +import Whir.KnowledgeExtraction import Whir.DuplexCompression import Whir.DuplexEncoding import Whir.DuplexFraming diff --git a/verification/whir/Whir/CommitmentAmbiguity.lean b/verification/whir/Whir/CommitmentAmbiguity.lean new file mode 100644 index 000000000..795a0625f --- /dev/null +++ b/verification/whir/Whir/CommitmentAmbiguity.lean @@ -0,0 +1,273 @@ +import Whir.OperationalRefinement +import Whir.SamplingProbability +import Whir.AdditiveColumn +import Whir.CausalGame + +namespace Whir.CommitmentAmbiguity +open Concrete Protocol +private theorem except_pure {S : Type} (s : S) : + (pure s : Except String S) = .ok s := rfl + +private theorem except_bind_ok {S T : Type} (s : S) (f : S → Except String T) : + (Except.ok s >>= f) = f s := rfl + + +/-- Changing an oracle does not affect any sumcheck fold, including malformed +messages. The oracle is consulted only by authentication. -/ +theorem folds_change_oracle (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (count start : Nat) (s : CheckedState) (root : Oracle) : + runSteps (foldStep block cs p) count start {s with oracle := root} = + {runSteps (foldStep block cs p) count start s with oracle := root} := by + induction count generalizing start s with + | zero => rfl + | succ count ih => + simp only [runSteps, foldStep] + exact ih (start+1) (foldStep block cs p start s) + +private theorem checked_congr {S : Type} (f g : Nat → S → Except String S) + (count start : Nat) (s : S) + (same : ∀ j, start ≤ j → j < start+count → ∀ t, f j t = g j t) : + runChecked f count start s = runChecked g count start s := by + induction count generalizing start s with + | zero => rfl + | succ count ih => + simp only [runChecked, same start (by omega) (by omega)] + congr 1 + funext t + exact ih (start+1) t (by intro j lo hi u; exact same j (by omega) (by omega) u) + +/-- Exact authentication result, not just acceptance, depends only on queried +rows. This includes duplicate queries and error-short-circuit behavior. -/ +theorem authentication_local (left right : Oracle) (qs : Array Nat) (p : LevelProof) + (same : ∀ j, j < qs.size → left[qs[j]!]! = right[qs[j]!]!) : + runChecked (authenticateRow left qs p) qs.size 0 () = + runChecked (authenticateRow right qs p) qs.size 0 () := by + apply checked_congr + intro j _ hi u + simp only [authenticateRow, same j (by omega)] + +/-- After the first query authentication, the verifier discards the initial +oracle. Later OOD values bind later commitments, not unqueried initial rows. -/ +theorem level_local (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (s : CheckedState) (root : Oracle) (qs : Array Nat) + (sampled : deriveQueries + ((foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! s).n + c.rates[i]!) + c.queries[i]! ch.levels[i]!.querySqueezes = some qs) + (same : ∀ j, j < qs.size → s.oracle[qs[j]!]! = root[qs[j]!]!) : + verifyLevel c ch proof i s = verifyLevel c ch proof i {s with oracle := root} := by + have folded : foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! {s with oracle := root} = + {foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! s with oracle := root} := + folds_change_oracle _ _ _ _ _ _ _ + have auth := authentication_local s.oracle root qs proof.levels[i]! same + unfold verifyLevel + dsimp only + simp only [folded, sampled, Option.elim_some] + have ho : (foldBlock (if i == 0 then 2^(c.logN-c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! s).oracle = s.oracle := by + apply OperationalRefinement.runSteps_invariant + (foldStep _ _ _) (fun _ t => t.oracle = s.oracle) _ _ s rfl + intro j t _ _ ht + exact ht + simp only [ho, except_pure, except_bind_ok, auth] + +/-- Full untrusted-verifier locality, with exactly its original rejection/error +result. No honesty assumption is imposed on the supplied opening. -/ +theorem verify_local (c : Config) (ch : Challenges) (lanes : Nat) + (left right : Oracle) (weight : Array E) (target : E) (proof : Opening) + (nonempty : 0 < c.folds.size) + (leftShape : oracleValid left (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes = true) + (rightShape : oracleValid right (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes = true) + (qs : Array Nat) + (sampled : deriveQueries + ((foldBlock (2^(c.logN-c.folds[0]!)) ch.levels[0]! proof.levels[0]! + ⟨c.logN, ⟨weight,target,proof.initial⟩,left⟩).n + c.rates[0]!) + c.queries[0]! ch.levels[0]!.querySqueezes = some qs) + (same : ∀ j, j < qs.size → left[qs[j]!]! = right[qs[j]!]!) : + verify c ch lanes left weight target proof = verify c ch lanes right weight target proof := by + have first := level_local c ch proof 0 + ⟨c.logN, ⟨weight,target,proof.initial⟩,left⟩ right qs (by simpa using sampled) same + obtain ⟨count, hc⟩ := Nat.exists_eq_succ_of_ne_zero (Nat.ne_of_gt nonempty) + simp only [verify, initializeVerifier, leftShape, rightShape, Bool.not_true, + Bool.false_eq_true, ↓reduceIte] + split + · rfl + · split + · rfl + · simp only [replayLevels, hc, runChecked, except_pure, except_bind_ok] + rw [first] + +/-- A spliced immutable commitment may support separate sessions using different +honest continuations. This theorem states the exact verifier mechanism; it does +not mistake a commitment-time list for one binding witness. -/ +theorem splice_accepts (c : Config) (ch : Challenges) (lanes : Nat) + (honest mixed : Oracle) (weight : Array E) (target : E) (proof : Opening) + (nonempty : 0 < c.folds.size) + (honestShape : oracleValid honest (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes = true) + (mixedShape : oracleValid mixed (2^(c.logN-c.folds[0]!+c.rates[0]!)) lanes = true) + (qs : Array Nat) + (sampled : deriveQueries + ((foldBlock (2^(c.logN-c.folds[0]!)) ch.levels[0]! proof.levels[0]! + ⟨c.logN, ⟨weight,target,proof.initial⟩,honest⟩).n + c.rates[0]!) + c.queries[0]! ch.levels[0]!.querySqueezes = some qs) + (same : ∀ j, j < qs.size → honest[qs[j]!]! = mixed[qs[j]!]!) + (accepted : verify c ch lanes honest weight target proof = .ok ()) : + verify c ch lanes mixed weight target proof = .ok () := by + rw [← verify_local c ch lanes honest mixed weight target proof nonempty + honestShape mixedShape qs sampled same] + exact accepted + +/-- Small valid schedule for a fully kernel-evaluated counterexample. Production +profiles are analyzed separately; this is not a production probability claim. -/ +def smallConfig : Config := ⟨3, #[1,1], #[1,1], #[1,1], #[0,1]⟩ + +def smallWeight : Array E := #[E.one,E.zero,E.zero,E.zero,E.zero,E.zero,E.zero,E.zero] + +def smallRoot : Oracle := + #[#[E.zero],#[E.one],#[E.zero],#[E.one],#[E.zero],#[E.one],#[E.zero],#[E.one]] + +def smallChallenges (branch : Bool) : Challenges := + ⟨#[⟨#[E.zero], #[#[E.zero,E.zero]], #[if branch then E.one else E.zero], E.one⟩, + ⟨#[E.zero], #[], #[E.zero], E.one⟩], #[E.zero]⟩ + +def smallProof (branch : Bool) : Opening := + let t := if branch then E.one else E.zero + ⟨⟨t,t⟩, + #[⟨#[⟨t,t⟩], some #[#[t,E.zero],#[t,E.zero],#[t,E.zero],#[t,E.zero]], + #[⟨t,⟨t,t⟩⟩], #[#[t]], ⟨t,if branch then E.zero else t⟩⟩, + ⟨#[⟨t,t⟩], none, #[], #[#[t,E.zero]], ⟨t,t⟩⟩], + #[t,E.zero], #[]⟩ + +def smallSession (branch : Bool) : Except String Unit := + verify smallConfig (smallChallenges branch) 1 smallRoot smallWeight + (if branch then E.one else E.zero) (smallProof branch) + +private theorem kmul_zero (a : K) : kmul a 0 = 0 := by + apply FieldModel.toBaseQuotient_injective + simp [FieldModel.toBaseQuotient_kmul] + +private theorem zero_kmul (a : K) : kmul 0 a = 0 := by + apply FieldModel.toBaseQuotient_injective + simp [FieldModel.toBaseQuotient_kmul] + +private theorem one_kmul (a : K) : kmul 1 a = a := by + apply FieldModel.toBaseQuotient_injective + simp [FieldModel.toBaseQuotient_kmul] + +private theorem kmul_one (a : K) : kmul a 1 = a := by + apply FieldModel.toBaseQuotient_injective + simp [FieldModel.toBaseQuotient_kmul] + +private theorem kinv_one : kinv 1 = 1 := by + apply FieldModel.toBaseQuotient_injective + simp [FieldModel.toBaseQuotient_kinv] + +private theorem small_columns : + column 1 0 = #[E.one,E.zero] ∧ + column 2 0 = #[E.one,E.zero,E.zero,E.zero] ∧ + column 2 1 = #[E.one,E.one,E.zero,E.zero] := by + simp [column, normalizedSubspaces, subspaceRoots, tab, kmul_zero, zero_kmul, + kmul_one, kinv_one, E.scale, E.one, E.zero, + Std.Legacy.Range.forIn_eq_forIn_range', List.range', + Array.forIn_pure_yield_eq_foldl] + +private theorem column10 : column 1 0 = #[E.one,E.zero] := small_columns.1 +private theorem column20 : column 2 0 = #[E.one,E.zero,E.zero,E.zero] := small_columns.2.1 +private theorem column21 : column 2 1 = #[E.one,E.one,E.zero,E.zero] := small_columns.2.2 + +attribute [local cbv_opaque] column +attribute [local cbv_eval] column10 column20 column21 kmul_zero zero_kmul one_kmul kmul_one + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Two incompatible values of one public linear functional open against exactly +the same malicious immutable commitment, in two separate valid sessions. No +collision, mutable oracle, honest-root premise, or correctness axiom is used. -/ +theorem small_two_sessions : + smallConfig.valid = true ∧ + smallSession false = .ok () ∧ smallSession true = .ok () := by + cbv + +/-- The two accepted claims cannot be explained by any one witness. This rules +out zero-error uniqueness, not a specified probabilistic production bound. -/ +theorem small_claims_incompatible : + ¬ ∃ w : CausalGame.Witness smallConfig 1, + dot (CausalGame.paddedWitness smallConfig 1 w) smallWeight = E.zero ∧ + dot (CausalGame.paddedWitness smallConfig 1 w) smallWeight = E.one := by + rintro ⟨w,h0,h1⟩ + have bad : E.zero = E.one := h0.symm.trans h1 + have different : E.zero ≠ E.one := by decide + exact different bad + +private def parityEquiv (m : Nat) (b : Fin 2) : + {x : Fin (2*m) // x.val % 2 = b.val} ≃ Fin m where + toFun x := ⟨x.val.val / 2, by have h := x.val.isLt; omega⟩ + invFun y := ⟨⟨2*y.val+b.val, by have h := y.isLt; have hb := b.isLt; omega⟩, + by simp [Nat.add_mod, Nat.mod_eq_of_lt b.isLt]⟩ + left_inv x := by + apply Subtype.ext + apply Fin.ext + have h := Nat.mod_add_div x.val.val 2 + have hp := x.property + dsimp + omega + right_inv y := by + apply Fin.ext + have hb := b.isLt + dsimp + omega + +private theorem raw_parity_probability (b : Fin 2) : + SamplingProbability.probability (fun raw : Fin (2^13) => raw.val % 2 = b.val) = + (1/2 : ℝ) := by + classical + unfold SamplingProbability.probability + dsimp only + have hc : Fintype.card {raw : Fin (2^13) // raw.val % 2 = b.val} = 4096 := by + exact (Fintype.card_congr (parityEquiv 4096 b)).trans (by simp) + simp only [← Nat.card_eq_fintype_card] at hc ⊢ + rw [hc] + norm_num + +set_option maxRecDepth 100000 in +private theorem first_stratum_bits : + ∀ i : Fin 56, (strata 56 13)[i.val]!.1 ≤ 5 := by + decide +kernel + +/-- Production top-bit replacement preserves the low bit in each of its 56 +strata. A global-half splice would fail under stratification; a parity splice +does not. This is about the actual sampler, not an iid substitute. -/ +theorem first_place_parity (i : Fin 56) (raw : Nat) : + SamplingProbability.concretePlace 56 13 i.val raw % 2 = raw % 2 := by + have hb := first_stratum_bits i + have hd : 2 ∣ 2^(13-(strata 56 13)[i.val]!.1) := + dvd_pow_self 2 (by omega) + unfold SamplingProbability.concretePlace + rw [Nat.add_mod, Nat.mul_mod, Nat.mod_eq_zero_of_dvd hd, + Nat.mod_mod_of_dvd raw hd] + simp + +open scoped BigOperators in +/-- For the smallest rate-4 production profile, either parity branch contains +every first-level query with exact probability 2^-56. It is a sampler theorem; +the full-verifier bridge is `splice_accepts`, and grinding is not credited. -/ +theorem production_first_queries_one_parity (b : Fin 2) : + SamplingProbability.probability + (fun t : Fin ((56 + 192/13 - 1)/(192/13)) → E => + ∃ qs, deriveQueries 13 56 (Array.ofFn t) = some qs ∧ + ∀ i : Fin 56, qs[i.val]! % 2 = b.val) = (1/2 : ℝ)^56 := by + rw [SamplingProbability.deriveQueries_probability 13 56 (by decide) (by decide) + (fun _ q => q % 2 = b.val)] + simp only [first_place_parity, raw_parity_probability, Finset.prod_const, + Finset.card_univ, Fintype.card_fin] + +set_option maxRecDepth 100000 in +/-- The sampler parameters above are read from the actual production generator. -/ +theorem production_first_profile : + let c := (productionConfig 15 4).getD default + c.logN - c.folds[0]! + c.rates[0]! = 13 ∧ c.queries[0]! = 56 := by + decide +kernel + +end Whir.CommitmentAmbiguity diff --git a/verification/whir/Whir/CommitmentAnchor.lean b/verification/whir/Whir/CommitmentAnchor.lean new file mode 100644 index 000000000..d6bcf5fa6 --- /dev/null +++ b/verification/whir/Whir/CommitmentAnchor.lean @@ -0,0 +1,239 @@ +import Whir.InteractiveSoundness +import Whir.ExecutableOOD + +namespace Whir.CommitmentAnchor +open Concrete Protocol CausalGame ParameterBounds +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +/-- Identity is the entire immutable record, not its Merkle root alone. The +anchor point is sampled once after this root/shape and before its value and any +opening statements. Every session reuses the same point and value. This ideal +record does not claim that the deployed keyed transcript realizes that game. -/ +structure Commitment (p : Profile) where + lanes : Nat + root : BaseOracle + point : Fin (config p).logN → E + value : E + occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]! + +/-- The anchor's public linear weight has exactly the occupied-lane support. +Missing zero-tail coefficients are not treated as alternative witnesses. -/ +def weight (c : Config) (lanes : Nat) (point : Array E) : Array E := + tab (2^c.logN) fun i => + if i < lanes*2^(c.logN-c.folds[0]!) then (eqTable point)[i]! else E.zero + +def value (c : Config) (lanes : Nat) (w : Witness c lanes) (point : Array E) : E := + Concrete.mle (paddedWitness c lanes w) point + +/-- Zero-tail truncation preserves the claimed MLE on an actual supported +witness. This is the linear claim every later session must additionally check; +using a full-cube weight would violate the existing occupied-lane guards. -/ +theorem weight_value (c : Config) (lanes : Nat) (w : Witness c lanes) + (point : Array E) (point_size : point.size = c.logN) : + dot (paddedWitness c lanes w) (weight c lanes point) = value c lanes w point := by + classical + simp only [value, Concrete.mle, ArrayAlgebra.dot_eq_sum, weight, + ArrayLayout.size_tab, TerminalRefinement.size_eqTable, point_size, + paddedWitness, ArrayLayout.size_tab, min_self] + apply Finset.sum_congr rfl + intro i hi + have hif : i < 2^c.logN := Finset.mem_range.mp hi + simp only [ArrayLayout.getElem!_tab _ _ _ hif] + by_cases occupied : i < lanes*2^(c.logN-c.folds[0]!) + · simp only [occupied, ite_eq_left] + · have outside : ¬ i < (Array.ofFn w).size := by + simpa only [Array.size_ofFn, Fintype.card_fin] using occupied + simp [occupied] + +def claim (p : Profile) (commitment : Commitment p) : Claim := + ⟨weight (config p) commitment.lanes (Array.ofFn commitment.point), commitment.value⟩ + +def claims (p : Profile) (commitment : Commitment p) (opening : Array Claim) : Array Claim := + opening.push (claim p commitment) + +def input (p : Profile) (commitment : Commitment p) (opening : Array Claim) : Public := + ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening) + +/-- Candidate list is fixed solely by the original root and shape, before the +anchor point or malicious choice of its advertised value. -/ +noncomputable def selected (p : Profile) (lanes : Nat) (root : BaseOracle) + (point : Fin (config p).logN → E) (v : E) : Finset (Witness (config p) lanes) := by + classical + exact (InitialCandidates.witnesses (config p) lanes root).filter + (fun w => value (config p) lanes w (Array.ofFn point) = v) + +noncomputable def Ambiguous (p : Profile) (lanes : Nat) (root : BaseOracle) + (point : Fin (config p).logN → E) : Prop := + ∃ a ∈ InitialCandidates.witnesses (config p) lanes root, + ∃ b ∈ InitialCandidates.witnesses (config p) lanes root, a ≠ b ∧ + value (config p) lanes a (Array.ofFn point) = + value (config p) lanes b (Array.ofFn point) + +/-- Supported padding is injective. Only literal occupied base words are +witnesses; arbitrary differences in the mandated zero tail are excluded. -/ +theorem padded_injective (c : Config) (lanes : Nat) + (fits : lanes*2^(c.logN-c.folds[0]!) ≤ 2^c.logN) : + Function.Injective (paddedWitness c lanes) := by + intro a b same + funext i + apply FieldModel.ofK_injective + have hi : i.val < 2^c.logN := lt_of_lt_of_le i.isLt fits + have he := congrArg (fun xs : Array E => xs[i.val]!) same + simpa [paddedWitness, tab, getElem!_pos, i.isLt, hi] using he + +/-- Outside the point-only ambiguity event, EVERY advertised anchor value, +including one chosen maliciously after seeing the point, selects at most one +root-fixed candidate. This quantifier is simultaneous over all later sessions. -/ +theorem selected_unique (p : Profile) (lanes : Nat) (root : BaseOracle) + (point : Fin (config p).logN → E) (clean : ¬ Ambiguous p lanes root point) + (v : E) : (selected p lanes root point v).card ≤ 1 := by + classical + apply Finset.card_le_one.mpr + intro a ha b hb + obtain ⟨ha,hav⟩ := Finset.mem_filter.mp ha + obtain ⟨hb,hbv⟩ := Finset.mem_filter.mp hb + by_contra different + exact clean ⟨a,ha,b,hb,different,hav.trans hbv.symm⟩ + +/-- Cross-session uniqueness for a single immutable anchored commitment. Claims +and strategies can differ between sessions; satisfying the same anchor forces +the same supported root candidate. No honest-commitment premise is present. -/ +theorem cross_session (p : Profile) (commitment : Commitment p) + (clean : ¬ Ambiguous p commitment.lanes commitment.root commitment.point) + (a b : Witness (config p) commitment.lanes) + (ha : a ∈ selected p commitment.lanes commitment.root commitment.point commitment.value) + (hb : b ∈ selected p commitment.lanes commitment.root commitment.point commitment.value) : a = b := + Finset.card_le_one.mp (selected_unique p _ _ _ clean _) a ha b hb + +/-- A binding selector fixed before any opening statements or session strategy. +This uses classical choice for a mathematical binding definition, NOT an +algorithm or a claimed knowledge extractor. -/ +noncomputable def boundWitness (p : Profile) (commitment : Commitment p) : + Option (Witness (config p) commitment.lanes) := + if h : ∃ w, w ∈ selected p commitment.lanes commitment.root commitment.point commitment.value + then some h.choose else none + +theorem boundWitness_eq (p : Profile) (commitment : Commitment p) + (clean : ¬ Ambiguous p commitment.lanes commitment.root commitment.point) + (w : Witness (config p) commitment.lanes) + (hw : w ∈ selected p commitment.lanes commitment.root commitment.point commitment.value) : + boundWitness p commitment = some w := by + have hasCandidate : ∃ w, w ∈ selected p commitment.lanes commitment.root commitment.point commitment.value := ⟨w,hw⟩ + rw [boundWitness, dite_eq_left hasCandidate] + exact congrArg some (cross_session p commitment clean _ _ hasCandidate.choose_spec hw) + +/-- Every later actual causal verifier session additionally checks the same +immutable anchor. Off the anchor collision event, accepted claims contradicting +the one commitment-fixed witness have only the existing opening error, including +the additional anchor in the initial random batch. -/ +theorem unique_opening_probability (p : Profile) (commitment : Commitment p) + (clean : ¬ Ambiguous p commitment.lanes commitment.root commitment.point) + (opening : Array Claim) (strategy : Strategy) : + Soundness.uniformProb (Finset.univ.filter fun tape : Tape (config p) => + experiment (ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening)) strategy tape = true ∧ + ¬ ∃ w, boundWitness p commitment = some w ∧ + ∀ c ∈ opening.toList, dot (paddedWitness (config p) commitment.lanes w) c.weight = c.value) ≤ + GroupedChallenges.interactiveError (config p) (estimates (config p)) (opening.size+1) := by + classical + have bound := InteractiveSoundness.opening_probability p commitment.lanes commitment.root + (claims p commitment opening) strategy + have subset : (Finset.univ.filter fun tape : Tape (config p) => + experiment (ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening)) strategy tape = true ∧ + ¬ ∃ w, boundWitness p commitment = some w ∧ + ∀ c ∈ opening.toList, dot (paddedWitness (config p) commitment.lanes w) c.weight = c.value) ⊆ + Finset.univ.filter fun tape : Tape (config p) => + experiment (ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening)) strategy tape = true ∧ + ¬ ∃ w ∈ InitialCandidates.witnesses (config p) commitment.lanes commitment.root, + ∀ c ∈ (claims p commitment opening).toList, + dot (paddedWitness (config p) commitment.lanes w) c.weight = c.value := by + intro tape + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rintro ⟨accepted,contradicts⟩ + constructor + · exact accepted + rintro ⟨w,hw,allClaims⟩ + have anchor := allClaims (claim p commitment) + (by simp [claims]) + have selected : w ∈ selected p commitment.lanes commitment.root commitment.point commitment.value := by + apply Finset.mem_filter.mpr + refine ⟨hw,?_⟩ + simpa only [claim, weight_value, Array.size_ofFn, Fintype.card_fin] using anchor + apply contradicts + exact ⟨w,boundWitness_eq p commitment clean w selected,fun c hc => + allClaims c (by simp only [claims, Array.toList_push, List.mem_append, List.mem_singleton]; exact Or.inl hc)⟩ + apply le_trans ?_ (by simpa only [claims, Array.size_push] using bound) + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast (Finset.card_le_card subset) + +set_option maxRecDepth 100000 in +private theorem production_size : ∀ p : Profile, + (config p).logN ≤ 28 ∧ + 2^(config p).folds[0]! * 2^((config p).logN-(config p).folds[0]!) = + 2^(config p).logN := by + decide +kernel + +/-- Exact anchor ambiguity term for the actual commitment-fixed supported list. +The point is genuinely independent uniform E randomness after the root/shape; +this theorem is not a Fiat--Shamir or whole-PCS security bound. -/ +theorem ambiguity_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : lanes ≤ 2^(config p).folds[0]!) : + Soundness.uniformProb (Finset.univ.filter fun point : Fin (config p).logN → E => + Ambiguous p lanes root point) ≤ + ((InitialCandidates.witnesses (config p) lanes root).card.choose 2 : ℚ) * + ((config p).logN : ℚ) / 2^192 := by + classical + let candidates := InitialCandidates.witnesses (config p) lanes root + let arrays := candidates.image (paddedWitness (config p) lanes) + have fits : lanes*2^((config p).logN-(config p).folds[0]!) ≤ 2^(config p).logN := by + calc + _ ≤ 2^(config p).folds[0]! * 2^((config p).logN-(config p).folds[0]!) := + Nat.mul_le_mul_right _ occupied + _ = _ := (production_size p).2 + have inj := padded_injective (config p) lanes fits + have sz : ∀ a ∈ arrays, a.size = 2^(config p).logN := by + intro a ha + obtain ⟨w,_,rfl⟩ := Finset.mem_image.mp ha + simp [paddedWitness, tab] + have bound := ExecutableOOD.candidate_separation arrays sz + have event : ∀ point, + Ambiguous p lanes root point ↔ + ∃ a ∈ arrays, ∃ b ∈ arrays, a ≠ b ∧ + Concrete.mle a (Array.ofFn point) = Concrete.mle b (Array.ofFn point) := by + intro point + constructor + · rintro ⟨a,ha,b,hb,different,same⟩ + exact ⟨_,Finset.mem_image.mpr ⟨a,ha,rfl⟩, + _,Finset.mem_image.mpr ⟨b,hb,rfl⟩,fun e => different (inj e),same⟩ + · rintro ⟨a,ha,b,hb,different,same⟩ + obtain ⟨wa,hwa,rfl⟩ := Finset.mem_image.mp ha + obtain ⟨wb,hwb,rfl⟩ := Finset.mem_image.mp hb + exact ⟨wa,hwa,wb,hwb,fun e => different (congrArg _ e),same⟩ + simp_rw [← event] at bound + rw [Finset.card_image_of_injective _ inj, FieldModel.card_E] at bound + simpa only [candidates, mul_div_assoc, Nat.cast_pow, Nat.cast_ofNat] using bound + +/-- One anchor costs at most 2^-124 of list-selection ambiguity at the proved +2^32 list cap and dimension at most 28. Opening, adaptation, Merkle, FS and +concrete cryptographic terms are separate and must still be composed. -/ +theorem ambiguity_probability_numeric (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : lanes ≤ 2^(config p).folds[0]!) : + Soundness.uniformProb (Finset.univ.filter fun point : Fin (config p).logN → E => + Ambiguous p lanes root point) ≤ (1 : ℚ)/2^124 := by + classical + apply (ambiguity_probability p lanes root occupied).trans + have cards := InitialCandidates.production_witnesses_card p lanes root + have dims := (production_size p).1 + have num : ((InitialCandidates.witnesses (config p) lanes root).card.choose 2 : ℚ) * + ((config p).logN : ℚ) ≤ ((2^32 : Nat).choose 2 : ℚ)*28 := by + apply mul_le_mul + · exact_mod_cast Nat.choose_le_choose 2 cards + · exact_mod_cast dims + · exact Nat.cast_nonneg _ + · exact Nat.cast_nonneg _ + apply (div_le_div_of_nonneg_right num (by positivity)).trans + norm_num [Nat.choose_two_right] + +end Whir.CommitmentAnchor diff --git a/verification/whir/Whir/ConcreteSecurityBudget.lean b/verification/whir/Whir/ConcreteSecurityBudget.lean new file mode 100644 index 000000000..2dde19725 --- /dev/null +++ b/verification/whir/Whir/ConcreteSecurityBudget.lean @@ -0,0 +1,209 @@ +import Whir.WHIRNativeSecurity + +/-! Conditional, unground budget for the proposed #552 public-duplex model. + +The grouped-message `2^-79` term already includes the production Johnson list +of up to `2^32` candidates; the endpoint is adaptive list binding, not unique +binding or knowledge extraction. We charge the actual ring-switching term, +caller/WHIR allocation count, source attempts, DMV, and ordinary Merkle loss. +No proof-of-work multiplier is supplied by this endpoint. + +The illustrative caps permit a million attacker-plus-verifier source units, +65536 caller output blocks, `2^32` frozen family entries, a million free root +announcements, and `2^60` total metered public-compression units. The latter +is deliberately generous: the actual envelope is +`A + A*(pathFactor*A) + pathFactor*Mf`. The checked sufficient envelope below +allows `pathFactor ≤ 2^19` and `Mf ≤ 2^32`. These +are finite-experiment query/resource restrictions, NOT wall-clock bounds, +compiler safety, or assertions that every production input satisfies them. +The reachable verifier/path and actual envelope hypotheses are retained. + +The resulting checked probability bound is `2^-42`, not `2^-128`. The actual +`PublicRandomCompressionDMV` hypothesis remains unproved; no deterministic +BLAKE2s or deployed keyed-transcript security conclusion follows. -/ +namespace Whir.ConcreteSecurityBudget +open FiatShamirGame DuplexModeGame WHIRPhysicalDriver WHIRSourceChronology +open RawOracleCoupling.Concrete TypedOracleCompiler + +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 + +/-- Caps apply to different resources: frozen family size is not caller-output +fanout, and source units are not all physically executed compression calls. -/ +structure Caps (registry : ProductionRegistry) (Q A cap free : Nat) : Prop where + nonzero : 1 ≤ Q + compression : Q ≤ 2^60 + source : A ≤ 2^20 + caller : registry.callerOutputCap ≤ 2^16 + family : cap ≤ 2^32 + roots : free ≤ 2^20 + +/-- A sufficient, non-circular accounting envelope at the chosen compression +cap. `pathFactor` is the actual caller-output/packet-completion fanout, not +a new security parameter; this lemma does not assume valid inputs have it. -/ +theorem backfill_envelope_le (ctx : RawWHIRKeys.Context) (A Mf : Nat) + (source : A ≤ 2^20) (fanout : WHIRPublicBackfill.pathFactor ctx ≤ 2^19) + (path : Mf ≤ 2^32) : + WHIRSourceBackfill.budget ctx A Mf ≤ 2^60 := by + have h : WHIRSourceBackfill.budget ctx A Mf ≤ + 2^20 + (2^20*(2^19*2^20) + 2^19*2^32) := by + unfold WHIRSourceBackfill.budget + gcongr + exact h.trans (by norm_num) + +/-- This is the existing native endpoint's RHS, not a second soundness ledger. -/ +def endpointLoss (registry : ProductionRegistry) (Q A cap free : Nat) : ℚ := + WHIRObservableSecurity.romBound registry.publicRegistry A cap + dmvLoss Q + + WHIRSourceMerkleSecurity.loss Q free + +/-- Nonnegativity of the actual endpoint, needed to diagnose its concrete +full-view replacement rather than claiming a PCS attack. -/ +theorem endpointLoss_nonneg (registry : ProductionRegistry) (Q A cap free : Nat) + (nonzero : 1 ≤ Q) : 0 ≤ endpointLoss registry Q A cap free := by + have eps := WHIRRawROM.epsilon_nonneg cap + have hQone : (1 : ℚ) ≤ Q := by exact_mod_cast nonzero + have hsub : (0 : ℚ) ≤ Q-1 := sub_nonneg.mpr hQone + unfold endpointLoss WHIRObservableSecurity.romBound dmvLoss + WHIRSourceMerkleSecurity.loss PublicMerkleProbability.bound + positivity + +/-- Both maxima are computed from the actual 56 production schedules. -/ +theorem schedule_depths : RawWHIRKeys.maxDepth = 40 ∧ + WHIRSourceRootPolicy.productionDepth = 40 := by + decide +kernel + +/-- Full rational expression obtained by unfolding the existing endpoint. +The source-attempt factor is `A+1`, not a proof-of-work improvement. -/ +theorem endpointLoss_eq (registry : ProductionRegistry) (Q A cap free : Nat) : + endpointLoss registry Q A cap free = + min 1 ((((40 + registry.callerOutputCap) * (A+1) : Nat) : ℚ) * + ((1 : ℚ)/2^79 + WHIRFiatShamir.ringCharge cap)) + + min 1 ((Q.choose 2 : ℚ) / (2^256 : ℚ)) + + ((Q : ℚ) * ((Q+1) * (free+(Q+1)*41) : Nat) + 2*Q*(Q-1)) / 2^256 := by + simp only [endpointLoss, WHIRObservableSecurity.romBound, + allocationBudget, WHIRCallerRegistry.context, ProductionRegistry.publicRegistry, + schedule_depths.1, WHIRRawROM.epsilon, dmvLoss, WHIRSourceMerkleSecurity.loss, + WHIRSourceMerkleSecurity.rootBudget, PublicMerkleProbability.bound, schedule_depths.2] + +/-- The family cap's actual list/ring-switching contribution is much smaller +than `2^-79`; the existing `2^32` list factor is not silently discarded. -/ +theorem ringCharge_at_cap : + WHIRFiatShamir.ringCharge (2^32) = (2 : ℚ)/2^128 - 1/2^160 := by + norm_num [WHIRFiatShamir.ringCharge] + +/-- At the caller/source caps, the actual ROM term already exceeds `2^-43`. +Thus 42 is the strongest integral bit bound obtained uniformly from this +ledger at these caps; this is NOT a lower bound on attacker success. -/ +theorem capped_rom_exceeds_43 (registry : ProductionRegistry) + (caller : registry.callerOutputCap = 2^16) : + (1 : ℚ)/2^43 < + WHIRObservableSecurity.romBound registry.publicRegistry (2^20) (2^32) := by + simp only [WHIRObservableSecurity.romBound, allocationBudget, + WHIRCallerRegistry.context, ProductionRegistry.publicRegistry, schedule_depths.1, caller] + norm_num [WHIRRawROM.epsilon, WHIRFiatShamir.ringCharge] + +/-- Instantiates all three terms of the native endpoint under the stated caps. -/ +theorem endpointLoss_le (registry : ProductionRegistry) (Q A cap free : Nat) + (caps : Caps registry Q A cap free) : + endpointLoss registry Q A cap free ≤ (1 : ℚ)/2^42 := by + have allocation : allocationBudget registry.context * (A+1) ≤ + (40+2^16)*(2^20+1) := by + simp only [allocationBudget, ProductionRegistry.context, WHIRCallerRegistry.context, + ProductionRegistry.publicRegistry, schedule_depths.1] + exact Nat.mul_le_mul (Nat.add_le_add_left caps.caller 40) + (Nat.add_le_add_right caps.source 1) + have eps : WHIRRawROM.epsilon cap ≤ WHIRRawROM.epsilon (2^32) := + add_le_add_right (WHIRFiatShamir.ringCharge_mono caps.family) _ + have rom : WHIRObservableSecurity.romBound registry.publicRegistry A cap ≤ + (((40+2^16)*(2^20+1) : Nat) : ℚ) * WHIRRawROM.epsilon (2^32) := by + apply (min_le_right _ _).trans + apply mul_le_mul + · exact_mod_cast allocation + · exact eps + · exact WHIRRawROM.epsilon_nonneg cap + · positivity + have dmv : dmvLoss Q ≤ ((2^60 : Nat).choose 2 : ℚ) / 2^256 := by + apply (min_le_right _ _).trans + exact div_le_div_of_nonneg_right + (by exact_mod_cast Nat.choose_le_choose 2 caps.compression) (by positivity) + have roots : WHIRSourceMerkleSecurity.rootBudget Q free ≤ + (2^60+1)*(2^20+(2^60+1)*41) := by + unfold WHIRSourceMerkleSecurity.rootBudget + rw [schedule_depths.2] + gcongr + · exact caps.compression + · exact caps.roots + · exact caps.compression + have hQ : (Q : ℚ) ≤ (2^60 : ℚ) := by exact_mod_cast caps.compression + have hQone : (1 : ℚ) ≤ Q := by exact_mod_cast caps.nonzero + have merkle : WHIRSourceMerkleSecurity.loss Q free ≤ + (((2^60 : ℚ) * ((2^60+1)*(2^20+(2^60+1)*41) : Nat)) + + 2*(2^60)*(2^60-1)) / 2^256 := by + unfold WHIRSourceMerkleSecurity.loss PublicMerkleProbability.bound + apply div_le_div_of_nonneg_right _ (by positivity) + apply add_le_add + · exact mul_le_mul hQ (by exact_mod_cast roots) (by positivity) (by positivity) + · gcongr + have total := add_le_add (add_le_add rom dmv) merkle + apply total.trans + norm_num [WHIRRawROM.epsilon, WHIRFiatShamir.ringCharge, Nat.choose_two_right] + +/-- Actual native false-acceptance probability, in the public RANDOM-compression +experiment. DMV and every original reachable resource hypothesis remain. -/ +theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] + [Fintype DuplexPublicSimulator.Seed] + {cap : Nat} (registry : ProductionRegistry) (Q a b Mf free : Nat) + (attackers : Coins → Source cap (Input registry.context Q)) + (before : ∀ coins, Counts a (attackers coins)) + (verifierBudget : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget registry.context Q input.packet ≤ b) + (erase (attackers coins))) + (paths : ∀ coins, WHIRSourceBackfill.AllResults + (fun input => DuplexFraming.pathCost + (RawWHIRKeys.coordinate registry.context input.packet.val 0) ≤ Mf) + (erase (attackers coins))) + (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free + (WHIRNativeSecurity.sources registry Q attackers coins)) + (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) + (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed + DuplexPublicSimulator.State (DuplexPublicSimulator.simulator Q) registry.iv) + (caps : Caps registry Q (a+b) cap free) : + realProbability registry.iv (WHIRNativeSecurity.adversary registry Q attackers) + (WHIRNativeEvent.distinguisher registry Q cap) ≤ (1 : ℚ)/2^42 := + (WHIRNativeSecurity.random_compression_list_binding registry Q a b Mf free attackers + before verifierBudget paths announcements envelope security).trans + (endpointLoss_le registry Q (a+b) cap free caps) + +/-- No small full-view replacement loss for any class admitting the efficient +one-query known-answer observer. This is not a lower bound on PCS failure. -/ +theorem concrete_gap_not_small (Q : Nat) (iv : Digest32) (input : DuplexFraming.Node) + (loss : ℚ) + (Allowed : (C : Type) → [Fintype C] → (Output : Type) → + (C → Program Output) → (View Output → Bool) → Prop) + (primitive : ConcretePrimitiveGap Q iv loss Allowed) (nonzero : 1 ≤ Q) + (observer : Allowed Unit Digest32 (knownAnswerAdversary input) + (knownAnswerDistinguisher input)) : + ¬ loss ≤ (1 : ℚ)/2^42 := by + have lower := concretePrimitiveGap_knownAnswer_lower_bound Q iv input loss + Allowed primitive nonzero observer + have separation : (1 : ℚ)/2^42 < 1 - 1/(2^256 : ℚ) := by norm_num + exact not_le_of_gt (separation.trans_le lower) + +/-- The complete RHS of the current concrete endpoint also cannot be small +under a full-view class containing the known-answer observer. In particular, +adding the ROM/DMV/Merkle terms cannot repair the replacement premise. -/ +theorem concrete_endpoint_not_small (registry : ProductionRegistry) + (Q A cap free : Nat) (input : DuplexFraming.Node) (primitiveLoss : ℚ) + (Allowed : (C : Type) → [Fintype C] → (Output : Type) → + (C → Program Output) → (View Output → Bool) → Prop) + (primitive : ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed) + (nonzero : 1 ≤ Q) + (observer : Allowed Unit Digest32 (knownAnswerAdversary input) + (knownAnswerDistinguisher input)) : + ¬ endpointLoss registry Q A cap free + primitiveLoss ≤ (1 : ℚ)/2^42 := by + intro small + apply concrete_gap_not_small Q registry.iv input primitiveLoss Allowed + primitive nonzero observer + exact (le_add_of_nonneg_left (endpointLoss_nonneg registry Q A cap free nonzero)).trans small + +end Whir.ConcreteSecurityBudget diff --git a/verification/whir/Whir/KnowledgeExtraction.lean b/verification/whir/Whir/KnowledgeExtraction.lean new file mode 100644 index 000000000..48a192cc3 --- /dev/null +++ b/verification/whir/Whir/KnowledgeExtraction.lean @@ -0,0 +1,324 @@ +import Whir.InteractiveSoundness +import Mathlib.LinearAlgebra.Lagrange + +/-! Knowledge games and the information required by record interpolation. + +The rewind interface below counts black-box response calls exactly. Its fuel is +an abstract interaction bound, NOT a proof of machine running time: Lean +continuations, output construction, and the prover itself are not unit-cost. +No knowledge-soundness theorem or efficient list decoder is asserted. + +The checked obstruction concerns *record-only* interpolation. The dense causal +game exposes the entire root; a hashed commitment or an authenticated query log +would need a separate reduction to this observation model. In particular these +results do not assert impossibility of rewindable knowledge extraction. -/ +namespace Whir.KnowledgeExtraction +open Concrete Protocol CausalGame Polynomial +open scoped BigOperators + +/-- A commitment and its claims are chosen before the verifier tape. -/ +structure CommittedProver where + input : Public + respond : Strategy + +/-- The relation is the actual commitment-fixed list relation, not unique +opening and not merely truth of claims about an unrelated witness. -/ +def Explains (input : Public) (w : Witness input.config input.lanes) : Prop := + w ∈ InitialCandidates.witnesses input.config input.lanes input.root ∧ + ∀ claim ∈ input.claims.toList, + dot (paddedWitness input.config input.lanes w) claim.weight = claim.value + +/-- Rewinding resets the deterministic causal prover and replays a selected +challenge prefix. The extractor cannot invent past prover replies. This models +fixed prover coins; randomized provers need their coins fixed across rewinds. -/ +inductive RewindProgram (c : Config) (lanes : Nat) where + | finish (output : Option (Witness c lanes)) + | query (batches : List Batch) (message : Batch) + (next : Reply → RewindProgram c lanes) + +/-- Every response in this history is obtained from the black box itself. +Challenge schedules are typed `Batch` messages; this is the total `Strategy` +interface, not a claim about reset access to the deployed Fiat--Shamir prover. -/ +def replayPast (input : Public) (strategy : Strategy) : + History → List Batch → History + | past, [] => past + | past, message :: rest => + replayPast input strategy ((message, strategy input past message) :: past) rest + +structure RewindResult (c : Config) (lanes : Nat) where + output : Option (Witness c lanes) + responseCalls : Nat + +/-- Each round replays at most `maxReplay` messages before its new response. +Exhausted round fuel or an oversized prefix fails, rather than granting free +oracle access. Local Lean evaluation and prover running time are not unit-cost. -/ +def runRewind (input : Public) (strategy : Strategy) (maxReplay : Nat) : + Nat → RewindProgram input.config input.lanes → RewindResult input.config input.lanes + | _, .finish w => ⟨w, 0⟩ + | 0, .query _ _ _ => ⟨none, 0⟩ + | fuel + 1, .query batches message next => + if batches.length ≤ maxReplay then + let past := replayPast input strategy [] batches + let result := runRewind input strategy maxReplay fuel + (next (strategy input past message)) + ⟨result.output, result.responseCalls + batches.length + 1⟩ + else ⟨none, 0⟩ + +theorem responseCalls_le (input : Public) (strategy : Strategy) (maxReplay fuel : Nat) + (program : RewindProgram input.config input.lanes) : + (runRewind input strategy maxReplay fuel program).responseCalls ≤ + fuel * (maxReplay + 1) := by + induction fuel generalizing program with + | zero => cases program <;> simp [runRewind] + | succ fuel ih => + cases program with + | finish w => simp [runRewind] + | query batches message next => + simp only [runRewind] + split_ifs with within + · have bound := ih (next (strategy input (replayPast input strategy [] batches) message)) + simp only + rw [Nat.succ_mul] + omega + · simp + +/-- Extraction randomness is independent of the verifier tape. Bounds count +rewind rounds and replay messages; local runtime is a separate cost-model input, +not a self-reported field that an extractor could set to zero. -/ +structure Extractor (Seed : Type*) where + program : (input : Public) → Seed → RewindProgram input.config input.lanes + rewindRounds : Nat + maxReplay : Nat + +/-- An externally supplied operational cost model. No theorem in this module +certifies that this function measures the machine runtime of Lean code. That +refinement is REQUIRED before interpreting `runtimeBound` as efficient time. -/ +abbrev LocalCostModel (Seed : Type*) := Extractor Seed → Public → Strategy → Seed → Nat + +def Extractor.WithinRuntime {Seed : Type*} (extractor : Extractor Seed) + (cost : LocalCostModel Seed) (runtimeBound : Nat) : Prop := + ∀ input strategy seed, cost extractor input strategy seed ≤ runtimeBound + +def extractionSuccess {Seed : Type*} (extractor : Extractor Seed) + (prover : CommittedProver) (seed : Seed) : Prop := + ∃ w, (runRewind prover.input prover.respond extractor.maxReplay extractor.rewindRounds + (extractor.program prover.input seed)).output = some w ∧ Explains prover.input w + +/-- A joint independent uniform experiment, using the actual causal verifier. +No acceptance probability or extraction relation is assumed by a theorem here. -/ +noncomputable def knowledgeFailureProbability {Seed : Type*} [Fintype Seed] [Nonempty Seed] + (extractor : Extractor Seed) (prover : CommittedProver) : ℚ := by + classical + exact Soundness.uniformProb (Finset.univ.filter fun sample : Tape prover.input.config × Seed => + experiment prover.input prover.respond sample.1 = true ∧ + ¬ extractionSuccess extractor prover sample.2) + +/-- Explicit finite-instance knowledge requirement. This definition does not +assert a uniform polynomial-time family: that requires an implemented extractor +and a justified machine-cost bound in addition to the response-call bound. -/ +def KnowledgeBound {Seed : Type*} [Fintype Seed] [Nonempty Seed] + (extractor : Extractor Seed) (cost : LocalCostModel Seed) (runtimeBound : Nat) + (error : Public → ℚ) : Prop := + extractor.WithinRuntime cost runtimeBound ∧ ∀ prover, + knowledgeFailureProbability extractor prover ≤ error prover.input + +section Records +variable {F I : Type*} [Field F] [CharP F 2] + +/-- Interpolation can identify a novel coefficient row from `2^n` distinct +correct evaluations. This is uniqueness, not an algorithm finding a correct +common agreement set inside an adversarial commitment. -/ +theorem records_determine_row (basis : Nat → F) (n : Nat) + (independent : AdditiveCode.Independent basis n) + (records : Finset I) (domain : I → F) (distinct : Set.InjOn domain records) + (enough : 2 ^ n ≤ records.card) (a b : Fin (2 ^ n) → F) + (same : ∀ i ∈ records, + (CandidateFolding.novelEncoder basis n domain) a i = + (CandidateFolding.novelEncoder basis n domain) b i) : a = b := by + apply AdditiveCode.polynomial_injective independent + apply Polynomial.eq_of_degrees_lt_of_eval_index_eq records distinct + ((AdditiveCode.polynomial_degree_lt independent a).trans_le (by exact_mod_cast enough)) + ((AdditiveCode.polynomial_degree_lt independent b).trans_le (by exact_mod_cast enough)) + exact same + +/-- With fewer records there is a nonzero novel coefficient row vanishing on +all observations. This uses the explicit product of their linear factors; it +holds even without distinctness of the observed field points. -/ +theorem sparse_records_have_kernel (basis : Nat → F) (n : Nat) + (independent : AdditiveCode.Independent basis n) + (records : Finset I) (domain : I → F) (few : records.card < 2 ^ n) : + ∃ a : Fin (2 ^ n) → F, a ≠ 0 ∧ + ∀ i ∈ records, (CandidateFolding.novelEncoder basis n domain) a i = 0 := by + classical + let p : F[X] := ∏ i ∈ records, (Polynomial.X - Polynomial.C (domain i)) + have nonzero : p ≠ 0 := (Polynomial.monic_prod_X_sub_C domain records).ne_zero + have degree : p.degree < 2 ^ n := by + rw [Polynomial.degree_eq_natDegree nonzero] + dsimp [p] + rw [Polynomial.natDegree_finsetProd_X_sub_C_eq_card] + exact_mod_cast few + obtain ⟨a, ha⟩ := (AdditiveCode.polynomial_surjective independent p).mpr degree + refine ⟨a, ?_, ?_⟩ + · intro hz + subst a + have : p = 0 := by simpa [AdditiveCode.polynomial] using ha.symm + exact nonzero this + · intro i hi + change (AdditiveCode.polynomial basis n a).eval (domain i) = 0 + rw [ha] + simp only [p, Polynomial.eval_prod, Polynomial.eval_sub, Polynomial.eval_X, + Polynomial.eval_C] + exact Finset.prod_eq_zero hi (sub_self _) + +/-- No deterministic record-only decoder is correct for every coefficient row +below the interpolation threshold. This is an information lower bound, not a +claim that acceptance or rewinding cannot reveal additional information. -/ +theorem no_sparse_record_decoder (basis : Nat → F) (n : Nat) + (independent : AdditiveCode.Independent basis n) + (records : Finset I) (domain : I → F) (few : records.card < 2 ^ n) : + ¬ ∃ decode : (records → F) → (Fin (2 ^ n) → F), + ∀ a, decode (fun i => (CandidateFolding.novelEncoder basis n domain) a i) = a := by + obtain ⟨a, nonzero, vanishes⟩ := sparse_records_have_kernel basis n independent records domain few + rintro ⟨decode, correct⟩ + have observations : (fun i : records => + (CandidateFolding.novelEncoder basis n domain) a i) = + (fun i : records => (CandidateFolding.novelEncoder basis n domain) 0 i) := by + funext i + rw [vanishes i i.property, map_zero] + rfl + exact nonzero ((correct a).symm.trans ((congrArg decode observations).trans (correct 0))) +end Records + +/-- The exact initial row observation, computed by the verifier's dense encoder. +These are occupied base-field coefficients, not arbitrary extension witnesses. -/ +def rowRecords (n rate : Nat) (records : Finset (Fin (2 ^ (n + rate)))) + (words : Fin (2 ^ n) → K) : records → E := + fun q => (encode n rate (Array.ofFn fun j => E.ofK (words j)))[q.val.val]! + +/-- The matching upper threshold for actual base rows: `2^n` distinct machine +query positions identify their coefficients. Finding records belonging to one +candidate, rather than mixing candidates, is not supplied by this theorem. -/ +theorem actual_records_determine_row (n rate : Nat) (depth : n + rate ≤ 64) + (records : Finset (Fin (2 ^ (n + rate)))) (enough : 2 ^ n ≤ records.card) + (a b : Fin (2 ^ n) → K) (same : rowRecords n rate records a = rowRecords n rate records b) : + a = b := by + have encoded : ∀ q ∈ records, + (CandidateFolding.novelEncoder (AdditiveCode.bitBasis E.ofK) n + (fun q : Fin (2 ^ (n + rate)) => E.ofK (UInt64.ofNat q.val))) (fun j => E.ofK (a j)) q = + (CandidateFolding.novelEncoder (AdditiveCode.bitBasis E.ofK) n + (fun q : Fin (2 ^ (n + rate)) => E.ofK (UInt64.ofNat q.val))) (fun j => E.ofK (b j)) q := by + intro q hq + have observed := congrFun same (⟨q, hq⟩ : records) + unfold rowRecords at observed + rw [AdditiveCode.concrete_encode_eval n rate _ (by simp) _ q.isLt, + AdditiveCode.concrete_encode_eval n rate _ (by simp) _ q.isLt] at observed + simpa [AdditiveCode.concretePolynomial, AdditiveCode.arrayPolynomial, + AdditiveCode.concreteBaseRepresentation, QueryRefinement.concreteRepresentation, + CandidateFolding.novelEncoder] using observed + have coefficientEq := records_determine_row (AdditiveCode.bitBasis E.ofK) n + (AdditiveCode.concrete_bitBasis_independent n (by omega)) records + (fun q : Fin (2 ^ (n + rate)) => E.ofK (UInt64.ofNat q.val)) + (AdditiveCode.concreteDomain (n + rate) depth).injective.injOn enough + (fun j => E.ofK (a j)) (fun j => E.ofK (b j)) encoded + funext j + exact FieldModel.ofK_injective (congrFun coefficientEq j) + +private noncomputable def baseRepresentation : AdditiveCode.BaseRepresentation FieldModel.BaseQuotient where + map := FieldModel.toBaseQuotient + one := FieldModel.toBaseQuotient_one + add := FieldModel.toBaseQuotient_xor + mul := FieldModel.toBaseQuotient_kmul + inv := FieldModel.toBaseQuotient_kinv + +/-- Endpoint-connected obstruction: below `2^n` authenticated evaluations, +two distinct literal base-word rows have identical actual dense encodings at +every observed query. No unique commitment or accepting prover is presumed. -/ +theorem actual_sparse_rows (n rate : Nat) (depth : n + rate ≤ 64) + (records : Finset (Fin (2 ^ (n + rate)))) (few : records.card < 2 ^ n) : + ∃ words : Fin (2 ^ n) → K, words ≠ 0 ∧ + rowRecords n rate records words = rowRecords n rate records 0 := by + classical + let basis := AdditiveCode.bitBasis FieldModel.toBaseQuotient + let domain := fun q : Fin (2 ^ (n + rate)) => + FieldModel.toBaseQuotient (UInt64.ofNat q.val) + have independent : AdditiveCode.Independent basis n := + AdditiveCode.bitBasis_independent baseRepresentation + FieldModel.toBaseQuotient_injective n (by omega) + obtain ⟨a, nonzero, vanishes⟩ := + sparse_records_have_kernel basis n independent records domain few + choose words hwords using fun j => FieldModel.toBaseQuotient_bijective.2 (a j) + have nonzeroWords : words ≠ 0 := by + intro hz + apply nonzero + funext j + simpa [hz] using (hwords j).symm + refine ⟨words, nonzeroWords, ?_⟩ + have poly : + AdditiveCode.concretePolynomial n (Array.ofFn fun j => E.ofK (words j)) = + (AdditiveCode.polynomial basis n a).map FieldModel.baseEmbedding := by + rw [BaseCandidateDescent.map_polynomial] + unfold AdditiveCode.concretePolynomial AdditiveCode.arrayPolynomial + apply congrArg₂ (AdditiveCode.polynomial · n ·) + · funext j + simp [basis, AdditiveCode.bitBasis, AdditiveCode.concreteBaseRepresentation, + FieldModel.baseEmbedding_word] + · funext j + simp [QueryRefinement.concreteRepresentation] + rw [← hwords j, FieldModel.baseEmbedding_word] + funext q + unfold rowRecords + rw [AdditiveCode.concrete_encode_eval n rate _ (by simp) _ q.val.isLt, + AdditiveCode.concrete_encode_eval n rate _ (by simp) _ q.val.isLt, poly] + have zeroPoly : AdditiveCode.concretePolynomial n + (Array.ofFn fun j : Fin (2 ^ n) => E.ofK ((0 : Fin (2 ^ n) → K) j)) = 0 := by + simp [AdditiveCode.concretePolynomial, AdditiveCode.arrayPolynomial, + QueryRefinement.concreteRepresentation, AdditiveCode.polynomial, FieldModel.ofK_zero] + rw [zeroPoly, Polynomial.eval_zero] + rw [← FieldModel.baseEmbedding_word, Polynomial.eval_map_apply] + change FieldModel.baseEmbedding + ((CandidateFolding.novelEncoder basis n domain) a q.val) = 0 + rw [vanishes q.val q.property, map_zero] + +/-- In particular, a deterministic interpolation shortcut consuming only these +records cannot recover every production initial row. This is not a lower bound +against an extractor that also consumes a root, claims, or rewind responses. -/ +theorem actual_no_sparse_decoder (n rate : Nat) (depth : n + rate ≤ 64) + (records : Finset (Fin (2 ^ (n + rate)))) (few : records.card < 2 ^ n) : + ¬ ∃ decode : (records → E) → (Fin (2 ^ n) → K), + ∀ words, decode (rowRecords n rate records words) = words := by + obtain ⟨words, nonzero, same⟩ := actual_sparse_rows n rate depth records few + rintro ⟨decode, correct⟩ + exact nonzero ((correct words).symm.trans ((congrArg decode same).trans (correct 0))) + +theorem production_no_sparse_decoder (p : ParameterBounds.Profile) + (records : Finset (Fin (2 ^ ((ParameterBounds.config p).logN - + (ParameterBounds.config p).folds[0]! + (ParameterBounds.config p).rates[0]!)))) + (few : records.card < 2 ^ ((ParameterBounds.config p).logN - + (ParameterBounds.config p).folds[0]!)) : + ¬ ∃ decode : (records → E) → + (Fin (2 ^ ((ParameterBounds.config p).logN - + (ParameterBounds.config p).folds[0]!)) → K), + ∀ words, decode (rowRecords _ _ records words) = words := + actual_no_sparse_decoder _ _ (InitialCandidates.production_initial_facts p).2.2.1 records few + +/-- Connection of the game relation to the existing verifier endpoint. Outside +its concrete bad-challenge cover, acceptance implies an explanation exists. +This deliberately does not select it or claim it can be found efficiently. -/ +theorem accepted_safe_explanation (p : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (tape : Tape (ParameterBounds.config p)) + (accepted : experiment (ExecutionShapes.Input p lanes root claims) strategy tape = true) + (safe : ∀ q, ¬ CausalBadEvents.Bad + (ExecutionShapes.Input p lanes root claims) strategy q tape) : + ∃ w, Explains (ExecutionShapes.Input p lanes root claims) w := by + classical + by_contra noExplanation + have noWitness : ¬ ∃ w ∈ InitialCandidates.witnesses (ParameterBounds.config p) lanes root, + ∀ claim ∈ claims.toList, + dot (paddedWitness (ParameterBounds.config p) lanes w) claim.weight = claim.value := by + simpa [Explains, ExecutionShapes.Input] using noExplanation + obtain ⟨q, bad⟩ := InteractiveSoundness.accepted_false_cover + p lanes root claims strategy tape accepted noWitness + exact safe q bad + +end Whir.KnowledgeExtraction From 42df26ef0db7af44d708e1471c98e416f5a2b470 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 00:55:42 +0100 Subject: [PATCH 07/28] Keep executable ambiguity smoke scoped to its checked fixture --- verification/whir/Main.lean | 29 +---------------------------- 1 file changed, 1 insertion(+), 28 deletions(-) diff --git a/verification/whir/Main.lean b/verification/whir/Main.lean index d569c1982..b019a5550 100644 --- a/verification/whir/Main.lean +++ b/verification/whir/Main.lean @@ -62,34 +62,7 @@ def ambiguitySmoke : IO Unit := do "zero branch of immutable spliced commitment rejected" requireIO (Whir.CommitmentAmbiguity.smallSession true).isOk "one branch of immutable spliced commitment rejected" - let c := (productionConfig 15 4).getD default - let block := 2^(c.logN-c.folds[0]!) - let mixed := tab (2^(c.logN-c.folds[0]!+c.rates[0]!)) fun q => - #[if q % 2 == 0 then E.zero else E.one] - let weight := tab (2^c.logN) fun i => if i == 0 then E.one else E.zero - for branch in #[false,true] do - let ch : Challenges := ⟨tab c.folds.size (fun i => - let n := c.logN-(c.folds.toList.take (i+1)).sum - let depth := n+c.rates[i]! - let per := 192/depth - let chunks := (c.queries[i]!+per-1)/per - let raw := if i == 0 && branch then - (List.range per).foldl (fun out j => out+2^(j*depth)) 0 else 0 - let squeeze : E := ⟨UInt64.ofNat raw, UInt64.ofNat (raw/2^64), - UInt64.ofNat (raw/2^128)⟩ - ⟨tab c.folds[i]! (fun _ => fixture (i+1)), - tab (if i+1 < c.folds.size then c.oodCounts[i+1]! else 0) - (fun _ => tab n (fun j => fixture (20+i+j))), - tab chunks (fun _ => squeeze), fixture (60+i)⟩), - tab (c.logN-c.folds.toList.sum) (fun j => fixture (80+j))⟩ - let target := if branch then E.one else E.zero - let witness := tab block fun i => if branch && i == 0 then (1 : K) else 0 - let (_, proof) ← match prove c ch witness weight target with - | .ok result => pure result - | .error e => throw (IO.userError ("production splice prover: " ++ e)) - requireIO (verify c ch 1 mixed weight target proof).isOk - "production immutable splice branch rejected" - IO.println "ambiguity_smoke=same_immutable_root,incompatible_claims,small_kernel_fixture,production_15_rate4,both_sessions_accepted" + IO.println "ambiguity_smoke=same_immutable_root,incompatible_claims,small_kernel_fixture,both_sessions_accepted" def vectors : IO Unit := do emitN "kmul" (tab 40 fun i => (kmul (seed i) (seed (i+41))).toNat) From 929791a799b7cb2db22591a260c815869469c9dc Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 11:47:00 +0100 Subject: [PATCH 08/28] Clarify deployed transcript and proposed duplex security boundary --- verification/whir/README.md | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 868081c83..c00186acf 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -1,6 +1,6 @@ # Executable WHIR model and checked list binding -This isolated Lean project models leanVM's binary-field, interleaved WHIR variant, originally pinned to [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217) and now integrated normally with upstream [`10266a181437019400bc93d8dfbb373301ba8aa5`](https://github.com/leanEthereum/leanVM/tree/10266a181437019400bc93d8dfbb373301ba8aa5). It contains an executable concrete prover/verifier, checked concrete field and encoder mathematics, adaptive interactive **list binding** for the actual Lean verifier, and random-oracle bounds for executable standalone and stacked adversaries. Fresh Rust differential checks are separate implementation evidence. The deployed keyed transcript, proposed #552 duplex model and unmerged #565 selector fix are distinct source pins, not one proved production protocol. +This isolated Lean project models leanVM's binary field, interleaved WHIR variant, originally pinned to [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217) and integrated normally with upstream [`10266a181437019400bc93d8dfbb373301ba8aa5`](https://github.com/leanEthereum/leanVM/tree/10266a181437019400bc93d8dfbb373301ba8aa5). It contains an executable concrete prover/verifier, checked concrete field and encoder mathematics, adaptive interactive **list binding** for the actual Lean verifier, and random oracle bounds for executable standalone and stacked adversaries. Fresh Rust differential checks are separate implementation evidence. The `DuplexRefinement`, `DuplexFraming` and `WHIRNativeSecurity` chain models proposed #552, not the deployed upstream transcript. Its conditional `2^-42` public random compression endpoint does not currently apply to deployed code. ## Reproduce @@ -20,7 +20,7 @@ The runner builds and executes `whirModel`, executes the production Rust harness The live harness executes the integrated upstream crates through relative dependencies. Relevant relocated paths are `pcs/src/{ntt,stack_open,whir}/mod.rs` and `whir/{config,sumcheck}/mod.rs`. [#559 at `a956c82ac711b2f4dbb3793ef2679fa47f3d6435`](https://github.com/leanEthereum/leanVM/commit/a956c82ac711b2f4dbb3793ef2679fa47f3d6435) changed deeper commitments to retained message/NTT/Merkle data with queried rows regenerated and replayed in original order. [#550 at `f52bd991c8623894e7b03a2e50bede6c248ea1ad`](https://github.com/leanEthereum/leanVM/commit/f52bd991c8623894e7b03a2e50bede6c248ea1ad) changed optimized NTT/induced-weight execution; these kernels remain differentially checked, not universally refined. [#537 at `b735ce59975e51414b3290fce50e7a7ea10600b2`](https://github.com/leanEthereum/leanVM/commit/b735ce59975e51414b3290fce50e7a7ea10600b2) removed the Python verifier and its integrations. The Python runner here is orchestration, not a replacement verifier. -`fiat_shamir/src/lib.rs` retains the baseline keyed step chain: two pending extension scalars and squeeze tag `2`. The native Rust opening smoke exercises that deployed implementation. The separate Lean duplex construction targets only proposed [#552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d), whose byte framing and versioned transports are incompatible with the deployed chain. Neither the upstream merge nor differential execution instantiates the proposed duplex security theorem for deployed Rust. +The deployed `fiat_shamir/src/lib.rs` uses the current CV as the BLAKE2s compression chaining value, byte counter `64`, final flag `true`, two pending extension scalars and squeeze tag `2` inside the scalar block. Sampling updates the CV to the complete output and returns its first three little endian words. The unchanged proof checkout and fresh upstream [`a40a7fa6de0f5ba75214aa53aceff49a5c61d7e2`](https://github.com/leanEthereum/leanVM/commit/a40a7fa6de0f5ba75214aa53aceff49a5c61d7e2) transcript file have SHA256 `6e893d3e6268bd36db737167a667963c08bffb2620241ab6cebaccb33ce893f8`. The separate Lean `DuplexRefinement` and `DuplexFraming` construction targets proposed [#552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d), which has tweak encoded roles, separate output export and a retained output cursor. These are different state machines, not merely different descriptions of one duplex. Neither the upstream merge nor differential execution establishes the proposed mode's Fiat Shamir reduction for deployed Rust. [#565 at `41c140b04eb85f5cfe12c4d238d3979af7d85fbf`](https://github.com/leanEthereum/leanVM/commit/41c140b04eb85f5cfe12c4d238d3979af7d85fbf) remains unmerged. Current `stack_open/mod.rs::check_statement` checks point-claim range ends, not offset alignment or strided-slot bounds. The harness reports actual acceptance of three independently incorrect malformed selector claims as **KNOWN GAP**, outside valid-shape Lean comparisons. The mathematical native correspondence requires `SuccinctPointWeight.Shape`, established for constructed CPU/recursion placements, not for every public PCS statement accepted by that range-only check. No production Rust changes are made by this proof update. @@ -90,7 +90,7 @@ The proof constructs concrete initial-batching, fold-restoration, OOD/query-rest `WHIRROM.rom_list_binding_numeric` bounds actual standalone false acceptance by `min 1 (B * (K + 1) * 2^-79)`. `StackWHIRROM.rom_list_binding_numeric` gives `min 1 (B * (K + 1) * (2^-79 + ringCharge cap))` for original stacked family/point claims. Both prove their concrete replay parsing, strict-prefix event correspondence and terminal trace cover; neither asks the caller to assume accepted false openings are covered by bad events. Immutable statement catalogs and root oracles are explicit inputs, not mutable values chosen after a challenge. -The production checkout used by the main differential harness still has the older keyed step-chain transcript. The separate concrete duplex model targets exactly [open PR #552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). This is a conditional instantiation, not a merge, a waiver of that PR's failing Counts gate, or a DMV claim for the older transcript. +The production checkout used by the main differential harness executes the deployed CV compression transcript described above. The separate concrete duplex model targets exactly [open PR #552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). `DuplexRefinement`, `DuplexFraming` and the resulting `WHIRNativeSecurity` public compression chain therefore do not refine the deployed transcript. The capped conditional `2^-42` endpoint is a theorem about that #552 model, not a deployed security bound. `DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove actual framing inverses, message/template injection, canonical WHIR history encoding and the structural DMV conditions. `DuplexCompression` implements the actual BLAKE2s compression evaluator. Structural framing correctness is not a proof of the probabilistic DMV theorem. @@ -141,11 +141,11 @@ The proved mathematical boundary includes concrete K/E field laws, the Lean addi - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. Current Rust's selector guard is weaker than `Shape`; valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. -- **Deployment/security target:** the public-mode theorem targets proposed #552, not the deployed keyed transcript. Ground list binding is not unique binding. No grinding amplification or numerical 128-bit whole-system security conclusion is asserted. +- **Deployment/security target:** the public mode theorem targets proposed #552, not the deployed CV compression state machine. Its conditional `2^-42` endpoint does not currently apply to deployed code. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. -Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The concrete production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. The conditional public-mode theorem still targets only the pinned #552 source identified above, not the older keyed baseline. +Merkle transport gives a fixed first registration row oracle or explicit primitive game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the pinned #552 framing identified above. A Fiat Shamir refinement and actual mode coupling for the deployed CV compression transcript remain open gaps. -Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte-decoding error taxonomy or underflow behavior as production `TranscriptError`. The Rust smoke separately uses the actual stack-opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte-for-byte theorem for the older keyed transcript is claimed. +Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte decoding error taxonomy or underflow behavior as production `TranscriptError`. The Rust smoke separately uses the actual stack opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte for byte theorem for the deployed CV compression transcript is claimed. Verification found and fixed a Lean model evaluation-order bug: a malformed public weight reached batching before its shape guard and emitted a runtime out-of-bounds diagnostic despite returning rejection. The guard now runs before batching; the maintained executable smoke and runner's stderr check cover it. No production Rust discrepancy follows from that model bug. @@ -161,7 +161,7 @@ Current-source release Rust `rec::verifier::tests::the_smallest_opening_holds_in Fresh compiled-model execution exposed a startup bug that interpreter/proof checks had not detected: even `whirModel query 8 0` was killed under the required memory scope before emitting a record. Generated `FieldCardinality` C initializers eagerly called `List.finRange` for the `2^64` base-field enumeration and constructed extension-field Cartesian products. The proof-only `FieldModel.instFintypeK` and `instFintypeE`, plus their dependent mathematical challenge-table instances, are now explicitly noncomputable. `FieldTower` supplies canonical computable superclass dictionaries directly from the already-proved `instCommRingE`, so executable ring kernels do not synthesize operations through the noncomputable field-inverse structure. No second set of arithmetic operations or laws is introduced. This removes unnecessary executable initialization without changing the finite carriers, cardinality theorems or mathematical security statements. The rebuilt compiled empty-query command emitted `queries=` successfully under the same scope. The maintained differential runner exercises the actual compiled executable, not an interpreter-only replacement. -After the correction, fresh `python3 differential/run.py` passed **71 live record groups** and production query batches `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`. The compiled Lean multilevel opening accepted and rejected its maintained malformed/tampered cases without stderr diagnostics. The current Rust opening accepted mixed point/strided/ring claims and rejected damaged streams/scalars/authentication and source-enforced shape errors. It separately reported `accepted_incorrect_claim` for plain offset, strided offset and high strided slot, explicitly outside valid-shape refinement. The output identified `deployed_keyed_step,max_pending:2,squeeze_tag:2`; the Lean opening replay uses supplied ideal challenges, not the deployed BLAKE2s transcript. +After the correction, fresh `python3 differential/run.py` passed **71 live record groups** and production query batches `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`. The compiled Lean multilevel opening accepted and rejected its maintained malformed/tampered cases without stderr diagnostics. The current Rust opening accepted mixed point/strided/ring claims and rejected damaged streams/scalars/authentication and source enforced shape errors. It separately reported `accepted_incorrect_claim` for plain offset, strided offset and high strided slot, explicitly outside valid shape refinement. Its historical diagnostic label `deployed_keyed_step,max_pending:2,squeeze_tag:2` referred to the deployed CV compression transcript described above, not the #552 state machine. The Lean opening replay uses supplied ideal challenges, not deployed BLAKE2s challenges. ## Earlier scoped validation @@ -191,7 +191,7 @@ The selector discrepancy has a separately proposed fix in [PR #565](https://gith `CommitmentAnchor` defines commitment identity as the complete immutable root, shape, anchor point and advertised value. The root-fixed candidate list precedes the one fresh uniform extension-field anchor point. Supported padding is injective, and the anchor weight is truncated to the occupied lane prefix while preserving the actual padded witness MLE. Outside the point-only collision event, every malicious choice of advertised value selects at most one supported candidate simultaneously across all later sessions. The actual causal verifier checks this same anchor in every opening batch; its unique-opening failure bound conditional on an unambiguous anchor is the original opening ledger with the additional anchor claim counted. -The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `2^-124` at the proved list cap and supported production dimensions. This is only list-selection ambiguity, not whole-system security. `ConcreteSecurityBudget` separately proves a capped `2^-42` list-binding ledger for the existing conditional public-random-compression native endpoint and demonstrates why its stated caps do not yield a `2^-43` ledger. This is neither deployed BLAKE2 security nor the composed anchored endpoint; the extra commitment-time challenge still needs its Fiat-Shamir and concrete cryptographic composition. +The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `2^-124` at the proved list cap and supported production dimensions. This is only list selection ambiguity, not whole system security. `ConcreteSecurityBudget` separately proves a capped `2^-42` list binding ledger for the conditional #552 public random compression model and demonstrates why its stated caps do not yield a `2^-43` ledger. That endpoint does not currently apply to deployed code and is not the composed anchored endpoint. The extra commitment time challenge still needs its Fiat Shamir and concrete cryptographic composition. `KnowledgeExtraction` defines executable bounded rewind access and the actual acceptance-plus-extraction-failure experiment. Its checked record-only sparse-decoder impossibility result and exact reconstruction threshold concern the actual additive encoder. It does not provide an efficient successful knowledge extractor or a knowledge soundness theorem. Mathematical classical choice in the anchored binding selector is explicitly not an extractor. From ae1bc756a001ec05e2390d26d493012ce114c932 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 12:39:38 +0100 Subject: [PATCH 09/28] Document the newly deployed duplex mode and conditional source boundary --- verification/whir/README.md | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index c00186acf..f54c0950f 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -20,7 +20,7 @@ The runner builds and executes `whirModel`, executes the production Rust harness The live harness executes the integrated upstream crates through relative dependencies. Relevant relocated paths are `pcs/src/{ntt,stack_open,whir}/mod.rs` and `whir/{config,sumcheck}/mod.rs`. [#559 at `a956c82ac711b2f4dbb3793ef2679fa47f3d6435`](https://github.com/leanEthereum/leanVM/commit/a956c82ac711b2f4dbb3793ef2679fa47f3d6435) changed deeper commitments to retained message/NTT/Merkle data with queried rows regenerated and replayed in original order. [#550 at `f52bd991c8623894e7b03a2e50bede6c248ea1ad`](https://github.com/leanEthereum/leanVM/commit/f52bd991c8623894e7b03a2e50bede6c248ea1ad) changed optimized NTT/induced-weight execution; these kernels remain differentially checked, not universally refined. [#537 at `b735ce59975e51414b3290fce50e7a7ea10600b2`](https://github.com/leanEthereum/leanVM/commit/b735ce59975e51414b3290fce50e7a7ea10600b2) removed the Python verifier and its integrations. The Python runner here is orchestration, not a replacement verifier. -The deployed `fiat_shamir/src/lib.rs` uses the current CV as the BLAKE2s compression chaining value, byte counter `64`, final flag `true`, two pending extension scalars and squeeze tag `2` inside the scalar block. Sampling updates the CV to the complete output and returns its first three little endian words. The unchanged proof checkout and fresh upstream [`a40a7fa6de0f5ba75214aa53aceff49a5c61d7e2`](https://github.com/leanEthereum/leanVM/commit/a40a7fa6de0f5ba75214aa53aceff49a5c61d7e2) transcript file have SHA256 `6e893d3e6268bd36db737167a667963c08bffb2620241ab6cebaccb33ce893f8`. The separate Lean `DuplexRefinement` and `DuplexFraming` construction targets proposed [#552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d), which has tweak encoded roles, separate output export and a retained output cursor. These are different state machines, not merely different descriptions of one duplex. Neither the upstream merge nor differential execution establishes the proposed mode's Fiat Shamir reduction for deployed Rust. +[#552 is now merged at upstream `f11f84f585680cf10f676bb4d9ae1a67e26547ca`](https://github.com/leanEthereum/leanVM/commit/f11f84f585680cf10f676bb4d9ae1a67e26547ca). Its deployed framed byte duplex is the mode modeled by `DuplexRefinement` and `DuplexFraming`, pinned to [`ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). Inspection of the other Fiat Shamir files and native, recursive, CPU, tree and reduction callsites confirms that mode correspondence: native duplex, arithmetic adapter and recursive transcript blobs are identical; Merkle documentation and the removed Python raw-stream header do not change transcript transitions. This is a source audit, not universal compiler correspondence. The proof checkout's live differential harness remains integrated with the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source, whose old CV transcript must not be described as current upstream deployment. [#565 at `41c140b04eb85f5cfe12c4d238d3979af7d85fbf`](https://github.com/leanEthereum/leanVM/commit/41c140b04eb85f5cfe12c4d238d3979af7d85fbf) remains unmerged. Current `stack_open/mod.rs::check_statement` checks point-claim range ends, not offset alignment or strided-slot bounds. The harness reports actual acceptance of three independently incorrect malformed selector claims as **KNOWN GAP**, outside valid-shape Lean comparisons. The mathematical native correspondence requires `SuccinctPointWeight.Shape`, established for constructed CPU/recursion placements, not for every public PCS statement accepted by that range-only check. No production Rust changes are made by this proof update. @@ -90,7 +90,7 @@ The proof constructs concrete initial-batching, fold-restoration, OOD/query-rest `WHIRROM.rom_list_binding_numeric` bounds actual standalone false acceptance by `min 1 (B * (K + 1) * 2^-79)`. `StackWHIRROM.rom_list_binding_numeric` gives `min 1 (B * (K + 1) * (2^-79 + ringCharge cap))` for original stacked family/point claims. Both prove their concrete replay parsing, strict-prefix event correspondence and terminal trace cover; neither asks the caller to assume accepted false openings are covered by bad events. Immutable statement catalogs and root oracles are explicit inputs, not mutable values chosen after a challenge. -The production checkout used by the main differential harness executes the deployed CV compression transcript described above. The separate concrete duplex model targets exactly [open PR #552 at `ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). `DuplexRefinement`, `DuplexFraming` and the resulting `WHIRNativeSecurity` public compression chain therefore do not refine the deployed transcript. The capped conditional `2^-42` endpoint is a theorem about that #552 model, not a deployed security bound. +`DuplexRefinement`, `DuplexFraming` and the `WHIRNativeSecurity` public compression chain model the framed byte duplex now deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. The capped conditional `2^-42` endpoint concerns that mode and the modeled unanchored native WHIR experiment, under the explicit unproved DMV coupling and resource premises below. It is not a concrete BLAKE2s security bound or a theorem covering every deployed caller. In particular, the physical root-header decoder has not been migrated to the new immutable anchor records and opening frames, and the separate anchor codec uses an independent scalar-output experiment rather than the deployed cursor-based byte stream. Generic verifier vector sampling also uses repeated scalar draws, so its exhaustion behavior is not the native duplex's whole-request preflight. `DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove actual framing inverses, message/template injection, canonical WHIR history encoding and the structural DMV conditions. `DuplexCompression` implements the actual BLAKE2s compression evaluator. Structural framing correctness is not a proof of the probabilistic DMV theorem. @@ -141,11 +141,11 @@ The proved mathematical boundary includes concrete K/E field laws, the Lean addi - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. Current Rust's selector guard is weaker than `Shape`; valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. -- **Deployment/security target:** the public mode theorem targets proposed #552, not the deployed CV compression state machine. Its conditional `2^-42` endpoint does not currently apply to deployed code. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. +- **Deployment/security target:** the public mode theorem models the #552 byte duplex now deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint requires the stated DMV, source, valid-state and resource premises and concerns the modeled unanchored native event. It does not cover the new anchor frames or establish deterministic BLAKE2s security. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. -Merkle transport gives a fixed first registration row oracle or explicit primitive game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the pinned #552 framing identified above. A Fiat Shamir refinement and actual mode coupling for the deployed CV compression transcript remain open gaps. +Merkle transport gives a fixed first registration row oracle or explicit primitive game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the #552 byte duplex framing now deployed upstream. The actual adaptive mode coupling remains unproved; the anchored protocol's additional inputs, cursor-based anchor sampling and updated source-event refinement are separate open composition obligations. -Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte decoding error taxonomy or underflow behavior as production `TranscriptError`. The Rust smoke separately uses the actual stack opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte for byte theorem for the deployed CV compression transcript is claimed. +Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte decoding error taxonomy or underflow behavior as production `TranscriptError`. The historical Rust smoke separately uses the actual stack opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte for byte theorem for all deployed callers is claimed. Verification found and fixed a Lean model evaluation-order bug: a malformed public weight reached batching before its shape guard and emitted a runtime out-of-bounds diagnostic despite returning rejection. The guard now runs before batching; the maintained executable smoke and runner's stderr check cover it. No production Rust discrepancy follows from that model bug. @@ -191,7 +191,7 @@ The selector discrepancy has a separately proposed fix in [PR #565](https://gith `CommitmentAnchor` defines commitment identity as the complete immutable root, shape, anchor point and advertised value. The root-fixed candidate list precedes the one fresh uniform extension-field anchor point. Supported padding is injective, and the anchor weight is truncated to the occupied lane prefix while preserving the actual padded witness MLE. Outside the point-only collision event, every malicious choice of advertised value selects at most one supported candidate simultaneously across all later sessions. The actual causal verifier checks this same anchor in every opening batch; its unique-opening failure bound conditional on an unambiguous anchor is the original opening ledger with the additional anchor claim counted. -The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `2^-124` at the proved list cap and supported production dimensions. This is only list selection ambiguity, not whole system security. `ConcreteSecurityBudget` separately proves a capped `2^-42` list binding ledger for the conditional #552 public random compression model and demonstrates why its stated caps do not yield a `2^-43` ledger. That endpoint does not currently apply to deployed code and is not the composed anchored endpoint. The extra commitment time challenge still needs its Fiat Shamir and concrete cryptographic composition. +The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `2^-124` at the proved list cap and supported production dimensions. This is only list selection ambiguity, not whole system security. `ConcreteSecurityBudget` separately proves a capped `2^-42` list binding ledger for the conditional public random compression model of the now-deployed #552 mode and demonstrates why its stated caps do not yield a `2^-43` ledger. That endpoint retains the unproved DMV premise and modeled unanchored source event; it is not the composed anchored endpoint. The extra commitment time challenge still needs its cursor-based Fiat Shamir and concrete cryptographic composition. `KnowledgeExtraction` defines executable bounded rewind access and the actual acceptance-plus-extraction-failure experiment. Its checked record-only sparse-decoder impossibility result and exact reconstruction threshold concern the actual additive encoder. It does not provide an efficient successful knowledge extractor or a knowledge soundness theorem. Mathematical classical choice in the anchored binding selector is explicitly not an extractor. From df9f51c7dbd710a558ee3007c3267fd55cf2ea30 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 14:48:43 +0100 Subject: [PATCH 10/28] docs: distinguish historical PCS proofs from upstream rewrite --- verification/whir/README.md | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index f54c0950f..cff022a27 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -18,18 +18,18 @@ The runner builds and executes `whirModel`, executes the production Rust harness ### Current source drift -The live harness executes the integrated upstream crates through relative dependencies. Relevant relocated paths are `pcs/src/{ntt,stack_open,whir}/mod.rs` and `whir/{config,sumcheck}/mod.rs`. [#559 at `a956c82ac711b2f4dbb3793ef2679fa47f3d6435`](https://github.com/leanEthereum/leanVM/commit/a956c82ac711b2f4dbb3793ef2679fa47f3d6435) changed deeper commitments to retained message/NTT/Merkle data with queried rows regenerated and replayed in original order. [#550 at `f52bd991c8623894e7b03a2e50bede6c248ea1ad`](https://github.com/leanEthereum/leanVM/commit/f52bd991c8623894e7b03a2e50bede6c248ea1ad) changed optimized NTT/induced-weight execution; these kernels remain differentially checked, not universally refined. [#537 at `b735ce59975e51414b3290fce50e7a7ea10600b2`](https://github.com/leanEthereum/leanVM/commit/b735ce59975e51414b3290fce50e7a7ea10600b2) removed the Python verifier and its integrations. The Python runner here is orchestration, not a replacement verifier. +The live differential harness executes relative dependencies from the proof checkout's historical Rust source pin `10266a181437019400bc93d8dfbb373301ba8aa5`, not the latest upstream tree. At that pin, relevant paths are `pcs/src/{ntt,stack_open,whir}/mod.rs` and `whir/{config,sumcheck}/mod.rs`. [#559 at `a956c82ac711b2f4dbb3793ef2679fa47f3d6435`](https://github.com/leanEthereum/leanVM/commit/a956c82ac711b2f4dbb3793ef2679fa47f3d6435) changed deeper commitments to retained message/NTT/Merkle data with queried rows regenerated and replayed in original order. [#550 at `f52bd991c8623894e7b03a2e50bede6c248ea1ad`](https://github.com/leanEthereum/leanVM/commit/f52bd991c8623894e7b03a2e50bede6c248ea1ad) changed optimized NTT/induced-weight execution; these kernels remain differentially checked, not universally refined. [#537 at `b735ce59975e51414b3290fce50e7a7ea10600b2`](https://github.com/leanEthereum/leanVM/commit/b735ce59975e51414b3290fce50e7a7ea10600b2) removed the Python verifier and its integrations. The Python runner here is orchestration, not a replacement verifier. [#552 is now merged at upstream `f11f84f585680cf10f676bb4d9ae1a67e26547ca`](https://github.com/leanEthereum/leanVM/commit/f11f84f585680cf10f676bb4d9ae1a67e26547ca). Its deployed framed byte duplex is the mode modeled by `DuplexRefinement` and `DuplexFraming`, pinned to [`ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). Inspection of the other Fiat Shamir files and native, recursive, CPU, tree and reduction callsites confirms that mode correspondence: native duplex, arithmetic adapter and recursive transcript blobs are identical; Merkle documentation and the removed Python raw-stream header do not change transcript transitions. This is a source audit, not universal compiler correspondence. The proof checkout's live differential harness remains integrated with the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source, whose old CV transcript must not be described as current upstream deployment. -[#565 at `41c140b04eb85f5cfe12c4d238d3979af7d85fbf`](https://github.com/leanEthereum/leanVM/commit/41c140b04eb85f5cfe12c4d238d3979af7d85fbf) remains unmerged. Current `stack_open/mod.rs::check_statement` checks point-claim range ends, not offset alignment or strided-slot bounds. The harness reports actual acceptance of three independently incorrect malformed selector claims as **KNOWN GAP**, outside valid-shape Lean comparisons. The mathematical native correspondence requires `SuccinctPointWeight.Shape`, established for constructed CPU/recursion placements, not for every public PCS statement accepted by that range-only check. No production Rust changes are made by this proof update. +At the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source pin, `stack_open/mod.rs::check_statement` checks point-claim range ends, not offset alignment or strided-slot bounds. The harness reports actual acceptance of three independently incorrect malformed selector claims as **KNOWN GAP**, outside valid-shape Lean comparisons. [#599 at `5735b019`](https://github.com/leanEthereum/leanVM/commit/5735b019) has since replaced that public stack implementation with typed `pcs/src/stack.rs`, including aligned full-block containment and strided-slot validation. Its WHIR kernels are crate-internal, the test-only public dense-weight entry point is gone, NTT code is unified in `ntt.rs`, and query induction uses `whir::query::{Normalizers,QueryBatch}`. The mathematical native correspondence still requires `SuccinctPointWeight.Shape`; the historical harness does not establish correspondence for every statement accepted or rejected by this new source. No production Rust changes are made by this proof update. ## Protocol to code to theorem map -Paths below are relative to `crates/pcs/src` unless another crate is named. Historical Python mirrors have been removed upstream and are not current correspondence evidence. +Paths below are relative to `crates/pcs/src` at historical source pin `10266a181437019400bc93d8dfbb373301ba8aa5` unless another crate is named. They are not the relocated #599 paths. Historical Python mirrors have been removed upstream and are not current correspondence evidence. -| Protocol step | Current production implementation | Lean executable/specification | Checked guarantee and boundary | +| Protocol step | Historical pinned source implementation | Lean executable/specification | Checked guarantee and boundary | | --- | --- | --- | --- | | Shapes and rate ladder | `whir/config/mod.rs` | `Protocol.productionConfig`, `Layout`, `ParameterBounds` | Exact index arithmetic and kernel-checked error inequalities for all 56 profiles: log-size 15 through 28, rate index 1 through 4. | | K/E arithmetic and embedding | `primitives::field::{F64,F192}` | `Concrete`, `FieldModel`, `FieldIrreducible`, `FieldEquivalence` | Actual XOR/reduced multiplication, inverses, quotient field equivalences, exact cardinalities, embedding and distinct Frobenius conjugates are proved. No concrete field law is assumed. | @@ -110,7 +110,7 @@ Consequently `WHIRNativeSecurity.concrete_list_binding` is a formal conditional `SuccinctPointWeight.eqAt_eq_mle`, `SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle`, and `InducedTerminalRefinement.nativeBasisAt_eq_mle` connect the actual plain/strided selectors, shared-prefix ring evaluator, inverse-Frobenius coefficients, and native induced-basis recurrence to their dense meanings. `AccumulatedTerminalRefinement.stack_terminal_equivalence` composes every saved OOD/query context with the rotated original caller point. `WHIRNativeArithmetic.sourceVerify_refines` proves the complete scalar-only native-style verifier loop refines `Protocol.verify`, under explicit public shapes and authenticated-row premises; it does not assume caller-weight or terminal-evaluator equality. `WHIRNativeErasure.nativeVerify_erased` removes only ghost commitment oracles, preserving actual query rows and errors. -`SuccinctPointWeight.dimension_le_of_block_bound` derives coordinate dimension from full-block containment. `selector_lt_of_block_bound` proves the shifted high selector fits the suffix consumed by the native evaluator and is used by `region_mle`, hence the native `eqAt_eq_mle` chain. `Shape` no longer redundantly asks for dimension bounds in addition to containment; `Shape.point_iff` and `Shape.strided_iff` prove equivalence to the previous complete guard predicates. `WHIRCallerSupport.production_point_nativeShape` uses the reduced premise set. Offset alignment and strided-slot bounds remain genuine requirements, not consequences of current Rust's range-only guard. +`SuccinctPointWeight.dimension_le_of_block_bound` derives coordinate dimension from full-block containment. `selector_lt_of_block_bound` proves the shifted high selector fits the suffix consumed by the native evaluator and is used by `region_mle`, hence the native `eqAt_eq_mle` chain. `Shape` no longer redundantly asks for dimension bounds in addition to containment; `Shape.point_iff` and `Shape.strided_iff` prove equivalence to the previous complete guard predicates. `WHIRCallerSupport.production_point_nativeShape` uses the reduced premise set. Offset alignment and strided-slot bounds remain genuine requirements, not consequences of the historical source pin's range-only guard. The model also fixes a Lean L0 extraction discrepancy: authenticate the full padded leaf, discard only its leading absent lanes, and reverse the occupied lanes exactly once at the protocol boundary. Separately executed pruned and full-width regression cases exercised the real parser and hash path. This is a model correction, distinct from the Rust guard fix below. @@ -140,7 +140,7 @@ The proved mathematical boundary includes concrete K/E field laws, the Lean addi - **Unproved mathematical reduction:** `PublicRandomCompressionDMV.distinguishing` for `DuplexPublicSimulator.simulator Q` and the pinned #552 mode. Framing, public-chain recognition, seed reconstruction and actual RO-query metering are proved; the adaptive real/ideal probability coupling and its DMV birthday bound are not. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. -- **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. Current Rust's selector guard is weaker than `Shape`; valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. +- **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. - **Deployment/security target:** the public mode theorem models the #552 byte duplex now deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint requires the stated DMV, source, valid-state and resource premises and concerns the modeled unanchored native event. It does not cover the new anchor frames or establish deterministic BLAKE2s security. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. Merkle transport gives a fixed first registration row oracle or explicit primitive game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the #552 byte duplex framing now deployed upstream. The actual adaptive mode coupling remains unproved; the anchored protocol's additional inputs, cursor-based anchor sampling and updated source-event refinement are separate open composition obligations. @@ -151,17 +151,17 @@ Verification found and fixed a Lean model evaluation-order bug: a malformed publ Further source composition exposed a second auxiliary-model bug: an invalid claim-order annotation stopped public compression observation although the underlying source program continued and later roots could still be registered. The observer now preserves its first error while continuing to record real public calls and commitments. This changes neither the native verifier nor the mode program, and claimed annotations still cannot install family or point data. An actual BLAKE2s reproduction failed before the correction with zero recorded calls and passed afterward with one recorded call and the original error unchanged. -## Current upstream refresh validation +## Historical source refresh validation The final native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean`. The fresh `lake env lean -E warning Audit.lean` census reported **7488 exported theorem declarations**, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound`. This is a trust audit, not a count of independently substantive results. Explicit inspection of both native endpoint types, `PublicRandomCompressionDMV` fields and `ConcretePrimitiveGap` confirmed the hypotheses listed above; an axiom census alone would not discharge them. The build freshly exercised the maintained public-simulator, accumulated-terminal, scalar-native-verifier, caller-geometry, physical-row, source-backfill and partial-replay regressions. The exact known-answer game theorems and strengthened Merkle endpoint were kernel-checked in this closure. A separate executed observer smoke used actual public BLAKE2s, accepted its locally computed answer, rejected a changed digest, and charged exactly one direct primitive call; the exact random-world probability was proved, not estimated by sampling. -Current-source release Rust `rec::verifier::tests::the_smallest_opening_holds_in_both_verifiers` passed: honest mixed ordinary/strided/ring openings hold in the native verifier and recursive rows, and tampered claims fail their terminal checks. This is a scoped runtime regression, not universal Rust or compiler correctness. +Historical-pin release Rust `rec::verifier::tests::the_smallest_opening_holds_in_both_verifiers` passed: honest mixed ordinary/strided/ring openings hold in the native verifier and recursive rows, and tampered claims fail their terminal checks. This is a scoped runtime regression at `10266a181437019400bc93d8dfbb373301ba8aa5`, not universal Rust or compiler correctness and not execution of the rewritten #599 PCS crate. Fresh compiled-model execution exposed a startup bug that interpreter/proof checks had not detected: even `whirModel query 8 0` was killed under the required memory scope before emitting a record. Generated `FieldCardinality` C initializers eagerly called `List.finRange` for the `2^64` base-field enumeration and constructed extension-field Cartesian products. The proof-only `FieldModel.instFintypeK` and `instFintypeE`, plus their dependent mathematical challenge-table instances, are now explicitly noncomputable. `FieldTower` supplies canonical computable superclass dictionaries directly from the already-proved `instCommRingE`, so executable ring kernels do not synthesize operations through the noncomputable field-inverse structure. No second set of arithmetic operations or laws is introduced. This removes unnecessary executable initialization without changing the finite carriers, cardinality theorems or mathematical security statements. The rebuilt compiled empty-query command emitted `queries=` successfully under the same scope. The maintained differential runner exercises the actual compiled executable, not an interpreter-only replacement. -After the correction, fresh `python3 differential/run.py` passed **71 live record groups** and production query batches `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)`. The compiled Lean multilevel opening accepted and rejected its maintained malformed/tampered cases without stderr diagnostics. The current Rust opening accepted mixed point/strided/ring claims and rejected damaged streams/scalars/authentication and source enforced shape errors. It separately reported `accepted_incorrect_claim` for plain offset, strided offset and high strided slot, explicitly outside valid shape refinement. Its historical diagnostic label `deployed_keyed_step,max_pending:2,squeeze_tag:2` referred to the deployed CV compression transcript described above, not the #552 state machine. The Lean opening replay uses supplied ideal challenges, not deployed BLAKE2s challenges. +After the correction, fresh `python3 differential/run.py` passed **71 live record groups** and production query batches `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)` at the historical proof-checkout source pin. The compiled Lean multilevel opening accepted and rejected its maintained malformed/tampered cases without stderr diagnostics. That pinned Rust opening accepted mixed point/strided/ring claims and rejected damaged streams/scalars/authentication and source enforced shape errors. It separately reported `accepted_incorrect_claim` for plain offset, strided offset and high strided slot, explicitly outside valid shape refinement. Its diagnostic label `deployed_keyed_step,max_pending:2,squeeze_tag:2` referred to that pin's historical CV compression transcript, not the #552 state machine now deployed upstream. The Lean opening replay uses supplied ideal challenges, not deployed BLAKE2s challenges. ## Earlier scoped validation @@ -183,7 +183,7 @@ The pinned #552 duplex evaluator matched 37 independently executed Rust state/AP Before this upstream refresh, the standalone Rust harness passed release Clippy and rustdoc with warnings denied, and its orchestration runner passed Ruff and `ty`. Those tool checks are historical, not claimed rerun in the current proof/source update. Production verifier and guest fixtures are unchanged by this proof work. -The selector discrepancy has a separately proposed fix in [PR #565](https://github.com/leanEthereum/leanVM/pull/565), but that source is not integrated here. Current upstream still accepts the malformed plain/strided offsets and oversized strided slot with independently incorrect slice values; the refreshed live harness makes this visible rather than silently adopting the proposed guard. This remains a public PCS metadata-contract violation, not a demonstrated production VM proof exploit. +The historical selector discrepancy has a separately proposed fix in [PR #565](https://github.com/leanEthereum/leanVM/pull/565), but that source is not integrated into this proof checkout. The live harness still exercises the older range-only guard and records its malformed-selector acceptance. This must not be reported as a current upstream observation after #599's typed-stack rewrite and stricter checks. The historical discrepancy is a public PCS metadata-contract violation, not a demonstrated production VM proof exploit. ## Stronger binding and extraction investigation @@ -195,4 +195,4 @@ The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `KnowledgeExtraction` defines executable bounded rewind access and the actual acceptance-plus-extraction-failure experiment. Its checked record-only sparse-decoder impossibility result and exact reconstruction threshold concern the actual additive encoder. It does not provide an efficient successful knowledge extractor or a knowledge soundness theorem. Mathematical classical choice in the anchored binding selector is explicitly not an extractor. -The authorized production anchor cutover is developed on a separate upstream-based branch, not silently substituted for this proof-only draft's source pin. It merges the separate source-only Aeneas scope/ordered-loop refactor, which does not establish Rust-to-Lean equivalence. The existing malformed selector discrepancy and unproved full concrete compression replacement remain explicit limitations. +The authorized production anchor cutover is developed in [PR #600](https://github.com/leanEthereum/leanVM/pull/600) on a separate upstream-based branch, not silently substituted for this proof-only draft's historical source pin. Its normal integration of #599 is separate from the proof checkout and the Aeneas extraction work. Source refactors and finite smoke checks do not establish Rust-to-Lean equivalence. The historical malformed-selector observation, the new source-correspondence obligations and the unproved full concrete compression replacement remain explicit limitations. From 5fd289fb8ed4c8a7ea567f55f1e350859c787590 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 15:58:09 +0100 Subject: [PATCH 11/28] docs: qualify Merkle and scalar hash audits after upstream rewrite --- verification/whir/README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/verification/whir/README.md b/verification/whir/README.md index cff022a27..e3117eadf 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -24,6 +24,8 @@ The live differential harness executes relative dependencies from the proof chec At the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source pin, `stack_open/mod.rs::check_statement` checks point-claim range ends, not offset alignment or strided-slot bounds. The harness reports actual acceptance of three independently incorrect malformed selector claims as **KNOWN GAP**, outside valid-shape Lean comparisons. [#599 at `5735b019`](https://github.com/leanEthereum/leanVM/commit/5735b019) has since replaced that public stack implementation with typed `pcs/src/stack.rs`, including aligned full-block containment and strided-slot validation. Its WHIR kernels are crate-internal, the test-only public dense-weight entry point is gone, NTT code is unified in `ntt.rs`, and query induction uses `whir::query::{Normalizers,QueryBatch}`. The mathematical native correspondence still requires `SuccinctPointWeight.Shape`; the historical harness does not establish correspondence for every statement accepted or rejected by this new source. No production Rust changes are made by this proof update. +[#555 at `9255db3ea2a604898c8af4677f4707d5f671f83a`](https://github.com/leanEthereum/leanVM/commit/9255db3ea2a604898c8af4677f4707d5f671f83a) subsequently changes `fiat_shamir/src/merkle.rs` to batched verifier hashing and the production scalar BLAKE2s implementation under `primitives/src/hash`. The preceding Fiat Shamir file and callsite equality audit is pinned to the #552 merge, not a claim that these newer files are identical. The mathematical duplex transition model and BLAKE2s specification are distinct from universal refinement of the new optimized Rust backend. Its x86 scalar compression now reaches inline assembly, which the pinned Aeneas backend does not currently translate; a checked assembly semantics/ABI bridge is an additional explicit source-correspondence obligation, not an opaque implementation assumed equivalent. + ## Protocol to code to theorem map From fa13f619f560c1aa99200edbdd48480b4849b3f1 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 20:22:01 +0100 Subject: [PATCH 12/28] Prove adaptive duplex coupling and original interactive extraction --- verification/whir/Audit.lean | 3 + verification/whir/Main.lean | 18 +- verification/whir/README.md | 50 +- verification/whir/Whir.lean | 8 + .../whir/Whir/AnchorPrefixRefinement.lean | 373 ++++++ .../Whir/AnchorPrefixRefinementArith.lean | 140 ++ .../Whir/AnchorPrefixRefinementCaller.lean | 96 ++ .../whir/Whir/AnchorPrefixRefinementCost.lean | 74 + .../whir/Whir/AnchorPrefixRefinementRows.lean | 42 + .../Whir/AnchorPrefixRefinementSmoke.lean | 27 + .../whir/Whir/AnchoredByteStreamCausal.lean | 176 +++ .../whir/Whir/AnchoredByteStreamGroups.lean | 173 +++ .../whir/Whir/AnchoredByteStreamPrepared.lean | 329 +++++ .../whir/Whir/AnchoredByteStreamSmoke.lean | 40 + .../whir/Whir/AnchoredFiatShamirSecurity.lean | 279 ++++ .../Whir/AnchoredFiatShamirSecurityCodec.lean | 111 ++ .../Whir/AnchoredFiatShamirSecurityROM.lean | 304 +++++ .../whir/Whir/AnchoredHeaderCodec.lean | 184 +++ .../whir/Whir/AnchoredHeaderRoots.lean | 115 ++ .../whir/Whir/AnchoredPhysicalAcceptance.lean | 52 + .../whir/Whir/AnchoredPhysicalAnchor.lean | 57 + .../whir/Whir/AnchoredPhysicalDriver.lean | 351 +++++ .../whir/Whir/AnchoredPhysicalSmoke.lean | 96 ++ .../whir/Whir/AnchoredPhysicalTranscript.lean | 263 ++++ .../whir/Whir/AnchoredSourceCaller.lean | 230 ++++ .../whir/Whir/AnchoredSourceFreshCaller.lean | 217 +++ .../Whir/AnchoredSourceFreshCallerSmoke.lean | 178 +++ .../whir/Whir/AnchoredSourceRegistry.lean | 111 ++ .../Whir/AuthenticatedResetCollector.lean | 232 ++++ .../whir/Whir/AuthenticatedResetLaw.lean | 151 +++ .../Whir/AuthenticatedResetProbability.lean | 92 ++ .../whir/Whir/AuthenticatedResetSuffix.lean | 102 ++ .../whir/Whir/AuthenticatedResetSupport.lean | 278 ++++ verification/whir/Whir/CausalPrefix.lean | 2 +- verification/whir/Whir/CommitmentAnchor.lean | 225 +++- .../whir/Whir/ConcreteRowExtraction.lean | 380 ++++++ .../whir/Whir/ConcreteSecurityBudget.lean | 71 +- .../whir/Whir/CountedCandidateCheck.lean | 145 ++ .../Whir/CountedCandidateCheckArithmetic.lean | 234 ++++ .../whir/Whir/CountedCandidateCheckLoops.lean | 221 +++ .../Whir/CountedCandidateCheckOriginal.lean | 115 ++ .../CountedCandidateCheckOriginalAnchor.lean | 45 + .../CountedCandidateCheckOriginalBounds.lean | 168 +++ ...ntedCandidateCheckOriginalCorrectness.lean | 169 +++ .../CountedCandidateCheckOriginalCost.lean | 187 +++ .../CountedCandidateCheckOriginalMap.lean | 62 + ...ountedCandidateCheckOriginalResources.lean | 107 ++ .../CountedCandidateCheckOriginalWeights.lean | 93 ++ .../whir/Whir/CountedCandidateCheckSmoke.lean | 184 +++ verification/whir/Whir/DuplexModeGame.lean | 21 +- .../whir/Whir/DuplexPublicSimulator.lean | 15 - verification/whir/Whir/ExtractionField.lean | 89 ++ .../whir/Whir/ExtractorArithmeticCost.lean | 225 ++++ .../Whir/ExtractorArithmeticCostBounds.lean | 137 ++ .../ExtractorArithmeticCostPolynomial.lean | 100 ++ .../Whir/ExtractorArithmeticCostRetained.lean | 120 ++ .../Whir/ExtractorArithmeticCostSource.lean | 215 +++ .../ExtractorArithmeticCostSourceBounds.lean | 168 +++ ...ractorArithmeticCostSourceComparisons.lean | 117 ++ ...tractorArithmeticCostSourcePolynomial.lean | 62 + ...xtractorArithmeticCostSourceResources.lean | 191 +++ .../Whir/ExtractorArithmeticCostVerifier.lean | 235 ++++ ...ExtractorArithmeticCostVerifierBounds.lean | 186 +++ .../ExtractorArithmeticCostVerifierTotal.lean | 147 ++ verification/whir/Whir/FiatShamirGame.lean | 10 +- .../whir/Whir/InitialKnowledgeSchedule.lean | 314 +++++ .../whir/Whir/KnowledgeExtraction.lean | 45 +- .../whir/Whir/PCSRewindExtraction.lean | 178 +++ .../whir/Whir/PCSRewindExtractor.lean | 325 +++++ .../whir/Whir/PCSRewindExtractorAttempts.lean | 173 +++ .../whir/Whir/PCSRewindExtractorFixtures.lean | 186 +++ .../Whir/PCSRewindKnowledgeCollector.lean | 98 ++ .../whir/Whir/PCSRewindKnowledgeHeavy.lean | 140 ++ .../whir/Whir/PCSRewindKnowledgeMass.lean | 73 + .../Whir/PCSRewindKnowledgeOriginalBound.lean | 82 ++ .../PCSRewindKnowledgeOriginalChance.lean | 185 +++ ...PCSRewindKnowledgeOriginalProbability.lean | 103 ++ .../PCSRewindKnowledgeOriginalRecovery.lean | 83 ++ .../PCSRewindKnowledgeOriginalRepeated.lean | 216 +++ .../Whir/PCSRewindKnowledgeParameters.lean | 137 ++ .../whir/Whir/PCSRewindKnowledgePrefix.lean | 53 + .../Whir/PCSRewindKnowledgeProbability.lean | 134 ++ .../Whir/PCSRewindKnowledgeProduction.lean | 277 ++++ .../Whir/PCSRewindKnowledgeResources.lean | 138 ++ .../whir/Whir/PCSRewindKnowledgeSuccess.lean | 77 ++ .../whir/Whir/PCSRewindSourceProgram.lean | 349 +++++ .../whir/Whir/PCSRewindSourceRelation.lean | 51 + .../Whir/PCSRoundByRoundSourceDecoder.lean | 94 ++ ...SRoundByRoundSourceDecoderCorrectness.lean | 191 +++ .../PCSRoundByRoundSourceDecoderCost.lean | 133 ++ .../PCSRoundByRoundSourceDecoderSmoke.lean | 47 + .../whir/Whir/PublicCompressionCoupling.lean | 238 ++++ ...cCompressionCouplingActualCausalBound.lean | 65 + .../PublicCompressionCouplingActualJoint.lean | 115 ++ ...icCompressionCouplingActualJointBound.lean | 93 ++ ...blicCompressionCouplingActualMismatch.lean | 58 + .../PublicCompressionCouplingBirthday.lean | 122 ++ ...ublicCompressionCouplingBirthdayCache.lean | 88 ++ .../Whir/PublicCompressionCouplingCache.lean | 89 ++ .../Whir/PublicCompressionCouplingCausal.lean | 166 +++ .../PublicCompressionCouplingCausalRisk.lean | 78 ++ .../PublicCompressionCouplingCertified.lean | 70 + .../PublicCompressionCouplingClosure.lean | 55 + ...CompressionCouplingConstructionStream.lean | 173 +++ .../PublicCompressionCouplingCoordinates.lean | 87 ++ .../PublicCompressionCouplingGoodGraph.lean | 100 ++ .../Whir/PublicCompressionCouplingHidden.lean | 82 ++ ...blicCompressionCouplingIdealLateLinks.lean | 204 +++ .../PublicCompressionCouplingInspection.lean | 113 ++ ...cCompressionCouplingInspectionSupport.lean | 85 ++ .../Whir/PublicCompressionCouplingJoint.lean | 157 +++ ...ublicCompressionCouplingJointResidual.lean | 61 + .../Whir/PublicCompressionCouplingKeys.lean | 72 + .../Whir/PublicCompressionCouplingLabels.lean | 48 + ...licCompressionCouplingLateRecognition.lean | 579 ++++++++ .../Whir/PublicCompressionCouplingMixed.lean | 140 ++ .../PublicCompressionCouplingPrefixTrace.lean | 125 ++ ...licCompressionCouplingPrimitiveStream.lean | 151 +++ .../PublicCompressionCouplingPublicCache.lean | 149 +++ .../PublicCompressionCouplingPublicTrace.lean | 174 +++ .../PublicCompressionCouplingROOrigins.lean | 140 ++ .../PublicCompressionCouplingRecognition.lean | 60 + ...PublicCompressionCouplingRelabelCache.lean | 90 ++ .../PublicCompressionCouplingResidual.lean | 69 + ...PublicCompressionCouplingSourceStream.lean | 163 +++ ...cCompressionCouplingSourceStreamSmoke.lean | 51 + .../PublicCompressionCouplingStreamFacts.lean | 165 +++ .../PublicCompressionCouplingStreams.lean | 149 +++ .../PublicCompressionCouplingTargetCache.lean | 191 +++ .../PublicCompressionCouplingTargets.lean | 121 ++ ...CompressionCouplingTerminalSeedOrigin.lean | 87 ++ ...licCompressionCouplingTerminalSupport.lean | 124 ++ ...blicCompressionCouplingTerminalUnique.lean | 76 ++ .../Whir/PublicCompressionModeSecurity.lean | 44 + .../whir/Whir/ReedSolomonExtraction.lean | 1191 +++++++++++++++++ .../Whir/ResetAcceptanceAmplification.lean | 281 ++++ verification/whir/Whir/RewindBatchTarget.lean | 309 +++++ verification/whir/Whir/RewindCoverage.lean | 207 +++ .../whir/Whir/RewindRadiusExtraction.lean | 114 ++ .../whir/Whir/RewindRowExtraction.lean | 545 ++++++++ verification/whir/Whir/RewindTrajectory.lean | 119 ++ verification/whir/Whir/Root0FixedTarget.lean | 194 +++ .../Whir/SupportedCandidateCancellation.lean | 104 ++ .../whir/Whir/SupportedCandidateClaims.lean | 122 ++ .../Whir/SupportedCandidateExtraction.lean | 120 ++ .../whir/Whir/SupportedCandidateFolding.lean | 78 ++ .../whir/Whir/SupportedCandidateMCA.lean | 57 + .../Whir/SupportedCandidateParameters.lean | 34 + .../whir/Whir/SupportedCandidateProtocol.lean | 141 ++ .../SupportedCandidateProtocolAccepted.lean | 133 ++ .../Whir/SupportedCandidateProtocolHeavy.lean | 81 ++ ...SupportedCandidateProtocolProbability.lean | 328 +++++ .../Whir/SupportedCandidateProtocolRows.lean | 180 +++ .../whir/Whir/SupportedCandidateRecovery.lean | 247 ++++ .../whir/Whir/TriangularExtraction.lean | 455 +++++++ .../whir/Whir/UniqueRadiusSampling.lean | 102 ++ verification/whir/Whir/WHIRCallerSupport.lean | 54 +- verification/whir/Whir/WHIRNativeEvent.lean | 2 +- .../whir/Whir/WHIRNativeSecurity.lean | 27 +- .../whir/Whir/WHIRObservableSecurity.lean | 29 +- .../whir/Whir/WHIRPhysicalBinding.lean | 50 +- .../whir/Whir/WHIRPhysicalDriver.lean | 5 + verification/whir/Whir/WHIRROM.lean | 7 +- verification/whir/lakefile.toml | 32 + 164 files changed, 23718 insertions(+), 177 deletions(-) create mode 100644 verification/whir/Whir/AnchorPrefixRefinement.lean create mode 100644 verification/whir/Whir/AnchorPrefixRefinementArith.lean create mode 100644 verification/whir/Whir/AnchorPrefixRefinementCaller.lean create mode 100644 verification/whir/Whir/AnchorPrefixRefinementCost.lean create mode 100644 verification/whir/Whir/AnchorPrefixRefinementRows.lean create mode 100644 verification/whir/Whir/AnchorPrefixRefinementSmoke.lean create mode 100644 verification/whir/Whir/AnchoredByteStreamCausal.lean create mode 100644 verification/whir/Whir/AnchoredByteStreamGroups.lean create mode 100644 verification/whir/Whir/AnchoredByteStreamPrepared.lean create mode 100644 verification/whir/Whir/AnchoredByteStreamSmoke.lean create mode 100644 verification/whir/Whir/AnchoredFiatShamirSecurity.lean create mode 100644 verification/whir/Whir/AnchoredFiatShamirSecurityCodec.lean create mode 100644 verification/whir/Whir/AnchoredFiatShamirSecurityROM.lean create mode 100644 verification/whir/Whir/AnchoredHeaderCodec.lean create mode 100644 verification/whir/Whir/AnchoredHeaderRoots.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalAcceptance.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalAnchor.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalDriver.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalSmoke.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalTranscript.lean create mode 100644 verification/whir/Whir/AnchoredSourceCaller.lean create mode 100644 verification/whir/Whir/AnchoredSourceFreshCaller.lean create mode 100644 verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean create mode 100644 verification/whir/Whir/AnchoredSourceRegistry.lean create mode 100644 verification/whir/Whir/AuthenticatedResetCollector.lean create mode 100644 verification/whir/Whir/AuthenticatedResetLaw.lean create mode 100644 verification/whir/Whir/AuthenticatedResetProbability.lean create mode 100644 verification/whir/Whir/AuthenticatedResetSuffix.lean create mode 100644 verification/whir/Whir/AuthenticatedResetSupport.lean create mode 100644 verification/whir/Whir/ConcreteRowExtraction.lean create mode 100644 verification/whir/Whir/CountedCandidateCheck.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckArithmetic.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckLoops.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginal.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginalAnchor.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginalBounds.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginalCorrectness.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginalCost.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginalMap.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginalResources.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckOriginalWeights.lean create mode 100644 verification/whir/Whir/CountedCandidateCheckSmoke.lean create mode 100644 verification/whir/Whir/ExtractionField.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCost.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostBounds.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostPolynomial.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostRetained.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostSource.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostSourceBounds.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostSourceComparisons.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostSourcePolynomial.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostSourceResources.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostVerifier.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostVerifierBounds.lean create mode 100644 verification/whir/Whir/ExtractorArithmeticCostVerifierTotal.lean create mode 100644 verification/whir/Whir/InitialKnowledgeSchedule.lean create mode 100644 verification/whir/Whir/PCSRewindExtraction.lean create mode 100644 verification/whir/Whir/PCSRewindExtractor.lean create mode 100644 verification/whir/Whir/PCSRewindExtractorAttempts.lean create mode 100644 verification/whir/Whir/PCSRewindExtractorFixtures.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeCollector.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeHeavy.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeMass.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeOriginalBound.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeOriginalChance.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeOriginalProbability.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeOriginalRecovery.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeOriginalRepeated.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeParameters.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgePrefix.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeProbability.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeProduction.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeResources.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeSuccess.lean create mode 100644 verification/whir/Whir/PCSRewindSourceProgram.lean create mode 100644 verification/whir/Whir/PCSRewindSourceRelation.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundSourceDecoderCost.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundSourceDecoderSmoke.lean create mode 100644 verification/whir/Whir/PublicCompressionCoupling.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingActualCausalBound.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingActualJoint.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingActualJointBound.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingActualMismatch.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingBirthday.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingBirthdayCache.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingCache.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingCausal.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingCausalRisk.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingCertified.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingClosure.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingConstructionStream.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingCoordinates.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingGoodGraph.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingHidden.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingIdealLateLinks.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingInspection.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingInspectionSupport.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingJoint.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingJointResidual.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingKeys.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingLabels.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingLateRecognition.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingMixed.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingPrefixTrace.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingPrimitiveStream.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingPublicCache.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingPublicTrace.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingROOrigins.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingRecognition.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingRelabelCache.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingResidual.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingSourceStream.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingSourceStreamSmoke.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingStreamFacts.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingStreams.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingTargetCache.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingTargets.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingTerminalSeedOrigin.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingTerminalSupport.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingTerminalUnique.lean create mode 100644 verification/whir/Whir/PublicCompressionModeSecurity.lean create mode 100644 verification/whir/Whir/ReedSolomonExtraction.lean create mode 100644 verification/whir/Whir/ResetAcceptanceAmplification.lean create mode 100644 verification/whir/Whir/RewindBatchTarget.lean create mode 100644 verification/whir/Whir/RewindCoverage.lean create mode 100644 verification/whir/Whir/RewindRadiusExtraction.lean create mode 100644 verification/whir/Whir/RewindRowExtraction.lean create mode 100644 verification/whir/Whir/RewindTrajectory.lean create mode 100644 verification/whir/Whir/Root0FixedTarget.lean create mode 100644 verification/whir/Whir/SupportedCandidateCancellation.lean create mode 100644 verification/whir/Whir/SupportedCandidateClaims.lean create mode 100644 verification/whir/Whir/SupportedCandidateExtraction.lean create mode 100644 verification/whir/Whir/SupportedCandidateFolding.lean create mode 100644 verification/whir/Whir/SupportedCandidateMCA.lean create mode 100644 verification/whir/Whir/SupportedCandidateParameters.lean create mode 100644 verification/whir/Whir/SupportedCandidateProtocol.lean create mode 100644 verification/whir/Whir/SupportedCandidateProtocolAccepted.lean create mode 100644 verification/whir/Whir/SupportedCandidateProtocolHeavy.lean create mode 100644 verification/whir/Whir/SupportedCandidateProtocolProbability.lean create mode 100644 verification/whir/Whir/SupportedCandidateProtocolRows.lean create mode 100644 verification/whir/Whir/SupportedCandidateRecovery.lean create mode 100644 verification/whir/Whir/TriangularExtraction.lean create mode 100644 verification/whir/Whir/UniqueRadiusSampling.lean diff --git a/verification/whir/Audit.lean b/verification/whir/Audit.lean index d2b33e9bf..b6e382c10 100644 --- a/verification/whir/Audit.lean +++ b/verification/whir/Audit.lean @@ -4,6 +4,9 @@ import Lean.Util.CollectAxioms open Lean in run_cmd do let environment ← getEnv + for moduleName in environment.header.moduleNames do + if (`Whir).isPrefixOf moduleName then + logInfo m!"Audited import: {moduleName}" let mut count : Nat := 0 for (name, info) in environment.constants.toList do if (`Whir).isPrefixOf name then diff --git a/verification/whir/Main.lean b/verification/whir/Main.lean index b019a5550..dbf62a9be 100644 --- a/verification/whir/Main.lean +++ b/verification/whir/Main.lean @@ -1,6 +1,7 @@ import Whir.Protocol import Whir.CausalGame import Whir.CommitmentAmbiguity +import Whir.ConcreteRowExtraction open Whir.Concrete Whir.Protocol @@ -64,6 +65,20 @@ def ambiguitySmoke : IO Unit := do "one branch of immutable spliced commitment rejected" IO.println "ambiguity_smoke=same_immutable_root,incompatible_claims,small_kernel_fixture,both_sessions_accepted" +def extractionSmoke : IO Unit := do + let words : Array K := #[3, 5, 8, 13] + let honest := encode 2 2 (words.map E.ofK) + for errors in [0, 3, 6] do + let received : Vector E (Whir.ConcreteRowExtraction.domain 4 (by decide)).n := + Vector.ofFn fun i => + if i.val < errors then honest[i.val]! + E.ofK 1 else honest[i.val]! + let result := Whir.ConcreteRowExtraction.countedExtractRow 2 2 (by decide) received + requireIO (result.1 == some words) ("source-word Gao recovery failed with " ++ toString errors ++ " errors") + requireIO (result.2 ≤ Whir.ConcreteRowExtraction.rowArithmeticPolynomial 16) + "source-word decoder exceeded its proved field-arithmetic budget" + IO.println ("extraction_smoke=actual_word_encoder,N16,k4,errors" ++ toString errors ++ + ",recovered3_5_8_13,field_arithmetic" ++ toString result.2) + def vectors : IO Unit := do emitN "kmul" (tab 40 fun i => (kmul (seed i) (seed (i+41))).toNat) emitN "kinv" (tab 12 fun i => (kinv (seed i)).toNat) @@ -113,5 +128,6 @@ def main (args : List String) : IO Unit := do | none => throw (IO.userError "malformed query challenge vector") | some qs => emitN "queries" qs | ["ambiguity"] => ambiguitySmoke + | ["extraction"] => extractionSmoke | [] => vectors; smoke - | _ => throw (IO.userError "usage: whirModel [ambiguity | query DEPTH COUNT LIMB ...]") + | _ => throw (IO.userError "usage: whirModel [ambiguity | extraction | query DEPTH COUNT LIMB ...]") diff --git a/verification/whir/README.md b/verification/whir/README.md index e3117eadf..0cc64f224 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -1,6 +1,6 @@ -# Executable WHIR model and checked list binding +# Executable WHIR model, binding and interactive extraction -This isolated Lean project models leanVM's binary field, interleaved WHIR variant, originally pinned to [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217) and integrated normally with upstream [`10266a181437019400bc93d8dfbb373301ba8aa5`](https://github.com/leanEthereum/leanVM/tree/10266a181437019400bc93d8dfbb373301ba8aa5). It contains an executable concrete prover/verifier, checked concrete field and encoder mathematics, adaptive interactive **list binding** for the actual Lean verifier, and random oracle bounds for executable standalone and stacked adversaries. Fresh Rust differential checks are separate implementation evidence. The `DuplexRefinement`, `DuplexFraming` and `WHIRNativeSecurity` chain models proposed #552, not the deployed upstream transcript. Its conditional `2^-42` public random compression endpoint does not currently apply to deployed code. +This isolated Lean project models leanVM's binary-field interleaved WHIR variant, originally pinned to [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217) and integrated normally with upstream [`10266a181437019400bc93d8dfbb373301ba8aa5`](https://github.com/leanEthereum/leanVM/tree/10266a181437019400bc93d8dfbb373301ba8aa5). It contains the executable concrete prover/verifier, checked field/encoder mathematics, adaptive interactive list binding, immutable-anchor selection mathematics, an actual original-statement interactive reset extractor, and a proved adaptive ideal-compression duplex coupling. The duplex model matches #552 at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`; the live Rust harness remains historical. Fresh Rust differential checks are separate implementation evidence. These results do not establish Fiat-Shamir knowledge soundness, universal current-source correspondence or unconditional concrete BLAKE2s security. ## Reproduce @@ -16,6 +16,16 @@ python3 differential/run.py The runner builds and executes `whirModel`, executes the production Rust harness in release mode, and compares newly computed records. Its query mode also feeds actual production challenge limbs to Lean. It uses `/tmp/whir-lean-target`, two Cargo jobs, and one leanVM worker. Lean execution must emit no runtime diagnostic on stderr, including on malformed public inputs. There are no accepted-output snapshots to regenerate. Lean proof checking is separate from executable differential evidence. +The maintained compiled extraction and actual mode-stream regressions can be reproduced separately: + +```sh +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake build whirExtractionSmoke whirCountedExtractionSmoke whirActualSourceStreamSmoke whirRoundByRoundDecoderSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirExtractionSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirCountedExtractionSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirActualSourceStreamSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirRoundByRoundDecoderSmoke +``` + ### Current source drift The live differential harness executes relative dependencies from the proof checkout's historical Rust source pin `10266a181437019400bc93d8dfbb373301ba8aa5`, not the latest upstream tree. At that pin, relevant paths are `pcs/src/{ntt,stack_open,whir}/mod.rs` and `whir/{config,sumcheck}/mod.rs`. [#559 at `a956c82ac711b2f4dbb3793ef2679fa47f3d6435`](https://github.com/leanEthereum/leanVM/commit/a956c82ac711b2f4dbb3793ef2679fa47f3d6435) changed deeper commitments to retained message/NTT/Merkle data with queried rows regenerated and replayed in original order. [#550 at `f52bd991c8623894e7b03a2e50bede6c248ea1ad`](https://github.com/leanEthereum/leanVM/commit/f52bd991c8623894e7b03a2e50bede6c248ea1ad) changed optimized NTT/induced-weight execution; these kernels remain differentially checked, not universally refined. [#537 at `b735ce59975e51414b3290fce50e7a7ea10600b2`](https://github.com/leanEthereum/leanVM/commit/b735ce59975e51414b3290fce50e7a7ea10600b2) removed the Python verifier and its integrations. The Python runner here is orchestration, not a replacement verifier. @@ -66,7 +76,7 @@ The operational kernels are polymorphic over their minimal operations, and the c The implementation commits in K = GF(2^64), challenges in E = GF(2^192), and uses additive domains and the novel polynomial basis. The original multiplicative WHIR folding formulas cannot be copied into characteristic two. Quadratic messages contain only the constant and quadratic coefficient; the linear coefficient is reconstructed as `claim + quadratic`. -There is no commitment-time OOD sample, following Flock. The appropriate security relation is **list binding**, not unique binding. Subsequent OOD claims occur after new commitments. The production protocol sends intro polynomials one message ahead. `CausalGame` and the checked history/replay modules preserve that causal schedule, including the invisible final tail challenge; strategies cannot inspect future tape coordinates. +At the historical source pin there is no commitment-time OOD sample, following Flock, so its proved relation is list binding rather than unique binding. The separate #600 cutover adds the retained commitment-time anchor and binds every later opening to its complete identity. Subsequent OOD claims occur after new commitments. The protocol sends intro polynomials one message ahead; `CausalGame` and the checked history/replay modules preserve that schedule, including the invisible final tail challenge, without allowing strategies to inspect future tape. L0 folds the top witness variables because each interleaved lane is a contiguous stack block. Codeword lane order is reversed, so missing zero-tail lanes become leading zeros in a leaf. Only the live suffix is transported. Caller-coordinate rotation must not be applied to per-level induced weights. @@ -92,11 +102,11 @@ The proof constructs concrete initial-batching, fold-restoration, OOD/query-rest `WHIRROM.rom_list_binding_numeric` bounds actual standalone false acceptance by `min 1 (B * (K + 1) * 2^-79)`. `StackWHIRROM.rom_list_binding_numeric` gives `min 1 (B * (K + 1) * (2^-79 + ringCharge cap))` for original stacked family/point claims. Both prove their concrete replay parsing, strict-prefix event correspondence and terminal trace cover; neither asks the caller to assume accepted false openings are covered by bad events. Immutable statement catalogs and root oracles are explicit inputs, not mutable values chosen after a challenge. -`DuplexRefinement`, `DuplexFraming` and the `WHIRNativeSecurity` public compression chain model the framed byte duplex now deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. The capped conditional `2^-42` endpoint concerns that mode and the modeled unanchored native WHIR experiment, under the explicit unproved DMV coupling and resource premises below. It is not a concrete BLAKE2s security bound or a theorem covering every deployed caller. In particular, the physical root-header decoder has not been migrated to the new immutable anchor records and opening frames, and the separate anchor codec uses an independent scalar-output experiment rather than the deployed cursor-based byte stream. Generic verifier vector sampling also uses repeated scalar draws, so its exhaustion behavior is not the native duplex's whole-request preflight. +`DuplexRefinement`, `DuplexFraming` and the `WHIRNativeSecurity` public compression chain model the framed byte duplex deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. The capped conditional `2^-42` endpoint concerns that mode and the modeled unanchored native WHIR experiment under the resource and source-model premises below. The actual ideal-compression mode coupling is now proved, not a supplied DMV assumption. It is not a concrete BLAKE2s security bound or a theorem covering every deployed caller. Separate pinned anchored physical and cursor-byte refinements do not yet compose into the deployed anchored Fiat-Shamir endpoint; generic repeated-scalar vector sampling also does not establish whole-request exhaustion/error equivalence. -`DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove actual framing inverses, message/template injection, canonical WHIR history encoding and the structural DMV conditions. `DuplexCompression` implements the actual BLAKE2s compression evaluator. Structural framing correctness is not a proof of the probabilistic DMV theorem. +`DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove framing inverses, message/template injection, canonical WHIR history encoding and structural mode conditions. `DuplexCompression` implements BLAKE2s compression. The separate actual source-stream coupling supplies the stochastic whole-view bound; structural framing alone is not used as its proof. -`DuplexModeGame` defines finite real public-compression and ideal raw-random-oracle/simulator games for adaptive direct and construction queries, including auxiliary and verifier work. `PublicRandomCompressionDMV` now assumes only the actual universal view-distinguishing inequality; its redundant `simulatorBound` certificate field has been removed because `DuplexPublicSimulator.simulatorBound` proves the pinned simulator's metering. Structural reconstruction and metering do **not** prove the stochastic inequality. The finite-game coupling/H-coefficient argument for the actual mode and simulator remains a mathematical proof obligation. +`DuplexModeGame` defines finite real public-compression and ideal raw-random-oracle/simulator games for adaptive direct and construction queries, including auxiliary and verifier work. `PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss` proves the unrestricted whole-view inequality for the actual `DuplexPublicSimulator.simulator Q` under one aggregate `Counts Q` cap. `DuplexPublicSimulator.modeSecurity` supplies its proved `PublicCompressionModeBound`; native endpoints no longer ask for an external fixed-simulator security certificate. The corrected loss is `min(1,(2*choose(Q,2)+Q^2)/2^256) = min(1,(2Q^2-Q)/2^256)`. The earlier birthday-only coefficient was insufficient for the whole-view coupling and has been corrected. Sharp birthday subevent estimates remain separate from the full loss. Actual residual-table disintegration and adaptive stream alignment prove the coupling, including repeated queries, late recognition, final cache completion and unrestricted observers. `ConcretePrimitiveGap` is retained as a precisely named **full-public-view replacement premise**, not a standard computational hash-security assumption. `knownAnswerAdversary` makes one direct primitive query, and `knownAnswerDistinguisher` compares its answer with a local evaluation of public BLAKE2s. `knownAnswer_concreteProbability` is exactly `1`; `knownAnswer_realProbability` is exactly `2^-256`. The kernel-checked `concretePrimitiveGap_knownAnswer_lower_bound` therefore proves `primitiveLoss >= 1 - 2^-256` whenever `Q >= 1` and `Allowed` includes this pair. Ordinary efficient classes include this elementary observer. Efficiency, collision resistance or a stronger implementation audit cannot justify a small full-view loss. This counterexample applies to the public primitive experiment used for proposed #552 and does not refute the separate random-compression DMV claim. @@ -120,13 +130,15 @@ The model also fixes a Lean L0 extraction discrepancy: authenticate the full pad ## Original papers and version limits - [WHIR, ePrint 2024/1586](https://eprint.iacr.org/2024/1586): substantive full-paper sections read from the November 21, 2024 PDF. Lemma 4.4 is the interleaved Johnson bound; Definition 4.9 defines MCA; Definition 4.14 and Claim 4.15 concern multiplicative folding; Construction 5.1/Theorem 5.2 give conditional RBR soundness. This numbering is not silently attributed to every later proceedings revision. +- [WHIR proceedings, primary publisher](https://doi.org/10.1007/978-3-031-91134-7_8), footnote 6: the paper assumes `char(F) != 2` for its 2-smooth multiplicative subgroup and folding operation. This excludes direct application to this additive characteristic-two variant. The exact full-paper knowledge theorem was not verified in the newly retrieved publisher material and is not transplanted into the Lean model. +- [Building Cryptographic Proofs from Hash Functions, source edition v1.2](https://github.com/hash-based-snargs-book/hash-based-snargs-book/blob/305fa3d9d19ee6dba135de64b3156d1760df8426/snargs-book.pdf), March 25, 2026: Definition 31.1.6 requires a polynomial-time extractor from IOP strings without verifier coins; Theorem 31.3.1 gives straight-line state-restoration knowledge loss `(t+k)*epsilonRBR`; Theorem 26.1.1 gives BCS knowledge loss `epsilonSR(Q) + deltaMT_multi(Q,Q+1) + Q^2/2^lambda`. Construction 25.1.1 requires the raw minimum verifier-message entropy to be at least `lambda`. Grouped PCS messages have an E element, giving the intended PCS-only `lambda = 192`; neither 256-bit compression nor a hypothetical stretched seed changes that hypothesis. The actual byte-duplex/full-history and shared-Merkle adapter must be proved before applying these expressions. Flock, bus/GKR and outer-protocol entropy are not covered. - [Ligerito, ePrint 2025/1187](https://eprint.iacr.org/2025/1187): full [author PDF](https://angeris.github.io/papers/ligerito.pdf), dated May 2025, read including the matrix-vector/partial-sumcheck construction and recursive protocol section 6. An immutable ePrint revision identifier was not obtained. - [Ring switching, ePrint 2024/504](https://eprint.iacr.org/2024/504): packing/security sections read from a cached full PDF. Definition 2.2 is packing and Theorem 3.5 is the compiler security statement in that inspected copy. Its precise dated ePrint revision was not established; the inspected bytes are identified by SHA-256 below. - [LCH14, arXiv 1404.3458v2](https://arxiv.org/abs/1404.3458v2): July 24, 2014 version. Section II-B equations (3)-(4) give additive subspace polynomials; II-C gives the normalized product basis and the subsequent sections the transform recurrence. - [BCHKS25, ePrint 2025/2055](https://eprint.iacr.org/2025/2055): recovered and read from [ECCC TR25-169](https://eccc.weizmann.ac.il/report/2025/169/download/), title-page November 7, 2025. Corollary 1.4 is ordinary correlated agreement, so Annex B's stronger same-agreement-set adaptation needs its own argument. Theorem 4.6, pages 28-29, is the required list-correlated-agreement statement. Its rate is `(dimension - 1)/block length` and its multiplicity denominator is the Johnson slack, not twice the slack from Theorem 1.5. Section 3.2 explicitly charges content-factor exceptional roots omitted in an older proof. These security conclusions are not imported as Lean axioms here. - [DT24, ePrint 2024/1038](https://eprint.iacr.org/2024/1038): complete author PDF read and [pinned to hosting commit `3c36f36aa545f514a967a4f157e8476ad2be335b`](https://github.com/quangvdao/quangvdao.github.io/blob/3c36f36aa545f514a967a4f157e8476ad2be335b/papers/authored/constraint-packing-binary-tower-fields.pdf), Git blob `58244673916d0f7c7b140c5c936cb1493b3eae5c`. Claim 1 and equations (11)-(13) use basis independence for deterministic coordinate packing; characteristic two alone does not suffice. Algorithm 3's Wiedemann-tower arithmetic is not leanVM's representation. - [LFKN92, primary author manuscript](https://lance.fortnow.com/papers/files/ip.pdf): recovered through a real browser after the reader's HTTP 406; full protocol/security sections read. Rendered pages 3-4 confirm Theorem 1 (interactive proofs for P raised to a #P oracle), Lemma 3 (reduction to permanent checking), and Lemma 4 (degree-r polynomial agreement bounded by r/p). The manuscript proves the permanent expand/shrink protocol, not a named modern Boolean-cube sumcheck theorem. Its first-escape proof motivates `rbr_composition`; its footnote explicitly distinguishes ideal uniform field sampling from bit-based rejection sampling. -- [DMV18, ToSC 2018(4), pages 197-228](https://tosc.iacr.org/index.php/ToSC/en/article/download/7366/6536/2516), DOI [10.13154/tosc.v2018.i4.197-228](https://doi.org/10.13154/tosc.v2018.i4.197-228): the published original's template-execution model, Definitions 4-6 and 8, Theorem 1, and its random-function simulator/H-coefficient proof in section 5 were read. Theorem 1 counts direct and indirect primitive evaluations and separately bounds the simulator's random-oracle queries. Its probabilistic conclusion remains an explicit external game assumption; the corresponding concrete mode structure is proved in Lean. +- [DMV18, ToSC 2018(4), pages 197-228](https://tosc.iacr.org/index.php/ToSC/en/article/download/7366/6536/2516), DOI [10.13154/tosc.v2018.i4.197-228](https://doi.org/10.13154/tosc.v2018.i4.197-228): the published original's template-execution model, Definitions 4-6 and 8, Theorem 1, and random-function simulator/H-coefficient proof in section 5 were read. Its generic theorem is not substituted for the actual mode proof: this project now proves the concrete adaptive coupling with its own corrected whole-view coefficient and aggregate query cap. - [Jo26, ePrint 2026/891](https://eprint.iacr.org/2026/891) and [Gru24](https://eprint.iacr.org/2024/108): full originals remain unavailable after ePrint/publisher, author-site, archive and repository searches. The Jo26 PDF additionally remained behind a Cloudflare security-verification page in a real browser. Jo26 Theorem 4.4 is verified only as a local citation. No unverified original theorem numbering is asserted. The unavailable originals and incomplete revision pins above are explicit research limitations, not claimed completed source readings. @@ -139,13 +151,13 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: -- **Unproved mathematical reduction:** `PublicRandomCompressionDMV.distinguishing` for `DuplexPublicSimulator.simulator Q` and the pinned #552 mode. Framing, public-chain recognition, seed reconstruction and actual RO-query metering are proved; the adaptive real/ideal probability coupling and its DMV birthday bound are not. +- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. A coin-free full-root decoder is separately implemented and checked, but a complete public-transcript RBR knowledge theorem, Merkle-query-log extraction and the PCS byte-duplex BCS adapter must be proved before claiming Fiat-Shamir knowledge soundness. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. -- **Deployment/security target:** the public mode theorem models the #552 byte duplex now deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint requires the stated DMV, source, valid-state and resource premises and concerns the modeled unanchored native event. It does not cover the new anchor frames or establish deterministic BLAKE2s security. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. +- **Deployment/security target:** the public mode theorem models the #552 byte duplex deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not cover the new anchor frames or establish deterministic BLAKE2s security. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. -Merkle transport gives a fixed first registration row oracle or explicit primitive game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the #552 byte duplex framing now deployed upstream. The actual adaptive mode coupling remains unproved; the anchored protocol's additional inputs, cursor-based anchor sampling and updated source-event refinement are separate open composition obligations. +Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the #552 byte-duplex framing and the proved adaptive ideal-compression coupling. Additional anchor inputs, their cursor-based sampling, updated source-event refinement and Fiat-Shamir knowledge extraction remain separate composition obligations. Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte decoding error taxonomy or underflow behavior as production `TranscriptError`. The historical Rust smoke separately uses the actual stack opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte for byte theorem for all deployed callers is claimed. @@ -153,9 +165,15 @@ Verification found and fixed a Lean model evaluation-order bug: a malformed publ Further source composition exposed a second auxiliary-model bug: an invalid claim-order annotation stopped public compression observation although the underlying source program continued and later roots could still be registered. The observer now preserves its first error while continuing to record real public calls and commitments. This changes neither the native verifier nor the mode program, and claimed annotations still cannot install family or point data. An actual BLAKE2s reproduction failed before the correction with zero recorded calls and passed afterward with one recorded call and the original error unchanged. +## Completed coupling and interactive extraction validation + +The fresh completed dependency closure passed `lake build --wfail +Whir:olean +Main:olean` together with all five maintained compiled executables. `lake env lean -E warning Audit.lean` inventoried its imported proof modules and checked **9906 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. This audit covers the corrected adaptive duplex coupling loss, the original-statement interactive reset extractor, its exact success and resource bounds, the anchored source components and the full-root decoder helper. It does not import unfinished Fiat-Shamir knowledge composition work. + +Actual compiled execution accepted the honest multilevel model and rejected its malformed and tampered cases. The reset extractor recovered eight nonzero base-field coefficients through legal response calls, checked every original family and point claim plus the saved anchor, and rejected withholding, malformed rows and a deliberately false uncompressed family even when its compressed claim passed. Its counted original-statement execution agreed with the same result and exercised all 64 ring slices, strided claims and the anchor. The source-stream executable checked adaptive construction, public recognition and repeated cache access. The separate full-root Gao helper recovered the same word from a directly indexed raw table with one corrupted row and rejected malformed shape, wrong original claims and a changed anchor. Finite executions are regression evidence, not substitutes for the universal checked theorems. + ## Historical source refresh validation -The final native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean`. The fresh `lake env lean -E warning Audit.lean` census reported **7488 exported theorem declarations**, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound`. This is a trust audit, not a count of independently substantive results. Explicit inspection of both native endpoint types, `PublicRandomCompressionDMV` fields and `ConcretePrimitiveGap` confirmed the hypotheses listed above; an axiom census alone would not discharge them. +The previously published native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean`. Its fresh `lake env lean -E warning Audit.lean` census reported **7488 exported theorem declarations**, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound`. That historical inspection included both native endpoint types, the then-external `PublicRandomCompressionDMV` coupling certificate and `ConcretePrimitiveGap`. It did not discharge the external coupling certificate, which the completed finite-game coupling above has now removed; the separate concrete primitive premise remains as stated. The build freshly exercised the maintained public-simulator, accumulated-terminal, scalar-native-verifier, caller-geometry, physical-row, source-backfill and partial-replay regressions. The exact known-answer game theorems and strengthened Merkle endpoint were kernel-checked in this closure. A separate executed observer smoke used actual public BLAKE2s, accepted its locally computed answer, rejected a changed digest, and charged exactly one direct primitive call; the exact random-world probability was proved, not estimated by sampling. @@ -193,8 +211,14 @@ The historical selector discrepancy has a separately proposed fix in [PR #565](h `CommitmentAnchor` defines commitment identity as the complete immutable root, shape, anchor point and advertised value. The root-fixed candidate list precedes the one fresh uniform extension-field anchor point. Supported padding is injective, and the anchor weight is truncated to the occupied lane prefix while preserving the actual padded witness MLE. Outside the point-only collision event, every malicious choice of advertised value selects at most one supported candidate simultaneously across all later sessions. The actual causal verifier checks this same anchor in every opening batch; its unique-opening failure bound conditional on an unambiguous anchor is the original opening ledger with the additional anchor claim counted. -The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `2^-124` at the proved list cap and supported production dimensions. This is only list selection ambiguity, not whole system security. `ConcreteSecurityBudget` separately proves a capped `2^-42` list binding ledger for the conditional public random compression model of the now-deployed #552 mode and demonstrates why its stated caps do not yield a `2^-43` ledger. That endpoint retains the unproved DMV premise and modeled unanchored source event; it is not the composed anchored endpoint. The extra commitment time challenge still needs its cursor-based Fiat Shamir and concrete cryptographic composition. +The checked anchor ambiguity term is `choose(L,2) * dimension / |E|`, bounded by `2^-124` at the proved list cap and supported production dimensions. This is only list selection ambiguity, not whole system security. `ConcreteSecurityBudget` recomputes the capped `2^-42` list-binding ledger using the proved whole-view mode loss `min(1,(2Q^2-Q)/2^256)`; its ROM term alone still prevents a uniform `2^-43` ledger at those caps. The source, Merkle and mode terms remain separate, and the endpoint is the modeled unanchored source event, not a composed anchored endpoint. Commitment-time anchor/cursor mathematics and pinned source decoding remain distinct from full Fiat-Shamir and concrete cryptographic composition. + +`PCSRewindSource.complete_original_knowledge` is **interactive only**. The actual bounded reset machine collects legal authenticated Root0 rows, runs the counted Gao/base-word decoder and checks every original family slice, ordinary and strided point claim, and the literal retained anchor before returning a word. Every output is a member of the original Root0 candidate list and explains all original claims; neither candidate availability nor honest-root equality is a premise. For acceptance probability `κ`, the exact acceptance-plus-no-output bound is `1/2^50 + 2^-s`. This is an extraction cutoff and repetition failure expression, not a security level. + +Writing `gap = κ - 1/2^50`, the proof chooses fuel without requiring the executable machine to estimate `κ`. When `gap > 0`, the checked round bound is `((8N/gap)+1)(d+2)` and the checked attempt bound is `((8/gap)+1)s`, with Root0 row count `N` and initial folding depth `d`. `complete_original_resource` bounds the actual source arithmetic, strict-prefix oracle calls, consumed encoded reply words, original preparation/checks, retained rows and coordinate comparisons. Its Gao component is degree seven in `N`; the whole expression is polynomial in physical input dimensions, `1/gap`, `s` and literal admitted reply length. Rectangular Root0 input and occupied-lane restrictions are explicit. Prover CPU time and unbounded raw-response allocation are outside the unit-oracle-access boundary. + +Compiled source-extractor checks exercise nontrivial K coefficients, all original claims, malformed metadata and the case where `gamma = 0` masks a false original family in the compressed claim but the original checker rejects it. Kernel-checked output, probability and resource endpoints use only `propext`, `Classical.choice` and `Quot.sound`. This is **not a Fiat-Shamir knowledge result**, a full Rust correspondence theorem, or an unconditional concrete BLAKE2s claim. `KnowledgeExtraction` also retains the separate sparse record-only impossibility result; classical choice in the anchor's mathematical selector is not the implemented extractor. -`KnowledgeExtraction` defines executable bounded rewind access and the actual acceptance-plus-extraction-failure experiment. Its checked record-only sparse-decoder impossibility result and exact reconstruction threshold concern the actual additive encoder. It does not provide an efficient successful knowledge extractor or a knowledge soundness theorem. Mathematical classical choice in the anchored binding selector is explicitly not an extractor. +`PCSRoundByRoundSource.run` separately decodes the full Root0 message by direct indexed Gao/base-word processing, checks the actual common support and all original claims, and receives no strategy or verifier coins. Its output, SAME-word heavy-support recovery and counted degree-seven cost are kernel checked. The compiled generic-helper smoke exercises corrupted roots and malformed original statements. This decoder contract alone is not a completed RBR or Fiat-Shamir theorem. The authorized production anchor cutover is developed in [PR #600](https://github.com/leanEthereum/leanVM/pull/600) on a separate upstream-based branch, not silently substituted for this proof-only draft's historical source pin. Its normal integration of #599 is separate from the proof checkout and the Aeneas extraction work. Source refactors and finite smoke checks do not establish Rust-to-Lean equivalence. The historical malformed-selector observation, the new source-correspondence obligations and the unproved full concrete compression replacement remain explicit limitations. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index 19d941ec2..a90c7515b 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -145,3 +145,11 @@ import Whir.WHIRSourceChronology import Whir.WHIRSourceObserver import Whir.WHIRNativeSecurity import Whir.WHIRPhysicalRowsRegression +import Whir.PCSRewindKnowledgeOriginalBound +import Whir.AnchoredPhysicalAcceptance +import Whir.AnchoredByteStreamCausal +import Whir.AnchoredByteStreamPrepared +import Whir.AnchorPrefixRefinementCost +import Whir.AnchorPrefixRefinementRows +import Whir.PCSRoundByRoundSourceDecoderCorrectness +import Whir.PCSRoundByRoundSourceDecoderCost diff --git a/verification/whir/Whir/AnchorPrefixRefinement.lean b/verification/whir/Whir/AnchorPrefixRefinement.lean new file mode 100644 index 000000000..50c8ba3c6 --- /dev/null +++ b/verification/whir/Whir/AnchorPrefixRefinement.lean @@ -0,0 +1,373 @@ +import Whir.AnchoredPhysicalAnchor +import Whir.CommitmentAnchor + +/-! Refinement of the source occupied-prefix loop. The executable recurrence is `AnchoredPhysicalAnchor.prefixStep`; all sums here are proof specifications only. -/ +namespace Whir.AnchorPrefixRefinement +open Concrete Protocol ExecutableOOD SuccinctPointWeight +open scoped BigOperators +set_option maxRecDepth 10000 +set_option maxHeartbeats 3200000 + +/-- Dense occupied-prefix equality weight on the lower `j` Boolean lane bits. -/ +noncomputable def occupiedPrefix (j count : Nat) (r x : Nat → E) : E := + ∑ u : Cube j, if cubeIndex u < count then + Whir.eqWeight (fun i => r i.val) u * Whir.eqWeight (fun i => x i.val) u else 0 + +noncomputable def full (j : Nat) (r x : Nat → E) : E := + ∏ i : Fin j, (1+r i.val+x i.val) + +lemma prefix_zero (j : Nat) (r x : Nat → E) : occupiedPrefix j 0 r x = 0 := by + simp [occupiedPrefix] + +lemma prefix_full (j : Nat) (r x : Nat → E) : occupiedPrefix j (2^j) r x = full j r x := by + simp only [occupiedPrefix, cubeIndex_lt, ↓reduceIte] + rw [show (∑ u : Cube j, Whir.eqWeight (fun i => r i.val) u * + Whir.eqWeight (fun i => x i.val) u) = + Whir.mle (Whir.eqWeight (fun i : Fin j => r i.val)) (fun i => x i.val) by + unfold Whir.mle innerProduct + apply Finset.sum_congr rfl + intro u _ + ring] + exact mle_eqWeight _ _ + +lemma full_zero (r x : Nat → E) : full 0 r x = 1 := by simp [full] +lemma full_succ (j : Nat) (r x : Nat → E) : + full (j+1) r x = full j r x * (1+r j+x j) := by + simp [full, Fin.prod_univ_castSucc] + +lemma prefix_base (count : Nat) (r x : Nat → E) : + occupiedPrefix 0 count r x = if 0 < count then 1 else 0 := by + simp [occupiedPrefix, cubeIndex, Whir.eqWeight] + +lemma eqWeight_nat_split (d k : Nat) (r : Nat → E) (a : Cube d) (b : Cube k) : + Whir.eqWeight (fun i : Fin (d+k) => r i.val) (Fin.addCases a b) = + Whir.eqWeight (fun i : Fin d => r i.val) a * + Whir.eqWeight (fun i : Fin k => r (d+i.val)) b := by + simp [Whir.eqWeight, Fin.prod_univ_add] + +lemma prefix_split (j count : Nat) (r x : Nat → E) : + occupiedPrefix (j+1) count r x = + (1+r j)*(1+x j)*occupiedPrefix j count r x + + (r j*x j)*occupiedPrefix j (count-2^j) r x := by + unfold occupiedPrefix + rw [← Equiv.sum_comp (cubeAppendEquiv j 1)] + simp only [Fintype.sum_prod_type, cubeAppendEquiv, Equiv.coe_fn_mk, + cubeIndex_append, eqWeight_nat_split] + rw [Finset.sum_comm, sum_cube_succ] + simp only [Fin.cons_zero, Bool.false_eq_true, ↓reduceIte, cubeIndex, + Nat.mul_zero, Nat.add_zero] + simp only [Whir.eqWeight, Fintype.sum_unique] + simp only [Fin.prod_univ_succ, Fin.prod_univ_zero, Fin.cons_zero, Fin.cons_succ, + Bool.false_eq_true, ↓reduceIte, Fin.val_zero, Nat.zero_add, Nat.add_zero, + CharTwo.sub_eq_add, mul_one] + simp only [show ∀ a : Cube j, cubeIndex a + 2^j < count ↔ + cubeIndex a < count-2^j by intro a; omega, Finset.mul_sum] + congr 1 <;> apply Finset.sum_congr rfl <;> intro a _ + all_goals split_ifs <;> first | omega | ring + +lemma prefix_of_ge (j count : Nat) (r x : Nat → E) (h : 2^j ≤ count) : + occupiedPrefix j count r x = full j r x := by + rw [← prefix_full] + unfold occupiedPrefix + apply Finset.sum_congr rfl + intro u _ + simp only [cubeIndex_lt, ↓reduceIte, + show cubeIndex u < count from lt_of_lt_of_le (cubeIndex_lt u) h] + +lemma remainder_succ (n j : Nat) : + n % 2^(j+1) = n % 2^j + 2^j*(n.testBit j).toNat := by + have h := Nat.mod_add_div (n % (2^j*2)) (2^j) + simpa only [pow_succ, Nat.mod_mul_right_mod, Nat.mod_mul_right_div_self, + Nat.toNat_testBit] using h.symm + +lemma prefix_remainder_succ (n j : Nat) (r x : Nat → E) : + occupiedPrefix (j+1) (n % 2^(j+1)) r x = + if n.testBit j then + (1+r j)*(1+x j)*full j r x + + (r j*x j)*occupiedPrefix j (n % 2^j) r x + else (1+r j)*(1+x j)*occupiedPrefix j (n % 2^j) r x := by + rw [prefix_split, remainder_succ] + have hlt := Nat.mod_lt n (Nat.two_pow_pos j) + cases hb : n.testBit j + · simp only [Bool.toNat_false, Nat.mul_zero, Nat.add_zero, Bool.false_eq_true, ↓reduceIte] + rw [Nat.sub_eq_zero_of_le (Nat.le_of_lt hlt), prefix_zero, mul_zero, add_zero] + · simp only [Bool.toNat_true, Nat.mul_one, ↓reduceIte] + rw [prefix_of_ge j _ r x (by omega)] + simp only [Nat.add_sub_cancel] + +lemma coordinate_lo (r x : E) : (1+r)*(1+x) = (1+r+x)+r*x := by ring + +open AnchoredPhysicalAnchor AnchoredHeaderCodec +open AnchorPrefixRefinementArith + +def laneCoordinates (shape : Shape) (r : Array E) (j : Nat) : E := + r[shape.logN-shape.logBatch+j]! + +/-- Before the first occupied count bit, `partial = 1` is a sentinel, never a claimed empty-prefix sum. The full cube is required only while unprocessed count bits can consume it. -/ +structure Invariant (shape : Shape) (r x : Array E) (j : Nat) (s : PrefixState) : Prop where + started : s.started = decide (shape.lanes % 2^j ≠ 0) + «partial» : s.partial = if shape.lanes % 2^j = 0 then 1 else + occupiedPrefix j (shape.lanes % 2^j) (laneCoordinates shape r) (laneCoordinates shape x) + full : shape.lanes >>> j ≠ 0 → + s.full = full j (laneCoordinates shape r) (laneCoordinates shape x) + +lemma initial_invariant (shape : Shape) (r x : Array E) : + Invariant shape r x 0 {} := by + constructor <;> simp [Nat.mod_one, full_zero] + +lemma step_invariant (shape : Shape) (r x : Array E) (j : Nat) (s : PrefixState) + (h : Invariant shape r x j s) : + Invariant shape r x (j+1) (prefixStep shape r x j s) := by + have hm := Nat.mod_lt shape.lanes (Nat.two_pow_pos j) + have hp := prefix_remainder_succ shape.lanes j (laneCoordinates shape r) (laneCoordinates shape x) + have hr := remainder_succ shape.lanes j + have hc : shape.lanes >>> (j+1) ≠ 0 → shape.lanes >>> j ≠ 0 := by + simp only [Nat.shiftRight_eq_div_pow, pow_succ] + intro hn hz + rw [← Nat.div_div_eq_div_mul, hz] at hn + simp at hn + have hbfull : shape.lanes.testBit j = true → shape.lanes >>> j ≠ 0 := by + simp only [Nat.testBit_eq_decide_div_mod_eq, decide_eq_true_eq, Nat.shiftRight_eq_div_pow] + intro hb hz + simp [hz] at hb + have startedStep : (prefixStep shape r x j s).started = (shape.lanes.testBit j || s.started) := by + cases hb : shape.lanes.testBit j <;> cases hs : s.started <;> + by_cases hn : shape.lanes >>> (j+1) ≠ 0 <;> + simp [prefixStep, prefixStepWith, native, native_factor, hb, hs, hn] + have partialStep : (prefixStep shape r x j s).partial = + if shape.lanes.testBit j then + (if s.started then laneCoordinates shape r j*laneCoordinates shape x j*s.partial else 0) + + (1+laneCoordinates shape r j+laneCoordinates shape x j+ + laneCoordinates shape r j*laneCoordinates shape x j) * + (if j = 0 then 1 else s.full) + else if s.started then + (1+laneCoordinates shape r j+laneCoordinates shape x j+ + laneCoordinates shape r j*laneCoordinates shape x j)*s.partial + else s.partial := by + cases hb : shape.lanes.testBit j <;> cases hs : s.started <;> + by_cases hn : shape.lanes >>> (j+1) ≠ 0 + all_goals + simp only [prefixStep, prefixStepWith, native, native_factor, hb, hs, hn, + Bool.or_false, Bool.or_true, Bool.false_eq_true, ↓reduceIte, laneCoordinates] + all_goals try (by_cases hj : j = 0 <;> simp [hj]) + all_goals first | rfl | (split <;> rfl) + have fullStep : (prefixStep shape r x j s).full = + if shape.lanes >>> (j+1) ≠ 0 then + (if j = 0 then 1+laneCoordinates shape r j+laneCoordinates shape x j + else s.full*(1+laneCoordinates shape r j+laneCoordinates shape x j)) + else s.full := by + cases hb : shape.lanes.testBit j <;> cases hs : s.started <;> + by_cases hn : shape.lanes >>> (j+1) ≠ 0 <;> + simp [prefixStep, prefixStepWith, native, native_factor, hb, hs, hn, laneCoordinates] + all_goals rfl + constructor + · rw [startedStep, h.started, hr] + cases hb : shape.lanes.testBit j <;> simp [Bool.toNat_false, Bool.toNat_true] + · rw [partialStep, h.started, h.partial] + cases hb : shape.lanes.testBit j + · simp only [hb, Bool.toNat_false, Nat.mul_zero, Nat.add_zero, Bool.false_eq_true, + ↓reduceIte] at hr hp ⊢ + rw [hr] + by_cases hz : shape.lanes % 2^j = 0 + · simp [hz] + · rw [hr] at hp + simp [hz] + rw [hp, coordinate_lo] + · have hf := h.full (hbfull hb) + have hn : shape.lanes % 2^(j+1) ≠ 0 := by + rw [hr]; simp only [hb, Bool.toNat_true, Nat.mul_one] + have ht := Nat.two_pow_pos j + omega + simp only [hb, Bool.toNat_true, Nat.mul_one, ↓reduceIte] at hr hp ⊢ + rw [ite_eq_right hn, hp] + have lower : (if j = 0 then (1 : E) else s.full) = + full j (laneCoordinates shape r) (laneCoordinates shape x) := by + split_ifs with hj + · subst j; simp [full_zero] + · exact hf + rw [lower, ← coordinate_lo] + by_cases hz : shape.lanes % 2^j = 0 + · simp [hz, prefix_zero] + · simp [hz]; ring + · intro hn + rw [fullStep, ite_eq_left hn] + have hf := h.full (hc hn) + split_ifs with hj + · subst j; simp [full_succ, full_zero] + · rw [hf, full_succ] + +lemma loop_invariant (shape : Shape) (r x : Array E) (j : Nat) : + Invariant shape r x j + ((List.range j).foldl (fun s i => prefixStep shape r x i s) {}) := by + induction j with + | zero => exact initial_invariant shape r x + | succ j ih => + rw [List.range_succ, List.foldl_append] + exact step_invariant shape r x j _ ih + +lemma eqTable_cube {n : Nat} (r : Fin n → E) (u : Cube n) : + (Concrete.eqTable (Array.ofFn r))[cubeIndex u]! = Whir.eqWeight r u := by + induction n with + | zero => simp [cubeIndex, Whir.eqWeight, Array.ofFn_zero] + | succ n ih => + rw [Array.ofFn_succ'] + have hh := TerminalRefinement.eqTable_cons_get (r 0) + (Array.ofFn (fun i => r i.succ)) (cubeIndex (fun i => u i.succ)) + (by simpa using cubeIndex_lt (fun i => u i.succ)) + have hu : u = Fin.cons (u 0) (fun i => u i.succ) := by + ext i; exact Fin.cases rfl (fun _ => rfl) i + rw [hu] + cases hb : u 0 + · simpa [cubeIndex_cons, ← hu, Whir.eqWeight, Fin.prod_univ_succ, hb, ih, + CharTwo.sub_eq_add, mul_comm] using hh.1 + · simpa [cubeIndex_cons, ← hu, Whir.eqWeight, Fin.prod_univ_succ, hb, ih, + mul_comm] using hh.2 + +lemma occupied_cube_mle (d k lanes : Nat) (r x : Nat → E) : + Whir.mle (fun u : Cube (d+k) => + if cubeIndex u < lanes*2^d then + Whir.eqWeight (fun i => r i.val) u else 0) (fun i => x i.val) = + full d r x * occupiedPrefix k lanes (fun j => r (d+j)) (fun j => x (d+j)) := by + unfold Whir.mle innerProduct + rw [← Equiv.sum_comp (cubeAppendEquiv d k)] + simp only [Fintype.sum_prod_type, cubeAppendEquiv, Equiv.coe_fn_mk, + cubeIndex_append, eqWeight_nat_split] + have bound (a : Cube d) (b : Cube k) : + cubeIndex a + 2^d*cubeIndex b < lanes*2^d ↔ cubeIndex b < lanes := by + have ha := cubeIndex_lt a + have hd := Nat.two_pow_pos d + constructor + · intro h + by_contra hn + have hb : lanes ≤ cubeIndex b := by omega + have hm := Nat.mul_le_mul_left (2^d) hb + rw [Nat.mul_comm lanes] at h + omega + · intro h + have hm := Nat.mul_le_mul_left (2^d) (show cubeIndex b+1 ≤ lanes by omega) + rw [Nat.mul_add] at hm + rw [Nat.mul_comm lanes] + simp only [Nat.mul_one] at hm + omega + simp_rw [bound] + rw [Finset.sum_comm] + have term (b : Cube k) : + (∑ a : Cube d, + (Whir.eqWeight (fun i : Fin d => x i.val) a * + Whir.eqWeight (fun i : Fin k => x (d+i.val)) b) * + if cubeIndex b < lanes then + Whir.eqWeight (fun i : Fin d => r i.val) a * + Whir.eqWeight (fun i : Fin k => r (d+i.val)) b else 0) = + full d r x * (if cubeIndex b < lanes then + Whir.eqWeight (fun i : Fin k => r (d+i.val)) b * + Whir.eqWeight (fun i : Fin k => x (d+i.val)) b else 0) := by + rw [← prefix_full] + unfold occupiedPrefix + simp only [cubeIndex_lt, ↓reduceIte, Finset.sum_mul] + apply Finset.sum_congr rfl + intro a _ + split_ifs <;> ring + simp_rw [term] + rw [← Finset.mul_sum] + rfl + +lemma ofFn_bang (a : Array E) : + Array.ofFn (fun i : Fin a.size => a[i.val]!) = a := by + convert Array.ofFn_getElem (xs := a) using 1 + apply congrArg Array.ofFn + funext i + exact getElem!_pos a i.val i.isLt + +lemma occupied_cube_mle_dim (n d k lanes : Nat) (hd : d+k = n) (r x : Nat → E) : + Whir.mle (fun u : Cube n => + if cubeIndex u < lanes*2^d then Whir.eqWeight (fun i => r i.val) u else 0) + (fun i => x i.val) = + full d r x * occupiedPrefix k lanes (fun j => r (d+j)) (fun j => x (d+j)) := by + subst n + exact occupied_cube_mle d k lanes r x + +lemma full_split_dim (n d k : Nat) (hd : d+k = n) (r x : Nat → E) : + full n r x = full d r x * full k (fun j => r (d+j)) (fun j => x (d+j)) := by + subst n + simp [full, Fin.prod_univ_add] + +lemma dense_weight (c : Config) (lanes : Nat) (r x : Array E) + (hr : r.size = c.logN) (hx : x.size = c.logN) + (hk : c.folds[0]! ≤ c.logN) : + Concrete.mle (CommitmentAnchor.weight c lanes r) x = + full (c.logN-c.folds[0]!) (fun j => r[j]!) (fun j => x[j]!) * + occupiedPrefix c.folds[0]! lanes + (fun j => r[c.logN-c.folds[0]!+j]!) + (fun j => x[c.logN-c.folds[0]!+j]!) := by + have hs : c.logN-c.folds[0]!+c.folds[0]! = c.logN := by omega + have rx : Array.ofFn (fun i : Fin c.logN => x[i.val]!) = x := by + apply Array.ext + · simp [hx] + · intro i hi hj + simp only [Array.getElem_ofFn] + exact getElem!_pos x i hj + have rr : Array.ofFn (fun i : Fin c.logN => r[i.val]!) = r := by + apply Array.ext + · simp [hr] + · intro i hi hj + simp only [Array.getElem_ofFn] + exact getElem!_pos r i hj + have er (u : Cube c.logN) : + (Concrete.eqTable r)[cubeIndex u]! = Whir.eqWeight (fun i => r[i.val]!) u := by + have h := eqTable_cube (fun i : Fin c.logN => r[i.val]!) u + rwa [rr] at h + conv_lhs => rw [← rx] + rw [ExecutableOOD.mle_eq_cube _ _ (by simp [CommitmentAnchor.weight])] + have hd : ExecutableOOD.decode c.logN (CommitmentAnchor.weight c lanes r) = + fun u => if cubeIndex u < lanes*2^(c.logN-c.folds[0]!) then + Whir.eqWeight (fun i => r[i.val]!) u else 0 := by + funext u + simp only [ExecutableOOD.decode, CommitmentAnchor.weight, + ArrayLayout.getElem!_tab _ _ _ (cubeIndex_lt u)] + rw [er] + simp only [← FieldModel.E_zero_def] + rw [hd] + exact occupied_cube_mle_dim c.logN (c.logN-c.folds[0]!) c.folds[0]! lanes hs + (fun j => r[j]!) (fun j => x[j]!) + +lemma low_fold (n : Nat) (r x : Nat → E) : + (List.range n).foldl (fun acc j => acc*(1+r j+x j)) 1 = full n r x := by + induction n with + | zero => simp [full_zero] + | succ n ih => simp only [List.range_succ, List.foldl_append, List.foldl_cons, + List.foldl_nil, ih, full_succ] + +lemma partial_terminal (shape : Shape) (r x : Array E) + (hn : 0 < shape.lanes) (hlt : shape.lanes < 2^shape.logBatch) : + ((List.range shape.logBatch).foldl (fun s i => prefixStep shape r x i s) {}).partial = + occupiedPrefix shape.logBatch shape.lanes (laneCoordinates shape r) (laneCoordinates shape x) := by + have hp := (loop_invariant shape r x shape.logBatch).partial + simpa only [Nat.mod_eq_of_lt hlt, Nat.ne_of_gt hn, ↓reduceIte] using hp + +/-- Source terminal evaluation equals the actual dense occupied-prefix claim. No lane-count power-of-two or selector-alignment restriction is imposed. -/ +theorem anchorAt_dense (c : Config) (shape : Shape) (r x : Array E) + (hN : shape.logN = c.logN) (hB : shape.logBatch = c.folds[0]!) + (occupied : 0 < shape.lanes ∧ shape.lanes ≤ 2^shape.logBatch) + (dimensions : shape.logBatch < shape.logN) + (hr : r.size = shape.logN) (hx : x.size = shape.logN) : + anchorAt shape r x = Concrete.mle (CommitmentAnchor.weight c shape.lanes r) x := by + rw [dense_weight c shape.lanes r x (hr.trans hN) (hx.trans hN) (by omega)] + by_cases hc : shape.lanes = 2^shape.logBatch + · simp only [anchorAt_unfold, hc, ↓reduceIte] + rw [low_fold, ← hB, prefix_full] + exact full_split_dim r.size (c.logN-shape.logBatch) shape.logBatch + (by omega) (fun j => r[j]!) (fun j => x[j]!) + · simp only [anchorAt_unfold, hc, ↓reduceIte] + rw [partial_terminal shape r x occupied.1 (by omega), low_fold] + have coords (a : Array E) : laneCoordinates shape a = + fun j => a[c.logN-c.folds[0]!+j]! := by + funext j + simp [laneCoordinates, hN, hB] + rw [coords r, coords x] + simp only [hN, hB] + +#print axioms step_invariant +#print axioms dense_weight +#print axioms anchorAt_dense + +end Whir.AnchorPrefixRefinement diff --git a/verification/whir/Whir/AnchorPrefixRefinementArith.lean b/verification/whir/Whir/AnchorPrefixRefinementArith.lean new file mode 100644 index 000000000..09798375a --- /dev/null +++ b/verification/whir/Whir/AnchorPrefixRefinementArith.lean @@ -0,0 +1,140 @@ +import Whir.AnchoredHeaderCodec + +/-! One operational source algorithm, parameterized by the primitive `Arith` operations shared by Native and Rows. No dense sum is used to execute the algorithm. -/ +namespace Whir.AnchorPrefixRefinementArith +open Concrete AnchoredHeaderCodec + +structure Arith (A : Type) where + one : A + add : A → A → A + addConst : A → E → A + mul : A → A → A + mulAdd : A → A → A → A + +structure PrefixStateWith (A : Type) [One A] where + full : A := 1 + «partial» : A := 1 + started : Bool := false + +def native : Arith E := + ⟨E.one, E.add, E.add, E.mul, fun a b c => E.add (E.mul a b) c⟩ + +/-- Source `eq_eval` on one contiguous coordinate segment. -/ +def eqEvalWith {A : Type} (a : Arith A) (n : Nat) (r x : Nat → A) : A := + (List.range n).foldl (fun acc j => a.mulAdd acc (a.add (r j) (x j)) acc) a.one + +def prefixStepWith {A : Type} [One A] (a : Arith A) (shape : Shape) + (r x : Nat → A) (j : Nat) (s : PrefixStateWith A) : PrefixStateWith A := + let logRows := shape.logN-shape.logBatch + let rj := r (logRows+j) + let xj := x (logRows+j) + let factor := a.addConst (a.add rj xj) E.one + let bit := shape.lanes.testBit j + let s := if bit || s.started then + let hi := a.mul rj xj + let lo := a.add factor hi + if bit then + let lowerFull := if j = 0 then lo else a.mul lo s.full + {s with «partial» := if s.started then a.mulAdd hi s.partial lowerFull else lowerFull, started := true} + else {s with «partial» := a.mul lo s.partial} + else s + if shape.lanes >>> (j+1) ≠ 0 then + {s with full := if j = 0 then factor else a.mul s.full factor} + else s + +def anchorAtWith {A : Type} [One A] (a : Arith A) (shape : Shape) + (n : Nat) (r x : Nat → A) : A := + if shape.lanes = 2^shape.logBatch then eqEvalWith a n r x + else + let low := eqEvalWith a (shape.logN-shape.logBatch) r x + let state := (List.range shape.logBatch).foldl + (fun s j => prefixStepWith a shape r x j s) ⟨a.one,a.one,false⟩ + a.mul low state.partial + +/-- Only primitive arithmetic semantics are assumed by an operational adapter, never an anchor-weight specification. -/ +structure Adapter {A : Type} (a : Arith A) (eval : A → E) : Prop where + one : eval a.one = E.one + add : ∀ u v, eval (a.add u v) = E.add (eval u) (eval v) + addConst : ∀ u c, eval (a.addConst u c) = E.add (eval u) c + mul : ∀ u v, eval (a.mul u v) = E.mul (eval u) (eval v) + mulAdd : ∀ u v w, eval (a.mulAdd u v w) = E.add (E.mul (eval u) (eval v)) (eval w) + +def mapState {A : Type} [One A] (eval : A → E) (s : PrefixStateWith A) : PrefixStateWith E := + ⟨eval s.full,eval s.partial,s.started⟩ + +lemma prefixStep_adapter {A : Type} [One A] (a : Arith A) (eval : A → E) + (h : Adapter a eval) (shape : Shape) (r x : Nat → A) (j : Nat) (s : PrefixStateWith A) : + mapState eval (prefixStepWith a shape r x j s) = + prefixStepWith native shape (eval ∘ r) (eval ∘ x) j (mapState eval s) := by + simp only [mapState] + cases hb : shape.lanes.testBit j <;> cases hs : s.started <;> + by_cases hn : shape.lanes >>> (j+1) ≠ 0 <;> by_cases hj : j = 0 + all_goals + simp only [prefixStepWith, hb, hs, Bool.or_false, Bool.or_true, + Bool.false_eq_true, ↓reduceIte] + simp [hn, hj, native, Function.comp_apply, h.add, h.addConst, h.mul, h.mulAdd, hs] + all_goals split_ifs <;> simp [h.add, h.addConst, h.mul, h.mulAdd, hs] + +lemma eqEval_adapter {A : Type} (a : Arith A) (eval : A → E) (h : Adapter a eval) + (n : Nat) (r x : Nat → A) : + eval (eqEvalWith a n r x) = eqEvalWith native n (eval ∘ r) (eval ∘ x) := by + unfold eqEvalWith + have fold (l : List Nat) (s : A) : + eval (l.foldl (fun acc j => a.mulAdd acc (a.add (r j) (x j)) acc) s) = + l.foldl (fun acc j => E.add (E.mul acc (E.add (eval (r j)) (eval (x j)))) acc) (eval s) := by + induction l generalizing s with + | nil => rfl + | cons j l ih => simp only [List.foldl_cons, ih, h.mulAdd, h.add] + simpa only [native, Function.comp_apply, h.one] using fold (List.range n) a.one + +lemma anchorAt_adapter {A : Type} [One A] (a : Arith A) (eval : A → E) (h : Adapter a eval) + (shape : Shape) (n : Nat) (r x : Nat → A) : + eval (anchorAtWith a shape n r x) = anchorAtWith native shape n (eval ∘ r) (eval ∘ x) := by + have fold (l : List Nat) (s : PrefixStateWith A) : + mapState eval (l.foldl (fun s j => prefixStepWith a shape r x j s) s) = + l.foldl (fun s j => prefixStepWith native shape (eval ∘ r) (eval ∘ x) j s) (mapState eval s) := by + induction l generalizing s with + | nil => rfl + | cons j l ih => rw [List.foldl_cons, List.foldl_cons, ih, prefixStep_adapter a eval h] + unfold anchorAtWith + split_ifs + · exact eqEval_adapter a eval h n r x + · rw [h.mul, eqEval_adapter a eval h] + have hs := congrArg PrefixStateWith.partial (fold (List.range shape.logBatch) ⟨a.one,a.one,false⟩) + simp only [mapState, h.one] at hs + simpa only [native] using congrArg (E.mul (eqEvalWith native (shape.logN-shape.logBatch) (eval ∘ r) (eval ∘ x))) hs + +/-- Arithmetic expressions preserve the source primitive distinction between `add_const` and `mul_add`. Their evaluation is the operational meaning of a Rows expression, not a correctness axiom about its final weight. -/ +inductive RowsExpr where + | constant (value : E) + | add (left right : RowsExpr) + | addConst (value : RowsExpr) (constant : E) + | mul (left right : RowsExpr) + | mulAdd (left right addend : RowsExpr) + +instance : One RowsExpr := ⟨.constant E.one⟩ +instance : Inhabited RowsExpr := ⟨.constant E.zero⟩ + +def rows : Arith RowsExpr := + ⟨.constant E.one,.add,.addConst,.mul,.mulAdd⟩ + +def RowsExpr.eval : RowsExpr → E + | .constant value => value + | .add left right => E.add left.eval right.eval + | .addConst value c => E.add value.eval c + | .mul left right => E.mul left.eval right.eval + | .mulAdd left right addend => E.add (E.mul left.eval right.eval) addend.eval + +lemma rows_adapter : Adapter rows RowsExpr.eval := by constructor <;> intros <;> rfl + +/-- Native and Rows execute the same source branch schedule and have equal terminal arithmetic. -/ +theorem native_rows_anchor (shape : Shape) (n : Nat) (r x : Nat → RowsExpr) : + (anchorAtWith rows shape n r x).eval = + anchorAtWith native shape n (RowsExpr.eval ∘ r) (RowsExpr.eval ∘ x) := + anchorAt_adapter rows RowsExpr.eval rows_adapter shape n r x + +#print axioms prefixStep_adapter +#print axioms anchorAt_adapter +#print axioms native_rows_anchor + +end Whir.AnchorPrefixRefinementArith diff --git a/verification/whir/Whir/AnchorPrefixRefinementCaller.lean b/verification/whir/Whir/AnchorPrefixRefinementCaller.lean new file mode 100644 index 000000000..22a1e055e --- /dev/null +++ b/verification/whir/Whir/AnchorPrefixRefinementCaller.lean @@ -0,0 +1,96 @@ +import Whir.AnchorPrefixRefinement + +/-! The anchored source caller refines the actual family, point claims, and final immutable occupied-prefix anchor batch. -/ +namespace Whir.AnchorPrefixRefinement +open Concrete Protocol CausalGame AnchoredHeaderCodec AnchoredPhysicalAnchor + +private def batchStep (lambda : E) (s : Claim × E) (claim : Claim) : Claim × E := + (⟨weightGlue s.1.weight claim.weight s.2, s.1.value+s.2*claim.value⟩, s.2*lambda) + +private lemma batch_power (lambda : E) (claims : List Claim) (s : Claim × E) : + (claims.foldl (batchStep lambda) s).2 = s.2*lambda^claims.length := by + induction claims generalizing s with + | nil => simp + | cons a tail ih => simp only [List.foldl_cons, ih, batchStep, List.length_cons, pow_succ]; ring + +lemma batchClaims_push (width : Nat) (claims : Array Claim) (claim : Claim) (lambda : E) : + batchClaims width (claims.push claim) lambda = + ⟨weightGlue (batchClaims width claims lambda).weight claim.weight (lambda^claims.size), + (batchClaims width claims lambda).value+lambda^claims.size*claim.value⟩ := by + have form (a : Array Claim) : batchClaims width a lambda = + (a.toList.foldl (batchStep lambda) (⟨tab width fun _ => 0,0⟩,1)).1 := by + unfold batchClaims + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind, Array.foldl_toList] + rfl + simp only [form, Array.toList_push, List.foldl_append, List.foldl_cons, List.foldl_nil, batchStep] + have power := batch_power lambda claims.toList (⟨tab width fun _ => 0,0⟩,1) + simp only [one_mul, Array.length_toList] at power + rw [power] + +noncomputable def anchoredClaims {m : Nat} (c : Config) (record : Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) : Array Claim := + (RingPCSGame.transformedClaims (2^c.logN) family points seed).push + ⟨CommitmentAnchor.weight c record.shape.lanes record.point.toArray, record.value⟩ + +lemma initialClaim_dense {m : Nat} (c : Config) (record : Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) : + AnchoredPhysicalAnchor.initialClaim record family points seed lambda = + (batchClaims (2^c.logN) (anchoredClaims c record family points seed) lambda).value := by + rw [anchoredClaims, batchClaims_push] + simp only [AnchoredPhysicalAnchor.initialClaim] + rw [WHIRNativeArithmetic.initialClaim_eq_batch_value (2^c.logN)] + simp [RingPCSGame.transformedClaims, Nat.add_comm] + +lemma callerAt_dense {m : Nat} (c : Config) (record : Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) + (valid : record.Valid) (hN : record.shape.logN = c.logN) + (hB : record.shape.logBatch = c.folds[0]!) + (familyShape : SuccinctRingWeight.FamilyShape c.logN family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape c.logN points[i]) + (x : Array E) (hx : x.size = c.logN) : + callerAt record family points seed lambda x = + Concrete.mle (batchClaims (2^c.logN) (anchoredClaims c record family points seed) lambda).weight x := by + rw [anchoredClaims, batchClaims_push] + rw [AccumulatedTerminalAlgebra.mle_weightGlue _ _ _ _ + (by simp [hx]) (by simp [CommitmentAnchor.weight])] + rw [callerAt, anchorAt_dense c record.shape record.point.toArray x hN hB + ⟨by have := valid.1.2.2.2.2.1; omega, valid.1.2.2.2.2.2⟩ valid.1.1 + (by simpa using valid.2.2) (hx.trans hN.symm)] + have old := SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle family points seed lambda x + (by simpa [hx] using familyShape) (by simpa [hx] using pointShapes) + rw [old] + simp only [RingPCSGame.transformedClaims, Array.size_append, Array.size_map] + simp [hx, Nat.add_comm] + +/-- The native terminal equality now includes the actual supported anchor, with the same final batching power as its retained value. -/ +theorem sourceVerify_refines {m : Nat} (record : Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) (c : Config) (ch : Challenges) + (proof : Opening) (root : Oracle) + (valid : record.Valid) (hN : record.shape.logN = c.logN) + (hB : record.shape.logBatch = c.folds[0]!) + (familyShape : SuccinctRingWeight.FamilyShape c.logN family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape c.logN points[i]) + (weightShape : shapeValid c record.shape.lanes + (batchClaims (2^c.logN) (anchoredClaims c record family points seed) lambda).weight = true) + (rootShape : oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) record.shape.lanes = true) + (roots : WHIRNativeArithmetic.RootShapes c proof) + (authenticated : WHIRNativeArithmetic.AuthenticatedRows c ch proof root) + (success : AnchoredPhysicalAnchor.sourceVerify record family points seed lambda c ch proof = .ok ()) : + Protocol.verify c ch record.shape.lanes root + (batchClaims (2^c.logN) (anchoredClaims c record family points seed) lambda).weight + (batchClaims (2^c.logN) (anchoredClaims c record family points seed) lambda).value proof = .ok () := by + have refined := WHIRNativeArithmetic.nativeVerify_refines c ch record.shape.lanes + (AnchoredPhysicalAnchor.initialClaim record family points seed lambda) + (callerAt record family points seed lambda) proof _ root weightShape rootShape roots authenticated + (callerAt_dense c record family points seed lambda valid hN hB familyShape pointShapes) success + rwa [initialClaim_dense] at refined + +#print axioms initialClaim_dense +#print axioms callerAt_dense +#print axioms sourceVerify_refines + +end Whir.AnchorPrefixRefinement diff --git a/verification/whir/Whir/AnchorPrefixRefinementCost.lean b/verification/whir/Whir/AnchorPrefixRefinementCost.lean new file mode 100644 index 000000000..d99df008b --- /dev/null +++ b/verification/whir/Whir/AnchorPrefixRefinementCost.lean @@ -0,0 +1,74 @@ +import Whir.AnchorPrefixRefinement + +/-! Field-operation accounting for the very same source recurrence. A fused `mul_add` costs one multiplication and one addition. Constants, register copies, and Boolean branching are not field operations. This is not a machine-time or recursive-row-count model. -/ +namespace Whir.AnchorPrefixRefinementCost +open Concrete AnchoredHeaderCodec AnchoredPhysicalAnchor + +/-- Exact source branch charge: two additions build the factor; occupied branches build hi and lo; only higher nonzero count bits update full. -/ +def stepCharge (shape : Shape) (j : Nat) (started : Bool) : Nat := + 2 + (if shape.lanes.testBit j || started then + 2 + (if shape.lanes.testBit j then + (if j = 0 then 0 else 1) + (if started then 2 else 0) + else 1) + else 0) + + (if shape.lanes >>> (j+1) ≠ 0 then if j = 0 then 0 else 1 else 0) + +def countedStep (shape : Shape) (r x : Array E) (j : Nat) (s : PrefixState × Nat) : PrefixState × Nat := + (prefixStep shape r x j s.1, s.2+stepCharge shape j s.1.started) + +lemma stepCharge_bound (shape : Shape) (j : Nat) (started : Bool) : stepCharge shape j started ≤ 8 := by + unfold stepCharge + split_ifs <;> omega + +lemma counted_fold (shape : Shape) (r x : Array E) (l : List Nat) (s : PrefixState × Nat) : + (l.foldl (fun s j => countedStep shape r x j s) s).1 = + l.foldl (fun s j => prefixStep shape r x j s) s.1 ∧ + (l.foldl (fun s j => countedStep shape r x j s) s).2 ≤ s.2+8*l.length := by + induction l generalizing s with + | nil => simp + | cons j l ih => + have h := ih (countedStep shape r x j s) + constructor + · simpa only [List.foldl_cons, countedStep] using h.1 + · have hc := stepCharge_bound shape j s.1.started + simp only [List.foldl_cons, List.length_cons] + apply le_trans h.2 + change s.2+stepCharge shape j s.1.started+8*l.length ≤ s.2+8*(l.length+1) + omega + +/-- Returning the source value and its own arithmetic charge, not a hypothetical dense-table backend charge. -/ +def countedAnchorAt (shape : Shape) (r x : Array E) : E × Nat := + if shape.lanes = 2^shape.logBatch then (anchorAt shape r x,3*r.size) + else + let result := (List.range shape.logBatch).foldl + (fun s j => countedStep shape r x j s) ({},0) + (AnchorPrefixRefinementArith.native.mul + (AnchorPrefixRefinementArith.eqEvalWith AnchorPrefixRefinementArith.native + (shape.logN-shape.logBatch) (fun i => r[i]!) (fun i => x[i]!)) result.1.partial, + 3*(shape.logN-shape.logBatch)+result.2+1) + +lemma countedAnchorAt_value (shape : Shape) (r x : Array E) : + (countedAnchorAt shape r x).1 = anchorAt shape r x := by + have hv := (counted_fold shape r x (List.range shape.logBatch) ({},0)).1 + unfold countedAnchorAt anchorAt AnchorPrefixRefinementArith.anchorAtWith + split_ifs + · rfl + · dsimp only + rw [hv] + rfl + +/-- Linear source arithmetic bound, including the full-cube fast branch and all low coordinates. The high-coordinate DP never allocates or evaluates an intermediate cube. -/ +theorem countedAnchorAt_bound (shape : Shape) (r x : Array E) (hr : r.size = shape.logN) : + (countedAnchorAt shape r x).2 ≤ 3*shape.logN+8*shape.logBatch+1 := by + have hb := (counted_fold shape r x (List.range shape.logBatch) ({},0)).2 + simp only [List.length_range, Nat.zero_add] at hb + unfold countedAnchorAt + split_ifs + · simp only [hr]; omega + · simp only + have hs : shape.logN-shape.logBatch ≤ shape.logN := Nat.sub_le _ _ + omega + +#print axioms countedAnchorAt_value +#print axioms countedAnchorAt_bound +end Whir.AnchorPrefixRefinementCost diff --git a/verification/whir/Whir/AnchorPrefixRefinementRows.lean b/verification/whir/Whir/AnchorPrefixRefinementRows.lean new file mode 100644 index 000000000..6e1b6d9c3 --- /dev/null +++ b/verification/whir/Whir/AnchorPrefixRefinementRows.lean @@ -0,0 +1,42 @@ +import Whir.AnchorPrefixRefinement + +/-! The shared Rows arithmetic expression adapter reaches the same occupied-prefix dense claim as Native. This theorem does not assert a physical circuit-row-count bound or a separate compiler correctness theorem. -/ +namespace Whir.AnchorPrefixRefinementRows +open Concrete Protocol AnchoredHeaderCodec AnchorPrefixRefinementArith + +/-- The Rows entry point is just the shared source algorithm on arithmetic expressions. -/ +def rowsAnchorAt (shape : Shape) (r x : Array RowsExpr) : RowsExpr := + anchorAtWith rows shape r.size (fun j => r[j]!) (fun j => x[j]!) + +lemma eval_map_bang (a : Array RowsExpr) (j : Nat) : + (a.map RowsExpr.eval)[j]! = (a[j]!).eval := by + by_cases hj : j < a.size + · rw [getElem!_pos (a.map RowsExpr.eval) j (by simpa using hj), + getElem!_pos a j hj, Array.getElem_map] + · rw [getElem!_neg (a.map RowsExpr.eval) j (by simpa using hj), getElem!_neg a j hj] + rfl + +/-- Operational Native/Rows adapter, with primitive expression semantics proved rather than a final correct-weight premise. -/ +theorem rowsAnchorAt_native (shape : Shape) (r x : Array RowsExpr) : + (rowsAnchorAt shape r x).eval = + AnchoredPhysicalAnchor.anchorAt shape (r.map RowsExpr.eval) (x.map RowsExpr.eval) := by + rw [rowsAnchorAt, native_rows_anchor] + unfold AnchoredPhysicalAnchor.anchorAt + simp only [Array.size_map] + congr 1 <;> funext j <;> simp [Function.comp_apply, eval_map_bang] + +/-- Full-cube and arbitrary occupied-prefix Rows arithmetic reach the actual dense anchor encoding. -/ +theorem rowsAnchorAt_dense (c : Config) (shape : Shape) (r x : Array RowsExpr) + (hN : shape.logN = c.logN) (hB : shape.logBatch = c.folds[0]!) + (occupied : 0 < shape.lanes ∧ shape.lanes ≤ 2^shape.logBatch) + (dimensions : shape.logBatch < shape.logN) + (hr : r.size = shape.logN) (hx : x.size = shape.logN) : + (rowsAnchorAt shape r x).eval = + Concrete.mle (CommitmentAnchor.weight c shape.lanes (r.map RowsExpr.eval)) (x.map RowsExpr.eval) := by + rw [rowsAnchorAt_native] + exact AnchorPrefixRefinement.anchorAt_dense c shape _ _ hN hB occupied dimensions + (by simpa using hr) (by simpa using hx) + +#print axioms rowsAnchorAt_native +#print axioms rowsAnchorAt_dense +end Whir.AnchorPrefixRefinementRows diff --git a/verification/whir/Whir/AnchorPrefixRefinementSmoke.lean b/verification/whir/Whir/AnchorPrefixRefinementSmoke.lean new file mode 100644 index 000000000..b7d737fdc --- /dev/null +++ b/verification/whir/Whir/AnchorPrefixRefinementSmoke.lean @@ -0,0 +1,27 @@ +import Whir.AnchoredPhysicalAnchor +import Whir.CommitmentAnchor + +/-! Executable source DP compared with the existing dense encoder, including nonzero high coordinates and the full-cube branch. -/ +namespace Whir.AnchorPrefixRefinementSmoke +open Concrete Protocol AnchoredPhysicalAnchor AnchoredHeaderCodec + +def config : Config := ⟨5, #[3], #[1], #[1], #[0]⟩ +def shape (lanes : Nat) : Shape := ⟨5, 3, 1, lanes⟩ +def point (salt : Nat) : Array E := Array.ofFn fun j : Fin 5 => + ⟨UInt64.ofNat (salt+3*j.val), UInt64.ofNat (salt+j.val+7), 11⟩ + +def smoke : IO Unit := do + for lanes in [1, 3, 8] do + let actual := anchorAt (shape lanes) (point 7) (point 23) + let dense := Concrete.mle (CommitmentAnchor.weight config lanes (point 7)) (point 23) + unless actual == dense do + throw (IO.userError s!"anchor source DP differs from dense occupied weight: lanes={lanes}") + let symbolic := AnchorPrefixRefinementArith.anchorAtWith AnchorPrefixRefinementArith.rows + (shape lanes) 5 (fun j => .constant ((point 7)[j]!)) (fun j => .constant ((point 23)[j]!)) + unless symbolic.eval == actual do + throw (IO.userError s!"shared Rows arithmetic differs from Native: lanes={lanes}") + IO.println s!"anchor source Native/Rows DP = dense occupied weight: lanes={lanes}, logN=5, logBatch=3" + +end Whir.AnchorPrefixRefinementSmoke + +def main : IO Unit := Whir.AnchorPrefixRefinementSmoke.smoke diff --git a/verification/whir/Whir/AnchoredByteStreamCausal.lean b/verification/whir/Whir/AnchoredByteStreamCausal.lean new file mode 100644 index 000000000..8f05b58bb --- /dev/null +++ b/verification/whir/Whir/AnchoredByteStreamCausal.lean @@ -0,0 +1,176 @@ +import Whir.AnchoredByteStreamGroups + +/-! Any first raw query into a recognized original point run allocates its whole +byte vector. Later queries, even with different block indices, reuse that same +immutable run. Off-image queries and complete public replies are preserved. -/ +namespace Whir.AnchoredByteStreamCausal +open Concrete FiatShamirGame DuplexFraming DuplexModeGame +open RawOracleCoupling RawOracleCoupling.Concrete TypedOracleCompiler +open AnchoredFiatShamirSecurityCodec AnchoredByteStreamGroups + +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +variable (Q dimension : Nat) (iv : Digest32) (accept : FramedHistory → Bool) + +abbrev Packet := {run : Run Q dimension iv // accept run.history = true} + +private theorem run_ext {a b : Run Q dimension iv} (history : a.history = b.history) : a = b := by + cases a + cases b + cases history + rfl + +private theorem packet_key_injective (positive : 0 < blockCount dimension) : + Function.Injective (fun packet : Packet Q dimension iv accept => + key packet.val ⟨0,positive⟩) := by + intro a b same + dsimp only at same + have hb := key_decodes b.val ⟨0,positive⟩ + rw [← same] at hb + have h := (key_decodes a.val ⟨0,positive⟩).symm.trans hb + apply Subtype.ext + apply run_ext + exact congrArg Coordinate.history (Option.some.inj h) + +@[instance_reducible] noncomputable def packetFintype (positive : 0 < blockCount dimension) : + Fintype (Packet Q dimension iv accept) := + Fintype.ofInjective (fun packet => key packet.val ⟨0,positive⟩) + (packet_key_injective Q dimension iv accept positive) + +noncomputable def recognize (raw : RawKey Q) : + Option (Sigma (fun _ : Packet Q dimension iv accept => Fin (blockCount dimension))) := do + let q ← WHIRHeaderRoots.decodeRaw iv raw + match q.terminal with + | .output block => + if good : accept q.history = true ∧ + (∀ i : Fin (blockCount dimension), + DuplexEncoding.Admissible (⟨q.history,.output i.val⟩ : Coordinate)) ∧ + (∀ i : Fin (blockCount dimension), + pathCost (⟨q.history,.output i.val⟩ : Coordinate) ≤ Q) ∧ + block < blockCount dimension then + some ⟨⟨⟨q.history,good.2.1,good.2.2.1⟩,good.1⟩,⟨block,good.2.2.2⟩⟩ + else none + | _ => none + +def encode (c : Sigma (fun _ : Packet Q dimension iv accept => Fin (blockCount dimension))) : + RawKey Q := key c.1.val c.2 + +theorem recognize_encode (c : Sigma + (fun _ : Packet Q dimension iv accept => Fin (blockCount dimension))) : + recognize Q dimension iv accept (encode Q dimension iv accept c) = some c := by + rcases c with ⟨⟨⟨history,admissible,bounded⟩,accepted⟩,i⟩ + simp [recognize, encode, key_decodes, coordinate, accepted, admissible, bounded] + +theorem encode_recognize (raw : RawKey Q) (c : Sigma + (fun _ : Packet Q dimension iv accept => Fin (blockCount dimension))) + (recognized : recognize Q dimension iv accept raw = some c) : + encode Q dimension iv accept c = raw := by + unfold recognize at recognized + cases decoded : WHIRHeaderRoots.decodeRaw iv raw with + | none => simp [decoded] at recognized + | some q => + simp only [decoded] at recognized + dsimp only [Bind.bind, Option.bind] at recognized + cases terminal : q.terminal with + | output block => + rw [terminal] at recognized + dsimp only at recognized + split at recognized + · rename_i good + have eq := Option.some.inj recognized + subst c + obtain ⟨bound,valid,exactRaw⟩ := WHIRHeaderRoots.decodeRaw_sound iv raw q decoded + simpa [encode, key, coordinate, ← terminal] using exactRaw + · contradiction + | commitment consumed => simp [terminal] at recognized + | powBase consumed bits => simp [terminal] at recognized + +noncomputable def partition : Partition (RawKey Q) (Packet Q dimension iv accept) + (fun _ => Fin (blockCount dimension)) where + encode := encode Q dimension iv accept + recognize := recognize Q dimension iv accept + recognize_encode := recognize_encode Q dimension iv accept + encode_recognize := encode_recognize Q dimension iv accept + +/-- The recognizer is exact, including flags, IV, path holes and all raw bits. +A physical header predicate is read from the key history, never its answer. -/ +theorem recognized_history (raw : RawKey Q) (c : Sigma + (fun _ : Packet Q dimension iv accept => Fin (blockCount dimension))) + (recognized : recognize Q dimension iv accept raw = some c) : + WHIRHeaderRoots.decodeRaw iv raw = some (coordinate c.1.val c.2) := by + rw [← encode_recognize Q dimension iv accept raw c recognized] + exact key_decodes c.1.val c.2 + +noncomputable def request {R : Type} {n : Nat} + (next : Digest32 → Sampling ((partition Q dimension iv accept).Key) + ((partition Q dimension iv accept).Answer (D := Digest32)) R n) (raw : RawKey Q) : + Sampling ((partition Q dimension iv accept).Key) + ((partition Q dimension iv accept).Answer (D := Digest32)) R (n+1) := + match h : recognize Q dimension iv accept raw with + | some c => .draw (.inl c.1) (fun blocks => next (blocks c.2)) + | none => .draw (.inr ⟨raw,h⟩) next + +noncomputable def compile {R : Type} : {n : Nat} → + Sampling (RawKey Q) (fun _ => Digest32) R n → + Sampling ((partition Q dimension iv accept).Key) + ((partition Q dimension iv accept).Answer (D := Digest32)) R n + | _, .ret result => .ret result + | _, .draw raw next => request Q dimension iv accept + (fun answer => compile (next answer)) raw + +theorem compile_eval {R : Type} {n : Nat} + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) + (table : RawKey Q → Digest32) : + Sampling.eval ((partition Q dimension iv accept).split table) + (compile Q dimension iv accept source) = Sampling.eval table source := by + induction source with + | ret result => rfl + | draw raw next ih => + unfold compile request + split + · rename_i c h + simp only [Sampling.eval, Partition.split, ih] + change Sampling.eval table (next (table (encode Q dimension iv accept c))) = _ + rw [encode_recognize Q dimension iv accept raw c h] + · simp only [Sampling.eval, Partition.split, ih] + +/-- Exact coupling for every adaptive raw continuation. The actual requested +full block is exposed; proactive coordinates are not additional raw replies. -/ +theorem causal_raw_distribution {R : Type} {n : Nat} + (positive : 0 < blockCount dimension) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) (payoff : R → ℚ) : + average (fun table : RawKey Q → Digest32 => payoff (Sampling.eval table source)) = + Sampling.expectation (fun result => payoff result.1) + (RawOracleCoupling.memo (compile Q dimension iv accept source) (fun _ => none)) := by + classical + let _ := packetFintype Q dimension iv accept positive + rw [← RawOracleCoupling.empty_table_eq_memo] + have h := RawOracleCoupling.average_equiv + ((partition Q dimension iv accept).tableEquiv (D := Digest32)) + (fun table => payoff (Sampling.eval table (compile Q dimension iv accept source))) + simpa only [Partition.tableEquiv, Equiv.coe_fn_mk, compile_eval] using h + +/-- The completed whole-run cache is also preserved jointly; a final observer +may inspect all allocated public bytes without a restricted-observer premise. -/ +theorem causal_full_distribution {R : Type} {n : Nat} + (positive : 0 < blockCount dimension) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) + (payoff : R × TypedFiatShamirGame.Cache ((partition Q dimension iv accept).Key) + ((partition Q dimension iv accept).Answer (D := Digest32)) → ℚ) : + average (fun table : RawKey Q → Digest32 => payoff + (Sampling.eval ((partition Q dimension iv accept).split table) + (RawOracleCoupling.memo (compile Q dimension iv accept source) (fun _ => none)))) = + Sampling.expectation payoff + (RawOracleCoupling.memo (compile Q dimension iv accept source) (fun _ => none)) := by + classical + let _ := packetFintype Q dimension iv accept positive + have h := RawOracleCoupling.average_equiv + ((partition Q dimension iv accept).tableEquiv (D := Digest32)) + (fun table => payoff (Sampling.eval table + (RawOracleCoupling.memo (compile Q dimension iv accept source) (fun _ => none)))) + exact h.trans (RawOracleCoupling.table_eq_memo_full _ (fun _ => none) payoff) + +end Whir.AnchoredByteStreamCausal + +#print axioms Whir.AnchoredByteStreamCausal.causal_raw_distribution +#print axioms Whir.AnchoredByteStreamCausal.causal_full_distribution diff --git a/verification/whir/Whir/AnchoredByteStreamGroups.lean b/verification/whir/Whir/AnchoredByteStreamGroups.lean new file mode 100644 index 000000000..95ba8164c --- /dev/null +++ b/verification/whir/Whir/AnchoredByteStreamGroups.lean @@ -0,0 +1,173 @@ +import Whir.AnchoredFiatShamirSecurityROM +import Whir.WHIRHeaderRoots + +/-! Exact output-run raw fibers. Freshness is checked against chronological raw +answers, not postulated for arbitrary source challenge keys. All other raw +answers and all retained bytes remain in the joint public view. -/ +namespace Whir.AnchoredByteStreamGroups +open Concrete FiatShamirGame DuplexFraming DuplexModeGame +open RawOracleCoupling.Concrete AnchoredFiatShamirSecurityCodec +open CommitmentAnchor ParameterBounds +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +structure Run (Q dimension : Nat) (iv : Digest32) where + history : FramedHistory + admissible : ∀ i : Fin (blockCount dimension), + DuplexEncoding.Admissible (⟨history,.output i.val⟩ : Coordinate) + bounded : ∀ i : Fin (blockCount dimension), + pathCost (⟨history,.output i.val⟩ : Coordinate) ≤ Q + +def coordinate {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) + (i : Fin (blockCount dimension)) : Coordinate := ⟨run.history,.output i.val⟩ + +def key {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) + (i : Fin (blockCount dimension)) : RawKey Q := + constructionKey Q iv (coordinate run i) (run.bounded i) + +theorem key_decodes {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) + (i : Fin (blockCount dimension)) : + WHIRHeaderRoots.decodeRaw iv (key run i) = some (coordinate run i) := + WHIRHeaderRoots.decodeRaw_construction iv _ (run.admissible i) (run.bounded i) + +theorem key_injective {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) : + Function.Injective (key run) := by + intro i j same + have h := (key_decodes run i).symm.trans (same ▸ key_decodes run j) + have hq := Option.some.inj h + have ht := congrArg Coordinate.terminal hq + exact Fin.ext (Terminal.output.inj ht) + +abbrev Outside {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) := + {raw : RawKey Q // ¬ ∃ i, key run i = raw} + +noncomputable def rawParts {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) : + (RawKey Q → Digest32) ≃ (Blocks dimension × (Outside run → Digest32)) where + toFun table := (fun i => table (key run i), fun raw => table raw.val) + invFun parts := fun raw => if h : ∃ i, key run i = raw then parts.1 (Classical.choose h) + else parts.2 ⟨raw,h⟩ + left_inv table := by + funext raw + dsimp + split + · rename_i h + exact congrArg table (Classical.choose_spec h) + · rfl + right_inv parts := by + classical + apply Prod.ext + · funext i + dsimp + have h : ∃ j, key run j = key run i := ⟨i,rfl⟩ + simp only [h, dite_true] + exact congrArg parts.1 (key_injective run (Classical.choose_spec h)) + · funext raw + dsimp + simp only [raw.property, dite_false] + +noncomputable def jointParts {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) : + (RawKey Q → Digest32) ≃ (Joint dimension × (Outside run → Digest32)) := + (rawParts run).trans (Equiv.prodCongr (vectorParts dimension) (Equiv.refl _)) + +/-- No oracle observer is excluded: the point, suffix and complete remaining +raw table are preserved together, including arbitrary known-answer observers. -/ +theorem joint_public_average {Q dimension : Nat} {iv : Digest32} + (run : Run Q dimension iv) + (payoff : Joint dimension × (Outside run → Digest32) → ℚ) : + average (fun table : RawKey Q → Digest32 => payoff (jointParts run table)) = + average payoff := RawOracleCoupling.average_equiv (jointParts run) payoff + +abbrev ByteHistory (Q : Nat) := List (RawKey Q × Digest32) + +def Fresh {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) + (past : ByteHistory Q) : Prop := ∀ i entry, entry ∈ past → key run i ≠ entry.1 + +noncomputable def eligible {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) + (past : ByteHistory Q) : Bool := by + classical + exact decide (Fresh run past) + +theorem eligible_fresh {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) + (past : ByteHistory Q) (checked : eligible run past = true) : Fresh run past := by + classical + simpa [eligible] using checked + +def agrees {Q : Nat} (past : ByteHistory Q) (table : RawKey Q → Digest32) : Prop := + ∀ entry ∈ past, table entry.1 = entry.2 + +noncomputable def outsideAgrees {Q dimension : Nat} {iv : Digest32} + (run : Run Q dimension iv) (past : ByteHistory Q) (fresh : Fresh run past) + (rest : Outside run → Digest32) : Prop := + ∀ entry (member : entry ∈ past), rest ⟨entry.1,by + rintro ⟨i,h⟩ + exact fresh i entry member h⟩ = entry.2 + +theorem agrees_joint {Q dimension : Nat} {iv : Digest32} (run : Run Q dimension iv) + (past : ByteHistory Q) (fresh : Fresh run past) (table : RawKey Q → Digest32) : + agrees past table ↔ outsideAgrees run past fresh (jointParts run table).2 := by + rfl + +/-- Exact causal fiber equality. Conditioning on every chronological raw reply +leaves the joint point and residual uniform, and leaves all other answers +available. The prepare step may use the whole completed history. -/ +theorem fresh_history_average {Q dimension : Nat} {iv : Digest32} + (run : Run Q dimension iv) (past : ByteHistory Q) (checked : eligible run past = true) + (payoff : Joint dimension → (Outside run → Digest32) → ℚ) : + average (fun table : RawKey Q → Digest32 => + if agrees past table then payoff (jointParts run table).1 (jointParts run table).2 else 0) = + average (fun rest : Outside run → Digest32 => + if outsideAgrees run past (eligible_fresh run past checked) rest then + average (fun answer : Joint dimension => payoff answer rest) else 0) := by + classical + have h := joint_public_average run (fun parts => + if outsideAgrees run past (eligible_fresh run past checked) parts.2 then + payoff parts.1 parts.2 else 0) + simp only [← agrees_joint] at h + rw [h, WHIRObservableSecurity.average_product, RawOracleCoupling.average_comm] + apply congrArg average + funext rest + split <;> simp only [average_const] + +/-- The source root and lanes are frozen inputs on this fresh chronological +fiber. The same choose-list ambiguity bound applies to real byte-stream points. -/ +theorem fresh_group_ambiguity {Q : Nat} {iv : Digest32} (p : Profile) + (run : Run Q (config p).logN iv) (past : ByteHistory Q) + (checked : eligible run past = true) (lanes : Nat) (root : CausalGame.BaseOracle) + (occupied : lanes ≤ 2^(config p).folds[0]!) : + average (fun table : RawKey Q → Digest32 => + if agrees past table ∧ Ambiguous p lanes root (jointParts run table).1.1 + then (1 : ℚ) else 0) ≤ + average (fun table : RawKey Q → Digest32 => if agrees past table then (1 : ℚ) else 0) / + 2^124 := by + classical + have badBound : average (fun answer : Joint (config p).logN => + if Ambiguous p lanes root answer.1 then (1 : ℚ) else 0) ≤ (1 : ℚ)/2^124 := by + rw [WHIRObservableSecurity.average_product] + change average (fun pt : Fin (config p).logN → E => + average (fun _ : Residual (config p).logN => + if Ambiguous p lanes root pt then (1 : ℚ) else 0)) ≤ _ + simp_rw [average_const] + have bound := ambiguity_probability_numeric p lanes root occupied + simpa only [average, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using bound + have lhs := fresh_history_average run past checked (fun answer _ => + if Ambiguous p lanes root answer.1 then (1 : ℚ) else 0) + have rhs := fresh_history_average run past checked (fun _ _ => (1 : ℚ)) + simp only [average_const] at rhs + simp only [ite_and] at * + rw [lhs, rhs] + calc + _ ≤ average (fun rest : Outside run → Digest32 => + (if outsideAgrees run past (eligible_fresh run past checked) rest then (1 : ℚ) else 0) / + 2^124) := by + apply average_mono + intro rest + by_cases h : outsideAgrees run past (eligible_fresh run past checked) rest + · simpa [h] using badBound + · simp [h] + _ = _ := by simp only [average, Finset.sum_div, div_div, mul_comm] + +end Whir.AnchoredByteStreamGroups + +#print axioms Whir.AnchoredByteStreamGroups.joint_public_average +#print axioms Whir.AnchoredByteStreamGroups.fresh_history_average +#print axioms Whir.AnchoredByteStreamGroups.fresh_group_ambiguity diff --git a/verification/whir/Whir/AnchoredByteStreamPrepared.lean b/verification/whir/Whir/AnchoredByteStreamPrepared.lean new file mode 100644 index 000000000..7195998e3 --- /dev/null +++ b/verification/whir/Whir/AnchoredByteStreamPrepared.lean @@ -0,0 +1,329 @@ +import Whir.AnchoredByteStreamCausal + +/-! Causal preparation on actual completed raw-byte history. The earliest query +into any point block prepares the root, then allocates the entire byte run. +All later indices reuse the immutable original record. -/ +namespace Whir.AnchoredByteStreamPrepared +open Concrete Protocol CausalGame ParameterBounds CommitmentAnchor FiatShamirGame +open TypedOracleCompiler RawOracleCoupling RawOracleCoupling.Concrete +open AnchoredFiatShamirSecurityCodec AnchoredByteStreamGroups +open AnchoredByteStreamCausal +open DuplexFraming DuplexModeGame + +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 + +variable {p : Profile} {Q : Nat} {iv : Digest32} {accept : FramedHistory → Bool} + +abbrev PointPacket (p : Profile) (Q : Nat) (iv : Digest32) (accept : FramedHistory → Bool) := + Packet Q (config p).logN iv accept +abbrev Records := AnchoredFiatShamirSecurity.Cache p (PointPacket p Q iv accept) +abbrev Group := (partition Q (config p).logN iv accept).Key +abbrev Reply := (partition Q (config p).logN iv accept).Answer (D := Digest32) +abbrev GroupCache := TypedFiatShamirGame.Cache (Group (p := p) (Q := Q) (iv := iv) (accept := accept)) + (Reply (p := p) (Q := Q) (iv := iv) (accept := accept)) + +structure Policy (p : Profile) (Q : Nat) (iv : Digest32) (accept : FramedHistory → Bool) where + prepare : ByteHistory Q → PointPacket p Q iv accept → AnchoredFiatShamirSecurity.PreAnchor p + advertise : ByteHistory Q → PointPacket p Q iv accept → Joint (config p).logN → E + +noncomputable def step (policy : Policy p Q iv accept) (past : ByteHistory Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (packet : PointPacket p Q iv accept) (blocks : Blocks (config p).logN) := + AnchoredFiatShamirSecurity.advance + { choose := fun _ => packet + prepare := fun _ _ => policy.prepare past packet + advertise := fun _ _ answer => policy.advertise past packet answer } + records (vectorParts (config p).logN blocks) + +theorem repeated_original (policy : Policy p Q iv accept) (past : ByteHistory Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (packet : PointPacket p Q iv accept) (e : AnchoredFiatShamirSecurity.Entry p _) + (hit : AnchoredFiatShamirSecurity.lookup records packet = some e) + (blocks : Blocks (config p).logN) : step policy past records packet blocks = e :: records := by + exact AnchoredFiatShamirSecurity.repeated_key _ records e hit _ + +noncomputable def compile (policy : Policy p Q iv accept) {R : Type} : {n : Nat} → + Sampling (RawKey Q) (fun _ => Digest32) R n → ByteHistory Q → + Records (p := p) (Q := Q) (iv := iv) (accept := accept) → + Sampling (Group (p := p) (Q := Q) (iv := iv) (accept := accept)) + (Reply (p := p) (Q := Q) (iv := iv) (accept := accept)) + (R × Records (p := p) (Q := Q) (iv := iv) (accept := accept)) n + | _, .ret result, _, records => .ret (result,records) + | _, .draw raw next, past, records => + match h : recognize Q (config p).logN iv accept raw with + | some c => .draw (.inl c.1) (fun blocks => + compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + | none => .draw (.inr ⟨raw,h⟩) (fun answer => + compile policy (next answer) ((raw,answer)::past) records) + +private def Seen (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (cache : GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept)) : Prop := + ∀ packet blocks, cache (.inl packet) = some blocks → + ∃ e, AnchoredFiatShamirSecurity.lookup records packet = some e + +private theorem step_clean (policy : Policy p Q iv accept) (past : ByteHistory Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (clean : ¬ AnchoredFiatShamirSecurity.Dirty records) (packet : PointPacket p Q iv accept) + (blocks : Blocks (config p).logN) + (separated : ¬ Ambiguous p (policy.prepare past packet).lanes + (policy.prepare past packet).root (point (config p).logN blocks)) : + ¬ AnchoredFiatShamirSecurity.Dirty (step policy past records packet blocks) := by + classical + unfold step AnchoredFiatShamirSecurity.advance + dsimp only + cases hit : AnchoredFiatShamirSecurity.lookup records packet with + | none => + simp only [AnchoredFiatShamirSecurity.Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨separated,clean⟩ + | some e => + have member : e ∈ records := List.mem_of_find?_eq_some hit + simp only [AnchoredFiatShamirSecurity.Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨fun bad => clean ⟨e,member,bad⟩,clean⟩ + +private theorem step_seen (policy : Policy p Q iv accept) (past : ByteHistory Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (cache : GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept)) (seen : Seen records cache) + (packet : PointPacket p Q iv accept) (blocks : Blocks (config p).logN) : + Seen (step policy past records packet blocks) (TypedFiatShamirGame.put cache (.inl packet) blocks) := by + classical + intro wanted value present + unfold step AnchoredFiatShamirSecurity.advance + dsimp only + cases hit : AnchoredFiatShamirSecurity.lookup records packet with + | none => + by_cases same : wanted = packet + · subst wanted + refine ⟨⟨packet, + ⟨(policy.prepare past packet).lanes,(policy.prepare past packet).root, + (vectorParts (config p).logN blocks).1, + policy.advertise past packet (vectorParts (config p).logN blocks), + (policy.prepare past packet).occupied⟩, + (vectorParts (config p).logN blocks).2⟩,?_⟩ + simp [AnchoredFiatShamirSecurity.lookup] + · have old : cache (.inl wanted) = some value := by + simpa [TypedFiatShamirGame.put, same] using present + obtain ⟨e,found⟩ := seen wanted value old + exact ⟨e,by simpa [AnchoredFiatShamirSecurity.lookup, Ne.symm same] using found⟩ + | some e => + by_cases same : wanted = packet + · subst wanted + refine ⟨e,?_⟩ + have keyeq : e.key = packet := by + have member := List.find?_some hit + simpa using member + simp [AnchoredFiatShamirSecurity.lookup, keyeq] + · have old : cache (.inl wanted) = some value := by + simpa [TypedFiatShamirGame.put, same] using present + obtain ⟨other,found⟩ := seen wanted value old + have keyeq : e.key = packet := by + have member := List.find?_some hit + simpa using member + exact ⟨other,by simpa [AnchoredFiatShamirSecurity.lookup, keyeq, Ne.symm same] using found⟩ + +private theorem ambiguity_average (pre : AnchoredFiatShamirSecurity.PreAnchor p) : + average (fun blocks : Blocks (config p).logN => + if Ambiguous p pre.lanes pre.root (point (config p).logN blocks) then (1 : ℚ) else 0) ≤ + (1 : ℚ)/2^124 := by + rw [vector_point_average (config p).logN + (fun pt => if Ambiguous p pre.lanes pre.root pt then (1 : ℚ) else 0)] + have h := ambiguity_probability_numeric p pre.lanes pre.root pre.occupied.2 + simpa only [average, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using h + +private theorem memo_bound (policy : Policy p Q iv accept) {R : Type} {n : Nat} + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) (past : ByteHistory Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (cache : GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept)) + (seen : Seen records cache) (clean : ¬ AnchoredFiatShamirSecurity.Dirty records) : + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (compile policy source past records) cache) ≤ (n : ℚ)/2^124 := by + classical + induction source generalizing past records cache with + | ret result => + simp only [compile, RawOracleCoupling.memo, Sampling.expectation, clean, ↓reduceIte] + positivity + | @draw n raw next ih => + unfold compile + split + · rename_i c recognized + cases cached : cache (.inl c.1) with + | some blocks => + obtain ⟨e,hit⟩ := seen c.1 blocks cached + have repeated := repeated_original policy past records c.1 e hit blocks + have nextClean : ¬ AnchoredFiatShamirSecurity.Dirty (step policy past records c.1 blocks) := by + rw [repeated] + have member : e ∈ records := List.mem_of_find?_eq_some hit + simp only [AnchoredFiatShamirSecurity.Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨fun bad => clean ⟨e,member,bad⟩,clean⟩ + have nextSeen : Seen (step policy past records c.1 blocks) cache := by + have s := step_seen policy past records cache seen c.1 blocks + have putSame : TypedFiatShamirGame.put cache (.inl c.1) blocks = cache := by + funext k + by_cases same : k = .inl c.1 + · subst k; simp [cached] + · simp [TypedFiatShamirGame.put_other _ _ _ _ same] + simpa [putSame] using s + simp only [RawOracleCoupling.memo, cached, Sampling.expectation_pad] + exact (ih (blocks c.2) _ _ _ nextSeen nextClean).trans + (div_le_div_of_nonneg_right (by exact_mod_cast Nat.le_succ n) (by positivity)) + | none => + simp only [RawOracleCoupling.memo, cached, Sampling.expectation] + have fiber (blocks : Blocks (config p).logN) : + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks)) ≤ + (if Ambiguous p (policy.prepare past c.1).lanes (policy.prepare past c.1).root + (point (config p).logN blocks) then 1 else 0) + (n : ℚ)/2^124 := by + by_cases bad : Ambiguous p (policy.prepare past c.1).lanes (policy.prepare past c.1).root + (point (config p).logN blocks) + · have one := Sampling.expectation_le_one + (fun result : (R × Records (p := p) (Q := Q) (iv := iv) (accept := accept)) × + GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept) => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (fun result => by split <;> norm_num) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks)) + simpa [bad] using one.trans (le_add_of_nonneg_right (by positivity : 0 ≤ (n : ℚ)/2^124)) + · simpa [bad] using ih (blocks c.2) _ _ _ + (step_seen policy past records cache seen c.1 blocks) + (step_clean policy past records clean c.1 blocks bad) + have averaged := average_mono fiber + have badBound := ambiguity_average (policy.prepare past c.1) + have bound : + average (fun blocks : Blocks (config p).logN => + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks))) ≤ + (1 : ℚ)/2^124 + (n : ℚ)/2^124 := averaged.trans (by + rw [average_add, average_const] + exact add_le_add badBound le_rfl) + have arithmetic : (1 : ℚ)/2^124 + (n : ℚ)/2^124 = + ((n+1 : Nat) : ℚ)/2^124 := by push_cast; ring + refine le_trans (le_of_eq ?_) (bound.trans_eq arithmetic) + refine @RawOracleCoupling.average_equiv + (Reply (p := p) (Q := Q) (iv := iv) (accept := accept) (.inl c.1)) + (Blocks (config p).logN) ?_ ?_ (Equiv.refl (Blocks (config p).logN)) + (fun blocks : Blocks (config p).logN => + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks))) + · rename_i unrecognized + have updatedSeen (answer : Digest32) : + Seen records (TypedFiatShamirGame.put cache (.inr ⟨raw,unrecognized⟩) answer) := by + intro packet blocks present + apply seen packet blocks + simpa [TypedFiatShamirGame.put] using present + cases cached : cache (.inr ⟨raw,unrecognized⟩) with + | some answer => + simp only [RawOracleCoupling.memo, cached, Sampling.expectation_pad] + exact (ih answer _ _ _ seen clean).trans + (div_le_div_of_nonneg_right (by exact_mod_cast Nat.le_succ n) (by positivity)) + | none => + simp only [RawOracleCoupling.memo, cached, Sampling.expectation] + apply (average_mono (fun answer => ih answer _ _ _ (updatedSeen answer) clean)).trans + rw [average_const] + exact div_le_div_of_nonneg_right (by exact_mod_cast Nat.le_succ n) (by positivity) + +/-- Genuine adaptive source-key preparation. Roots depend on the completed raw +history, including every fourth word actually queried. First contact may be ANY +point block; the whole run is memoized and repeats preserve the same point. +No fresh-source-key assumption occurs in this theorem. -/ +theorem causal_prepared_ambiguity {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) : + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)) ≤ (n : ℚ)/2^124 := + memo_bound policy source [] [] (fun _ => none) + (by intro packet blocks present; contradiction) + (by simp [AnchoredFiatShamirSecurity.Dirty]) + +private theorem profile_blocks : ∀ p : Profile, 0 < blockCount (config p).logN := by + decide +kernel + +noncomputable def execution (policy : Policy p Q iv accept) {R : Type} {n : Nat} + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) (table : RawKey Q → Digest32) := + Sampling.eval ((partition Q (config p).logN iv accept).split table) + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)) + +private theorem compile_result {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) (past : ByteHistory Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (table : RawKey Q → Digest32) : + (Sampling.eval ((partition Q (config p).logN iv accept).split table) + (compile policy source past records)).1 = Sampling.eval table source := by + induction source generalizing past records with + | ret result => rfl + | draw raw next ih => + unfold compile + split + · rename_i c recognized + simp only [Sampling.eval, Partition.split, ih] + change Sampling.eval table + (next (table (AnchoredByteStreamCausal.encode Q (config p).logN iv accept c))) = _ + rw [AnchoredByteStreamCausal.encode_recognize Q (config p).logN iv accept raw c recognized] + · simp only [Sampling.eval, Partition.split, ih] + +/-- The compiler changes no raw reply or continuation. Its extra state consists +only of the immutable prepared records and the memoized complete point runs. -/ +theorem execution_result {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) (table : RawKey Q → Digest32) : + (execution policy source table).1.1 = Sampling.eval table source := by + unfold execution + rw [RawOracleCoupling.memo_eval_first, RawOracleCoupling.overlay_empty] + rw [compile_result] + +/-- Joint coupling includes the actual source result, immutable records and +private grouped cache. No part of any public raw answer is erased. -/ +theorem prepared_full_distribution {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) + (payoff : (R × Records (p := p) (Q := Q) (iv := iv) (accept := accept)) × + GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept) → ℚ) : + average (fun table : RawKey Q → Digest32 => payoff (execution policy source table)) = + Sampling.expectation payoff + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)) := by + classical + let _ := packetFintype Q (config p).logN iv accept (profile_blocks p) + have h := RawOracleCoupling.average_equiv + ((partition Q (config p).logN iv accept).tableEquiv (D := Digest32)) + (fun table => payoff (Sampling.eval table + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)))) + rw [show average (fun table : RawKey Q → Digest32 => payoff (execution policy source table)) = + average (fun table => payoff (Sampling.eval table + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)))) from h] + exact RawOracleCoupling.table_eq_memo_full _ (fun _ => none) payoff + +theorem prepared_raw_table_ambiguity {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) : + Soundness.uniformProb (Finset.univ.filter fun table : RawKey Q → Digest32 => + AnchoredFiatShamirSecurity.Dirty (execution policy source table).1.2) ≤ (n : ℚ)/2^124 := by + classical + have h := prepared_full_distribution policy source + (fun result => if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + have bound := causal_prepared_ambiguity policy source + rw [← h] at bound + simpa only [average, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using bound + + +end Whir.AnchoredByteStreamPrepared + +#print axioms Whir.AnchoredByteStreamPrepared.repeated_original +#print axioms Whir.AnchoredByteStreamPrepared.causal_prepared_ambiguity +#print axioms Whir.AnchoredByteStreamPrepared.execution_result +#print axioms Whir.AnchoredByteStreamPrepared.prepared_full_distribution +#print axioms Whir.AnchoredByteStreamPrepared.prepared_raw_table_ambiguity diff --git a/verification/whir/Whir/AnchoredByteStreamSmoke.lean b/verification/whir/Whir/AnchoredByteStreamSmoke.lean new file mode 100644 index 000000000..a2b5571bc --- /dev/null +++ b/verification/whir/Whir/AnchoredByteStreamSmoke.lean @@ -0,0 +1,40 @@ +import Whir.AnchoredByteStreamSampler + +/-! Executable byte-codec fixture, not a replacement oracle or a cryptographic +assumption. Coordinate one consumes the fourth word of block zero and then the +first two words of block one. All public answers are recovered exactly. -/ +namespace Whir.AnchoredByteStreamSmoke +open Concrete FiatShamirGame AnchoredFiatShamirSecurityCodec + +def fixture : Blocks 3 := fun block byte => + ⟨32*block.val+byte.val, by have hb : block.val < 3 := block.isLt; have := byte.isLt; omega⟩ + +def decodedBytes : List (List Nat) := List.ofFn (fun j : Fin 3 => + List.ofFn (fun i : Fin 24 => (ByteCodec.encodeE (point 3 fixture j) i).val)) + +def expected : List (List Nat) := List.ofFn (fun j : Fin 3 => + List.ofFn (fun i : Fin 24 => 24*j.val+i.val)) + +def straddlingSmoke : Bool := decodedBytes == expected && + decide (blockCount 28 = 21) && decide (residualCount 3 = 24) && + decide ((vectorParts 3 fixture).2 ⟨0,by decide⟩ = (⟨72,by decide⟩ : Byte)) + +#eval straddlingSmoke + +example : blockCount 28 = 21 := by decide +kernel +example : residualCount 3 = 24 := by decide +kernel + +/-- The first byte of the second scalar really is the observable fourth word, +not the first word of a second independent digest. -/ +example : (ByteCodec.encodeE (point 3 fixture ⟨1,by decide⟩) ⟨0,by decide⟩).val = 24 := by + decide +kernel + +example : (ByteCodec.encodeE (point 3 fixture ⟨1,by decide⟩) ⟨8,by decide⟩).val = 32 := by + decide +kernel + +end Whir.AnchoredByteStreamSmoke + +def main : IO Unit := do + unless Whir.AnchoredByteStreamSmoke.straddlingSmoke do + throw (IO.userError "Byte-stream scalar straddling or retained-suffix check failed") + IO.println "byte_stream_smoke=passed: contiguous scalars, fourth-word straddling, retained suffix" diff --git a/verification/whir/Whir/AnchoredFiatShamirSecurity.lean b/verification/whir/Whir/AnchoredFiatShamirSecurity.lean new file mode 100644 index 000000000..c4146d34b --- /dev/null +++ b/verification/whir/Whir/AnchoredFiatShamirSecurity.lean @@ -0,0 +1,279 @@ +import Whir.CommitmentAnchor +import Whir.AnchoredFiatShamirSecurityCodec + +/-! Finite deferred-sampling anchored game. Roots and shapes are chosen from the +completed public cache, not from the unanswered point. A repeated key returns +its entire immutable record; it is not a new chance to choose a root or value. +This is the byte-stream anchor reference game, not a native verifier body theorem. -/ +namespace Whir.AnchoredFiatShamirSecurity +open Concrete Protocol CausalGame ParameterBounds CommitmentAnchor +open scoped BigOperators +set_option maxRecDepth 100000 +set_option maxHeartbeats 1000000 +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +abbrev Point (p : Profile) := Fin (config p).logN → E + +/-- The complete retained suffix of the final 32-byte output block is public. -/ +abbrev Tail (p : Profile) := AnchoredFiatShamirSecurityCodec.Residual (config p).logN +abbrev Answer (p : Profile) := Point p × Tail p + +def Samples (p : Profile) : Nat → Type + | 0 => Unit + | n+1 => Answer p × Samples p n + +noncomputable instance samplesFintype (p : Profile) : (n : Nat) → Fintype (Samples p n) + | 0 => inferInstanceAs (Fintype Unit) + | n+1 => by + letI := samplesFintype p n + exact inferInstanceAs (Fintype (Answer p × Samples p n)) + +instance samplesNonempty (p : Profile) : (n : Nat) → Nonempty (Samples p n) + | 0 => inferInstanceAs (Nonempty Unit) + | n+1 => by + let := samplesNonempty p n + exact inferInstanceAs (Nonempty (Answer p × Samples p n)) + +/-- The concrete grouped answer space consists of exactly ceil(24*logN/32) +output blocks from one contiguous run, starting at cursor zero. -/ +def DigestSamples (p : Profile) : Nat → Type + | 0 => Unit + | n+1 => AnchoredFiatShamirSecurityCodec.Blocks (config p).logN × DigestSamples p n + +instance digestSamplesFintype (p : Profile) : (n : Nat) → Fintype (DigestSamples p n) + | 0 => inferInstanceAs (Fintype Unit) + | n+1 => by + letI := digestSamplesFintype p n + exact inferInstanceAs (Fintype (AnchoredFiatShamirSecurityCodec.Blocks (config p).logN × + DigestSamples p n)) + +def digestSamplesCodec (p : Profile) : (n : Nat) → DigestSamples p n ≃ Samples p n + | 0 => Equiv.refl Unit + | n+1 => Equiv.prodCongr + (AnchoredFiatShamirSecurityCodec.vectorParts (config p).logN) (digestSamplesCodec p n) + +private theorem uniform_equiv {A B : Type} [Fintype A] [Fintype B] + (e : A ≃ B) (P : B → Prop) : + Soundness.uniformProb (Finset.univ.filter fun a : A => P (e a)) = + Soundness.uniformProb (Finset.univ.filter P) := by + classical + have h := RawOracleCoupling.average_equiv e (fun b => if P b then (1 : ℚ) else 0) + simpa only [FiatShamirGame.average, Soundness.uniformProb, Finset.card_filter, + Nat.cast_sum, Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using h + +/-- This record is supplied BEFORE the fresh answer. -/ +structure PreAnchor (p : Profile) where + lanes : Nat + root : BaseOracle + occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]! + +structure Entry (p : Profile) (Key : Type) where + key : Key + commitment : Commitment p + discarded : Tail p + +abbrev Cache (p : Profile) (Key : Type) := List (Entry p Key) + +/-- All adaptive decisions see completed cache entries only. The advertised +value can depend on the newly returned point; the root and shape cannot. -/ +structure Policy (p : Profile) (Key : Type) where + choose : Cache p Key → Key + prepare : Cache p Key → Key → PreAnchor p + advertise : Cache p Key → Key → Answer p → E + +noncomputable def lookup {p : Profile} {Key : Type} (cache : Cache p Key) (key : Key) := + cache.find? (fun e => decide (e.key = key)) + +noncomputable def advance {p : Profile} {Key : Type} (policy : Policy p Key) + (cache : Cache p Key) (answer : Answer p) : Cache p Key := + let key := policy.choose cache + match lookup cache key with + | some e => e :: cache + | none => + let pre := policy.prepare cache key + ⟨key, ⟨pre.lanes,pre.root,answer.1,policy.advertise cache key answer,pre.occupied⟩, + answer.2⟩ :: cache + +/-- Unused coordinates at repeated keys are ignored, not reprogrammed. Every +fresh coordinate is independent uniform; the experiment has at most n queries. -/ +noncomputable def run {p : Profile} {Key : Type} (policy : Policy p Key) : + (n : Nat) → Cache p Key → Samples p n → Cache p Key + | 0, cache, _ => cache + | n+1, cache, sample => run policy n (advance policy cache sample.1) sample.2 + +def Dirty {p : Profile} {Key : Type} (cache : Cache p Key) : Prop := + ∃ e ∈ cache, Ambiguous p e.commitment.lanes e.commitment.root e.commitment.point + +/-- A hit returns the same entire record and discarded public words. Logging +the repeat permits arbitrary subsequent adaptive decisions, without resampling. -/ +theorem repeated_key {p : Profile} {Key : Type} (policy : Policy p Key) + (cache : Cache p Key) (e : Entry p Key) + (hit : lookup cache (policy.choose cache) = some e) (answer : Answer p) : + advance policy cache answer = e :: cache := by + simp [advance, hit] + +private theorem clean_advance {p : Profile} {Key : Type} (policy : Policy p Key) + (cache : Cache p Key) (clean : ¬ Dirty cache) (answer : Answer p) + (separated : ¬ Ambiguous p (policy.prepare cache (policy.choose cache)).lanes + (policy.prepare cache (policy.choose cache)).root answer.1) : + ¬ Dirty (advance policy cache answer) := by + classical + unfold advance + dsimp only + cases hit : lookup cache (policy.choose cache) with + | none => + simp only [Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨separated, clean⟩ + | some e => + have member : e ∈ cache := List.mem_of_find?_eq_some hit + simp only [Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨fun bad => clean ⟨e,member,bad⟩,clean⟩ + +private theorem projection_probability {A B : Type} [Fintype A] [Fintype B] + [Nonempty B] (P : A → Prop) : + Soundness.uniformProb (Finset.univ.filter fun x : A × B => P x.1) = + Soundness.uniformProb (Finset.univ.filter P) := by + classical + have sets : (Finset.univ.filter fun x : A × B => P x.1) = + (Finset.univ.filter P) ×ˢ (Finset.univ : Finset B) := by ext x; simp + rw [sets] + simp only [Soundness.uniformProb, Finset.card_product, Finset.card_univ, + Fintype.card_prod, Nat.cast_mul] + exact mul_div_mul_right _ _ (by positivity) + +/-- Actual finite adaptive union/fiber bound. Preparation at round i can depend +on every previous root, point and advertised value. No independence of an +adversarially selected final root from the points is postulated. -/ +theorem adaptive_ambiguity_probability {p : Profile} {Key : Type} + (policy : Policy p Key) (n : Nat) (cache : Cache p Key) (clean : ¬ Dirty cache) : + Soundness.uniformProb (Finset.univ.filter fun samples : Samples p n => + Dirty (run policy n cache samples)) ≤ (n : ℚ) / 2^124 := by + classical + induction n generalizing cache with + | zero => simp [run, clean, Soundness.uniformProb] + | succ n ih => + change Soundness.uniformProb (Finset.univ.filter fun samples : Answer p × Samples p n => + Dirty (run policy n (advance policy cache samples.1) samples.2)) ≤ _ + have bound := RingMapBatching.conditional_error (A := Answer p) (B := Samples p n) + (fun answer => Ambiguous p (policy.prepare cache (policy.choose cache)).lanes + (policy.prepare cache (policy.choose cache)).root answer.1) + (fun sample : Answer p × Samples p n => + Dirty (run policy n (advance policy cache sample.1) sample.2)) + ((1 : ℚ)/2^124) ((n : ℚ)/2^124) + (div_nonneg (Nat.cast_nonneg n) (pow_nonneg (by norm_num) _)) + (by + rw [projection_probability] + exact ambiguity_probability_numeric p _ _ + (policy.prepare cache (policy.choose cache)).occupied.2) + (by + intro answer separated + exact ih (advance policy cache answer) + (clean_advance policy cache clean answer separated)) + convert bound using 1 + push_cast + ring + +/-- With the compression cap also bounding fresh anchor-key attempts, adaptive +root grinding costs at most 2^-64, not the one-root 2^-124 term. -/ +theorem adaptive_ambiguity_numeric {p : Profile} {Key : Type} + (policy : Policy p Key) (n : Nat) (attempts : n ≤ 2^60) : + Soundness.uniformProb (Finset.univ.filter fun samples : Samples p n => + Dirty (run policy n [] samples)) ≤ (1 : ℚ)/2^64 := by + apply (adaptive_ambiguity_probability policy n [] (by simp [Dirty])).trans + have h : (n : ℚ) ≤ 2^60 := by exact_mod_cast attempts + exact (div_le_div_of_nonneg_right h (by positivity)).trans (by norm_num) + +/-- The final root/shape/point must be an actual immutable cache entry. Selection +may inspect ALL completed attempts, including failed ones. -/ +abbrev Selector {p : Profile} {Key : Type} (policy : Policy p Key) (n : Nat) := + (samples : Samples p n) → Option {e : Entry p Key // e ∈ run policy n [] samples} + +/-- The final advertised value may be chosen after all point grinding. It then +belongs to the immutable commitment identity used in every opening session. -/ +def chosenCommitment {p : Profile} {Key : Type} (e : Entry p Key) (v : E) : Commitment p := + {e.commitment with value := v} + +noncomputable def Failure {p : Profile} {Key : Type} (policy : Policy p Key) + (n : Nat) (select : Selector policy n) + (advertised : Samples p n → E) + (opening : Samples p n → Array Claim) (strategy : Samples p n → Strategy) + (sample : Samples p n × Tape (config p)) : Prop := + match select sample.1 with + | none => False + | some e => openingFailure p (chosenCommitment e.val (advertised sample.1)) + (opening sample.1) (strategy sample.1) sample.2 + +/-- One fresh causal opening tape is composed with a fully adaptive chosen +anchor. Its selector is CommitmentAnchor.boundWitness of that immutable record; +the anchor claim is included in the opening/resource cap. This is binding, +not an efficient extractor and not a native Fiat--Shamir transport theorem. -/ +theorem adaptive_unique_opening_probability {p : Profile} {Key : Type} + (policy : Policy p Key) (n : Nat) (select : Selector policy n) + (advertised : Samples p n → E) + (opening : Samples p n → Array Claim) (strategy : Samples p n → Strategy) + (opening_cap : ∀ samples, (opening samples).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter (Failure policy n select advertised opening strategy)) ≤ + (n : ℚ)/2^124 + (1 : ℚ)/2^73 := by + classical + apply RingMapBatching.conditional_error + (fun samples => Dirty (run policy n [] samples)) _ _ _ (by positivity) + (adaptive_ambiguity_probability policy n [] (by simp [Dirty])) + intro samples clean + cases h : select samples with + | none => simp [Failure, h, Soundness.uniformProb] + | some e => + have separated : ¬ Ambiguous p e.val.commitment.lanes e.val.commitment.root + e.val.commitment.point := fun bad => clean ⟨e.val,e.property,bad⟩ + simpa only [Failure, h] using + (unique_opening_probability p (chosenCommitment e.val (advertised samples)) + separated (opening samples) + (strategy samples)).trans (production_interactive p _ (opening_cap samples)) + +theorem adaptive_unique_opening_numeric {p : Profile} {Key : Type} + (policy : Policy p Key) (n : Nat) (attempts : n ≤ 2^60) (select : Selector policy n) + (advertised : Samples p n → E) + (opening : Samples p n → Array Claim) (strategy : Samples p n → Strategy) + (opening_cap : ∀ samples, (opening samples).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter (Failure policy n select advertised opening strategy)) ≤ + (1 : ℚ)/2^64 + (1 : ℚ)/2^73 := by + apply (adaptive_unique_opening_probability policy n select advertised opening strategy opening_cap).trans + apply add_le_add _ le_rfl + have h : (n : ℚ) ≤ 2^60 := by exact_mod_cast attempts + exact (div_le_div_of_nonneg_right h (by positivity)).trans (by norm_num) + +/-- Finite byte-stream grouped-digest reference experiment, retaining all public +bytes and consistent cached repeats. Exact raw-key causal grouping is supplied +by AnchoredByteStreamCausal and AnchoredByteStreamPrepared. This opening term +still uses an independent causal tape, not the deployed byte-stream body. -/ +theorem grouped_digest_unique_opening_numeric {p : Profile} {Key : Type} + (policy : Policy p Key) (n : Nat) (attempts : n ≤ 2^60) (select : Selector policy n) + (advertised : Samples p n → E) + (opening : Samples p n → Array Claim) (strategy : Samples p n → Strategy) + (opening_cap : ∀ samples, (opening samples).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter fun raw : + DigestSamples p n × Tape (config p) => + Failure policy n select advertised opening strategy + (digestSamplesCodec p n raw.1,raw.2)) ≤ + (1 : ℚ)/2^64 + (1 : ℚ)/2^73 := by + have transport := uniform_equiv + (Equiv.prodCongr (digestSamplesCodec p n) (Equiv.refl (Tape (config p)))) + (Failure policy n select advertised opening strategy) + have same : + Soundness.uniformProb (Finset.univ.filter fun raw : + DigestSamples p n × Tape (config p) => + Failure policy n select advertised opening strategy + (digestSamplesCodec p n raw.1,raw.2)) = + Soundness.uniformProb (Finset.univ.filter + (Failure policy n select advertised opening strategy)) := by + simpa only [Equiv.prodCongr_apply, Prod.map, Equiv.refl_apply] using transport + rw [same] + exact adaptive_unique_opening_numeric policy n attempts select advertised opening strategy opening_cap + +end Whir.AnchoredFiatShamirSecurity + +#print axioms Whir.AnchoredFiatShamirSecurity.repeated_key +#print axioms Whir.AnchoredFiatShamirSecurity.adaptive_ambiguity_probability +#print axioms Whir.AnchoredFiatShamirSecurity.adaptive_ambiguity_numeric +#print axioms Whir.AnchoredFiatShamirSecurity.adaptive_unique_opening_probability +#print axioms Whir.AnchoredFiatShamirSecurity.adaptive_unique_opening_numeric +#print axioms Whir.AnchoredFiatShamirSecurity.grouped_digest_unique_opening_numeric diff --git a/verification/whir/Whir/AnchoredFiatShamirSecurityCodec.lean b/verification/whir/Whir/AnchoredFiatShamirSecurityCodec.lean new file mode 100644 index 000000000..c23315848 --- /dev/null +++ b/verification/whir/Whir/AnchoredFiatShamirSecurityCodec.lean @@ -0,0 +1,111 @@ +import Whir.WHIRObservableSecurity +import Whir.DuplexRefinement + +/-! The deployed sampler consumes consecutive 24-byte scalars from one 32-byte +output stream. Full oracle blocks remain public, including the retained suffix. -/ +namespace Whir.AnchoredFiatShamirSecurityCodec +open Concrete FiatShamirGame +open scoped BigOperators + +def blockCount (dimension : Nat) : Nat := (24*dimension+31)/32 +def residualCount (dimension : Nat) : Nat := 32*blockCount dimension-24*dimension +abbrev Blocks (dimension : Nat) := Fin (blockCount dimension) → Digest32 +abbrev Residual (dimension : Nat) := Fin (residualCount dimension) → Byte +abbrev Joint (dimension : Nat) := (Fin dimension → E) × Residual dimension + +theorem block_capacity (dimension : Nat) : 24*dimension ≤ 32*blockCount dimension := by + unfold blockCount + omega + +theorem residual_lt_block (dimension : Nat) : residualCount dimension < 32 := by + unfold residualCount blockCount + omega + +/-- Row-major concatenation, not a separate low-word projection per digest. -/ +def flatten (dimension : Nat) : Blocks dimension ≃ (Fin (32*blockCount dimension) → Byte) where + toFun blocks := fun i => blocks ⟨i.val/32, by omega⟩ ⟨i.val%32, Nat.mod_lt _ (by decide)⟩ + invFun bytes := fun j i => bytes ⟨32*j.val+i.val, by have := j.isLt; have := i.isLt; omega⟩ + left_inv blocks := by + funext j i + dsimp + congr 2 <;> have := i.isLt <;> omega + right_inv bytes := by + funext i + dsimp + congr 1 + apply Fin.ext + dsimp + omega + +/-- Split at the actual consumed cursor. The residual is at most 31 bytes, +not eight discarded bytes for every scalar. -/ +def splitBytes (dimension : Nat) : (Fin (32*blockCount dimension) → Byte) ≃ + ((Fin dimension → Scalar24) × Residual dimension) where + toFun bytes := (fun j i => bytes ⟨24*j.val+i.val, by + have := j.isLt; have := i.isLt; have := block_capacity dimension; omega⟩, + fun i => bytes ⟨24*dimension+i.val, by + have := i.isLt; have := block_capacity dimension; unfold residualCount at *; omega⟩) + invFun parts := fun i => if h : i.val < 24*dimension then + parts.1 ⟨i.val/24, by omega⟩ ⟨i.val%24, Nat.mod_lt _ (by decide)⟩ + else parts.2 ⟨i.val-24*dimension, by + have := i.isLt; unfold residualCount; omega⟩ + left_inv bytes := by + funext i + dsimp + split + · congr 1; apply Fin.ext; dsimp; omega + · congr 1; apply Fin.ext; dsimp; omega + right_inv parts := by + apply Prod.ext + · funext j i + dsimp + have h : 24*j.val+i.val < 24*dimension := by have := j.isLt; have := i.isLt; omega + simp only [h, dite_true] + apply congrArg₂ parts.1 + · apply Fin.ext; dsimp; have := i.isLt; omega + · apply Fin.ext; dsimp; have := i.isLt; omega + · funext i + dsimp + have h : ¬ 24*dimension+i.val < 24*dimension := by omega + simp only [h, dite_false] + apply congrArg parts.2 + apply Fin.ext + dsimp + omega + +def vectorParts (dimension : Nat) : Blocks dimension ≃ Joint dimension := + (flatten dimension).trans ((splitBytes dimension).trans + (Equiv.prodCongr (Equiv.piCongrRight fun _ => WHIRFiatShamir.scalarCodec) (Equiv.refl _))) + +def point (dimension : Nat) (blocks : Blocks dimension) : Fin dimension → E := + (vectorParts dimension blocks).1 + +/-- Executable specification of the source's block-straddling 24-byte chunks. -/ +theorem point_bytes (dimension : Nat) (blocks : Blocks dimension) (j : Fin dimension) : + point dimension blocks j = ByteCodec.decodeE (fun i => + blocks ⟨(24*j.val+i.val)/32, by + have := j.isLt; have := i.isLt; have := block_capacity dimension; omega⟩ + ⟨(24*j.val+i.val)%32, Nat.mod_lt _ (by decide)⟩) := rfl + +/-- Exact joint public-view equality, with no restriction on the payoff's +inspection of any fourth word, retained bytes or decoded coordinate. -/ +theorem vector_full_average (dimension : Nat) (payoff : Joint dimension → ℚ) : + average (fun blocks : Blocks dimension => payoff (vectorParts dimension blocks)) = + average payoff := RawOracleCoupling.average_equiv (vectorParts dimension) payoff + +theorem vector_point_average (dimension : Nat) (payoff : (Fin dimension → E) → ℚ) : + average (fun blocks : Blocks dimension => payoff (point dimension blocks)) = + average payoff := by + have h := vector_full_average dimension (fun parts => payoff parts.1) + rw [WHIRObservableSecurity.average_product] at h + simpa only [point, average_const] using h + +/-- The complete public block vector can always be reconstructed exactly. -/ +theorem full_answer_recovered (dimension : Nat) (blocks : Blocks dimension) : + (vectorParts dimension).symm (vectorParts dimension blocks) = blocks := + (vectorParts dimension).symm_apply_apply blocks + +end Whir.AnchoredFiatShamirSecurityCodec + +#print axioms Whir.AnchoredFiatShamirSecurityCodec.vector_full_average +#print axioms Whir.AnchoredFiatShamirSecurityCodec.vector_point_average diff --git a/verification/whir/Whir/AnchoredFiatShamirSecurityROM.lean b/verification/whir/Whir/AnchoredFiatShamirSecurityROM.lean new file mode 100644 index 000000000..9eb0c099d --- /dev/null +++ b/verification/whir/Whir/AnchoredFiatShamirSecurityROM.lean @@ -0,0 +1,304 @@ +import Whir.AnchoredFiatShamirSecurity + +/-! The actual contiguous 32-byte output-block ROM, globally memoized at original +record keys. Roots are prepared before point blocks; complete byte answers, +including the retained suffix, remain available to all adaptive decisions. +Raw-source grouping and chronological eligibility are proved separately. -/ +namespace Whir.AnchoredFiatShamirSecurityROM +open Concrete Protocol CausalGame ParameterBounds CommitmentAnchor +open AnchoredFiatShamirSecurity FiatShamirGame TypedOracleCompiler +open scoped BigOperators +set_option maxRecDepth 100000 +set_option maxHeartbeats 1000000 +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +/-- Only completed history reaches the policy. All repeats are actual requests +in the reference table, but the operational compiler memoizes them globally. -/ +noncomputable def program {p : Profile} {Key : Type} (policy : Policy p Key) : + (n : Nat) → AnchoredFiatShamirSecurity.Cache p Key → + Sampling Key (fun _ => Answer p) (AnchoredFiatShamirSecurity.Cache p Key) n + | 0, history => .ret history + | n+1, history => .draw (policy.choose history) + (fun answer => program policy n (advance policy history answer)) + +private def Seen {p : Profile} {Key : Type} (history : AnchoredFiatShamirSecurity.Cache p Key) + (cache : TypedFiatShamirGame.Cache Key (fun _ => Answer p)) : Prop := + ∀ key answer, cache key = some answer → ∃ e ∈ history, e.key = key + +private theorem lookup_miss {p : Profile} {Key : Type} + (history : AnchoredFiatShamirSecurity.Cache p Key) (key : Key) + (miss : lookup history key = none) : ¬ ∃ e ∈ history, e.key = key := by + classical + induction history with + | nil => simp + | cons e rest ih => + by_cases same : e.key = key + · simp [lookup, same] at miss + · have tail : lookup rest key = none := by simpa [lookup, same] using miss + simpa [same] using ih tail + +private theorem lookup_key {p : Profile} {Key : Type} + (history : AnchoredFiatShamirSecurity.Cache p Key) (key : Key) (e : Entry p Key) + (hit : lookup history key = some e) : e.key = key := by + classical + induction history with + | nil => simp [lookup] at hit + | cons head rest ih => + by_cases same : head.key = key + · have eq : head = e := by simpa [lookup, same] using hit + exact eq ▸ same + · exact ih (by simpa [lookup, same] using hit) + +private theorem advance_members {p : Profile} {Key : Type} (policy : Policy p Key) + (history : AnchoredFiatShamirSecurity.Cache p Key) (answer : Answer p) : + (∀ e ∈ history, e ∈ advance policy history answer) ∧ + ∃ e ∈ advance policy history answer, e.key = policy.choose history := by + classical + unfold advance + dsimp only + cases hit : lookup history (policy.choose history) with + | none => + constructor + · intro item member; exact List.mem_cons_of_mem _ member + · exact ⟨_,List.mem_cons_self,rfl⟩ + | some e => + constructor + · intro item member; exact List.mem_cons_of_mem _ member + · exact ⟨e,List.mem_cons_self,lookup_key history _ e hit⟩ + +private theorem advance_clean {p : Profile} {Key : Type} (policy : Policy p Key) + (history : AnchoredFiatShamirSecurity.Cache p Key) (clean : ¬ Dirty history) + (answer : Answer p) + (sep : ¬ Ambiguous p (policy.prepare history (policy.choose history)).lanes + (policy.prepare history (policy.choose history)).root answer.1) : + ¬ Dirty (advance policy history answer) := by + classical + unfold advance + dsimp only + cases hit : lookup history (policy.choose history) with + | none => + simp only [Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨sep,clean⟩ + | some e => + have member : e ∈ history := List.mem_of_find?_eq_some hit + simp only [Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨fun bad => clean ⟨e,member,bad⟩,clean⟩ + +private theorem memo_bound {p : Profile} {Key : Type} [DecidableEq Key] + (policy : Policy p Key) (n : Nat) (history : AnchoredFiatShamirSecurity.Cache p Key) + (cache : TypedFiatShamirGame.Cache Key (fun _ => Answer p)) + (seen : Seen history cache) (clean : ¬ Dirty history) : + Sampling.expectation (fun result => if Dirty result.1 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (program policy n history) cache) ≤ (n : ℚ)/2^124 := by + classical + induction n generalizing history cache with + | zero => simp [program, RawOracleCoupling.memo, Sampling.expectation, clean] + | succ n ih => + let key := policy.choose history + have stepSeen (answer : Answer p) : + Seen (advance policy history answer) (TypedFiatShamirGame.put cache key answer) := by + intro wanted value present + by_cases same : wanted = key + · subst wanted + exact (advance_members policy history answer).2 + · have old : cache wanted = some value := by + simpa only [TypedFiatShamirGame.put_other _ _ _ _ same] using present + obtain ⟨e,member,equal⟩ := seen wanted value old + exact ⟨e,(advance_members policy history answer).1 e member,equal⟩ + have oldSeen (answer : Answer p) : Seen (advance policy history answer) cache := by + intro wanted value present + obtain ⟨e,member,equal⟩ := seen wanted value present + exact ⟨e,(advance_members policy history answer).1 e member,equal⟩ + cases hit : cache key with + | some answer => + have actualHit : ∃ e, lookup history key = some e := by + cases find : lookup history key with + | some e => exact ⟨e,rfl⟩ + | none => exact False.elim (lookup_miss history key find (seen key answer hit)) + obtain ⟨e,find⟩ := actualHit + have continuedClean : ¬ Dirty (advance policy history answer) := by + rw [repeated_key policy history e find answer] + have member : e ∈ history := List.mem_of_find?_eq_some find + simp only [Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨fun bad => clean ⟨e,member,bad⟩,clean⟩ + have actualHit : cache (policy.choose history) = some answer := hit + simp only [program, RawOracleCoupling.memo, actualHit, Sampling.expectation_pad] + have mono : (n : ℚ)/2^124 ≤ ((n+1 : Nat) : ℚ)/2^124 := + div_le_div_of_nonneg_right (by exact_mod_cast Nat.le_succ n) (by positivity) + exact (ih _ _ (oldSeen answer) continuedClean).trans mono + | none => + have actualMiss : cache (policy.choose history) = none := hit + simp only [program, RawOracleCoupling.memo, actualMiss, Sampling.expectation] + let bad := fun answer : Answer p => + Ambiguous p (policy.prepare history key).lanes (policy.prepare history key).root answer.1 + have fibers (answer : Answer p) : + Sampling.expectation (fun result => if Dirty result.1 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (program policy n (advance policy history answer)) + (TypedFiatShamirGame.put cache key answer)) ≤ + (if bad answer then 1 else 0) + (n : ℚ)/2^124 := by + by_cases badPoint : bad answer + · have one := Sampling.expectation_le_one + (fun result : AnchoredFiatShamirSecurity.Cache p Key × + TypedFiatShamirGame.Cache Key (fun _ => Answer p) => + if Dirty result.1 then (1 : ℚ) else 0) + (fun result => by split <;> norm_num) + (RawOracleCoupling.memo (program policy n (advance policy history answer)) + (TypedFiatShamirGame.put cache key answer)) + simpa [badPoint] using one.trans + (le_add_of_nonneg_right (div_nonneg (Nat.cast_nonneg n) (by positivity))) + · simpa [badPoint] using ih _ _ (stepSeen answer) + (advance_clean policy history clean answer badPoint) + have badBound : average (fun answer : Answer p => if bad answer then (1 : ℚ) else 0) ≤ + (1 : ℚ)/2^124 := by + change average (fun answer : Point p × Tail p => + if Ambiguous p (policy.prepare history key).lanes + (policy.prepare history key).root answer.1 then (1 : ℚ) else 0) ≤ _ + rw [WHIRObservableSecurity.average_product (X := Point p) (Y := Tail p)] + change average (fun point : Point p => average (fun _ : Tail p => + if Ambiguous p (policy.prepare history key).lanes + (policy.prepare history key).root point then (1 : ℚ) else 0)) ≤ _ + simp_rw [average_const] + have separation := ambiguity_probability_numeric p + (policy.prepare history key).lanes (policy.prepare history key).root + (policy.prepare history key).occupied.2 + simpa only [average, Soundness.uniformProb, Finset.card_filter, + Nat.cast_sum, Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using separation + have bound : average (fun answer : Answer p => + Sampling.expectation (fun result => if Dirty result.1 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (program policy n (advance policy history answer)) + (TypedFiatShamirGame.put cache key answer))) ≤ + (1 : ℚ)/2^124 + (n : ℚ)/2^124 := (average_mono fibers).trans (by + rw [average_add, average_const] + exact add_le_add badBound le_rfl) + calc + _ ≤ (1 : ℚ)/2^124 + (n : ℚ)/2^124 := bound + _ = _ := by push_cast; ring + +/-- Actual uniform finite vector ROM, including repeated keys, with adaptive +roots prepared before their first answer. Internal cache invariants are PROVED +from the empty cache, not handed to the adversary as endpoint assumptions. -/ +theorem table_ambiguity_probability {p : Profile} {Key : Type} [Fintype Key] + [DecidableEq Key] (policy : Policy p Key) (n : Nat) : + Soundness.uniformProb (Finset.univ.filter fun table : Key → Answer p => + Dirty (Sampling.eval table (program policy n []))) ≤ (n : ℚ)/2^124 := by + classical + have coupled := RawOracleCoupling.empty_table_eq_memo (program policy n []) + (fun history => if Dirty history then (1 : ℚ) else 0) + have bounded := memo_bound policy n [] (fun _ => none) + (by intro key answer present; contradiction) (by simp [Dirty]) + rw [← coupled] at bounded + simpa only [average, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using bounded + +/-- Each original record has ceil(24*logN/32) distinct output-block fibers. +The joint codec retains every byte of every raw reply. -/ +def blockTableCodec (p : Profile) (Key : Type) : + ((Key × Fin (AnchoredFiatShamirSecurityCodec.blockCount (config p).logN)) → Digest32) ≃ + (Key → Answer p) := + (Equiv.curry Key (Fin (AnchoredFiatShamirSecurityCodec.blockCount (config p).logN)) + Digest32).trans + (Equiv.piCongrRight fun _ => AnchoredFiatShamirSecurityCodec.vectorParts (config p).logN) + +theorem block_table_ambiguity_probability {p : Profile} {Key : Type} [Fintype Key] + [DecidableEq Key] (policy : Policy p Key) (n : Nat) : + Soundness.uniformProb (Finset.univ.filter fun table : + (Key × Fin (AnchoredFiatShamirSecurityCodec.blockCount (config p).logN)) → Digest32 => + Dirty (Sampling.eval (blockTableCodec p Key table) (program policy n []))) ≤ + (n : ℚ)/2^124 := by + classical + have transport := RawOracleCoupling.average_equiv (blockTableCodec p Key) + (fun table => if Dirty (Sampling.eval table (program policy n [])) then (1 : ℚ) else 0) + have probabilityEq : + Soundness.uniformProb (Finset.univ.filter fun table : + (Key × Fin (AnchoredFiatShamirSecurityCodec.blockCount (config p).logN)) → Digest32 => + Dirty (Sampling.eval (blockTableCodec p Key table) (program policy n []))) = + Soundness.uniformProb (Finset.univ.filter fun table : Key → Answer p => + Dirty (Sampling.eval table (program policy n []))) := by + simpa only [average, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using transport + rw [probabilityEq] + exact table_ambiguity_probability policy n + +abbrev BlockOracle (p : Profile) (Key : Type) := + (Key × Fin (AnchoredFiatShamirSecurityCodec.blockCount (config p).logN)) → Digest32 + +noncomputable def historyOf {p : Profile} {Key : Type} (policy : Policy p Key) + (n : Nat) (table : BlockOracle p Key) := + Sampling.eval (blockTableCodec p Key table) (program policy n []) + +/-- Final selection is from an actually answered root/shape/point record, not a +root chosen using an unqueried table point. The advertised value is still free. -/ +abbrev TableSelector {p : Profile} {Key : Type} (policy : Policy p Key) (n : Nat) := + (table : BlockOracle p Key) → Option {e : Entry p Key // e ∈ historyOf policy n table} + +noncomputable def TableFailure {p : Profile} {Key : Type} (policy : Policy p Key) + (n : Nat) (select : TableSelector policy n) (advertised : BlockOracle p Key → E) + (opening : BlockOracle p Key → Array Claim) (strategy : BlockOracle p Key → Strategy) + (sample : BlockOracle p Key × Tape (config p)) : Prop := + match select sample.1 with + | none => False + | some e => openingFailure p (chosenCommitment e.val (advertised sample.1)) + (opening sample.1) (strategy sample.1) sample.2 + +/-- Adaptive byte-stream ROM anchor selection followed by one independent causal +opening tape. Final selection may inspect the entire public raw block table; +pre-point root preparation still sees completed history only. This theorem +does not identify that independent opening tape with the native verifier body. -/ +theorem block_table_unique_opening_probability {p : Profile} {Key : Type} + [Fintype Key] [DecidableEq Key] (policy : Policy p Key) (n : Nat) + (select : TableSelector policy n) (advertised : BlockOracle p Key → E) + (opening : BlockOracle p Key → Array Claim) (strategy : BlockOracle p Key → Strategy) + (opening_cap : ∀ table, (opening table).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + (TableFailure policy n select advertised opening strategy)) ≤ + (n : ℚ)/2^124 + (1 : ℚ)/2^73 := by + classical + apply RingMapBatching.conditional_error + (fun table : BlockOracle p Key => Dirty (historyOf policy n table)) + _ _ _ (by positivity) (block_table_ambiguity_probability policy n) + intro table clean + cases chosen : select table with + | none => simp [TableFailure, chosen, Soundness.uniformProb] + | some e => + have sep : ¬ Ambiguous p e.val.commitment.lanes e.val.commitment.root + e.val.commitment.point := fun bad => clean ⟨e.val,e.property,bad⟩ + simpa only [TableFailure, chosen] using + (unique_opening_probability p (chosenCommitment e.val (advertised table)) + sep (opening table) (strategy table)).trans + (production_interactive p _ (opening_cap table)) + +private theorem profile_blocks : ∀ p : Profile, + 1 ≤ AnchoredFiatShamirSecurityCodec.blockCount (config p).logN := by + decide +kernel + +/-- Source resource accounting charges actual 32-byte output blocks, not one +digest per scalar. Repeated requests are conservatively charged too. -/ +theorem block_table_unique_opening_numeric {p : Profile} {Key : Type} + [Fintype Key] [DecidableEq Key] (policy : Policy p Key) (n Q : Nat) + (blockBudget : n * AnchoredFiatShamirSecurityCodec.blockCount (config p).logN ≤ Q) + (compression : Q ≤ 2^60) + (select : TableSelector policy n) (advertised : BlockOracle p Key → E) + (opening : BlockOracle p Key → Array Claim) (strategy : BlockOracle p Key → Strategy) + (opening_cap : ∀ table, (opening table).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + (TableFailure policy n select advertised opening strategy)) ≤ + (1 : ℚ)/2^64 + (1 : ℚ)/2^73 := by + have attempts : n ≤ 2^60 := calc + n = n*1 := by simp + _ ≤ n*AnchoredFiatShamirSecurityCodec.blockCount (config p).logN := + Nat.mul_le_mul_left n (profile_blocks p) + _ ≤ Q := blockBudget + _ ≤ 2^60 := compression + apply (block_table_unique_opening_probability policy n select advertised opening strategy + opening_cap).trans + apply add_le_add _ le_rfl + have h : (n : ℚ) ≤ 2^60 := by exact_mod_cast attempts + exact (div_le_div_of_nonneg_right h (by positivity)).trans (by norm_num) + + +end Whir.AnchoredFiatShamirSecurityROM + +#print axioms Whir.AnchoredFiatShamirSecurityROM.table_ambiguity_probability +#print axioms Whir.AnchoredFiatShamirSecurityROM.block_table_ambiguity_probability +#print axioms Whir.AnchoredFiatShamirSecurityROM.block_table_unique_opening_probability +#print axioms Whir.AnchoredFiatShamirSecurityROM.block_table_unique_opening_numeric diff --git a/verification/whir/Whir/AnchoredHeaderCodec.lean b/verification/whir/Whir/AnchoredHeaderCodec.lean new file mode 100644 index 000000000..9248b2d36 --- /dev/null +++ b/verification/whir/Whir/AnchoredHeaderCodec.lean @@ -0,0 +1,184 @@ +import Whir.ByteCodec +import Whir.DuplexRefinement +import Whir.WHIRHistory + +/-! Source hand-port of `pcs/src/whir/commit.rs` at 32c62977136d02cfaac106c1e363c922c1a50109. Context capture is read-only. The output cache is not a record field and cannot be installed through this interface. Digest halves use the deployed two-word/two-word packing. -/ +namespace Whir.AnchoredHeaderCodec +open Concrete FiatShamirGame + +structure Shape where + logN : Nat + logBatch : Nat + logRate : Nat + lanes : Nat + deriving DecidableEq, Repr + +def Shape.Valid (s : Shape) : Prop := + s.logBatch < s.logN ∧ s.logN < 64 ∧ 1 ≤ s.logRate ∧ + s.logN - s.logBatch + s.logRate < 64 ∧ 1 ≤ s.lanes ∧ s.lanes ≤ 2^s.logBatch + +instance (s : Shape) : Decidable s.Valid := inferInstanceAs (Decidable (_ ∧ _ ∧ _ ∧ _ ∧ _ ∧ _)) + +structure Context where + cv : Digest32 + pending : Fin 8 → Option K + pendingBytes : Nat + first : Bool + previous : UInt64 + squeezed : UInt64 + deriving DecidableEq + +/-- This is exactly the native record metadata guard, not an arbitrary output-cache certificate. Reachable snapshots additionally have normalized partial words by construction. -/ +def Context.Valid (c : Context) : Prop := + c.pendingBytes ≤ 64 ∧ ∀ i : Fin 8, (c.pending i).isSome = decide (i.val < (c.pendingBytes+7)/8) + +instance (c : Context) : Decidable c.Valid := inferInstanceAs (Decidable (_ ∧ _)) + +/-- Missing bytes in the last live word are literal zero. No compression, finalization, sampler, or transcript mutation occurs. -/ +def capture (s : DuplexRefinement.State) : Context := + { cv := s.cv + pending := fun i => if i.val < (s.pending.size+7)/8 then + some (ByteCodec.decodeK (fun j => s.pending[8*i.val+j.val]?.getD 0)) else none + pendingBytes := s.pending.size + first := s.first + previous := UInt64.ofNat s.previous + squeezed := UInt64.ofNat s.consumed } + +theorem capture_valid (s : DuplexRefinement.State) (bounded : s.pending.size ≤ 64) : + (capture s).Valid := by + refine ⟨bounded,?_⟩ + intro i + simp only [capture] + by_cases h : i.val < (s.pending.size+7)/8 <;> simp [h] + +theorem capture_cache_irrelevant (s : DuplexRefinement.State) (out : Digest32) : + capture {s with output := out} = capture s := rfl + +def anchorMarker : E := ⟨0x636e612d72696877,0x000031762d726f68,0⟩ +def openingMarker : E := ⟨0x65706f2d72696877,0x0031762d676e696e,0⟩ +def shapeScalar (s : Shape) : E := + ⟨UInt64.ofNat s.logN,UInt64.ofNat s.logBatch,UInt64.ofNat s.logRate⟩ +def lanesScalar (s : Shape) : E := ⟨UInt64.ofNat s.lanes,0,0⟩ + +def headerScalars (s : Shape) (root : Digest32) : List E := + [anchorMarker,shapeScalar s,lanesScalar s,(ByteCodec.hashToScalars root).1, + (ByteCodec.hashToScalars root).2] + +@[simp] theorem headerScalars_length (s : Shape) (root : Digest32) : + (headerScalars s root).length = 5 := rfl + +theorem originalTransport_length (s : Shape) (root : Digest32) (value : E) : + (headerScalars s root ++ [value]).length = 6 := rfl + +def parseHeader (s : Shape) : List E → Option Digest32 + | [marker,shape,lanes,a,b] => + if marker = anchorMarker ∧ shape = shapeScalar s ∧ lanes = lanesScalar s then + ByteCodec.scalarsToHash (a,b) + else none + | _ => none + +@[simp] theorem parseHeader_header (s : Shape) (root : Digest32) : + parseHeader s (headerScalars s root) = some root := by + simp [parseHeader,headerScalars,ByteCodec.scalarsToHash_hashToScalars] + +theorem parseHeader_sound (s : Shape) (values : List E) (root : Digest32) + (parsed : parseHeader s values = some root) : values = headerScalars s root := by + unfold parseHeader at parsed + split at parsed + next marker shape lanes a b => + split at parsed + next matched => + obtain ⟨rfl,rfl,rfl⟩ := matched + have exactRoot := ByteCodec.hashToScalars_scalarsToHash (a,b) root parsed + have first := congrArg Prod.fst exactRoot + have second := congrArg Prod.snd exactRoot + simp only [headerScalars,first,second] + next => contradiction + next => contradiction + +structure Record where + shape : Shape + root : Digest32 + context : Context + point : List E + value : E + deriving DecidableEq + +def Record.Valid (r : Record) : Prop := r.shape.Valid ∧ r.context.Valid ∧ r.point.length = r.shape.logN +instance (r : Record) : Decidable r.Valid := inferInstanceAs (Decidable (_ ∧ _ ∧ _)) + +/-- Three consecutive live words per scalar, with K zero padding in the final partial pack. -/ +def pendingPacks (c : Context) : List E := + (List.range ((c.pendingBytes+23)/24)).map fun i => + ⟨(c.pending ⟨3*i % 8,Nat.mod_lt _ (by decide)⟩).getD 0, + if 3*i+1 < (c.pendingBytes+7)/8 then + (c.pending ⟨(3*i+1)%8,Nat.mod_lt _ (by decide)⟩).getD 0 else 0, + if 3*i+2 < (c.pendingBytes+7)/8 then + (c.pending ⟨(3*i+2)%8,Nat.mod_lt _ (by decide)⟩).getD 0 else 0⟩ + +def openingScalars (r : Record) : List E := + [openingMarker,shapeScalar r.shape,lanesScalar r.shape, + (ByteCodec.hashToScalars r.root).1,(ByteCodec.hashToScalars r.root).2, + (ByteCodec.hashToScalars r.context.cv).1,(ByteCodec.hashToScalars r.context.cv).2, + ⟨UInt64.ofNat r.context.pendingBytes,if r.context.first then 1 else 0,r.context.previous⟩, + ⟨r.context.squeezed,0,0⟩] ++ pendingPacks r.context ++ r.point ++ [r.value] + +theorem openingScalars_length (r : Record) : + (openingScalars r).length = 10 + r.point.length + (r.context.pendingBytes+23)/24 := by + simp only [openingScalars,List.length_append,List.length_cons,List.length_nil, + pendingPacks,List.length_map,List.length_range] + omega + +theorem openingScalars_valid_length (r : Record) (valid : r.Valid) : + (openingScalars r).length = 10 + r.shape.logN + (r.context.pendingBytes+23)/24 := by + rw [openingScalars_length,valid.2.2] + +inductive Error where + | commitmentMismatch + | malformedTranscript + | cursorExhausted + deriving DecidableEq, Repr + +/-- Native read order: validate metadata and point/configuration before reading the frame. Missing transport is an error, not a zero-filled scalar; mismatch rejects before any batching challenge. -/ +def verifyBinding (expected : Shape) (r : Record) (transport : List E) : Except Error (List E) := + if r.Valid ∧ r.shape = expected then + let frame := openingScalars r + if transport.length < frame.length then .error .malformedTranscript + else if transport.take frame.length = frame then .ok (transport.drop frame.length) + else .error .commitmentMismatch + else .error .commitmentMismatch + +theorem verifyBinding_honest (r : Record) (valid : r.Valid) (suffix : List E) : + verifyBinding r.shape r (openingScalars r ++ suffix) = .ok suffix := by + simp [verifyBinding,valid] + +theorem verifyBinding_sound (expected : Shape) (r : Record) (transport rest : List E) + (accepted : verifyBinding expected r transport = .ok rest) : + r.Valid ∧ r.shape = expected ∧ transport = openingScalars r ++ rest := by + unfold verifyBinding at accepted + split at accepted + next metadata => + dsimp only at accepted + split at accepted + next => contradiction + next length => + split at accepted + next same => + cases accepted + refine ⟨metadata.1,metadata.2,?_⟩ + calc + transport = transport.take (openingScalars r).length ++ transport.drop (openingScalars r).length := + (List.take_append_drop _ _).symm + _ = openingScalars r ++ transport.drop (openingScalars r).length := by rw [same] + next => contradiction + next => contradiction + +theorem verifyBinding_reject (expected : Shape) (r : Record) (transport : List E) + (tampered : transport.take (openingScalars r).length ≠ openingScalars r) : + ∀ rest, verifyBinding expected r transport ≠ .ok rest := by + intro rest accepted + have complete := (verifyBinding_sound expected r transport rest accepted).2.2 + rw [complete,List.take_left] at tampered + exact tampered rfl + +end Whir.AnchoredHeaderCodec diff --git a/verification/whir/Whir/AnchoredHeaderRoots.lean b/verification/whir/Whir/AnchoredHeaderRoots.lean new file mode 100644 index 000000000..9d2d6b863 --- /dev/null +++ b/verification/whir/Whir/AnchoredHeaderRoots.lean @@ -0,0 +1,115 @@ +import Whir.AnchoredHeaderCodec +import Whir.WHIRHeaderRoots + +/-! Original-anchor keys have an arbitrary prior history. Their last completed absorb run ends with the five commitment-header scalars. Looking only at the first absorb frame would misparse real fresh-session commitments. Exact raw reconstruction remains the existing bounded DMV decoder. -/ +namespace Whir.AnchoredHeaderRoots +open Concrete FiatShamirGame DuplexModeGame AnchoredHeaderCodec + +structure Public where + iv : Digest32 + domain : Digest32 + shapes : Digest32 → Option Shape + +structure Header where + statement : Digest32 + shape : Shape + root : Digest32 + deriving DecidableEq + +/-- Shape selection and native shape validation occur before scalar decoding. Root padding is checked by scalarsToHash, not discarded. -/ +def fromHistory (registry : Public) (history : FramedHistory) : Option Header := + if history.domain = registry.domain then + match registry.shapes history.statement with + | none => none + | some shape => + if shape.Valid then + match history.frames.getLast? with + | some (.absorb _ bytes) => + if 120 ≤ bytes.length then + (WHIRHistory.parseExact 5 (bytes.drop (bytes.length-120))).bind fun scalars => + (parseHeader shape scalars).map (fun root => ⟨history.statement,shape,root⟩) + else none + | _ => none + else none + else none + +def rawHeader (registry : Public) {Q : Nat} (raw : RawKey Q) : Option Header := + (WHIRHeaderRoots.decodeRaw registry.iv raw).bind fun q => + match q.terminal with + | .output _ => fromHistory registry q.history + | _ => none + +theorem rawHeader_construction (registry : Public) {Q : Nat} (history : FramedHistory) (block : Nat) + (valid : DuplexEncoding.Admissible (⟨history,.output block⟩ : Coordinate)) + (bound : DuplexFraming.pathCost (⟨history,.output block⟩ : Coordinate) ≤ Q) : + rawHeader registry (constructionKey Q registry.iv ⟨history,.output block⟩ bound) = + fromHistory registry history := by + simp [rawHeader,WHIRHeaderRoots.decodeRaw_construction registry.iv _ valid bound] + +/-- A raw header is read from the query alone, before its oracle answer, even for caller-output garbage keys. No output bytes or advertised value are parser arguments. -/ +theorem rawHeader_exact (registry : Public) {Q : Nat} (raw : RawKey Q) (header : Header) + (parsed : rawHeader registry raw = some header) : + ∃ q, WHIRHeaderRoots.decodeRaw registry.iv raw = some q ∧ + (∃ block, q.terminal = .output block) ∧ + (∃ bound : DuplexFraming.pathCost q ≤ Q, + DuplexEncoding.Admissible q ∧ DuplexModeGame.constructionKey Q registry.iv q bound = raw) ∧ + fromHistory registry q.history = some header := by + cases decoded : WHIRHeaderRoots.decodeRaw registry.iv raw with + | none => simp [rawHeader,decoded] at parsed + | some q => + cases terminal : q.terminal with + | commitment cursor => simp [rawHeader,decoded,terminal] at parsed + | powBase cursor bits => simp [rawHeader,decoded,terminal] at parsed + | output block => + exact ⟨q,rfl,⟨block,terminal⟩,WHIRHeaderRoots.decodeRaw_sound registry.iv raw q decoded, + by simpa [rawHeader,decoded,terminal] using parsed⟩ + +theorem fromHistory_valid (registry : Public) (history : FramedHistory) (header : Header) + (parsed : fromHistory registry history = some header) : + history.domain = registry.domain ∧ header.statement = history.statement ∧ + registry.shapes history.statement = some header.shape ∧ header.shape.Valid := by + unfold fromHistory at parsed + split at parsed + next domain => + cases selected : registry.shapes history.statement with + | none => simp [selected] at parsed + | some shape => + simp only [selected] at parsed + split at parsed + next valid => + cases last : history.frames.getLast? with + | none => simp [last] at parsed + | some frame => + cases frame with + | nonce previous bits value => simp [last] at parsed + | absorb previous bytes => + simp only [last] at parsed + split at parsed + next enough => + cases decoded : WHIRHistory.parseExact 5 (bytes.drop (bytes.length-120)) with + | none => simp [decoded] at parsed + | some scalars => + cases root : parseHeader shape scalars with + | none => simp [decoded,root] at parsed + | some digest => + simp only [decoded,root,Option.bind_some,Option.map_some,Option.some.injEq] at parsed + subst header + exact ⟨domain,rfl,rfl,valid⟩ + next => contradiction + next => contradiction + next => contradiction + +/-- The actual five-scalar header is recognized after any earlier absorb bytes and any earlier frame history. The point output and advertised value are not needed to decode it. -/ +theorem fromHistory_header (registry : Public) (statement root : Digest32) (shape : Shape) + (selected : registry.shapes statement = some shape) (valid : shape.Valid) + (earlier : List Frame) (previous : Nat) (pending : List Byte) : + fromHistory registry ⟨registry.domain,statement, + earlier ++ [.absorb previous (pending ++ WHIRHistory.scalarBytes (headerScalars shape root))]⟩ = + some ⟨statement,shape,root⟩ := by + have encoded : (WHIRHistory.scalarBytes (headerScalars shape root)).length = 120 := by + rw [WHIRHistory.scalarBytes_length,headerScalars_length] + have parsed := WHIRHistory.parseExact_roundtrip (headerScalars shape root) + rw [headerScalars_length] at parsed + simp [fromHistory,selected,valid,encoded,parsed,List.getLast?_append,List.getLast?_singleton] + +end Whir.AnchoredHeaderRoots diff --git a/verification/whir/Whir/AnchoredPhysicalAcceptance.lean b/verification/whir/Whir/AnchoredPhysicalAcceptance.lean new file mode 100644 index 000000000..043361a29 --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalAcceptance.lean @@ -0,0 +1,52 @@ +import Whir.AnchoredPhysicalDriver +import Whir.AnchorPrefixRefinementCaller + +/-! Pinned 32c accepted-event refinement. Caller geometry and the supported anchor batch are derived from actual source decoding in either boundary. The remaining hypotheses are the physical authenticated-row/root properties, not claim coverage or an assumed acceptance payload. Their cryptographic transport belongs to the physical Merkle/mode bridge. -/ +namespace Whir.AnchoredPhysicalAcceptance +open Concrete Protocol FiatShamirGame AnchoredHeaderCodec AnchoredPhysicalDriver + +theorem accepted_anchored_shapes {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : Record} + (accepted : Accepted ctx Q cap packet record) (seed : RingPCSGame.Prefix) (lambda : E) : + let c := ParameterBounds.config packet.val.profile + let claims := AnchorPrefixRefinement.anchoredClaims c record accepted.request.claims.family accepted.request.claims.points seed + (claims.all (fun claim => shapeValid c record.shape.lanes claim.weight) = true) ∧ + shapeValid c record.shape.lanes (CausalGame.batchClaims (2^c.logN) claims lambda).weight = true := by + obtain ⟨boundary,model,answers,same,parsed⟩ := accepted.origin + exact request_anchored_shapes boundary cap packet.val.profile model record accepted.configuration same + (RawWHIRKeys.entry ctx packet.val) answers accepted.request parsed seed lambda + +/-- Any actual accepted source result refines to the dense causal WHIR verifier with the same original anchor. Row authenticity is exposed rather than replaced by a universal bad-event-cover assumption. -/ +theorem accepted_protocol {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : Record} + (accepted : Accepted ctx Q cap packet record) (root : Oracle) + (rootShape : oracleValid root + (2^((ParameterBounds.config packet.val.profile).logN-(ParameterBounds.config packet.val.profile).folds[0]!+ + (ParameterBounds.config packet.val.profile).rates[0]!)) record.shape.lanes = true) + (roots : ∀ proof, CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) accepted.wire.tape) accepted.wire.replies = .ok proof → + WHIRNativeArithmetic.RootShapes (ParameterBounds.config packet.val.profile) proof) + (authenticated : ∀ proof, CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) accepted.wire.tape) accepted.wire.replies = .ok proof → + WHIRNativeArithmetic.AuthenticatedRows (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) accepted.wire.tape) proof root) : + ∃ seed lambda proof, accepted.wire.initial = some (seed,lambda) ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) accepted.wire.tape) accepted.wire.replies = .ok proof ∧ + let c := ParameterBounds.config packet.val.profile + let claims := AnchorPrefixRefinement.anchoredClaims c record accepted.request.claims.family accepted.request.claims.points seed + Protocol.verify c (CausalGame.challenges c accepted.wire.tape) record.shape.lanes root + (CausalGame.batchClaims (2^c.logN) claims lambda).weight + (CausalGame.batchClaims (2^c.logN) claims lambda).value proof = .ok () := by + obtain ⟨⟨seed,lambda⟩,proof,initial,parsed,native⟩ := accepted.acceptance + refine ⟨seed,lambda,proof,initial,parsed,?_⟩ + obtain ⟨families,points⟩ := accepted_nativeShapes accepted + apply AnchorPrefixRefinement.sourceVerify_refines record accepted.request.claims.family accepted.request.claims.points + seed lambda _ _ proof root accepted.configuration.1 accepted.configuration.2.1 accepted.configuration.2.2.1 + families _ (accepted_anchored_shapes accepted seed lambda).2 rootShape (roots proof parsed) (authenticated proof parsed) native + intro i + exact points _ (by simp) + +#print axioms accepted_anchored_shapes +#print axioms accepted_protocol +end Whir.AnchoredPhysicalAcceptance diff --git a/verification/whir/Whir/AnchoredPhysicalAnchor.lean b/verification/whir/Whir/AnchoredPhysicalAnchor.lean new file mode 100644 index 000000000..96bb5688b --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalAnchor.lean @@ -0,0 +1,57 @@ +import Whir.AnchorPrefixRefinementArith +import Whir.WHIRNativeArithmetic + +/-! Source hand-port of 32c `anchor.rs::anchor_eq_at` and `stack_open::OpeningWeight`. The prefix recurrence never allocates a cube or evaluates the full equality product for missing lanes. Its dense semantic refinement is a separate mathematical theorem, not an evaluator argument accepted by the executable verifier. -/ +namespace Whir.AnchoredPhysicalAnchor +open Concrete Protocol AnchoredHeaderCodec + +abbrev PrefixState := AnchorPrefixRefinementArith.PrefixStateWith E + +def prefixStep (shape : Shape) (r x : Array E) (j : Nat) (s : PrefixState) : PrefixState := + AnchorPrefixRefinementArith.prefixStepWith AnchorPrefixRefinementArith.native shape + (fun i => r[i]!) (fun i => x[i]!) j s + +def anchorAt (shape : Shape) (r x : Array E) : E := + AnchorPrefixRefinementArith.anchorAtWith AnchorPrefixRefinementArith.native shape r.size + (fun i => r[i]!) (fun i => x[i]!) + +theorem native_factor (r x : E) : E.add (E.add r x) E.one = 1+r+x := by + change (r+x)+(1 : E) = 1+r+x + ring + +theorem native_eq_factor (acc r x : E) : + E.add (E.mul acc (E.add r x)) acc = acc*(1+r+x) := by + change acc*(r+x)+acc = acc*(1+r+x) + ring + +/-- Normalized equality product notation for the operational source fold. -/ +theorem anchorAt_unfold (shape : Shape) (r x : Array E) : + anchorAt shape r x = + if shape.lanes = 2^shape.logBatch then + (List.range r.size).foldl (fun (acc : E) j => acc*((1 : E)+r[j]!+x[j]!)) (1 : E) + else + (List.range (shape.logN-shape.logBatch)).foldl + (fun (acc : E) j => acc*((1 : E)+r[j]!+x[j]!)) (1 : E) * + ((List.range shape.logBatch).foldl (fun s j => prefixStep shape r x j s) {}).partial := by + unfold anchorAt AnchorPrefixRefinementArith.anchorAtWith AnchorPrefixRefinementArith.eqEvalWith + simp only [AnchorPrefixRefinementArith.native, native_eq_factor] + simp only [← FieldModel.E_one_def] + rfl + +def initialClaim {m : Nat} (record : Record) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) : E := + WHIRNativeArithmetic.initialClaim family points seed lambda + lambda^(points.size+1)*record.value + +def callerAt {m : Nat} (record : Record) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) (x : Array E) : E := + SuccinctRingGroups.sourceStackWeightAt family points seed lambda x + + lambda^(points.size+1)*anchorAt record.shape record.point.toArray x + +/-- The family takes power zero, existing point claims powers 1..points.size, and the retained anchor the final power. No additional random point, transcript reset or full-cube PointClaim is substituted. -/ +def sourceVerify {m : Nat} (record : Record) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (ch : Challenges) (proof : Opening) : Except String Unit := + WHIRNativeArithmetic.nativeVerify c ch record.shape.lanes (initialClaim record family points seed lambda) + (callerAt record family points seed lambda) proof + +end Whir.AnchoredPhysicalAnchor diff --git a/verification/whir/Whir/AnchoredPhysicalDriver.lean b/verification/whir/Whir/AnchoredPhysicalDriver.lean new file mode 100644 index 000000000..89e9f7333 --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalDriver.lean @@ -0,0 +1,351 @@ +import Whir.AnchoredSourceCaller +import Whir.AnchoredSourceFreshCaller +import Whir.AnchoredSourceRegistry +import Whir.AnchoredPhysicalTranscript +import Whir.AnchoredPhysicalAnchor +import Whir.WHIRPhysicalDriver +import Whir.CommitmentAnchor + +/-! Pinned 32c anchored acceptance endpoint. The old physical decoder is used only for the unchanged WHIR opening suffix and authenticated rows. Its unanchored caller header, claim resolver and terminal acceptance function are not called here. Every acceptance is produced by the occupied-prefix native arithmetic after an exact immutable-record caller parse. -/ +namespace Whir.AnchoredPhysicalDriver +open Concrete Protocol FiatShamirGame WHIRSourceChronology +open AnchoredHeaderCodec WHIRPhysicalVerifier +open MerkleTransport MerkleTransport.Commitments + +/-- Exact profile/configuration guard before any WHIR gamma/map/lambda output. The point-count bound includes the family and the new anchor power. -/ +def configuration (p : ParameterBounds.Profile) (r : Record) : Prop := + r.Valid ∧ r.shape.logN = (ParameterBounds.config p).logN ∧ + r.shape.logBatch = (ParameterBounds.config p).folds[0]! ∧ + r.shape.logRate = (ParameterBounds.config p).rates[0]! +instance (p : ParameterBounds.Profile) (r : Record) : Decidable (configuration p r) := + inferInstanceAs (Decidable (_ ∧ _ ∧ _ ∧ _)) + +inductive Boundary where + | original + | fresh + deriving DecidableEq + +def decodeCaller (boundary : Boundary) (layout : WHIRCallerClaims.CallerLayout) (record : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) : Option AnchoredSourceCaller.Claims := + match boundary with + | .original => AnchoredSourceCaller.decode layout record.context entry answers + | .fresh => AnchoredSourceFreshCaller.decode layout record entry answers + +theorem decodeCaller_geometry (boundary : Boundary) (model : WHIRCallerSupport.ProductionLayout) (record : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (decoded : AnchoredSourceCaller.Claims) + (parsed : decodeCaller boundary model.layout record entry answers = some decoded) : + WHIRCallerGeometry.ClaimsValid + (fun i d => WHIRCallerSupport.columnFits model.sources i d = true) + (fun o d => WHIRCallerSupport.ringFits model.sources o d = true) + (WHIRCallerClaims.callerPlacements model.layout) decoded.caller := by + cases boundary with + | original => exact AnchoredSourceCaller.decode_geometry model record.context entry answers decoded parsed + | fresh => exact AnchoredSourceFreshCaller.decode_geometry model record entry answers decoded parsed + +/-- Decoder inputs are physical prior answers. Missing keys reject rather than becoming arbitrary scalar defaults. Original context and identity come from the native original receiver; transport cannot replace them. -/ +def request (boundary : Boundary) (cap : Nat) (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (record : Record) (entry : FramedHistory) (answers : Coordinate → Option Digest32) : + Option (CausalBindingState.ClaimRequest cap p) := + if (WHIRCallerOutputs.callerOutputs entry).all (fun q => (answers q).isSome) then do + let decoded ← decodeCaller boundary layout record entry + (fun q => (answers q).getD DuplexRefinement.zeroDigest) + if decoded.record ≠ record then none else do + if laneBound : record.shape.lanes ≤ 2^(ParameterBounds.config p).folds[0]! then + if familyBound : decoded.caller.families.length ≤ cap then + if pointBound : decoded.caller.points.size+2 ≤ 2^64 then + some ⟨record.root,record.shape.lanes,laneBound, + ⟨decoded.caller.families.length,fun i => decoded.caller.families[i],familyBound, + decoded.caller.points,by omega⟩⟩ + else none + else none + else none + else none + +theorem opening_metadata (model : WHIRCallerSupport.ProductionLayout) (p : ParameterBounds.Profile) + (record : Record) (configured : configuration p record) + (same : record.shape = AnchoredSourceCaller.shape model.layout) : + WHIRCallerClaims.openingMatches p record.shape.lanes model.layout = true := by + simp only [WHIRCallerClaims.openingMatches,Bool.and_eq_true,beq_iff_eq] + exact ⟨⟨congrArg Shape.lanes same, + (WHIRCallerSupport.config_initial_geometry p).1.symm.trans + (configured.2.1.symm.trans (congrArg Shape.logN same))⟩, + (AnchoredSourceCaller.config_initial_rate p).symm.trans + (configured.2.2.2.symm.trans (congrArg Shape.logRate same))⟩ + +theorem request_origin (boundary : Boundary) (cap : Nat) (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (record : Record) (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (result : CausalBindingState.ClaimRequest cap p) + (accepted : request boundary cap p layout record entry answers = some result) : + ∃ decoded, decodeCaller boundary layout record entry + (fun q => (answers q).getD DuplexRefinement.zeroDigest) = some decoded ∧ + decoded.record = record ∧ result.root = record.root ∧ result.lanes = record.shape.lanes := by + unfold request at accepted + split at accepted + next present => + cases parsed : decodeCaller boundary layout record entry + (fun q => (answers q).getD DuplexRefinement.zeroDigest) with + | none => simp [parsed] at accepted + | some decoded => + simp only [parsed,bind,Option.bind] at accepted + split at accepted + next mismatch => contradiction + next same => + split at accepted + next lanes => + split at accepted + next families => + split at accepted + next points => + cases Option.some.inj accepted + exact ⟨decoded,rfl,not_ne_iff.mp same,rfl,rfl⟩ + next => contradiction + next => contradiction + next => contradiction + next => contradiction + +theorem request_nativeShapes (boundary : Boundary) (cap : Nat) (p : ParameterBounds.Profile) + (model : WHIRCallerSupport.ProductionLayout) (record : Record) + (configured : configuration p record) (same : record.shape = AnchoredSourceCaller.shape model.layout) + (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (result : CausalBindingState.ClaimRequest cap p) + (accepted : request boundary cap p model.layout record entry answers = some result) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN result.claims.family ∧ + (∀ point ∈ result.claims.points.toList, + SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by + unfold request at accepted + split at accepted + next present => + cases parsed : decodeCaller boundary model.layout record entry + (fun q => (answers q).getD DuplexRefinement.zeroDigest) with + | none => simp [parsed] at accepted + | some decoded => + simp only [parsed,bind,Option.bind] at accepted + split at accepted + next mismatch => contradiction + next matched => + split at accepted + next lanes => + split at accepted + next families => + split at accepted + next points => + cases Option.some.inj accepted + exact WHIRCallerSupport.geometry_nativeShapes model p record.shape.lanes + (opening_metadata model p record configured same) lanes decoded.caller + (decodeCaller_geometry boundary model record entry _ decoded parsed) + next => contradiction + next => contradiction + next => contradiction + next => contradiction + +theorem request_anchored_shapes (boundary : Boundary) (cap : Nat) (p : ParameterBounds.Profile) + (model : WHIRCallerSupport.ProductionLayout) (record : Record) + (configured : configuration p record) (same : record.shape = AnchoredSourceCaller.shape model.layout) + (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (result : CausalBindingState.ClaimRequest cap p) + (accepted : request boundary cap p model.layout record entry answers = some result) + (seed : RingPCSGame.Prefix) (lambda : E) : + let c := ParameterBounds.config p + let claims := (RingPCSGame.transformedClaims (2^c.logN) result.claims.family result.claims.points seed).push + ⟨CommitmentAnchor.weight c record.shape.lanes record.point.toArray,record.value⟩ + (claims.all (fun claim => Protocol.shapeValid c record.shape.lanes claim.weight) = true) ∧ + Protocol.shapeValid c record.shape.lanes (CausalGame.batchClaims (2^c.logN) claims lambda).weight = true := by + unfold request at accepted + split at accepted + next present => + cases parsed : decodeCaller boundary model.layout record entry + (fun q => (answers q).getD DuplexRefinement.zeroDigest) with + | none => simp [parsed] at accepted + | some decoded => + simp only [parsed,bind,Option.bind] at accepted + split at accepted + next mismatch => contradiction + next matched => + split at accepted + next lanes => + split at accepted + next families => + split at accepted + next points => + cases Option.some.inj accepted + exact AnchoredSourceCaller.geometry_anchored_shapes model p record.shape.lanes + (opening_metadata model p record configured same) lanes decoded + (decodeCaller_geometry boundary model record entry _ decoded parsed) seed lambda record.point.toArray record.value + next => contradiction + next => contradiction + next => contradiction + next => contradiction + +structure Accepted (ctx : RawWHIRKeys.Context) (Q cap : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (record : Record) where + request : CausalBindingState.ClaimRequest cap packet.val.profile + wire : WireState packet.val.profile + history : List (Sigma (RawOracleCoupling.Concrete.GroupAnswer ctx Q)) + configuration : configuration packet.val.profile record + origin : ∃ boundary : Boundary, ∃ model : WHIRCallerSupport.ProductionLayout, ∃ answers : Coordinate → Option Digest32, + record.shape = AnchoredSourceCaller.shape model.layout ∧ + AnchoredPhysicalDriver.request boundary cap packet.val.profile model.layout record + (RawWHIRKeys.entry ctx packet.val) answers = some request + acceptance : ∃ (seedBatch : RingPCSGame.Prefix × E) (proof : Opening), + wire.initial = some seedBatch ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) wire.tape) wire.replies = .ok proof ∧ + AnchoredPhysicalAnchor.sourceVerify record request.claims.family request.claims.points seedBatch.1 seedBatch.2 + (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) wire.tape) proof = .ok () + +def finish (ctx : RawWHIRKeys.Context) (Q cap : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (record : Record) (configured : configuration packet.val.profile record) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) (state : WireState packet.val.profile) + (history : List (Sigma (RawOracleCoupling.Concrete.GroupAnswer ctx Q))) + (origin : ∃ boundary : Boundary, ∃ model : WHIRCallerSupport.ProductionLayout, ∃ answers : Coordinate → Option Digest32, + record.shape = AnchoredSourceCaller.shape model.layout ∧ + AnchoredPhysicalDriver.request boundary cap packet.val.profile model.layout record + (RawWHIRKeys.entry ctx packet.val) answers = some request) : + Option (Accepted ctx Q cap packet record) := + match initial : state.initial with + | none => none + | some (seed,lambda) => + let c := ParameterBounds.config packet.val.profile + let challenges := CausalGame.challenges c state.tape + match parsed : CausalGame.opening c challenges state.replies with + | .error _ => none + | .ok proof => + match accepted : AnchoredPhysicalAnchor.sourceVerify record request.claims.family request.claims.points + seed lambda c challenges proof with + | .error _ => none + | .ok () => some ⟨request,state,history,configured,origin,⟨(seed,lambda),proof,initial,parsed,accepted⟩⟩ + +/-- Trusted native continuation for either the original caller entry or a later fresh entry. The fresh boundary never receives or samples the original commitment again. Full record comparison finishes before readPhysicalPackets obtains opening gamma/map/lambda. -/ +def verifySource (cap : Nat) (boundary : Boundary) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (record : Record) (proofs : Array PrunedMerklePaths) : + Source cap (Option (Accepted ctx Q cap packet record)) := + if configured : configuration packet.val.profile record then + if mismatch : record.shape ≠ AnchoredSourceCaller.shape model.layout then .done none else + .commit record.root (readCallerInputs ctx Q packet (WHIRModeFinal.callerPositions ctx Q packet) + (fun _ => none) (fun answers => + match parsed : request boundary cap packet.val.profile model.layout record (RawWHIRKeys.entry ctx packet.val) answers with + | none => .done none + | some request => + .claims packet.val.profile (RawWHIRKeys.entry ctx packet.val) request + (readPhysicalPackets ctx stack Q packet.val.profile record.shape.lanes proofs none + (RawOracleCoupling.Concrete.completion ctx Q packet) (completion_profiles ctx Q packet) + (initialWireState packet.val.profile record.root) + (fun state history => .done (finish ctx Q cap packet record configured request state history + ⟨boundary,model,answers,not_ne_iff.mp mismatch,parsed⟩))))) + else .done none + +theorem verifySource_rejected_configuration (cap : Nat) (boundary : Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (record : Record) (proofs : Array PrunedMerklePaths) + (invalid : ¬ configuration packet.val.profile record) : + verifySource cap boundary model ctx stack Q packet record proofs = .done none := by + simp [verifySource,invalid] + +theorem verifySource_rejected_shape (cap : Nat) (boundary : Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (record : Record) (proofs : Array PrunedMerklePaths) + (foreign : record.shape ≠ AnchoredSourceCaller.shape model.layout) : + verifySource cap boundary model ctx stack Q packet record proofs = .done none := by + by_cases configured : configuration packet.val.profile record + · simp [verifySource,configured,foreign] + · simp [verifySource,configured] + +theorem verifySource_counted (cap : Nat) (boundary : Boundary) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (record : Record) (proofs : Array PrunedMerklePaths) : + Counts (sourceBudget ctx Q packet) (verifySource cap boundary model ctx stack Q packet record proofs) := by + unfold verifySource + split + · split + · trivial + · change Counts _ (readCallerInputs _ _ _ _ _ _) + apply readCallerInputs_counted + intro answers + split + · trivial + · change Counts _ (readPhysicalPackets ctx stack Q packet.val.profile record.shape.lanes proofs none _ _ _ _) + apply readPhysicalPackets_counted ctx stack Q packet.val.profile + _ proofs none _ (completion_profiles ctx Q packet) _ _ 0 + intro state history + trivial + · trivial + +/-- Failure is false on rejection. Successful claims are the original decoded native caller claims, and the selector is one immutable record across all sessions. The physical Merkle and mode bridges are separate obligations, not assumed claim coverage. -/ +def nativeWrong (p : ParameterBounds.Profile) (commitment : CommitmentAnchor.Commitment p) + (claims : CausalBindingState.OriginalClaims cap) : Prop := + ¬ ∃ witness, CommitmentAnchor.boundWitness p commitment = some witness ∧ + RingPCSGame.Honest (ParameterBounds.config p) commitment.lanes claims.family claims.points witness + +/-- The root list is computed only from the existing first frozen record table. Neither the original point nor the advertised value contributes to its reconstruction. -/ +noncomputable def anchoredView (p : ParameterBounds.Profile) (state : CausalBindingState.State cap) + (record : Record) (configured : configuration p record) : CommitmentAnchor.Commitment p where + lanes := record.shape.lanes + root := (CausalBindingState.capture state p record.root record.shape.lanes + (by rw [← configured.2.2.1]; exact configured.1.1.2.2.2.2.2)).base + point := fun i => record.point[i.val]'(by rw [configured.1.2.2,configured.2.1]; exact i.isLt) + value := record.value + occupied := ⟨configured.1.1.2.2.2.2.1,by + rw [← configured.2.2.1]; exact configured.1.1.2.2.2.2.2⟩ + +def failure {ctx : RawWHIRKeys.Context} {Q cap : Nat} {packet : RawWHIRKeys.Packet ctx Q} {record : Record} + (state : CausalBindingState.State cap) : + Option (Accepted ctx Q cap packet record) → Prop + | none => False + | some accepted => nativeWrong packet.val.profile + (anchoredView packet.val.profile state record accepted.configuration) accepted.request.claims + +theorem anchored_list_bound (p : ParameterBounds.Profile) (state : CausalBindingState.State cap) + (record : Record) (configured : configuration p record) : + (InitialCandidates.witnesses (ParameterBounds.config p) record.shape.lanes + (anchoredView p state record configured).root).card ≤ 2^32 := + InitialCandidates.production_witnesses_card p _ _ + +/-- Outside one original-point ambiguity event, all later fresh sessions and all their adaptive claim choices share this one selector. -/ +theorem honest_anchor_selects (p : ParameterBounds.Profile) (commitment : CommitmentAnchor.Commitment p) + (clean : ¬ CommitmentAnchor.Ambiguous p commitment.lanes commitment.root commitment.point) + (claims : CausalBindingState.OriginalClaims cap) + (w : CausalGame.Witness (ParameterBounds.config p) commitment.lanes) + (candidate : w ∈ InitialCandidates.witnesses (ParameterBounds.config p) commitment.lanes commitment.root) + (anchor : CommitmentAnchor.value (ParameterBounds.config p) commitment.lanes w + (Array.ofFn commitment.point) = commitment.value) + (honest : RingPCSGame.Honest (ParameterBounds.config p) commitment.lanes claims.family claims.points w) : + ¬ nativeWrong p commitment claims := by + intro wrong + have selected : w ∈ CommitmentAnchor.selected p commitment.lanes commitment.root + commitment.point commitment.value := Finset.mem_filter.mpr ⟨candidate,anchor⟩ + exact wrong ⟨w,CommitmentAnchor.boundWitness_eq p commitment clean w selected,honest⟩ + +/-- Every accepted result carries the literal native occupied-anchor check, with the same retained record. This theorem exposes no caller-chosen evaluator or acceptance-proof input. -/ +theorem accepted_native {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : Record} (accepted : Accepted ctx Q cap packet record) : + ∃ seed lambda proof, + AnchoredPhysicalAnchor.sourceVerify record accepted.request.claims.family accepted.request.claims.points + seed lambda (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) accepted.wire.tape) proof = .ok () := by + obtain ⟨⟨seed,lambda⟩,proof,_,_,native⟩ := accepted.acceptance + exact ⟨seed,lambda,proof,native⟩ + +theorem accepted_record_origin {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : Record} (accepted : Accepted ctx Q cap packet record) : + ∃ (boundary : Boundary) (layout : WHIRCallerClaims.CallerLayout) + (answers : Coordinate → Option Digest32) (decoded : AnchoredSourceCaller.Claims), decodeCaller boundary layout record + (RawWHIRKeys.entry ctx packet.val) (fun q => (answers q).getD DuplexRefinement.zeroDigest) = some decoded ∧ + decoded.record = record ∧ accepted.request.root = record.root ∧ accepted.request.lanes = record.shape.lanes := by + obtain ⟨boundary,model,answers,_,parsed⟩ := accepted.origin + obtain ⟨decoded,parsed,matched,root,lanes⟩ := + request_origin boundary cap packet.val.profile model.layout record (RawWHIRKeys.entry ctx packet.val) answers + accepted.request parsed + exact ⟨boundary,model.layout,answers,decoded,parsed,matched,root,lanes⟩ + +theorem accepted_nativeShapes {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : Record} (accepted : Accepted ctx Q cap packet record) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config packet.val.profile).logN accepted.request.claims.family ∧ + (∀ point ∈ accepted.request.claims.points.toList, + SuccinctPointWeight.Shape (ParameterBounds.config packet.val.profile).logN point) := by + obtain ⟨boundary,model,answers,same,parsed⟩ := accepted.origin + exact request_nativeShapes boundary cap packet.val.profile model record accepted.configuration same + (RawWHIRKeys.entry ctx packet.val) answers accepted.request parsed + +end Whir.AnchoredPhysicalDriver diff --git a/verification/whir/Whir/AnchoredPhysicalSmoke.lean b/verification/whir/Whir/AnchoredPhysicalSmoke.lean new file mode 100644 index 000000000..e7cf7227d --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalSmoke.lean @@ -0,0 +1,96 @@ +import Whir.AnchoredSourcePacket +import Lean.Util.CollectAxioms +import Whir.WHIRNativeErasure + +/-! Executable smoke of the native commit/open record boundary with the real BLAKE2s primitive. These tests do not claim an honest complete WHIR opening fixture or a concrete BLAKE2s security bound. -/ +namespace Whir.AnchoredPhysicalSmoke +open Concrete FiatShamirGame DuplexModeGame AnchoredHeaderCodec AnchoredPhysicalTranscript +open WHIRSourceChronology + +local instance : Add E := ⟨E.add⟩ +local instance : Mul E := ⟨E.mul⟩ +local instance : Zero E := ⟨E.zero⟩ +local instance : One E := ⟨E.one⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +private def iv : Digest32 := DuplexCompression.parameterIV +private def digest (x : Nat) : Digest32 := + fun i => ⟨(x / 256 ^ i.val) % 256, Nat.mod_lt _ (by decide)⟩ + +private theorem digest_exact (x : Nat) : digest x = ByteCodec.encodeNat 32 x := by + funext i + apply Fin.ext + exact (ByteCodec.encodeNat_byte 32 x i).symm +private def shape : Shape := ⟨15,6,1,3⟩ +private def original : DuplexRefinement.State := + DuplexRefinement.absorb (compressionOf blake2sOracle) + (DuplexRefinement.seed (compressionOf blake2sOracle) iv (digest 7) (digest 9)) + (List.ofFn (ByteCodec.encodeNat 13 0x0102030405060708090a0b0c0d)) +private def fresh : DuplexRefinement.State := + DuplexRefinement.seed (compressionOf blake2sOracle) iv (digest 11) (digest 13) + +def smoke : List (String × Bool) := + match (runReal blake2sOracle iv (compile + (receiveSource (cap := 32) shape original (headerScalars shape (digest 17)) (fun _ => 23)))).view.result.value with + | .error _ => [("original commitment received",false)] + | .ok (_,record) => + let frame := openingScalars record + let foreign := {record with root := digest 19} + let context := {record with context := {record.context with previous := record.context.previous+1}} + let point := {record with point := (record.point.headD 0+1)::record.point.drop 1} + let value := {record with value := record.value+1} + let honest := (runReal blake2sOracle iv (compile + (bindingSource (cap := 32) shape record fresh frame))).view.result.value + [("original commitment received",true), + ("derived anchor has exact dimension",record.point.length == shape.logN), + ("normalized native snapshot valid",decide record.context.Valid), + ("honest fresh-session record accepted",match honest with | .ok (_,[]) => true | _ => false), + ("foreign record rejected",verifyBinding shape record (openingScalars foreign) == .error .commitmentMismatch), + ("tampered original context rejected",verifyBinding shape record (openingScalars context) == .error .commitmentMismatch), + ("tampered original point rejected",verifyBinding shape record (openingScalars point) == .error .commitmentMismatch), + ("tampered advertised value rejected",verifyBinding shape record (openingScalars value) == .error .commitmentMismatch), + ("truncated frame errors",verifyBinding shape record (frame.drop 1) == .error .malformedTranscript)] + + +/-- A complete native arithmetic opening with omitted lanes, after an honest record binding in a different session. Dense prover weights are test data only; the executable verifier uses the prefix DP. Merkle authentication of the erased physical fixture is not claimed. -/ +def nativeSmoke : IO Unit := do + for (label,passed) in smoke do + unless passed do throw (IO.userError s!"record smoke failed: {label}") + let c : Protocol.Config := ⟨3,#[1,1],#[1,1],#[2,2],#[0,1]⟩ + let sh : Shape := ⟨3,1,1,1⟩ + let witness : Array K := #[1,7,19,5] + let padded : Array E := witness.map E.ofK ++ #[0,0,0,0] + let result := (runReal blake2sOracle iv (compile (receiveSource (cap := 32) sh original + (headerScalars sh (digest 17)) (fun point => Concrete.mle padded point.toArray)))).view.result.value + let record ← match result with + | .ok (_,record) => pure record + | .error _ => throw (IO.userError "native fixture original commitment rejected") + match (runReal blake2sOracle iv (compile (bindingSource (cap := 32) sh record fresh + (openingScalars record)))).view.result.value with + | .error _ => throw (IO.userError "native fixture fresh record binding rejected") + | .ok _ => pure () + let ch : Protocol.Challenges := + ⟨#[⟨#[2],#[#[13,17]],#[43],7⟩,⟨#[3],#[],#[47],11⟩],#[5]⟩ + let beta : E := 41 + let weight := (CommitmentAnchor.weight c 1 record.point.toArray).map (beta*·) + let target := beta*record.value + let proof ← match Protocol.prove c ch witness weight target with + | .ok (_,proof) => pure proof + | .error message => throw (IO.userError s!"native fixture honest prover: {message}") + let family : Fin 0 → RingPCSGame.FamilyClaim := Fin.elim0 + let seed : RingPCSGame.Prefix := (⟨3,1,0⟩,fun _ => 0) + match AnchoredPhysicalAnchor.sourceVerify record family #[] seed beta c ch + (WHIRPhysicalErasure.eraseOracles proof) with + | .ok () => IO.println "honest fresh-session occupied-prefix native opening accepted" + | .error message => throw (IO.userError s!"native fixture honest verifier: {message}") + +#print axioms AnchoredHeaderCodec.verifyBinding_sound +#print axioms digest_exact +#print axioms AnchoredHeaderRoots.rawHeader_exact +#print axioms AnchoredSourceRegistry.first_query_freezes +#print axioms AnchoredPhysicalTranscript.absorbSource_real +#print axioms AnchoredPhysicalDriver.honest_anchor_selects + +end Whir.AnchoredPhysicalSmoke + +def main : IO Unit := Whir.AnchoredPhysicalSmoke.nativeSmoke diff --git a/verification/whir/Whir/AnchoredPhysicalTranscript.lean b/verification/whir/Whir/AnchoredPhysicalTranscript.lean new file mode 100644 index 000000000..57bf81639 --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalTranscript.lean @@ -0,0 +1,263 @@ +import Whir.AnchoredHeaderCodec +import Whir.WHIRSourceComposition + +/-! Counted physical compression source for the new immutable commit/open boundary. This hand-port uses the same public primitive interface and source-owned chronological records as the physical WHIR verifier. It does not identify an arbitrary chosen-CV primitive oracle with independent random anchor coordinates. -/ +namespace Whir.AnchoredPhysicalTranscript +open Concrete FiatShamirGame DuplexRefinement DuplexFraming +open DuplexModeGame (PrimitiveOracle Query runReal compressionOf) +open WHIRSourceChronology AnchoredHeaderCodec + +/-- Pure capture cannot install a cached output. The native source retains its existing private cache and only uses it under the usual CacheValid precondition. -/ +def absorbByteSource (s : State) (b : Byte) : Source cap State := + let s := if s.consumed = 0 then s else {s with previous := s.consumed,consumed := 0} + if s.pending.size = 64 then + .ask (.primitive .auxiliary ⟨s.cv,padded s.pending,absorbTweak s.first false 64 s.previous,true⟩) + (fun cv => .done {s with cv,pending := #[b],first := false,previous := 0}) + else .done {s with pending := s.pending.push b} + +def absorbSource (s : State) : List Byte → Source cap State + | [] => .done s + | b :: rest => (absorbByteSource s b).bind (fun s => absorbSource s rest) + +def finishSource (s : State) : Source cap State := + if s.pending.isEmpty then .done s else + .ask (.primitive .auxiliary ⟨s.cv,padded s.pending, + absorbTweak s.first true s.pending.size s.previous,true⟩) + (fun cv => .done {s with cv,pending := #[],first := true,previous := 0}) + +def squeezeByteSource (s : State) : Source cap (State × Byte) := + if s.consumed % 32 = 0 then + .ask (.primitive .auxiliary ⟨s.cv,wordsBlock [s.consumed/32],UInt64.ofNat (6*2^56),true⟩) + (fun digest => .done ({s with consumed := s.consumed+1,output := digest}, + digest ⟨s.consumed%32,Nat.mod_lt _ (by decide)⟩)) + else .done ({s with consumed := s.consumed+1}, + s.output ⟨s.consumed%32,Nat.mod_lt _ (by decide)⟩) + +def squeezeLoopSource : Nat → State → Source cap (State × List Byte) + | 0,s => .done (s,[]) + | n+1,s => (squeezeByteSource s).bind fun (t,b) => + (squeezeLoopSource n t).map fun (u,bs) => (u,b::bs) + +def squeezeSource (s : State) (n : Nat) : Source cap (Except DuplexRefinement.Error (State × List Byte)) := + if n = 0 then .done (.ok (s,[])) + else if s.consumed+n ≤ maxCursor then + (finishSource s).bind fun t => (squeezeLoopSource n t).map Except.ok + else .done (.error .cursorExhausted) + +def sampleVecSource (s : State) (n : Nat) : Source cap (Except DuplexRefinement.Error (State × List E)) := + (squeezeSource s (24*n)).map (Except.map fun (t,bytes) => + (t,List.ofFn (fun j : Fin n => ByteCodec.decodeE (fun i => + (bytes[24*j.val+i.val]?).getD 0)))) + +def scalarsBytes (xs : List E) : List Byte := xs.flatMap (fun x => List.ofFn (ByteCodec.encodeE x)) + +/-- Header parsing and shape validation happen before point sampling. Root announcement precedes the finalization and first fresh output block; its snapshot therefore cannot contain any anchor answer. Only the advertised value is read after that one point. -/ +def receiveSource (expected : Shape) (s : State) (header : List E) (advertised : List E → E) : + Source cap (Except AnchoredHeaderCodec.Error (State × Record)) := + if !decide expected.Valid then .done (.error .commitmentMismatch) + else match parseHeader expected header with + | none => .done (.error .commitmentMismatch) + | some root => + (absorbSource s (scalarsBytes header)).bind fun headerState => + .commit root ((sampleVecSource headerState expected.logN).bind fun sampled => + match sampled with + | .error _ => .done (.error .cursorExhausted) + | .ok (pointState,point) => + let advertised := advertised point + (absorbSource pointState (scalarsBytes [advertised])).map fun final => + .ok (final,⟨expected,root,capture s,point,advertised⟩)) + +/-- A fresh-session frame is absorbed only after all record fields match. An invalid or truncated record returns a literal error with no compression call and no opening batching challenge. -/ +def bindingSource (expected : Shape) (record : Record) (session : State) (transport : List E) : + Source cap (Except AnchoredHeaderCodec.Error (State × List E)) := + match verifyBinding expected record transport with + | .error e => .done (.error e) + | .ok rest => (absorbSource session (scalarsBytes (openingScalars record))).map + (fun state => .ok (state,rest)) + +theorem bindingSource_rejected (expected : Shape) (record : Record) (session : State) + (transport : List E) (e : AnchoredHeaderCodec.Error) + (rejected : verifyBinding expected record transport = .error e) : + bindingSource (cap := cap) expected record session transport = .done (.error e) := by + simp [bindingSource,rejected] + +theorem absorbByteSource_real (C : PrimitiveOracle) (iv : Digest32) (s : State) (b : Byte) : + (runReal C iv (compile (absorbByteSource (cap := cap) s b))).view.result.value = + absorbByte (compressionOf C) s b := by + unfold absorbByteSource absorbByte + dsimp only + split <;> split <;> rfl + +theorem finishSource_real (C : PrimitiveOracle) (iv : Digest32) (s : State) : + (runReal C iv (compile (finishSource (cap := cap) s))).view.result.value = finish (compressionOf C) s := by + unfold finishSource finish finalized + split <;> rfl + +theorem squeezeByteSource_real (C : PrimitiveOracle) (iv : Digest32) (s : State) : + (runReal C iv (compile (squeezeByteSource (cap := cap) s))).view.result.value = + squeezeByte (compressionOf C) s := by + unfold squeezeByteSource squeezeByte outputBlock + split <;> rfl + +theorem absorbSource_real (C : PrimitiveOracle) (iv : Digest32) (s : State) (bytes : List Byte) : + (runReal C iv (compile (absorbSource (cap := cap) s bytes))).view.result.value = + absorb (compressionOf C) s bytes := by + induction bytes generalizing s with + | nil => rfl + | cons b rest ih => + rw [absorbSource,Source.real_bind] + dsimp only + rw [absorbByteSource_real,ih] + rfl + +theorem squeezeLoopSource_real (C : PrimitiveOracle) (iv : Digest32) (n : Nat) (s : State) : + (runReal C iv (compile (squeezeLoopSource (cap := cap) n s))).view.result.value = + squeezeLoop (compressionOf C) n s := by + induction n generalizing s with + | zero => rfl + | succ n ih => + rw [squeezeLoopSource,Source.real_bind] + dsimp only + have sampled := squeezeByteSource_real (cap := cap) C iv s + rw [Source.real_map] + dsimp only + rw [ih] + exact congrArg (fun pair : State × Byte => + let rest := squeezeLoop (compressionOf C) n pair.1 + (rest.1,pair.2::rest.2)) sampled + +theorem squeezeSource_real (C : PrimitiveOracle) (iv : Digest32) (s : State) (n : Nat) : + (runReal C iv (compile (squeezeSource (cap := cap) s n))).view.result.value = + squeeze (compressionOf C) s n := by + unfold squeezeSource squeeze + split + · rfl + · split + · rw [Source.real_bind] + dsimp only + have finished := finishSource_real (cap := cap) C iv s + rw [finished,Source.real_map] + dsimp only + exact congrArg Except.ok (squeezeLoopSource_real (cap := cap) C iv n (finish (compressionOf C) s)) + · rfl + +theorem sampleVecSource_real (C : PrimitiveOracle) (iv : Digest32) (s : State) (n : Nat) : + (runReal C iv (compile (sampleVecSource (cap := cap) s n))).view.result.value = + sampleVec (compressionOf C) s n := by + rw [sampleVecSource,Source.real_map] + dsimp only + have squeezed := squeezeSource_real (cap := cap) C iv s (24*n) + rw [squeezed] + unfold sampleVec + split + next e sampled => simp [sampled,Except.map] + next t bytes sampled => + simp only [sampled,Except.map] + have size := (squeeze_exact_cursor (compressionOf C) s t (24*n) bytes sampled).2 + apply congrArg (fun point : List E => (Except.ok (t,point) : Except DuplexRefinement.Error (State × List E))) + apply congrArg (@List.ofFn E n) + funext j + apply congrArg ByteCodec.decodeE + funext i + have bound : 24*j.val+i.val < bytes.length := by + have := j.isLt + have := i.isLt + omega + simp [bound] + +theorem absorbByteSource_counted (s : State) (b : Byte) : Counts 1 (absorbByteSource (cap := cap) s b) := by + unfold absorbByteSource + dsimp only + split <;> split <;> simp [Counts,Query.cost] + +theorem absorbSource_counted (s : State) (bytes : List Byte) : + Counts bytes.length (absorbSource (cap := cap) s bytes) := by + induction bytes generalizing s with + | nil => trivial + | cons b rest ih => + simpa only [absorbSource,List.length_cons,Nat.add_comm] using + Source.bind_counted (absorbByteSource s b) (fun t => absorbSource t rest) 1 rest.length + (absorbByteSource_counted s b) ih + +theorem finishSource_counted (s : State) : Counts 1 (finishSource (cap := cap) s) := by + unfold finishSource + split <;> simp [Counts,Query.cost] + +theorem squeezeByteSource_counted (s : State) : Counts 1 (squeezeByteSource (cap := cap) s) := by + unfold squeezeByteSource + split <;> simp [Counts,Query.cost] + +theorem squeezeLoopSource_counted (n : Nat) (s : State) : + Counts n (squeezeLoopSource (cap := cap) n s) := by + induction n generalizing s with + | zero => trivial + | succ n ih => + simpa only [squeezeLoopSource,Nat.add_comm] using + Source.bind_counted (squeezeByteSource s) (fun (t,b) => + (squeezeLoopSource n t).map (fun (u,bs) => (u,b::bs))) 1 n + (squeezeByteSource_counted s) (fun (t,b) => (Source.map_counted _ _ _).mpr (ih t)) + +theorem squeezeSource_counted (s : State) (n : Nat) : + Counts (1+n) (squeezeSource (cap := cap) s n) := by + unfold squeezeSource + split + · trivial + · split + · exact Source.bind_counted (finishSource s) _ 1 n (finishSource_counted s) + (fun t => (Source.map_counted _ _ _).mpr (squeezeLoopSource_counted n t)) + · trivial + +theorem sampleVecSource_counted (s : State) (n : Nat) : + Counts (1+24*n) (sampleVecSource (cap := cap) s n) := by + exact (Source.map_counted _ _ _).mpr (squeezeSource_counted s (24*n)) + +/-- This bound deliberately counts all source context and frame bytes, including the original CV and pending packs. It is conservative per byte, not the obsolete unanchored packet path cost. -/ +def receiveBudget (shape : Shape) : Nat := 120 + (1+24*shape.logN) + 24 + +theorem receiveSource_counted (shape : Shape) (s : State) (header : List E) (advertised : List E → E) : + Counts (receiveBudget shape) (receiveSource (cap := cap) shape s header advertised) := by + unfold receiveSource + split + · trivial + · split + · trivial + · rename_i root parsed + have exactHeader := parseHeader_sound shape header root parsed + subst header + apply Source.bind_counted _ _ 120 (1+24*shape.logN+24) + · have counted := absorbSource_counted (cap := cap) s (scalarsBytes (headerScalars shape root)) + simpa [scalarsBytes,headerScalars] using counted + · intro state + change Counts _ ((sampleVecSource state shape.logN).bind _) + apply Source.bind_counted _ _ (1+24*shape.logN) 24 (sampleVecSource_counted state _) + intro sampled + cases sampled with + | error e => trivial + | ok result => + apply (Source.map_counted _ _ _).mpr + have counted := absorbSource_counted (cap := cap) result.1 (scalarsBytes [advertised result.2]) + simpa [scalarsBytes] using counted + +theorem bindingSource_counted (expected : Shape) (record : Record) (session : State) (transport : List E) : + Counts (24*(openingScalars record).length) (bindingSource (cap := cap) expected record session transport) := by + unfold bindingSource + cases checked : verifyBinding expected record transport with + | error error => trivial + | ok rest => + apply (Source.map_counted _ _ _).mpr + have bytes : (scalarsBytes (openingScalars record)).length = 24*(openingScalars record).length := + WHIRHistory.scalarBytes_length _ + simpa only [bytes] using absorbSource_counted (cap := cap) session (scalarsBytes (openingScalars record)) + +/-- Nonempty mandatory header absorption discards the old output cursor before the one original vector request. There is no externally installed output cache in the captured record. -/ +theorem original_header_resets_cursor (C : DuplexRefinement.Compression) (s : State) (shape : Shape) (root : Digest32) : + (absorb C s (scalarsBytes (headerScalars shape root))).consumed = 0 := by + apply absorb_nonempty_cursor + have length : (scalarsBytes (headerScalars shape root)).length = 120 := by + change (WHIRHistory.scalarBytes (headerScalars shape root)).length = 120 + rw [WHIRHistory.scalarBytes_length,headerScalars_length] + intro empty + rw [empty] at length + contradiction + +end Whir.AnchoredPhysicalTranscript diff --git a/verification/whir/Whir/AnchoredSourceCaller.lean b/verification/whir/Whir/AnchoredSourceCaller.lean new file mode 100644 index 000000000..022ca4952 --- /dev/null +++ b/verification/whir/Whir/AnchoredSourceCaller.lean @@ -0,0 +1,230 @@ +import Whir.AnchoredHeaderCodec +import Whir.WHIRCallerSource +import Whir.WHIRCallerSupport +import Whir.CommitmentAnchor + +/-! The 32c CPU/recursion scalar projection retains the existing production payload interpreter and its public layouts. It reads one original header, derives one anchor point from the prior byte stream, retains its value, and compares the complete record at the stack boundary before opening batching. Original context is the native captured input to this parser, not a serialized claim or a caller-selected output cache. -/ +namespace Whir.AnchoredSourceCaller +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec + +def shape (layout : CallerLayout) : Shape := + ⟨callerMu layout,6,callerRate layout,callerLanes layout⟩ + +/-- These are the source's range guards. No unmerged selector-alignment guard is introduced. -/ +def prelude : CallerLayout → CallerParser Unit + | .recursion _ => pure () + | .cpu layout => do + check (layout.tables.length == 11) + readAnnouncements (layout.tables.map CpuTableLayout.tau ++ [layout.logInvRate]) + let clock ← readScalar + check (clock.c1 == 0 && clock.c2 == 0 && clock.c0.toNat / 2^40 == 1 && clock.c0.toNat % 32 == 0) + +def receive (layout : CallerLayout) (original : Context) : CallerParser Record := do + check (decide (shape layout).Valid) + let header ← readScalars 5 + let some root := parseHeader (shape layout) header | return ← (fun _ => none) + let point ← drawScalars (shape layout).logN + let value ← readScalar + pure ⟨shape layout,root,original,point,value⟩ + +def payload : CallerLayout → CallerParser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) + | .recursion layout => recPayload layout + | .cpu layout => cpuPayload layout + +/-- Literal equality is checked on every transported record scalar before the caller may produce its final opening input. -/ +def binding (record : Record) : CallerParser Unit := do + let frame ← readScalars (openingScalars record).length + check (frame == openingScalars record) + +structure Claims where + record : Record + caller : CallerClaims + +/-- This source projection covers the immutable original record and every original production claim; the anchor is retained separately for the occupied-prefix verifier, not disguised as a full-cube PointClaim. -/ +def sourceClaims (layout : CallerLayout) (original : Context) : CallerParser Claims := do + prelude layout + let record ← receive layout original + let (families,points) ← payload layout + binding record + pure ⟨record,⟨record.root,families,points⟩⟩ + +def reads (n : Nat) : List WHIRCallerShape.EventShape := List.replicate n (.absorb 24) +def draws (n : Nat) : List WHIRCallerShape.EventShape := List.replicate n (.squeeze 24) + +/-- The actual extra anchor run and full retransmitted original context are counted. The old payload schedule is retained, not a second caller convention. -/ +def callerShape (layout : CallerLayout) (pendingBytes : Nat) : List WHIRCallerShape.EventShape := + reads (rootScalarCount layout-2) ++ reads 5 ++ draws (shape layout).logN ++ reads 1 ++ + (WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout) ++ + reads (10+(shape layout).logN+(pendingBytes+23)/24) + +def entryLength (layout : CallerLayout) (pendingBytes : Nat) : Nat := + WHIRCallerShape.entryCount (callerShape layout pendingBytes) + +def outputCap (layout : CallerLayout) (pendingBytes : Nat) : Nat := + WHIRCallerShape.callerOutputCap (callerShape layout pendingBytes) + +/-- An exact caller parse rejects all leftover tokens, including a second resampled anchor or a substituted opening record. -/ +def interpret (layout : CallerLayout) (original : Context) (tokens : List CallerToken) : Option Claims := do + if tokensShape tokens ≠ callerShape layout original.pendingBytes then none else do + let (claims,rest) ← sourceClaims layout original tokens + if rest.isEmpty then some claims else none + +def decode (layout : CallerLayout) (original : Context) (entry : FramedHistory) + (answers : Coordinate → Digest32) : Option Claims := do + let tokens ← entryTokens entry answers + interpret layout original tokens + +def physical (compression : DuplexRefinement.Compression) (iv : Digest32) + (layout : CallerLayout) (original : Context) (entry : FramedHistory) : Option Claims := do + let tokens ← WHIRCallerClaims.sourceTokens compression iv entry + interpret layout original tokens + +theorem decode_physical (compression : DuplexRefinement.Compression) (iv : Digest32) + (layout : CallerLayout) (original : Context) (entry : FramedHistory) + (answers : Coordinate → Digest32) + (observed : ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, + answers q = DuplexRefinement.evalCoordinate compression iv q) : + decode layout original entry answers = physical compression iv layout original entry := by + simp only [decode,physical,entryTokens_source compression iv entry answers observed] + +theorem binding_exact (record : Record) (suffix : List CallerToken) : + binding record ((openingScalars record).map CallerToken.sent ++ suffix) = some ((),suffix) := by + change ((readScalars (openingScalars record).length + ((openingScalars record).map CallerToken.sent ++ suffix)).bind + (fun pair => check (pair.1 == openingScalars record) pair.2)) = some ((),suffix) + rw [readScalars_sent] + simp [check] + rfl + +open WHIRCallerGeometry + +theorem payload_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : CallerLayout) (geometry : LayoutGeometry C R layout) : + Ensures (payload layout) (PayloadValid C R (callerPlacements layout)) := by + cases layout with + | cpu layout => exact cpuPayload_geometry C R columnDown ringDown layout geometry + | recursion layout => exact recPayload_geometry C R columnDown ringDown layout geometry + +theorem sourceClaims_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) (ringDown : Downward R) + (layout : CallerLayout) (geometry : LayoutGeometry C R layout) (original : Context) : + Ensures (sourceClaims layout original) (fun claims => ClaimsValid C R (callerPlacements layout) claims.caller) := by + unfold sourceClaims + refine ensures_bind_any _ _ _ ?_ + intro _ + refine ensures_bind_any _ _ _ ?_ + intro record + refine ensures_bind _ _ _ _ (payload_geometry C R columnDown ringDown layout geometry) ?_ + intro result valid + refine ensures_bind_any _ _ _ ?_ + intro _ + exact ensures_pure _ _ valid + +theorem decode_geometry (model : WHIRCallerSupport.ProductionLayout) (original : Context) + (entry : FramedHistory) (answers : Coordinate → Digest32) (claims : Claims) + (accepted : decode model.layout original entry answers = some claims) : + ClaimsValid (fun i d => WHIRCallerSupport.columnFits model.sources i d = true) + (fun o d => WHIRCallerSupport.ringFits model.sources o d = true) + (callerPlacements model.layout) claims.caller := by + cases trace : entryTokens entry answers with + | none => simp [decode,trace] at accepted + | some tokens => + have interpreted : interpret model.layout original tokens = some claims := by + simpa [decode,trace] using accepted + unfold interpret at interpreted + split at interpreted + · contradiction + · cases parsed : sourceClaims model.layout original tokens with + | none => simp [parsed] at interpreted + | some result => + simp only [parsed] at interpreted + change (if result.2.isEmpty then some result.1 else none) = some claims at interpreted + split at interpreted + · cases Option.some.inj interpreted + exact sourceClaims_geometry _ _ (WHIRCallerSupport.columnFits_mono model.sources) + (WHIRCallerSupport.ringFits_mono model.sources) model.layout model.geometry original + tokens result.1 result.2 parsed + · contradiction + +/-- Native dimensions and occupied support come from the same constructed production layout as the historical payload, not an assumed claim-coverage predicate. -/ +theorem decode_nativeShapes (model : WHIRCallerSupport.ProductionLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (original : Context) (entry : FramedHistory) (answers : Coordinate → Digest32) (claims : Claims) + (accepted : decode model.layout original entry answers = some claims) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN + (fun i : Fin claims.caller.families.length => claims.caller.families[i]) ∧ + (∀ point ∈ claims.caller.points.toList, SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by + exact WHIRCallerSupport.geometry_nativeShapes model p lanes metadata laneBound claims.caller + (decode_geometry model original entry answers claims accepted) + +theorem geometry_anchored_shapes (model : WHIRCallerSupport.ProductionLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (decoded : Claims) + (geometry : WHIRCallerGeometry.ClaimsValid + (fun i d => WHIRCallerSupport.columnFits model.sources i d = true) + (fun o d => WHIRCallerSupport.ringFits model.sources o d = true) (callerPlacements model.layout) decoded.caller) + (seed : RingPCSGame.Prefix) (lambda : E) (point : Array E) (value : E) : + let c := ParameterBounds.config p + let claims := (RingPCSGame.transformedClaims (2^c.logN) + (fun j : Fin decoded.caller.families.length => decoded.caller.families[j]) decoded.caller.points seed).push + ⟨CommitmentAnchor.weight c lanes point,value⟩ + (claims.all (fun claim => Protocol.shapeValid c lanes claim.weight) = true) ∧ + Protocol.shapeValid c lanes (CausalGame.batchClaims (2^c.logN) claims lambda).weight = true := by + obtain ⟨rings,points⟩ := WHIRCallerSupport.geometry_support model decoded.caller geometry + have occupied := WHIRCallerSupport.openingMatches_occupied model.layout p lanes metadata + let c := ParameterBounds.config p + let claims := (RingPCSGame.transformedClaims (2^c.logN) + (fun j : Fin decoded.caller.families.length => decoded.caller.families[j]) decoded.caller.points seed).push + ⟨CommitmentAnchor.weight c lanes point,value⟩ + have supported : ∀ claim ∈ claims.toList, claim.weight.size = 2^c.logN ∧ + ∀ i, lanes*2^(c.logN-c.folds[0]!) ≤ i → i < 2^c.logN → claim.weight[i]! = 0 := by + intro claim member + simp only [claims,Array.toList_push,List.mem_append,List.mem_singleton] at member + rcases member with member | last + · refine ⟨WHIRCallerSupport.transformed_claim_size _ _ _ _ claim member,?_⟩ + intro i lower upper + exact WHIRCallerSupport.transformed_claim_support _ (callerWords model.layout) _ _ seed + (fun j => rings _ (by simp)) points claim member i (occupied.trans lower) upper + · subst claim + refine ⟨by simp [CommitmentAnchor.weight],?_⟩ + intro i lower upper + simp [CommitmentAnchor.weight,ArrayLayout.getElem!_tab _ _ _ upper,Nat.not_lt_of_le lower] + rfl + constructor + · apply Array.all_eq_true'.mpr + intro claim member + have supported := supported claim (by simpa [claims,c] using member) + exact WHIRCallerSupport.shapeValid_of_support c lanes claim.weight + (ParameterBounds.production_config_valid p).1 + (WHIRCallerSupport.openingMatches_positive model.layout p lanes metadata) laneBound supported.1 + (fun i lower upper => supported.2 i lower (by simpa [supported.1] using upper)) + · apply WHIRCallerSupport.shapeValid_of_support c lanes _ + (ParameterBounds.production_config_valid p).1 + (WHIRCallerSupport.openingMatches_positive model.layout p lanes metadata) laneBound + (InitialBatching.batchClaims_size _ _ _) + intro i lower upper + apply InitialBatching.batchClaims_zero_tail (2^c.logN) (lanes*2^(c.logN-c.folds[0]!)) claims lambda _ i lower + (by simpa only [InitialBatching.batchClaims_size] using upper) + intro j i lower upper + exact (supported claims[j] (by simp)).2 i lower upper + +theorem decode_anchored_shapes (model : WHIRCallerSupport.ProductionLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (original : Context) (entry : FramedHistory) (answers : Coordinate → Digest32) (decoded : Claims) + (accepted : decode model.layout original entry answers = some decoded) + (seed : RingPCSGame.Prefix) (lambda : E) (point : Array E) (value : E) : + let c := ParameterBounds.config p + let claims := (RingPCSGame.transformedClaims (2^c.logN) + (fun j : Fin decoded.caller.families.length => decoded.caller.families[j]) decoded.caller.points seed).push + ⟨CommitmentAnchor.weight c lanes point,value⟩ + (claims.all (fun claim => Protocol.shapeValid c lanes claim.weight) = true) ∧ + Protocol.shapeValid c lanes (CausalGame.batchClaims (2^c.logN) claims lambda).weight = true := + geometry_anchored_shapes model p lanes metadata laneBound decoded + (decode_geometry model original entry answers decoded accepted) seed lambda point value + +theorem config_initial_rate : ∀ p : ParameterBounds.Profile, + (ParameterBounds.config p).rates[0]! = p.2.val+1 := by + decide +kernel +end Whir.AnchoredSourceCaller diff --git a/verification/whir/Whir/AnchoredSourceFreshCaller.lean b/verification/whir/Whir/AnchoredSourceFreshCaller.lean new file mode 100644 index 000000000..cf583e25b --- /dev/null +++ b/verification/whir/Whir/AnchoredSourceFreshCaller.lean @@ -0,0 +1,217 @@ +import Whir.AnchoredSourceCaller + +/-! Fresh-session scalar projection of the anchored caller. The trusted record is +an input, never received or reconstructed: only the historical payload followed +by its complete binding frame is parsed. This module proves parser/physical +compression correspondence, not packet-driver equivalence, algebraic acceptance, +or concrete BLAKE2s security. `none` deliberately forgets the native error and +consumed cursor; only successful parses have the exact consumption theorem below. +Native metadata validation and error/consumption refinement belong to the driver. -/ +namespace Whir.AnchoredSourceFreshCaller +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec +open WHIRCallerGeometry + +/-- Keep the original payload schedule, removing exactly its original root and +CPU announcements. No original prelude, header, or anchor sample is replayed. -/ +def callerShape (layout : CallerLayout) (saved : Record) : List WHIRCallerShape.EventShape := + (WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout) ++ + AnchoredSourceCaller.reads (openingScalars saved).length + +def entryLength (layout : CallerLayout) (saved : Record) : Nat := + WHIRCallerShape.entryCount (callerShape layout saved) + +def outputCap (layout : CallerLayout) (saved : Record) : Nat := + WHIRCallerShape.callerOutputCap (callerShape layout saved) + +/-- The returned record and root are literally the saved inputs; attacker tokens +can only supply the existing payload and a frame checked against that record. -/ +def sourceClaims (layout : CallerLayout) (saved : Record) : + CallerParser AnchoredSourceCaller.Claims := do + let (families,points) ← AnchoredSourceCaller.payload layout + AnchoredSourceCaller.binding saved + pure ⟨saved,⟨saved.root,families,points⟩⟩ + +/-- Exact event shape and full consumption are both required. A successful +payload with an inserted original header, resampled anchor, or leftover tokens +cannot bypass either guard. -/ +def interpret (layout : CallerLayout) (saved : Record) (tokens : List CallerToken) : + Option AnchoredSourceCaller.Claims := do + if tokensShape tokens ≠ callerShape layout saved then none else do + let (claims,rest) ← sourceClaims layout saved tokens + if rest.isEmpty then some claims else none + +def decode (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) : Option AnchoredSourceCaller.Claims := do + let tokens ← entryTokens entry answers + interpret layout saved tokens + +def physical (compression : DuplexRefinement.Compression) (iv : Digest32) + (layout : CallerLayout) (saved : Record) (entry : FramedHistory) : + Option AnchoredSourceCaller.Claims := do + let tokens ← WHIRCallerClaims.sourceTokens compression iv entry + interpret layout saved tokens + +/-- Equality holds for successes and failures, including malformed exact frame +recovery. This does not identify native error constructors or failure cursors. -/ +theorem decode_physical (compression : DuplexRefinement.Compression) (iv : Digest32) + (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) + (observed : ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, + answers q = DuplexRefinement.evalCoordinate compression iv q) : + decode layout saved entry answers = physical compression iv layout saved entry := by + simp only [decode,physical,entryTokens_source compression iv entry answers observed] + +/-- Literal equality is required even when an altered frame has the same scalar +count and therefore the same fresh event shape. -/ +theorem binding_frame_rejected (saved : Record) (frame : List E) + (suffix : List CallerToken) (length : frame.length = (openingScalars saved).length) + (changed : frame ≠ openingScalars saved) : + AnchoredSourceCaller.binding saved (frame.map CallerToken.sent ++ suffix) = none := by + change ((readScalars (openingScalars saved).length + (frame.map CallerToken.sent ++ suffix)).bind + (fun pair => check (pair.1 == openingScalars saved) pair.2)) = none + rw [← length,readScalars_sent] + simp [check,changed] + +/-- Binding succeeds after exactly the shared payload, without replaying any +part of the original receive operation. The suffix is retained by the state +parser and rejected by the exact `interpret` guard if nonempty. -/ +theorem sourceClaims_bound (layout : CallerLayout) (saved : Record) + (tokens suffix : List CallerToken) + (families : List RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (payload : AnchoredSourceCaller.payload layout tokens = + some ((families,points),(openingScalars saved).map CallerToken.sent ++ suffix)) : + sourceClaims layout saved tokens = + some (⟨saved,⟨saved.root,families,points⟩⟩,suffix) := by + change ((AnchoredSourceCaller.payload layout tokens).bind + (fun pair => ((AnchoredSourceCaller.binding saved pair.2).bind + (fun bound => some ((⟨saved,⟨saved.root,pair.1.1,pair.1.2⟩⟩ : + AnchoredSourceCaller.Claims),bound.2))))) = _ + rw [payload] + simp only [Option.bind_some,AnchoredSourceCaller.binding_exact] + +theorem interpret_exact (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) (claims : AnchoredSourceCaller.Claims) : + interpret layout saved tokens = some claims ↔ + tokensShape tokens = callerShape layout saved ∧ + sourceClaims layout saved tokens = some (claims,[]) := by + unfold interpret + by_cases shape : tokensShape tokens = callerShape layout saved + · simp only [shape,ne_eq,not_true_eq_false,↓reduceIte] + cases parsed : sourceClaims layout saved tokens with + | none => simp + | some result => + rcases result with ⟨value,rest⟩ + cases rest with + | nil => simp + | cons token rest => simp + · simp [shape] + +theorem interpret_shape_rejected (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) (mismatch : tokensShape tokens ≠ callerShape layout saved) : + interpret layout saved tokens = none := by + simp [interpret,mismatch] + +theorem interpret_leftover_rejected (layout : CallerLayout) (saved : Record) + (tokens rest : List CallerToken) (claims : AnchoredSourceCaller.Claims) + (parsed : sourceClaims layout saved tokens = some (claims,rest)) (leftover : rest ≠ []) : + interpret layout saved tokens = none := by + unfold interpret + split + · rfl + · simp only [parsed] + cases rest with + | nil => contradiction + | cons token rest => rfl + +/-- Every accepted entry decodes to the exact fresh shape and leaves no scalar, +draw, or nonce token. Frame decoding additionally checks exact entry identity. -/ +theorem decode_exact (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) (claims : AnchoredSourceCaller.Claims) + (accepted : decode layout saved entry answers = some claims) : + ∃ tokens, entryTokens entry answers = some tokens ∧ + tokensShape tokens = callerShape layout saved ∧ + sourceClaims layout saved tokens = some (claims,[]) := by + cases trace : entryTokens entry answers with + | none => simp [decode,trace] at accepted + | some tokens => + have interpreted : interpret layout saved tokens = some claims := by + simpa [decode,trace] using accepted + exact ⟨tokens,rfl,(interpret_exact layout saved tokens claims).mp interpreted⟩ + +theorem sourceClaims_retained (layout : CallerLayout) (saved : Record) : + Ensures (sourceClaims layout saved) (fun claims => + claims.record = saved ∧ claims.caller.root = saved.root) := by + unfold sourceClaims + refine ensures_bind_any _ _ _ ?_ + intro result + refine ensures_bind_any _ _ _ ?_ + intro _ + exact ensures_pure _ _ ⟨rfl,rfl⟩ + +theorem decode_retained (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) (claims : AnchoredSourceCaller.Claims) + (accepted : decode layout saved entry answers = some claims) : + claims.record = saved ∧ claims.caller.root = saved.root := by + obtain ⟨tokens,_,_,parsed⟩ := decode_exact layout saved entry answers claims accepted + exact sourceClaims_retained layout saved tokens claims [] parsed + +theorem sourceClaims_geometry (C R : Nat → Nat → Prop) (columnDown : Downward C) + (ringDown : Downward R) (layout : CallerLayout) (geometry : LayoutGeometry C R layout) + (saved : Record) : Ensures (sourceClaims layout saved) (fun claims => + ClaimsValid C R (callerPlacements layout) claims.caller) := by + unfold sourceClaims + refine ensures_bind _ _ _ _ + (AnchoredSourceCaller.payload_geometry C R columnDown ringDown layout geometry) ?_ + intro result valid + refine ensures_bind_any _ _ _ ?_ + intro _ + exact ensures_pure _ _ valid + +theorem decode_geometry (model : WHIRCallerSupport.ProductionLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) + (claims : AnchoredSourceCaller.Claims) + (accepted : decode model.layout saved entry answers = some claims) : + ClaimsValid (fun i d => WHIRCallerSupport.columnFits model.sources i d = true) + (fun o d => WHIRCallerSupport.ringFits model.sources o d = true) + (callerPlacements model.layout) claims.caller := by + obtain ⟨tokens,_,_,parsed⟩ := decode_exact model.layout saved entry answers claims accepted + exact sourceClaims_geometry _ _ (WHIRCallerSupport.columnFits_mono model.sources) + (WHIRCallerSupport.ringFits_mono model.sources) model.layout model.geometry saved + tokens claims [] parsed + +theorem decode_nativeShapes (model : WHIRCallerSupport.ProductionLayout) + (p : ParameterBounds.Profile) (lanes : Nat) + (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) + (claims : AnchoredSourceCaller.Claims) + (accepted : decode model.layout saved entry answers = some claims) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN + (fun i : Fin claims.caller.families.length => claims.caller.families[i]) ∧ + (∀ point ∈ claims.caller.points.toList, + SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by + exact WHIRCallerSupport.geometry_nativeShapes model p lanes metadata laneBound claims.caller + (decode_geometry model saved entry answers claims accepted) + +/-- The same geometry/support helper as the original caller, including the saved +anchor as an occupied-prefix claim, rather than a fabricated full-cube claim. -/ +theorem decode_anchored_shapes (model : WHIRCallerSupport.ProductionLayout) + (p : ParameterBounds.Profile) (lanes : Nat) + (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) + (decoded : AnchoredSourceCaller.Claims) + (accepted : decode model.layout saved entry answers = some decoded) + (seed : RingPCSGame.Prefix) (lambda : E) : + let c := ParameterBounds.config p + let claims := (RingPCSGame.transformedClaims (2^c.logN) + (fun j : Fin decoded.caller.families.length => decoded.caller.families[j]) + decoded.caller.points seed).push + ⟨CommitmentAnchor.weight c lanes saved.point.toArray,saved.value⟩ + (claims.all (fun claim => Protocol.shapeValid c lanes claim.weight) = true) ∧ + Protocol.shapeValid c lanes (CausalGame.batchClaims (2^c.logN) claims lambda).weight = true := + AnchoredSourceCaller.geometry_anchored_shapes model p lanes metadata laneBound decoded + (decode_geometry model saved entry answers decoded accepted) seed lambda saved.point.toArray saved.value + +end Whir.AnchoredSourceFreshCaller diff --git a/verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean b/verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean new file mode 100644 index 000000000..54c38d403 --- /dev/null +++ b/verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean @@ -0,0 +1,178 @@ +import Whir.AnchoredSourceFreshCaller +import Lean.Util.CollectAxioms + +/-! Standalone executable fresh-caller parser regression. Real deployed primitive +outputs are recovered in two different transcript seeds. Payload scalar zeroes +are claim-projection fixture data, not an honest algebraically verified caller +proof; no packet/native-verifier or concrete hash-security claim follows. -/ +namespace Whir.AnchoredSourceFreshCallerSmoke +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +private def compression : DuplexRefinement.Compression := + DuplexModeGame.compressionOf DuplexModeGame.blake2sOracle +private def iv : Digest32 := DuplexCompression.parameterIV +/-- The existing exact byte formula avoids evaluating the recursive encoder's +high-index Fin eliminators repeatedly in this compiled fixture. -/ +private def digest (n : Nat) : Digest32 := + fun i => ⟨(n / 256^i.val) % 256,Nat.mod_lt _ (by decide)⟩ + +private theorem digest_exact (n : Nat) : digest n = ByteCodec.encodeNat 32 n := by + funext i + apply Fin.ext + exact (ByteCodec.encodeNat_byte 32 n i).symm +private def layout : CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ + +private def zeroToken : WHIRCallerShape.EventShape → CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) + +private def payloadTokens : List CallerToken := + ((WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout)).map zeroToken + +private def boundTokens (saved : Record) : List CallerToken := + payloadTokens ++ (openingScalars saved).map CallerToken.sent + +private def freshEntry (tokens : List CallerToken) : FramedHistory := + tokenHistory (digest 11) (digest 13) tokens + +/-- Store each permitted physical output as bytes once. Outside-output answers +are irrelevant to `entryTokens`, exactly as in its existing observer contract. -/ +private def actualBlocks (entry : FramedHistory) : List (Coordinate × Array Byte) := + (WHIRCallerOutputs.callerOutputs entry).map + (fun q => (q,Array.ofFn (DuplexRefinement.evalCoordinate compression iv q))) + +private def answersFromBlocks (blocks : List (Coordinate × Array Byte)) (q : Coordinate) : Digest32 := + match blocks.find? (fun row => decide (row.1 = q)) with + | some (_,bytes) => fun i => bytes[i.val]! + | none => digest 0 + +private theorem actualAnswers_observed (entry : FramedHistory) (q : Coordinate) + (member : q ∈ WHIRCallerOutputs.callerOutputs entry) : + answersFromBlocks (actualBlocks entry) q = DuplexRefinement.evalCoordinate compression iv q := by + unfold answersFromBlocks actualBlocks + let blocks := (WHIRCallerOutputs.callerOutputs entry).map + (fun q => (q,Array.ofFn (DuplexRefinement.evalCoordinate compression iv q))) + change (match blocks.find? (fun row => decide (row.1 = q)) with + | some (_,bytes) => fun (i : Fin 32) => bytes[i.val]! + | none => digest 0) = _ + cases found : blocks.find? (fun row => decide (row.1 = q)) with + | none => + have absent := List.find?_eq_none.mp found + have contained : (q,Array.ofFn (DuplexRefinement.evalCoordinate compression iv q)) ∈ blocks := + List.mem_map.mpr ⟨q,member,rfl⟩ + have impossible := absent _ contained + simp at impossible + | some row => + obtain ⟨key,_,equal⟩ := List.mem_map.mp (List.mem_of_find?_eq_some found) + have predicate := List.find?_some found + have keyEq : row.1 = q := of_decide_eq_true predicate + subst row + dsimp only at keyEq + subst key + funext i + simp + +private theorem fresh_actual (saved : Record) (entry : FramedHistory) : + AnchoredSourceFreshCaller.decode layout saved entry (answersFromBlocks (actualBlocks entry)) = + AnchoredSourceFreshCaller.physical compression iv layout saved entry := + AnchoredSourceFreshCaller.decode_physical compression iv layout saved entry + (answersFromBlocks (actualBlocks entry)) (actualAnswers_observed entry) + +private def parseFresh (saved : Record) (tokens : List CallerToken) : + Option AnchoredSourceCaller.Claims := + let entry := freshEntry tokens + let blocks := actualBlocks entry + AnchoredSourceFreshCaller.decode layout saved entry (answersFromBlocks blocks) + +private def changedFrame (saved : Record) : Record := + {saved with value := saved.value+1} + +private def require (label : String) (passed : Bool) : IO Unit := do + unless passed do throw (IO.userError s!"fresh-caller parser smoke failed: {label}") + IO.println s!"fresh-caller parser: {label}" + +/-- Obtain the saved anchor from the original seeded stream, then parse a +separately seeded fresh payload with no original header or anchor draw. -/ +def smoke : IO Unit := do + IO.println "fresh-caller parser: starting actual original/fresh fixture" + let original := DuplexRefinement.seed compression iv (digest 7) (digest 9) + let shape := AnchoredSourceCaller.shape layout + let root := digest 17 + let header := headerScalars shape root + let afterHeader := DuplexRefinement.absorb compression original (WHIRHistory.scalarBytes header) + let point ← match DuplexRefinement.sampleVec compression afterHeader shape.logN with + | .ok (_,point) => pure point + | .error _ => throw (IO.userError "original anchor sampling failed") + require "original physical anchor derived" (point.length == shape.logN) + let saved : Record := ⟨shape,root,capture original,point,E.ofK 23⟩ + require "trusted saved record metadata valid" (decide saved.Valid) + let tokens := boundTokens saved + let originalTokens := header.map CallerToken.sent ++ point.map CallerToken.draw ++ + [CallerToken.sent saved.value] ++ tokens + let originalEntry := tokenHistory (digest 7) (digest 9) originalTokens + let entry := freshEntry tokens + require "genuinely separate transcript seed" (decide (originalEntry.domain ≠ entry.domain)) + let originalBlocks := actualBlocks originalEntry + let originalClaims := AnchoredSourceCaller.decode layout saved.context originalEntry (answersFromBlocks originalBlocks) + require "original record parsed before saving" (match originalClaims with + | some decoded => decide (decoded.record = saved ∧ decoded.caller.root = root) + | none => false) + let claims := parseFresh saved tokens + require "fresh saved-record payload accepted" (match claims with + | some decoded => decide (decoded.record = saved ∧ decoded.caller.root = root) + | none => false) + require "changed frame retains exact fresh shape" (decide + (tokensShape (boundTokens (changedFrame saved)) = AnchoredSourceFreshCaller.callerShape layout saved)) + require "changed binding frame rejected" (parseFresh saved (boundTokens (changedFrame saved))).isNone + let insertedHeader := header.map CallerToken.sent ++ tokens + require "inserted original header rejected" (parseFresh saved insertedHeader).isNone + let resampled := payloadTokens ++ point.map CallerToken.draw ++ + (openingScalars saved).map CallerToken.sent + require "resampled anchor rejected" (parseFresh saved resampled).isNone + let leftovers := tokens ++ [.sent 0] + require "leftover scalar rejected" (parseFresh saved leftovers).isNone + let leftoverEntry := freshEntry leftovers + let leftoverBlocks := actualBlocks leftoverEntry + let leftoverRaw := (WHIRCallerClaims.entryTokens leftoverEntry (answersFromBlocks leftoverBlocks)).bind + (AnchoredSourceFreshCaller.sourceClaims layout saved) + require "state parser retains leftover before exact guard" (match leftoverRaw with + | some (decoded,rest) => decide (decoded.record = saved ∧ rest = [.sent 0]) + | none => false) + let broken := {entry with frames := entry.frames.mapIdx (fun i frame => + if i = 0 then + match frame with + | .absorb consumed bytes => .absorb (consumed+1) bytes + | .nonce consumed bits nonce => .nonce (consumed+1) bits nonce + else frame)} + let malformedBlocks := actualBlocks broken + let malformed := AnchoredSourceFreshCaller.decode layout saved broken (answersFromBlocks malformedBlocks) + require "malformed consumption cursor rejected" malformed.isNone + +#print axioms AnchoredSourceFreshCaller.decode_physical +#print axioms AnchoredSourceFreshCaller.interpret_exact +#print axioms AnchoredSourceFreshCaller.decode_retained +#print axioms AnchoredSourceFreshCaller.decode_geometry +#print axioms AnchoredSourceFreshCaller.decode_nativeShapes +#print axioms AnchoredSourceFreshCaller.decode_anchored_shapes +#print axioms AnchoredSourceFreshCaller.binding_frame_rejected +#print axioms AnchoredSourceFreshCaller.sourceClaims_bound +#print axioms digest_exact +#print axioms actualAnswers_observed +#print axioms fresh_actual + +end Whir.AnchoredSourceFreshCallerSmoke + +def main : IO Unit := Whir.AnchoredSourceFreshCallerSmoke.smoke diff --git a/verification/whir/Whir/AnchoredSourceRegistry.lean b/verification/whir/Whir/AnchoredSourceRegistry.lean new file mode 100644 index 000000000..5f4e5b5e5 --- /dev/null +++ b/verification/whir/Whir/AnchoredSourceRegistry.lean @@ -0,0 +1,111 @@ +import Whir.AnchoredHeaderRoots +import Whir.WHIRSourceChronology + +/-! First registration is source-derived from the exact raw key before its first group reply. The underlying root snapshot and historical first-record table are the existing causal state, not a second Merkle verifier convention. Shape/statement identities index immutable header captures while equal roots reuse their earlier frozen table. -/ +namespace Whir.AnchoredSourceRegistry +open Concrete FiatShamirGame DuplexModeGame +open MerkleTransport.Commitments +open AnchoredHeaderRoots + +structure Frozen where + snapshot : Snapshot + records : Records + log : PublicMerkleLog.PublicLog + +structure State (cap : Nat) where + binding : CausalBindingState.State cap := CausalBindingState.empty cap + headers : Header → Option Frozen := fun _ => none + +/-- No answer, point, value or acceptance evidence is an argument. Every output-block index uses this same first header identity. -/ +def register (state : State cap) (header : Header) : State cap := + match state.headers header with + | some _ => state + | none => + let binding := CausalBindingState.registerRoot state.binding header.root + { binding + headers := Function.update state.headers header (some + ⟨(lookup header.root binding.registry).getD (CausalBindingState.snapshot []), + (binding.frozen header.root).getD [],(binding.frozenLog header.root).getD []⟩) } + +def beforeRaw (registry : Public) (state : State cap) {Q : Nat} (key : RawKey Q) : State cap := + match rawHeader registry key with + | none => state + | some header => register state header + +/-- The native step receives the key before allocating its reply. This order prevents a later root, caller-output marker, or original-point value from changing the registered capture. -/ +def allocate (registry : Public) (state : State cap) {Q : Nat} (key : RawKey Q) + (answer : State cap → Digest32 × State cap) : Digest32 × State cap := + answer (beforeRaw registry state key) + +theorem register_known (state : State cap) (header : Header) : + ∃ frozen, (register state header).headers header = some frozen := by + unfold register + split + next frozen known => exact ⟨frozen,known⟩ + next unknown => simp + +theorem register_root_known (state : State cap) (header : Header) + (new : state.headers header = none) : + ∃ snapshot, lookup header.root (register state header).binding.registry = some snapshot := by + simp only [register,new] + exact CausalBindingState.registerRoot_known state.binding header.root + +theorem register_preserves (state : State cap) (header other : Header) (frozen : Frozen) + (known : state.headers header = some frozen) : + (register state other).headers header = some frozen := by + unfold register + split + · exact known + · rename_i absent + by_cases same : header = other + · subst other; rw [known] at absent; contradiction + · simpa [Function.update_of_ne same] using known + +theorem register_binding_extends (state : State cap) (header : Header) : + CausalBindingState.Extends state.binding (register state header).binding := by + unfold register + split + · exact .refl _ + · exact CausalBindingState.registerRoot_extends _ _ + +theorem beforeRaw_known (registry : Public) (state : State cap) {Q : Nat} (key : RawKey Q) + (header : Header) (parsed : rawHeader registry key = some header) : + ∃ frozen, (beforeRaw registry state key).headers header = some frozen := by + simp only [beforeRaw,parsed] + exact register_known state header + +theorem beforeRaw_preserves (registry : Public) (state : State cap) {Q : Nat} (key : RawKey Q) + (header : Header) (frozen : Frozen) (known : state.headers header = some frozen) : + (beforeRaw registry state key).headers header = some frozen := by + unfold beforeRaw + split + · exact known + · exact register_preserves state header _ frozen known + +theorem beforeRaw_binding_extends (registry : Public) (state : State cap) {Q : Nat} (key : RawKey Q) : + CausalBindingState.Extends state.binding (beforeRaw registry state key).binding := by + unfold beforeRaw + split + · exact .refl _ + · exact register_binding_extends state _ + +/-- Replaying more raw requests cannot overwrite root or shape captures. Each first group is prepared at its query, not after a requested block or an adaptive advertised value. -/ +def prepareHistory (registry : Public) : State cap → List (RawKey Q) → State cap + | state,[] => state + | state,key::rest => prepareHistory registry (beforeRaw registry state key) rest + +theorem prepareHistory_preserves (registry : Public) (state : State cap) (keys : List (RawKey Q)) + (header : Header) (frozen : Frozen) (known : state.headers header = some frozen) : + (prepareHistory registry state keys).headers header = some frozen := by + induction keys generalizing state with + | nil => exact known + | cons key rest ih => exact ih _ (beforeRaw_preserves registry state key header frozen known) + +theorem first_query_freezes (registry : Public) (state : State cap) (key : RawKey Q) + (rest : List (RawKey Q)) (header : Header) (parsed : rawHeader registry key = some header) : + ∃ frozen, (beforeRaw registry state key).headers header = some frozen ∧ + (prepareHistory registry state (key::rest)).headers header = some frozen := by + obtain ⟨frozen,known⟩ := beforeRaw_known registry state key header parsed + exact ⟨frozen,known,prepareHistory_preserves registry _ rest header frozen known⟩ + +end Whir.AnchoredSourceRegistry diff --git a/verification/whir/Whir/AuthenticatedResetCollector.lean b/verification/whir/Whir/AuthenticatedResetCollector.lean new file mode 100644 index 000000000..7954329aa --- /dev/null +++ b/verification/whir/Whir/AuthenticatedResetCollector.lean @@ -0,0 +1,232 @@ +import Whir.RewindRowExtraction + +/-! A black-box collector runs COMPLETE verifier trials. Acceptance, including +all tag/shape/algebra/authentication checks, gates every recorded response. +The executable path never reads a root preimage to manufacture a record. -/ +namespace Whir.AuthenticatedResetSupport +open Concrete Protocol CausalGame CausalProbability KnowledgeExtraction RewindRowExtraction + +/-- The actual verifier on supplied black-box replies. -/ +def acceptedReplies (input : Public) (tape : Tape input.config) (answers : List Reply) : Bool := + let c := input.config + let ch := challenges c tape + if !(input.claims.all fun claim => shapeValid c input.lanes claim.weight) then false + else + let statement := batchClaims (2 ^ c.logN) input.claims tape.1 + match opening c ch answers.toArray with + | .error _ => false + | .ok proof => (verify c ch input.lanes (liftRoot input.root) + statement.weight statement.value proof).isOk + +theorem acceptedReplies_actual (input : Public) (strategy : Strategy) (tape : Tape input.config) : + acceptedReplies input tape (run strategy input [] + (visibleBatches input.config tape.1 (challenges input.config tape))) = + experiment input strategy tape := by rfl + +/-- Rejection or a malformed position list returns no data, not a default row. -/ +def acceptedRecords (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) (answers : List Reply) : + List (Fin (2 ^ depth) × Array E) := + if acceptedReplies input tape answers then + let ch := challenges input.config tape + let proof := decodedOpening input.config ch answers.toArray + match deriveQueries depth input.config.queries[level.val]! ch.levels[level.val]!.querySqueezes with + | none => [] + | some positions => + if valid : positions.size = input.config.queries[level.val]! ∧ + ∀ i : Fin input.config.queries[level.val]!, positions[i.val]! < 2 ^ depth then + List.ofFn fun i : Fin input.config.queries[level.val]! => + (⟨positions[i.val]!, valid.2 i⟩, proof.levels[level.val]!.rows[i.val]!) + else [] + else [] + +def trialRecords (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (depth : Nat) : + List (Fin (2 ^ depth) × Array E) := + acceptedRecords prover.input tape level depth (run prover.respond prover.input [] + (visibleBatches prover.input.config tape.1 (challenges prover.input.config tape))) + +theorem acceptedRecords_length_le (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) (answers : List Reply) : + (acceptedRecords input tape level depth answers).length ≤ input.config.queries[level.val]! := by + unfold acceptedRecords + split + · dsimp only + split + · simp + · split <;> simp + · simp + +theorem rejected_no_records (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (depth : Nat) + (rejected : experiment prover.input prover.respond tape = false) : + trialRecords prover tape level depth = [] := by + simp [trialRecords, acceptedRecords, acceptedReplies_actual, rejected] + +/-- All records, not just records from an honest strategy, satisfy the actual +verifier's authentication equation. The depth premise is purely static shape. -/ +theorem trialRecords_authenticated (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (depth : Nat) + (shape : (CausalExecution.foldAt prover.input prover.respond tape level + prover.input.config.folds[level.val]!).n + prover.input.config.rates[level.val]! = depth) : + ∀ record ∈ trialRecords prover tape level depth, + record.2 = (CausalExecution.levelAt prover.input prover.respond tape level).oracle[record.1.val]! := by + intro record member + unfold trialRecords acceptedRecords at member + split at member + · rename_i accepted + rw [acceptedReplies_actual] at accepted + obtain ⟨positions, sampled, rowCount, auth⟩ := accepted_queries_authenticated + prover.input prover.respond tape accepted level + rw [shape] at sampled + simp only [sampled] at member + split at member + · rename_i valid + obtain ⟨i, rfl⟩ := List.mem_ofFn.mp member + have authentic := auth i.val (by rw [valid.1]; exact i.isLt) + simpa [bne, CausalExecution.proof, CausalTerminal.proof] using authentic + · simp at member + · simp at member + +/-- Each message is obtained by legal strict-prefix replay; earlier replies are +never passed to the black box by the extractor. -/ +def trialProgram (input : Public) (historyPrefix : List Batch) : List Batch → + (List Reply → RewindProgram input.config input.lanes) → RewindProgram input.config input.lanes + | [], finish => finish [] + | message :: rest, finish => + .query historyPrefix message (fun reply => + trialProgram input (historyPrefix ++ [message]) rest (fun replies => finish (reply :: replies))) + +/-- A collection of full trials, stopped only by its supplied output checker. -/ +def collectAcceptedProgram (input : Public) (level : Fin input.config.folds.size) (depth : Nat) : + List (Tape input.config) → (List (Fin (2 ^ depth) × Array E) → Option (Witness input.config input.lanes)) → + RewindProgram input.config input.lanes + | [], finish => .finish (finish []) + | tape :: tapes, finish => + trialProgram input [] (visibleBatches input.config tape.1 (challenges input.config tape)) + (fun replies => collectAcceptedProgram input level depth tapes + (fun records => finish (acceptedRecords input tape level depth replies ++ records))) + +def collectedRecords (prover : CommittedProver) (level : Fin prover.input.config.folds.size) + (depth : Nat) (tapes : List (Tape prover.input.config)) : List (Fin (2 ^ depth) × Array E) := + tapes.flatMap (fun tape => trialRecords prover tape level depth) + +theorem collectedRecords_length_le (prover : CommittedProver) (level : Fin prover.input.config.folds.size) + (depth : Nat) (tapes : List (Tape prover.input.config)) : + (collectedRecords prover level depth tapes).length ≤ tapes.length * prover.input.config.queries[level.val]! := by + induction tapes with + | nil => simp [collectedRecords] + | cons tape tapes ih => + simpa only [collectedRecords, trialRecords, List.flatMap_cons, List.length_append, + List.length_cons, Nat.add_mul, Nat.one_mul, Nat.add_comm] using + Nat.add_le_add (acceptedRecords_length_le prover.input tape level depth _) ih + +theorem replayPast_append (input : Public) (strategy : Strategy) (past : History) + (left right : List Batch) : + replayPast input strategy past (left ++ right) = + replayPast input strategy (replayPast input strategy past left) right := by + induction left generalizing past with + | nil => rfl + | cons message left ih => simp only [List.cons_append, replayPast, ih] + +/-- Count every response and every replay, including rejected trials. This is +an interaction count, not a unit-cost runtime claim: verifier field arithmetic, +coordinate comparisons, list/array allocation and the prover's own work are +separate. The data bound counts retained authenticated coordinate/row records; +arbitrary untrusted reply allocation is not charged as field arithmetic. -/ +def trialCalls : Nat → Nat → Nat + | _, 0 => 0 + | start, count + 1 => trialCalls (start + 1) count + start + 1 + +theorem run_trialProgram (input : Public) (strategy : Strategy) (historyPrefix messages : List Batch) + (maxReplay extra : Nat) (within : historyPrefix.length + messages.length ≤ maxReplay) + (finish : List Reply → RewindProgram input.config input.lanes) : + runRewind input strategy maxReplay (messages.length + extra) + (trialProgram input historyPrefix messages finish) = + let result := runRewind input strategy maxReplay extra + (finish (run strategy input (replayPast input strategy [] historyPrefix) messages)) + ⟨result.output, result.responseCalls + trialCalls historyPrefix.length messages.length⟩ := by + induction messages generalizing historyPrefix finish with + | nil => + simp only [List.length_nil, Nat.zero_add, trialProgram, run, trialCalls, Nat.add_zero] + | cons message messages ih => + have current : historyPrefix.length ≤ maxReplay := by simp only [List.length_cons] at within; omega + have later : (historyPrefix ++ [message]).length + messages.length ≤ maxReplay := by + simpa [List.length_cons, List.length_append, Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using within + rw [List.length_cons, show messages.length + 1 + extra = (messages.length + extra) + 1 by omega] + simp only [trialProgram, runRewind, ite_eq_left current] + rw [ih (historyPrefix ++ [message]) later] + simp only [run, replayPast_append, replayPast, List.length_append, List.length_singleton, + trialCalls] + congr 1 + omega + +def collectionFuel (input : Public) (tapes : List (Tape input.config)) : Nat := + (tapes.map fun tape => (visibleBatches input.config tape.1 (challenges input.config tape)).length).sum + +def collectionCalls (input : Public) (tapes : List (Tape input.config)) : Nat := + (tapes.map fun tape => trialCalls 0 + (visibleBatches input.config tape.1 (challenges input.config tape)).length).sum + +theorem run_collectAcceptedProgram (prover : CommittedProver) + (level : Fin prover.input.config.folds.size) (depth maxReplay : Nat) + (tapes : List (Tape prover.input.config)) + (within : ∀ tape ∈ tapes, + (visibleBatches prover.input.config tape.1 (challenges prover.input.config tape)).length ≤ maxReplay) + (finish : List (Fin (2 ^ depth) × Array E) → Option (Witness prover.input.config prover.input.lanes)) : + runRewind prover.input prover.respond maxReplay (collectionFuel prover.input tapes) + (collectAcceptedProgram prover.input level depth tapes finish) = + ⟨finish (collectedRecords prover level depth tapes), collectionCalls prover.input tapes⟩ := by + induction tapes generalizing finish with + | nil => simp [collectAcceptedProgram, collectionFuel, collectionCalls, collectedRecords, runRewind] + | cons tape tapes ih => + simp only [collectAcceptedProgram, collectionFuel, List.map_cons, List.sum_cons] + rw [run_trialProgram _ _ [] _ maxReplay _ (by simpa using within tape (by simp))] + dsimp only + simp only [collectionFuel] at ih + rw [ih (fun t ht => within t (by simp [ht]))] + simp [replayPast, collectedRecords, trialRecords, collectionCalls, Nat.add_comm] + +/-- Acceptance itself ensures data availability for each actual sampled +coordinate; parsing success is proved, not assumed of the malicious prover. -/ +theorem trialRecords_contains (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (depth : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) + (query : RewindCoverage.QueryTape depth prover.input.config.queries[level.val]!) + (squeezes : (challenges prover.input.config tape).levels[level.val]!.querySqueezes = Array.ofFn query) + (accepted : experiment prover.input prover.respond tape = true) + (i : Fin prover.input.config.queries[level.val]!) : + ∃ record ∈ trialRecords prover tape level depth, + record.1 = RewindCoverage.sampledPosition depth _ positive noWrap query i := by + unfold trialRecords acceptedRecords + rw [acceptedReplies_actual, accepted] + simp only [ite_true] + rw [squeezes, SamplingProbability.deriveQueries_eq depth _ positive noWrap] + have valid : (Concrete.tab prover.input.config.queries[level.val]! fun j => + SamplingProbability.concretePlace prover.input.config.queries[level.val]! depth j + (Layout.rawQuery depth (fun k => (Array.ofFn query)[k]!.toNat) j)).size = + prover.input.config.queries[level.val]! ∧ + ∀ j : Fin prover.input.config.queries[level.val]!, + (Concrete.tab prover.input.config.queries[level.val]! fun j => + SamplingProbability.concretePlace prover.input.config.queries[level.val]! depth j + (Layout.rawQuery depth (fun k => (Array.ofFn query)[k]!.toNat) j))[j.val]! < 2 ^ depth := by + constructor + · simp + · intro j + rw [ArrayLayout.getElem!_tab _ _ _ j.isLt, + ← RewindCoverage.sampledPosition_actual depth _ positive noWrap query j] + exact (RewindCoverage.sampledPosition depth _ positive noWrap query j).isLt + simp only [dite_eq_left valid] + refine ⟨_, List.mem_ofFn.mpr ⟨i, rfl⟩, ?_⟩ + apply Fin.ext + simpa only [Prod.fst, Fin.val_mk, ArrayLayout.getElem!_tab _ _ _ i.isLt] using + (RewindCoverage.sampledPosition_actual depth _ positive noWrap query i).symm + +#print axioms run_trialProgram +#print axioms run_collectAcceptedProgram +#print axioms trialRecords_contains + +#print axioms trialRecords_authenticated +#print axioms rejected_no_records +#print axioms collectedRecords_length_le +end Whir.AuthenticatedResetSupport diff --git a/verification/whir/Whir/AuthenticatedResetLaw.lean b/verification/whir/Whir/AuthenticatedResetLaw.lean new file mode 100644 index 000000000..125eb3395 --- /dev/null +++ b/verification/whir/Whir/AuthenticatedResetLaw.lean @@ -0,0 +1,151 @@ +import Whir.AuthenticatedResetSuffix +import Whir.AuthenticatedResetProbability + +/-! Exact averaging of a random actual prefix and an independent full reset. +Tape coordinates are swapped by bijections; no accepted-prover goodness or +conditional independence of replies is an input to this law. -/ +namespace Whir.AuthenticatedResetSupport +open Concrete Protocol CausalGame CausalProbability SamplingProbability AuthenticatedResetProbability + +private theorem get_resetCoordinates {c : Config} (cut : Nat) (fresh base : Tape c) + (qs : List (Coordinate c)) (q : Coordinate c) : + get q (resetCoordinates cut fresh qs base) = + if cut ≤ position q ∧ q ∈ qs then get q fresh else get q base := by + induction qs generalizing base with + | nil => simp [resetCoordinates] + | cons r rs ih => + by_cases same : q = r + · subst r + by_cases later : cut ≤ position q + · simp [resetCoordinates, ih, later] + · simp [resetCoordinates, ih, later] + · by_cases later : cut ≤ position r + · simp [resetCoordinates, ih, later, same, get_set_ne _ _ _ _ same] + · simp [resetCoordinates, ih, later, same] + +private theorem levelCoordinate_visible {c : Config} (i : Fin c.folds.size) (q : Coordinate c) + (member : q ∈ levelCoordinates c i.val) : q ∈ visibleCoordinates c := by + apply List.mem_append_left + apply List.mem_append_right + exact List.mem_flatMap.mpr ⟨i.val, List.mem_range.mpr i.isLt, member⟩ + +private theorem coordinate_enumerated {c : Config} (q : Coordinate c) : + q ∈ visibleCoordinates c ++ List.ofFn (fun j : Fin (c.logN - c.folds.toList.sum) => Coordinate.tail j) := by + cases q with + | initial => simp [visibleCoordinates] + | fold i j => + apply List.mem_append_left + apply levelCoordinate_visible i + simp only [levelCoordinates, i.isLt, dite_true, List.mem_append] + exact Or.inl (Or.inl (List.mem_ofFn.mpr ⟨j, rfl⟩)) + | ood i j => + apply List.mem_append_left + apply levelCoordinate_visible i + simp only [levelCoordinates, i.isLt, dite_true, List.mem_append] + exact Or.inl (Or.inr (List.mem_ofFn.mpr ⟨j, rfl⟩)) + | query i => + apply List.mem_append_left + apply levelCoordinate_visible i + simp [levelCoordinates, i.isLt] + | tail j => exact List.mem_append_right _ (List.mem_ofFn.mpr ⟨j, rfl⟩) + +def mixedTape {c : Config} (cut : Nat) (base fresh : Tape c) : Tape c := + (coordinates c).symm (fun q => if position q < cut then get q base else get q fresh) + +@[simp] theorem get_mixedTape {c : Config} (cut : Nat) (base fresh : Tape c) (q : Coordinate c) : + get q (mixedTape cut base fresh) = if position q < cut then get q base else get q fresh := by + change ((coordinates c) ((coordinates c).symm _)) q = _ + simp + +theorem resetSuffix_eq_mixedTape {c : Config} (cut : Nat) (base fresh : Tape c) : + resetSuffix cut base fresh = mixedTape cut base fresh := by + apply (coordinates c).injective + funext q + change get q _ = get q _ + rw [get_mixedTape] + unfold resetSuffix + rw [get_resetCoordinates] + simp only [coordinate_enumerated, and_true] + split_ifs <;> first | rfl | omega + +/-- Swapping coordinates is an involution of the ENTIRE two-tape space. -/ +def mixEquiv (c : Config) (cut : Nat) : Tape c × Tape c ≃ Tape c × Tape c where + toFun p := (mixedTape cut p.1 p.2, mixedTape cut p.2 p.1) + invFun p := (mixedTape cut p.1 p.2, mixedTape cut p.2 p.1) + left_inv p := by + apply Prod.ext <;> apply (coordinates c).injective <;> funext q + all_goals change get q (mixedTape cut _ _) = get q _ + all_goals simp only [get_mixedTape]; split_ifs <;> rfl + right_inv p := by + apply Prod.ext <;> apply (coordinates c).injective <;> funext q + all_goals change get q (mixedTape cut _ _) = get q _ + all_goals simp only [get_mixedTape]; split_ifs <;> rfl + +theorem resetSuffix_probability {c : Config} (cut : Nat) (event : Tape c → Prop) : + probability (fun p : Tape c × Tape c => event (resetSuffix cut p.1 p.2)) = probability event := by + simp only [resetSuffix_eq_mixedTape] + exact (probability_equiv (mixEquiv c cut) (fun p => event p.1)).trans (product_left event) + +def replaceEquiv {c : Config} (q : Coordinate c) : Tape c × Sample q ≃ Tape c × Sample q where + toFun p := (set q p.1 p.2, get q p.1) + invFun p := (set q p.1 p.2, get q p.1) + left_inv p := by simp + right_inv p := by simp + +theorem replace_probability {c : Config} (q : Coordinate c) (event : Tape c → Prop) : + probability (fun p : Tape c × Sample q => event (set q p.1 p.2)) = probability event := + (probability_equiv (replaceEquiv q) (fun p => event p.1)).trans (product_left event) + +/-- Full reset/query replacement preserves the original verifier law when the +prefix is independently uniform; no first-accepted-prefix conditioning occurs. -/ +theorem resetAndReplace_probability {c : Config} (cut : Nat) (q : Coordinate c) (event : Tape c → Prop) : + probability (fun p : (Tape c × Tape c) × Sample q => + event (set q (resetSuffix cut p.1.1 p.1.2) p.2)) = probability event := by + simp only [resetSuffix_eq_mixedTape] + have mixed := probability_equiv (Equiv.prodCongr (mixEquiv c cut) (Equiv.refl (Sample q))) + (fun p : (Tape c × Tape c) × Sample q => event (set q p.1.1 p.2)) + change probability (fun p : (Tape c × Tape c) × Sample q => + event (set q (mixedTape cut p.1.1 p.1.2) p.2)) = _ at mixed + rw [mixed] + let shuffle : (Tape c × Tape c) × Sample q ≃ (Tape c × Sample q) × Tape c := + { toFun := fun p => ((p.1.1, p.2), p.1.2) + invFun := fun p => ((p.1.1, p.2), p.1.2) + left_inv := fun _ => rfl + right_inv := fun _ => rfl } + have reordered := probability_equiv shuffle + (fun p : (Tape c × Sample q) × Tape c => event (set q p.1.1 p.1.2)) + change probability (fun p : (Tape c × Tape c) × Sample q => event (set q p.1.1 p.2)) = _ at reordered + rw [reordered, product_left (fun p : Tape c × Sample q => event (set q p.1 p.2))] + exact replace_probability q event + +def fullResetEquiv (input : Public) (level : Fin input.config.folds.size) (depth : Nat) + (chunks : queryChunks input.config level = + ((input.config.queries[level.val]! + 192 / depth - 1) / (192 / depth))) : + Tape input.config × (RewindCoverage.QueryTape depth input.config.queries[level.val]! × + (E × Tape input.config)) ≃ + (Tape input.config × Tape input.config) × Sample (.query level) where + toFun p := ((p.1, p.2.2.2), ((fun j => p.2.1 (Fin.cast chunks j)), p.2.2.1)) + invFun p := (p.1.1, ((fun j => p.2.1 (Fin.cast chunks.symm j)), (p.2.2, p.1.2))) + left_inv _ := rfl + right_inv _ := rfl + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Exact acceptance averaging for the implemented legal full-reset sampler, +not an assumed law on partially accepting prover answers. -/ +theorem fullResetTape_probability (input : Public) (level : Fin input.config.folds.size) + (depth : Nat) (chunks) (event : Tape input.config → Prop) : + probability (fun p : Tape input.config × + (RewindCoverage.QueryTape depth input.config.queries[level.val]! × (E × Tape input.config)) => + event (fullResetTape input p.1 level depth chunks p.2.1 p.2.2)) = probability event := by + have fact := probability_equiv (fullResetEquiv input level depth chunks) + (fun p : (Tape input.config × Tape input.config) × Sample (.query level) => + event (set (.query level) (resetSuffix (position (.query level)) p.1.1 p.1.2) p.2)) + simpa only [fullResetTape, fullResetEquiv, Equiv.coe_fn_mk] using + fact.trans (resetAndReplace_probability _ _ event) + +#print axioms fullResetTape_probability + +#print axioms resetSuffix_probability +#print axioms resetAndReplace_probability +end Whir.AuthenticatedResetSupport diff --git a/verification/whir/Whir/AuthenticatedResetProbability.lean b/verification/whir/Whir/AuthenticatedResetProbability.lean new file mode 100644 index 000000000..549bf34bc --- /dev/null +++ b/verification/whir/Whir/AuthenticatedResetProbability.lean @@ -0,0 +1,92 @@ +import Whir.RewindCoverage + +/-! Finite probability facts for acceptance-dependent reset events. Independence +is used only for the complete product trial seed, never for prover answers. -/ +namespace Whir.AuthenticatedResetProbability +open SamplingProbability +open scoped BigOperators + +variable {A : Type*} [Fintype A] [Nonempty A] + +theorem nonneg (P : A → Prop) : 0 ≤ probability P := by + unfold probability + positivity + +theorem mono (P Q : A → Prop) (h : ∀ a, P a → Q a) : + probability P ≤ probability Q := by + classical + simp only [probability, Fintype.card_subtype] + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_le_card (by intro a ha; simpa using h a (Finset.mem_filter.mp ha).2) + +theorem le_one (P : A → Prop) : probability P ≤ 1 := by + classical + unfold probability + apply (div_le_one (by exact_mod_cast Fintype.card_pos : (0 : ℝ) < Fintype.card A)).mpr + rw [Fintype.card_subtype] + exact_mod_cast Finset.card_filter_le Finset.univ P + +theorem complement (P : A → Prop) : probability (fun a => ¬ P a) = 1 - probability P := by + classical + have partition : (Finset.univ.filter P).card + (Finset.univ.filter fun a => ¬ P a).card = + Fintype.card A := by + simpa using Finset.card_filter_add_card_filter_not (s := (Finset.univ : Finset A)) P + simp only [probability, Fintype.card_subtype] + have positive : (0 : ℝ) < Fintype.card A := by exact_mod_cast Fintype.card_pos + have castPartition : ((Finset.univ.filter P).card : ℝ) + + (Finset.univ.filter fun a => ¬ P a).card = Fintype.card A := by exact_mod_cast partition + field_simp + linarith + +omit [Nonempty A] in +theorem union_le {I : Type*} [Fintype I] (P : I → A → Prop) : + probability (fun a => ∃ i, P i a) ≤ ∑ i, probability (P i) := by + classical + have events : (Finset.univ.filter fun a => ∃ i, P i a) = + Finset.univ.biUnion (fun i => Finset.univ.filter (P i)) := by ext a; simp + rw [probability_eq_uniformProb, events] + simpa only [probability_eq_uniformProb, Rat.cast_sum] using + (show (Soundness.uniformProb (Finset.univ.biUnion fun i => Finset.univ.filter (P i)) : ℝ) ≤ + ∑ i, (Soundness.uniformProb (Finset.univ.filter (P i)) : ℝ) by + exact_mod_cast Soundness.union_bound (fun i => Finset.univ.filter (P i))) + +def splitUnit (A : Type*) : A ≃ Unit × A where + toFun a := ((), a) + invFun a := a.2 + left_inv _ := rfl + right_inv a := by cases a with | mk u a => cases u; rfl + +theorem independent_misses (P : A → Prop) (rounds : Nat) : + probability (fun seed : Fin rounds → A => ∀ r, ¬ P (seed r)) = + (1 - probability P) ^ rounds := by + have product := coordinateEvent_probability (splitUnit (Fin rounds → A)) (fun _ a => ¬ P a) + change probability (fun seed : Fin rounds → A => ∀ r, ¬ P (seed r)) = + ∏ _ : Fin rounds, probability (fun a => ¬ P a) at product + simpa only [complement, Finset.prod_const, Finset.card_univ, Fintype.card_fin] using product + +omit [Nonempty A] in +theorem product_left {B : Type*} [Fintype B] [Nonempty B] (P : A → Prop) : + probability (fun a : A × B => P a.1) = probability P := by + classical + let e : {a : A × B // P a.1} ≃ {a : A // P a} × B := + { toFun := fun a => (⟨a.val.1, a.property⟩, a.val.2) + invFun := fun a => ⟨(a.1.val, a.2), a.1.property⟩ + left_inv := fun _ => rfl + right_inv := fun _ => rfl } + unfold probability + rw [Fintype.card_congr e, Fintype.card_prod, Fintype.card_prod, Nat.cast_mul, Nat.cast_mul] + exact mul_div_mul_right _ _ (by exact_mod_cast Fintype.card_ne_zero) + +omit [Nonempty A] in +theorem probability_average {B : Type*} [Fintype B] [Nonempty B] (P : A × B → Prop) : + probability P = (∑ a, probability (fun b => P (a, b))) / Fintype.card A := by + classical + have cards : (Finset.univ.filter P).card = + ∑ a : A, (Finset.univ.filter fun b : B => P (a, b)).card := by + simpa using + (Fintype.sum_prod_type (fun a : A × B => if P a then (1 : Nat) else 0)) + simp only [probability, Fintype.card_subtype, cards, Fintype.card_prod, + Nat.cast_mul, Nat.cast_sum, ← Finset.sum_div] + rw [div_div, mul_comm] + +end Whir.AuthenticatedResetProbability diff --git a/verification/whir/Whir/AuthenticatedResetSuffix.lean b/verification/whir/Whir/AuthenticatedResetSuffix.lean new file mode 100644 index 000000000..612aa8ddf --- /dev/null +++ b/verification/whir/Whir/AuthenticatedResetSuffix.lean @@ -0,0 +1,102 @@ +import Whir.AuthenticatedResetCollector + +/-! Fresh suffix entropy replaces every coordinate at or after a legal query +cut. Prefix messages and the fixed prover coins are replayed unchanged. Extra +unused prefix entropy in the fresh tape is ignored, not rejection-sampled. -/ +namespace Whir.AuthenticatedResetSupport +open Concrete Protocol CausalGame CausalProbability KnowledgeExtraction + +/-- Only verifier tape coordinates, never prover responses, are reset. -/ +def resetCoordinates {c : Config} (cut : Nat) (fresh : Tape c) : + List (Coordinate c) → Tape c → Tape c + | [], base => base + | q :: qs, base => resetCoordinates cut fresh qs + (if cut ≤ position q then set q base (get q fresh) else base) + +def resetSuffix {c : Config} (cut : Nat) (base fresh : Tape c) : Tape c := + resetCoordinates cut fresh (visibleCoordinates c ++ + List.ofFn (fun j : Fin (c.logN - c.folds.toList.sum) => Coordinate.tail j)) base + +theorem resetCoordinates_prefix {c : Config} (cut : Nat) (fresh base : Tape c) + (qs : List (Coordinate c)) : + (visibleBatches c (resetCoordinates cut fresh qs base).1 + (challenges c (resetCoordinates cut fresh qs base))).take cut = + (visibleBatches c base.1 (challenges c base)).take cut := by + induction qs generalizing base with + | nil => rfl + | cons q qs ih => + unfold resetCoordinates + rw [ih] + split + · rename_i later + have fixed := visible_prefix q base (get q fresh) + have take := congrArg (List.take cut) fixed + simpa only [List.take_take, Nat.min_eq_left later] using take + · rfl + +theorem resetCoordinates_levelAt (input : Public) (strategy : Strategy) (cut : Nat) + (fresh base : Tape input.config) (qs : List (Coordinate input.config)) + (level : Fin input.config.folds.size) + (before : levelStart (challenges input.config base) level ≤ cut) : + CausalExecution.levelAt input strategy (resetCoordinates cut fresh qs base) level = + CausalExecution.levelAt input strategy base level := by + induction qs generalizing base with + | nil => rfl + | cons q qs ih => + unfold resetCoordinates + split + · rename_i later + rw [ih _ (by rw [CausalPositions.levelStart_set]; exact before)] + exact CausalStateCausality.levelAt_set input strategy q base (get q fresh) + level level.isLt.le (before.trans later) + · exact ih base before + +/-- The sampler's query squeezes and its independent lambda are retained as +one actual query message. The fresh suffix includes all later coordinates. -/ +def fullResetTape (input : Public) (base : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) + (chunks : queryChunks input.config level = + ((input.config.queries[level.val]! + 192 / depth - 1) / (192 / depth))) + (query : RewindCoverage.QueryTape depth input.config.queries[level.val]!) + (suffix : E × Tape input.config) : Tape input.config := + set (.query level) (resetSuffix (position (.query level)) base suffix.2) + ((fun j => query (Fin.cast chunks j)), suffix.1) + +theorem fullResetTape_prefix (input : Public) (base : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) (chunks) (query) (suffix) : + RewindRowExtraction.queryPrefix input (fullResetTape input base level depth chunks query suffix) level = + RewindRowExtraction.queryPrefix input base level := by + unfold fullResetTape + rw [RewindRowExtraction.queryPrefix_reset] + exact resetCoordinates_prefix _ _ _ _ + +theorem fullResetTape_oracle (input : Public) (strategy : Strategy) (base : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) (chunks) (query) (suffix) : + (CausalExecution.levelAt input strategy (fullResetTape input base level depth chunks query suffix) level).oracle = + (CausalExecution.levelAt input strategy base level).oracle := by + unfold fullResetTape + rw [RewindRowExtraction.reset_oracle_fixed] + have before : levelStart (challenges input.config base) level ≤ position (.query level) := by + rw [CausalPositions.position_query level base] + omega + exact congrArg CheckedState.oracle (resetCoordinates_levelAt input strategy _ _ base _ level before) + +theorem fullResetTape_squeezes (input : Public) (base : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) (chunks) (query) (suffix) : + (challenges input.config (fullResetTape input base level depth chunks query suffix)).levels[level.val]!.querySqueezes = + Array.ofFn query := by + simp only [challenges, _root_.getElem!_pos, Array.size_ofFn, level.isLt, Array.getElem_ofFn] + change Array.ofFn (get (.query level) (fullResetTape input base level depth chunks query suffix)).1 = _ + unfold fullResetTape + rw [get_set] + apply Array.ext + · simp only [Array.size_ofFn] + exact chunks + · intro i hi hi' + simp only [Array.getElem_ofFn, Fin.cast] + +#print axioms fullResetTape_squeezes + +#print axioms fullResetTape_prefix +#print axioms fullResetTape_oracle +end Whir.AuthenticatedResetSupport diff --git a/verification/whir/Whir/AuthenticatedResetSupport.lean b/verification/whir/Whir/AuthenticatedResetSupport.lean new file mode 100644 index 000000000..03bd025c1 --- /dev/null +++ b/verification/whir/Whir/AuthenticatedResetSupport.lean @@ -0,0 +1,278 @@ +import Whir.RewindRowExtraction +import Whir.AuthenticatedResetProbability +import Whir.AuthenticatedResetSuffix + +/-! Acceptance-dependent support of the actual stratified query sampler. Full +trials, including lambda and the remaining suffix, are repeated independently. +Rejected or malformed verifier trials supply no data. -/ +namespace Whir.AuthenticatedResetSupport +open Concrete Protocol CausalGame CausalProbability KnowledgeExtraction +open SamplingProbability RewindCoverage AuthenticatedResetProbability +open scoped BigOperators + +section Support +variable (depth count : Nat) (positive : 0 < depth) (noWrap : depth ≤ 64) +variable {Suffix : Type*} [Fintype Suffix] [Nonempty Suffix] + +abbrev Trial := QueryTape depth count × Suffix + +def Occurs (target : Fin (2 ^ depth)) (trial : Trial depth count (Suffix := Suffix)) : Prop := + ∃ i, sampledPosition depth count positive noWrap trial.1 i = target + +noncomputable def availability (accept : Trial depth count (Suffix := Suffix) → Prop) + (target : Fin (2 ^ depth)) : ℝ := + probability (fun trial => accept trial ∧ Occurs depth count positive noWrap target trial) + +noncomputable def heavy (accept : Trial depth count (Suffix := Suffix) → Prop) (η : ℝ) : + Finset (Fin (2 ^ depth)) := + @Finset.filter _ (fun q => η ≤ availability depth count positive noWrap accept q) + (Classical.decPred _) Finset.univ + +theorem allQueriesHit_iff (A : Finset (Fin (2 ^ depth))) (tape : QueryTape depth count) : + allQueriesHit depth count A tape ↔ + ∀ i, sampledPosition depth count positive noWrap tape i ∈ A := by + classical + unfold allQueriesHit + rw [deriveQueries_eq depth count positive noWrap] + simp only [Option.some.injEq] + constructor + · rintro ⟨qs, rfl, hit⟩ i + have member := hit i + rw [ArrayLayout.getElem!_tab _ _ _ i.isLt, + ← sampledPosition_actual depth count positive noWrap tape i] at member + obtain ⟨q, hq, same⟩ := Finset.mem_image.mp member + have eq : q = sampledPosition depth count positive noWrap tape i := Fin.ext same + simpa [eq] using hq + · intro hit + refine ⟨_, rfl, ?_⟩ + intro i + rw [ArrayLayout.getElem!_tab _ _ _ i.isLt, + ← sampledPosition_actual depth count positive noWrap tape i] + exact Finset.mem_image.mpr ⟨_, hit i, rfl⟩ + +/-- κ is the actual acceptance probability, even when the prover withholds +precisely on particular coordinates or suffixes. No answer independence is used. -/ +theorem acceptance_le_heavy_probability (accept : Trial depth count (Suffix := Suffix) → Prop) + (η : ℝ) (ηnonneg : 0 ≤ η) : + probability accept ≤ + probability (allQueriesHit depth count (heavy depth count positive noWrap accept η)) + + (2 ^ depth : Nat) * η := by + classical + let H := heavy depth count positive noWrap accept η + let events : Option (Fin (2 ^ depth)) → Trial depth count (Suffix := Suffix) → Prop + | none => fun t => allQueriesHit depth count H t.1 + | some q => fun t => accept t ∧ Occurs depth count positive noWrap q t ∧ q ∉ H + have included : ∀ t, accept t → ∃ j, events j t := by + intro t accepted + by_cases all : allQueriesHit depth count H t.1 + · exact ⟨none, all⟩ + · rw [allQueriesHit_iff depth count positive noWrap] at all + push Not at all + obtain ⟨i, outside⟩ := all + exact ⟨some _, accepted, ⟨i, rfl⟩, outside⟩ + have lightBound : ∀ q, probability (events (some q)) ≤ η := by + intro q + by_cases member : q ∈ H + · have empty : events (some q) = fun _ => False := by funext t; simp [events, member] + rw [empty] + simpa [probability] using ηnonneg + · have light : availability depth count positive noWrap accept q < η := by + simpa [H, heavy] using member + exact (mono _ _ (fun t h => ⟨h.1, h.2.1⟩)).trans light.le + calc + probability accept ≤ probability (fun t => ∃ j, events j t) := mono _ _ included + _ ≤ ∑ j, probability (events j) := union_le events + _ = probability (events none) + ∑ q, probability (events (some q)) := by + rw [Fintype.sum_option] + _ ≤ probability (allQueriesHit depth count H) + ∑ _ : Fin (2 ^ depth), η := by + dsimp only [events] + rw [product_left] + exact add_le_add le_rfl (Finset.sum_le_sum fun q _ => lightBound q) + _ = probability (allQueriesHit depth count H) + (2 ^ depth : Nat) * η := by simp + +/-- The density envelope uses the actual stratified law, not iid uniform +replacement queries. -/ +theorem acceptance_le_heavy (accept : Trial depth count (Suffix := Suffix) → Prop) + (η : ℝ) (ηnonneg : 0 ≤ η) : + probability accept ≤ + ((heavy depth count positive noWrap accept η).card / (2 ^ depth : Nat) : ℝ) ^ count + + (2 ^ depth : Nat) * η := by + refine (acceptance_le_heavy_probability depth count positive noWrap accept η ηnonneg).trans ?_ + simpa [StratifiedDensity.globalDensity] using + add_le_add_right (actual_query_bound depth count positive noWrap + (heavy depth count positive noWrap accept η)) ((2 ^ depth : Nat) * η) + +/-- Strict acceptance above the light-support envelope forces genuinely +available coordinates, not merely coordinates occurring in rejected transcripts. -/ +theorem heavy_card_gt (accept : Trial depth count (Suffix := Suffix) → Prop) + (η : ℝ) (ηnonneg : 0 ≤ η) (B : Nat) + (large : ((B : ℝ) / (2 ^ depth : Nat)) ^ count + (2 ^ depth : Nat) * η < probability accept) : + B < (heavy depth count positive noWrap accept η).card := by + by_contra notLarge + have card : (heavy depth count positive noWrap accept η).card ≤ B := by omega + have powers : ((heavy depth count positive noWrap accept η).card / (2 ^ depth : Nat) : ℝ) ^ count ≤ + ((B : ℝ) / (2 ^ depth : Nat)) ^ count := by + apply pow_le_pow_left₀ (by positivity) + exact div_le_div_of_nonneg_right (by exact_mod_cast card) (by positivity) + have bound := acceptance_le_heavy depth count positive noWrap accept η ηnonneg + linarith + +def CoversHeavy (accept : Trial depth count (Suffix := Suffix) → Prop) (η : ℝ) + (fuel : Nat) (seed : Fin fuel → Trial depth count (Suffix := Suffix)) : Prop := + ∀ target ∈ heavy depth count positive noWrap accept η, + ∃ r, accept (seed r) ∧ Occurs depth count positive noWrap target (seed r) + +/-- Fresh FULL suffixes are repeated; there is no resampling of just coordinates +while leaving a maliciously selected suffix fixed. -/ +theorem coverage_failure_le (accept : Trial depth count (Suffix := Suffix) → Prop) + (η : ℝ) (_ηnonneg : 0 ≤ η) (ηle : η ≤ 1) (fuel : Nat) : + probability (fun seed => ¬ CoversHeavy depth count positive noWrap accept η fuel seed) ≤ + (2 ^ depth : Nat) * (1 - η) ^ fuel := by + classical + let events := fun target : Fin (2 ^ depth) => fun seed : Fin fuel → Trial depth count (Suffix := Suffix) => + target ∈ heavy depth count positive noWrap accept η ∧ + ∀ r, ¬ (accept (seed r) ∧ Occurs depth count positive noWrap target (seed r)) + have included : ∀ seed, ¬ CoversHeavy depth count positive noWrap accept η fuel seed → + ∃ target, events target seed := by + intro seed failure + simpa [CoversHeavy, events, not_forall, not_imp, not_exists] using failure + have each : ∀ target, probability (events target) ≤ (1 - η) ^ fuel := by + intro target + by_cases member : target ∈ heavy depth count positive noWrap accept η + · have available : η ≤ availability depth count positive noWrap accept target := by + simpa [heavy] using member + refine (mono _ _ (fun seed h => h.2)).trans ?_ + rw [independent_misses (fun t : Trial depth count (Suffix := Suffix) => + accept t ∧ Occurs depth count positive noWrap target t) fuel] + apply pow_le_pow_left₀ + · exact sub_nonneg.mpr (le_one _) + · dsimp [availability] at available + linarith + · have empty : events target = fun _ => False := by funext seed; simp [events, member] + rw [empty] + simp only [probability, Fintype.card_subtype] + simp + exact pow_nonneg (sub_nonneg.mpr ηle) _ + calc + _ ≤ probability (fun seed => ∃ target, events target seed) := mono _ _ included + _ ≤ ∑ target, probability (events target) := union_le events + _ ≤ ∑ _ : Fin (2 ^ depth), (1 - η) ^ fuel := Finset.sum_le_sum fun q _ => each q + _ = _ := by simp +end Support + +section Actual +variable (prover : CommittedProver) (base : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (depth : Nat) + (positive : 0 < depth) (noWrap : depth ≤ 64) + (chunks : queryChunks prover.input.config level = + ((prover.input.config.queries[level.val]! + 192 / depth - 1) / (192 / depth))) + +abbrev FullTrial := Trial depth prover.input.config.queries[level.val]! + (Suffix := E × Tape prover.input.config) + +def resetAccept (trial : FullTrial prover level depth) : Prop := + experiment prover.input prover.respond + (fullResetTape prover.input base level depth chunks trial.1 trial.2) = true + +def resetTapes (fuel : Nat) (seed : Fin fuel → FullTrial prover level depth) : + List (Tape prover.input.config) := + List.ofFn fun r => fullResetTape prover.input base level depth chunks (seed r).1 (seed r).2 + +def HasHeavyRecords (η : ℝ) (fuel : Nat) (seed : Fin fuel → FullTrial prover level depth) : Prop := + ∀ q ∈ heavy depth prover.input.config.queries[level.val]! positive noWrap + (resetAccept prover base level depth chunks) η, + ∃ record ∈ collectedRecords prover level depth (resetTapes prover base level depth chunks fuel seed), + record.1 = q + +theorem heavy_records_of_coverage (η : ℝ) (fuel : Nat) (seed : Fin fuel → FullTrial prover level depth) + (coverage : CoversHeavy depth prover.input.config.queries[level.val]! positive noWrap + (resetAccept prover base level depth chunks) η fuel seed) : + HasHeavyRecords prover base level depth positive noWrap chunks η fuel seed := by + intro q heavyQ + obtain ⟨r, accepted, i, hit⟩ := coverage q heavyQ + obtain ⟨record, member, coordinate⟩ := trialRecords_contains prover + (fullResetTape prover.input base level depth chunks (seed r).1 (seed r).2) + level depth positive noWrap (seed r).1 (fullResetTape_squeezes _ _ _ _ _ _ _) accepted i + refine ⟨record, List.mem_flatMap.mpr ⟨_, ?_, member⟩, coordinate.trans hit⟩ + exact List.mem_ofFn.mpr ⟨r, rfl⟩ + +/-- End-to-end heavy-coordinate availability of the real acceptance-guarded +collector, including arbitrary withholding and malformed answers. -/ +theorem actual_collector_coverage_failure (η : ℝ) (ηnonneg : 0 ≤ η) (ηle : η ≤ 1) (fuel : Nat) : + probability (fun seed : Fin fuel → FullTrial prover level depth => + ¬ HasHeavyRecords prover base level depth positive noWrap chunks η fuel seed) ≤ + (2 ^ depth : Nat) * (1 - η) ^ fuel := by + refine (mono _ _ (fun seed failure covered => + failure (heavy_records_of_coverage prover base level depth positive noWrap chunks η fuel seed covered))).trans ?_ + exact coverage_failure_le depth prover.input.config.queries[level.val]! positive noWrap + (resetAccept prover base level depth chunks) η ηnonneg ηle fuel + +theorem actual_collected_authenticated (fuel : Nat) (seed : Fin fuel → FullTrial prover level depth) + (shape : ∀ r, (CausalExecution.foldAt prover.input prover.respond + (fullResetTape prover.input base level depth chunks (seed r).1 (seed r).2) level + prover.input.config.folds[level.val]!).n + prover.input.config.rates[level.val]! = depth) : + ∀ record ∈ collectedRecords prover level depth (resetTapes prover base level depth chunks fuel seed), + record.2 = (CausalExecution.levelAt prover.input prover.respond base level).oracle[record.1.val]! := by + intro record member + obtain ⟨tape, inTapes, inRecords⟩ := List.mem_flatMap.mp member + change tape ∈ List.ofFn _ at inTapes + obtain ⟨r, rfl⟩ := List.mem_ofFn.mp inTapes + have auth := trialRecords_authenticated prover _ level depth (shape r) record inRecords + rwa [fullResetTape_oracle] at auth + +#print axioms actual_collector_coverage_failure +#print axioms actual_collected_authenticated +end Actual + +/-- One inverse-availability block reduces each heavy-coordinate miss to 1/2. +The caller supplies a natural block with block·η≥1; taking ceil(1/η) works. -/ +theorem inverse_availability_block (η : ℝ) (ηpositive : 0 < η) (ηle : η ≤ 1) + (block : Nat) (enough : 1 ≤ (block : ℝ) * η) : + (1 - η) ^ block ≤ (1 / 2 : ℝ) := by + have blockPositive : 0 < block := by + by_contra h + have zero : block = 0 := by omega + norm_num [zero] at enough + by_cases endpoint : η = 1 + · simp [endpoint, Nat.ne_of_gt blockPositive] + have strict : η < 1 := lt_of_le_of_ne ηle endpoint + have gap : 0 < 1 - η := by linarith + have nonneg : 0 ≤ 1 - η := gap.le + have ratioNonneg : 0 ≤ η / (1 - η) := div_nonneg ηpositive.le gap.le + have ratio : η ≤ η / (1 - η) := by + apply (le_div_iff₀ gap).mpr + nlinarith + have bernoulli := one_add_mul_le_pow (by linarith : (-2 : ℝ) ≤ η / (1 - η)) block + have two : 2 ≤ (1 + η / (1 - η)) ^ block := by + have mul := mul_le_mul_of_nonneg_left ratio (by positivity : (0 : ℝ) ≤ block) + linarith + have reciprocal : (1 - η) * (1 + η / (1 - η)) = 1 := by + field_simp [ne_of_gt gap] + ring + have product : (1 - η) ^ block * (1 + η / (1 - η)) ^ block = 1 := by + rw [← mul_pow, reciprocal, one_pow] + have bound := mul_le_mul_of_nonneg_left two (pow_nonneg nonneg block) + rw [product] at bound + linarith + +theorem polynomial_availability_schedule (depth count : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) {Suffix : Type*} [Fintype Suffix] [Nonempty Suffix] + (accept : Trial depth count (Suffix := Suffix) → Prop) + (η : ℝ) (ηpositive : 0 < η) (ηle : η ≤ 1) (block security : Nat) + (enough : 1 ≤ (block : ℝ) * η) : + probability (fun seed => ¬ CoversHeavy depth count positive noWrap accept η (block * security) seed) ≤ + (2 ^ depth : Nat) * (1 / 2 : ℝ) ^ security := by + refine (coverage_failure_le depth count positive noWrap accept η ηpositive.le ηle _).trans ?_ + apply mul_le_mul_of_nonneg_left _ (by positivity) + rw [pow_mul] + exact pow_le_pow_left₀ (pow_nonneg (sub_nonneg.mpr ηle) block) + (inverse_availability_block η ηpositive ηle block enough) security + +#print axioms inverse_availability_block +#print axioms polynomial_availability_schedule + +#print axioms acceptance_le_heavy_probability +#print axioms acceptance_le_heavy +#print axioms heavy_card_gt +#print axioms coverage_failure_le +end Whir.AuthenticatedResetSupport diff --git a/verification/whir/Whir/CausalPrefix.lean b/verification/whir/Whir/CausalPrefix.lean index 98fa51373..95276a797 100644 --- a/verification/whir/Whir/CausalPrefix.lean +++ b/verification/whir/Whir/CausalPrefix.lean @@ -192,7 +192,7 @@ theorem event_set_future (input : Public) (strategy : Strategy) omega) simp only [CausalBadEvents.Bad, kernels.1, kernels.2, draw] -private theorem finite_pred_congr {I : Type*} [Fintype I] [DecidableEq I] {A : I → Type*} +theorem finite_pred_congr {I : Type*} [Fintype I] [DecidableEq I] {A : I → Type*} (P : ((i : I) → A i) → Prop) (locked : I → Prop) (step : ∀ f i, ¬ locked i → ∀ x, P (Function.update f i x) ↔ P f) (f g : (i : I) → A i) (same : ∀ i, locked i → f i = g i) : P f ↔ P g := by diff --git a/verification/whir/Whir/CommitmentAnchor.lean b/verification/whir/Whir/CommitmentAnchor.lean index d6bcf5fa6..0ec4a0ec4 100644 --- a/verification/whir/Whir/CommitmentAnchor.lean +++ b/verification/whir/Whir/CommitmentAnchor.lean @@ -1,8 +1,10 @@ import Whir.InteractiveSoundness import Whir.ExecutableOOD +import Whir.RingMapBatching namespace Whir.CommitmentAnchor open Concrete Protocol CausalGame ParameterBounds +open scoped BigOperators set_option maxRecDepth 100000 set_option maxHeartbeats 800000 noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P @@ -124,6 +126,16 @@ theorem boundWitness_eq (p : Profile) (commitment : Commitment p) rw [boundWitness, dite_eq_left hasCandidate] exact congrArg some (cross_session p commitment clean _ _ hasCandidate.choose_spec hw) +/-- Consumer-visible failure of the actual causal verifier: acceptance with no explanation by the one immutable commitment's mathematical selector. This predicate does not assert knowledge extraction. -/ +def openingFailure (p : Profile) (commitment : Commitment p) + (opening : Array Claim) (strategy : Strategy) (tape : Tape (config p)) : Prop := + experiment (ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening)) strategy tape = true ∧ + ¬ ∃ w, boundWitness p commitment = some w ∧ + ∀ c ∈ opening.toList, + dot (paddedWitness (config p) commitment.lanes w) c.weight = c.value + +attribute [local irreducible] openingFailure + /-- Every later actual causal verifier session additionally checks the same immutable anchor. Off the anchor collision event, accepted claims contradicting the one commitment-fixed witness have only the existing opening error, including @@ -132,24 +144,20 @@ theorem unique_opening_probability (p : Profile) (commitment : Commitment p) (clean : ¬ Ambiguous p commitment.lanes commitment.root commitment.point) (opening : Array Claim) (strategy : Strategy) : Soundness.uniformProb (Finset.univ.filter fun tape : Tape (config p) => - experiment (ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening)) strategy tape = true ∧ - ¬ ∃ w, boundWitness p commitment = some w ∧ - ∀ c ∈ opening.toList, dot (paddedWitness (config p) commitment.lanes w) c.weight = c.value) ≤ + openingFailure p commitment opening strategy tape) ≤ GroupedChallenges.interactiveError (config p) (estimates (config p)) (opening.size+1) := by classical have bound := InteractiveSoundness.opening_probability p commitment.lanes commitment.root (claims p commitment opening) strategy have subset : (Finset.univ.filter fun tape : Tape (config p) => - experiment (ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening)) strategy tape = true ∧ - ¬ ∃ w, boundWitness p commitment = some w ∧ - ∀ c ∈ opening.toList, dot (paddedWitness (config p) commitment.lanes w) c.weight = c.value) ⊆ + openingFailure p commitment opening strategy tape) ⊆ Finset.univ.filter fun tape : Tape (config p) => experiment (ExecutionShapes.Input p commitment.lanes commitment.root (claims p commitment opening)) strategy tape = true ∧ ¬ ∃ w ∈ InitialCandidates.witnesses (config p) commitment.lanes commitment.root, ∀ c ∈ (claims p commitment opening).toList, dot (paddedWitness (config p) commitment.lanes w) c.weight = c.value := by intro tape - simp only [Finset.mem_filter, Finset.mem_univ, true_and] + simp only [Finset.mem_filter, Finset.mem_univ, true_and, openingFailure] rintro ⟨accepted,contradicts⟩ constructor · exact accepted @@ -236,4 +244,207 @@ theorem ambiguity_probability_numeric (p : Profile) (lanes : Nat) (root : BaseOr apply (div_le_div_of_nonneg_right num (by positivity)).trans norm_num [Nat.choose_two_right] +/-- The root, supported lane count and profile are fixed before sampling this point. Only the advertised value depends on the point; the record is reused unchanged in every opening session. -/ +def sampledCommitment (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]!) + (advertised : (Fin (config p).logN → E) → E) + (point : Fin (config p).logN → E) : Commitment p := + ⟨lanes, root, point, advertised point, occupied⟩ + +private theorem ledger_mono (p : Profile) {a b : Nat} (h : a ≤ b) : + GroupedChallenges.interactiveError (config p) (estimates (config p)) a ≤ + GroupedChallenges.interactiveError (config p) (estimates (config p)) b := by + unfold GroupedChallenges.interactiveError + exact add_le_add (add_le_add (initialBatch_mono _ h) le_rfl) le_rfl + +/-- Finite product averaging charges the exceptional outer event once, while retaining the actual nonconstant inner ledger. Events may depend arbitrarily on both coordinates. -/ +private theorem exceptional_product_average {A B : Type*} + [Fintype A] [Fintype B] [Nonempty A] [Nonempty B] + (bad : A → Prop) (event : A × B → Prop) (ledger : A → ℚ) + (nonnegative : ∀ x, 0 ≤ ledger x) + (good : ∀ x, ¬ bad x → + Soundness.uniformProb (Finset.univ.filter fun y : B => event (x,y)) ≤ ledger x) : + Soundness.uniformProb (Finset.univ.filter event) ≤ + Soundness.uniformProb (Finset.univ.filter bad) + + (∑ x : A, ledger x) / Fintype.card A := by + classical + have fiber (x : A) : + Soundness.uniformProb (Finset.univ.filter fun y : B => event (x,y)) ≤ + (if bad x then 1 else 0) + ledger x := by + by_cases hx : bad x + · have one : Soundness.uniformProb + (Finset.univ.filter fun y : B => event (x,y)) ≤ 1 := by + unfold Soundness.uniformProb + apply (div_le_one (by positivity)).mpr + exact_mod_cast Finset.card_le_univ _ + simpa [hx] using one.trans (le_add_of_nonneg_right (nonnegative x)) + · simpa [hx] using good x hx + rw [RingMapBatching.uniform_product] + calc + _ ≤ (∑ x : A, ((if bad x then 1 else 0 : ℚ) + ledger x)) / Fintype.card A := + div_le_div_of_nonneg_right (Finset.sum_le_sum fun x _ => fiber x) (by positivity) + _ = _ := by + simp only [Finset.sum_add_distrib, Soundness.uniformProb, Finset.card_filter, + Nat.cast_sum, Nat.cast_ite, Nat.cast_one, Nat.cast_zero] + rw [add_div] + +/-- Actual joint ideal game: one uniform anchor point followed by an independent uniform session tape. Every malicious value, opening and causal strategy is allowed to depend on the point. The candidate list remains fixed by the original root and supported shape. -/ +theorem joint_opening_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]!) + (advertised : (Fin (config p).logN → E) → E) + (opening : (Fin (config p).logN → E) → Array Claim) + (strategy : (Fin (config p).logN → E) → Strategy) : + Soundness.uniformProb (Finset.univ.filter + fun sample : (Fin (config p).logN → E) × Tape (config p) => + openingFailure p (sampledCommitment p lanes root occupied advertised sample.1) + (opening sample.1) (strategy sample.1) sample.2) ≤ + ((InitialCandidates.witnesses (config p) lanes root).card.choose 2 : ℚ) * + ((config p).logN : ℚ) / 2^192 + + (∑ point : Fin (config p).logN → E, + GroupedChallenges.interactiveError (config p) (estimates (config p)) + ((opening point).size+1)) / Fintype.card (Fin (config p).logN → E) := by + classical + let ledger := fun point : Fin (config p).logN → E => + GroupedChallenges.interactiveError (config p) (estimates (config p)) + ((opening point).size+1) + calc + _ ≤ Soundness.uniformProb (Finset.univ.filter (Ambiguous p lanes root)) + + (∑ point : Fin (config p).logN → E, ledger point) / + Fintype.card (Fin (config p).logN → E) := by + apply exceptional_product_average (Ambiguous p lanes root) _ ledger + (fun point => InteractiveSoundness.error_nonneg _ _) + intro point clean + exact unique_opening_probability p + (sampledCommitment p lanes root occupied advertised point) clean + (opening point) (strategy point) + _ ≤ _ := by + dsimp only [ledger] + exact add_le_add (ambiguity_probability p lanes root occupied.2) le_rfl + +/-- A uniform cap on later opening statements gives the actual opening ledger at maxClaimSize plus the single immutable anchor claim. The pair-collision charge is not multiplied by the number of sessions or openings. -/ +theorem joint_opening_probability_capped (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]!) + (advertised : (Fin (config p).logN → E) → E) + (opening : (Fin (config p).logN → E) → Array Claim) + (strategy : (Fin (config p).logN → E) → Strategy) + (maxClaimSize : Nat) (opening_cap : ∀ point, (opening point).size ≤ maxClaimSize) : + Soundness.uniformProb (Finset.univ.filter + fun sample : (Fin (config p).logN → E) × Tape (config p) => + openingFailure p (sampledCommitment p lanes root occupied advertised sample.1) + (opening sample.1) (strategy sample.1) sample.2) ≤ + ((InitialCandidates.witnesses (config p) lanes root).card.choose 2 : ℚ) * + ((config p).logN : ℚ) / 2^192 + + GroupedChallenges.interactiveError (config p) (estimates (config p)) (maxClaimSize+1) := by + classical + apply RingMapBatching.conditional_error (Ambiguous p lanes root) _ _ _ + (InteractiveSoundness.error_nonneg _ _) (ambiguity_probability p lanes root occupied.2) + intro point clean + exact (unique_opening_probability p + (sampledCommitment p lanes root occupied advertised point) clean + (opening point) (strategy point)).trans + (ledger_mono p (Nat.add_le_add_right (opening_cap point) 1)) + +/-- The supported production profiles have dimension at most 28 and a proved root-fixed list cap of 2^32. With the anchor included in the 2^64 claim cap, the composed ideal-interactive bound is exactly stated as 2^-124 plus 2^-73, not rounded to a whole-system 128-bit claim. -/ +theorem joint_opening_probability_numeric (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]!) + (advertised : (Fin (config p).logN → E) → E) + (opening : (Fin (config p).logN → E) → Array Claim) + (strategy : (Fin (config p).logN → E) → Strategy) + (opening_cap : ∀ point, (opening point).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + fun sample : (Fin (config p).logN → E) × Tape (config p) => + openingFailure p (sampledCommitment p lanes root occupied advertised sample.1) + (opening sample.1) (strategy sample.1) sample.2) ≤ + (1 : ℚ)/2^124 + (1 : ℚ)/2^73 := by + classical + apply RingMapBatching.conditional_error (Ambiguous p lanes root) _ _ _ + (by positivity) (ambiguity_probability_numeric p lanes root occupied.2) + intro point clean + exact (unique_opening_probability p + (sampledCommitment p lanes root occupied advertised point) clean + (opening point) (strategy point)).trans + (production_interactive p _ (opening_cap point)) + +/-- Two fresh independent session tapes share one point and one malicious advertised value. The second opening and strategy may depend on the entire first tape. Failure means either accepted session lacks an explanation by the same commitment-fixed selector. Finite fiber averaging charges the anchor collision once and both opening ledgers. -/ +theorem joint_two_session_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]!) + (advertised : (Fin (config p).logN → E) → E) + (opening₁ : (Fin (config p).logN → E) → Array Claim) + (strategy₁ : (Fin (config p).logN → E) → Strategy) + (opening₂ : (Fin (config p).logN → E) → Tape (config p) → Array Claim) + (strategy₂ : (Fin (config p).logN → E) → Tape (config p) → Strategy) + (maxClaimSize₁ maxClaimSize₂ : Nat) + (cap₁ : ∀ point, (opening₁ point).size ≤ maxClaimSize₁) + (cap₂ : ∀ point tape₁, (opening₂ point tape₁).size ≤ maxClaimSize₂) : + Soundness.uniformProb (Finset.univ.filter + fun sample : (Fin (config p).logN → E) × (Tape (config p) × Tape (config p)) => + openingFailure p (sampledCommitment p lanes root occupied advertised sample.1) + (opening₁ sample.1) (strategy₁ sample.1) sample.2.1 ∨ + openingFailure p (sampledCommitment p lanes root occupied advertised sample.1) + (opening₂ sample.1 sample.2.1) (strategy₂ sample.1 sample.2.1) sample.2.2) ≤ + ((InitialCandidates.witnesses (config p) lanes root).card.choose 2 : ℚ) * + ((config p).logN : ℚ) / 2^192 + + (GroupedChallenges.interactiveError (config p) (estimates (config p)) (maxClaimSize₁+1) + + GroupedChallenges.interactiveError (config p) (estimates (config p)) (maxClaimSize₂+1)) := by + classical + apply RingMapBatching.conditional_error (Ambiguous p lanes root) _ _ _ + (add_nonneg (InteractiveSoundness.error_nonneg _ _) (InteractiveSoundness.error_nonneg _ _)) + (ambiguity_probability p lanes root occupied.2) + intro point clean + apply RingMapBatching.conditional_error + (openingFailure p (sampledCommitment p lanes root occupied advertised point) + (opening₁ point) (strategy₁ point)) _ _ _ + (InteractiveSoundness.error_nonneg _ _) + ((unique_opening_probability p + (sampledCommitment p lanes root occupied advertised point) clean + (opening₁ point) (strategy₁ point)).trans + (ledger_mono p (Nat.add_le_add_right (cap₁ point) 1))) + intro tape₁ first_clean + simp only [first_clean, false_or] + exact (unique_opening_probability p + (sampledCommitment p lanes root occupied advertised point) clean + (opening₂ point tape₁) (strategy₂ point tape₁)).trans + (ledger_mono p (Nat.add_le_add_right (cap₂ point tape₁) 1)) + +/-- Numeric two-session bound in the same ideal game, allowing adaptation to the first tape and retaining one anchor charge. No Fiat-Shamir or concrete keyed-transcript realization is asserted. -/ +theorem joint_two_session_probability_numeric (p : Profile) (lanes : Nat) (root : BaseOracle) + (occupied : 0 < lanes ∧ lanes ≤ 2^(config p).folds[0]!) + (advertised : (Fin (config p).logN → E) → E) + (opening₁ : (Fin (config p).logN → E) → Array Claim) + (strategy₁ : (Fin (config p).logN → E) → Strategy) + (opening₂ : (Fin (config p).logN → E) → Tape (config p) → Array Claim) + (strategy₂ : (Fin (config p).logN → E) → Tape (config p) → Strategy) + (cap₁ : ∀ point, (opening₁ point).size+1 ≤ 2^64) + (cap₂ : ∀ point tape₁, (opening₂ point tape₁).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + fun sample : (Fin (config p).logN → E) × (Tape (config p) × Tape (config p)) => + openingFailure p (sampledCommitment p lanes root occupied advertised sample.1) + (opening₁ sample.1) (strategy₁ sample.1) sample.2.1 ∨ + openingFailure p (sampledCommitment p lanes root occupied advertised sample.1) + (opening₂ sample.1 sample.2.1) (strategy₂ sample.1 sample.2.1) sample.2.2) ≤ + (1 : ℚ)/2^124 + ((1 : ℚ)/2^73 + (1 : ℚ)/2^73) := by + classical + apply RingMapBatching.conditional_error (Ambiguous p lanes root) _ _ _ + (by positivity) (ambiguity_probability_numeric p lanes root occupied.2) + intro point clean + apply RingMapBatching.conditional_error + (openingFailure p (sampledCommitment p lanes root occupied advertised point) + (opening₁ point) (strategy₁ point)) _ _ _ (by positivity) + ((unique_opening_probability p + (sampledCommitment p lanes root occupied advertised point) clean + (opening₁ point) (strategy₁ point)).trans + (production_interactive p _ (cap₁ point))) + intro tape₁ first_clean + simp only [first_clean, false_or] + exact (unique_opening_probability p + (sampledCommitment p lanes root occupied advertised point) clean + (opening₂ point tape₁) (strategy₂ point tape₁)).trans + (production_interactive p _ (cap₂ point tape₁)) + end Whir.CommitmentAnchor + +#print axioms Whir.CommitmentAnchor.joint_opening_probability +#print axioms Whir.CommitmentAnchor.joint_opening_probability_capped +#print axioms Whir.CommitmentAnchor.joint_opening_probability_numeric +#print axioms Whir.CommitmentAnchor.joint_two_session_probability +#print axioms Whir.CommitmentAnchor.joint_two_session_probability_numeric diff --git a/verification/whir/Whir/ConcreteRowExtraction.lean b/verification/whir/Whir/ConcreteRowExtraction.lean new file mode 100644 index 000000000..730ced57f --- /dev/null +++ b/verification/whir/Whir/ConcreteRowExtraction.lean @@ -0,0 +1,380 @@ +import Whir.ReedSolomonExtraction +import Whir.ExtractionField +import CompPoly.Univariate.ToPoly.Degree +import Whir.TriangularExtraction + +set_option maxHeartbeats 1600000 +set_option maxRecDepth 4096 + +/-! Concrete WHIR row decoding in the unique radius, on the actual source nodes +and novel encoding. `extractRow_recovers` recovers literal base words and rejects +non-base coefficients rather than projecting arbitrary extension words. +`countedExtractRow` includes Gao preprocessing, full novel preparation and +peeling; its value equals `extractRow`. Its coefficient-arithmetic count is +bounded by the explicit single-variable polynomial `rowArithmeticPolynomial N` +for the no-wrap source profile. This counts extension-field arithmetic, +including 382 multiplications per inverse, not comparisons or memory traffic. +All decoders require access to an entire received row. They are not extractors +for a Merkle digest and do not themselves establish a PCS access hypothesis. -/ +namespace Whir.ConcreteRowExtraction +open Concrete CompPoly + +/-- The machine's actual no-wrap evaluation nodes, not a substituted RS domain. -/ +def domain (depth : Nat) (noWrap : depth ≤ 64) : CompPoly.ReedSolomon.Domain E := + ⟨Array.ofFn (fun i : Fin (2 ^ depth) => E.ofK (UInt64.ofNat i.val)), by + simp only [Array.toList_ofFn] + exact List.nodup_ofFn_ofInjective (AdditiveCode.concreteDomain depth noWrap).injective⟩ + +@[simp] theorem domain_size (depth : Nat) (noWrap : depth ≤ 64) : + (domain depth noWrap).n = 2 ^ depth := by simp [domain, CompPoly.ReedSolomon.Domain.n] + +/-- The dictionary is local and computational. Public input does not gain free access to a hashed root's preimage. -/ +def decode (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : Option (CPolynomial E) := + @ReedSolomonExtraction.decode E ExtractionField.field inferInstance inferInstance + (2 ^ n) (domain (n + rate) noWrap) received + +section Correctness +local instance : Field E := ExtractionField.field + +private theorem prepared_subspace (v : Nat → E) (n : Nat) : + (TriangularExtraction.subspace v n).toPoly = + @AdditiveCode.subspace E FieldModel.instFieldE v n := by + induction n with + | zero => simp [TriangularExtraction.subspace, AdditiveCode.subspace, CPolynomial.X_toPoly] + | succ n ih => + simp [TriangularExtraction.subspace, AdditiveCode.subspace, CPolynomial.toPoly_mul, + CPolynomial.toPoly_add, CPolynomial.C_toPoly, CPolynomial.eval_toPoly, ih] + +private theorem prepared_normalized (v : Nat → E) (n : Nat) : + (TriangularExtraction.normalized v n).toPoly = + @AdditiveCode.normalized E FieldModel.instFieldE v n := by + rw [TriangularExtraction.normalized, CPolynomial.toPoly_mul, CPolynomial.C_toPoly, + CPolynomial.eval_toPoly, prepared_subspace] + change Polynomial.C (ExtractionField.inverse + ((@AdditiveCode.subspace E FieldModel.instFieldE v n).eval (v n))) * + (@AdditiveCode.subspace E FieldModel.instFieldE v n) = _ + rw [ExtractionField.inverse_eq] + rfl + +private theorem prepared_novel (v : Nat → E) (n j : Nat) : + (TriangularExtraction.novel v n j).toPoly = + @AdditiveCode.novel E FieldModel.instFieldE v n j := by + induction n generalizing j with + | zero => simp [TriangularExtraction.novel, AdditiveCode.novel, CPolynomial.toPoly_one] + | succ n ih => + simp only [TriangularExtraction.novel, AdditiveCode.novel] + split_ifs <;> simp [CPolynomial.toPoly_mul, prepared_normalized, ih] + +/-- Executable inversion of the actual novel basis. -/ +def coefficients (n : Nat) (p : CPolynomial E) : Array E := + TriangularExtraction.recover + (TriangularExtraction.novel (AdditiveCode.bitBasis E.ofK) n) (2 ^ n) p + +/-- Instrumented coefficient peeling with the actual extension inverse charged +at 382 extension multiplications. The novel basis is the real WHIR basis; +preparing that basis and allocating/reversing the result are not charged here. -/ +def countedCoefficients (n : Nat) (p : CPolynomial E) : Array E × Nat := + let result := TriangularExtraction.countedPeel 382 + (TriangularExtraction.novel (AdditiveCode.bitBasis E.ofK) n) (2 ^ n) p + (result.1.reverse.toArray, result.2) + +theorem countedCoefficients_value (n : Nat) (p : CPolynomial E) : + (countedCoefficients n p).1 = coefficients n p := by + simp [countedCoefficients, coefficients, TriangularExtraction.recover, + TriangularExtraction.countedPeel_value] + +/-- A quadratic arithmetic bound for the actual post-Gao coefficient-peeling +phase. The support bound follows from the decoded degree and the proved +triangular WHIR basis, not from an assumed internal-loop resource counter. +This does not claim a full decoder machine-time bound. -/ +theorem countedCoefficients_cost (n : Nat) (noWrap : n ≤ 64) (p : CPolynomial E) + (degree : p.degree < 2 ^ n) : + (countedCoefficients n p).2 ≤ 2 ^ n * (4 * 2 ^ n + 384) := by + apply TriangularExtraction.countedPeel_cost 382 + (TriangularExtraction.novel (AdditiveCode.bitBasis E.ofK) n) (2 ^ n) (2 ^ n) p + · exact CPolynomial.mem_degreeLT_iff_size_le.mp (CPolynomial.mem_degreeLT.mpr degree) + · intro i hi + apply CPolynomial.mem_degreeLT_iff_size_le.mp + apply CPolynomial.mem_degreeLT.mpr + rw [CPolynomial.degree_lt_iff_coeff_zero] + intro j hj + rw [CPolynomial.coeff_toPoly, prepared_novel] + have novelDegree := @AdditiveCode.novel_degree E FieldModel.instFieldE + (AdditiveCode.bitBasis E.ofK) inferInstance n + (AdditiveCode.concrete_bitBasis_independent n noWrap) i hi + exact Polynomial.coeff_eq_zero_of_natDegree_lt (by rw [novelDegree.1]; omega) + +/-- Base-word projection is guarded. An extension coefficient with nonzero higher components fails rather than being silently truncated. -/ +def baseWords (n : Nat) (p : CPolynomial E) : Option (Array K) := + let recovered := coefficients n p + if recovered.all (fun e => e.c1 == 0 && e.c2 == 0) then + some (recovered.map E.c0) + else none + +/-- Successful projection certifies every recovered extension coefficient is +literally the embedding of the returned base word, rather than a truncation. -/ +theorem baseWords_sound (n : Nat) (p : CPolynomial E) (a : Array K) + (success : baseWords n p = some a) : + coefficients n p = a.map E.ofK := by + dsimp only [baseWords] at success + split_ifs at success with guard + · have output : (coefficients n p).map E.c0 = a := Option.some.inj success + rw [← output, Array.map_map] + apply Array.ext + · simp + · intro i left right + have components := Array.all_eq_true.mp guard i left + simp only [Bool.and_eq_true, beq_iff_eq] at components + have low : (coefficients n p)[i].c1 = 0 := components.1 + have high : (coefficients n p)[i].c2 = 0 := components.2 + simp only [Array.getElem_map, Function.comp_apply, E.ofK] + cases equal : (coefficients n p)[i] + simp_all + +def extractRow (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : Option (Array K) := + (decode n rate noWrap received).bind (baseWords n) + +theorem coefficients_recovers (n : Nat) (noWrap : n ≤ 64) + (a : Array E) (shape : a.size = 2 ^ n) (p : CPolynomial E) + (polynomial : p.toPoly = AdditiveCode.concretePolynomial n a) : + coefficients n p = a := by + have representation : p.toPoly = ∑ i ∈ Finset.range (2 ^ n), + Polynomial.C (a[i]!) * + @AdditiveCode.novel E FieldModel.instFieldE (AdditiveCode.bitBasis E.ofK) n i := by + rw [polynomial] + unfold AdditiveCode.concretePolynomial AdditiveCode.arrayPolynomial AdditiveCode.polynomial + rw [Finset.sum_range] + simp [AdditiveCode.concreteBaseRepresentation, QueryRefinement.concreteRepresentation, + Polynomial.smul_eq_C_mul] + have equal : p = ∑ i ∈ Finset.range (2 ^ n), CPolynomial.C (a[i]!) * + TriangularExtraction.novel (AdditiveCode.bitBasis E.ofK) n i := by + apply CPolynomial.eq_iff_coeff.mpr + intro j + rw [CPolynomial.coeff_toPoly, CPolynomial.coeff_toPoly, representation] + apply congrArg (fun q : Polynomial E => q.coeff j) + rw [CPolynomial.toPoly_sum] + apply Finset.sum_congr rfl + intro i hi + rw [CPolynomial.toPoly_mul, CPolynomial.C_toPoly, prepared_novel] + have recovered := TriangularExtraction.recover_recovers + (TriangularExtraction.novel (AdditiveCode.bitBasis E.ofK) n) (2 ^ n) (fun i => a[i]!) + (by + intro i j hi hij + rw [CPolynomial.coeff_toPoly, prepared_novel] + have degree := @AdditiveCode.novel_degree E FieldModel.instFieldE + (AdditiveCode.bitBasis E.ofK) inferInstance n + (AdditiveCode.concrete_bitBasis_independent n noWrap) i hi + exact Polynomial.coeff_eq_zero_of_natDegree_lt (degree.1.trans_lt hij)) + (by + intro i hi + rw [CPolynomial.coeff_toPoly, prepared_novel] + have degree := @AdditiveCode.novel_degree E FieldModel.instFieldE + (AdditiveCode.bitBasis E.ofK) inferInstance n + (AdditiveCode.concrete_bitBasis_independent n noWrap) i hi + have leading : (@AdditiveCode.novel E FieldModel.instFieldE + (AdditiveCode.bitBasis E.ofK) n i).coeff i = + (@AdditiveCode.novel E FieldModel.instFieldE (AdditiveCode.bitBasis E.ofK) n i).leadingCoeff := by + simpa only [degree.1] using + (Polynomial.coeff_natDegree (p := @AdditiveCode.novel E FieldModel.instFieldE + (AdditiveCode.bitBasis E.ofK) n i)) + rw [leading] + exact degree.2) + rw [coefficients, equal, recovered] + apply Array.ext + · simp [shape] + · intro i left right + simp [getElem!_pos, right] + +theorem baseWords_recovers (n : Nat) (noWrap : n ≤ 64) + (a : Array K) (shape : a.size = 2 ^ n) (p : CPolynomial E) + (polynomial : p.toPoly = AdditiveCode.concretePolynomial n (a.map E.ofK)) : + baseWords n p = some a := by + rw [baseWords, coefficients_recovers n noWrap (a.map E.ofK) (by simp [shape]) p polynomial] + simp [E.ofK, Array.map_map, Function.comp_def] + +/-- For a supplied supported row inside the exact Gao radius, the actual decoder returns its actual dense-encoder polynomial. This is stronger than uniqueness or existence alone, but still does not prove verifier acceptance implies this radius. -/ +theorem decode_actual_row (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) (a : Array E) (shape : a.size = 2 ^ n) + (received : Vector E (domain (n + rate) noWrap).n) + (radius : 2 * hammingDist received.get (fun i => (encode n rate a)[i.val]!) ≤ + 2 ^ (n + rate) - 2 ^ n) : + ∃ p, decode n rate noWrap received = some p ∧ + p.toPoly = AdditiveCode.concretePolynomial n a := by + let p : CPolynomial E := CPolynomial.toPolyLinearEquiv.symm + (AdditiveCode.concretePolynomial n a) + have polynomial : p.toPoly = AdditiveCode.concretePolynomial n a := + CPolynomial.toPolyLinearEquiv.apply_symm_apply _ + have degree : p.degree < 2 ^ n := by + rw [CPolynomial.degree_toPoly, polynomial] + exact AdditiveCode.concrete_polynomial_degree_lt n (by omega) a + have node (i : Fin (domain (n + rate) noWrap).n) : + p.toPoly.eval ((domain (n + rate) noWrap).val[i]) = (encode n rate a)[i.val]! := by + rw [polynomial] + have within : i.val < 2 ^ (n + rate) := by simpa using i.isLt + rw [AdditiveCode.concrete_encode_eval n rate a shape i.val within] + rw [show (domain (n + rate) noWrap).val[i] = E.ofK (UInt64.ofNat i.val) from by + change (Array.ofFn (fun q : Fin (2 ^ (n + rate)) => E.ofK (UInt64.ofNat q.val)))[i.val] = _ + rw [Array.getElem_ofFn]] + refine ⟨p, ?_, polynomial⟩ + change ReedSolomonExtraction.decode (2 ^ n) (domain (n + rate) noWrap) received = some p + apply ReedSolomonExtraction.decode_recovers (2 ^ n) (domain (n + rate) noWrap) + received p (by simpa using redundancy) degree + simpa only [domain_size, node] using radius + +/-- A returned polynomial identifies at most one valid extension coefficient array. This theorem is not an executable novel-basis inversion algorithm. -/ +theorem returned_row_identifies_coefficients (n : Nat) (noWrap : n ≤ 64) + (a b : Array E) (aShape : a.size = 2 ^ n) (bShape : b.size = 2 ^ n) + (p : CPolynomial E) + (aPolynomial : p.toPoly = AdditiveCode.concretePolynomial n a) + (bPolynomial : p.toPoly = AdditiveCode.concretePolynomial n b) : a = b := + AdditiveCode.concrete_polynomial_injective n noWrap a b aShape bShape + (aPolynomial.symm.trans bPolynomial) + + +/-- A complete row decoder endpoint, returning actual occupied base words. The radius concerns one supported row and the input is an explicitly available received word, not a digest. -/ +theorem extractRow_recovers (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) (a : Array K) (shape : a.size = 2 ^ n) + (received : Vector E (domain (n + rate) noWrap).n) + (radius : 2 * hammingDist received.get (fun i => (encode n rate (a.map E.ofK))[i.val]!) ≤ + 2 ^ (n + rate) - 2 ^ n) : + extractRow n rate noWrap received = some a := by + obtain ⟨p, decoded, polynomial⟩ := + decode_actual_row n rate noWrap redundancy (a.map E.ofK) (by simp [shape]) received radius + rw [extractRow, decoded, Option.bind_some] + exact baseWords_recovers n (by omega) a shape p polynomial + +/-- Include the actual recursively recomputed novel-basis preparation in the +field-arithmetic cost of projection, before performing the same guarded +base-word conversion. Coefficient lookups and component comparisons are not +field arithmetic; they are not silently charged as multiplications. -/ +def countedBaseWords (n : Nat) (p : CPolynomial E) : Option (Array K) × Nat := + let result := TriangularExtraction.countedPreparedPeel 382 + (AdditiveCode.bitBasis E.ofK) n (2 ^ n) p + let recovered := result.1.reverse.toArray + (if recovered.all (fun e => e.c1 == 0 && e.c2 == 0) then + some (recovered.map E.c0) else none, result.2) + +theorem countedBaseWords_value (n : Nat) (p : CPolynomial E) : + (countedBaseWords n p).1 = baseWords n p := by + simp only [countedBaseWords, TriangularExtraction.countedPreparedPeel_value, + baseWords, coefficients, TriangularExtraction.recover] + rfl + +def projectionBudget (n : Nat) : Nat := + 2 ^ n * (TriangularExtraction.novelBudget 382 n (2 ^ (n + 1)) + + 4 * 2 ^ (n + 1) + 384) + +theorem countedBaseWords_cost (n : Nat) (p : CPolynomial E) (degree : p.degree < 2 ^ n) : + (countedBaseWords n p).2 ≤ projectionBudget n := by + apply TriangularExtraction.countedPreparedPeel_cost 382 + (AdditiveCode.bitBasis E.ofK) n (2 ^ n) (2 ^ (n + 1)) p (Nat.le_refl _) + exact (CPolynomial.mem_degreeLT_iff_size_le.mp + (CPolynomial.mem_degreeLT.mpr degree)).trans + (Nat.pow_le_pow_right (by decide : 1 ≤ (2 : Nat)) (Nat.le_succ n)) + +/-- Instrument the whole executable source-row decoder. Its input remains an +explicit received word; this is not an oracle for a hashed commitment. +The concrete domain constructor writes `N` embedded UInt64 coordinates and +uses no extension-field arithmetic. The field counter includes Gao's nodal +product, Lagrange interpolation, fueled Euclidean loop with actual degree +drop, final remainder/division, original novel-basis preparation, coefficient +peeling and the guarded projection. -/ +def countedExtractRow (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : Option (Array K) × Nat := + let decoded := ReedSolomonExtraction.countedDecode 382 (2 ^ n) (domain (n + rate) noWrap) received + match decoded.1 with + | none => (none, decoded.2) + | some p => + let projected := countedBaseWords n p + (projected.1, decoded.2 + projected.2) + +theorem countedExtractRow_value (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : + (countedExtractRow n rate noWrap received).1 = extractRow n rate noWrap received := by + simp only [countedExtractRow, ReedSolomonExtraction.countedDecode_value, extractRow, decode] + split <;> simp_all [countedBaseWords_value] + +/-- Explicit polynomial field-arithmetic budget. `N=2^(n+rate)`, `k=2^n`; +the log-depth parameter `n` occurs only polynomially in the basis term. +No field-size enumeration, inverse-as-unit-cost assumption, or hidden +intermediate-width hypothesis appears in this budget. -/ +def rowArithmeticBudget (n rate : Nat) : Nat := + ReedSolomonExtraction.decoderBudget 382 (2 ^ (n + rate)) + projectionBudget n + +theorem countedExtractRow_cost (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) + (received : Vector E (domain (n + rate) noWrap).n) : + (countedExtractRow n rate noWrap received).2 ≤ rowArithmeticBudget n rate := by + have decoderCost := ReedSolomonExtraction.countedDecode_cost 382 (2 ^ n) + (domain (n + rate) noWrap) received + rw [domain_size] at decoderCost + unfold countedExtractRow + cases output : (ReedSolomonExtraction.countedDecode 382 (2 ^ n) + (domain (n + rate) noWrap) received).1 with + | none => + simp only [output] + exact decoderCost.trans (Nat.le_add_right _ _) + | some p => + have success : ReedSolomonExtraction.decode (2 ^ n) (domain (n + rate) noWrap) + received = some p := by + rw [← ReedSolomonExtraction.countedDecode_value 382] + exact output + have degree := (ReedSolomonExtraction.decode_proximity (2 ^ n) + (domain (n + rate) noWrap) received p (by simpa using redundancy) success).1 + simp only [output] + exact Nat.add_le_add decoderCost (countedBaseWords_cost n p degree) + +theorem countedExtractRow_recovers (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) (a : Array K) (shape : a.size = 2 ^ n) + (received : Vector E (domain (n + rate) noWrap).n) + (radius : 2 * hammingDist received.get (fun i => (encode n rate (a.map E.ofK))[i.val]!) ≤ + 2 ^ (n + rate) - 2 ^ n) : + (countedExtractRow n rate noWrap received).1 = some a ∧ + (countedExtractRow n rate noWrap received).2 ≤ rowArithmeticBudget n rate := by + exact ⟨(countedExtractRow_value n rate noWrap received).trans + (extractRow_recovers n rate noWrap redundancy a shape received radius), + countedExtractRow_cost n rate noWrap redundancy received⟩ + +/-- Written in the actual dimensions rather than their logarithms: this is a +polynomial in depth, message length and block length, with the concrete inverse +charged at 382. The decoder term has degree seven in block length; the +novel-preparation/projection term has degree three in message length. -/ +def sourceRowPolynomialBudget (depth dimension blockLength : Nat) : Nat := + ReedSolomonExtraction.decoderBudget 382 blockLength + + dimension * (TriangularExtraction.novelBudget 382 depth (2 * dimension) + + 8 * dimension + 384) + +theorem rowArithmeticBudget_eq_polynomial (n rate : Nat) : + rowArithmeticBudget n rate = + sourceRowPolynomialBudget n (2 ^ n) (2 ^ (n + rate)) := by + unfold rowArithmeticBudget projectionBudget sourceRowPolynomialBudget + rw [show 2 ^ (n + 1) = 2 * 2 ^ n from by rw [Nat.pow_succ, Nat.mul_comm]] + congr 2 + ring + +/-- A single-variable polynomial budget for the no-wrap source profile. +Taking depth 64 is conservative; no sampling, soundness, or access premise is +used to derive the coefficient-arithmetic bound. -/ +def rowArithmeticPolynomial (blockLength : Nat) : Nat := + sourceRowPolynomialBudget 64 blockLength blockLength + +theorem sourceRowPolynomialBudget_mono (depth dimension blockLength : Nat) + (depthBound : depth ≤ 64) (dimensionBound : dimension ≤ blockLength) : + sourceRowPolynomialBudget depth dimension blockLength ≤ rowArithmeticPolynomial blockLength := by + unfold rowArithmeticPolynomial sourceRowPolynomialBudget + TriangularExtraction.novelBudget TriangularExtraction.preparationUnit + gcongr + +theorem countedExtractRow_polynomial_cost (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) + (received : Vector E (domain (n + rate) noWrap).n) : + (countedExtractRow n rate noWrap received).2 ≤ + rowArithmeticPolynomial (2 ^ (n + rate)) := by + have bound := countedExtractRow_cost n rate noWrap redundancy received + rw [rowArithmeticBudget_eq_polynomial] at bound + exact bound.trans (sourceRowPolynomialBudget_mono _ _ _ (by omega) redundancy.le) + +end Correctness +end Whir.ConcreteRowExtraction diff --git a/verification/whir/Whir/ConcreteSecurityBudget.lean b/verification/whir/Whir/ConcreteSecurityBudget.lean index 2dde19725..c880b3d58 100644 --- a/verification/whir/Whir/ConcreteSecurityBudget.lean +++ b/verification/whir/Whir/ConcreteSecurityBudget.lean @@ -1,11 +1,12 @@ import Whir.WHIRNativeSecurity +import Mathlib.Data.Nat.Choose.Cast -/-! Conditional, unground budget for the proposed #552 public-duplex model. +/-! Resource-conditional budget for the pinned #552 public-duplex model. The grouped-message `2^-79` term already includes the production Johnson list of up to `2^32` candidates; the endpoint is adaptive list binding, not unique binding or knowledge extraction. We charge the actual ring-switching term, -caller/WHIR allocation count, source attempts, DMV, and ordinary Merkle loss. +caller/WHIR allocation count, source attempts, actual duplex coupling, and ordinary Merkle loss. No proof-of-work multiplier is supplied by this endpoint. The illustrative caps permit a million attacker-plus-verifier source units, @@ -18,11 +19,13 @@ are finite-experiment query/resource restrictions, NOT wall-clock bounds, compiler safety, or assertions that every production input satisfies them. The reachable verifier/path and actual envelope hypotheses are retained. -The resulting checked probability bound is `2^-42`, not `2^-128`. The actual -`PublicRandomCompressionDMV` hypothesis remains unproved; no deterministic -BLAKE2s or deployed keyed-transcript security conclusion follows. -/ +The resulting checked probability bound remains `2^-42`, not `2^-128`, with +the proved whole-view duplex loss `min 1 ((2*Q^2-Q)/2^256)`. No external mode +security premise remains. The finite random-compression experiment does not +justify deterministic BLAKE2s security or universal deployed #599/#555 source +correspondence; valid caller shapes and reachable resource hypotheses remain. -/ namespace Whir.ConcreteSecurityBudget -open FiatShamirGame DuplexModeGame WHIRPhysicalDriver WHIRSourceChronology +open FiatShamirGame DuplexModeGame WHIRPhysicalDriver WHIRPhysicalDriver.Unanchored WHIRSourceChronology open RawOracleCoupling.Concrete TypedOracleCompiler set_option maxRecDepth 100000 @@ -53,7 +56,7 @@ theorem backfill_envelope_le (ctx : RawWHIRKeys.Context) (A Mf : Nat) /-- This is the existing native endpoint's RHS, not a second soundness ledger. -/ def endpointLoss (registry : ProductionRegistry) (Q A cap free : Nat) : ℚ := - WHIRObservableSecurity.romBound registry.publicRegistry A cap + dmvLoss Q + + WHIRObservableSecurity.romBound registry.publicRegistry A cap + duplexModeLoss Q + WHIRSourceMerkleSecurity.loss Q free /-- Nonnegativity of the actual endpoint, needed to diagnose its concrete @@ -63,7 +66,7 @@ theorem endpointLoss_nonneg (registry : ProductionRegistry) (Q A cap free : Nat) have eps := WHIRRawROM.epsilon_nonneg cap have hQone : (1 : ℚ) ≤ Q := by exact_mod_cast nonzero have hsub : (0 : ℚ) ≤ Q-1 := sub_nonneg.mpr hQone - unfold endpointLoss WHIRObservableSecurity.romBound dmvLoss + unfold endpointLoss WHIRObservableSecurity.romBound duplexModeLoss WHIRSourceMerkleSecurity.loss PublicMerkleProbability.bound positivity @@ -78,13 +81,36 @@ theorem endpointLoss_eq (registry : ProductionRegistry) (Q A cap free : Nat) : endpointLoss registry Q A cap free = min 1 ((((40 + registry.callerOutputCap) * (A+1) : Nat) : ℚ) * ((1 : ℚ)/2^79 + WHIRFiatShamir.ringCharge cap)) + - min 1 ((Q.choose 2 : ℚ) / (2^256 : ℚ)) + + min 1 ((2 * (Q.choose 2 : ℚ) + (Q : ℚ) * Q) / (2^256 : ℚ)) + ((Q : ℚ) * ((Q+1) * (free+(Q+1)*41) : Nat) + 2*Q*(Q-1)) / 2^256 := by simp only [endpointLoss, WHIRObservableSecurity.romBound, allocationBudget, WHIRCallerRegistry.context, ProductionRegistry.publicRegistry, - schedule_depths.1, WHIRRawROM.epsilon, dmvLoss, WHIRSourceMerkleSecurity.loss, + schedule_depths.1, WHIRRawROM.epsilon, duplexModeLoss, WHIRSourceMerkleSecurity.loss, WHIRSourceMerkleSecurity.rootBudget, PublicMerkleProbability.bound, schedule_depths.2] +/-- Exact polynomial whole-view mode coefficient, including the sharp linear +correction. The source-attempt and ordinary Merkle terms are unchanged. -/ +theorem endpointLoss_expansion (registry : ProductionRegistry) (Q A cap free : Nat) : + endpointLoss registry Q A cap free = + min 1 ((((40 + registry.callerOutputCap) * (A+1) : Nat) : ℚ) * + ((1 : ℚ)/2^79 + WHIRFiatShamir.ringCharge cap)) + + min 1 ((2 * (Q : ℚ)^2 - Q) / (2^256 : ℚ)) + + ((Q : ℚ) * ((Q+1) * (free+(Q+1)*41) : Nat) + 2*Q*(Q-1)) / 2^256 := by + have coefficient : 2 * (Q.choose 2 : ℚ) + (Q : ℚ) * Q = 2 * (Q : ℚ)^2 - Q := by + rw [Nat.cast_choose_two ℚ Q] + ring + simpa only [coefficient] using endpointLoss_eq registry Q A cap free + +/-- Exact ledger at the illustrative caps, not an attacker-success lower +bound or a concrete deployed-system security claim. -/ +theorem endpointLoss_at_caps (registry : ProductionRegistry) + (caller : registry.callerOutputCap = 2^16) : + endpointLoss registry (2^60) (2^20) (2^32) (2^20) = + (5712480737351244866976450137972416606804377619 : ℚ) / + 50216813883093446110686315385661331328818843555712276103168 := by + rw [endpointLoss_expansion, caller] + norm_num [WHIRFiatShamir.ringCharge] + /-- The family cap's actual list/ring-switching contribution is much smaller than `2^-79`; the existing `2^32` list factor is not silently discarded. -/ theorem ringCharge_at_cap : @@ -122,10 +148,15 @@ theorem endpointLoss_le (registry : ProductionRegistry) (Q A cap free : Nat) · exact eps · exact WHIRRawROM.epsilon_nonneg cap · positivity - have dmv : dmvLoss Q ≤ ((2^60 : Nat).choose 2 : ℚ) / 2^256 := by + have mode : duplexModeLoss Q ≤ + (2 * ((2^60 : Nat).choose 2 : ℚ) + (2^60 : ℚ) * 2^60) / 2^256 := by apply (min_le_right _ _).trans - exact div_le_div_of_nonneg_right - (by exact_mod_cast Nat.choose_le_choose 2 caps.compression) (by positivity) + apply div_le_div_of_nonneg_right _ (by positivity) + apply add_le_add + · exact mul_le_mul_of_nonneg_left + (by exact_mod_cast Nat.choose_le_choose 2 caps.compression) (by positivity) + · have hQ : (Q : ℚ) ≤ (2^60 : ℚ) := by exact_mod_cast caps.compression + exact mul_le_mul hQ hQ (by positivity) (by positivity) have roots : WHIRSourceMerkleSecurity.rootBudget Q free ≤ (2^60+1)*(2^20+(2^60+1)*41) := by unfold WHIRSourceMerkleSecurity.rootBudget @@ -144,14 +175,14 @@ theorem endpointLoss_le (registry : ProductionRegistry) (Q A cap free : Nat) apply add_le_add · exact mul_le_mul hQ (by exact_mod_cast roots) (by positivity) (by positivity) · gcongr - have total := add_le_add (add_le_add rom dmv) merkle + have total := add_le_add (add_le_add rom mode) merkle apply total.trans norm_num [WHIRRawROM.epsilon, WHIRFiatShamir.ringCharge, Nat.choose_two_right] -/-- Actual native false-acceptance probability, in the public RANDOM-compression -experiment. DMV and every original reachable resource hypothesis remain. -/ +/-- Actual native false-acceptance probability in the public RANDOM-compression +experiment. The actual mode coupling is instantiated internally; every original +reachable resource hypothesis and the valid-shape source model remain. -/ theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] - [Fintype DuplexPublicSimulator.Seed] {cap : Nat} (registry : ProductionRegistry) (Q a b Mf free : Nat) (attackers : Coins → Source cap (Input registry.context Q)) (before : ∀ coins, Counts a (attackers coins)) @@ -165,13 +196,11 @@ theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (WHIRNativeSecurity.sources registry Q attackers coins)) (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) - (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed - DuplexPublicSimulator.State (DuplexPublicSimulator.simulator Q) registry.iv) (caps : Caps registry Q (a+b) cap free) : realProbability registry.iv (WHIRNativeSecurity.adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ (1 : ℚ)/2^42 := (WHIRNativeSecurity.random_compression_list_binding registry Q a b Mf free attackers - before verifierBudget paths announcements envelope security).trans + before verifierBudget paths announcements envelope).trans (endpointLoss_le registry Q (a+b) cap free caps) /-- No small full-view replacement loss for any class admitting the efficient @@ -191,7 +220,7 @@ theorem concrete_gap_not_small (Q : Nat) (iv : Digest32) (input : DuplexFraming. /-- The complete RHS of the current concrete endpoint also cannot be small under a full-view class containing the known-answer observer. In particular, -adding the ROM/DMV/Merkle terms cannot repair the replacement premise. -/ +adding the ROM/duplex/Merkle terms cannot repair the replacement premise. -/ theorem concrete_endpoint_not_small (registry : ProductionRegistry) (Q A cap free : Nat) (input : DuplexFraming.Node) (primitiveLoss : ℚ) (Allowed : (C : Type) → [Fintype C] → (Output : Type) → diff --git a/verification/whir/Whir/CountedCandidateCheck.lean b/verification/whir/Whir/CountedCandidateCheck.lean new file mode 100644 index 000000000..2a5491ada --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheck.lean @@ -0,0 +1,145 @@ +import Whir.CountedCandidateCheckArithmetic + +/-! Value-connected instrumentation of the cached common-coordinate checker. Every original public claim is evaluated. No commitment is recomputed and no intermediate GS decoder is invoked. The input contract is independent of acceptance and explicitly bounds claims, records, dimensions and physical rows. -/ +namespace Whir.CountedCandidateCheck +open Concrete Protocol CausalGame SupportedCandidateExtraction CandidateFolding +open scoped BigOperators + +/-- Run one actual dense source encoding per padded lane and retain both outputs. -/ +def countedEncodedLanes (c : Config) (candidate : Array E) : Array (Array E) × Nat := + let encoded := Array.ofFn fun lane : Fin (laneCount c) => + countedEncode (c.logN - c.folds[0]!) c.rates[0]! + (Array.ofFn (unpack true (laneCount c) (width c) candidate lane)) + (encoded.map Prod.fst, (encoded.map Prod.snd).toList.sum) + +theorem countedEncodedLanes_value (c : Config) (candidate : Array E) : + (countedEncodedLanes c candidate).1 = encodedLanes c candidate := by + simp [countedEncodedLanes, encodedLanes, Array.map_ofFn, Function.comp_def, countedEncode_value] + +def encoderBound (c : Config) : Nat := + laneCount c * blockLength c * + (2 * (c.logN - c.folds[0]!) * (c.logN - c.folds[0]!) + + 131 * (c.logN - c.folds[0]!) + 5 * width c) + +theorem countedEncodedLanes_cost (c : Config) (candidate : Array E) : + (countedEncodedLanes c candidate).2 ≤ encoderBound c := by + simp only [countedEncodedLanes, Array.toList_map, Array.toList_ofFn, + List.map_ofFn, List.sum_ofFn] + calc + _ ≤ ∑ _lane : Fin (laneCount c), blockLength c * + (2 * (c.logN - c.folds[0]!) * (c.logN - c.folds[0]!) + + 131 * (c.logN - c.folds[0]!) + 5 * width c) := by + apply Finset.sum_le_sum + intro lane _ + exact countedEncode_cost _ _ _ + _ = encoderBound c := by simp [encoderBound, Nat.mul_assoc] + +/-- Full all-claim check: the pair array shares each actual dot result with its counter. Eager checking bounds the source short-circuit implementation too. -/ +def countedClaims (input : Public) (candidate : Array E) : Bool × Nat := + let checked := input.claims.map fun claim => + let result := countedDot candidate claim.weight + (result.1 == claim.value, result.2) + ((checked.map Prod.fst).all id, (checked.map Prod.snd).toList.sum) + +theorem countedClaims_value (input : Public) (candidate : Array E) : + (countedClaims input candidate).1 = + input.claims.all (fun claim => dot candidate claim.weight == claim.value) := by + simp [countedClaims, countedDot, Array.map_map, Function.comp_def] + +theorem countedClaims_cost (input : Public) (candidate : Array E) : + (countedClaims input candidate).2 ≤ input.claims.size * (2 * candidate.size) := by + simp only [countedClaims, Array.map_map, Array.toList_map, Function.comp_def, countedDot] + have h := List.sum_le_length_nsmul + (input.claims.toList.map fun claim => 2 * min candidate.size claim.weight.size) + (2 * candidate.size) (by + intro cost member + obtain ⟨claim, _, rfl⟩ := List.mem_map.mp member + exact Nat.mul_le_mul_left 2 (Nat.min_le_left _ _)) + simpa [Nat.mul_comm] using h + +/-- The expensive cache is outside the record loop. Comparisons and coordinate set construction contribute no field operations. -/ +def countedVerified (input : Public) (candidate : Array E) + (records : List (Record input.config)) : Bool × Nat := + if candidate.size == laneCount input.config * width input.config then + let encoded := countedEncodedLanes input.config candidate + let common := ((records.filter (rowMatches input.config input.lanes encoded.1)).map Prod.fst).toFinset + let claims := countedClaims input candidate + (decide (ParameterBounds.threshold input.config 0 ≤ common.card) && claims.1, + encoded.2 + claims.2) + else (false, 0) + +theorem countedVerified_value (input : Public) (candidate : Array E) + (records : List (Record input.config)) : + (countedVerified input candidate records).1 = verified input candidate records := by + unfold countedVerified verified commonCoordinates + split <;> simp_all [countedEncodedLanes_value, countedClaims_value] + +def checkerBound (input : Public) : Nat := + encoderBound input.config + input.claims.size * (2 * laneCount input.config * width input.config) + +theorem countedVerified_cost (input : Public) (candidate : Array E) + (records : List (Record input.config)) : + (countedVerified input candidate records).2 ≤ checkerBound input := by + unfold countedVerified + split + · rename_i shape + have shape : candidate.size = laneCount input.config * width input.config := by + exact beq_iff_eq.mp shape + have he := countedEncodedLanes_cost input.config candidate + have hc := countedClaims_cost input candidate + dsimp only + rw [shape] at hc + unfold checkerBound + nlinarith + · exact Nat.zero_le _ + +def countedFinish (input : Public) (candidate : Array E) + (records : List (Record input.config)) : Option (Witness input.config input.lanes) × Nat := + let checked := countedVerified input candidate records + (if checked.1 then some (InitialCandidates.project input.config input.lanes candidate) else none, + checked.2) + +theorem countedFinish_value (input : Public) (candidate : Array E) + (records : List (Record input.config)) : + (countedFinish input candidate records).1 = finish input candidate records := by + simp [countedFinish, finish, countedVerified_value] + +theorem countedFinish_cost (input : Public) (candidate : Array E) + (records : List (Record input.config)) : + (countedFinish input candidate records).2 ≤ checkerBound input := + countedVerified_cost input candidate records + +/-- Strict resource contract. Raw prover replies are external oracle output; bounded consumed records and public input are a separate explicit premise. -/ +structure ConsumerInput (input : Public) (recordLimit claimLimit : Nat) + (records : List (Record input.config)) : Prop where + foldBound : input.config.folds[0]! ≤ input.config.logN + noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64 + lanes : input.lanes ≤ laneCount input.config + recordCount : records.length ≤ recordLimit + recordRows : ∀ record ∈ records, record.2.size = input.lanes + claims : input.claims.size ≤ claimLimit + claimWeights : ∀ claim ∈ input.claims.toList, claim.weight.size = laneCount input.config * width input.config + rootRows : input.root.size = blockLength input.config + rootLanes : ∀ row ∈ input.root.toList, row.size = input.lanes + +/-- Single-variable field-arithmetic polynomial after the transparent no-wrap restriction. The degree-seven Gao term is added by the complete extractor. -/ +def checkerPolynomial (lanes nodes claims : Nat) : Nat := + lanes * nodes * (16576 + 5 * nodes) + claims * (2 * lanes * nodes) + +theorem checkerBound_polynomial (input : Public) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + checkerBound input ≤ checkerPolynomial (laneCount input.config) + (blockLength input.config) input.claims.size := by + have depth : input.config.logN - input.config.folds[0]! ≤ 64 := by omega + have widthBound : width input.config ≤ blockLength input.config := by + apply Nat.pow_le_pow_right (by decide : 1 ≤ 2) + omega + have square : 2 * (input.config.logN - input.config.folds[0]!) * + (input.config.logN - input.config.folds[0]!) + + 131 * (input.config.logN - input.config.folds[0]!) ≤ 16576 := by nlinarith + unfold checkerBound encoderBound checkerPolynomial + apply Nat.add_le_add + · exact Nat.mul_le_mul_left _ (by omega) + · exact Nat.mul_le_mul_left _ (Nat.mul_le_mul_left _ widthBound) + +end Whir.CountedCandidateCheck diff --git a/verification/whir/Whir/CountedCandidateCheckArithmetic.lean b/verification/whir/Whir/CountedCandidateCheckArithmetic.lean new file mode 100644 index 000000000..1246501c4 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckArithmetic.lean @@ -0,0 +1,234 @@ +import Whir.PCSRewindExtractorAttempts +import Whir.FieldInverse + +/-! Executable source-loop counters. A unit is one K or E addition or multiplication. E.scale charges its three K multiplications. The source K inverse uses its actual 64-bit exponentiation loop, not the decoder's E inverse. Comparisons, copies, input words and oracle calls are not field arithmetic. -/ +namespace Whir.CountedCandidateCheck +open Concrete Protocol CausalGame SupportedCandidateExtraction + +/-- Instrument a loop while retaining its actual source state. -/ +def loop {S X : Type*} (step : S → X → S × Nat) : List X → S × Nat → S × Nat + | [], state => state + | x :: xs, state => + let next := step state.1 x + loop step xs (next.1, state.2 + next.2) + +theorem loop_value {S X : Type*} (step : S → X → S × Nat) (xs : List X) (s : S × Nat) : + (loop step xs s).1 = xs.foldl (fun v x => (step v x).1) s.1 := by + induction xs generalizing s with + | nil => rfl + | cons x xs ih => simpa [loop] using ih ((step s.1 x).1, s.2 + (step s.1 x).2) + +theorem loop_constant_charge {S X : Type*} (step : S → X → S × Nat) (charge : X → Nat) + (equal : ∀ s x, (step s x).2 = charge x) (xs : List X) (s : S × Nat) : + (loop step xs s).2 = s.2 + (xs.map charge).sum := by + induction xs generalizing s with + | nil => simp [loop] + | cons x xs ih => simp [loop, ih, equal, Nat.add_assoc] + +theorem loop_bound {S X : Type*} (step : S → X → S × Nat) (P : S → Prop) + (bound : Nat) (preserve : ∀ s x, P s → P (step s x).1) + (charge : ∀ s x, P s → (step s x).2 ≤ bound) + (xs : List X) (s : S × Nat) (valid : P s.1) : + (loop step xs s).2 ≤ s.2 + xs.length * bound := by + induction xs generalizing s with + | nil => simp [loop] + | cons x xs ih => + have h := ih ((step s.1 x).1, s.2 + (step s.1 x).2) (preserve _ _ valid) + simp only [loop, List.length_cons] + calc + _ ≤ s.2 + (step s.1 x).2 + xs.length * bound := h + _ ≤ s.2 + (xs.length + 1) * bound := by + have hc := charge s.1 x valid + rw [Nat.add_mul, Nat.one_mul] + omega + +/-- Count the fixed source square-and-multiply body. -/ +def powStep (exponent : Nat) (s : K × K) (i : Nat) : (K × K) × Nat := + ((kmul s.1 s.1, if exponent.testBit i then kmul s.2 s.1 else s.2), + 1 + if exponent.testBit i then 1 else 0) + +def countedKpow (a : K) (exponent : Nat) : K × Nat := + let result := loop (powStep exponent) (List.range 64) ((a, 1), 0) + (result.1.2, result.2) + +theorem countedKpow_value (a : K) (exponent : Nat) : + (countedKpow a exponent).1 = kpow a exponent := by + unfold countedKpow + dsimp only + rw [loop_value] + unfold kpow + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + ← apply_ite, List.forIn_pure_yield_eq_foldl, pure_bind] + apply congrArg (fun s : K × K => s.2) + apply congrArg (fun f => List.foldl f (a, 1) (List.range 64)) + funext s i + unfold powStep + split_ifs <;> rfl + +def countedKinv (a : K) : K × Nat := countedKpow a (2 ^ 64 - 2) + +theorem countedKinv_value (a : K) : (countedKinv a).1 = kinv a := + countedKpow_value a _ + +theorem countedKinv_cost (a : K) : (countedKinv a).2 ≤ 128 := by + have h := loop_bound (powStep (2 ^ 64 - 2)) (fun _ => True) 2 + (by intros; trivial) (by intro s i _; simp only [powStep]; split_ifs <;> decide) + (List.range 64) ((a, 1), 0) trivial + simpa [countedKinv, countedKpow] using h + +theorem countedKinv_exact_cost (a : K) : (countedKinv a).2 = 127 := by + have h := loop_constant_charge (powStep (2 ^ 64 - 2)) + (fun i => 1 + if (2 ^ 64 - 2 : Nat).testBit i then 1 else 0) + (by intros; rfl) (List.range 64) ((a, 1), 0) + have concrete : ((List.range 64).map + (fun i => 1 + if (2 ^ 64 - 2 : Nat).testBit i then 1 else 0)).sum = 127 := by decide + rw [concrete] at h + simpa only [countedKinv, countedKpow, Nat.zero_add] using h + +/-- The arithmetic certificate applies to precisely the inverse being charged. -/ +theorem countedKinv_field (a : K) : + E.ofK (countedKinv a).1 = (E.ofK a)⁻¹ := by + rw [countedKinv_value] + exact FieldModel.ofK_kinv a + +def rootsStep (s : Array K × Array K) (i : Nat) : (Array K × Array K) × Nat := + let layer := s.2.map fun x => kmul x (x ^^^ s.1[i]!) + ((s.1.push layer[0]!, layer.extract 1 layer.size), 2 * s.2.size) + +def countedRoots (n : Nat) : Array K × Nat := + let result := loop rootsStep (List.range n) + ((#[1], tab n fun i => (1 : K) <<< UInt64.ofNat (i + 1)), 0) + (result.1.1, result.2) + +theorem countedRoots_value (n : Nat) : (countedRoots n).1 = subspaceRoots n := by + unfold countedRoots + dsimp only + rw [loop_value] + unfold subspaceRoots + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + rfl + +theorem countedRoots_cost (n : Nat) : (countedRoots n).2 ≤ 2 * n * n := by + have h := loop_bound rootsStep (fun s => s.2.size ≤ n) (2 * n) + (by intro s i hs; simpa [rootsStep, Array.size_extract] using + (show min s.2.size s.2.size - 1 ≤ n by omega)) + (by intro s i hs; simpa [rootsStep] using Nat.mul_le_mul_left 2 hs) + (List.range n) ((#[1], tab n fun i => (1 : K) <<< UInt64.ofNat (i + 1)), 0) + (by simp [tab]) + simpa [countedRoots, Nat.mul_comm, Nat.mul_left_comm, Nat.mul_assoc] using h + +def normalizationStep (roots : Array K) (s : Array K × K) (i : Nat) : + (Array K × K) × Nat := + let inverse := countedKinv roots[i]! + ((s.1.push (kmul s.2 inverse.1), kmul s.2 (s.2 ^^^ roots[i]!)), inverse.2 + 3) + +def countedNormalization (n : Nat) (x : K) : Array K × Nat := + let roots := countedRoots n + let result := loop (normalizationStep roots.1) (List.range n) ((#[], x), roots.2) + (result.1.1, result.2) + +theorem countedNormalization_value (n : Nat) (x : K) : + (countedNormalization n x).1 = normalizedSubspaces n x := by + unfold countedNormalization + dsimp only + rw [loop_value, countedRoots_value] + unfold normalizedSubspaces + simp only [Std.Legacy.Range.forIn_eq_forIn_range', Std.Legacy.Range.size, + Nat.sub_zero, Nat.add_sub_cancel, Nat.div_one, ← List.range_eq_range', + List.forIn_pure_yield_eq_foldl, pure_bind] + simp only [normalizationStep, countedKinv_value] + rfl + +theorem countedNormalization_cost (n : Nat) (x : K) : + (countedNormalization n x).2 ≤ 2 * n * n + 131 * n := by + have h := loop_bound (normalizationStep (countedRoots n).1) (fun _ => True) 131 + (by intros; trivial) (by + intro s i _ + dsimp [normalizationStep] + have h := countedKinv_cost (countedRoots n).1[i]! + omega) + (List.range n) ((#[], x), (countedRoots n).2) trivial + have hr := countedRoots_cost n + simp only [countedNormalization] at ⊢ + simp only [List.length_range] at h + omega + +/-- Each source scale evaluates three base-field multiplications. -/ +def columnStep (out : Array E) (s : K) : Array E × Nat := + (out ++ out.map (fun x => x.scale s), 3 * out.size) + +def countedColumn (n q : Nat) : Array E × Nat := + let normalized := countedNormalization n (UInt64.ofNat q) + loop columnStep normalized.1.toList (#[E.one], normalized.2) + +theorem countedColumn_value (n q : Nat) : (countedColumn n q).1 = column n q := by + unfold countedColumn + rw [loop_value, countedNormalization_value] + unfold column + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + rw [← Array.foldl_toList] + rfl + +private theorem column_loop_cost (xs : List K) (a : Array E) (cost : Nat) : + (loop columnStep xs (a, cost)).2 = cost + 3 * a.size * (2 ^ xs.length - 1) := by + induction xs generalizing a cost with + | nil => simp [loop] + | cons x xs ih => + simp only [loop, columnStep, ih, Array.size_append, Array.size_map, List.length_cons, + Nat.pow_succ] + have positive : 0 < 2 ^ xs.length := by positivity + have hsub : 2 ^ xs.length * 2 - 1 = 2 * (2 ^ xs.length - 1) + 1 := by omega + rw [hsub] + ring + +theorem countedColumn_cost (n q : Nat) : + (countedColumn n q).2 ≤ 2 * n * n + 131 * n + 3 * 2 ^ n := by + simp only [countedColumn, column_loop_cost, Array.size_singleton, + Nat.mul_one, Array.length_toList, countedNormalization_value, + QueryRefinement.size_normalizedSubspaces] + have h := countedNormalization_cost n (UInt64.ofNat q) + omega + +/-- Source dot materializes exactly min(a.size,b.size) products and additions. -/ +def countedDot (a b : Array E) : E × Nat := (dot a b, 2 * min a.size b.size) + +@[simp] theorem countedDot_value (a b : Array E) : (countedDot a b).1 = dot a b := rfl + +theorem countedDot_source (a b : Array E) : + let products := tab (min a.size b.size) fun i => a[i]! * b[i]! + (countedDot a b).1 = products.foldl (· + ·) 0 ∧ + (countedDot a b).2 = 2 * products.size := by + simp [countedDot, dot, ArrayLayout.size_tab] + +def countedEncode (n rate : Nat) (a : Array E) : Array E × Nat := + let rows := tab (2 ^ (n + rate)) fun q => + let col := countedColumn n q + let result := countedDot a col.1 + (result.1, col.2 + result.2) + (rows.map Prod.fst, (rows.map Prod.snd).toList.sum) + +theorem countedEncode_value (n rate : Nat) (a : Array E) : + (countedEncode n rate a).1 = encode n rate a := by + simp [countedEncode, countedDot, countedColumn_value, encode, tab, Array.map_map, + Function.comp_def] + +theorem countedEncode_cost (n rate : Nat) (a : Array E) : + (countedEncode n rate a).2 ≤ + 2 ^ (n + rate) * (2 * n * n + 131 * n + 5 * 2 ^ n) := by + let charge := fun q => (countedColumn n q).2 + (countedDot a (countedColumn n q).1).2 + have h := List.sum_le_length_nsmul ((List.range (2 ^ (n + rate))).map charge) + (2 * n * n + 131 * n + 5 * 2 ^ n) (by + intro cost member + obtain ⟨q, _, rfl⟩ := List.mem_map.mp member + dsimp [charge, countedDot] + rw [countedColumn_value, QueryRefinement.size_column] + have hc := countedColumn_cost n q + have hm : min a.size (2 ^ n) ≤ 2 ^ n := Nat.min_le_right _ _ + omega) + simpa [countedEncode, tab, charge, Array.map_map, Array.toList_map, + Function.comp_def, Nat.mul_comm] using h + +end Whir.CountedCandidateCheck diff --git a/verification/whir/Whir/CountedCandidateCheckLoops.lean b/verification/whir/Whir/CountedCandidateCheckLoops.lean new file mode 100644 index 000000000..ea6010cc4 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckLoops.lean @@ -0,0 +1,221 @@ +import Whir.CountedCandidateCheck + +/-! Non-field resource units for the actual finite record preparation loops. Lookup comparisons, output slots and row words are charged separately from field arithmetic. Root/response shapes are consumer restrictions, not a consequence of acceptance used to bound arbitrary raw replies. -/ +namespace Whir.CountedCandidateCheck +open Concrete Protocol CausalGame SupportedCandidateExtraction PCSRewindExtractor +open scoped BigOperators + +/-- One comparison for each actually visited record, stopping at the first hit. -/ +def countedLookup {N : Nat} {F : Type*} : List (Fin N × F) → Fin N → Option F × Nat + | [], _ => (none, 0) + | (position, value) :: rest, target => + if target = position then (some value, 1) + else + let tail := countedLookup rest target + (tail.1, tail.2 + 1) + +theorem countedLookup_value {N : Nat} {F : Type*} (records : List (Fin N × F)) (q : Fin N) : + (countedLookup records q).1 = RewindRowExtraction.lookup records q := by + induction records with + | nil => rfl + | cons record records ih => + cases record + simp only [countedLookup, RewindRowExtraction.lookup] + split <;> simp [ih] + +theorem countedLookup_cost {N : Nat} {F : Type*} (records : List (Fin N × F)) (q : Fin N) : + (countedLookup records q).2 ≤ records.length := by + induction records with + | nil => simp [countedLookup] + | cons record records ih => + cases record + simp only [countedLookup, List.length_cons] + split <;> simp_all + +def countedFilledRecords (input : Public) (records : List (Record input.config)) : + Array (Option (Array K)) × Nat := + let looked := Array.ofFn fun q : Fin (blockLength input.config) => countedLookup records q + (looked.map Prod.fst, (looked.map Prod.snd).toList.sum) + +theorem countedFilledRecords_value (input : Public) (records : List (Record input.config)) : + (countedFilledRecords input records).1 = filledRecords input records := by + simp [countedFilledRecords, filledRecords, Array.map_ofFn, Function.comp_def, countedLookup_value] + +theorem countedFilledRecords_cost (input : Public) (records : List (Record input.config)) : + (countedFilledRecords input records).2 ≤ blockLength input.config * records.length := by + simp only [countedFilledRecords, Array.toList_map, Array.toList_ofFn, + List.map_ofFn, List.sum_ofFn] + calc + _ ≤ ∑ _q : Fin (blockLength input.config), records.length := by + apply Finset.sum_le_sum + intro q _ + exact countedLookup_cost records q + _ = _ := by simp + +/-- Actual receivedLaneCached tables materialize one slot per node per occupied lane. Missing entries are zero filled through the same source accessor. -/ +def countedReceivedTables (input : Public) (records : List (Record input.config)) : + Array (Array E) × Nat := + let filled := countedFilledRecords input records + let received := Array.ofFn fun lane : Fin input.lanes => + Array.ofFn (receivedLaneCached input filled.1 lane) + (received, filled.2 + input.lanes * blockLength input.config) + +theorem countedReceivedTables_value (input : Public) (records : List (Record input.config)) : + (countedReceivedTables input records).1 = + Array.ofFn (fun lane : Fin input.lanes => Array.ofFn (receivedLane input records lane)) := by + simp [countedReceivedTables, countedFilledRecords_value, receivedLane] + +theorem countedReceivedTables_cost (input : Public) (records : List (Record input.config)) : + (countedReceivedTables input records).2 ≤ + blockLength input.config * records.length + input.lanes * blockLength input.config := by + have h := countedFilledRecords_cost input records + dsimp [countedReceivedTables] + omega + +/-- No successful output can hide an unbounded array allocation: the literal output dimension is fixed before running the extractor. -/ +theorem output_length (input : Public) (w : Witness input.config input.lanes) : + (Array.ofFn w).size = input.lanes * width input.config := by simp + +/-- Configuration scalars and public structural slots. -/ +def publicHeaderWords (c : Config) : Nat := + 8 + c.folds.size + c.rates.size + c.queries.size + c.oodCounts.size + +/-- Consumed 64-bit words plus structural slots. E weights and values each contain three K-sized words. Prover time and discarded raw allocation are not asserted to be bounded by this public/retained-record admission count. -/ +def consumedWords (input : Public) (records : List (Record input.config)) : Nat := + publicHeaderWords input.config + input.root.size + (input.root.toList.map Array.size).sum + + (input.claims.toList.map (fun claim => 3 * claim.weight.size + 4)).sum + + (records.map (fun record => record.2.size + 2)).sum + +theorem consumedWords_bound (input : Public) (records : List (Record input.config)) + (recordLimit claimLimit : Nat) (consumer : ConsumerInput input recordLimit claimLimit records) : + consumedWords input records ≤ publicHeaderWords input.config + + blockLength input.config * (input.lanes + 1) + + claimLimit * (3 * laneCount input.config * width input.config + 4) + + recordLimit * (input.lanes + 2) := by + have root : (input.root.toList.map Array.size).sum = blockLength input.config * input.lanes := by + have eq : input.root.toList.map Array.size = input.root.toList.map (fun _ => input.lanes) := by + apply List.map_congr_left + intro row member + exact consumer.rootLanes row member + rw [eq] + simp [consumer.rootRows] + have claims := List.sum_le_length_nsmul + (input.claims.toList.map (fun claim => 3 * claim.weight.size + 4)) + (3 * (laneCount input.config * width input.config) + 4) (by + intro size member + obtain ⟨claim, hc, rfl⟩ := List.mem_map.mp member + rw [consumer.claimWeights claim hc]) + have rows := List.sum_le_length_nsmul (records.map (fun record => record.2.size + 2)) + (input.lanes + 2) (by + intro size member + obtain ⟨record, hr, rfl⟩ := List.mem_map.mp member + rw [consumer.recordRows record hr]) + simp at claims rows + have cb := Nat.mul_le_mul_right (3 * (laneCount input.config * width input.config) + 4) consumer.claims + have rb := Nat.mul_le_mul_right (input.lanes + 2) consumer.recordCount + unfold consumedWords + rw [root, consumer.rootRows] + simp [Nat.mul_assoc] at claims rows ⊢ + nlinarith + +/-- The real short-circuit all loop, retaining the number of visited entries. -/ +def countedAll {F : Type*} (predicate : F → Bool) : List F → Bool × Nat + | [] => (true, 0) + | x :: xs => + if predicate x then + let tail := countedAll predicate xs + (tail.1, tail.2 + 1) + else (false, 1) + +theorem countedAll_value {F : Type*} (predicate : F → Bool) (xs : List F) : + (countedAll predicate xs).1 = xs.all predicate := by + induction xs with + | nil => rfl + | cons x xs ih => simp only [countedAll, List.all_cons]; split <;> simp_all + +theorem countedAll_cost {F : Type*} (predicate : F → Bool) (xs : List F) : + (countedAll predicate xs).2 ≤ xs.length := by + induction xs with + | nil => simp [countedAll] + | cons x xs ih => simp only [countedAll, List.length_cons]; split <;> simp_all + +/-- One row-size comparison plus up to three base-component comparisons per actually visited E entry. This is not charged as a field operation. -/ +def countedRowMatches (c : Config) (lanes : Nat) (encoded : Array (Array E)) (record : Record c) : + Bool × Nat := + if record.2.size == lanes then + let checked := countedAll (fun lane : Fin (laneCount c) => + (encoded[lane.val]!)[record.1.val]! == E.ofK (recordLane lanes record.2 lane.val)) + (List.finRange (laneCount c)) + (checked.1, 1 + 3 * checked.2) + else (false, 1) + +theorem countedRowMatches_value (c : Config) (lanes : Nat) (encoded : Array (Array E)) (record : Record c) : + (countedRowMatches c lanes encoded record).1 = rowMatches c lanes encoded record := by + unfold countedRowMatches rowMatches + split <;> simp_all [countedAll_value] + +theorem countedRowMatches_cost (c : Config) (lanes : Nat) (encoded : Array (Array E)) (record : Record c) : + (countedRowMatches c lanes encoded record).2 ≤ 1 + 3 * laneCount c := by + unfold countedRowMatches + split + · dsimp only + have h := countedAll_cost (fun lane : Fin (laneCount c) => + (encoded[lane.val]!)[record.1.val]! == E.ofK (recordLane lanes record.2 lane.val)) + (List.finRange (laneCount c)) + simpa using Nat.add_le_add_left (Nat.mul_le_mul_left 3 h) 1 + · omega + +def countedFilter {F : Type*} (predicate : F → Bool × Nat) : + List F → List F × Nat + | [] => ([], 0) + | x :: xs => + let checked := predicate x + let tail := countedFilter predicate xs + (if checked.1 then x :: tail.1 else tail.1, checked.2 + tail.2) + +theorem countedFilter_value {F : Type*} (predicate : F → Bool × Nat) (xs : List F) : + (countedFilter predicate xs).1 = xs.filter (fun x => (predicate x).1) := by + induction xs with + | nil => rfl + | cons x xs ih => simp [countedFilter, List.filter_cons, ih] + +theorem countedFilter_cost {F : Type*} (predicate : F → Bool × Nat) (xs : List F) + (bound : Nat) (charges : ∀ x ∈ xs, (predicate x).2 ≤ bound) : + (countedFilter predicate xs).2 ≤ xs.length * bound := by + induction xs with + | nil => simp [countedFilter] + | cons x xs ih => + have head := charges x (by simp) + have tail := ih (fun x hx => charges x (by simp [hx])) + dsimp [countedFilter] + rw [Nat.add_mul, Nat.one_mul] + omega + +/-- Cache is shared with every record. The source coordinate deduplication is retained literally; its insertion scan upper charge is length*(length+1). The row-match comparison counter is from the actual short-circuit lane loop. -/ +def countedCommonCoordinates (c : Config) (lanes : Nat) (candidate : Array E) + (records : List (Record c)) : Finset (Fin (blockLength c)) × Nat := + let encoded := encodedLanes c candidate + let matched := countedFilter (countedRowMatches c lanes encoded) records + let coordinates := matched.1.map Prod.fst + (coordinates.toFinset, matched.2 + coordinates.length * (coordinates.length + 1)) + +theorem countedCommonCoordinates_value (c : Config) (lanes : Nat) (candidate : Array E) + (records : List (Record c)) : + (countedCommonCoordinates c lanes candidate records).1 = commonCoordinates c lanes candidate records := by + simp [countedCommonCoordinates, commonCoordinates, countedFilter_value, countedRowMatches_value] + +theorem countedCommonCoordinates_cost (c : Config) (lanes : Nat) (candidate : Array E) + (records : List (Record c)) : + (countedCommonCoordinates c lanes candidate records).2 ≤ + records.length * (1 + 3 * laneCount c) + records.length * (records.length + 1) := by + have row := countedFilter_cost (countedRowMatches c lanes (encodedLanes c candidate)) records + (1 + 3 * laneCount c) (by intros; apply countedRowMatches_cost) + have length : (countedFilter (countedRowMatches c lanes (encodedLanes c candidate)) records).1.length ≤ + records.length := by + rw [countedFilter_value] + exact List.length_filter_le _ _ + dsimp [countedCommonCoordinates] + simp only [List.length_map] + nlinarith + +end Whir.CountedCandidateCheck diff --git a/verification/whir/Whir/CountedCandidateCheckOriginal.lean b/verification/whir/Whir/CountedCandidateCheckOriginal.lean new file mode 100644 index 000000000..05333800d --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginal.lean @@ -0,0 +1,115 @@ +import Whir.CountedCandidateCheckOriginalAnchor +import Whir.BatchingRefinement + +/-! The actual original-claim checker caches immutable input weights once and materializes the witness once per check. Original family bit slices, all ordinary and strided point claims, and the literal saved anchor are checked separately before an output can be returned. Public finite functions are input-table reads, not an allowance for arbitrary external evaluation time. -/ +namespace Whir.OriginalClaimsChecker +open Concrete Protocol CausalGame RingPCSGame CountedCandidateCheck +open scoped BigOperators + +set_option maxHeartbeats 4000000 + +def pointGuard (dimension occupied : Nat) : PointClaim → Prop + | .point offset point _ => point.size ≤ dimension ∧ offset % 2 ^ point.size = 0 ∧ + offset + 2 ^ point.size ≤ occupied + | .strided offset slot stride point _ => stride + point.size ≤ dimension ∧ + slot < 2 ^ stride ∧ offset % 2 ^ (stride + point.size) = 0 ∧ + offset + 2 ^ (stride + point.size) ≤ occupied + +instance (dimension occupied : Nat) (point : PointClaim) : Decidable (pointGuard dimension occupied point) := by + cases point <;> unfold pointGuard <;> infer_instance + +def Guards (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) : Prop := + c.folds[0]! ≤ c.logN ∧ c.logN ≤ 64 ∧ 0 < lanes ∧ lanes ≤ 2 ^ c.folds[0]! ∧ + anchorPoint.size = c.logN ∧ + (∀ j, (family j).point.size ≤ c.logN ∧ + (family j).offset % 2 ^ (family j).point.size = 0 ∧ + (family j).offset + 2 ^ (family j).point.size ≤ lanes * 2 ^ (c.logN - c.folds[0]!)) ∧ + ∀ i : Fin points.size, pointGuard c.logN (lanes * 2 ^ (c.logN - c.folds[0]!)) points[i] + +instance (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) : Decidable (Guards c lanes family points anchorPoint) := by + unfold Guards + infer_instance + +structure Prepared (c : Config) (lanes m : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) where + guards : Guards c lanes family points anchorPoint + familyWeights : Array (Array E) + familyWeights_eq : familyWeights = Array.ofFn (fun j : Fin m => + tab (2 ^ c.logN) (regionWeight (family j).offset (family j).point)) + familyTargets : Array (Array E) + familyTargets_eq : familyTargets = Array.ofFn (fun j : Fin m => Array.ofFn (family j).slices) + pointClaims : Array Claim + pointClaims_eq : pointClaims = points.map (publicPoint (2 ^ c.logN)) + anchorTable : Array E + anchorTable_eq : anchorTable = eqTable anchorPoint + anchorClaim : Claim + anchorClaim_eq : anchorClaim = ⟨CommitmentAnchor.weight c lanes anchorPoint, anchorValue⟩ + basisCache : Array E + basisCache_eq : basisCache = powers (E.ofK 2) 64 + +def prepare (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) : + Option (Prepared c lanes m family points anchorPoint anchorValue) := + if valid : Guards c lanes family points anchorPoint then + let anchorTable := eqTable anchorPoint + let anchorWeight := tab (2 ^ c.logN) fun i => + if i < lanes * 2 ^ (c.logN - c.folds[0]!) then anchorTable[i]! else 0 + some { + guards := valid + familyWeights := Array.ofFn (fun j : Fin m => + let claim := family j + tab (2 ^ c.logN) (regionWeight claim.offset claim.point)) + familyWeights_eq := rfl + familyTargets := Array.ofFn (fun j : Fin m => Array.ofFn (family j).slices) + familyTargets_eq := rfl + pointClaims := points.map (publicPoint (2 ^ c.logN)) + pointClaims_eq := rfl + anchorTable := anchorTable + anchorTable_eq := rfl + anchorClaim := ⟨anchorWeight, anchorValue⟩ + anchorClaim_eq := rfl + basisCache := powers (E.ofK 2) 64 + basisCache_eq := rfl } + else none + +/-- Tail recursion uses no per-bit coefficient array or repeated witness materialization. A zero bit skips its field addition. -/ +def sliceLoop (words : Array K) (weights : Array E) (bit : Fin 64) : Nat → Nat → E → E + | 0, _, value => value + | fuel + 1, offset, value => + let next := if wordBit (words[offset]?.getD 0) bit then value + weights[offset]! else value + sliceLoop words weights bit fuel (offset + 1) next + +def slice (words : Array K) (weights : Array E) (bit : Fin 64) : E := + sliceLoop words weights bit weights.size 0 0 + +def check {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (w : Witness c lanes) : Bool := + let words := Array.ofFn w + let familyOk := (List.finRange m).all fun j => + (List.finRange 64).all fun bit => + slice words prepared.familyWeights[j.val]! bit == (prepared.familyTargets[j.val]!)[bit.val]! + if !familyOk then false else + let packed := tab (2 ^ c.logN) fun i => E.ofK (words[i]?.getD 0) + prepared.pointClaims.all (fun claim => dot packed claim.weight == claim.value) && + (dot packed prepared.anchorTable == anchorValue) + +/-- Gamma powers and the six-stage additive map are shared by the family weight and target computations. Every gamma stays inside the additive map. -/ +def input {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (root : BaseOracle) + (publicPrefix : Prefix) : Public := + let scales := powers publicPrefix.1 m + let phi := executableMap publicPrefix.2 + let members := List.finRange m + let weight := tab (2 ^ c.logN) fun v => + members.foldl (fun value j => value + + phi (scales[j.val]! * (prepared.familyWeights[j.val]!)[v]!)) 0 + let target := (List.finRange 64).foldl (fun value bit => value + prepared.basisCache[bit.val]! * + phi (members.foldl (fun value j => value + + scales[j.val]! * (prepared.familyTargets[j.val]!)[bit.val]!) 0)) 0 + ⟨c, lanes, root, (#[(⟨weight, target⟩ : Claim)] ++ prepared.pointClaims).push prepared.anchorClaim⟩ + +end Whir.OriginalClaimsChecker diff --git a/verification/whir/Whir/CountedCandidateCheckOriginalAnchor.lean b/verification/whir/Whir/CountedCandidateCheckOriginalAnchor.lean new file mode 100644 index 000000000..85e459d7d --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginalAnchor.lean @@ -0,0 +1,45 @@ +import Whir.CountedCandidateCheckOriginalWeights +import Whir.ExtractorArithmeticCostVerifier +import Whir.CommitmentAnchor + +/-! The final original anchor check counts the literal anchor value functional, with one actual equality table and the actual dot loop. It is not a recomputed commitment, a resampled point, or a compressed replacement for the original anchor. -/ +namespace Whir.CountedCandidateCheck +open Concrete Protocol CausalGame SupportedCandidateExtraction +open Whir.ExtractorArithmeticCost + +def countedOriginalMle (candidate point : Array E) : E × Nat := + let table := countedEqTable point + let result := countedDot candidate table.1 + (result.1, table.2 + result.2) + +theorem countedOriginalMle_value (candidate point : Array E) : + (countedOriginalMle candidate point).1 = Concrete.mle candidate point := by + simp [countedOriginalMle, countedDot_value, countedEqTable_value, Concrete.mle] + +theorem countedOriginalMle_field (candidate point : Array E) : + (countedOriginalMle candidate point).2 ≤ 3 * 2 ^ point.size + 2 * candidate.size := by + have table := countedEqTable_cost point + have dot : (countedDot candidate (countedEqTable point).1).2 = + 2 * min candidate.size (countedEqTable point).1.size := rfl + have minimum := Nat.min_le_left candidate.size (countedEqTable point).1.size + unfold countedOriginalMle tableCharge at * + dsimp only + have dense : 2 ^ point.size - 1 ≤ 2 ^ point.size := Nat.sub_le _ _ + nlinarith + +/-- The equality table materializes its bounded physical number of entries; no success or acceptance premise supplies this dimension. -/ +theorem countedOriginalMle_table_size (point : Array E) : + (countedEqTable point).1.size = 2 ^ point.size := by + rw [countedEqTable_value] + exact TerminalRefinement.size_eqTable point + +def countedOriginalAnchor (c : Config) (lanes : Nat) (w : Witness c lanes) (point : Array E) : E × Nat := + countedOriginalMle (paddedWitness c lanes w) point + +theorem countedOriginalAnchor_value (c : Config) (lanes : Nat) (w : Witness c lanes) (point : Array E) : + (countedOriginalAnchor c lanes w point).1 = CommitmentAnchor.value c lanes w point := + countedOriginalMle_value _ _ + +#print axioms countedOriginalAnchor_value + +end Whir.CountedCandidateCheck diff --git a/verification/whir/Whir/CountedCandidateCheckOriginalBounds.lean b/verification/whir/Whir/CountedCandidateCheckOriginalBounds.lean new file mode 100644 index 000000000..372d13d7c --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginalBounds.lean @@ -0,0 +1,168 @@ +import Whir.CountedCandidateCheckOriginalCost +import Whir.CountedCandidateCheckOriginalCorrectness + +/-! Complete source-derived bounds for immutable original preparation, one cached public transformation and one actual final checker. The physical cube length is explicit, and malformed preparation never runs its allocating/field-arithmetic branch. -/ +namespace Whir.OriginalClaimsChecker +open Concrete Protocol CausalGame RingPCSGame CountedCandidateCheck +open scoped BigOperators + +set_option maxHeartbeats 4000000 + +private theorem eqCharge_source (point : Array E) (v : Nat) : + eqCharge point v = (countedOriginalEqWeight point v).2 := + (countedOriginalEqWeight_charge point v).symm + +private theorem eqCharge_bound (point : Array E) (v : Nat) : eqCharge point v ≤ 2 * point.size := by + rw [eqCharge_source] + exact countedOriginalEqWeight_field _ _ + +private theorem regionCharge_bound (offset : Nat) (point : Array E) (v : Nat) : + regionCharge offset point v ≤ 2 * point.size := by + unfold regionCharge + split + · exact eqCharge_bound _ _ + · simp + +private theorem pointCharge_bound (claim : PointClaim) (v : Nat) : + pointCharge claim v ≤ 2 * originalPointDimension claim := by + cases claim with + | point offset point value => exact regionCharge_bound _ _ _ + | strided offset slot stride point value => + simp only [pointCharge, originalPointDimension] + split + · exact eqCharge_bound _ _ + · simp + +theorem sum_map_bound {X : Type*} (xs : List X) (f : X → Nat) (bound : Nat) + (each : ∀ x ∈ xs, f x ≤ bound) : (xs.map f).sum ≤ xs.length * bound := by + induction xs with + | nil => simp + | cons x xs ih => + have current := each x (by simp) + have rest := ih (fun y member => each y (by simp [member])) + simp only [List.map_cons, List.sum_cons, List.length_cons] + nlinarith + +theorem point_dimension (dimension occupied : Nat) (claim : PointClaim) + (guarded : pointGuard dimension occupied claim) : originalPointDimension claim ≤ dimension := by + cases claim <;> simp only [pointGuard, originalPointDimension] at * <;> omega + +def preparationFieldPolynomial (size families points : Nat) : Nat := + 128 * size * (families + points) + 3 * size + 64 + +def checkFieldPolynomial (size families points : Nat) : Nat := + 64 * families * size + 2 * (points + 1) * size + +theorem preparationField_bound (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) + (guards : Guards c lanes family points anchorPoint) : + preparationField c family points anchorPoint ≤ preparationFieldPolynomial (2 ^ c.logN) m points.size := by + have familyDimension := guards.2.2.2.2.2.1 + have pointDimension := guards.2.2.2.2.2.2 + have familyCost := sum_map_bound (List.finRange m) + (fun j => ((List.range (2 ^ c.logN)).map (regionCharge (family j).offset (family j).point)).sum) + (2 ^ c.logN * (2 * c.logN)) (by + intro j _ + have bound := sum_map_bound (List.range (2 ^ c.logN)) + (regionCharge (family j).offset (family j).point) (2 * c.logN) (by + intro v _ + exact (regionCharge_bound _ _ _).trans (Nat.mul_le_mul_left 2 (familyDimension j).1)) + simpa using bound) + have pointCost := sum_map_bound (List.finRange points.size) + (fun i => ((List.range (2 ^ c.logN)).map (pointCharge points[i])).sum) + (2 ^ c.logN * (2 * c.logN)) (by + intro i _ + have bound := sum_map_bound (List.range (2 ^ c.logN)) (pointCharge points[i]) + (2 * c.logN) (by + intro v _ + exact (pointCharge_bound _ _).trans + (Nat.mul_le_mul_left 2 (point_dimension _ _ _ (pointDimension i)))) + simpa using bound) + simp only [List.length_finRange] at familyCost pointCost + have dimension := guards.2.1 + have pointSize := guards.2.2.2.2.1 + have dense : 2 ^ anchorPoint.size - 1 ≤ 2 ^ c.logN := by rw [pointSize]; exact Nat.sub_le _ _ + have perDimension : 2 ^ c.logN * (2 * c.logN) ≤ 2 ^ c.logN * 128 := + Nat.mul_le_mul_left _ (by omega) + have familyBudget := familyCost.trans (Nat.mul_le_mul_left m perDimension) + have pointBudget := pointCost.trans (Nat.mul_le_mul_left points.size perDimension) + unfold preparationField preparationFieldPolynomial Whir.ExtractorArithmeticCost.tableCharge + nlinarith + +theorem countedPrepare_field (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) : + (countedPrepare c lanes family points anchorPoint anchorValue).2.fieldArithmetic ≤ + preparationFieldPolynomial (2 ^ c.logN) m points.size := by + unfold countedPrepare + dsimp only + split + · rename_i valid + have guarded : Guards c lanes family points anchorPoint := + (prepare_some_iff c lanes family points anchorPoint anchorValue).mp valid + exact preparationField_bound c lanes family points anchorPoint guarded + · simp [preparationFieldPolynomial] + +theorem countedCheck_value {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (w : Witness c lanes) : + (countedCheck prepared w).1 = check prepared w := by + simp only [countedCheck, arithmeticAll_value, countedSlice_value, countedDot_value, + Array.all_toList, check] + split <;> rfl + +theorem countedCheck_field {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (w : Witness c lanes) : + (countedCheck prepared w).2.fieldArithmetic ≤ checkFieldPolynomial (2 ^ c.logN) m points.size := by + have familySize : ∀ j : Fin m, prepared.familyWeights[j.val]!.size = 2 ^ c.logN := by + intro j + rw [prepared.familyWeights_eq] + simp [getElem!_pos, j.isLt] + have familyCost := arithmeticAll_field + (fun j : Fin m => arithmeticAll (fun bit : Fin 64 => + let value := countedSlice (Array.ofFn w) prepared.familyWeights[j.val]! bit + (value.1 == (prepared.familyTargets[j.val]!)[bit.val]!, value.2)) (List.finRange 64)) + (List.finRange m) (64 * 2 ^ c.logN) (by + intro j _ + have inner := arithmeticAll_field + (fun bit : Fin 64 => + let value := countedSlice (Array.ofFn w) prepared.familyWeights[j.val]! bit + (value.1 == (prepared.familyTargets[j.val]!)[bit.val]!, value.2)) + (List.finRange 64) (2 ^ c.logN) (by + intro bit _ + simpa only [familySize j] using countedSlice_field (Array.ofFn w) prepared.familyWeights[j.val]! bit) + simpa using inner) + have pointsCost := arithmeticAll_field + (fun claim : Claim => + let value := countedDot (tab (2 ^ c.logN) fun i => E.ofK ((Array.ofFn w)[i]?.getD 0)) claim.weight + (value.1 == claim.value, value.2)) prepared.pointClaims.toList (2 * 2 ^ c.logN) (by + intro claim _ + exact Nat.mul_le_mul_left 2 (by + simp)) + have pointCount : prepared.pointClaims.toList.length = points.size := by + rw [prepared.pointClaims_eq] + simp + have anchorCost : + (countedDot (tab (2 ^ c.logN) fun i => E.ofK ((Array.ofFn w)[i]?.getD 0)) prepared.anchorTable).2 ≤ + 2 * 2 ^ c.logN := + Nat.mul_le_mul_left 2 (by + simp) + simp only [List.length_finRange, pointCount] at familyCost pointsCost + unfold countedCheck + dsimp only + split <;> dsimp only [checkWork] <;> unfold checkFieldPolynomial <;> nlinarith + +theorem countedInput_field {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (root : BaseOracle) + (publicPrefix : Prefix) : (countedInput prepared root publicPrefix).2.fieldArithmetic = + m + 77 * m * 2 ^ c.logN + 64 * (2 * m + 77) := by + simp [countedInput, transformationWork, transformationField, mapField_eq] + ring + +#print axioms countedPrepare_field +#print axioms countedCheck_value +#print axioms countedCheck_field +#print axioms countedInput_field + +end Whir.OriginalClaimsChecker diff --git a/verification/whir/Whir/CountedCandidateCheckOriginalCorrectness.lean b/verification/whir/Whir/CountedCandidateCheckOriginalCorrectness.lean new file mode 100644 index 000000000..31e7d4d29 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginalCorrectness.lean @@ -0,0 +1,169 @@ +import Whir.CountedCandidateCheckOriginal + +/-! Correctness of the cached original checker and cached public transformation. These results quantify over every prepared immutable original statement and every candidate; no honest-root recomputation or compressed-family equality replaces original honesty. -/ +namespace Whir.OriginalClaimsChecker +open Concrete Protocol CausalGame RingPCSGame CountedCandidateCheck +open scoped BigOperators + +set_option maxHeartbeats 4000000 + +private theorem sliceLoop_eq (words : Array K) (weights : Array E) (bit : Fin 64) + (fuel offset : Nat) (value : E) : + sliceLoop words weights bit fuel offset value = value + + ∑ j ∈ Finset.range fuel, + if wordBit (words[offset + j]?.getD 0) bit then weights[offset + j]! else 0 := by + induction fuel generalizing offset value with + | zero => simp [sliceLoop] + | succ fuel ih => + rw [sliceLoop, ih, Finset.sum_range_succ'] + by_cases h : wordBit (words[offset]?.getD 0) bit = true + · simp [h, add_assoc, add_comm, add_left_comm] + · simp [h, add_comm, add_left_comm] + +theorem slice_eq (words : Array K) (weights : Array E) (bit : Fin 64) : + slice words weights bit = RingSwitch.slice + (fun v : Fin weights.size => weights[v.val]!) + (fun i v => wordBit (words[v.val]?.getD 0) i) bit := by + unfold slice RingSwitch.slice + rw [sliceLoop_eq] + simp only [zero_add] + rw [Fin.sum_univ_eq_sum_range + (fun v => RingSwitch.bit (wordBit (words[v]?.getD 0) bit) * weights[v]!) weights.size] + apply Finset.sum_congr rfl + intro v within + cases h : wordBit (words[v]?.getD 0) bit <;> simp [RingSwitch.bit] + +private theorem family_weight (c : Config) (lanes m : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (j : Fin m) : + prepared.familyWeights[j.val]! = tab (2 ^ c.logN) (regionWeight (family j).offset (family j).point) := by + rw [prepared.familyWeights_eq] + simp [getElem!_pos, j.isLt] + +private theorem family_target (c : Config) (lanes m : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (j : Fin m) (bit : Fin 64) : + (prepared.familyTargets[j.val]!)[bit.val]! = (family j).slices bit := by + rw [prepared.familyTargets_eq] + simp [getElem!_pos, j.isLt, bit.isLt] + +private theorem family_slice (c : Config) (lanes m : Nat) (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared c lanes m family points anchorPoint anchorValue) + (w : Witness c lanes) (j : Fin m) (bit : Fin 64) : + slice (Array.ofFn w) prepared.familyWeights[j.val]! bit = honestSlices c lanes family w j bit := by + rw [family_weight] + unfold slice honestSlices RingSwitch.slice paddedWord + rw [sliceLoop_eq] + simp only [ArrayLayout.size_tab, zero_add] + rw [Fin.sum_univ_eq_sum_range (fun v => + RingSwitch.bit (wordBit ((Array.ofFn w)[v]?.getD 0) bit) * + regionWeight (family j).offset (family j).point v) (2 ^ c.logN)] + apply Finset.sum_congr rfl + intro v within + rw [ArrayLayout.getElem!_tab _ _ _ (Finset.mem_range.mp within)] + cases h : wordBit ((Array.ofFn w)[v]?.getD 0) bit <;> simp [RingSwitch.bit] + +/-- Some preparation is possible exactly when the literal source metadata guards hold. -/ +theorem prepare_some_iff (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) : + (prepare c lanes family points anchorPoint anchorValue).isSome = true ↔ + Guards c lanes family points anchorPoint := by + unfold prepare + split <;> simp_all + +/-- This is original honesty, including every one of the64 bit slices per original family, every point value, and the same saved anchor. -/ +theorem check_iff {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (w : Witness c lanes) : + check prepared w = true ↔ Honest c lanes family points w ∧ + CommitmentAnchor.value c lanes w anchorPoint = anchorValue := by + have familyCheck : ((List.finRange m).all fun j => (List.finRange 64).all fun bit => + slice (Array.ofFn w) prepared.familyWeights[j.val]! bit == + (prepared.familyTargets[j.val]!)[bit.val]!) = true ↔ + (fun j => (family j).slices) = honestSlices c lanes family w := by + simp only [List.all_eq_true, List.mem_finRange, forall_true_left, beq_iff_eq, + family_slice, family_target] + exact ⟨fun h => funext (fun j => funext (fun bit => (h j bit).symm)), + fun h j bit => (congrFun (congrFun h j) bit).symm⟩ + have pointsCheck : prepared.pointClaims.all + (fun claim => dot (paddedWitness c lanes w) claim.weight == claim.value) = true ↔ + ∀ point ∈ points.toList, + dot (paddedWitness c lanes w) (publicPoint (2 ^ c.logN) point).weight = pointValue point := by + rw [prepared.pointClaims_eq, Array.all_eq_true] + simp only [Array.size_map, Array.getElem_map, publicPoint, beq_iff_eq] + constructor + · intro h point member + obtain ⟨i, within, rfl⟩ := Array.mem_iff_getElem.mp (Array.mem_toList_iff.mp member) + exact h i within + · intro h i within + exact h _ (Array.getElem_mem_toList within) + unfold check + dsimp only + change (if !((List.finRange m).all fun j => (List.finRange 64).all fun bit => + slice (Array.ofFn w) prepared.familyWeights[j.val]! bit == + (prepared.familyTargets[j.val]!)[bit.val]!) then false else + prepared.pointClaims.all (fun claim => dot (paddedWitness c lanes w) claim.weight == claim.value) && + (dot (paddedWitness c lanes w) prepared.anchorTable == anchorValue)) = true ↔ _ + rw [prepared.anchorTable_eq] + change (if !((List.finRange m).all fun j => (List.finRange 64).all fun bit => + slice (Array.ofFn w) prepared.familyWeights[j.val]! bit == + (prepared.familyTargets[j.val]!)[bit.val]!) then false else + prepared.pointClaims.all (fun claim => dot (paddedWitness c lanes w) claim.weight == claim.value) && + (CommitmentAnchor.value c lanes w anchorPoint == anchorValue)) = true ↔ _ + by_cases f : ((List.finRange m).all fun j => (List.finRange 64).all fun bit => + slice (Array.ofFn w) prepared.familyWeights[j.val]! bit == + (prepared.familyTargets[j.val]!)[bit.val]!) = true + · have hf := familyCheck.mp f + simp [f, hf, Honest, Bool.and_eq_true, beq_iff_eq, pointsCheck] + · have hf : (fun j => (family j).slices) ≠ honestSlices c lanes family w := by + intro h + exact f (familyCheck.mpr h) + simp [f, hf, Honest] + +/-- The cached transformation is exactly the source family-first stack with the original anchor appended at its original final position. -/ +theorem input_claims {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (publicPrefix : Prefix) : + (input prepared root publicPrefix).claims = + (transformedClaims (2 ^ c.logN) family points publicPrefix).push + ⟨CommitmentAnchor.weight c lanes anchorPoint, anchorValue⟩ := by + have familyWeights : ∀ j : Fin m, prepared.familyWeights[j.val]! = + tab (2 ^ c.logN) (regionWeight (family j).offset (family j).point) := family_weight _ _ _ _ _ _ _ prepared + have targets : ∀ j : Fin m, ∀ bit : Fin 64, + (prepared.familyTargets[j.val]!)[bit.val]! = (family j).slices bit := family_target _ _ _ _ _ _ _ prepared + have cache : ∀ bit : Fin 64, prepared.basisCache[bit.val]! = basis bit := by + intro bit + rw [prepared.basisCache_eq, BatchingRefinement.get_powers _ _ _ bit.isLt] + rfl + unfold input transformedClaims familyPublic familyTarget RingSwitch.familyTarget transparentWeight + dsimp only + rw [prepared.pointClaims_eq, prepared.anchorClaim_eq] + congr 3 + apply congrArg (fun claim : Claim => [claim]) + congr 1 + · apply Array.ext + · simp [ArrayLayout.size_tab] + · intro v hv _ + have within : v < 2 ^ c.logN := by simpa using hv + rw [ArrayLayout.getElem_tab _ _ _ within, ArrayLayout.getElem_tab _ _ _ within] + simp only [Fin.sum_univ_def, List.sum_eq_foldl, List.foldl_map] + apply congrArg (fun f => (List.finRange m).foldl f (0 : E)) + funext value j + rw [BatchingRefinement.get_powers _ _ _ j.isLt, familyWeights j, + ArrayLayout.getElem!_tab _ _ _ within] + · simp only [Fin.sum_univ_def, List.sum_eq_foldl, List.foldl_map] + apply congrArg (fun f => (List.finRange 64).foldl f (0 : E)) + funext value bit + rw [cache bit] + congr 2 + apply congrArg (executableMap publicPrefix.2) + apply congrArg (fun f => (List.finRange m).foldl f (0 : E)) + funext value j + rw [BatchingRefinement.get_powers _ _ _ j.isLt, targets j bit] + +#print axioms check_iff +#print axioms input_claims + +end Whir.OriginalClaimsChecker diff --git a/verification/whir/Whir/CountedCandidateCheckOriginalCost.lean b/verification/whir/Whir/CountedCandidateCheckOriginalCost.lean new file mode 100644 index 000000000..6e8139323 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginalCost.lean @@ -0,0 +1,187 @@ +import Whir.CountedCandidateCheckOriginal +import Whir.CountedCandidateCheckLoops + +/-! Concrete original-checker resource counters. Field charges follow the source product, sum, square and power loops. Non-field charges include bit reads, array lookups, comparisons, loop visits and admitted finite input/output slots. Upper charges also cover source short-circuiting; no supplied cost model determines any coefficient. -/ +namespace Whir.OriginalClaimsChecker +open Concrete Protocol CausalGame RingPCSGame CountedCandidateCheck +open scoped BigOperators + +set_option maxHeartbeats 4000000 + +structure Work where + fieldArithmetic : Nat := 0 + bitReads : Nat := 0 + lookups : Nat := 0 + comparisons : Nat := 0 + iterations : Nat := 0 + slots : Nat := 0 + deriving Repr, BEq + +def Work.total (work : Work) : Nat := work.fieldArithmetic + work.bitReads + work.lookups + + work.comparisons + work.iterations + work.slots + +/-- This charge uses only metadata and bit tests, not a second execution of the field products. -/ +def eqCharge (point : Array E) (v : Nat) : Nat := + ((List.finRange point.size).map fun i => 1 + if v.testBit i.val then 0 else 1).sum + +def regionCharge (offset : Nat) (point : Array E) (v : Nat) : Nat := + if offset ≤ v ∧ v < offset + 2 ^ point.size then eqCharge point (v - offset) else 0 + +def pointCharge : PointClaim → Nat → Nat + | .point offset point _, v => regionCharge offset point v + | .strided offset slot stride point _, v => + if offset + slot ≤ v ∧ v < offset + 2 ^ (stride + point.size) ∧ + (v - offset) % 2 ^ stride = slot then eqCharge point ((v - offset) / 2 ^ stride) else 0 + +def preparationField (c : Config) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) : Nat := + ((List.finRange m).map fun j => ((List.range (2 ^ c.logN)).map + (regionCharge (family j).offset (family j).point)).sum).sum + + ((List.finRange points.size).map fun i => ((List.range (2 ^ c.logN)).map (pointCharge points[i])).sum).sum + + Whir.ExtractorArithmeticCost.tableCharge anchorPoint + 64 + +/-- Includes the extra metadata-only charge traversal, so instrumentation bookkeeping does not disappear from the non-field resource boundary. -/ +def preparationWork (c : Config) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) : Work := + let dimensionWords := ((List.finRange m).map fun j => (family j).point.size + 64 + 4).sum + + ((List.finRange points.size).map fun i => originalPointDimension points[i] + 6).sum + anchorPoint.size + 12 + { fieldArithmetic := preparationField c family points anchorPoint + bitReads := 2 * (m + points.size) * 2 ^ c.logN * c.logN + lookups := 3 * dimensionWords + 2 * (m + points.size + 1) * 2 ^ c.logN * (c.logN + 4) + comparisons := 5 + 3 * m + 4 * points.size + (4 * m + 6 * points.size) * 2 ^ c.logN + iterations := 5 + m * (66 + 2 ^ c.logN * (2 * c.logN + 4)) + + points.size * (2 + 2 ^ c.logN * (2 * c.logN + 6)) + 4 * 2 ^ c.logN + c.logN + 64 + slots := 4 * (m + points.size + 2) * 2 ^ c.logN + 64 * m + 64 + dimensionWords } + +def countedPrepare (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) : + Option (Prepared c lanes m family points anchorPoint anchorValue) × Work := + let result := prepare c lanes family points anchorPoint anchorValue + if result.isSome then (result, preparationWork c family points anchorPoint) else + (result, { comparisons := 16 * (m + points.size + 1), iterations := 16 * (m + points.size + 1) }) + +theorem countedPrepare_value (c : Config) (lanes : Nat) {m : Nat} (family : Fin m → FamilyClaim) + (points : Array PointClaim) (anchorPoint : Array E) (anchorValue : E) : + (countedPrepare c lanes family points anchorPoint anchorValue).1 = + prepare c lanes family points anchorPoint anchorValue := by + unfold countedPrepare + dsimp only + split <;> rfl + +def countedSliceLoop (words : Array K) (weights : Array E) (bit : Fin 64) : + Nat → Nat → E × Nat → E × Nat + | 0, _, state => state + | fuel + 1, offset, state => + let next := if wordBit (words[offset]?.getD 0) bit then + (state.1 + weights[offset]!, state.2 + 1) else state + countedSliceLoop words weights bit fuel (offset + 1) next + +def countedSlice (words : Array K) (weights : Array E) (bit : Fin 64) : E × Nat := + countedSliceLoop words weights bit weights.size 0 (0, 0) + +private theorem countedSliceLoop_value (words : Array K) (weights : Array E) (bit : Fin 64) + (fuel offset : Nat) (state : E × Nat) : + (countedSliceLoop words weights bit fuel offset state).1 = + sliceLoop words weights bit fuel offset state.1 := by + induction fuel generalizing offset state with + | zero => rfl + | succ fuel ih => + simp only [countedSliceLoop, sliceLoop] + split <;> simp_all + +private theorem countedSliceLoop_field (words : Array K) (weights : Array E) (bit : Fin 64) + (fuel offset : Nat) (state : E × Nat) : + (countedSliceLoop words weights bit fuel offset state).2 ≤ state.2 + fuel := by + induction fuel generalizing offset state with + | zero => simp [countedSliceLoop] + | succ fuel ih => + simp only [countedSliceLoop] + split + · exact (ih (offset + 1) (state.1 + weights[offset]!, state.2 + 1)).trans_eq (by omega) + · exact (ih (offset + 1) state).trans (by omega) + +theorem countedSlice_value (words : Array K) (weights : Array E) (bit : Fin 64) : + (countedSlice words weights bit).1 = slice words weights bit := countedSliceLoop_value _ _ _ _ _ _ + +theorem countedSlice_field (words : Array K) (weights : Array E) (bit : Fin 64) : + (countedSlice words weights bit).2 ≤ weights.size := by + simpa [countedSlice] using countedSliceLoop_field words weights bit weights.size 0 (0, 0) + +/-- The predicate runs only until its first actual false result, retaining all field work already performed. -/ +def arithmeticAll {X : Type*} (predicate : X → Bool × Nat) : List X → Bool × Nat + | [] => (true, 0) + | x :: xs => + let next := predicate x + if next.1 then + let rest := arithmeticAll predicate xs + (rest.1, next.2 + rest.2) + else (false, next.2) + +theorem arithmeticAll_value {X : Type*} (predicate : X → Bool × Nat) (xs : List X) : + (arithmeticAll predicate xs).1 = xs.all (fun x => (predicate x).1) := by + induction xs with + | nil => rfl + | cons x xs ih => simp [arithmeticAll, List.all_cons, ih]; split <;> simp_all + +theorem arithmeticAll_field {X : Type*} (predicate : X → Bool × Nat) (xs : List X) + (bound : Nat) (each : ∀ x ∈ xs, (predicate x).2 ≤ bound) : + (arithmeticAll predicate xs).2 ≤ xs.length * bound := by + induction xs with + | nil => simp [arithmeticAll] + | cons x xs ih => + have current := each x (by simp) + have rest := ih (fun y member => each y (by simp [member])) + simp only [arithmeticAll, List.length_cons] + split <;> dsimp only <;> nlinarith + +def checkWork (c : Config) (lanes m points : Nat) (fieldArithmetic : Nat) : Work := + let size := 2 ^ c.logN + { fieldArithmetic + bitReads := 64 * m * size + lookups := 2 * 64 * m * size + 4 * (points + 1) * size + lanes * 2 ^ (c.logN - c.folds[0]!) + comparisons := 3 * (64 * m + points + 1) + 64 * m * size + iterations := 64 * m * (size + 1) + 2 * (points + 1) * (size + 1) + slots := lanes * 2 ^ (c.logN - c.folds[0]!) + size + (points + 1) * size } + +def countedCheck {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (w : Witness c lanes) : Bool × Work := + let words := Array.ofFn w + let familyOk := arithmeticAll (fun j : Fin m => arithmeticAll (fun bit : Fin 64 => + let value := countedSlice words prepared.familyWeights[j.val]! bit + (value.1 == (prepared.familyTargets[j.val]!)[bit.val]!, value.2)) (List.finRange 64)) (List.finRange m) + if !familyOk.1 then (false, checkWork c lanes m points.size familyOk.2) else + let packed := tab (2 ^ c.logN) fun i => E.ofK (words[i]?.getD 0) + let pointOk := arithmeticAll (fun claim : Claim => + let value := countedDot packed claim.weight + (value.1 == claim.value, value.2)) prepared.pointClaims.toList + let anchor := countedDot packed prepared.anchorTable + (pointOk.1 && (anchor.1 == anchorValue), checkWork c lanes m points.size (familyOk.2 + pointOk.2 + anchor.2)) + +/-- Source square-and-multiply depth: six shifts32,16,8,4,2,1, plus one scale and one add in each stage. -/ +def mapField : Nat := ((List.finRange 6).map fun j => 2 ^ (5 - j.val) + 2).sum + +theorem mapField_eq : mapField = 75 := by decide + +def transformationField (c : Config) (m : Nat) : Nat := + m + 2 ^ c.logN * m * (mapField + 2) + 64 * (2 * m + mapField + 2) + +def transformationWork (c : Config) (m points : Nat) : Work := + let size := 2 ^ c.logN + { fieldArithmetic := transformationField c m + lookups := 2 * m * size + 2 * m * 64 + points + 6 + 64 + iterations := m + m * size * (mapField + 2) + 64 * (2 * m + mapField + 2) + points + 2 + slots := size + m + points + 2 } + +def countedInput {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (root : BaseOracle) + (publicPrefix : Prefix) : Public × Work := + (input prepared root publicPrefix, transformationWork c m points.size) + +theorem countedInput_value {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (root : BaseOracle) + (publicPrefix : Prefix) : (countedInput prepared root publicPrefix).1 = input prepared root publicPrefix := rfl + +end Whir.OriginalClaimsChecker diff --git a/verification/whir/Whir/CountedCandidateCheckOriginalMap.lean b/verification/whir/Whir/CountedCandidateCheckOriginalMap.lean new file mode 100644 index 000000000..11fedf828 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginalMap.lean @@ -0,0 +1,62 @@ +import Whir.CountedCandidateCheckOriginalCost + +/-! Instrumented literal source squaring and six additive-map stages. The 75-operation public transformation charge is connected to the actual field-valued map, not an uninterpreted counter or an assumed backend. -/ +namespace Whir.OriginalClaimsChecker +open Concrete RingPCSGame CountedCandidateCheck + +set_option maxHeartbeats 4000000 + +def countedSquare (x : E) : Nat → E × Nat + | 0 => (x, 0) + | n + 1 => let y := countedSquare x n; (y.1 * y.1, y.2 + 1) + +theorem countedSquare_value (x : E) (n : Nat) : (countedSquare x n).1 = squareIter x n := by + induction n with + | zero => rfl + | succ n ih => simp [countedSquare, squareIter, ih] + +theorem countedSquare_field (x : E) (n : Nat) : (countedSquare x n).2 = n := by + induction n with + | zero => rfl + | succ n ih => simp [countedSquare, ih] + +def countedMapStep (challenges : Fin 6 → E) (value : E) (j : Fin 6) : E × Nat := + let square := countedSquare value (2 ^ (5 - j.val)) + (value + challenges j * square.1, square.2 + 2) +private theorem countedMapStep_value (challenges : Fin 6 → E) (value : E) (j : Fin 6) : + (countedMapStep challenges value j).1 = mapStage (challenges j) (2 ^ (5 - j.val)) value := by + simp [countedMapStep, countedSquare_value, mapStage] +private theorem countedMapStep_field (challenges : Fin 6 → E) (value : E) (j : Fin 6) : + (countedMapStep challenges value j).2 = 2 ^ (5 - j.val) + 2 := by + simp [countedMapStep, countedSquare_field] + +def countedMap (challenges : Fin 6 → E) (x : E) : E × Nat := + loop (countedMapStep challenges) (List.finRange 6) (x, 0) + +private theorem composed_value (challenges : Fin 6 → E) (xs : List (Fin 6)) + (hom : E →+ E) (x : E) : + (xs.foldl (fun φ j => (mapStage (challenges j) (2 ^ (5 - j.val))).comp φ) hom) x = + xs.foldl (fun value j => mapStage (challenges j) (2 ^ (5 - j.val)) value) (hom x) := by + induction xs generalizing hom with + | nil => rfl + | cons j xs ih => + simpa only [List.foldl_cons, AddMonoidHom.comp_apply] using + (ih ((mapStage (challenges j) (2 ^ (5 - j.val))).comp hom)) + +theorem countedMap_value (challenges : Fin 6 → E) (x : E) : + (countedMap challenges x).1 = executableMap challenges x := by + rw [countedMap, loop_value] + simp only [countedMapStep_value] + exact (composed_value challenges (List.finRange 6) (AddMonoidHom.id E) x).symm + +theorem countedMap_field (challenges : Fin 6 → E) (x : E) : (countedMap challenges x).2 = 75 := by + have charge := loop_constant_charge (countedMapStep challenges) + (fun j => 2 ^ (5 - j.val) + 2) (countedMapStep_field challenges) (List.finRange 6) (x, 0) + have exactCharge : (countedMap challenges x).2 = mapField := by + simpa only [countedMap, Nat.zero_add, mapField] using charge + exact exactCharge.trans mapField_eq + +#print axioms countedMap_value +#print axioms countedMap_field + +end Whir.OriginalClaimsChecker diff --git a/verification/whir/Whir/CountedCandidateCheckOriginalResources.lean b/verification/whir/Whir/CountedCandidateCheckOriginalResources.lean new file mode 100644 index 000000000..77f692009 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginalResources.lean @@ -0,0 +1,107 @@ +import Whir.CountedCandidateCheckOriginalBounds + +/-! Source field operations, bit tests, lookups, comparisons, loop visits and finite storage slots are separate logical units. These polynomials bound every such charged unit for guarded immutable original statements, without deriving dimensional restrictions from acceptance. They do not assert a wall-clock bound for an external prover. -/ +namespace Whir.OriginalClaimsChecker +open Concrete Protocol CausalGame RingPCSGame CountedCandidateCheck + +set_option maxHeartbeats 4000000 + +def preparationPolynomial (size families points : Nat) : Nat := + (532 * families + 536 * points + 151) * size + 661 * families + 286 * points + 570 + +def checkPolynomial (size families points : Nat) : Nat := + (384 * families + 9 * points + 12) * size + 256 * families + 5 * points + 5 + +def transformationPolynomial (size families points : Nat) : Nat := + (156 * families + 1) * size + 387 * families + 3 * points + 9930 + +theorem guarded_occupied_le (c : Config) (lanes : Nat) {m : Nat} + (family : Fin m → FamilyClaim) (points : Array PointClaim) (anchorPoint : Array E) + (guards : Guards c lanes family points anchorPoint) : + lanes * 2 ^ (c.logN - c.folds[0]!) ≤ 2 ^ c.logN := by + have scaled := Nat.mul_le_mul_right (2 ^ (c.logN - c.folds[0]!)) guards.2.2.2.1 + have foldBound := guards.1 + have exponent : c.folds[0]! + (c.logN - c.folds[0]!) = c.logN := by omega + simpa only [← Nat.pow_add, exponent] using scaled + +theorem preparationWork_total (c : Config) (lanes : Nat) {m : Nat} + (family : Fin m → FamilyClaim) (points : Array PointClaim) (anchorPoint : Array E) + (guards : Guards c lanes family points anchorPoint) : + (preparationWork c family points anchorPoint).total ≤ + preparationPolynomial (2 ^ c.logN) m points.size := by + have field := preparationField_bound c lanes family points anchorPoint guards + have dimension := guards.2.1 + have anchorDimension := guards.2.2.2.2.1 + have families := sum_map_bound (List.finRange m) + (fun j => (family j).point.size + 64 + 4) 132 (by + intro j _ + have hd := (guards.2.2.2.2.2.1 j).1 + omega) + have pointsBound := sum_map_bound (List.finRange points.size) + (fun i => originalPointDimension points[i] + 6) 70 (by + intro i _ + have hd := point_dimension _ _ _ (guards.2.2.2.2.2.2 i) + omega) + simp only [List.length_finRange] at families pointsBound + have bits := Nat.mul_le_mul_left (2 * (m + points.size) * 2 ^ c.logN) dimension + have lookups := Nat.mul_le_mul_left (2 * (m + points.size + 1) * 2 ^ c.logN) + (show c.logN + 4 ≤ 68 by omega) + have familyInner := Nat.mul_le_mul_left (2 ^ c.logN) + (show 2 * c.logN + 4 ≤ 132 by omega) + have familyLoops := Nat.mul_le_mul_left m (Nat.add_le_add_left familyInner 66) + have pointInner := Nat.mul_le_mul_left (2 ^ c.logN) + (show 2 * c.logN + 6 ≤ 134 by omega) + have pointLoops := Nat.mul_le_mul_left points.size (Nat.add_le_add_left pointInner 2) + unfold preparationWork Work.total preparationPolynomial preparationFieldPolynomial at * + dsimp only at * + nlinarith + +theorem countedPrepare_total (c : Config) (lanes : Nat) {m : Nat} + (family : Fin m → FamilyClaim) (points : Array PointClaim) (anchorPoint : Array E) + (anchorValue : E) : + (countedPrepare c lanes family points anchorPoint anchorValue).2.total ≤ + preparationPolynomial (2 ^ c.logN) m points.size := by + unfold countedPrepare + dsimp only + split + · rename_i valid + exact preparationWork_total c lanes family points anchorPoint + ((prepare_some_iff c lanes family points anchorPoint anchorValue).mp valid) + · simp only [Work.total] + unfold preparationPolynomial + omega + +theorem checkWork_total (c : Config) (lanes families points charge : Nat) + (occupied : lanes * 2 ^ (c.logN - c.folds[0]!) ≤ 2 ^ c.logN) + (field : charge ≤ checkFieldPolynomial (2 ^ c.logN) families points) : + (checkWork c lanes families points charge).total ≤ + checkPolynomial (2 ^ c.logN) families points := by + unfold checkWork Work.total checkPolynomial checkFieldPolynomial at * + dsimp only at * + nlinarith + +theorem countedCheck_total {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (w : Witness c lanes) : + (countedCheck prepared w).2.total ≤ checkPolynomial (2 ^ c.logN) m points.size := by + have occupied := guarded_occupied_le c lanes family points anchorPoint prepared.guards + have field := countedCheck_field prepared w + unfold countedCheck at field ⊢ + dsimp only at field ⊢ + split <;> rename_i branch <;> simp only [branch, ite_true] at field <;> + exact checkWork_total c lanes m points.size _ occupied field + +theorem countedInput_total {c : Config} {lanes m : Nat} {family : Fin m → FamilyClaim} + {points : Array PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) (root : BaseOracle) + (publicPrefix : Prefix) : + (countedInput prepared root publicPrefix).2.total = transformationPolynomial (2 ^ c.logN) m points.size := by + simp only [countedInput, transformationWork, transformationField, Work.total, mapField_eq] + unfold transformationPolynomial + ring + +#print axioms countedPrepare_total +#print axioms countedCheck_total +#print axioms countedInput_total + +end Whir.OriginalClaimsChecker diff --git a/verification/whir/Whir/CountedCandidateCheckOriginalWeights.lean b/verification/whir/Whir/CountedCandidateCheckOriginalWeights.lean new file mode 100644 index 000000000..4d5052ab0 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckOriginalWeights.lean @@ -0,0 +1,93 @@ +import Whir.CountedCandidateCheckArithmetic +import Whir.RingPCSGame + +/-! Executable original-claim weight counters. Each actual equality-factor iteration reads one coordinate bit and one point entry, multiplies once, and adds only for a zero bit. Region and strided selectors retain the literal source predicates; their bounded-word metadata operations are separate from field arithmetic. -/ +namespace Whir.CountedCandidateCheck +open Concrete Protocol CausalGame RingPCSGame +open scoped BigOperators + +private def originalEqStep (point : Array E) (u : Nat) (value : E) (i : Fin point.size) : E × Nat := + if u.testBit i.val then (value * point[i], 1) else (value * (1 + point[i]), 2) + +private theorem originalEqStep_value (point : Array E) (u : Nat) (value : E) (i : Fin point.size) : + (originalEqStep point u value i).1 = value * (if u.testBit i.val then point[i] else 1 + point[i]) := by + unfold originalEqStep + split <;> rfl + +def countedOriginalEqWeight (point : Array E) (u : Nat) : E × Nat := + loop (originalEqStep point u) (List.finRange point.size) (1, 0) + +theorem countedOriginalEqWeight_value (point : Array E) (u : Nat) : + (countedOriginalEqWeight point u).1 = RingPCSGame.eqWeight point u := by + simp only [countedOriginalEqWeight, loop_value, originalEqStep_value, RingPCSGame.eqWeight, + Fin.prod_univ_def, List.prod_eq_foldl, List.foldl_map] + +theorem countedOriginalEqWeight_field (point : Array E) (u : Nat) : + (countedOriginalEqWeight point u).2 ≤ 2 * point.size := by + have bound := loop_bound (originalEqStep point u) (fun _ => True) 2 + (fun _ _ _ => trivial) (by intro value i _; unfold originalEqStep; split <;> simp) + (List.finRange point.size) (1, 0) trivial + simpa [countedOriginalEqWeight, Nat.mul_comm] using bound + +/-- Exact source factor charges: the companion metadata pass need not recompute any field product. -/ +theorem countedOriginalEqWeight_charge (point : Array E) (u : Nat) : + (countedOriginalEqWeight point u).2 = + ((List.finRange point.size).map fun i => 1 + if u.testBit i.val then 0 else 1).sum := by + have charged := loop_constant_charge (originalEqStep point u) + (fun i => 1 + if u.testBit i.val then 0 else 1) + (by intro value i; unfold originalEqStep; split <;> simp_all) + (List.finRange point.size) (1, 0) + simpa [countedOriginalEqWeight] using charged + +/-- Exact bit-read, point-lookup and product-loop lengths are identical to the actual source factor list. -/ +theorem countedOriginalEqWeight_loops (point : Array E) : + (List.finRange point.size).length = point.size := by simp + +def countedOriginalRegionWeight (offset : Nat) (point : Array E) (v : Nat) : E × Nat := + if offset ≤ v ∧ v < offset + 2 ^ point.size then countedOriginalEqWeight point (v - offset) else (0, 0) + +theorem countedOriginalRegionWeight_value (offset : Nat) (point : Array E) (v : Nat) : + (countedOriginalRegionWeight offset point v).1 = regionWeight offset point v := by + unfold countedOriginalRegionWeight regionWeight + split <;> simp [countedOriginalEqWeight_value] + +theorem countedOriginalRegionWeight_field (offset : Nat) (point : Array E) (v : Nat) : + (countedOriginalRegionWeight offset point v).2 ≤ 2 * point.size := by + unfold countedOriginalRegionWeight + split + · exact countedOriginalEqWeight_field _ _ + · simp + +def originalPointDimension : PointClaim → Nat + | .point _ point _ => point.size + | .strided _ _ _ point _ => point.size + +def countedOriginalPointWeight : PointClaim → Nat → E × Nat + | .point offset point _, v => countedOriginalRegionWeight offset point v + | .strided offset slot stride point _, v => + if offset + slot ≤ v ∧ v < offset + 2 ^ (stride + point.size) ∧ + (v - offset) % 2 ^ stride = slot then + countedOriginalEqWeight point ((v - offset) / 2 ^ stride) else (0, 0) + +theorem countedOriginalPointWeight_value (claim : PointClaim) (v : Nat) : + (countedOriginalPointWeight claim v).1 = pointWeight claim v := by + cases claim with + | point offset point value => exact countedOriginalRegionWeight_value _ _ _ + | strided offset slot stride point value => + simp only [countedOriginalPointWeight, pointWeight] + split <;> simp [countedOriginalEqWeight_value] + +theorem countedOriginalPointWeight_field (claim : PointClaim) (v : Nat) : + (countedOriginalPointWeight claim v).2 ≤ 2 * originalPointDimension claim := by + cases claim with + | point offset point value => exact countedOriginalRegionWeight_field _ _ _ + | strided offset slot stride point value => + simp only [countedOriginalPointWeight, originalPointDimension] + split + · exact countedOriginalEqWeight_field _ _ + · simp + +#print axioms countedOriginalEqWeight_value +#print axioms countedOriginalPointWeight_value + +end Whir.CountedCandidateCheck diff --git a/verification/whir/Whir/CountedCandidateCheckSmoke.lean b/verification/whir/Whir/CountedCandidateCheckSmoke.lean new file mode 100644 index 000000000..8db7cfb18 --- /dev/null +++ b/verification/whir/Whir/CountedCandidateCheckSmoke.lean @@ -0,0 +1,184 @@ +import Whir.ExtractorArithmeticCostPolynomial +import Whir.CountedCandidateCheckOriginalAnchor +import Whir.ExtractorArithmeticCostSource + +/-! Bounded compiled smoke for the actual source encoder, full causal verifier, Root0 Gao decoder and all-claim checker. The legal reset machine retains its strict-prefix replay count. No intermediate GS backend is executed. -/ +namespace Whir.CountedCandidateCheckSmoke +open SupportedCandidateExtraction +open Concrete Protocol CausalGame KnowledgeExtraction PCSRewindExtractor +open AuthenticatedResetSupport CountedCandidateCheck ExtractorArithmeticCost + +def config : Config := ⟨3, #[1, 1], #[2, 2], #[16, 8], #[0, 1]⟩ +def words : Array K := #[3, 5, 7, 11, 13, 17, 19, 23] +def tape : Tape config := + ⟨E.ofK 3, (fun _ => ⟨(fun _ => E.ofK 5), (fun _ _ => E.ofK 7), + (fun _ => E.ofK 11), E.ofK 13⟩), (fun _ => E.ofK 17)⟩ + +def reply (proof : Opening) : Batch → Reply + | .initial _ => .initial proof.initial + | .fold level round _ => + .fold proof.levels[level]!.afterFold[round]! + (if round + 1 = config.folds[level]! then proof.levels[level]!.nextOracle else none) + (if level + 1 = config.folds.size && round + 1 = config.folds[level]! then proof.residual else #[]) + | .ood level index _ => .ood proof.levels[level]!.oods[index]! + | .query level _ _ => .query proof.levels[level]!.rows proof.levels[level]!.intro + | .tail round _ => .tail proof.tailMessages[round]! + +def run : IO Unit := do + let weight := tab 8 fun i => E.ofK (UInt64.ofNat (i + 29)) + let value := dot (words.map E.ofK) weight + let (root, proof) ← match prove config (challenges config tape) words weight value with + | .error message => throw (IO.userError message) + | .ok result => pure result + let input : Public := ⟨config, 2, root.map (Array.map E.c0), #[⟨weight, value⟩]⟩ + let strategy : Strategy := fun _ _ batch => reply proof batch + let answers := CausalGame.run strategy input [] (visibleBatches config tape.1 (challenges config tape)) + let acceptance := countedAcceptedReplies input tape answers + unless acceptance.1 == acceptedReplies input tape answers && acceptance.1 do + throw (IO.userError "counted full verifier disagrees with actual accepted trial") + let inverse := countedKinv 41 + unless inverse.1 == kinv 41 && inverse.2 == 127 do + throw (IO.userError "source inverse value or 127-multiplication count mismatch") + let encoded := countedEncode 2 2 #[E.ofK 3, E.ofK 5, E.ofK 7, E.ofK 11] + unless encoded.1 == encode 2 2 #[E.ofK 3, E.ofK 5, E.ofK 7, E.ofK 11] do + throw (IO.userError "counted source encoder mismatch") + let originalPoint := #[E.ofK 29, E.ofK 31, E.ofK 37] + let equality := countedOriginalEqWeight originalPoint 5 + unless equality.1 == RingPCSGame.eqWeight originalPoint 5 && equality.2 == 4 do + throw (IO.userError "original equality-factor bit/lookup arithmetic mismatch") + let strided := RingPCSGame.PointClaim.strided 4 1 1 #[E.ofK 3, E.ofK 5] 0 + let located := countedOriginalPointWeight strided 9 + let outside := countedOriginalPointWeight strided 8 + unless located.1 == RingPCSGame.pointWeight strided 9 && located.2 == 3 && + outside.1 == 0 && outside.2 == 0 do + throw (IO.userError "literal original strided selector or field count mismatch") + let anchorCheck := countedOriginalMle (words.map E.ofK) originalPoint + unless anchorCheck.1 == Concrete.mle (words.map E.ofK) originalPoint && anchorCheck.2 == 37 do + throw (IO.userError "literal retained anchor arithmetic mismatch") + let level : Fin input.config.folds.size := ⟨0, by change 0 < config.folds.size; decide⟩ + let noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64 := by + change 4 ≤ 64 + decide + let program := countedCollect input level 4 [tape] 0 (fun records total => + let decoded := countedDecodeAndCheck input (baseRecords records) noWrap + .finish decoded.1 (total + decoded.2)) + let fuel := collectionFuel input [tape] + let result := runCounted input strategy (streamLength config) fuel program + let actual := runRewind input strategy (streamLength config) fuel program.erase + unless result.output.map (fun witness => Array.ofFn witness) == some words do + throw (IO.userError "counted legal extractor did not recover the literal K witness") + unless result.output.map (fun witness => Array.ofFn witness) == + actual.output.map (fun witness => Array.ofFn witness) && result.responseCalls == actual.responseCalls do + throw (IO.userError "counted legal machine disagrees with existing rewind interpreter") + let records := baseRecords (acceptedRecords input tape level 4 answers) + let received := countedReceivedTables input records + unless received.1 == Array.ofFn (fun lane : Fin input.lanes => + Array.ofFn (fun q : Fin (blockLength input.config) => receivedLane input records lane q)) && + received.2 ≤ blockLength input.config * records.length + input.lanes * blockLength input.config do + throw (IO.userError "counted lookup/received-row loop value or bound mismatch") + let matched := countedCommonCoordinates input.config input.lanes (words.map E.ofK) records + unless decide (matched.1 = + SupportedCandidateExtraction.commonCoordinates input.config input.lanes (words.map E.ofK) records) && + matched.2 ≤ records.length * (1 + 3 * input.lanes) + records.length * (records.length + 1) do + throw (IO.userError "counted common-coordinate comparison value or bound mismatch") + let checked := countedDecodeAndCheck input records noWrap + let original := decodeAndCheck input records noWrap + unless checked.1.map (fun witness => Array.ofFn witness) == + original.1.map (fun witness => Array.ofFn witness) do + throw (IO.userError "counted decode/check disagrees with actual output") + unless checked.2 ≤ decodeCheckBound input && acceptance.2 > 0 && checked.2 > original.2 do + throw (IO.userError "full arithmetic counter omitted verifier or candidate-check work") + unless decide (ParameterBounds.threshold input.config 0 ≤ + (SupportedCandidateExtraction.commonCoordinates input.config input.lanes (words.map E.ofK) records).card) do + throw (IO.userError "false-claim fixture lacks enough authenticated common coordinates") + let falseInput : Public := ⟨config, 2, input.root, #[⟨weight, value + E.ofK 1⟩]⟩ + let falseCheck := countedDecodeAndCheck falseInput records noWrap + unless falseCheck.1.isNone do throw (IO.userError "original public false claim was not checked") + let malformed : Strategy := fun _ _ _ => .tail default + let rejected := runCounted input malformed (streamLength config) fuel program + unless rejected.output.isNone do throw (IO.userError "malformed causal replies were accepted") + let witness : Witness config 2 := fun i => words[i.val]! + let familyWeights := tab 8 (RingPCSGame.regionWeight 0 originalPoint) + let families : Fin 1 → RingPCSGame.FamilyClaim := fun _ => + ⟨0, originalPoint, fun bit => OriginalClaimsChecker.slice words familyWeights bit⟩ + let pointPrototype := RingPCSGame.PointClaim.strided 4 1 1 #[E.ofK 3] 0 + let pointValue := dot (words.map E.ofK) (RingPCSGame.publicPoint 8 pointPrototype).weight + let originalPoints := #[RingPCSGame.PointClaim.strided 4 1 1 #[E.ofK 3] pointValue] + let anchorValue := Concrete.mle (words.map E.ofK) originalPoint + let prepared ← match (OriginalClaimsChecker.countedPrepare config 2 families originalPoints originalPoint anchorValue).1 with + | none => throw (IO.userError "guarded original family/strided/anchor preparation rejected") + | some prepared => pure prepared + let preparation := (OriginalClaimsChecker.countedPrepare config 2 families originalPoints originalPoint anchorValue).2 + let originalCheck := OriginalClaimsChecker.countedCheck prepared witness + unless originalCheck.1 == OriginalClaimsChecker.check prepared witness && originalCheck.1 && + originalCheck.2.fieldArithmetic == 54 && preparation.fieldArithmetic == 124 do + throw (IO.userError "all64 original slices, strided point or saved anchor counter disagrees") + let mapDraws : Fin 6 → E := fun j => if j.val == 0 then 1 else 0 + let publicPrefix : RingPCSGame.Prefix := ⟨1, mapDraws⟩ + let mapped := OriginalClaimsChecker.countedMap mapDraws (E.ofK 41) + unless mapped.1 == RingPCSGame.executableMap mapDraws (E.ofK 41) && mapped.2 == 75 do + throw (IO.userError "actual 63-square/six-scale/six-add public map disagrees") + let originalPublic := OriginalClaimsChecker.countedInput prepared #[] publicPrefix + unless originalPublic.2.fieldArithmetic == 5673 do + throw (IO.userError "cached original source public transformation count disagrees") + let sourceStatement := batchClaims 8 originalPublic.1.claims tape.1 + let (sourceRoot, sourceProof) ← match prove config (challenges config tape) words sourceStatement.weight sourceStatement.value with + | .error message => throw (IO.userError message) + | .ok result => pure result + let sourceInput := OriginalClaimsChecker.input prepared (sourceRoot.map (Array.map E.c0)) publicPrefix + let sourceStrategy : Strategy := fun _ _ batch => reply sourceProof batch + let sourceLevel : Fin sourceInput.config.folds.size := ⟨0, by change 0 < config.folds.size; decide⟩ + let sourceNoWrap : sourceInput.config.logN - sourceInput.config.folds[0]! + sourceInput.config.rates[0]! ≤ 64 := by + change 4 ≤ 64 + decide + let sourceProgram := ExtractorArithmeticCostSource.program sourceInput sourceLevel [tape] sourceNoWrap + (OriginalClaimsChecker.countedCheck prepared) + let sourceFuel := collectionFuel sourceInput [tape] + let sourceMeasured := runCounted sourceInput sourceStrategy (streamLength config) sourceFuel sourceProgram + let sourceActual := runRewind sourceInput sourceStrategy (streamLength config) sourceFuel + (PCSRewindSource.program sourceInput sourceLevel [tape] sourceNoWrap (OriginalClaimsChecker.check prepared)) + unless sourceMeasured.output.map (fun w => Array.ofFn w) == some words && + sourceMeasured.output.map (fun w => Array.ofFn w) == sourceActual.output.map (fun w => Array.ofFn w) && + sourceMeasured.responseCalls == sourceActual.responseCalls do + throw (IO.userError "counted actual original-source legal reset/Root0 result or replay calls disagree") + let lyingFamilies : Fin 1 → RingPCSGame.FamilyClaim := fun j => + {families j with slices := fun bit => (families j).slices bit + if bit.val == 0 then 1 else 0} + let lyingPrepared ← match OriginalClaimsChecker.prepare config 2 lyingFamilies originalPoints originalPoint anchorValue with + | none => throw (IO.userError "well-shaped false original family failed metadata guard") + | some prepared => pure prepared + let lyingInput := OriginalClaimsChecker.input lyingPrepared sourceInput.root publicPrefix + unless lyingInput.claims.map (fun claim => (claim.weight, claim.value)) == + sourceInput.claims.map (fun claim => (claim.weight, claim.value)) do + throw (IO.userError "source map kernel did not mask the false uncompressed slice") + let sourceAnswers := CausalGame.run sourceStrategy sourceInput [] (visibleBatches config tape.1 (challenges config tape)) + let sourceRecords := baseRecords (acceptedRecords sourceInput tape sourceLevel 4 sourceAnswers) + unless decide (ParameterBounds.threshold config 0 ≤ + (SupportedCandidateExtraction.commonCoordinates config 2 (words.map E.ofK) sourceRecords).card) do + throw (IO.userError "false original-family fixture lacks enough authenticated records") + let compressedOnly := countedDecodeAndCheck lyingInput sourceRecords sourceNoWrap + unless compressedOnly.1.isSome do + throw (IO.userError "masked false-family fixture did not pass the compressed public checker") + let lyingMeasured := runCounted lyingInput sourceStrategy (streamLength config) sourceFuel + (ExtractorArithmeticCostSource.program lyingInput sourceLevel [tape] sourceNoWrap + (OriginalClaimsChecker.countedCheck lyingPrepared)) + let lyingActual := runRewind lyingInput sourceStrategy (streamLength config) sourceFuel + (PCSRewindSource.program lyingInput sourceLevel [tape] sourceNoWrap (OriginalClaimsChecker.check lyingPrepared)) + unless lyingMeasured.output.isNone && lyingActual.output.isNone && + lyingMeasured.responseCalls == lyingActual.responseCalls do + throw (IO.userError "actual uncompressed all64 original checker accepted a masked false family") + let malformedFamilies : Fin 1 → RingPCSGame.FamilyClaim := fun j => {families j with offset := 8} + unless (OriginalClaimsChecker.countedPrepare config 2 malformedFamilies originalPoints originalPoint anchorValue).1.isNone && + (OriginalClaimsChecker.countedPrepare config 2 families originalPoints #[E.ofK 29] anchorValue).1.isNone do + throw (IO.userError "literal original span or saved-anchor dimension guard was bypassed") + IO.println s!"counted-original-source: prepare-field={preparation.fieldArithmetic}, public-field={originalPublic.2.fieldArithmetic}, all64+strided+anchor-field={originalCheck.2.fieldArithmetic}, map-field={mapped.2}" + IO.println s!"counted-original-resources: prepare={preparation.total}, public={originalPublic.2.total}, all64-check={originalCheck.2.total}, bit-reads={originalCheck.2.bitReads}" + IO.println s!"counted-original-source-root0: field={sourceMeasured.fieldArithmetic + preparation.fieldArithmetic + originalPublic.2.fieldArithmetic}, replay-calls={sourceMeasured.responseCalls}, reply-words={sourceMeasured.encodedReplyWords}; masked false original rejected after enough authenticated records" + IO.println s!"counted-source: inverse={inverse.2}, encoder={encoded.2}, verifier={acceptance.2}" + IO.println s!"counted-root0: decoder={original.2}, decode+allclaims={checked.2}, total={result.fieldArithmetic}, replay-calls={result.responseCalls}, reply-words={result.encodedReplyWords}" + IO.println s!"counted-loops: received={received.2}, common-comparisons={matched.2}, admitted-public-and-record-words={consumedWords input records}" + IO.println s!"counted-original-primitives: equality={equality.2}, strided={located.2}, anchor-mle={anchorCheck.2}" + IO.println "counted-root0: exact source/check/reset result agreement; false claim checked after enough authenticated records; malformed replies rejected" + +end Whir.CountedCandidateCheckSmoke + +def main : IO Unit := Whir.CountedCandidateCheckSmoke.run diff --git a/verification/whir/Whir/DuplexModeGame.lean b/verification/whir/Whir/DuplexModeGame.lean index 1c0563f3d..3dd6d50eb 100644 --- a/verification/whir/Whir/DuplexModeGame.lean +++ b/verification/whir/Whir/DuplexModeGame.lean @@ -239,15 +239,14 @@ noncomputable def ModeAdv {Q : Nat} {Seed State AdvCoins Result : Type} (D : View Result → Bool) : ℚ := |realProbability iv adversary D - idealProbability sim iv adversary counted D| -/-- Precise remaining stochastic DMV18 Theorem 1 boundary for the proved mode. -Only the view-distinguishing inequality is assumed. The pinned simulator's -query bound is proved separately, never a cryptographic certificate field. -/ -structure PublicRandomCompressionDMV (Q : Nat) (Seed State : Type) [Fintype Seed] +/-- Whole-view bound certificate for a simulator. The actual pinned simulator +has a proved certificate, not an external distinguishing assumption. -/ +structure PublicCompressionModeBound (Q : Nat) (Seed State : Type) [Fintype Seed] (sim : Simulator Q Seed State) (iv : Digest32) : Prop where distinguishing : ∀ (AdvCoins Result : Type) [Fintype AdvCoins] (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) (D : View Result → Bool), - ModeAdv sim iv adversary counted D ≤ dmvLoss Q + ModeAdv sim iv adversary counted D ≤ duplexModeLoss Q /-- An explicit full-public-view deterministic-primitive replacement game. The known-answer theorem below rules out a small loss for any permitted class @@ -339,26 +338,26 @@ theorem constructionKey_injective (Q : Nat) (iv : Digest32) no PCS relation and cannot supply or replace a caller's Counts certificate. -/ theorem randomCompression_transfer {Q : Nat} {Seed State AdvCoins Result : Type} [Fintype Seed] [Fintype AdvCoins] (sim : Simulator Q Seed State) (iv : Digest32) - (security : PublicRandomCompressionDMV Q Seed State sim iv) + (security : PublicCompressionModeBound Q Seed State sim iv) (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) (D : View Result → Bool) {bound : ℚ} (ideal : idealProbability sim iv adversary counted D ≤ bound) : - realProbability iv adversary D ≤ bound + dmvLoss Q := by + realProbability iv adversary D ≤ bound + duplexModeLoss Q := by have h := (abs_le.mp (security.distinguishing AdvCoins Result adversary counted D)).2 linarith -/-- The optional concrete-hash modeling gap is a *separate* public-primitive -game assumption and a separate additive term. It is never absorbed into DMV. -/ +/-- The optional concrete-hash modeling gap is a separate public-primitive +game assumption and additive term, not part of the ideal mode coupling. -/ theorem concrete_transfer {Q : Nat} {Seed State AdvCoins Result : Type} [Fintype Seed] [Fintype AdvCoins] (sim : Simulator Q Seed State) (iv : Digest32) - (security : PublicRandomCompressionDMV Q Seed State sim iv) + (security : PublicCompressionModeBound Q Seed State sim iv) (Allowed : (Coins : Type) → [Fintype Coins] → (Output : Type) → (Coins → Program Output) → (View Output → Bool) → Prop) {primitiveLoss bound : ℚ} (primitive : ConcretePrimitiveGap Q iv primitiveLoss Allowed) (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) (D : View Result → Bool) (permitted : Allowed AdvCoins Result adversary D) (ideal : idealProbability sim iv adversary counted D ≤ bound) : - concreteProbability iv adversary D ≤ bound + dmvLoss Q + primitiveLoss := by + concreteProbability iv adversary D ≤ bound + duplexModeLoss Q + primitiveLoss := by have hp := (abs_le.mp (primitive AdvCoins Result adversary D permitted counted)).2 have hm := randomCompression_transfer sim iv security adversary counted D ideal linarith diff --git a/verification/whir/Whir/DuplexPublicSimulator.lean b/verification/whir/Whir/DuplexPublicSimulator.lean index f47fff795..60c837199 100644 --- a/verification/whir/Whir/DuplexPublicSimulator.lean +++ b/verification/whir/Whir/DuplexPublicSimulator.lean @@ -530,20 +530,6 @@ noncomputable def seedFintype : Fintype Seed := by letI : Finite Node := Finite.of_injective fields inj exact Fintype.ofFinite Seed -/-- Only the probabilistic distinguishing inequality remains external. The -simulator is fixed, its public reconstruction is checked, and the private-call -bound is a theorem rather than a field supplied by the cryptographic premise. -/ -theorem security_of_distinguishing (Q : Nat) (iv : Digest32) - (distinguishing : letI := seedFintype - ∀ (AdvCoins Result : Type) [Fintype AdvCoins] - (adversary : AdvCoins → Program Result) (counted : ∀ a, Counts Q (adversary a)) - (D : View Result → Bool), - ModeAdv (simulator Q) iv adversary counted D ≤ dmvLoss Q) : - letI := seedFintype - PublicRandomCompressionDMV Q Seed State (simulator Q) iv := by - let := seedFintype - exact ⟨distinguishing⟩ - theorem recognized_publicBody {log : PublicLog} {input : Node} {ns : List Node} (h : recognized log input = some ns) : ∃ rest, ns = input :: rest ∧ PublicBody log input.cv rest := by @@ -1227,7 +1213,6 @@ theorem publicCut_runPartial {Q : Nat} {Result : Type} (cache : RawKey Q → Opt #print axioms initial_budgetSafe #print axioms simulatorBound #print axioms replay_actual -#print axioms security_of_distinguishing #print axioms replayAnswers_consistent #print axioms reconstructSeed_agrees #print axioms reconstructSeed_runIdeal diff --git a/verification/whir/Whir/ExtractionField.lean b/verification/whir/Whir/ExtractionField.lean new file mode 100644 index 000000000..523b83315 --- /dev/null +++ b/verification/whir/Whir/ExtractionField.lean @@ -0,0 +1,89 @@ +import Whir.FieldInverse + +/-! A computational extension-field dictionary for extraction. The existing algebraic field dictionary uses finite-field choice for inversion. This local dictionary instead uses a fixed square-and-multiply ladder and retains the canonical executable ring operations. It is not installed as a global instance. -/ +namespace Whir.ExtractionField +open Concrete + +/-- At depth `n`, this computes `a^(2^(n+1)-2)` using exactly two multiplications per recursive step. -/ +def inversePower : Nat → E → E + | 0, _ => 1 + | n + 1, a => + let square := a * a + square * inversePower n square + +theorem inversePower_eq (n : Nat) (a : E) : inversePower n a = a ^ (2 ^ (n + 1) - 2) := by + induction n generalizing a with + | zero => simp [inversePower] + | succ n ih => + rw [inversePower, ih, ← pow_two, ← pow_succ', ← pow_mul] + congr 1 + have positive : 2 ≤ 2 ^ (n + 1) := by + calc + 2 = 2 ^ 1 := by norm_num + _ ≤ 2 ^ (n + 1) := Nat.pow_le_pow_right (by omega) (by omega) + rw [Nat.pow_succ] + omega + +def inverse (a : E) : E := inversePower 191 a + +theorem inverse_eq (a : E) : inverse a = a⁻¹ := by + rw [inverse, inversePower_eq] + by_cases zero : a = 0 + · subst a + simp + · have fermat := FiniteField.pow_card_sub_one_eq_one a zero + rw [FieldModel.card_E] at fermat + apply (mul_left_cancel₀ zero) + rw [mul_inv_cancel₀ zero, ← pow_succ'] + convert fermat using 1 + +/-- Proofs are erased; all data operations come from the concrete ring and the fixed inversion ladder. -/ +abbrev field : Field E where + toCommRing := FieldModel.instCommRingE + toNontrivial := (inferInstance : Nontrivial E) + inv := inverse + div a b := E.mul a (inverse b) + div_eq_mul_inv _ _ := rfl + zpow z a := match z with + | Int.ofNat n => FieldModel.instCommRingE.npow n a + | Int.negSucc n => inverse (FieldModel.instCommRingE.npow (n + 1) a) + nnratCast q := E.mul (FieldModel.instCommRingE.natCast q.num) + (inverse (FieldModel.instCommRingE.natCast q.den)) + ratCast q := E.mul (FieldModel.instCommRingE.intCast q.num) + (inverse (FieldModel.instCommRingE.natCast q.den)) + mul_inv_cancel a nonzero := by rw [inverse_eq]; exact mul_inv_cancel₀ nonzero + inv_zero := by rw [inverse_eq]; exact inv_zero + nnqsmul q a := E.mul (E.mul (FieldModel.instCommRingE.natCast q.num) + (inverse (FieldModel.instCommRingE.natCast q.den))) a + qsmul q a := E.mul (E.mul (FieldModel.instCommRingE.intCast q.num) + (inverse (FieldModel.instCommRingE.natCast q.den))) a + +/-- Cost-instrumented execution of the very same ladder. The first projection is +proved equal to the dictionary's implementation, so the count cannot describe a +different inverse algorithm. One unit is one concrete extension multiplication; +array traffic and word instructions are not included. -/ +def countedInversePower : Nat → E → E × Nat + | 0, _ => (1, 0) + | n + 1, a => + let square := a * a + let tail := countedInversePower n square + (square * tail.1, tail.2 + 2) + +theorem countedInversePower_value (n : Nat) (a : E) : + (countedInversePower n a).1 = inversePower n a := by + induction n generalizing a with + | zero => rfl + | succ n ih => simp [countedInversePower, inversePower, ih] + +theorem countedInversePower_cost (n : Nat) (a : E) : + (countedInversePower n a).2 = 2 * n := by + induction n generalizing a with + | zero => rfl + | succ n ih => simp [countedInversePower, ih, Nat.mul_add] + +theorem inverse_191_steps_382_multiplications (a : E) : + (countedInversePower 191 a).1 = inverse a ∧ + (countedInversePower 191 a).2 = 382 := by + exact ⟨countedInversePower_value 191 a, countedInversePower_cost 191 a⟩ + +end Whir.ExtractionField diff --git a/verification/whir/Whir/ExtractorArithmeticCost.lean b/verification/whir/Whir/ExtractorArithmeticCost.lean new file mode 100644 index 000000000..8ee1848b9 --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCost.lean @@ -0,0 +1,225 @@ +import Whir.ExtractorArithmeticCostVerifierTotal + +/-! Complete Root0 Gao plus candidate checking, executed inside the legal strict-prefix reset machine. The field counter is accumulated only when an actual full verifier trial or decode/check runs. Black-box response calls are separate oracle accesses; external prover time and arbitrary reply allocation are not claimed to be extractor field arithmetic. -/ +namespace Whir.ExtractorArithmeticCost +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck + +/-- The existing decoder is Root0 Gao only. Its counted field arithmetic is combined with the full cached common-coordinate and original-claims check. -/ +def countedDecodeAndCheck (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + Option (Witness input.config input.lanes) × Nat := + let decoded := decodeRecords input records noWrap + match decoded.1 with + | none => (none, decoded.2) + | some witness => + let checked := countedFinish input (paddedWitness input.config input.lanes witness) records + (checked.1, decoded.2 + checked.2) + +theorem countedDecodeAndCheck_value (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + (countedDecodeAndCheck input records noWrap).1 = (decodeAndCheck input records noWrap).1 := by + unfold countedDecodeAndCheck decodeAndCheck + dsimp only + cases decoded : (decodeRecords input records noWrap).1 <;> simp [countedFinish_value] + +def decodeCheckBound (input : Public) : Nat := + input.lanes * ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) + checkerBound input + +theorem countedDecodeAndCheck_cost (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) : + (countedDecodeAndCheck input records noWrap).2 ≤ decodeCheckBound input := by + have hd := decodeRecords_decoder_cost input records noWrap redundancy + unfold countedDecodeAndCheck + dsimp only + cases decoded : (decodeRecords input records noWrap).1 with + | none => + dsimp only + unfold decodeCheckBound + omega + | some witness => + have hc := countedFinish_cost input (paddedWitness input.config input.lanes witness) records + dsimp only + unfold decodeCheckBound + omega + +/-- The source accepted-record parser is reused, with acceptance evaluated exactly once by its counted verifier. -/ +def countedAcceptedRecords (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) (answers : List Reply) : + List (Fin (2 ^ depth) × Array E) × Nat := + let accepted := countedAcceptedReplies input tape answers + let records := if accepted.1 then + let ch := challenges input.config tape + let proof := decodedOpening input.config ch answers.toArray + match deriveQueries depth input.config.queries[level.val]! ch.levels[level.val]!.querySqueezes with + | none => [] + | some positions => + if valid : positions.size = input.config.queries[level.val]! ∧ + ∀ i : Fin input.config.queries[level.val]!, positions[i.val]! < 2 ^ depth then + List.ofFn fun i : Fin input.config.queries[level.val]! => + (⟨positions[i.val]!, valid.2 i⟩, proof.levels[level.val]!.rows[i.val]!) + else [] + else [] + (records, accepted.2) + +theorem countedAcceptedRecords_value (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) (depth : Nat) (answers : List Reply) : + (countedAcceptedRecords input tape level depth answers).1 = acceptedRecords input tape level depth answers := by + simp only [countedAcceptedRecords, countedAcceptedReplies_value, acceptedRecords] + rfl + +/-- Instrumented legal machine. Counters at a query describe local work already performed, so even fuel exhaustion retains the consumed arithmetic. -/ +inductive CountedProgram (c : Config) (lanes : Nat) where + | finish (output : Option (Witness c lanes)) (fieldArithmetic : Nat) + | query (fieldArithmetic : Nat) (batches : List Batch) (message : Batch) + (next : Reply → CountedProgram c lanes) + +def CountedProgram.erase {c : Config} {lanes : Nat} : CountedProgram c lanes → RewindProgram c lanes + | .finish output _ => .finish output + | .query _ batches message next => .query batches message (fun reply => (next reply).erase) + + +/-- Consumed 64-bit field words plus structural slots. Every E scalar has three K-sized words. Prover construction time is outside this admission unit. -/ +def replyWords : Reply → Nat + | .initial _ => 7 + | .fold _ next residual => + 9 + (next.getD #[]).size + + 3 * ((next.getD #[]).toList.map Array.size).sum + 3 * residual.size + | .ood _ => 10 + | .query rows _ => 7 + rows.size + 3 * (rows.toList.map Array.size).sum + | .tail _ => 7 +structure CountedResult (c : Config) (lanes : Nat) where + output : Option (Witness c lanes) + fieldArithmetic : Nat + responseCalls : Nat + encodedReplyWords : Nat + +def runCounted (input : Public) (strategy : Strategy) (maxReplay : Nat) : + Nat → CountedProgram input.config input.lanes → CountedResult input.config input.lanes + | _, .finish output charge => ⟨output, charge, 0, 0⟩ + | 0, .query charge _ _ _ => ⟨none, charge, 0, 0⟩ + | fuel + 1, .query charge batches message next => + if batches.length ≤ maxReplay then + let past := replayPast input strategy [] batches + let answer := strategy input past message + let result := runCounted input strategy maxReplay fuel (next answer) + ⟨result.output, result.fieldArithmetic, result.responseCalls + batches.length + 1, + result.encodedReplyWords + (past.map (fun entry => replyWords entry.2)).sum + replyWords answer⟩ + else ⟨none, charge, 0, 0⟩ + +theorem runCounted_value (input : Public) (strategy : Strategy) (maxReplay fuel : Nat) + (program : CountedProgram input.config input.lanes) : + (runCounted input strategy maxReplay fuel program).output = + (runRewind input strategy maxReplay fuel program.erase).output ∧ + (runCounted input strategy maxReplay fuel program).responseCalls = + (runRewind input strategy maxReplay fuel program.erase).responseCalls := by + induction fuel generalizing program with + | zero => cases program <;> simp [runCounted, CountedProgram.erase, runRewind] + | succ fuel ih => + cases program with + | finish output charge => simp [runCounted, CountedProgram.erase, runRewind] + | query charge batches message next => + simp only [runCounted, CountedProgram.erase, runRewind] + split + · exact ⟨(ih _).1, congrArg (· + batches.length + 1) (ih _).2⟩ + · exact ⟨rfl, rfl⟩ + +def countedTrial (input : Public) (charge : Nat) (historyPrefix : List Batch) : + List Batch → (List Reply → CountedProgram input.config input.lanes) → + CountedProgram input.config input.lanes + | [], finish => finish [] + | message :: rest, finish => + .query charge historyPrefix message (fun reply => + countedTrial input charge (historyPrefix ++ [message]) rest (fun replies => finish (reply :: replies))) + +theorem countedTrial_erase (input : Public) (charge : Nat) (historyPrefix messages : List Batch) + (finish : List Reply → CountedProgram input.config input.lanes) + (original : List Reply → RewindProgram input.config input.lanes) + (equal : ∀ replies, (finish replies).erase = original replies) : + (countedTrial input charge historyPrefix messages finish).erase = + trialProgram input historyPrefix messages original := by + induction messages generalizing historyPrefix finish original with + | nil => exact equal [] + | cons message messages ih => + simp only [countedTrial, CountedProgram.erase, trialProgram] + congr 1 + funext reply + exact ih _ _ _ (fun replies => equal (reply :: replies)) + +def countedCollect (input : Public) (level : Fin input.config.folds.size) (depth : Nat) : + List (Tape input.config) → Nat → + (List (Fin (2 ^ depth) × Array E) → Nat → CountedProgram input.config input.lanes) → + CountedProgram input.config input.lanes + | [], charge, finish => finish [] charge + | tape :: tapes, charge, finish => + countedTrial input charge [] (visibleBatches input.config tape.1 (challenges input.config tape)) + (fun replies => + let accepted := countedAcceptedRecords input tape level depth replies + countedCollect input level depth tapes (charge + accepted.2) + (fun records total => finish (accepted.1 ++ records) total)) + +theorem countedCollect_erase (input : Public) (level : Fin input.config.folds.size) (depth : Nat) + (tapes : List (Tape input.config)) (charge : Nat) + (finish : List (Fin (2 ^ depth) × Array E) → Nat → CountedProgram input.config input.lanes) + (original : List (Fin (2 ^ depth) × Array E) → RewindProgram input.config input.lanes) + (equal : ∀ records total, (finish records total).erase = original records) : + (countedCollect input level depth tapes charge finish).erase = continueCollect input level depth tapes original := by + induction tapes generalizing charge finish original with + | nil => exact equal [] charge + | cons tape tapes ih => + simp only [countedCollect, continueCollect] + apply countedTrial_erase + intro replies + try dsimp only + rw [ih _ _ _ (by intro records total; rw [equal])] + simp only [countedAcceptedRecords_value] + +def countedRepeatedProgram (profile : ParameterBounds.Profile) (rounds : Nat) (input : Public) + (equal : input.config = ParameterBounds.config profile) : + List (Seed profile rounds) → Nat → CountedProgram input.config input.lanes + | [], charge => .finish none charge + | seed :: seeds, charge => + countedCollect input (equal.symm ▸ initialLevel profile) + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (seedTapes profile rounds input equal seed) charge (fun records total => + let decoded := countedDecodeAndCheck input (baseRecords records) (by + simpa only [equal] using (InitialCandidates.production_initial_facts profile).2.2.1) + match decoded.1 with + | some witness => .finish (some witness) (total + decoded.2) + | none => countedRepeatedProgram profile rounds input equal seeds (total + decoded.2)) + +theorem countedRepeatedProgram_erase (profile : ParameterBounds.Profile) (rounds : Nat) (input : Public) + (equal : input.config = ParameterBounds.config profile) (seeds : List (Seed profile rounds)) (charge : Nat) : + (countedRepeatedProgram profile rounds input equal seeds charge).erase = repeatedProgram profile rounds input equal seeds := by + induction seeds generalizing charge with + | nil => rfl + | cons seed seeds ih => + simp only [countedRepeatedProgram, repeatedProgram] + apply countedCollect_erase + intro records total + try dsimp only + rw [countedDecodeAndCheck_value] + split <;> simp_all [CountedProgram.erase] + +/-- Exact agreement with the existing actual repeated extractor, including all strict-prefix replay responses, not merely independent decoder calls. -/ +theorem actualRepeated_value (profile : ParameterBounds.Profile) (rounds attempts lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) : + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength (ParameterBounds.config profile)) + (attempts * (rounds * streamLength (ParameterBounds.config profile))) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + let actual := runRewind input strategy (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program input seed) + measured.output = actual.output ∧ measured.responseCalls = actual.responseCalls := by + dsimp only + have h := runCounted_value (ExecutionShapes.Input profile lanes root claims) strategy + (streamLength (ParameterBounds.config profile)) + (attempts * (rounds * streamLength (ParameterBounds.config profile))) + (countedRepeatedProgram profile rounds (ExecutionShapes.Input profile lanes root claims) + rfl (List.ofFn seed) 0) + simpa [countedRepeatedProgram_erase, repeatedExtractor] using h + +end Whir.ExtractorArithmeticCost diff --git a/verification/whir/Whir/ExtractorArithmeticCostBounds.lean b/verification/whir/Whir/ExtractorArithmeticCostBounds.lean new file mode 100644 index 000000000..22840c275 --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostBounds.lean @@ -0,0 +1,137 @@ +import Whir.ExtractorArithmeticCost + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 4096 + +namespace Whir.ExtractorArithmeticCost +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck + +/-- Every reachable program node has a bounded accumulated arithmetic count. The actual factory below proves this property from source counters. -/ +def CountedProgram.Bounded {c : Config} {lanes : Nat} (bound : Nat) : CountedProgram c lanes → Prop + | .finish _ charge => charge ≤ bound + | .query charge _ _ next => charge ≤ bound ∧ ∀ reply, (next reply).Bounded bound + +theorem runCounted_cost (input : Public) (strategy : Strategy) (maxReplay fuel bound : Nat) + (program : CountedProgram input.config input.lanes) (valid : program.Bounded bound) : + (runCounted input strategy maxReplay fuel program).fieldArithmetic ≤ bound := by + induction fuel generalizing program with + | zero => cases program <;> exact (by first | exact valid | exact valid.1) + | succ fuel ih => + cases program with + | finish output charge => exact valid + | query charge batches message next => + simp only [runCounted] + split + · exact ih _ (valid.2 _) + · exact valid.1 + +private theorem countedTrial_bounded (input : Public) (charge bound : Nat) + (historyPrefix messages : List Batch) (finish : List Reply → CountedProgram input.config input.lanes) + (charged : charge ≤ bound) (valid : ∀ replies, (finish replies).Bounded bound) : + (countedTrial input charge historyPrefix messages finish).Bounded bound := by + induction messages generalizing historyPrefix finish with + | nil => exact valid [] + | cons message messages ih => + exact ⟨charged, fun reply => ih _ _ (fun replies => valid (reply :: replies))⟩ + +theorem countedCollect_bounded (input : Public) (level : Fin input.config.folds.size) + (depth : Nat) (tapes : List (Tape input.config)) (charge trialBound bound : Nat) + (trials : ∀ tape ∈ tapes, ∀ answers, + (countedAcceptedReplies input tape answers).2 ≤ trialBound) + (finish : List (Fin (2 ^ depth) × Array E) → Nat → CountedProgram input.config input.lanes) + (charged : charge + tapes.length * trialBound ≤ bound) + (valid : ∀ records total, total ≤ charge + tapes.length * trialBound → + (finish records total).Bounded bound) : + (countedCollect input level depth tapes charge finish).Bounded bound := by + induction tapes generalizing charge finish with + | nil => exact valid [] charge (by simp) + | cons tape tapes ih => + simp only [countedCollect] + apply countedTrial_bounded input charge bound _ _ _ (by omega) + intro replies + try dsimp only + have cost : (countedAcceptedRecords input tape level depth replies).2 ≤ trialBound := + trials tape (by simp) replies + apply ih (charge + (countedAcceptedRecords input tape level depth replies).2) + (fun t ht answers => trials t (by simp [ht]) answers) _ + · simp only [List.length_cons, Nat.succ_mul] at charged + omega + · intro records total totalBound + apply valid + simp only [List.length_cons, Nat.succ_mul] + omega + +theorem seedTapes_length (profile : ParameterBounds.Profile) (rounds : Nat) (input : Public) + (equal : input.config = ParameterBounds.config profile) (seed : Seed profile rounds) : + (seedTapes profile rounds input equal seed).length = rounds := by + cases input with + | mk config lanes root claims => + dsimp only at equal + subst config + simp [seedTapes] + +/-- A fixed natural trial budget is not an assumed cost model: it is exactly the proved trialPolynomial applied to strict public challenge dimensions. -/ +theorem countedRepeatedProgram_bounded (profile : ParameterBounds.Profile) (rounds : Nat) + (input : Public) (equal : input.config = ParameterBounds.config profile) + (dimension folds oods queries tail : Nat) + (consumer : ∀ tape : Tape input.config, + ChallengeInput input.config (challenges input.config tape) dimension folds oods queries tail) + (redundancy : width input.config < blockLength input.config) + (seeds : List (Seed profile rounds)) (charge bound : Nat) + (charged : charge + seeds.length * + (rounds * trialPolynomial input.claims.size input.config.folds.size dimension folds oods queries tail + + decodeCheckBound input) ≤ bound) : + (countedRepeatedProgram profile rounds input equal seeds charge).Bounded bound := by + induction seeds generalizing charge with + | nil => simpa [countedRepeatedProgram, CountedProgram.Bounded] using charged + | cons seed seeds ih => + simp only [countedRepeatedProgram] + apply countedCollect_bounded input _ _ _ charge + (trialPolynomial input.claims.size input.config.folds.size dimension folds oods queries tail) bound + · intro tape _ answers + exact countedAcceptedReplies_bound input tape answers _ _ _ _ _ (consumer tape) + · simp only [seedTapes_length] + simp only [List.length_cons, Nat.succ_mul] at charged + omega + · intro records total totalBound + have cost := countedDecodeAndCheck_cost input (baseRecords records) (by + simpa only [equal] using (InitialCandidates.production_initial_facts profile).2.2.1) redundancy + simp only [seedTapes_length] at totalBound + try dsimp only + split + · dsimp [CountedProgram.Bounded] + simp only [List.length_cons, Nat.succ_mul] at charged + omega + · apply ih + simp only [List.length_cons, Nat.succ_mul] at charged + omega + +def totalFieldPolynomial (input : Public) (attempts rounds dimension folds oods queries tail : Nat) : Nat := + attempts * (rounds * trialPolynomial input.claims.size input.config.folds.size + dimension folds oods queries tail + decodeCheckBound input) + +/-- End-to-end arithmetic and interaction bounds on the actual bounded legal repeated extractor, with exact output and response-count correspondence. -/ +theorem actualRepeated_cost (profile : ParameterBounds.Profile) (rounds attempts lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) (dimension folds oods queries tail : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + dimension folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) : + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength (ParameterBounds.config profile)) + (attempts * (rounds * streamLength (ParameterBounds.config profile))) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + measured.fieldArithmetic ≤ totalFieldPolynomial input attempts rounds dimension folds oods queries tail ∧ + measured.responseCalls ≤ attempts * (rounds * streamLength (ParameterBounds.config profile)) * + (streamLength (ParameterBounds.config profile) + 1) := by + dsimp only + constructor + · apply runCounted_cost + apply countedRepeatedProgram_bounded profile rounds _ rfl dimension folds oods queries tail consumer redundancy + simp [totalFieldPolynomial] + · rw [(actualRepeated_value profile rounds attempts lanes root claims strategy seed).2] + exact repeatedExtractor_responseCalls profile attempts rounds ⟨_, strategy⟩ seed + +end Whir.ExtractorArithmeticCost diff --git a/verification/whir/Whir/ExtractorArithmeticCostPolynomial.lean b/verification/whir/Whir/ExtractorArithmeticCostPolynomial.lean new file mode 100644 index 000000000..dc41aa58f --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostPolynomial.lean @@ -0,0 +1,100 @@ +import Whir.ExtractorArithmeticCostBounds +import Whir.CountedCandidateCheckLoops + +/-! The dimensions in the polynomial are physical lanes and nodes, not a logarithmic dimension misleadingly called polynomial. Encoded input words U are an explicit admission charge. External prover runtime and raw allocation are outside the oracle-access boundary, even for rejected responses. -/ +namespace Whir.ExtractorArithmeticCost +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck + +def physicalLevelPolynomial (lanes nodes folds oods queries : Nat) : Nat := + folds * (3 * lanes * nodes + 6) + oods * (5 * lanes * nodes + 7) + + (queries + 1) * (16586 + 12 * lanes * nodes) + +def physicalTrialPolynomial (lanes nodes claims levels folds oods queries tail : Nat) : Nat := + claims * (2 * lanes * nodes + 3) + + levels * physicalLevelPolynomial lanes nodes folds oods queries + + tail * (3 * lanes * nodes + 6) + 5 * lanes * nodes + 1 + +def physicalFieldPolynomial (lanes occupied nodes claims levels attempts rounds folds oods queries tail : Nat) : Nat := + attempts * (rounds * physicalTrialPolynomial lanes nodes claims levels folds oods queries tail + + occupied * ConcreteRowExtraction.rowArithmeticPolynomial nodes + checkerPolynomial lanes nodes claims) + +theorem denseWidth_le_physical (c : Config) (foldBound : c.folds[0]! ≤ c.logN) : + 2 ^ c.logN ≤ laneCount c * blockLength c := by + have eq : 2 ^ c.logN = laneCount c * width c := by + dsimp [laneCount, width] + rw [← Nat.pow_add] + congr 1 + omega + rw [eq] + apply Nat.mul_le_mul_left + apply Nat.pow_le_pow_right (by decide : 1 ≤ 2) + omega + +theorem totalFieldPolynomial_physical (input : Public) (attempts rounds folds oods queries tail : Nat) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + totalFieldPolynomial input attempts rounds input.config.logN folds oods queries tail ≤ + physicalFieldPolynomial (laneCount input.config) input.lanes (blockLength input.config) + input.claims.size input.config.folds.size attempts rounds folds oods queries tail := by + have width := denseWidth_le_physical input.config foldBound + have checker := checkerBound_polynomial input noWrap + unfold totalFieldPolynomial trialPolynomial verifierPolynomial levelPolynomial decodeCheckBound + physicalFieldPolynomial physicalTrialPolynomial physicalLevelPolynomial + simp only [Nat.add_assoc, Nat.mul_assoc] at * + gcongr + +/-- Complete field-plus-oracle-access resource count. U is charged literally, not hidden in a unit-cost call; no timing assertion about external computation is made. The strict physical root/claims/output restrictions remain explicit. -/ +theorem actualRepeated_total_resource (profile : ParameterBounds.Profile) (rounds attempts lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) (folds oods queries tail encodedInputWords : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + (ParameterBounds.config profile).logN folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) + (_physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (_physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (_occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (_physicalClaims : ∀ claim ∈ claims.toList, + claim.weight.size = laneCount (ParameterBounds.config profile) * width (ParameterBounds.config profile)) + (admittedInput : + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength input.config) + (attempts * (rounds * streamLength input.config)) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + measured.encodedReplyWords + consumedWords input [] ≤ encodedInputWords) : + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength input.config) + (attempts * (rounds * streamLength input.config)) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + measured.fieldArithmetic + measured.responseCalls + + (measured.encodedReplyWords + consumedWords input []) ≤ + physicalFieldPolynomial (laneCount input.config) lanes (blockLength input.config) + claims.size input.config.folds.size attempts rounds folds oods queries tail + + attempts * (rounds * streamLength input.config) * (streamLength input.config + 1) + + encodedInputWords := by + dsimp only + have cost := actualRepeated_cost profile rounds attempts lanes root claims strategy seed + (ParameterBounds.config profile).logN folds oods queries tail consumer redundancy + have polynomial := totalFieldPolynomial_physical (ExecutionShapes.Input profile lanes root claims) + attempts rounds folds oods queries tail (InitialCandidates.production_initial_facts profile).2.1 + (InitialCandidates.production_initial_facts profile).2.2.1 + exact Nat.add_le_add (Nat.add_le_add (cost.1.trans polynomial) cost.2) admittedInput + +/-- Separately charged, value-connected finite lookup/received-row work. It is not silently included in the field units and does not depend on acceptance. -/ +theorem admitted_preparation_resource (input : Public) (records : List (Record input.config)) + (recordLimit claimLimit : Nat) (consumer : ConsumerInput input recordLimit claimLimit records) : + (countedReceivedTables input records).2 + consumedWords input records ≤ + blockLength input.config * recordLimit + input.lanes * blockLength input.config + + publicHeaderWords input.config + blockLength input.config * (input.lanes + 1) + + claimLimit * (3 * laneCount input.config * width input.config + 4) + + recordLimit * (input.lanes + 2) := by + have prep := (countedReceivedTables_cost input records).trans + (Nat.add_le_add_right (Nat.mul_le_mul_left _ consumer.recordCount) _) + have words := consumedWords_bound input records recordLimit claimLimit consumer + omega + +#print axioms actualRepeated_total_resource +#print axioms admitted_preparation_resource + +end Whir.ExtractorArithmeticCost diff --git a/verification/whir/Whir/ExtractorArithmeticCostRetained.lean b/verification/whir/Whir/ExtractorArithmeticCostRetained.lean new file mode 100644 index 000000000..e85a96d2f --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostRetained.lean @@ -0,0 +1,120 @@ +import Whir.PCSRewindKnowledgeResources + +/-! Retained-record preparation costs for the actual production prefix collectors. Literal public root, claim and lane guards plus authenticated collected rows discharge the strict consumer contract. Summing all potential attempts also bounds any actual verified-output stopping subset; external prover computation remains outside these resource units. -/ +namespace Whir.ExtractorArithmeticCost +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck +open scoped BigOperators + +set_option maxHeartbeats 4000000 + +abbrev retainedRecords (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) := + let input := ExecutionShapes.Input profile lanes root claims + baseRecords (collectedRecords ⟨input, strategy⟩ (initialLevel profile) (initialDepth profile) + (seedTapes profile rounds input rfl seed)) + +/-- No acceptance-to-resource inference: authentication identifies every retained row with a bounded literal public row. -/ +theorem retained_consumer (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (physicalClaims : ∀ claim ∈ claims.toList, + claim.weight.size = laneCount (ParameterBounds.config profile) * width (ParameterBounds.config profile)) : + let input := ExecutionShapes.Input profile lanes root claims + ConsumerInput input (rounds * input.config.queries[0]!) claims.size + (retainedRecords profile rounds lanes root claims strategy seed) := by + dsimp only + have facts := InitialCandidates.production_initial_facts profile + refine ⟨facts.2.1, facts.2.2.1, occupied, ?_, ?_, le_rfl, physicalClaims, + physicalRoot, physicalLanes⟩ + · exact (List.length_filterMap_le _ _).trans + (production_collected_records profile rounds lanes root claims strategy seed) + · intro record member + have authenticated := collected_base_authenticated profile lanes root claims strategy + (seedTapes profile rounds (ExecutionShapes.Input profile lanes root claims) rfl seed) + rw [authenticated record member] + have within : record.1.val < root.size := by + rw [physicalRoot] + exact record.1.isLt + rw [getElem!_pos root record.1.val within] + exact physicalLanes _ (Array.getElem_mem_toList within) + +/-- Actual filled-record lookup and received-lane table values on the actual accepted full-suffix collector. -/ +theorem retained_preparation_value (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) : + let input := ExecutionShapes.Input profile lanes root claims + let records := retainedRecords profile rounds lanes root claims strategy seed + (countedFilledRecords input records).1 = filledRecords input records ∧ + (countedReceivedTables input records).1 = Array.ofFn (fun lane : Fin input.lanes => + Array.ofFn (fun q : Fin (blockLength input.config) => receivedLane input records lane q)) := by + exact ⟨countedFilledRecords_value _ _, countedReceivedTables_value _ _⟩ + +/-- Separately charged lookup visits, materialized received slots and admitted public/retained words. -/ +def retainedPreparation (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) : Nat := + let input := ExecutionShapes.Input profile lanes root claims + let records := retainedRecords profile rounds lanes root claims strategy seed + (countedReceivedTables input records).2 + consumedWords input records + +def retainedPreparationPolynomial (c : Config) (rounds lanes claims : Nat) : Nat := + blockLength c * (rounds * c.queries[0]!) + lanes * blockLength c + + publicHeaderWords c + blockLength c * (lanes + 1) + + claims * (3 * laneCount c * width c + 4) + rounds * c.queries[0]! * (lanes + 2) + +theorem production_retained_preparation (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (physicalClaims : ∀ claim ∈ claims.toList, + claim.weight.size = laneCount (ParameterBounds.config profile) * width (ParameterBounds.config profile)) : + retainedPreparation profile rounds lanes root claims strategy seed ≤ + retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes claims.size := by + exact admitted_preparation_resource (ExecutionShapes.Input profile lanes root claims) + (retainedRecords profile rounds lanes root claims strategy seed) _ _ + (retained_consumer profile rounds lanes root claims strategy seed physicalRoot physicalLanes + occupied physicalClaims) + +/-- Every potential prefix is bounded, including withholding and rejected trials; any actual stopping subset is therefore bounded by the same attempt polynomial. -/ +theorem production_retained_preparation_subset (profile : ParameterBounds.Profile) + (rounds attempts lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) (visited : Finset (Fin attempts)) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (physicalClaims : ∀ claim ∈ claims.toList, + claim.weight.size = laneCount (ParameterBounds.config profile) * width (ParameterBounds.config profile)) : + (∑ i ∈ visited, retainedPreparation profile rounds lanes root claims strategy (seed i)) ≤ + attempts * retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes claims.size := by + have card : visited.card ≤ attempts := by + simpa using Finset.card_le_card (Finset.subset_univ visited) + calc + _ ≤ ∑ _i ∈ visited, + retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes claims.size := + Finset.sum_le_sum (fun i _ => production_retained_preparation profile rounds lanes root claims + strategy (seed i) physicalRoot physicalLanes occupied physicalClaims) + _ = visited.card * retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes claims.size := by + simp + _ ≤ _ := Nat.mul_le_mul_right _ card + +theorem production_all_retained_preparation (profile : ParameterBounds.Profile) + (rounds attempts lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (physicalClaims : ∀ claim ∈ claims.toList, + claim.weight.size = laneCount (ParameterBounds.config profile) * width (ParameterBounds.config profile)) : + (∑ i, retainedPreparation profile rounds lanes root claims strategy (seed i)) ≤ + attempts * retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes claims.size := by + simpa using production_retained_preparation_subset profile rounds attempts lanes root claims + strategy seed Finset.univ physicalRoot physicalLanes occupied physicalClaims + +#print axioms retained_consumer +#print axioms retained_preparation_value +#print axioms production_all_retained_preparation +#print axioms production_retained_preparation_subset + +end Whir.ExtractorArithmeticCost diff --git a/verification/whir/Whir/ExtractorArithmeticCostSource.lean b/verification/whir/Whir/ExtractorArithmeticCostSource.lean new file mode 100644 index 000000000..eb247092d --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostSource.lean @@ -0,0 +1,215 @@ +import Whir.PCSRewindSourceProgram +import Whir.CountedCandidateCheckOriginalResources +import Whir.CountedCandidateCheckOriginalMap +import Whir.ExtractorArithmeticCostBounds + +/-! Counted actual source extraction. The common-coordinate certificate runs without redundant compressed functional checks; the immutable original checker then checks all 64 slices of every family, all original points and the saved anchor. Each attempt includes its fresh source transformation and the real causal reset collector. -/ +namespace Whir.ExtractorArithmeticCostSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck ExtractorArithmeticCost + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 4096 +attribute [local irreducible] ParameterBounds.config + +def decoded (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checker : Witness input.config input.lanes → Bool × OriginalClaimsChecker.Work) : + Option (Witness input.config input.lanes) × Nat := + let source := decodeRecords input records noWrap + match source.1 with + | none => (none, source.2) + | some w => + let certificate := countedFinish {input with claims := #[]} (paddedWitness input.config input.lanes w) records + match certificate.1 with + | none => (none, source.2 + certificate.2) + | some certified => + let original := checker certified + (if original.1 then some certified else none, source.2 + certificate.2 + original.2.fieldArithmetic) + +theorem decoded_value (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checker : Witness input.config input.lanes → Bool × OriginalClaimsChecker.Work) : + (decoded input records noWrap checker).1 = + PCSRewindSource.decodedWithFinal input records noWrap (fun w => (checker w).1) := by + unfold decoded PCSRewindSource.decodedWithFinal + dsimp only + cases source : (decodeRecords input records noWrap).1 with + | none => simp + | some w => + simp only [Option.bind_some] + rw [← countedFinish_value] + cases certificate : (countedFinish {input with claims := #[]} (paddedWitness input.config input.lanes w) records).1 <;> + simp + +def decodedBound (input : Public) (families points : Nat) : Nat := + input.lanes * ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) + + checkerBound {input with claims := #[]} + + OriginalClaimsChecker.checkFieldPolynomial (2 ^ input.config.logN) families points + +theorem decoded_field (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) (families points : Nat) + (checker : Witness input.config input.lanes → Bool × OriginalClaimsChecker.Work) + (originalBound : ∀ w, (checker w).2.fieldArithmetic ≤ + OriginalClaimsChecker.checkFieldPolynomial (2 ^ input.config.logN) families points) : + (decoded input records noWrap checker).2 ≤ decodedBound input families points := by + have decoder := decodeRecords_decoder_cost input records noWrap redundancy + unfold decoded + dsimp only + cases source : (decodeRecords input records noWrap).1 with + | none => dsimp only; unfold decodedBound; omega + | some w => + dsimp only + have common := countedFinish_cost {input with claims := #[]} (paddedWitness input.config input.lanes w) records + cases certificate : (countedFinish {input with claims := #[]} (paddedWitness input.config input.lanes w) records).1 with + | none => dsimp only; unfold decodedBound; omega + | some certified => + have original := originalBound certified + dsimp only + unfold decodedBound + omega + +def program (input : Public) (level : Fin input.config.folds.size) (tapes : List (Tape input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checker : Witness input.config input.lanes → Bool × OriginalClaimsChecker.Work) : + CountedProgram input.config input.lanes := + countedCollect input level (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) tapes 0 + (fun records total => + let checked := decoded input (baseRecords records) noWrap checker + .finish checked.1 (total + checked.2)) + +theorem continueCollect_finish (input : Public) (level : Fin input.config.folds.size) (depth : Nat) + (tapes : List (Tape input.config)) + (finish : List (Fin (2 ^ depth) × Array E) → Option (Witness input.config input.lanes)) : + continueCollect input level depth tapes (fun records => .finish (finish records)) = + collectAcceptedProgram input level depth tapes finish := by + induction tapes generalizing finish with + | nil => rfl + | cons tape tapes ih => + simp only [continueCollect, collectAcceptedProgram] + congr 1 + funext replies + exact ih _ + +theorem program_erase (input : Public) (level : Fin input.config.folds.size) (tapes : List (Tape input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checker : Witness input.config input.lanes → Bool × OriginalClaimsChecker.Work) : + (program input level tapes noWrap checker).erase = + PCSRewindSource.program input level tapes noWrap (fun w => (checker w).1) := by + unfold program PCSRewindSource.program + rw [← continueCollect_finish] + apply countedCollect_erase + intro records total + simp only [CountedProgram.erase, decoded_value] + +def runOne {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) : + CountedResult (ParameterBounds.config profile) lanes := + let inp := OriginalClaimsChecker.countedInput prepared root seed.1 + let result := runCounted inp.1 (strategy seed.1) (streamLength inp.1.config) + (rounds * streamLength inp.1.config) + (program inp.1 (initialLevel profile) (seedTapes profile rounds inp.1 rfl seed.2) + (InitialCandidates.production_initial_facts profile).2.2.1 (OriginalClaimsChecker.countedCheck prepared)) + {result with fieldArithmetic := inp.2.fieldArithmetic + result.fieldArithmetic} + +theorem runOne_value {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) : + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output = + (PCSRewindSource.runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output ∧ + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).responseCalls = + (PCSRewindSource.runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).responseCalls := by + unfold runOne PCSRewindSource.runOne + dsimp only [OriginalClaimsChecker.countedInput] + have agreement := runCounted_value (OriginalClaimsChecker.input prepared root seed.1) (strategy seed.1) + (streamLength (ParameterBounds.config profile)) (rounds * streamLength (ParameterBounds.config profile)) + (program (OriginalClaimsChecker.input prepared root seed.1) (initialLevel profile) + (seedTapes profile rounds (OriginalClaimsChecker.input prepared root seed.1) rfl seed.2) + (InitialCandidates.production_initial_facts profile).2.2.1 (OriginalClaimsChecker.countedCheck prepared)) + have erased := program_erase (OriginalClaimsChecker.input prepared root seed.1) (initialLevel profile) + (seedTapes profile rounds (OriginalClaimsChecker.input prepared root seed.1) rfl seed.2) + (InitialCandidates.production_initial_facts profile).2.2.1 (OriginalClaimsChecker.countedCheck prepared) + rw [erased] at agreement + have checkEq : (fun w : Witness (ParameterBounds.config profile) lanes => + (OriginalClaimsChecker.countedCheck prepared w).1) = OriginalClaimsChecker.check prepared := + funext (OriginalClaimsChecker.countedCheck_value prepared) + have programs := congrArg (fun checker : Witness (ParameterBounds.config profile) lanes → Bool => + PCSRewindSource.program (OriginalClaimsChecker.input prepared root seed.1) (initialLevel profile) + (seedTapes profile rounds (OriginalClaimsChecker.input prepared root seed.1) rfl seed.2) + (InitialCandidates.production_initial_facts profile).2.2.1 checker) checkEq + have machines := congrArg (fun p => runRewind (OriginalClaimsChecker.input prepared root seed.1) + (strategy seed.1) (streamLength (ParameterBounds.config profile)) + (rounds * streamLength (ParameterBounds.config profile)) p) programs + exact ⟨agreement.1.trans (congrArg RewindResult.output machines), + agreement.2.trans (congrArg RewindResult.responseCalls machines)⟩ + +def runAttempts {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) : + List (PCSRewindSource.Seed profile rounds) → CountedResult (ParameterBounds.config profile) lanes + | [] => ⟨none, 0, 0, 0⟩ + | seed :: rest => + let first := runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed + match first.output with + | some w => {first with output := some w} + | none => + let later := runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy rest + ⟨later.output, first.fieldArithmetic + later.fieldArithmetic, first.responseCalls + later.responseCalls, + first.encodedReplyWords + later.encodedReplyWords⟩ + +theorem runAttempts_value {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seeds : List (PCSRewindSource.Seed profile rounds)) : + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).output = + (PCSRewindSource.runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).output ∧ + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).responseCalls = + (PCSRewindSource.runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).responseCalls := by + induction seeds with + | nil => exact ⟨rfl, rfl⟩ + | cons seed rest ih => + have first := runOne_value profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed + simp only [runAttempts, PCSRewindSource.runAttempts] + rw [first.1] + split <;> dsimp only <;> simp_all + +def run {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) : + CountedResult (ParameterBounds.config profile) lanes := + let cached := OriginalClaimsChecker.countedPrepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue + match cached.1 with + | none => ⟨none, cached.2.fieldArithmetic, 0, 0⟩ + | some prepared => + let result := runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy (List.ofFn seed) + {result with fieldArithmetic := cached.2.fieldArithmetic + result.fieldArithmetic} + +theorem run_value {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) : + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).output = + (PCSRewindSource.run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).output ∧ + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).responseCalls = + (PCSRewindSource.run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).responseCalls := by + unfold run PCSRewindSource.run + dsimp only + rw [OriginalClaimsChecker.countedPrepare_value] + cases cached : OriginalClaimsChecker.prepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue with + | none => trivial + | some prepared => + exact runAttempts_value profile rounds lanes family points anchorPoint anchorValue prepared root strategy _ + +#print axioms run_value + +end Whir.ExtractorArithmeticCostSource diff --git a/verification/whir/Whir/ExtractorArithmeticCostSourceBounds.lean b/verification/whir/Whir/ExtractorArithmeticCostSourceBounds.lean new file mode 100644 index 000000000..d4c1cad1d --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostSourceBounds.lean @@ -0,0 +1,168 @@ +import Whir.ExtractorArithmeticCostSource +import Whir.ExtractorArithmeticCostPolynomial + +/-! Complete arithmetic and strict-prefix interaction budgets for the executable original-source wrapper. Public dimensions bound resource consumption independently of verifier acceptance. Decoder arithmetic is the concrete degree-seven Root0 Gao bound; no intermediate GS backend occurs. -/ +namespace Whir.ExtractorArithmeticCostSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck ExtractorArithmeticCost + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 4096 +attribute [local irreducible] ParameterBounds.config + +theorem program_bounded (input : Public) (level : Fin input.config.folds.size) (tapes : List (Tape input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) (families points : Nat) + (checker : Witness input.config input.lanes → Bool × OriginalClaimsChecker.Work) + (originalBound : ∀ w, (checker w).2.fieldArithmetic ≤ + OriginalClaimsChecker.checkFieldPolynomial (2 ^ input.config.logN) families points) + (dimension folds oods queries tail : Nat) + (consumer : ∀ tape ∈ tapes, + ChallengeInput input.config (challenges input.config tape) dimension folds oods queries tail) : + (program input level tapes noWrap checker).Bounded + (tapes.length * trialPolynomial input.claims.size input.config.folds.size dimension folds oods queries tail + + decodedBound input families points) := by + unfold program + apply countedCollect_bounded input level _ tapes 0 + (trialPolynomial input.claims.size input.config.folds.size dimension folds oods queries tail) + · intro tape member answers + exact countedAcceptedReplies_bound input tape answers _ _ _ _ _ (consumer tape member) + · omega + · intro records total totalBound + have decodeCost := decoded_field input (baseRecords records) noWrap redundancy families points checker originalBound + dsimp only [CountedProgram.Bounded] + omega + +theorem input_claim_count {c : Config} {lanes m : Nat} {family : Fin m → RingPCSGame.FamilyClaim} + {points : Array RingPCSGame.PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : OriginalClaimsChecker.Prepared c lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (publicPrefix : RingPCSGame.Prefix) : + (OriginalClaimsChecker.input prepared root publicPrefix).claims.size = points.size + 2 := by + simp [OriginalClaimsChecker.input, prepared.pointClaims_eq] + omega + +def oneFieldPolynomial (c : Config) (lanes families points rounds dimension folds oods queries tail : Nat) : Nat := + OriginalClaimsChecker.transformationField c families + + rounds * trialPolynomial (points + 2) c.folds.size dimension folds oods queries tail + + lanes * ConcreteRowExtraction.rowArithmeticPolynomial (blockLength c) + encoderBound c + + OriginalClaimsChecker.checkFieldPolynomial (2 ^ c.logN) families points + +theorem runOne_field {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) + (dimension folds oods queries tail : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + dimension folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) : + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).fieldArithmetic ≤ + oneFieldPolynomial (ParameterBounds.config profile) lanes m points.size rounds dimension folds oods queries tail := by + let inp := OriginalClaimsChecker.input prepared root seed.1 + have bound := program_bounded inp (initialLevel profile) (seedTapes profile rounds inp rfl seed.2) + (InitialCandidates.production_initial_facts profile).2.2.1 redundancy m points.size + (OriginalClaimsChecker.countedCheck prepared) (OriginalClaimsChecker.countedCheck_field prepared) + dimension folds oods queries tail (fun tape _ => consumer tape) + have actual := runCounted_cost inp (strategy seed.1) (streamLength inp.config) + (rounds * streamLength inp.config) _ _ bound + have claims : inp.claims.size = points.size + 2 := input_claim_count prepared root seed.1 + rw [seedTapes_length profile rounds inp rfl seed.2, claims] at actual + have decodeBudget : decodedBound inp m points.size = + lanes * ConcreteRowExtraction.rowArithmeticPolynomial (blockLength (ParameterBounds.config profile)) + + encoderBound (ParameterBounds.config profile) + + OriginalClaimsChecker.checkFieldPolynomial (2 ^ (ParameterBounds.config profile).logN) m points.size := by + unfold decodedBound checkerBound + change lanes * ConcreteRowExtraction.rowArithmeticPolynomial (blockLength (ParameterBounds.config profile)) + + (encoderBound (ParameterBounds.config profile) + 0 * _) + _ = _ + simp only [Nat.zero_mul, Nat.add_zero] + rfl + have trialBudget : trialPolynomial (points.size + 2) inp.config.folds.size dimension folds oods queries tail = + trialPolynomial (points.size + 2) (ParameterBounds.config profile).folds.size dimension folds oods queries tail := rfl + rw [decodeBudget, trialBudget] at actual + unfold runOne + dsimp only [OriginalClaimsChecker.countedInput] + unfold oneFieldPolynomial + dsimp only [inp, OriginalClaimsChecker.transformationWork] at actual ⊢ + omega + +theorem runOne_calls {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) : + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).responseCalls ≤ + (rounds * streamLength (ParameterBounds.config profile)) * (streamLength (ParameterBounds.config profile) + 1) := by + rw [(runOne_value profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).2] + exact responseCalls_le _ _ _ _ _ + +theorem runAttempts_field {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seeds : List (PCSRewindSource.Seed profile rounds)) + (dimension folds oods queries tail : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + dimension folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) : + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).fieldArithmetic ≤ + seeds.length * oneFieldPolynomial (ParameterBounds.config profile) lanes m points.size rounds dimension folds oods queries tail := by + induction seeds with + | nil => simp [runAttempts] + | cons seed seeds ih => + have first := runOne_field profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed + dimension folds oods queries tail consumer redundancy + simp only [runAttempts] + split <;> dsimp only <;> simp only [List.length_cons, Nat.succ_mul] <;> omega + +theorem runAttempts_calls {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seeds : List (PCSRewindSource.Seed profile rounds)) : + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).responseCalls ≤ + seeds.length * ((rounds * streamLength (ParameterBounds.config profile)) * (streamLength (ParameterBounds.config profile) + 1)) := by + induction seeds with + | nil => simp [runAttempts] + | cons seed seeds ih => + have first := runOne_calls profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed + simp only [runAttempts] + split <;> dsimp only <;> simp only [List.length_cons, Nat.succ_mul] <;> omega + +def totalFieldPolynomial (c : Config) (lanes families points attempts rounds dimension folds oods queries tail : Nat) : Nat := + OriginalClaimsChecker.preparationFieldPolynomial (2 ^ c.logN) families points + + attempts * oneFieldPolynomial c lanes families points rounds dimension folds oods queries tail + +theorem run_cost {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) + (dimension folds oods queries tail : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + dimension folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) : + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).fieldArithmetic ≤ + totalFieldPolynomial (ParameterBounds.config profile) lanes m points.size attempts rounds dimension folds oods queries tail ∧ + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).responseCalls ≤ + attempts * ((rounds * streamLength (ParameterBounds.config profile)) * (streamLength (ParameterBounds.config profile) + 1)) := by + have preparation := OriginalClaimsChecker.countedPrepare_field (ParameterBounds.config profile) lanes family points anchorPoint anchorValue + unfold run + dsimp only + split + · dsimp only + unfold totalFieldPolynomial + exact ⟨by omega, Nat.zero_le _⟩ + · rename_i prepared _ + have field := runAttempts_field profile rounds lanes family points anchorPoint anchorValue prepared root strategy + (List.ofFn seed) dimension folds oods queries tail consumer redundancy + have calls := runAttempts_calls profile rounds lanes family points anchorPoint anchorValue prepared root strategy (List.ofFn seed) + simp only [List.length_ofFn] at field calls + dsimp only + unfold totalFieldPolynomial + exact ⟨by omega, calls⟩ + +#print axioms run_cost + +end Whir.ExtractorArithmeticCostSource diff --git a/verification/whir/Whir/ExtractorArithmeticCostSourceComparisons.lean b/verification/whir/Whir/ExtractorArithmeticCostSourceComparisons.lean new file mode 100644 index 000000000..54e2cefd2 --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostSourceComparisons.lean @@ -0,0 +1,117 @@ +import Whir.ExtractorArithmeticCostSourcePolynomial + +/-! The actual source common-coordinate matcher and coordinate deduplication comparisons have their own counter, separate from field arithmetic. Full source extractor resource composition includes these comparisons, literal retained-row preparation, immutable original preparation/check reservations and strict-prefix oracle access. -/ +namespace Whir.ExtractorArithmeticCostSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck ExtractorArithmeticCost +open scoped BigOperators + +set_option maxHeartbeats 4000000 +attribute [local irreducible] ParameterBounds.config + +def commonComparisonPolynomial (c : Config) (rounds : Nat) : Nat := + (rounds * c.queries[0]!) * (1 + 3 * laneCount c) + + (rounds * c.queries[0]!) * (rounds * c.queries[0]! + 1) + +def sourceRecords {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) := + retainedRecords profile rounds lanes root (OriginalClaimsChecker.input prepared root seed.1).claims + (strategy seed.1) seed.2 + +theorem sourceRecords_count {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) : + (sourceRecords profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).length ≤ + rounds * (ParameterBounds.config profile).queries[0]! := by + exact (List.length_filterMap_le _ _).trans + (production_collected_records profile rounds lanes root + (OriginalClaimsChecker.input prepared root seed.1).claims (strategy seed.1) seed.2) + +theorem source_common_value_and_cost {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) + (candidate : Array E) : + let records := sourceRecords profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed + (countedCommonCoordinates (ParameterBounds.config profile) lanes candidate records).1 = + commonCoordinates (ParameterBounds.config profile) lanes candidate records ∧ + (countedCommonCoordinates (ParameterBounds.config profile) lanes candidate records).2 ≤ + commonComparisonPolynomial (ParameterBounds.config profile) rounds := by + dsimp only + constructor + · exact countedCommonCoordinates_value _ _ _ _ + · have comparisons := countedCommonCoordinates_cost (ParameterBounds.config profile) lanes candidate + (sourceRecords profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed) + have records := sourceRecords_count profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed + unfold commonComparisonPolynomial + exact comparisons.trans (by gcongr) + +def commonComparisonReservation (c : Config) (records : Nat) : Nat := + records * (1 + 3 * laneCount c) + records * (records + 1) + +theorem all_common_comparison_reservations {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) : + (∑ i, commonComparisonReservation (ParameterBounds.config profile) + (sourceRecords profile rounds lanes family points anchorPoint anchorValue prepared root strategy (seed i)).length) ≤ + attempts * commonComparisonPolynomial (ParameterBounds.config profile) rounds := by + calc + _ ≤ ∑ _i : Fin attempts, commonComparisonPolynomial (ParameterBounds.config profile) rounds := by + apply Finset.sum_le_sum + intro i _ + have records := sourceRecords_count profile rounds lanes family points anchorPoint anchorValue prepared root strategy (seed i) + unfold commonComparisonReservation commonComparisonPolynomial + gcongr + _ = _ := by simp + +/-- Complete actual legal source run resource polynomial. Every original and retained input restriction is explicit, no honest-root recomputation is assumed, and consumed response words are charged by literal U. The external prover is a unit oracle-access boundary, not a purported machine-time-efficient algorithm. -/ +theorem run_complete_physical_resource {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) + (folds oods queries tail encodedWords : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + (ParameterBounds.config profile).logN folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (admitted : (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).encodedReplyWords ≤ encodedWords) : + let c := ParameterBounds.config profile + let measured := run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed + measured.fieldArithmetic + measured.responseCalls + measured.encodedReplyWords + + originalReservation c lanes attempts family points anchorPoint anchorValue + + (∑ i, retainedCharge profile rounds lanes family points anchorPoint anchorValue prepared root strategy (seed i)) + + (∑ i, commonComparisonReservation c + (sourceRecords profile rounds lanes family points anchorPoint anchorValue prepared root strategy (seed i)).length) ≤ + physicalSourceFieldPolynomial (laneCount c) lanes (2 ^ c.logN) (blockLength c) m points.size c.folds.size + attempts rounds folds oods queries tail + + attempts * ((rounds * streamLength c) * (streamLength c + 1)) + encodedWords + + originalReservationPolynomial c m points.size attempts + + attempts * retainedPreparationPolynomial c rounds lanes (points.size + 2) + + attempts * commonComparisonPolynomial c rounds := by + dsimp only + have complete := run_complete_resource profile attempts rounds lanes family points anchorPoint anchorValue prepared root strategy seed + (ParameterBounds.config profile).logN folds oods queries tail encodedWords consumer redundancy + physicalRoot physicalLanes occupied admitted + have physical := totalFieldPolynomial_physical (ParameterBounds.config profile) lanes m points.size attempts rounds folds oods queries tail + (InitialCandidates.production_initial_facts profile).2.1 (InitialCandidates.production_initial_facts profile).2.2.1 + have comparisons := all_common_comparison_reservations profile attempts rounds lanes family points anchorPoint anchorValue prepared + root strategy seed + omega + +#print axioms source_common_value_and_cost +#print axioms run_complete_physical_resource + +end Whir.ExtractorArithmeticCostSource diff --git a/verification/whir/Whir/ExtractorArithmeticCostSourcePolynomial.lean b/verification/whir/Whir/ExtractorArithmeticCostSourcePolynomial.lean new file mode 100644 index 000000000..c6a76748b --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostSourcePolynomial.lean @@ -0,0 +1,62 @@ +import Whir.ExtractorArithmeticCostSourceResources + +/-! Polynomial source-extractor arithmetic in actual physical cube length S, row nodes N, padded lanes, original families and points, attempts and reset trials. The Gao term is degree seven in N. Logarithmic dimension is not relabelled as physical length, and the source map's 75 operations remain literal. -/ +namespace Whir.ExtractorArithmeticCostSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck ExtractorArithmeticCost + +set_option maxHeartbeats 4000000 +attribute [local irreducible] ParameterBounds.config + +def physicalSourceFieldPolynomial (paddedLanes occupied cube nodes families points levels attempts rounds folds oods queries tail : Nat) : Nat := + OriginalClaimsChecker.preparationFieldPolynomial cube families points + + attempts * (families + 77 * families * cube + 64 * (2 * families + 77) + + rounds * physicalTrialPolynomial paddedLanes nodes (points + 2) levels folds oods queries tail + + occupied * ConcreteRowExtraction.rowArithmeticPolynomial nodes + checkerPolynomial paddedLanes nodes 0 + + OriginalClaimsChecker.checkFieldPolynomial cube families points) + +theorem totalFieldPolynomial_physical (c : Config) (lanes families points attempts rounds folds oods queries tail : Nat) + (foldBound : c.folds[0]! ≤ c.logN) + (noWrap : c.logN - c.folds[0]! + c.rates[0]! ≤ 64) : + totalFieldPolynomial c lanes families points attempts rounds c.logN folds oods queries tail ≤ + physicalSourceFieldPolynomial (laneCount c) lanes (2 ^ c.logN) (blockLength c) families points c.folds.size + attempts rounds folds oods queries tail := by + have width := denseWidth_le_physical c foldBound + have trial : trialPolynomial (points + 2) c.folds.size c.logN folds oods queries tail ≤ + physicalTrialPolynomial (laneCount c) (blockLength c) (points + 2) c.folds.size folds oods queries tail := by + unfold trialPolynomial verifierPolynomial levelPolynomial physicalTrialPolynomial physicalLevelPolynomial + simp only [Nat.add_assoc, Nat.mul_assoc] at * + gcongr + have common : encoderBound c ≤ checkerPolynomial (laneCount c) (blockLength c) 0 := by + simpa only [checkerBound, Array.size_empty, Nat.zero_mul, Nat.add_zero] using + checkerBound_polynomial (⟨c, lanes, #[], #[]⟩ : Public) noWrap + have transformation : OriginalClaimsChecker.transformationField c families = + families + 77 * families * 2 ^ c.logN + 64 * (2 * families + 77) := by + simp only [OriginalClaimsChecker.transformationField, OriginalClaimsChecker.mapField_eq] + ring + unfold totalFieldPolynomial oneFieldPolynomial physicalSourceFieldPolynomial + rw [transformation] + gcongr + +theorem run_physical_field {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) + (folds oods queries tail : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + (ParameterBounds.config profile).logN folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) : + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).fieldArithmetic ≤ + physicalSourceFieldPolynomial (laneCount (ParameterBounds.config profile)) lanes + (2 ^ (ParameterBounds.config profile).logN) (blockLength (ParameterBounds.config profile)) m points.size + (ParameterBounds.config profile).folds.size attempts rounds folds oods queries tail := by + have arithmetic := run_cost profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed + (ParameterBounds.config profile).logN folds oods queries tail consumer redundancy + exact arithmetic.1.trans (totalFieldPolynomial_physical (ParameterBounds.config profile) lanes m points.size + attempts rounds folds oods queries tail (InitialCandidates.production_initial_facts profile).2.1 + (InitialCandidates.production_initial_facts profile).2.2.1) + +#print axioms run_physical_field + +end Whir.ExtractorArithmeticCostSource diff --git a/verification/whir/Whir/ExtractorArithmeticCostSourceResources.lean b/verification/whir/Whir/ExtractorArithmeticCostSourceResources.lean new file mode 100644 index 000000000..353e1d560 --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostSourceResources.lean @@ -0,0 +1,191 @@ +import Whir.ExtractorArithmeticCostSourceBounds +import Whir.ExtractorArithmeticCostRetained + +/-! Explicit original-source data, loop and oracle-access boundary. The public physical root shape is a literal consumer restriction, not a conclusion of acceptance. The retained-row charge covers real filled-record lookups and materialized lane tables. All potential original-check and preparation reservations bound the actually visited stopping prefix. Prover CPU time and unbounded raw response allocation remain external; every consumed encoded word is explicitly admitted by U. -/ +namespace Whir.ExtractorArithmeticCostSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport PCSRewindExtractor CountedCandidateCheck ExtractorArithmeticCost +open scoped BigOperators + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 4096 +attribute [local irreducible] ParameterBounds.config + +theorem input_weight_sizes {c : Config} {lanes m : Nat} {family : Fin m → RingPCSGame.FamilyClaim} + {points : Array RingPCSGame.PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : OriginalClaimsChecker.Prepared c lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (publicPrefix : RingPCSGame.Prefix) : + ∀ claim ∈ (OriginalClaimsChecker.input prepared root publicPrefix).claims.toList, + claim.weight.size = 2 ^ c.logN := by + intro claim member + rw [OriginalClaimsChecker.input_claims] at member + simp only [RingPCSGame.transformedClaims, Array.toList_push, Array.toList_append, + Array.toList_map, List.mem_append, List.mem_singleton, List.mem_map] at member + rcases member with (compressed | pointed) | anchored + · subst claim + simp [RingPCSGame.familyPublic] + · obtain ⟨point, _, equal⟩ := pointed + subst claim + simp [RingPCSGame.publicPoint] + · subst claim + simp [CommitmentAnchor.weight] + +theorem cube_size (c : Config) (foldBound : c.folds[0]! ≤ c.logN) : + 2 ^ c.logN = laneCount c * width c := by + unfold laneCount width + rw [← Nat.pow_add] + congr 1 + omega + +def retainedCharge {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) : Nat := + retainedPreparation profile rounds lanes root (OriginalClaimsChecker.input prepared root seed.1).claims + (strategy seed.1) seed.2 + +theorem retainedCharge_bound {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.Seed profile rounds) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) : + retainedCharge profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed ≤ + retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes (points.size + 2) := by + have weights := input_weight_sizes prepared root seed.1 + rw [cube_size (ParameterBounds.config profile) (InitialCandidates.production_initial_facts profile).2.1] at weights + have cost := production_retained_preparation profile rounds lanes root + (OriginalClaimsChecker.input prepared root seed.1).claims (strategy seed.1) seed.2 + physicalRoot physicalLanes occupied weights + rw [input_claim_count] at cost + exact cost + +def originalReservation (c : Config) (lanes attempts : Nat) {m : Nat} + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) : Nat := + (OriginalClaimsChecker.countedPrepare c lanes family points anchorPoint anchorValue).2.total + + attempts * ((OriginalClaimsChecker.transformationWork c m points.size).total + + (OriginalClaimsChecker.checkWork c lanes m points.size 0).total) + +def originalReservationPolynomial (c : Config) (families points attempts : Nat) : Nat := + OriginalClaimsChecker.preparationPolynomial (2 ^ c.logN) families points + + attempts * (OriginalClaimsChecker.transformationPolynomial (2 ^ c.logN) families points + + OriginalClaimsChecker.checkPolynomial (2 ^ c.logN) families points) + +theorem transformationWork_total (c : Config) (families points : Nat) : + (OriginalClaimsChecker.transformationWork c families points).total = + OriginalClaimsChecker.transformationPolynomial (2 ^ c.logN) families points := by + simp only [OriginalClaimsChecker.transformationWork, OriginalClaimsChecker.transformationField, + OriginalClaimsChecker.Work.total, OriginalClaimsChecker.mapField_eq] + unfold OriginalClaimsChecker.transformationPolynomial + ring + +theorem originalReservation_bound (c : Config) (lanes attempts : Nat) {m : Nat} + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (foldBound : c.folds[0]! ≤ c.logN) (occupied : lanes ≤ laneCount c) : + originalReservation c lanes attempts family points anchorPoint anchorValue ≤ + originalReservationPolynomial c m points.size attempts := by + have words : lanes * 2 ^ (c.logN - c.folds[0]!) ≤ 2 ^ c.logN := by + rw [cube_size c foldBound] + exact Nat.mul_le_mul_right _ occupied + have check := OriginalClaimsChecker.checkWork_total c lanes m points.size 0 words (Nat.zero_le _) + have prepare := OriginalClaimsChecker.countedPrepare_total c lanes family points anchorPoint anchorValue + unfold originalReservation originalReservationPolynomial + rw [transformationWork_total] + exact Nat.add_le_add prepare (Nat.mul_le_mul_left _ (Nat.add_le_add_left check _)) + +/-- One executable source run plus all admitted encoded replies and a conservative separate reservation for original data/loops. The reservation deliberately includes its field component as well, so the displayed total is an upper accounting unit, not a claim of equality with machine instructions. -/ +theorem run_total_resource {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) + (dimension folds oods queries tail encodedWords : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + dimension folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) + (_physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (_physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (admitted : (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).encodedReplyWords ≤ encodedWords) : + let measured := run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed + measured.fieldArithmetic + measured.responseCalls + measured.encodedReplyWords + + originalReservation (ParameterBounds.config profile) lanes attempts family points anchorPoint anchorValue ≤ + totalFieldPolynomial (ParameterBounds.config profile) lanes m points.size attempts rounds dimension folds oods queries tail + + attempts * ((rounds * streamLength (ParameterBounds.config profile)) * (streamLength (ParameterBounds.config profile) + 1)) + + encodedWords + originalReservationPolynomial (ParameterBounds.config profile) m points.size attempts := by + dsimp only + have arithmetic := run_cost profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed + dimension folds oods queries tail consumer redundancy + have originals := originalReservation_bound (ParameterBounds.config profile) lanes attempts family points anchorPoint anchorValue + (InitialCandidates.production_initial_facts profile).2.1 occupied + omega + +/-- Summed actual source-prefix retained preparations, hence also every actually visited stopping subset. Root and original statement arrays remain immutable, whereas each seed's public compression and causal prover strategy are the actual ones. -/ +theorem all_retained_source_resources {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) : + (∑ i, retainedCharge profile rounds lanes family points anchorPoint anchorValue prepared root strategy (seed i)) ≤ + attempts * retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes (points.size + 2) := by + calc + _ ≤ ∑ _i : Fin attempts, + retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes (points.size + 2) := + Finset.sum_le_sum (fun i _ => retainedCharge_bound profile rounds lanes family points anchorPoint anchorValue + prepared root strategy (seed i) physicalRoot physicalLanes occupied) + _ = _ := by simp + +theorem fixed_output_length {c : Config} {lanes m : Nat} {family : Fin m → RingPCSGame.FamilyClaim} + {points : Array RingPCSGame.PointClaim} {anchorPoint : Array E} {anchorValue : E} + (prepared : OriginalClaimsChecker.Prepared c lanes m family points anchorPoint anchorValue) + (w : Witness c lanes) : + (Array.ofFn w).size = lanes * width c ∧ (Array.ofFn w).size ≤ 2 ^ c.logN := by + have occupied := OriginalClaimsChecker.guarded_occupied_le c lanes family points anchorPoint prepared.guards + constructor + · simp [width] + · simpa [width] using occupied + +theorem run_complete_resource {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seed : PCSRewindSource.RepeatedSeed profile attempts rounds) + (dimension folds oods queries tail encodedWords : Nat) + (consumer : ∀ tape : Tape (ParameterBounds.config profile), + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + dimension folds oods queries tail) + (redundancy : width (ParameterBounds.config profile) < blockLength (ParameterBounds.config profile)) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (occupied : lanes ≤ laneCount (ParameterBounds.config profile)) + (admitted : (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).encodedReplyWords ≤ encodedWords) : + let measured := run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed + measured.fieldArithmetic + measured.responseCalls + measured.encodedReplyWords + + originalReservation (ParameterBounds.config profile) lanes attempts family points anchorPoint anchorValue + + (∑ i, retainedCharge profile rounds lanes family points anchorPoint anchorValue prepared root strategy (seed i)) ≤ + totalFieldPolynomial (ParameterBounds.config profile) lanes m points.size attempts rounds dimension folds oods queries tail + + attempts * ((rounds * streamLength (ParameterBounds.config profile)) * (streamLength (ParameterBounds.config profile) + 1)) + + encodedWords + originalReservationPolynomial (ParameterBounds.config profile) m points.size attempts + + attempts * retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes (points.size + 2) := by + dsimp only + exact Nat.add_le_add + (run_total_resource profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed + dimension folds oods queries tail encodedWords consumer redundancy physicalRoot physicalLanes occupied admitted) + (all_retained_source_resources profile attempts rounds lanes family points anchorPoint anchorValue prepared + root strategy seed physicalRoot physicalLanes occupied) + +#print axioms run_complete_resource + +#print axioms run_total_resource +#print axioms all_retained_source_resources + +end Whir.ExtractorArithmeticCostSource diff --git a/verification/whir/Whir/ExtractorArithmeticCostVerifier.lean b/verification/whir/Whir/ExtractorArithmeticCostVerifier.lean new file mode 100644 index 000000000..ae2e24ae3 --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostVerifier.lean @@ -0,0 +1,235 @@ +import Whir.CountedCandidateCheck + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 4096 + +/-! Arithmetic annotations for the actual checked causal verifier. Charges follow source loop lengths, not acceptance and not a user-provided cost model. Dense source columns use the certified countedColumn upper charge. Rejected trials are charged too. This is a field-operation bound, not machine time. -/ +namespace Whir.ExtractorArithmeticCost +open Concrete Protocol CausalGame CountedCandidateCheck AuthenticatedResetSupport + +/-- FoldPair has two additions and one multiplication; Message.eval has six operations. The output loop has weight.size/2 iterations. -/ +def foldCharge (weight : Array E) : Nat := 3 * (weight.size / 2) + 6 + +def countedSteps {S : Type*} (step : Nat → S → S × Nat) : Nat → Nat → S × Nat → S × Nat + | 0, _, s => s + | count + 1, start, s => + let next := step start s.1 + countedSteps step count (start + 1) (next.1, s.2 + next.2) + +theorem countedSteps_value {S : Type*} (step : Nat → S → S × Nat) + (count start : Nat) (s : S × Nat) : + (countedSteps step count start s).1 = runSteps (fun i v => (step i v).1) count start s.1 := by + induction count generalizing start s with + | zero => rfl + | succ count ih => + simpa [countedSteps, runSteps] using + (ih (start + 1) ((step start s.1).1, s.2 + (step start s.1).2)) + +def countedFoldBlock (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : CheckedState) : CheckedState × Nat := + countedSteps (fun j state => (foldStep block cs p j state, foldCharge state.state.weight)) + cs.folds.size 0 (s, 0) + +@[simp] theorem countedFoldBlock_value (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (s : CheckedState) : (countedFoldBlock block cs p s).1 = foldBlock block cs p s := by + simp [countedFoldBlock, countedSteps_value, foldBlock] + +/-- eqTable's source map body evaluates (1+r), x*(1+r), x*r per old entry. -/ +def tableCharge (point : Array E) : Nat := 3 * (2 ^ point.size - 1) + +def tableStep (out : Array E) (r : E) : Array E × Nat := + ((out.map fun x => x * (1 + r)) ++ (out.map fun x => x * r), 3 * out.size) + +def countedEqTable (point : Array E) : Array E × Nat := loop tableStep point.toList (#[1], 0) + +theorem countedEqTable_value (point : Array E) : (countedEqTable point).1 = eqTable point := by + unfold countedEqTable + rw [loop_value] + unfold eqTable + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + rw [← Array.foldl_toList] + rfl + +private theorem table_loop_cost (xs : List E) (a : Array E) (cost : Nat) : + (loop tableStep xs (a, cost)).2 = cost + 3 * a.size * (2 ^ xs.length - 1) := by + induction xs generalizing a cost with + | nil => simp [loop] + | cons x xs ih => + simp only [loop, tableStep, ih, Array.size_append, Array.size_map, List.length_cons, Nat.pow_succ] + have positive : 0 < 2 ^ xs.length := by positivity + have hsub : 2 ^ xs.length * 2 - 1 = 2 * (2 ^ xs.length - 1) + 1 := by omega + rw [hsub] + ring + +theorem countedEqTable_cost (point : Array E) : (countedEqTable point).2 = tableCharge point := by + simp [countedEqTable, table_loop_cost, tableCharge] + +/-- Each OOD multiplies lambda once, glues two message coefficients and the claim (six operations), and glues every weight entry (two operations). -/ +def countedOodBatch (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) : + (VerifierState E × E) × Nat := + countedSteps (fun j state => + (oodStep cs p j state, tableCharge cs.oodPoints[j]! + 2 * state.1.weight.size + 7)) + p.oods.size 0 ((s, E.one), 0) + +@[simp] theorem countedOodBatch_value (cs : LevelChallenges) (p : LevelProof) (s : VerifierState E) : + (countedOodBatch cs p s).1 = oodBatch cs p s := by + simp [countedOodBatch, countedSteps_value, oodBatch] + +/-- Source column cost certificate, with no inverse treated as unit cost. -/ +def columnCharge (n : Nat) : Nat := 2 * n * n + 131 * n + 3 * 2 ^ n + +theorem actualColumn_charge (n q : Nat) : + (countedColumn n q).1 = column n q ∧ (countedColumn n q).2 ≤ columnCharge n := + ⟨countedColumn_value n q, countedColumn_cost n q⟩ + +/-- Source powers loop: one multiplication per query. inducedColumns executes one multiply and one addition per query per dense output coordinate. enforced builds one eq table and performs dot plus multiply/add for each supplied row. The upper charge uses the actual minimum dot length bound 2^folds.size. -/ +def queryCharge (n : Nat) (cs : LevelChallenges) (p : LevelProof) (qs : Array Nat) + (s : VerifierState E × E) : Nat := + qs.size + qs.size * (columnCharge n + 2 * 2 ^ n) + + tableCharge cs.folds + p.rows.size * (2 * 2 ^ cs.folds.size + 2) + + 2 * s.1.weight.size + 7 + +def countedQueryBatch (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : VerifierState E × E) : VerifierState E × Nat := + (queryBatch n i cs p qs s, queryCharge n cs p qs s) + +@[simp] theorem countedQueryBatch_value (n i : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : VerifierState E × E) : + (countedQueryBatch n i cs p qs s).1 = queryBatch n i cs p qs s := rfl + +/-- Same checked ordering as verifyLevel, including early failures before query batching. Authentication, shape checks and query derivation have zero field arithmetic; their input/loop resources are accounted separately. -/ +def countedVerifyLevel (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (s : CheckedState) : Except String CheckedState × Nat := + let cs := ch.levels[i]! + let p := proof.levels[i]! + if p.afterFold.size != cs.folds.size || p.oods.size != cs.oodPoints.size then + (.error "round/OOD length", 0) + else + let folded := countedFoldBlock (if i == 0 then 2 ^ (c.logN - c.folds[0]!) else 1) cs p s + let boundary : Except String Unit := do + if i + 1 < c.folds.size then + let next ← p.nextOracle.elim (throw "missing commitment") pure + if !oracleValid next (2 ^ (folded.1.n - c.folds[i + 1]! + c.rates[i + 1]!)) + (2 ^ c.folds[i + 1]!) then throw "commitment shape" + else + if p.nextOracle.isSome || proof.residual.size != 2 ^ folded.1.n then throw "final length" + match boundary with + | .error error => (.error error, folded.2) + | .ok _ => + match deriveQueries (folded.1.n + c.rates[i]!) c.queries[i]! cs.querySqueezes with + | none => (.error "query challenges", folded.2) + | some qs => + if p.rows.size != qs.size then (.error "query length", folded.2) + else + match runChecked (authenticateRow folded.1.oracle qs p) qs.size 0 () with + | .error error => (.error error, folded.2) + | .ok _ => + let ood := countedOodBatch cs p folded.1.state + let batched := countedQueryBatch folded.1.n i cs p qs ood.1 + (.ok ⟨folded.1.n, batched.1, p.nextOracle.getD #[]⟩, + folded.2 + ood.2 + batched.2) + +private theorem except_bind_ok {S T : Type u} (s : S) (f : S → Except String T) : + (Except.ok s >>= f) = f s := rfl +private theorem except_bind_error {S T : Type u} (e : String) (f : S → Except String T) : + (Except.error e >>= f) = .error e := rfl +private theorem except_pure {S : Type u} (s : S) : (pure s : Except String S) = .ok s := rfl +private theorem except_throw {S : Type u} (e : String) : (throw e : Except String S) = .error e := rfl +attribute [local simp] except_bind_ok except_bind_error except_pure except_throw + +theorem countedVerifyLevel_value (c : Config) (ch : Challenges) (proof : Opening) + (i : Nat) (s : CheckedState) : + (countedVerifyLevel c ch proof i s).1 = verifyLevel c ch proof i s := by + cases next : proof.levels[i]!.nextOracle <;> + simp only [countedVerifyLevel, verifyLevel, countedFoldBlock_value, + countedOodBatch_value, countedQueryBatch_value, next, Option.elim, + except_pure, except_throw, except_bind_ok, except_bind_error] + all_goals first | rfl | (split <;> try simp_all) + all_goals first | rfl | (split <;> try simp_all) + all_goals first | rfl | (split <;> try simp_all) + all_goals first | rfl | (split <;> try simp_all) + all_goals first | rfl | (split <;> try simp_all) + all_goals first | rfl | (split <;> try simp_all) + all_goals first | rfl | (split <;> try simp_all) + +/-- Checked replay retains the count even when a level rejects. -/ +def countedChecked {S : Type*} (step : Nat → S → Except String S × Nat) : + Nat → Nat → S → Except String S × Nat + | 0, _, s => (.ok s, 0) + | count + 1, start, s => + let next := step start s + match next.1 with + | .error error => (.error error, next.2) + | .ok value => + let tail := countedChecked step count (start + 1) value + (tail.1, next.2 + tail.2) + +theorem countedChecked_value {S : Type*} (step : Nat → S → Except String S × Nat) + (count start : Nat) (s : S) : + (countedChecked step count start s).1 = runChecked (fun i v => (step i v).1) count start s := by + induction count generalizing start s with + | zero => rfl + | succ count ih => + simp only [countedChecked, runChecked] + cases h : (step start s).1 <;> simp [ih] + +def countedCloseTail (ch : Challenges) (proof : Opening) (s : VerifierState E) : + VerifierState E × Nat := + countedSteps (fun j state => (tailStep ch proof j state, foldCharge state.weight)) + ch.tail.size 0 (s, 0) + +@[simp] theorem countedCloseTail_value (ch : Challenges) (proof : Opening) (s : VerifierState E) : + (countedCloseTail ch proof s).1 = closeTail ch proof s := by + simp [countedCloseTail, countedSteps_value, closeTail] + +def countedVerify (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (weight : Array E) (target : E) (proof : Opening) : Except String Unit × Nat := + match initializeVerifier c ch lanes root weight target proof with + | .error error => (.error error, 0) + | .ok initial => + let levels := countedChecked (countedVerifyLevel c ch proof) c.folds.size 0 initial + match levels.1 with + | .error error => (.error error, levels.2) + | .ok final => + let tail := countedCloseTail ch proof final.state + (checkClosing ch proof tail.1, + levels.2 + tail.2 + tableCharge ch.tail + 2 * min proof.residual.size (2 ^ ch.tail.size) + 1) + +theorem countedVerify_value (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (weight : Array E) (target : E) (proof : Opening) : + (countedVerify c ch lanes root weight target proof).1 = verify c ch lanes root weight target proof := by + unfold countedVerify verify replayLevels + simp only [countedChecked_value, countedVerifyLevel_value, countedCloseTail_value] + cases initialized : initializeVerifier c ch lanes root weight target proof with + | error error => simp + | ok initial => + simp only [except_bind_ok] + cases runChecked (verifyLevel c ch proof) c.folds.size 0 initial <;> simp + +/-- batchClaims preserves its dense width even for malformed claim arrays. -/ +def countedBatchClaims (width : Nat) (claims : Array Claim) (lambda : E) : Claim × Nat := + (batchClaims width claims lambda, claims.size * (2 * width + 3)) + +@[simp] theorem countedBatchClaims_value (width : Nat) (claims : Array Claim) (lambda : E) : + (countedBatchClaims width claims lambda).1 = batchClaims width claims lambda := rfl + +def countedAcceptedReplies (input : Public) (tape : Tape input.config) (answers : List Reply) : Bool × Nat := + let c := input.config + let ch := challenges c tape + if !(input.claims.all fun claim => shapeValid c input.lanes claim.weight) then (false, 0) + else + let statement := countedBatchClaims (2 ^ c.logN) input.claims tape.1 + match opening c ch answers.toArray with + | .error _ => (false, statement.2) + | .ok proof => + let checked := countedVerify c ch input.lanes (liftRoot input.root) statement.1.weight statement.1.value proof + (checked.1.isOk, statement.2 + checked.2) + +theorem countedAcceptedReplies_value (input : Public) (tape : Tape input.config) (answers : List Reply) : + (countedAcceptedReplies input tape answers).1 = acceptedReplies input tape answers := by + unfold countedAcceptedReplies acceptedReplies + simp only [countedBatchClaims_value, countedVerify_value] + split <;> simp_all + cases opening input.config (challenges input.config tape) answers.toArray <;> rfl + +end Whir.ExtractorArithmeticCost diff --git a/verification/whir/Whir/ExtractorArithmeticCostVerifierBounds.lean b/verification/whir/Whir/ExtractorArithmeticCostVerifierBounds.lean new file mode 100644 index 000000000..601e85b1f --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostVerifierBounds.lean @@ -0,0 +1,186 @@ +import Whir.ExtractorArithmeticCostVerifier + +namespace Whir.ExtractorArithmeticCost +open Concrete Protocol CausalGame CountedCandidateCheck AuthenticatedResetSupport + +/-- Strict challenge consumer restrictions. These are imposed before running any trial, and apply to rejected as well as accepted replies. Public tapes from production configurations have exactly these finite dimensions. -/ +structure ChallengeInput (c : Config) (ch : Challenges) (dimension folds oods queries tail : Nat) : Prop where + dimensionBound : c.logN ≤ dimension + noWrap : dimension ≤ 64 + foldDimensions : ∀ i < c.folds.size, ch.levels[i]!.folds.size ≤ dimension + foldLoops : ∀ i < c.folds.size, ch.levels[i]!.folds.size ≤ folds + oodLoops : ∀ i < c.folds.size, ch.levels[i]!.oodPoints.size ≤ oods + oodDimensions : ∀ i < c.folds.size, ∀ point ∈ ch.levels[i]!.oodPoints.toList, point.size ≤ dimension + queryLoops : ∀ i < c.folds.size, c.queries[i]! ≤ queries + tailDimension : ch.tail.size ≤ dimension + tailLoops : ch.tail.size ≤ tail + +def StateBound (dimension : Nat) (s : CheckedState) : Prop := + s.n ≤ dimension ∧ s.state.weight.size ≤ 2 ^ dimension + +theorem countedSteps_bound {S : Type*} (step : Nat → S → S × Nat) (P : S → Prop) + (bound : Nat) (preserve : ∀ i s, P s → P (step i s).1) + (charge : ∀ i s, P s → (step i s).2 ≤ bound) + (count start : Nat) (s : S × Nat) (valid : P s.1) : + P (countedSteps step count start s).1 ∧ + (countedSteps step count start s).2 ≤ s.2 + count * bound := by + induction count generalizing start s with + | zero => exact ⟨valid, by simp [countedSteps]⟩ + | succ count ih => + obtain ⟨hp, hc⟩ := ih (start + 1) ((step start s.1).1, s.2 + (step start s.1).2) + (preserve _ _ valid) + refine ⟨hp, ?_⟩ + have hs := charge start s.1 valid + simp only [countedSteps] + simp only [Nat.succ_mul] + omega + +private theorem fold_preserves (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (dimension i : Nat) (s : CheckedState) (h : StateBound dimension s) : + StateBound dimension (foldStep block cs p i s) := by + obtain ⟨hn, hw⟩ := h + dsimp [StateBound, foldStep, VerifierState.fold] + constructor + · omega + · simp only [foldValues] + split <;> simp only [ArrayLayout.size_foldLow, ArrayLayout.size_foldLane] <;> omega + +theorem countedFoldBlock_bound (block : Nat) (cs : LevelChallenges) (p : LevelProof) + (dimension : Nat) (s : CheckedState) (valid : StateBound dimension s) : + StateBound dimension (countedFoldBlock block cs p s).1 ∧ + (countedFoldBlock block cs p s).2 ≤ cs.folds.size * (3 * 2 ^ dimension + 6) := by + have h := countedSteps_bound + (fun j state => (foldStep block cs p j state, foldCharge state.state.weight)) + (StateBound dimension) (3 * 2 ^ dimension + 6) + (fun i s hs => fold_preserves block cs p dimension i s hs) + (by intro i s hs; dsimp [foldCharge]; have hw := hs.2; omega) + cs.folds.size 0 (s, 0) valid + simpa [countedFoldBlock] using h + +private theorem default_point_bound (cs : LevelChallenges) (dimension : Nat) + (points : ∀ point ∈ cs.oodPoints.toList, point.size ≤ dimension) (j : Nat) : + cs.oodPoints[j]!.size ≤ dimension := by + by_cases h : j < cs.oodPoints.size + · apply points + simp only [getElem!_pos, h] + exact Array.getElem_mem_toList h + · rw [getElem!_neg cs.oodPoints j h] + change 0 ≤ dimension + omega + +theorem countedOodBatch_bound (cs : LevelChallenges) (p : LevelProof) + (dimension : Nat) (s : VerifierState E) (weight : s.weight.size ≤ 2 ^ dimension) + (points : ∀ point ∈ cs.oodPoints.toList, point.size ≤ dimension) : + (countedOodBatch cs p s).1.1.weight.size ≤ 2 ^ dimension ∧ + (countedOodBatch cs p s).2 ≤ p.oods.size * (5 * 2 ^ dimension + 7) := by + have h := countedSteps_bound + (fun j state => (oodStep cs p j state, + tableCharge cs.oodPoints[j]! + 2 * state.1.weight.size + 7)) + (fun state : VerifierState E × E => state.1.weight.size ≤ 2 ^ dimension) + (5 * 2 ^ dimension + 7) + (by intro i state hs; simpa [oodStep, VerifierState.batch, ArrayAlgebra.size_weightGlue] using hs) + (by + intro i state hs + dsimp [tableCharge] + have hd := default_point_bound cs dimension points i + have hp : 2 ^ cs.oodPoints[i]!.size ≤ 2 ^ dimension := + Nat.pow_le_pow_right (by decide) hd + omega) + p.oods.size 0 ((s, E.one), 0) weight + simpa [countedOodBatch] using h + +theorem columnCharge_bound (dimension n : Nat) (noWrap : dimension ≤ 64) (hn : n ≤ dimension) : + columnCharge n ≤ 16576 + 3 * 2 ^ dimension := by + have hp : 2 ^ n ≤ 2 ^ dimension := Nat.pow_le_pow_right (by decide) hn + have small : n ≤ 64 := hn.trans noWrap + dsimp [columnCharge] + nlinarith + +private theorem derived_size (depth count : Nat) (squeezes : Array E) (qs : Array Nat) + (success : deriveQueries depth count squeezes = some qs) : qs.size = count := by + unfold deriveQueries at success + split at success <;> simp_all + rw [← success.2] + simp [ArrayLayout.size_tab] + +theorem queryCharge_bound (dimension n : Nat) (cs : LevelChallenges) (p : LevelProof) + (qs : Array Nat) (s : VerifierState E × E) (noWrap : dimension ≤ 64) + (nBound : n ≤ dimension) (folds : cs.folds.size ≤ dimension) + (weight : s.1.weight.size ≤ 2 ^ dimension) (rows : p.rows.size = qs.size) : + queryCharge n cs p qs s ≤ (qs.size + 1) * (16586 + 12 * 2 ^ dimension) := by + have column := columnCharge_bound dimension n noWrap nBound + have hp : 2 ^ n ≤ 2 ^ dimension := Nat.pow_le_pow_right (by decide) nBound + have hf : 2 ^ cs.folds.size ≤ 2 ^ dimension := Nat.pow_le_pow_right (by decide) folds + have induced : qs.size * (columnCharge n + 2 * 2 ^ n) ≤ + qs.size * (16576 + 5 * 2 ^ dimension) := + Nat.mul_le_mul_left _ (by omega) + have enforced : qs.size * (2 * 2 ^ cs.folds.size + 2) ≤ qs.size * (2 * 2 ^ dimension + 2) := + Nat.mul_le_mul_left _ (by omega) + have table : 2 ^ cs.folds.size - 1 ≤ 2 ^ dimension := by omega + dsimp [queryCharge, tableCharge] + rw [rows] + nlinarith + +/-- Explicit per-level polynomial in actual challenge loop dimensions and the dense physical input width. -/ +def levelPolynomial (dimension folds oods queries : Nat) : Nat := + folds * (3 * 2 ^ dimension + 6) + oods * (5 * 2 ^ dimension + 7) + + (queries + 1) * (16586 + 12 * 2 ^ dimension) + +theorem countedVerifyLevel_bound (c : Config) (ch : Challenges) (proof : Opening) + (dimension folds oods queries tail i : Nat) + (input : ChallengeInput c ch dimension folds oods queries tail) + (hi : i < c.folds.size) (s : CheckedState) (valid : StateBound dimension s) : + (∀ after, (countedVerifyLevel c ch proof i s).1 = .ok after → StateBound dimension after) ∧ + (countedVerifyLevel c ch proof i s).2 ≤ levelPolynomial dimension folds oods queries := by + have fold := countedFoldBlock_bound + (if i == 0 then 2 ^ (c.logN - c.folds[0]!) else 1) ch.levels[i]! proof.levels[i]! dimension s valid + have foldCost : (countedFoldBlock + (if i == 0 then 2 ^ (c.logN - c.folds[0]!) else 1) ch.levels[i]! proof.levels[i]! s).2 ≤ + folds * (3 * 2 ^ dimension + 6) := + fold.2.trans (Nat.mul_le_mul_right _ (input.foldLoops i hi)) + unfold countedVerifyLevel + dsimp only + split + · exact ⟨by intro after h; contradiction, Nat.zero_le _⟩ + · rename_i lengths + have equalLengths : proof.levels[i]!.afterFold.size = ch.levels[i]!.folds.size ∧ + proof.levels[i]!.oods.size = ch.levels[i]!.oodPoints.size := by + simpa only [Bool.or_eq_true, bne_iff_ne, not_or, not_not] using lengths + have oodsEqual := equalLengths.2 + split + · exact ⟨by intro after h; contradiction, by unfold levelPolynomial; omega⟩ + · try dsimp only + split + · exact ⟨by intro after h; contradiction, by unfold levelPolynomial; omega⟩ + · rename_i qs derived + have querySize := derived_size _ _ _ qs derived + split + · exact ⟨by intro after h; contradiction, by unfold levelPolynomial; omega⟩ + · rename_i rowSize + have rowSize : proof.levels[i]!.rows.size = qs.size := by simpa using rowSize + split + · exact ⟨by intro after h; contradiction, by unfold levelPolynomial; omega⟩ + · have ood := countedOodBatch_bound ch.levels[i]! proof.levels[i]! dimension + (countedFoldBlock (if i == 0 then 2 ^ (c.logN - c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! s).1.state fold.1.2 (input.oodDimensions i hi) + have oodCost := ood.2.trans (Nat.mul_le_mul_right _ + (oodsEqual.trans_le (input.oodLoops i hi))) + have query := queryCharge_bound dimension _ ch.levels[i]! proof.levels[i]! qs + (countedOodBatch ch.levels[i]! proof.levels[i]! + (countedFoldBlock (if i == 0 then 2 ^ (c.logN - c.folds[0]!) else 1) + ch.levels[i]! proof.levels[i]! s).1.state).1 + input.noWrap fold.1.1 (input.foldDimensions i hi) ood.1 rowSize + have queryCost := query.trans (Nat.mul_le_mul_right _ + (Nat.add_le_add_right (querySize.trans_le (input.queryLoops i hi)) 1)) + constructor + · intro after success + have equal := Except.ok.inj success + subst after + refine ⟨fold.1.1, ?_⟩ + simpa [countedQueryBatch, queryBatch, VerifierState.batch, + ArrayAlgebra.size_weightGlue] using ood.1 + · dsimp [countedQueryBatch] + unfold levelPolynomial + omega + +end Whir.ExtractorArithmeticCost diff --git a/verification/whir/Whir/ExtractorArithmeticCostVerifierTotal.lean b/verification/whir/Whir/ExtractorArithmeticCostVerifierTotal.lean new file mode 100644 index 000000000..06778bd74 --- /dev/null +++ b/verification/whir/Whir/ExtractorArithmeticCostVerifierTotal.lean @@ -0,0 +1,147 @@ +import Whir.ExtractorArithmeticCostVerifierBounds + +namespace Whir.ExtractorArithmeticCost +open Concrete Protocol CausalGame CountedCandidateCheck AuthenticatedResetSupport + +private theorem countedChecked_bound {S : Type*} (step : Nat → S → Except String S × Nat) + (P : S → Prop) (bound count start : Nat) + (valid : ∀ i, start ≤ i → i < start + count → ∀ s, P s → + (∀ after, (step i s).1 = .ok after → P after) ∧ (step i s).2 ≤ bound) + (s : S) (hs : P s) : + (∀ after, (countedChecked step count start s).1 = .ok after → P after) ∧ + (countedChecked step count start s).2 ≤ count * bound := by + induction count generalizing start s with + | zero => + refine ⟨?_, by simp [countedChecked]⟩ + intro after h + have equal : s = after := Except.ok.inj h + simpa [← equal] using hs + | succ count ih => + have current := valid start le_rfl (by omega) s hs + cases h : (step start s).1 with + | error error => + simp only [countedChecked, h] + refine ⟨by intro after h; contradiction, ?_⟩ + rw [Nat.succ_mul] + omega + | ok after => + have tail := ih (start + 1) + (by intro i lower upper s hs; exact valid i (by omega) (by omega) s hs) + after (current.1 after h) + simp only [countedChecked, h] + refine ⟨tail.1, ?_⟩ + rw [Nat.succ_mul] + omega + +def verifierPolynomial (levels dimension folds oods queries tail : Nat) : Nat := + levels * levelPolynomial dimension folds oods queries + + tail * (3 * 2 ^ dimension + 6) + 5 * 2 ^ dimension + 1 + +theorem countedVerify_bound (c : Config) (ch : Challenges) (lanes : Nat) (root : Oracle) + (weight : Array E) (target : E) (proof : Opening) + (dimension folds oods queries tail : Nat) + (input : ChallengeInput c ch dimension folds oods queries tail) + (weightBound : weight.size ≤ 2 ^ dimension) : + (countedVerify c ch lanes root weight target proof).2 ≤ + verifierPolynomial c.folds.size dimension folds oods queries tail := by + unfold countedVerify + cases initialized : initializeVerifier c ch lanes root weight target proof with + | error error => exact Nat.zero_le _ + | ok initial => + have initialBound : StateBound dimension initial := by + have shape := (CausalExecution.initialize_success _ _ _ _ _ _ _ _ initialized).2.2 + rw [shape] + exact ⟨input.dimensionBound, weightBound⟩ + have levels := countedChecked_bound (countedVerifyLevel c ch proof) (StateBound dimension) + (levelPolynomial dimension folds oods queries) c.folds.size 0 + (by + intro i _ hi state valid + exact countedVerifyLevel_bound c ch proof + dimension folds oods queries tail i input (by omega) state valid) + initial initialBound + cases replayed : (countedChecked (countedVerifyLevel c ch proof) c.folds.size 0 initial).1 with + | error error => + dsimp only + simp only [replayed] + unfold verifierPolynomial + omega + | ok final => + have finalBound := levels.1 final replayed + have close := countedSteps_bound + (fun j state => (tailStep ch proof j state, foldCharge state.weight)) + (fun state : VerifierState E => state.weight.size ≤ 2 ^ dimension) + (3 * 2 ^ dimension + 6) + (by + intro j state valid + dsimp [tailStep, VerifierState.fold] + simp only [foldValues] + split <;> simp only [ArrayLayout.size_foldLow, ArrayLayout.size_foldLane] <;> omega) + (by intro j state valid; dsimp [foldCharge]; omega) + ch.tail.size 0 (final.state, 0) finalBound.2 + have tailCost : (countedCloseTail ch proof final.state).2 ≤ + tail * (3 * 2 ^ dimension + 6) := by + have localCost : (countedCloseTail ch proof final.state).2 ≤ + ch.tail.size * (3 * 2 ^ dimension + 6) := by + simpa [countedCloseTail] using close.2 + exact localCost.trans (Nat.mul_le_mul_right _ input.tailLoops) + have tableBound : 2 ^ ch.tail.size ≤ 2 ^ dimension := + Nat.pow_le_pow_right (by decide) input.tailDimension + have dotBound : min proof.residual.size (2 ^ ch.tail.size) ≤ 2 ^ dimension := + (Nat.min_le_right _ _).trans tableBound + dsimp only + simp only [replayed] + unfold verifierPolynomial tableCharge + omega + +private theorem batch_weight (width : Nat) (claims : Array Claim) (lambda : E) : + (batchClaims width claims lambda).weight.size = width := by + unfold batchClaims + simp only [Array.forIn_pure_yield_eq_foldl, pure_bind] + rw [← Array.foldl_toList] + have h : ∀ (xs : List Claim) (s : Claim × E), + (xs.foldl (fun state claim => + (⟨weightGlue state.1.weight claim.weight state.2, + state.1.value + state.2 * claim.value⟩, state.2 * lambda)) s).1.weight.size = + s.1.weight.size := by + intro xs + induction xs with + | nil => intro s; rfl + | cons x xs ih => + intro s + simpa [List.foldl_cons, ArrayAlgebra.size_weightGlue] using + (ih (⟨weightGlue s.1.weight x.weight s.2, s.1.value + s.2 * x.value⟩, s.2 * lambda)) + simpa [ArrayLayout.size_tab] using + (h claims.toList (⟨tab width fun _ => E.zero, E.zero⟩, E.one)) + +def trialPolynomial (claims levels dimension folds oods queries tail : Nat) : Nat := + claims * (2 * 2 ^ dimension + 3) + + verifierPolynomial levels dimension folds oods queries tail + +theorem countedAcceptedReplies_bound (input : Public) (tape : Tape input.config) + (answers : List Reply) (dimension folds oods queries tail : Nat) + (consumer : ChallengeInput input.config (challenges input.config tape) + dimension folds oods queries tail) : + (countedAcceptedReplies input tape answers).2 ≤ + trialPolynomial input.claims.size input.config.folds.size dimension folds oods queries tail := by + have widthBound : 2 ^ input.config.logN ≤ 2 ^ dimension := + Nat.pow_le_pow_right (by decide) consumer.dimensionBound + unfold countedAcceptedReplies + dsimp only + split + · exact Nat.zero_le _ + · try dsimp only + cases parsed : opening input.config (challenges input.config tape) answers.toArray with + | error error => + dsimp [countedBatchClaims] + unfold trialPolynomial + nlinarith + | ok proof => + have verified := countedVerify_bound input.config (challenges input.config tape) input.lanes + (liftRoot input.root) (batchClaims (2 ^ input.config.logN) input.claims tape.1).weight + (batchClaims (2 ^ input.config.logN) input.claims tape.1).value proof + dimension folds oods queries tail consumer (by rw [batch_weight]; exact widthBound) + dsimp [countedBatchClaims] + unfold trialPolynomial + nlinarith + +end Whir.ExtractorArithmeticCost diff --git a/verification/whir/Whir/FiatShamirGame.lean b/verification/whir/Whir/FiatShamirGame.lean index b19c51def..084421052 100644 --- a/verification/whir/Whir/FiatShamirGame.lean +++ b/verification/whir/Whir/FiatShamirGame.lean @@ -468,9 +468,13 @@ theorem mode_transfer {Coins View : Type*} [Fintype Coins] (G : ModeGame Coins V have h := (abs_le.mp (secure D permitted)).2 linarith -/-- DMV's advertised compression-model loss; applicability requires the -subtree-free/radical-decodable/message-decodable mode proof, kept separate. -/ -def dmvLoss (Q : Nat) : ℚ := min 1 ((Q.choose 2 : ℚ) / (2 ^ 256 : ℚ)) +/-- Sharp birthday subevent budget, not the whole-view duplex loss. -/ +def compressionBirthdayLoss (Q : Nat) : ℚ := min 1 ((Q.choose 2 : ℚ) / (2 ^ 256 : ℚ)) + +/-- Actual adaptive whole-view duplex budget: output collisions, public late +links, and guesses of unrevealed construction states share one Counts Q cap. -/ +def duplexModeLoss (Q : Nat) : ℚ := + min 1 ((2 * (Q.choose 2 : ℚ) + (Q : ℚ) * Q) / (2 ^ 256 : ℚ)) /-! Remaining instantiation obligations (not axioms): diff --git a/verification/whir/Whir/InitialKnowledgeSchedule.lean b/verification/whir/Whir/InitialKnowledgeSchedule.lean new file mode 100644 index 000000000..a5c5f46d3 --- /dev/null +++ b/verification/whir/Whir/InitialKnowledgeSchedule.lean @@ -0,0 +1,314 @@ +import Whir.SupportedCandidateClaims +import Whir.SupportedCandidateMCA +import Whir.CausalFolds + +/-! SAME-target backward induction over the actual causal fold kernels. The +fresh-scalar guards concern incoming prefixes, never future acceptance. -/ +namespace Whir.InitialKnowledgeSchedule +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open CandidateFolding SupportedCandidateExtraction ParameterBounds + +set_option maxRecDepth 100000 +set_option maxHeartbeats 400000 +attribute [local irreducible] ParameterBounds.config + +noncomputable def paired (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) := + OracleReplay.pairedOracle (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy t i).oracle (challenges input.config t).levels[i.val]!.folds + j.val j.isLt (N := 2 ^ (remaining input.config i + input.config.rates[i.val]!)) + +noncomputable def RawMCA (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) + (t : Tape input.config) : Prop := + MutualAgreement.RowBad MutualAgreement.foldGenerator + (LinearMap.range (concreteEncoder (remaining input.config i) input.config.rates[i.val]!)) + (threshold input.config i) + ![fun lane => paired input strategy t i j (evenLane lane), + fun lane => paired input strategy t i j (oddLane lane)] + (challenges input.config t).levels[i.val]!.folds[j.val]! + +noncomputable def ClaimEscape (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) + (t : Tape input.config) : Prop := + (challenges input.config t).levels[i.val]!.folds[j.val]! ∈ + candidateRoundEscape (foldCandidates input strategy t i j) + (foldAt input strategy t i j).state (block input.config i) + +/-- Chronological coefficient folds, with the verifier's actual physical block. +The compact prover messages are not coefficient tables and do not occur here. -/ +def foldFrom (input : Public) (t : Tape input.config) (i start count : Nat) + (a : Array E) : Array E := + (List.range count).foldl (fun a j => foldValues a (block input.config i) + (challenges input.config t).levels[i]!.folds[start+j]!) a + +@[simp] theorem foldFrom_zero (input : Public) (t : Tape input.config) (i start : Nat) + (a : Array E) : foldFrom input t i start 0 a = a := rfl + +theorem foldFrom_succ (input : Public) (t : Tape input.config) (i start count : Nat) + (a : Array E) : foldFrom input t i start (count+1) a = + foldFrom input t i (start+1) count + (foldValues a (block input.config i) + (challenges input.config t).levels[i]!.folds[start]!) := by + unfold foldFrom + rw [List.range_succ_eq_map, List.foldl_cons, List.foldl_map] + congr 1 + funext a j + congr 2 + omega + +/-- The SAME chosen final candidate inherits every actual incoming claim. This +is an actual trajectory theorem; no abstract safe-schedule premise is supplied. -/ +theorem same_target_lifts (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (i : Fin (config p).folds.size) (start count : Nat) + (bound : start + count ≤ (config p).folds[i.val]!) + (mca : ∀ j : Fin (config p).folds[i.val]!, start ≤ j.val → j.val < start+count → + ¬ RawMCA (Input p lanes root claims) strategy i j t) + (guard : ∀ j : Fin (config p).folds[i.val]!, start ≤ j.val → j.val < start+count → + ¬ ClaimEscape (Input p lanes root claims) strategy i j t) + (target : Array E) + (member : target ∈ foldCandidates (Input p lanes root claims) strategy t i (start+count)) + (truth : dot target (foldAt (Input p lanes root claims) strategy t i (start+count)).state.weight = + (foldAt (Input p lanes root claims) strategy t i (start+count)).state.claim) : + ∃ original ∈ foldCandidates (Input p lanes root claims) strategy t i start, + foldFrom (Input p lanes root claims) t i start count original = target ∧ + dot original (foldAt (Input p lanes root claims) strategy t i start).state.weight = + (foldAt (Input p lanes root claims) strategy t i start).state.claim := by + induction count generalizing start with + | zero => exact ⟨target, member, rfl, truth⟩ + | succ count ih => + let input := Input p lanes root claims + let j : Fin (config p).folds[i.val]! := ⟨start, by omega⟩ + obtain ⟨middle, hm, he, ht⟩ := ih (start+1) (by omega) + (by intro j hj hk; exact mca j (by omega) (by omega)) + (by intro j hj hk; exact guard j (by omega) (by omega)) + (by simpa only [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using member) + (by simpa only [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using truth) + have nextMember : middle ∈ arrayCandidates (i.val == 0) + (concreteEncoder (remaining input.config i) input.config.rates[i.val]!) + (foldOracle (paired input strategy t i j) + (challenges input.config t).levels[i.val]!.folds[start]!) + (threshold input.config i) := by + unfold foldCandidates at hm + rw [OracleReplay.oracleAt_succ _ _ _ _ start j.isLt] at hm + exact hm + obtain ⟨original, ho, hf⟩ := array_lifts (i.val == 0) _ _ rfl _ _ _ + (mca j le_rfl (by change start < start+(count+1); omega)) middle nextMember + have pairedEq := OracleReplay.paired_candidates (i.val == 0) input.config.folds[i.val]! + (remaining input.config i) input.config.rates[i.val]! start (threshold input.config i) + (levelAt input strategy t i).oracle (challenges input.config t).levels[i.val]!.folds j.isLt + have originalMember : original ∈ foldCandidates input strategy t i start := by + change original ∈ arrayCandidates (i.val == 0) + (concreteEncoder (remaining input.config i) input.config.rates[i.val]!) + (OracleReplay.pairedOracle (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy t i).oracle (challenges input.config t).levels[i.val]!.folds + start j.isLt) (threshold input.config i) at ho + rw [pairedEq] at ho + exact ho + change middle = foldValues original + (CandidateFolding.foldBlock (i.val == 0) (dimension input.config i)) + (challenges input.config t).levels[i.val]!.folds[start]! at hf + refine ⟨original, originalMember, ?_, ?_⟩ + · rw [foldFrom_succ, CausalFolds.block_eq, ← hf] + exact he + · have shape := OracleReplay.candidate_round_shape (i.val == 0) input.config.folds[i.val]! + (remaining input.config i) input.config.rates[i.val]! start (threshold input.config i) + (levelAt input strategy t i).oracle (challenges input.config t).levels[i.val]!.folds + j.isLt original ho + apply backward_claim _ (foldAt input strategy t i start).state + (CandidateFolding.foldBlock (i.val == 0) (dimension input.config i)) + (if i.val == 0 then 2 ^ (input.config.folds[i.val]! - (start+1)) + else 2 ^ (input.config.folds[i.val]! - (start+1)) * 2 ^ remaining input.config i) + (challenges input.config t).levels[i.val]!.folds[start]! + (proof input strategy t).levels[i.val]!.afterFold[start]! + original originalMember shape + (candidate_weight_size p lanes root claims strategy t i start (by omega) original originalMember) + (by simpa only [ClaimEscape, CausalFolds.block_eq, j] using + guard j le_rfl (by change start < start+(count+1); omega)) + rw [← hf] + simpa only [foldAt_succ, foldStep, CausalFolds.block_eq] using ht + +/-- Both raw knowledge exclusions are incoming-prefix measurable. -/ +theorem paired_set (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) + (q : Coordinate input.config) (x : Sample q) + (before : levelStart (challenges input.config t) i.val+j.val ≤ position q) : + paired input strategy (set q t x) i j = paired input strategy t i j := + CausalFolds.pairedOracle_set input strategy i j q t x before + +theorem knowledgeEvents_set_future (input : Public) (strategy : Strategy) + (t : Tape input.config) (i : Fin input.config.folds.size) + (j : Fin input.config.folds[i.val]!) (q : Coordinate input.config) (x : Sample q) + (before : levelStart (challenges input.config t) i.val+j.val+1 ≤ position q) : + (RawMCA input strategy i j (set q t x) ↔ RawMCA input strategy i j t) ∧ + (ClaimEscape input strategy i j (set q t x) ↔ ClaimEscape input strategy i j t) := by + have scalar : (challenges input.config (set q t x)).levels[i.val]!.folds[j.val]! = + (challenges input.config t).levels[i.val]!.folds[j.val]! := by + rw [CausalStateCausality.challenge_fold, CausalStateCausality.challenge_fold] + apply get_set_ne + intro same + have hp := congrArg position same + rw [CausalPositions.position_fold i j t] at hp + omega + constructor + · unfold RawMCA + rw [paired_set input strategy t i j q x (by omega), scalar] + · unfold ClaimEscape + rw [scalar, + CausalStateCausality.foldCandidates_set input strategy q t x i j.val j.isLt.le (by omega), + CausalStateCausality.foldAt_set input strategy q t x i j.val j.isLt.le (by omega)] + +open Classical in +theorem rawMCA_fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) : + Soundness.uniformProb (Finset.univ.filter fun r : E => + RawMCA (Input p lanes root claims) strategy i j (set (.fold i j) t r)) ≤ + (2 ^ 108 : ℚ) / 2 ^ 192 := by + let input := Input p lanes root claims + have event : (Finset.univ.filter fun r : E => + RawMCA input strategy i j (set (.fold i j) t r)) = + mcaSeeds p i (paired input strategy t i j) := by + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and, RawMCA, mcaSeeds, + paired_set input strategy t i j (.fold i j) r + (CausalPositions.position_fold i j t).symm.le, + CausalStateCausality.challenge_fold, get_set] + rfl + rw [event] + exact mcaSeeds_probability p i _ + +open Classical in +theorem claimEscape_fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) : + Soundness.uniformProb (Finset.univ.filter fun r : E => + ClaimEscape (Input p lanes root claims) strategy i j (set (.fold i j) t r)) ≤ + (2 ^ 33 : ℚ) / 2 ^ 192 := by + let input := Input p lanes root claims + have before := (CausalPositions.position_fold i j t).symm.le + have events : (Finset.univ.filter fun r : E => + ClaimEscape input strategy i j (set (.fold i j) t r)) = + candidateRoundEscape (foldCandidates input strategy t i j) + (foldAt input strategy t i j).state (block input.config i) := by + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and, ClaimEscape, + CausalStateCausality.challenge_fold, get_set, + CausalStateCausality.foldCandidates_set input strategy (.fold i j) t r i j.val j.isLt.le before, + CausalStateCausality.foldAt_set input strategy (.fold i j) t r i j.val j.isLt.le before] + rw [events] + have bound := candidateRoundEscape_probability (foldCandidates input strategy t i j) + (foldAt input strategy t i j).state (block input.config i) + have cap : ((foldCandidates input strategy t i j).card : ℚ) ≤ 2 ^ 32 := by + exact_mod_cast ConcreteCandidates.production_arrayCandidates_card (i.val == 0) p i + (OracleReplay.oracleAt (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy t i).oracle (challenges input.config t).levels[i.val]!.folds j.val) + rw [FieldModel.card_E] at bound + simp only [Nat.cast_pow, Nat.cast_ofNat] at bound + calc + _ ≤ (2 ^ 32 : ℚ) * (2 / 2 ^ 192) := + bound.trans (mul_le_mul_of_nonneg_right cap (by positivity)) + _ = _ := by norm_num + +open Classical in +theorem rawMCA_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) + (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) : + Soundness.uniformProb (Finset.univ.filter (RawMCA (Input p lanes root claims) strategy i j)) ≤ + (2 ^ 108 : ℚ) / 2 ^ 192 := by + apply fiber_event_bound (.fold i j) + intro rest + exact rawMCA_fiber_bound p lanes root claims strategy rest.val i j + +open Classical in +theorem claimEscape_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) + (i : Fin (config p).folds.size) (j : Fin (config p).folds[i.val]!) : + Soundness.uniformProb (Finset.univ.filter (ClaimEscape (Input p lanes root claims) strategy i j)) ≤ + (2 ^ 33 : ℚ) / 2 ^ 192 := by + apply fiber_event_bound (.fold i j) + intro rest + exact claimEscape_fiber_bound p lanes root claims strategy rest.val i j + +/-- All 56 profiles use the physical six-fold initial ladder. -/ +theorem production_initial_six : ∀ p : Profile, (config p).folds[0]! = 6 := by + decide +kernel + +open Classical in +noncomputable def InitialFoldBad (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) : Prop := + ∃ j : Fin (config p).folds[0]!, + RawMCA (Input p lanes root claims) strategy ⟨0, (production_config_valid p).2.1⟩ j t ∨ + ClaimEscape (Input p lanes root claims) strategy ⟨0, (production_config_valid p).2.1⟩ j t + +open scoped BigOperators in +open Classical in +theorem uniform_or_family_bound {Ω I : Type*} [Fintype Ω] [Fintype I] + (event : Ω → Prop) (P Q : I → Ω → Prop) + [DecidablePred event] [∀ i, DecidablePred (P i)] [∀ i, DecidablePred (Q i)] + (cover : ∀ t, event t ↔ ∃ i, P i t ∨ Q i t) (ep eq : ℚ) + (hp : ∀ i, Soundness.uniformProb (Finset.univ.filter (P i)) ≤ ep) + (hq : ∀ i, Soundness.uniformProb (Finset.univ.filter (Q i)) ≤ eq) : + Soundness.uniformProb (Finset.univ.filter event) ≤ + (Fintype.card I : ℚ) * (ep+eq) := by + let events (j : I × Bool) : Finset Ω := + Finset.univ.filter fun t => if j.2 then P j.1 t else Q j.1 t + let errors (j : I × Bool) : ℚ := if j.2 then ep else eq + have equality : Finset.univ.filter event = + Finset.univ.biUnion events := by + ext t + simp [events, cover, exists_or, or_comm] + rw [equality] + calc + _ ≤ ∑ j, Soundness.uniformProb (events j) := Soundness.union_bound events + _ ≤ ∑ j, errors j := by + apply Finset.sum_le_sum + rintro ⟨j, b⟩ _ + cases b + · exact hq j + · exact hp j + _ = _ := by + rw [Fintype.sum_prod_type] + simp [errors, mul_add] + +open Classical in +theorem uniform_or_bound {Ω : Type*} [Fintype Ω] (P Q : Ω → Prop) + [DecidablePred P] [DecidablePred Q] (ep eq : ℚ) + (hp : Soundness.uniformProb (Finset.univ.filter P) ≤ ep) + (hq : Soundness.uniformProb (Finset.univ.filter Q) ≤ eq) : + Soundness.uniformProb (Finset.univ.filter fun t => P t ∨ Q t) ≤ ep+eq := by + have bound := uniform_or_family_bound (fun t => P t ∨ Q t) + (fun _ : Unit => P) (fun _ : Unit => Q) (by intro t; simp) + ep eq (fun _ => hp) (fun _ => hq) + simpa using bound + +open scoped BigOperators in +open Classical in +theorem initialFoldBad_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) : + Soundness.uniformProb (Finset.univ.filter (InitialFoldBad p lanes root claims strategy)) ≤ + 6 * ((2 ^ 108 : ℚ) / 2 ^ 192 + 2 ^ 33 / 2 ^ 192) := by + have bound := @uniform_or_family_bound (Tape (config p)) (Fin (config p).folds[0]!) + inferInstance inferInstance + (InitialFoldBad p lanes root claims strategy) + (fun j t => RawMCA (Input p lanes root claims) strategy + ⟨0, (production_config_valid p).2.1⟩ j t) + (fun j t => ClaimEscape (Input p lanes root claims) strategy + ⟨0, (production_config_valid p).2.1⟩ j t) + inferInstance inferInstance inferInstance + (fun _ => Iff.rfl) + ((2 ^ 108 : ℚ) / 2 ^ 192) ((2 ^ 33 : ℚ) / 2 ^ 192) + (fun j => rawMCA_probability p lanes root claims strategy ⟨0, (production_config_valid p).2.1⟩ j) + (fun j => claimEscape_probability p lanes root claims strategy ⟨0, (production_config_valid p).2.1⟩ j) + rw [Fintype.card_fin] at bound + calc + _ ≤ ((config p).folds[0]! : ℚ) * + ((2 ^ 108 : ℚ) / 2 ^ 192 + 2 ^ 33 / 2 ^ 192) := bound + _ = 6 * ((2 ^ 108 : ℚ) / 2 ^ 192 + 2 ^ 33 / 2 ^ 192) := + congrArg (fun n : Nat => (n : ℚ) * ((2 ^ 108 : ℚ) / 2 ^ 192 + 2 ^ 33 / 2 ^ 192)) + (production_initial_six p) + +#print axioms same_target_lifts +#print axioms initialFoldBad_probability +end Whir.InitialKnowledgeSchedule diff --git a/verification/whir/Whir/KnowledgeExtraction.lean b/verification/whir/Whir/KnowledgeExtraction.lean index 48a192cc3..a64da5cb1 100644 --- a/verification/whir/Whir/KnowledgeExtraction.lean +++ b/verification/whir/Whir/KnowledgeExtraction.lean @@ -1,17 +1,14 @@ import Whir.InteractiveSoundness import Mathlib.LinearAlgebra.Lagrange +import Whir.ConcreteRowExtraction -/-! Knowledge games and the information required by record interpolation. +/-! Knowledge games, actual unique-radius row decoding, and the information required by record interpolation. -The rewind interface below counts black-box response calls exactly. Its fuel is -an abstract interaction bound, NOT a proof of machine running time: Lean -continuations, output construction, and the prover itself are not unit-cost. -No knowledge-soundness theorem or efficient list decoder is asserted. +The rewind interface counts black-box response calls exactly. Its fuel is an abstract interaction bound, not a proof of machine running time: Lean continuations, output construction, and the prover itself are not unit-cost. `ConcreteRowExtraction` supplies executable Gao decoding with a concrete dense-encoder correspondence. It requires a full received row inside the unique radius and does not establish that verifier acceptance supplies such a row. No knowledge-soundness theorem is asserted. -The checked obstruction concerns *record-only* interpolation. The dense causal -game exposes the entire root; a hashed commitment or an authenticated query log -would need a separate reduction to this observation model. In particular these -results do not assert impossibility of rewindable knowledge extraction. -/ +The extraction integration is split by access and algebra: `RewindRowExtraction` parses real fixed-public reset answers and composes the source decoder/counter; `PCSRewindExtraction` assembles the occupied witness and states the actual accepted-without-explaining-output cover. `RewindCoverage` proves stratified query-coordinate coverage, not availability of valid replies from an adversarial prover. `RewindTrajectory`, `RewindBatchTarget` and `RewindRadiusExtraction` track generic-E next-root candidates and the OOD-selected fixed projection target, with actual authentication and an explicit nonzero batching-collision event. `TraceBasisExtraction`, `ShoupTraceExtraction` and `PCSListExtraction` provide a non-enumerating source-extension list-decoder path. These pieces do not supply a Fiat–Shamir reset reduction, a common-lane reconstruction theorem for every accepted prefix, or a complete knowledge-error bound. + +The checked obstruction concerns record-only interpolation. The dense causal game exposes the entire root; a hashed commitment or an authenticated query log needs a separate access reduction. These results do not assert impossibility of rewindable knowledge extraction. -/ namespace Whir.KnowledgeExtraction open Concrete Protocol CausalGame Polynomial open scoped BigOperators @@ -83,21 +80,13 @@ theorem responseCalls_le (input : Public) (strategy : Strategy) (maxReplay fuel · simp /-- Extraction randomness is independent of the verifier tape. Bounds count -rewind rounds and replay messages; local runtime is a separate cost-model input, -not a self-reported field that an extractor could set to zero. -/ +rewind rounds and replay messages; value-connected local arithmetic is measured +separately by the concrete extractor instrumentation. -/ structure Extractor (Seed : Type*) where program : (input : Public) → Seed → RewindProgram input.config input.lanes rewindRounds : Nat maxReplay : Nat -/-- An externally supplied operational cost model. No theorem in this module -certifies that this function measures the machine runtime of Lean code. That -refinement is REQUIRED before interpreting `runtimeBound` as efficient time. -/ -abbrev LocalCostModel (Seed : Type*) := Extractor Seed → Public → Strategy → Seed → Nat - -def Extractor.WithinRuntime {Seed : Type*} (extractor : Extractor Seed) - (cost : LocalCostModel Seed) (runtimeBound : Nat) : Prop := - ∀ input strategy seed, cost extractor input strategy seed ≤ runtimeBound def extractionSuccess {Seed : Type*} (extractor : Extractor Seed) (prover : CommittedProver) (seed : Seed) : Prop := @@ -113,14 +102,6 @@ noncomputable def knowledgeFailureProbability {Seed : Type*} [Fintype Seed] [Non experiment prover.input prover.respond sample.1 = true ∧ ¬ extractionSuccess extractor prover sample.2) -/-- Explicit finite-instance knowledge requirement. This definition does not -assert a uniform polynomial-time family: that requires an implemented extractor -and a justified machine-cost bound in addition to the response-call bound. -/ -def KnowledgeBound {Seed : Type*} [Fintype Seed] [Nonempty Seed] - (extractor : Extractor Seed) (cost : LocalCostModel Seed) (runtimeBound : Nat) - (error : Public → ℚ) : Prop := - extractor.WithinRuntime cost runtimeBound ∧ ∀ prover, - knowledgeFailureProbability extractor prover ≤ error prover.input section Records variable {F I : Type*} [Field F] [CharP F 2] @@ -321,4 +302,14 @@ theorem accepted_safe_explanation (p : ParameterBounds.Profile) (lanes : Nat) p lanes root claims strategy tape accepted noWitness exact safe q bad +#print axioms responseCalls_le +#print axioms records_determine_row +#print axioms sparse_records_have_kernel +#print axioms no_sparse_record_decoder +#print axioms actual_records_determine_row +#print axioms actual_sparse_rows +#print axioms actual_no_sparse_decoder +#print axioms production_no_sparse_decoder +#print axioms accepted_safe_explanation + end Whir.KnowledgeExtraction diff --git a/verification/whir/Whir/PCSRewindExtraction.lean b/verification/whir/Whir/PCSRewindExtraction.lean new file mode 100644 index 000000000..9288a9c57 --- /dev/null +++ b/verification/whir/Whir/PCSRewindExtraction.lean @@ -0,0 +1,178 @@ +import Whir.RewindRowExtraction +import Whir.RewindCoverage +import Whir.UniqueRadiusSampling + +/-! Fixed-public, occupied-lane extraction using only replayed query replies. The root in the ideal public type is never read by this algorithm. Reset availability, authenticated response availability, and an initial common-lane unique radius are distinct access/proximity obligations. The existing interactive list-loss theorem supplies existence of an explaining list member, not this stronger radius. -/ +namespace Whir.PCSRewindExtraction +open Concrete Protocol CausalGame CausalProbability KnowledgeExtraction RewindRowExtraction +set_option maxHeartbeats 800000 + +abbrev rowWidth (input : Public) := 2 ^ (input.config.logN - input.config.folds[0]!) + +def witnessLane (input : Public) (w : Witness input.config input.lanes) + (lane : Fin input.lanes) : Array K := + Array.ofFn fun j : Fin (rowWidth input) => w ⟨lane.val * rowWidth input + j.val, by + have positive : 0 < rowWidth input := by unfold rowWidth; positivity + have bound := lane.isLt + have jb := j.isLt + have scaled := Nat.mul_le_mul_right (rowWidth input) (Nat.succ_le_of_lt bound) + nlinarith⟩ + +/-- Assembly fails on missing or wrongly sized decoded lanes. No padded or invented witness coefficients are emitted. -/ +def assembleWitness (input : Public) (results : Fin input.lanes → Option (Array K)) : + Option (Witness input.config input.lanes) := + if complete : ∀ lane, (results lane).isSome = true ∧ + (results lane).map Array.size = some (rowWidth input) then + some fun j => + let lane : Fin input.lanes := ⟨j.val / rowWidth input, by + have positive : 0 < rowWidth input := by unfold rowWidth; positivity + exact (Nat.div_lt_iff_lt_mul positive).mpr j.isLt⟩ + ((results lane).get (complete lane).1)[j.val % rowWidth input]! + else none + +theorem assembleWitness_recovers (input : Public) (w : Witness input.config input.lanes) + (results : Fin input.lanes → Option (Array K)) + (correct : ∀ lane, results lane = some (witnessLane input w lane)) : + assembleWitness input results = some w := by + have complete : ∀ lane, (results lane).isSome = true ∧ + (results lane).map Array.size = some (rowWidth input) := by + intro lane + simp [correct lane, witnessLane] + simp only [assembleWitness, dite_eq_left complete] + congr 1 + funext j + have positive : 0 < rowWidth input := by unfold rowWidth; positivity + simp [correct, witnessLane, getElem!_pos, Nat.mod_lt _ positive, + Nat.div_add_mod'] + +def decodeWitness (input : Public) (requests : List QueryRequest) (answers : List Reply) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + Option (Witness input.config input.lanes) := + let decoded := Array.ofFn fun lane : Fin input.lanes => + extractReplies (input.config.logN - input.config.folds[0]!) + input.config.rates[0]! noWrap input.config.queries[0]! + (input.lanes - 1 - lane.val) requests answers + assembleWitness input fun lane => decoded[lane.val]'(by + simpa only [decoded, Array.size_ofFn] using lane.isLt) + +/-- Every occupied lane is decoded from the same collected replies. Leaf lanes are reversed exactly as in the verifier's initial lane layout. -/ +def extractWitness (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (_initialLevel : level.val = 0) (rounds : Nat) + (seed : Fin rounds → Sample (.query level)) + (noWrap : prover.input.config.logN - prover.input.config.folds[0]! + + prover.input.config.rates[0]! ≤ 64) : Option (Witness prover.input.config prover.input.lanes) := + let requests := List.ofFn fun round => resetRequest prover.input level (seed round) + let answers := (collectResets prover tape level rounds seed).replies + decodeWitness prover.input requests answers noWrap + +/-- The implemented whole occupied-witness extractor composes the supported-row decoder outputs. This interface exposes the exact missing common-lane recovery obligation rather than assuming PCS soundness. -/ +theorem extractWitness_recovers (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (initialLevel : level.val = 0) (rounds : Nat) + (seed : Fin rounds → Sample (.query level)) + (noWrap : prover.input.config.logN - prover.input.config.folds[0]! + + prover.input.config.rates[0]! ≤ 64) + (w : Witness prover.input.config prover.input.lanes) + (lanesRecovered : ∀ lane : Fin prover.input.lanes, + extractReplies (prover.input.config.logN - prover.input.config.folds[0]!) + prover.input.config.rates[0]! noWrap prover.input.config.queries[0]! + (prover.input.lanes - 1 - lane.val) + (List.ofFn fun round => resetRequest prover.input level (seed round)) + (collectResets prover tape level rounds seed).replies = + some (witnessLane prover.input w lane)) : + extractWitness prover tape level initialLevel rounds seed noWrap = some w := by + apply assembleWitness_recovers + intro lane + simpa only [Array.getElem_ofFn] using lanesRecovered lane + +/-- The same algorithm as a bounded rewind-machine program. The finishing continuation is given only response records. -/ +def extractionProgram (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) (_initialLevel : level.val = 0) (rounds : Nat) + (seed : Fin rounds → Sample (.query level)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + RewindProgram input.config input.lanes := + let requests := List.ofFn fun round => resetRequest input level (seed round) + collectProgram input (queryPrefix input tape level) requests + (fun answers => decodeWitness input requests answers noWrap) + +theorem extractionProgram_run (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (initialLevel : level.val = 0) (rounds : Nat) + (seed : Fin rounds → Sample (.query level)) + (noWrap : prover.input.config.logN - prover.input.config.folds[0]! + + prover.input.config.rates[0]! ≤ 64) : + runRewind prover.input prover.respond (queryPrefix prover.input tape level).length rounds + (extractionProgram prover.input tape level initialLevel rounds seed noWrap) = + ⟨extractWitness prover tape level initialLevel rounds seed noWrap, + rounds * ((queryPrefix prover.input tape level).length + 1)⟩ := by + have replay := run_collectProgram prover.input prover.respond + (queryPrefix prover.input tape level) (queryPrefix prover.input tape level).length le_rfl + (List.ofFn fun round => resetRequest prover.input level (seed round)) + (fun answers => decodeWitness prover.input + (List.ofFn fun round => resetRequest prover.input level (seed round)) answers noWrap) + simpa only [List.length_ofFn, extractionProgram, extractWitness, collectResets, + collect_responseCalls] using replay + +/-- Actual acceptance without an explaining output is covered by an existing causal bad prefix or by failure of the stated occupied-lane recovery condition. The second event is not bounded by the existing list-loss soundness theorem. -/ +theorem accepted_without_output_cover (p : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (tape : Tape (ParameterBounds.config p)) + (output : Option (Witness (ParameterBounds.config p) lanes)) + (accepted : experiment (ExecutionShapes.Input p lanes root claims) strategy tape = true) + (failed : ¬ ∃ w, output = some w ∧ Explains (ExecutionShapes.Input p lanes root claims) w) : + (∃ q, CausalBadEvents.Bad (ExecutionShapes.Input p lanes root claims) strategy q tape) ∨ + (∃ w, Explains (ExecutionShapes.Input p lanes root claims) w ∧ output ≠ some w) := by + classical + by_cases bad : ∃ q, CausalBadEvents.Bad (ExecutionShapes.Input p lanes root claims) strategy q tape + · exact Or.inl bad + · obtain ⟨w, explains⟩ := accepted_safe_explanation p lanes root claims strategy tape accepted + (fun q event => bad ⟨q, event⟩) + exact Or.inr ⟨w, explains, fun equal => failed ⟨w, equal, explains⟩⟩ + +/-- The unexplained-acceptance event for the implemented extractor, not an arbitrary output observer. The remaining term is concrete supported-row decoding failure for an explaining commitment-time witness. -/ +theorem accepted_without_extracted_witness_cover (p : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (tape : Tape (ParameterBounds.config p)) + (level : Fin (ParameterBounds.config p).folds.size) (initialLevel : level.val = 0) + (rounds : Nat) (seed : Fin rounds → Sample (.query level)) + (noWrap : (ParameterBounds.config p).logN - (ParameterBounds.config p).folds[0]! + + (ParameterBounds.config p).rates[0]! ≤ 64) + (accepted : experiment (ExecutionShapes.Input p lanes root claims) strategy tape = true) + (failed : ¬ ∃ w, + extractWitness ⟨ExecutionShapes.Input p lanes root claims, strategy⟩ tape + level initialLevel rounds seed noWrap = some w ∧ + Explains (ExecutionShapes.Input p lanes root claims) w) : + (∃ q, CausalBadEvents.Bad (ExecutionShapes.Input p lanes root claims) strategy q tape) ∨ + ∃ w lane, Explains (ExecutionShapes.Input p lanes root claims) w ∧ + extractReplies ((ParameterBounds.config p).logN - (ParameterBounds.config p).folds[0]!) + (ParameterBounds.config p).rates[0]! noWrap (ParameterBounds.config p).queries[0]! + (lanes - 1 - lane.val) + (List.ofFn fun round => resetRequest (ExecutionShapes.Input p lanes root claims) level (seed round)) + (collectResets ⟨ExecutionShapes.Input p lanes root claims, strategy⟩ tape level rounds seed).replies ≠ + some (witnessLane (ExecutionShapes.Input p lanes root claims) w lane) := by + classical + obtain bad | ⟨w, explains, missed⟩ := accepted_without_output_cover + p lanes root claims strategy tape _ accepted failed + · exact Or.inl bad + · right + have notRecovered : ¬ ∀ lane : Fin lanes, + extractReplies ((ParameterBounds.config p).logN - (ParameterBounds.config p).folds[0]!) + (ParameterBounds.config p).rates[0]! noWrap (ParameterBounds.config p).queries[0]! + (lanes - 1 - lane.val) + (List.ofFn fun round => resetRequest (ExecutionShapes.Input p lanes root claims) level (seed round)) + (collectResets ⟨ExecutionShapes.Input p lanes root claims, strategy⟩ tape level rounds seed).replies = + some (witnessLane (ExecutionShapes.Input p lanes root claims) w lane) := + fun recovered => by + have recoveredFull := extractWitness_recovers + ⟨ExecutionShapes.Input p lanes root claims, strategy⟩ tape level initialLevel + rounds seed noWrap w recovered + exact missed recoveredFull + push Not at notRecovered + obtain ⟨lane, failedLane⟩ := notRecovered + exact ⟨w, lane, explains, failedLane⟩ + +#print axioms assembleWitness_recovers +#print axioms extractWitness_recovers +#print axioms extractionProgram_run +#print axioms accepted_without_output_cover +#print axioms accepted_without_extracted_witness_cover + +end Whir.PCSRewindExtraction diff --git a/verification/whir/Whir/PCSRewindExtractor.lean b/verification/whir/Whir/PCSRewindExtractor.lean new file mode 100644 index 000000000..5d809043c --- /dev/null +++ b/verification/whir/Whir/PCSRewindExtractor.lean @@ -0,0 +1,325 @@ +import Whir.PCSRewindExtraction +import Whir.SupportedCandidateCancellation +import Whir.AuthenticatedResetSupport +import Whir.ResetAcceptanceAmplification +import Whir.SupportedCandidateParameters + +/-! Root0 occupied-witness Gao decoding and deterministic verified output. +The input is a finite authenticated record list, not an ideal root preimage. +The executable extractor decodes only the live K lanes at Root0; the independent +extension-field GS backend is not invoked by this algorithm. The counter below +measures decoder field arithmetic only; whole-extractor accounting is supplied +by the value-connected instrumentation in `ExtractorArithmeticCost`. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction + +/-- Parse each recorded coordinate once, shared by all live decoder lanes. -/ +def filledRecords (input : Public) (records : List (Record input.config)) : + Array (Option (Array K)) := + Array.ofFn fun q : Fin (blockLength input.config) => RewindRowExtraction.lookup records q + +def receivedLaneCached (input : Public) (filled : Array (Option (Array K))) + (lane : Fin input.lanes) : Fin (blockLength input.config) → E := fun q => + match filled[q.val]! with + | none => 0 + | some row => E.ofK (recordLane input.lanes row lane.val) + +/-- All missing coordinates are zero-filled. This does not assume they agree +with the committed word: the precise error radius is a recovery hypothesis. -/ +def receivedLane (input : Public) (records : List (Record input.config)) (lane : Fin input.lanes) : + Fin (blockLength input.config) → E := + receivedLaneCached input (filledRecords input records) lane + +/-- The actual instrumented Gao/novel/base-word pipeline is run once per live lane. -/ +def decodeRecords (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + Option (Witness input.config input.lanes) × Nat := + let filled := filledRecords input records + let decoded := Array.ofFn fun lane : Fin input.lanes => + ConcreteRowExtraction.countedExtractRow (input.config.logN - input.config.folds[0]!) + input.config.rates[0]! noWrap + ⟨Array.ofFn (receivedLaneCached input filled lane), by simp⟩ + (PCSRewindExtraction.assembleWitness input (fun lane => + (decoded[lane.val]'(by simp [decoded])).1), + (decoded.map Prod.snd).toList.sum) + +open scoped BigOperators in +/-- Value-connected field-arithmetic bound for decoding ALL occupied K lanes. -/ +theorem decodeRecords_decoder_cost (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) : + (decodeRecords input records noWrap).2 ≤ + input.lanes * ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) := by + simp only [decodeRecords, Array.toList_map, Array.toList_ofFn, List.map_ofFn, List.sum_ofFn] + calc + _ ≤ ∑ _lane : Fin input.lanes, + ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) := by + apply Finset.sum_le_sum + intro lane _ + exact ConcreteRowExtraction.countedExtractRow_polynomial_cost _ _ noWrap redundancy _ + _ = _ := by simp + +/-- Recovery runs the decoder, rather than selecting a known witness. Its +radius premises describe the actual zero-filled received lanes. -/ +theorem decodeRecords_recovers (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) + (w : Witness input.config input.lanes) + (radius : ∀ lane : Fin input.lanes, + 2 * hammingDist + (Vector.mk (Array.ofFn (receivedLane input records lane)) (by simp) : + Vector E (ConcreteRowExtraction.domain + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) noWrap).n).get + (fun i => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[i.val]!) ≤ + blockLength input.config - width input.config) : + (decodeRecords input records noWrap).1 = some w := by + apply PCSRewindExtraction.assembleWitness_recovers + intro lane + simp only [Array.getElem_ofFn] + exact (ConcreteRowExtraction.countedExtractRow_recovers _ _ noWrap redundancy + (PCSRewindExtraction.witnessLane input w lane) (by simp [PCSRewindExtraction.witnessLane]) + _ (radius lane)).1 + +/-- Output is checked on a common authenticated coordinate certificate and ALL +original public claims. It is not checked against a recomputed honest root. -/ +def decodeAndCheck (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + Option (Witness input.config input.lanes) × Nat := + let decoded := decodeRecords input records noWrap + (decoded.1.bind (fun w => + SupportedCandidateExtraction.finish input (paddedWitness input.config input.lanes w) records), + decoded.2) + +/-- Guarded conversion of accepted extension rows back to literal base leaves. -/ +def baseRow (row : Array E) : Option (Array K) := + if row.all (fun e => e.c1 == 0 && e.c2 == 0) then some (row.map E.c0) else none + +def baseRecords {N : Nat} (records : List (Fin N × Array E)) : List (Fin N × Array K) := + records.filterMap (fun record => (baseRow record.2).map (record.1, ·)) + +theorem baseRow_sound (row : Array E) (base : Array K) (success : baseRow row = some base) : + row = base.map E.ofK := by + unfold baseRow at success + split at success + · rename_i guard + have equal := Option.some.inj success + rw [← equal, Array.map_map] + apply Array.ext + · simp + · intro i hi hj + have h := Array.all_eq_true.mp guard i hi + simp only [Bool.and_eq_true, beq_iff_eq] at h + cases entry : row[i] + simp_all [E.ofK, Function.comp_apply] + · contradiction + +theorem baseRow_embedded (row : Array K) : baseRow (row.map E.ofK) = some row := by + simp [baseRow, E.ofK, Array.map_map, Function.comp_def] + +theorem baseRecords_authenticated {N : Nat} (root : BaseOracle) + (records : List (Fin N × Array E)) + (authenticated : ∀ record ∈ records, record.2 = (root[record.1.val]!).map E.ofK) : + ∀ record ∈ baseRecords records, record.2 = root[record.1.val]! := by + intro record member + obtain ⟨original, memberOriginal, projected⟩ := List.mem_filterMap.mp member + rw [authenticated original memberOriginal, baseRow_embedded] at projected + have equal := Option.some.inj projected + subst record + rfl + +theorem decodeAndCheck_sound (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (threshold : width input.config - 1 < ParameterBounds.threshold input.config 0) + (w : Witness input.config input.lanes) + (output : (decodeAndCheck input records noWrap).1 = some w) : Explains input w := by + simp only [decodeAndCheck] at output + obtain ⟨decoded, _, checked⟩ := Option.bind_eq_some_iff.mp output + exact finish_explains input _ records authenticated foldBound laneBound noWrap threshold w checked + +/-- Every trial is run through the black box with strict-prefix replay. Only +fully accepted trials contribute rows to the candidate check. -/ +def extractionProgram (input : Public) (level : Fin input.config.folds.size) + (tapes : List (Tape input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + RewindProgram input.config input.lanes := + AuthenticatedResetSupport.collectAcceptedProgram input level + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) tapes + (fun records => (decodeAndCheck input (baseRecords records) noWrap).1) + +theorem extractionProgram_run (prover : CommittedProver) + (level : Fin prover.input.config.folds.size) (tapes : List (Tape prover.input.config)) + (noWrap : prover.input.config.logN - prover.input.config.folds[0]! + + prover.input.config.rates[0]! ≤ 64) + (maxReplay : Nat) + (within : ∀ tape ∈ tapes, + (visibleBatches prover.input.config tape.1 (challenges prover.input.config tape)).length ≤ maxReplay) : + runRewind prover.input prover.respond maxReplay + (AuthenticatedResetSupport.collectionFuel prover.input tapes) + (extractionProgram prover.input level tapes noWrap) = + ⟨(decodeAndCheck prover.input (baseRecords (AuthenticatedResetSupport.collectedRecords + prover level (prover.input.config.logN - prover.input.config.folds[0]! + + prover.input.config.rates[0]!) tapes)) noWrap).1, + AuthenticatedResetSupport.collectionCalls prover.input tapes⟩ := + AuthenticatedResetSupport.run_collectAcceptedProgram prover level _ maxReplay tapes within _ + +def initialLevel (profile : ParameterBounds.Profile) : + Fin (ParameterBounds.config profile).folds.size := + ⟨0, by have valid := (ParameterBounds.production_config_valid profile).2.1; omega⟩ + +theorem collected_initial_embedded (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (tapes : List (Tape (ParameterBounds.config profile))) : + let input := ExecutionShapes.Input profile lanes root claims + ∀ record ∈ AuthenticatedResetSupport.collectedRecords + ⟨input, strategy⟩ (initialLevel profile) + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) tapes, + record.2 = (root[record.1.val]!).map E.ofK := by + dsimp only + intro record member + obtain ⟨tape, _, member⟩ := List.mem_flatMap.mp member + have shape : (CausalExecution.foldAt (ExecutionShapes.Input profile lanes root claims) + strategy tape (initialLevel profile) (ParameterBounds.config profile).folds[0]!).n + + (ParameterBounds.config profile).rates[0]! = + (ParameterBounds.config profile).logN - (ParameterBounds.config profile).folds[0]! + + (ParameterBounds.config profile).rates[0]! := by + have dimensions := (ExecutionShapes.foldAt_shape profile lanes root claims strategy tape + (initialLevel profile) (ParameterBounds.config profile).folds[0]! (by rfl)).1 + simp only [initialLevel, Nat.sub_self, Nat.add_zero] at dimensions + simp only [initialLevel] + rw [dimensions, (InitialCandidates.production_initial_facts profile).1] + have authentic := AuthenticatedResetSupport.trialRecords_authenticated + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ tape (initialLevel profile) _ shape record member + change record.2 = (liftRoot root)[record.1.val]! at authentic + rw [authentic] + by_cases within : record.1.val < root.size + · simp [liftRoot, getElem!_pos, within] + · simp [liftRoot, getElem!_neg, within] + change (#[] : Array E) = (#[] : Array K).map E.ofK + simp + +theorem collected_base_authenticated (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (tapes : List (Tape (ParameterBounds.config profile))) : + let input := ExecutionShapes.Input profile lanes root claims + ∀ record ∈ baseRecords (AuthenticatedResetSupport.collectedRecords + ⟨input, strategy⟩ (initialLevel profile) + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) tapes), + record.2 = root[record.1.val]! := by + dsimp only + exact baseRecords_authenticated root _ (collected_initial_embedded profile lanes root claims strategy tapes) + + +def streamLength (c : Config) : Nat := + 1 + ((List.range c.folds.size).map (fun i => c.folds[i]! + oodCount c i + 1)).sum + + (c.logN - c.folds.toList.sum - 1) + +theorem visible_length (c : Config) (tape : Tape c) : + (visibleBatches c tape.1 (challenges c tape)).length = streamLength c := by + simp only [visibleBatches, List.length_append, List.length_singleton, List.length_ofFn, + List.length_flatMap, challenges, Array.size_ofFn] + congr 2 + congr 1 + apply List.map_congr_left + intro i hi + have bound : i < c.folds.size := List.mem_range.mp hi + simp [levelBatches, getElem!_pos, bound, Nat.add_assoc] + +deriving instance DecidableEq for Config + +abbrev initialDepth (profile : ParameterBounds.Profile) := + (ParameterBounds.config profile).logN - (ParameterBounds.config profile).folds[0]! + + (ParameterBounds.config profile).rates[0]! + +theorem initialChunks (profile : ParameterBounds.Profile) : + queryChunks (ParameterBounds.config profile) (initialLevel profile) = + (((ParameterBounds.config profile).queries[0]! + 192 / initialDepth profile - 1) / + (192 / initialDepth profile)) := by + simp only [queryChunks, initialLevel] + rw [(InitialCandidates.production_initial_facts profile).1] + +abbrev TrialSeed (profile : ParameterBounds.Profile) := + RewindCoverage.QueryTape (initialDepth profile) (ParameterBounds.config profile).queries[0]! × + (E × Tape (ParameterBounds.config profile)) + +abbrev Seed (profile : ParameterBounds.Profile) (rounds : Nat) := + Tape (ParameterBounds.config profile) × (Fin rounds → TrialSeed profile) + +/-- Uses the collector's exact stratified-query and independent full-suffix +sampling law, including the invisible final verifier challenge. -/ +def seedTapes (profile : ParameterBounds.Profile) (rounds : Nat) (input : Public) + (equal : input.config = ParameterBounds.config profile) (seed : Seed profile rounds) : + List (Tape input.config) := + equal.symm ▸ (List.ofFn fun round => AuthenticatedResetSupport.fullResetTape + ⟨ParameterBounds.config profile, input.lanes, input.root, input.claims⟩ seed.1 + (initialLevel profile) (initialDepth profile) (initialChunks profile) + (seed.2 round).1 (seed.2 round).2) + +/-- Actual finite-profile extractor. Other configurations are rejected. Every +query is a legal full trial against the fixed committed public input/prover. -/ +def extractor (profile : ParameterBounds.Profile) (rounds : Nat) : Extractor (Seed profile rounds) where + program input seed := + if equal : input.config = ParameterBounds.config profile then + extractionProgram input (equal.symm ▸ initialLevel profile) + (seedTapes profile rounds input equal seed) (by + simpa only [equal] using (InitialCandidates.production_initial_facts profile).2.2.1) + else .finish none + rewindRounds := rounds * streamLength (ParameterBounds.config profile) + maxReplay := streamLength (ParameterBounds.config profile) + +theorem extractor_program (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (seed : Seed profile rounds) : + let input := ExecutionShapes.Input profile lanes root claims + (extractor profile rounds).program input seed = + extractionProgram input (initialLevel profile) (seedTapes profile rounds input rfl seed) + (InitialCandidates.production_initial_facts profile).2.2.1 := by + simp only [extractor] + rfl + +theorem collectionFuel_ofFn (input : Public) (rounds : Nat) (tapes : Fin rounds → Tape input.config) : + AuthenticatedResetSupport.collectionFuel input (List.ofFn tapes) = + rounds * streamLength input.config := by + simp [AuthenticatedResetSupport.collectionFuel, visible_length, List.map_ofFn, List.sum_ofFn] + +theorem extractor_run (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) : + let input := ExecutionShapes.Input profile lanes root claims + let tapes := seedTapes profile rounds input rfl seed + runRewind input strategy (extractor profile rounds).maxReplay (extractor profile rounds).rewindRounds + ((extractor profile rounds).program input seed) = + ⟨(decodeAndCheck input (baseRecords (AuthenticatedResetSupport.collectedRecords + ⟨input, strategy⟩ (initialLevel profile) + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) tapes)) + (InitialCandidates.production_initial_facts profile).2.2.1).1, + AuthenticatedResetSupport.collectionCalls input tapes⟩ := by + dsimp only + rw [extractor_program] + change runRewind _ _ (streamLength (ParameterBounds.config profile)) + (rounds * streamLength (ParameterBounds.config profile)) _ = _ + rw [← collectionFuel_ofFn (ExecutionShapes.Input profile lanes root claims) rounds + (fun round => AuthenticatedResetSupport.fullResetTape + (ExecutionShapes.Input profile lanes root claims) seed.1 (initialLevel profile) + (initialDepth profile) (initialChunks profile) (seed.2 round).1 (seed.2 round).2)] + dsimp only [seedTapes] + apply extractionProgram_run (prover := ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩) + intro tape member + exact (visible_length _ _).le + +theorem extractor_output_explains (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) + (laneBound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (w : Witness (ParameterBounds.config profile) lanes) + (output : (runRewind (ExecutionShapes.Input profile lanes root claims) strategy + (extractor profile rounds).maxReplay (extractor profile rounds).rewindRounds + ((extractor profile rounds).program (ExecutionShapes.Input profile lanes root claims) seed)).output = some w) : + Explains (ExecutionShapes.Input profile lanes root claims) w := by + rw [extractor_run] at output + exact decodeAndCheck_sound _ _ _ (collected_base_authenticated profile lanes root claims strategy _) + (InitialCandidates.production_initial_facts profile).2.1 laneBound + (InitialCandidates.production_initial_facts profile).2.2.2 w output + +#print axioms baseRow_sound +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindExtractorAttempts.lean b/verification/whir/Whir/PCSRewindExtractorAttempts.lean new file mode 100644 index 000000000..216cfb41c --- /dev/null +++ b/verification/whir/Whir/PCSRewindExtractorAttempts.lean @@ -0,0 +1,173 @@ +import Whir.PCSRewindExtractor + +/-! Prefix amplification is implemented inside the bounded black-box machine. +Attempts stop only on a decoded-and-certified witness, never merely acceptance. +All prefix/suffix samples have the actual collector's finite product law. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction AuthenticatedResetSupport + +set_option maxHeartbeats 4000000 + +/-- Generalize the accepted-trial collector's finishing continuation so an +unsuccessful prefix can continue to another independent prefix. -/ +def continueCollect (input : Public) (level : Fin input.config.folds.size) (depth : Nat) : + List (Tape input.config) → + (List (Fin (2 ^ depth) × Array E) → RewindProgram input.config input.lanes) → + RewindProgram input.config input.lanes + | [], finish => finish [] + | tape :: tapes, finish => + trialProgram input [] (visibleBatches input.config tape.1 (challenges input.config tape)) + (fun replies => continueCollect input level depth tapes + (fun records => finish (acceptedRecords input tape level depth replies ++ records))) + +theorem run_continueCollect (prover : CommittedProver) + (level : Fin prover.input.config.folds.size) (depth maxReplay extra : Nat) + (tapes : List (Tape prover.input.config)) + (within : ∀ tape ∈ tapes, + (visibleBatches prover.input.config tape.1 (challenges prover.input.config tape)).length ≤ maxReplay) + (finish : List (Fin (2 ^ depth) × Array E) → RewindProgram prover.input.config prover.input.lanes) : + runRewind prover.input prover.respond maxReplay (collectionFuel prover.input tapes + extra) + (continueCollect prover.input level depth tapes finish) = + let result := runRewind prover.input prover.respond maxReplay extra + (finish (collectedRecords prover level depth tapes)) + ⟨result.output, result.responseCalls + collectionCalls prover.input tapes⟩ := by + induction tapes generalizing finish with + | nil => simp [continueCollect, collectionFuel, collectionCalls, collectedRecords] + | cons tape tapes ih => + simp only [continueCollect, collectionFuel, List.map_cons, List.sum_cons, Nat.add_assoc] + rw [run_trialProgram _ _ [] _ maxReplay _ (by simpa using within tape (by simp))] + dsimp only + erw [ih (fun t ht => within t (by simp [ht]))] + simp [replayPast, collectedRecords, trialRecords, collectionCalls, Nat.add_assoc, Nat.add_comm] + +def repeatedProgram (profile : ParameterBounds.Profile) (rounds : Nat) (input : Public) + (equal : input.config = ParameterBounds.config profile) : + List (Seed profile rounds) → RewindProgram input.config input.lanes + | [] => .finish none + | seed :: seeds => + continueCollect input (equal.symm ▸ initialLevel profile) + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (seedTapes profile rounds input equal seed) (fun records => + match (decodeAndCheck input (baseRecords records) (by + simpa only [equal] using (InitialCandidates.production_initial_facts profile).2.2.1)).1 with + | some witness => .finish (some witness) + | none => repeatedProgram profile rounds input equal seeds) + +abbrev RepeatedSeed (profile : ParameterBounds.Profile) (attempts rounds : Nat) := + Fin attempts → Seed profile rounds + +def repeatedExtractor (profile : ParameterBounds.Profile) (attempts rounds : Nat) : + Extractor (RepeatedSeed profile attempts rounds) where + program input seed := + if equal : input.config = ParameterBounds.config profile then + repeatedProgram profile rounds input equal (List.ofFn seed) + else .finish none + rewindRounds := attempts * (rounds * streamLength (ParameterBounds.config profile)) + maxReplay := streamLength (ParameterBounds.config profile) + +def firstOutput {α : Type*} : List (Option α) → Option α + | [] => none + | some value :: _ => some value + | none :: rest => firstOutput rest + +theorem repeatedProgram_output (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seeds : List (Seed profile rounds)) : + let input := ExecutionShapes.Input profile lanes root claims + (runRewind input strategy (streamLength (ParameterBounds.config profile)) + (seeds.length * (rounds * streamLength (ParameterBounds.config profile))) + (repeatedProgram profile rounds input rfl seeds)).output = + firstOutput (seeds.map (fun seed => + (runRewind input strategy (extractor profile rounds).maxReplay + (extractor profile rounds).rewindRounds ((extractor profile rounds).program input seed)).output)) := by + dsimp only + induction seeds with + | nil => simp [repeatedProgram, runRewind, firstOutput] + | cons seed seeds ih => + let input := ExecutionShapes.Input profile lanes root claims + have fuel : collectionFuel input (seedTapes profile rounds input rfl seed) = + rounds * streamLength (ParameterBounds.config profile) := + collectionFuel_ofFn _ _ _ + simp only [repeatedProgram, List.length_cons, Nat.succ_mul, List.map_cons] + rw [Nat.add_comm, ← fuel, run_continueCollect + (prover := ⟨input, strategy⟩) (within := fun tape _ => (visible_length _ _).le)] + rw [extractor_run] + dsimp only + cases decoded : (decodeAndCheck input (baseRecords (collectedRecords ⟨input, strategy⟩ + (initialLevel profile) (initialDepth profile) (seedTapes profile rounds input rfl seed))) + (InitialCandidates.production_initial_facts profile).2.2.1).1 with + | none => simpa only [decoded, firstOutput, fuel] using ih + | some witness => simp only [runRewind, firstOutput] + +theorem repeatedExtractor_output (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) : + let input := ExecutionShapes.Input profile lanes root claims + (runRewind input strategy (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program input seed)).output = + firstOutput (List.ofFn fun i => + (runRewind input strategy (extractor profile rounds).maxReplay (extractor profile rounds).rewindRounds + ((extractor profile rounds).program input (seed i))).output) := by + simpa [repeatedExtractor, List.map_ofFn, Function.comp_def] using + repeatedProgram_output profile rounds lanes root claims strategy (List.ofFn seed) + +/-- Every actual black-box response call, including rejected attempts and all +strict-prefix replays, is charged by the concrete repeated extractor. -/ +theorem repeatedExtractor_responseCalls (profile : ParameterBounds.Profile) (attempts rounds : Nat) + (prover : CommittedProver) (seed : RepeatedSeed profile attempts rounds) : + (runRewind prover.input prover.respond (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program prover.input seed)).responseCalls ≤ + attempts * (rounds * streamLength (ParameterBounds.config profile)) * + (streamLength (ParameterBounds.config profile) + 1) := + responseCalls_le _ _ _ _ _ + +theorem firstOutput_some_mem {α : Type*} (outputs : List (Option α)) (w : α) + (output : firstOutput outputs = some w) : some w ∈ outputs := by + induction outputs with + | nil => simp [firstOutput] at output + | cons value rest ih => + cases value with + | none => exact List.mem_cons_of_mem _ (ih output) + | some value => + have equal : value = w := Option.some.inj output + simp [equal] + +theorem repeatedExtractor_output_explains (profile : ParameterBounds.Profile) + (attempts rounds lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (seed : RepeatedSeed profile attempts rounds) + (laneBound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (w : Witness (ParameterBounds.config profile) lanes) + (output : (runRewind (ExecutionShapes.Input profile lanes root claims) strategy + (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program + (ExecutionShapes.Input profile lanes root claims) seed)).output = some w) : + Explains (ExecutionShapes.Input profile lanes root claims) w := by + rw [repeatedExtractor_output] at output + obtain ⟨attempt, accepted⟩ := List.mem_ofFn.mp (firstOutput_some_mem _ w output) + exact extractor_output_explains profile rounds lanes root claims strategy + (seed attempt) laneBound w accepted + +/-- Every original public functional is preserved, including the input anchor +functional whenever it is present among the original claims. -/ +theorem repeatedExtractor_original_claim (profile : ParameterBounds.Profile) + (attempts rounds lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (seed : RepeatedSeed profile attempts rounds) + (laneBound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (w : Witness (ParameterBounds.config profile) lanes) + (output : (runRewind (ExecutionShapes.Input profile lanes root claims) strategy + (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program + (ExecutionShapes.Input profile lanes root claims) seed)).output = some w) + (original : Claim) (member : original ∈ claims.toList) : + dot (paddedWitness (ParameterBounds.config profile) lanes w) original.weight = original.value := + (repeatedExtractor_output_explains profile attempts rounds lanes root claims strategy seed laneBound w output).2 + original member + +#print axioms run_continueCollect +#print axioms repeatedExtractor_responseCalls +#print axioms repeatedExtractor_output_explains +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindExtractorFixtures.lean b/verification/whir/Whir/PCSRewindExtractorFixtures.lean new file mode 100644 index 000000000..e20e47a50 --- /dev/null +++ b/verification/whir/Whir/PCSRewindExtractorFixtures.lean @@ -0,0 +1,186 @@ +import Whir.PCSRewindExtractor +import Whir.PCSRewindSourceProgram + +/-! Dense-model Root0 program smoke with eight nonzero K coefficients, all +original family slices, ordinary/strided points, and the retained anchor. +A false second family masked by gamma=0 must fail the real original checker. +This tests the legal collector/decoder/checker, not the physical header/byte adapter. +The independent extension GS artifact is neither imported nor run here. -/ +namespace Whir.PCSRewindExtractorFixtures +open Concrete Protocol CausalGame PCSRewindExtractor KnowledgeExtraction + +def sourceConfig : Config := ⟨3, #[1, 1], #[2, 2], #[16, 8], #[0, 1]⟩ +def sourceWords : Array K := #[3, 5, 7, 11, 13, 17, 19, 23] +def sourceTape : Tape sourceConfig := + ⟨E.ofK 3, (fun _ => ⟨(fun _ => E.ofK 5), (fun _ _ => E.ofK 7), + (fun _ => E.ofK 11), E.ofK 13⟩), (fun _ => E.ofK 17)⟩ + +def replyOfOpening (c : Config) (proof : Opening) : Batch → Reply + | .initial _ => .initial proof.initial + | .fold level round _ => + .fold proof.levels[level]!.afterFold[round]! + (if round + 1 = c.folds[level]! then proof.levels[level]!.nextOracle else none) + (if level + 1 = c.folds.size && round + 1 = c.folds[level]! then proof.residual else #[]) + | .ood level index _ => .ood proof.levels[level]!.oods[index]! + | .query level _ _ => .query proof.levels[level]!.rows proof.levels[level]!.intro + | .tail round _ => .tail proof.tailMessages[round]! + +def sourceStrategy (c : Config) (proof : Opening) : Strategy := fun _ _ batch => replyOfOpening c proof batch + +def runSource : IO Unit := do + let weight := tab 8 fun i => E.ofK (UInt64.ofNat (i + 29)) + let claim := dot (sourceWords.map E.ofK) weight + let anchorPoint : Array E := #[E.ofK 41, E.ofK 43, E.ofK 47] + let anchorWeight := eqTable anchorPoint + let anchorValue := Concrete.mle (sourceWords.map E.ofK) anchorPoint + let originalClaims : Array Claim := #[⟨weight, claim⟩, ⟨anchorWeight, anchorValue⟩] + let statement := batchClaims 8 originalClaims sourceTape.1 + unless statement.value == claim + sourceTape.1 * anchorValue do + throw (IO.userError "retained anchor lost its final lambda power") + let (root, proof) ← match prove sourceConfig (challenges sourceConfig sourceTape) + sourceWords statement.weight statement.value with + | .error message => throw (IO.userError message) + | .ok result => pure result + let input : Public := ⟨sourceConfig, 2, root.map (Array.map E.c0), originalClaims⟩ + let tapes : List (Tape input.config) := [sourceTape] + let strategy := sourceStrategy sourceConfig proof + unless experiment input strategy sourceTape do throw (IO.userError "source trial rejected") + let program := extractionProgram input ⟨0, by change 0 < sourceConfig.folds.size; decide⟩ tapes + (by change 4 ≤ 64; decide) + let result := runRewind input strategy (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel input tapes) program + let recovered := result.output.map (fun w => Array.ofFn w) + unless recovered == some sourceWords do throw (IO.userError "whole source witness mismatch") + unless input.claims.all (fun original => + dot (recovered.getD #[] |>.map E.ofK) original.weight == original.value) do + throw (IO.userError "extracted witness does not explain every original claim") + unless Concrete.mle (recovered.getD #[] |>.map E.ofK) anchorPoint == anchorValue do + throw (IO.userError "extracted witness changed the retained original anchor") + IO.println s!"whole-source: {sourceWords.size} nontrivial K coefficients, calls={result.responseCalls}" + let malformed : Strategy := fun _ _ _ => .tail default + let malformedResult := runRewind input malformed (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel input tapes) program + unless malformedResult.output.isNone do throw (IO.userError "malformed reply accepted by extractor") + let adverse : Strategy := fun instanceInput past batch => + match batch with + | .query level squeezes lambda => + match strategy instanceInput past (.query level squeezes lambda) with + | .query rows intro => .query (rows.map (fun row => row.map (fun e => e + E.ofK 1))) intro + | other => other + | other => strategy instanceInput past other + let adverseResult := runRewind input adverse (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel input tapes) program + unless adverseResult.output.isNone do throw (IO.userError "unauthenticated adverse row accepted") + unless !(experiment input adverse sourceTape) do + throw (IO.userError "unauthenticated adverse trial accepted") + let withholding : Strategy := fun instanceInput past batch => + match batch with + | .query _ _ _ => .query #[] default + | other => strategy instanceInput past other + unless !(experiment input withholding sourceTape) do + throw (IO.userError "withholding trial accepted") + let withholdingResult := runRewind input withholding (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel input tapes) program + unless withholdingResult.output.isNone do + throw (IO.userError "withholding prover produced extracted output") + let wrongInput : Public := { input with claims := #[⟨weight, claim + E.ofK 1⟩] } + unless !(experiment wrongInput strategy sourceTape) do + throw (IO.userError "wrong original claim accepted") + let wrongProgram := extractionProgram wrongInput + ⟨0, by change 0 < sourceConfig.folds.size; decide⟩ [sourceTape] (by change 4 ≤ 64; decide) + let wrongResult := runRewind wrongInput strategy (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel wrongInput [sourceTape]) wrongProgram + unless wrongResult.output.isNone do + throw (IO.userError "wrong original claim produced extracted output") + IO.println "whole-source: every original claim agrees; withholding and wrong claim rejected" + IO.println "whole-source: malformed tags and adverse rows rejected" + let zeroLambdaTape := CausalProbability.set (.query ⟨0, by decide⟩) sourceTape + ⟨(fun _ => E.ofK 11), E.zero⟩ + let (honestRoot, honestProof) ← match prove sourceConfig (challenges sourceConfig zeroLambdaTape) + sourceWords statement.weight statement.value with + | .error message => throw (IO.userError message) + | .ok result => pure result + let changedRow := (honestRoot[1]!).map (fun e => e + E.ofK 1) + let changedRoot := honestRoot.set! 1 changedRow + let changedRows := (honestProof.levels[0]!).rows.set! 1 changedRow + let changedFirst := { (honestProof.levels[0]!) with rows := changedRows } + let changedProof := {honestProof with levels := honestProof.levels.set! 0 changedFirst} + let changedInput : Public := ⟨sourceConfig, 2, changedRoot.map (Array.map E.c0), originalClaims⟩ + let changedStrategy := sourceStrategy sourceConfig changedProof + unless experiment changedInput changedStrategy zeroLambdaTape do + throw (IO.userError "malformed committed word should accept this legal trial") + let changedTapes : List (Tape changedInput.config) := [zeroLambdaTape] + let changedProgram := extractionProgram changedInput + ⟨0, by change 0 < sourceConfig.folds.size; decide⟩ changedTapes (by change 4 ≤ 64; decide) + let changedResult := runRewind changedInput changedStrategy (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel changedInput changedTapes) changedProgram + unless changedResult.output.map (fun w => Array.ofFn w) == some sourceWords do + throw (IO.userError "malformed committed word lost its nearby supported witness") + IO.println "whole-source: accepted malformed commitment, nearby witness recovered without honest-root equality" + -- Gamma=0 suppresses the SECOND original family in the compressed claim. + -- The actual source checker must nevertheless reject its incorrect slice. + let witness : Witness sourceConfig 2 := fun i => sourceWords[i.val]! + let skeleton : Fin 2 → RingPCSGame.FamilyClaim := fun i => + ⟨0, if i.val = 0 then #[E.ofK 2, E.ofK 3, E.ofK 5] else #[E.ofK 7, E.ofK 11, E.ofK 13], + fun _ => 0⟩ + let slices := RingPCSGame.honestSlices sourceConfig 2 skeleton witness + let families : Fin 2 → RingPCSGame.FamilyClaim := fun i => {skeleton i with slices := slices i} + let lyingFamilies : Fin 2 → RingPCSGame.FamilyClaim := fun i => + {families i with slices := fun bit => + if i.val = 1 ∧ bit.val = 0 then (families i).slices bit + 1 else (families i).slices bit} + let ordinaryPoint : Array E := #[E.ofK 29, E.ofK 31, E.ofK 37] + let stridedPoint : Array E := #[E.ofK 43, E.ofK 47] + let stridedWords := #[sourceWords[1]!, sourceWords[3]!, sourceWords[5]!, sourceWords[7]!] + let sourcePoints : Array RingPCSGame.PointClaim := + #[.point 0 ordinaryPoint (Concrete.mle (sourceWords.map E.ofK) ordinaryPoint), + .strided 0 1 1 stridedPoint (Concrete.mle (stridedWords.map E.ofK) stridedPoint)] + let honestPrepared ← match OriginalClaimsChecker.prepare sourceConfig 2 families sourcePoints anchorPoint anchorValue with + | none => throw (IO.userError "honest source public cache rejected") + | some prepared => pure prepared + let lyingPrepared ← match OriginalClaimsChecker.prepare sourceConfig 2 lyingFamilies sourcePoints anchorPoint anchorValue with + | none => throw (IO.userError "wrong family is well-shaped but cache rejected it") + | some prepared => pure prepared + let publicPrefix : RingPCSGame.Prefix := ⟨0, fun _ => 0⟩ + let skeletonInput := OriginalClaimsChecker.input honestPrepared #[] publicPrefix + let sourceStatement := batchClaims 8 skeletonInput.claims sourceTape.1 + let (sourceRoot, sourceProof) ← match prove sourceConfig (challenges sourceConfig sourceTape) + sourceWords sourceStatement.weight sourceStatement.value with + | .error message => throw (IO.userError message) + | .ok result => pure result + let sourceBaseRoot := sourceRoot.map (Array.map E.c0) + let honestInput := OriginalClaimsChecker.input honestPrepared sourceBaseRoot publicPrefix + let lyingInput := OriginalClaimsChecker.input lyingPrepared sourceBaseRoot publicPrefix + unless honestInput.claims.map (fun claim => (claim.weight, claim.value)) == + lyingInput.claims.map (fun claim => (claim.weight, claim.value)) do + throw (IO.userError "gamma=0 did not mask the second family's false original slice") + let sourceProver := sourceStrategy sourceConfig sourceProof + unless experiment honestInput sourceProver sourceTape && experiment lyingInput sourceProver sourceTape do + throw (IO.userError "source compressed protocol regression did not accept both inputs") + let sourceLevel : Fin sourceConfig.folds.size := ⟨0, by decide⟩ + let sourceNoWrap : sourceConfig.logN - sourceConfig.folds[0]! + sourceConfig.rates[0]! ≤ 64 := by decide + let sourceTapes : List (Tape sourceConfig) := [sourceTape] + let genericResult := runRewind lyingInput sourceProver (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel lyingInput sourceTapes) + (extractionProgram lyingInput sourceLevel sourceTapes sourceNoWrap) + unless genericResult.output.map (fun w => Array.ofFn w) == some sourceWords do + throw (IO.userError "compressed generic regression failed to recover the supported word") + let honestResult := runRewind honestInput sourceProver (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel honestInput sourceTapes) + (PCSRewindSource.program honestInput sourceLevel sourceTapes sourceNoWrap + (OriginalClaimsChecker.check honestPrepared)) + let lyingResult := runRewind lyingInput sourceProver (streamLength sourceConfig) + (AuthenticatedResetSupport.collectionFuel lyingInput sourceTapes) + (PCSRewindSource.program lyingInput sourceLevel sourceTapes sourceNoWrap + (OriginalClaimsChecker.check lyingPrepared)) + unless honestResult.output.map (fun w => Array.ofFn w) == some sourceWords do + throw (IO.userError "actual original source checker rejected its honest supported word") + unless lyingResult.output.isNone do + throw (IO.userError "actual source checker accepted a gamma-masked false original family") + IO.println s!"original-source: two full families, ordinary/strided points and retained anchor agree; calls={honestResult.responseCalls}" + IO.println s!"original-source: gamma=0 generic/compressed accepts, uncompressed false second family rejects; calls={lyingResult.responseCalls}" + + +end Whir.PCSRewindExtractorFixtures + +/-- Run the actual Root0 extractor on a small nontrivial legal source instance. -/ +def main : IO Unit := Whir.PCSRewindExtractorFixtures.runSource diff --git a/verification/whir/Whir/PCSRewindKnowledgeCollector.lean b/verification/whir/Whir/PCSRewindKnowledgeCollector.lean new file mode 100644 index 000000000..c92ad987d --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeCollector.lean @@ -0,0 +1,98 @@ +import Whir.PCSRewindKnowledgeHeavy + +/-! The legal full-trial collector recovers and verifies the SAME witness from +its heavy-coordinate certificate. The safe predicate is proof-only: the +collector's executable program tests ordinary verifier acceptance only. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open SamplingProbability AuthenticatedResetProbability AuthenticatedResetSupport +open SupportedCandidateRecovery ResetAcceptanceAmplification + +set_option maxHeartbeats 4000000 +attribute [local irreducible] ParameterBounds.config + +/-- The subset used to analyze the actual collector. -/ +def safeResetAccept (profile : ParameterBounds.Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) + (bad : Tape (ParameterBounds.config profile) → Prop) + (base : Tape (ParameterBounds.config profile)) (trial : TrialSeed profile) : Prop := + let tape := fullResetTape (ExecutionShapes.Input profile lanes root claims) base + (initialLevel profile) (initialDepth profile) (initialChunks profile) trial.1 trial.2 + experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true ∧ ¬ bad tape + +set_option maxRecDepth 100000 in +/-- Exact uniform law for prefix plus independent full reset suffix, applied +to the arbitrary SAFE acceptance predicate, not just coordinate events. -/ +theorem safeResetAccept_probability (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (bad : Tape (ParameterBounds.config profile) → Prop) : + probability (fun draw : Tape (ParameterBounds.config profile) × TrialSeed profile => + safeResetAccept profile lanes root claims strategy bad draw.1 draw.2) = + probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true ∧ ¬ bad tape) := by + unfold safeResetAccept + exact fullResetTape_probability (ExecutionShapes.Input profile lanes root claims) + (initialLevel profile) (initialDepth profile) (initialChunks profile) + (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true ∧ ¬ bad tape) + +/-- A production certificate carries a single explaining witness and the +actual common Root0 coordinates. Its radius is derived below from safe mass. -/ +structure HeavyWitness (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (H : Finset (Fin (blockLength (ParameterBounds.config profile)))) where + witness : Witness (ParameterBounds.config profile) lanes + explains : Explains (ExecutionShapes.Input profile lanes root claims) witness + matching : ∀ q ∈ H, rowMatches (ParameterBounds.config profile) lanes + (encodedLanes (ParameterBounds.config profile) (paddedWitness (ParameterBounds.config profile) lanes witness)) + (q, root[q.val]!) = true + +/-- Complete actual collectAcceptedProgram → all live Gao lanes → common +coordinate and ALL original claim checks → explaining verified output. -/ +theorem extractor_success_of_safe_coverage (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (bad : Tape (ParameterBounds.config profile) → Prop) + (base : Tape (ParameterBounds.config profile)) + (η : ℝ) (nonnegative : 0 ≤ η) + (large : (heavyQueryLoss profile : ℝ) + blockLength (ParameterBounds.config profile) * η < + probability (safeResetAccept profile lanes root claims strategy bad base)) + (certificate : HeavyWitness profile lanes root claims + (heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η)) + (seed : Fin rounds → TrialSeed profile) + (coverage : CoversHeavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η rounds seed) : + extractionSuccess (extractor profile rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ (base, seed) := by + let input := ExecutionShapes.Input profile lanes root claims + let tapes := seedTapes profile rounds input rfl (base, seed) + let extensionRecords := collectedRecords ⟨input, strategy⟩ (initialLevel profile) (initialDepth profile) tapes + let records := baseRecords extensionRecords + let H := heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η + have embedded : ∀ record ∈ extensionRecords, record.2 = (root[record.1.val]!).map E.ofK := + collected_initial_embedded profile lanes root claims strategy tapes + have authenticated : ∀ record ∈ records, record.2 = root[record.1.val]! := + collected_base_authenticated profile lanes root claims strategy tapes + have coveredExtension : ∀ q ∈ H, ∃ record ∈ extensionRecords, record.1 = q := + safe_collector_covers profile rounds lanes root claims strategy base _ + (fun trial accepted => accepted.1) η seed coverage + have covered : ∀ q ∈ H, ∃ record ∈ records, record.1 = q := + fun q member => baseRecords_covers root extensionRecords embedded q (coveredExtension q member) + have sizes := production_heavy_size profile _ η nonnegative large + have decoded := decodeAndCheck_of_heavy input records + (InitialCandidates.production_initial_facts profile).2.2.1 + (InitialCandidates.production_initial_facts profile).2.1 laneBound + (production_heavy_static profile).2.1 authenticated H covered sizes.1 sizes.2 certificate.witness + (fun q member lane => live_agrees_of_rowMatches input + (InitialCandidates.production_initial_facts profile).2.1 laneBound certificate.witness q + (certificate.matching q member) lane) + certificate.matching certificate.explains.2 + refine ⟨certificate.witness, ?_, certificate.explains⟩ + rw [extractor_run] + exact decoded + +#print axioms safeResetAccept_probability +#print axioms extractor_success_of_safe_coverage +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeHeavy.lean b/verification/whir/Whir/PCSRewindKnowledgeHeavy.lean new file mode 100644 index 000000000..9265115ef --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeHeavy.lean @@ -0,0 +1,140 @@ +import Whir.SupportedCandidateRecovery +import Whir.PCSRewindKnowledgePrefix + +/-! Exact heavy-support density arithmetic on all 56 source profiles. The +query envelope uses the MAXIMUM of Gao's integer half-distance cap and the +unchanged original commitment-list support threshold minus one. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open SamplingProbability AuthenticatedResetProbability AuthenticatedResetSupport + +set_option maxRecDepth 100000 +set_option maxHeartbeats 0 + +def gaoAgreementCap (profile : ParameterBounds.Profile) : Nat := + (blockLength (ParameterBounds.config profile) + width (ParameterBounds.config profile) - 1) / 2 + +/-- Gao radius AND the unchanged original commitment-list threshold must both +hold. At rate one the conservative list threshold is slightly above Gao's +half-distance threshold, so Gao radius alone is not a certificate. -/ +def heavyAgreementCap (profile : ParameterBounds.Profile) : Nat := + max (gaoAgreementCap profile) (ParameterBounds.threshold (ParameterBounds.config profile) 0 - 1) + +def heavyQueryLoss (profile : ParameterBounds.Profile) : ℚ := + ((heavyAgreementCap profile : ℚ) / blockLength (ParameterBounds.config profile)) ^ + (ParameterBounds.config profile).queries[0]! + +/-- Exact 56-profile bound uses actual varying query counts and both integer +thresholds; it never substitutes q=56 at rate one. -/ +theorem production_heavyQueryLoss : ∀ profile : ParameterBounds.Profile, + heavyQueryLoss profile ≤ radiusEnvelope := by + decide +kernel + +theorem production_heavy_static : ∀ p : ParameterBounds.Profile, + 0 < initialDepth p ∧ width (ParameterBounds.config p) < blockLength (ParameterBounds.config p) ∧ + ParameterBounds.threshold (ParameterBounds.config p) 0 ≤ heavyAgreementCap p + 1 := by + decide +kernel + +/-- Safe accepted mass above the exact query cap forces a common set large +enough for every live Gao lane AND the commitment-list certificate. -/ +theorem production_heavy_size (profile : ParameterBounds.Profile) + (accept : Trial (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (Suffix := E × Tape (ParameterBounds.config profile)) → Prop) + (η : ℝ) (nonnegative : 0 ≤ η) + (large : (heavyQueryLoss profile : ℝ) + blockLength (ParameterBounds.config profile) * η < + probability accept) : + let H := heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 accept η + 2 * (blockLength (ParameterBounds.config profile) - H.card) ≤ + blockLength (ParameterBounds.config profile) - width (ParameterBounds.config profile) ∧ + ParameterBounds.threshold (ParameterBounds.config profile) 0 ≤ H.card := by + dsimp only + have envelope : (((heavyAgreementCap profile : ℝ) / + blockLength (ParameterBounds.config profile)) ^ (ParameterBounds.config profile).queries[0]!) = + (heavyQueryLoss profile : ℝ) := by + simp [heavyQueryLoss, Rat.cast_div, Rat.cast_pow, Rat.cast_natCast] + have above := heavy_card_gt (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + accept η nonnegative (heavyAgreementCap profile) (by simpa only [envelope] using large) + have dimensions := (production_heavy_static profile).2 + have gao : gaoAgreementCap profile < + (heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 accept η).card := + (Nat.le_max_left _ _).trans_lt above + unfold gaoAgreementCap at gao + constructor <;> omega + +/-- Each available coordinate of a safe trial lies in its fixed agreement set. +This uses positive safe availability, not the fiction that all accepted +coordinates are true root rows. -/ +theorem heavy_subset_of_safe_hits (depth count : Nat) (positive : 0 < depth) (noWrap : depth ≤ 64) + {Suffix : Type*} [Fintype Suffix] [Nonempty Suffix] + (accept : Trial depth count (Suffix := Suffix) → Prop) + (η : ℝ) (ηpositive : 0 < η) (H : Finset (Fin (2 ^ depth))) + (hits : ∀ trial, accept trial → ∀ i, + RewindCoverage.sampledPosition depth count positive noWrap trial.1 i ∈ H) : + heavy depth count positive noWrap accept η ⊆ H := by + classical + intro q member + have available : η ≤ availability depth count positive noWrap accept q := by + simpa only [heavy, Finset.mem_filter, Finset.mem_univ, true_and] using member + by_contra outside + have empty : (fun trial => accept trial ∧ Occurs depth count positive noWrap q trial) = + (fun _ : Trial depth count (Suffix := Suffix) => False) := by + funext trial + apply propext + constructor + · rintro ⟨accepted, i, equal⟩ + exact outside (equal ▸ hits trial accepted i) + · simp + unfold availability at available + rw [empty] at available + simp [probability] at available + linarith + +/-- The analysis-safe subset is never tested by the executable collector. +Every accepted safe trial contributes its rows through the existing parser. -/ +theorem safe_collector_covers (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (base : Tape (ParameterBounds.config profile)) + (safeAccept : TrialSeed profile → Prop) + (safeAccepted : ∀ trial, safeAccept trial → + experiment (ExecutionShapes.Input profile lanes root claims) strategy + (fullResetTape (ExecutionShapes.Input profile lanes root claims) base + (initialLevel profile) (initialDepth profile) (initialChunks profile) trial.1 trial.2) = true) + (η : ℝ) (seed : Fin rounds → TrialSeed profile) + (coverage : CoversHeavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + safeAccept η rounds seed) : + let input := ExecutionShapes.Input profile lanes root claims + let records := collectedRecords ⟨input, strategy⟩ (initialLevel profile) (initialDepth profile) + (seedTapes profile rounds input rfl (base, seed)) + ∀ q ∈ heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 safeAccept η, + ∃ record ∈ records, record.1 = q := by + dsimp only + intro q member + obtain ⟨r, accepted, i, hit⟩ := coverage q member + obtain ⟨record, recorded, coordinate⟩ := trialRecords_contains + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ + (fullResetTape (ExecutionShapes.Input profile lanes root claims) base + (initialLevel profile) (initialDepth profile) (initialChunks profile) (seed r).1 (seed r).2) + (initialLevel profile) (initialDepth profile) (production_heavy_static profile).1 + (InitialCandidates.production_initial_facts profile).2.2.1 (seed r).1 + (fullResetTape_squeezes _ _ _ _ _ _ _) (safeAccepted (seed r) accepted) i + refine ⟨record, List.mem_flatMap.mpr ⟨_, ?_, recorded⟩, coordinate.trans hit⟩ + exact List.mem_ofFn.mpr ⟨r, rfl⟩ + +/-- Literal base projection cannot discard an authenticated Root0 record. -/ +theorem baseRecords_covers {N : Nat} (root : BaseOracle) (records : List (Fin N × Array E)) + (authenticated : ∀ record ∈ records, record.2 = (root[record.1.val]!).map E.ofK) + (q : Fin N) (covered : ∃ record ∈ records, record.1 = q) : + ∃ record ∈ baseRecords records, record.1 = q := by + obtain ⟨record, recorded, coordinate⟩ := covered + refine ⟨(record.1, root[record.1.val]!), List.mem_filterMap.mpr ⟨record, recorded, ?_⟩, coordinate⟩ + rw [authenticated record recorded, baseRow_embedded] + rfl + +#print axioms production_heavy_size +#print axioms heavy_subset_of_safe_hits +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeMass.lean b/verification/whir/Whir/PCSRewindKnowledgeMass.lean new file mode 100644 index 000000000..ea24fdc65 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeMass.lean @@ -0,0 +1,73 @@ +import Whir.PCSRewindKnowledgeProduction + +/-! A pointwise mass bound lets fresh public compression be averaged without +assuming that every public prefix has the overall acceptance advantage. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open SamplingProbability AuthenticatedResetProbability AuthenticatedResetSupport +open ResetAcceptanceAmplification + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 100000 +attribute [local irreducible] ParameterBounds.config + + theorem production_single_attempt_mass (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) (gap : ℝ) (gapPositive : 0 < gap) + (large : (knowledgeBadEnvelope : ℝ) + 2 * (heavyQueryLoss profile : ℝ) + gap < + probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true)) : + (probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) - + (knowledgeBadEnvelope : ℝ)) / 4 ≤ + probability (extractionSuccess (extractor profile (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩) := by + classical + have acceptanceLeOne := le_one + (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) + have lossNonnegative : (0 : ℝ) ≤ (heavyQueryLoss profile : ℝ) := by + unfold heavyQueryLoss + positivity + have badNonnegative : (0 : ℝ) ≤ (knowledgeBadEnvelope : ℝ) := by + norm_num [knowledgeBadEnvelope] + have gapLeOne : gap ≤ 1 := by linarith + let safe := fun draw : Tape (ParameterBounds.config profile) × TrialSeed profile => + safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) draw.1 draw.2 + have mass := production_safe_mass profile lanes root claims strategy laneBound claimShape claimCap + have conditional : ∀ base, GoodPrefix safe base → + 1 - (1 / 4 : ℝ) ≤ probability (fun seed : Fin (knowledgeRounds profile gap) → TrialSeed profile => + extractionSuccess (extractor profile (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ (base, seed)) := by + intro base good + have conditionalMass := good + change probability safe / 2 ≤ probability _ at conditionalMass + have scale : (blockLength (ParameterBounds.config profile) : ℝ) * heavyAvailability profile gap = gap / 4 := by + unfold heavyAvailability + push_cast + field_simp [show (blockLength (ParameterBounds.config profile) : ℝ) ≠ 0 by positivity] + have heavyMass : (heavyQueryLoss profile : ℝ) + + blockLength (ParameterBounds.config profile) * heavyAvailability profile gap < + probability (safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) base) := by + rw [scale] + dsimp only [safe] at conditionalMass + linarith + let certificate := Classical.choice (production_heavy_witness profile lanes root claims strategy base + (heavyAvailability profile gap) (heavyAvailability_positive profile gap gapPositive) heavyMass) + have recovered := conditional_extractor_schedule profile lanes root claims strategy laneBound + (productionBad profile lanes root claims strategy) base (heavyAvailability profile gap) + (heavyAvailability_positive profile gap gapPositive) (heavyAvailability_le_one profile gap gapLeOne) + (availabilityBlock profile gap) 0 (availabilityBlock_enough profile gap gapPositive) heavyMass certificate + change 1 - (1 / 4 : ℝ) * (1 / 2 : ℝ) ^ 0 ≤ _ at recovered + convert recovered using 1 <;> simp only [knowledgeRounds, pow_zero, mul_one] + unfold probability + congr 1 + have chance := prefix_attempt_chance safe + (extractionSuccess (extractor profile (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩) + (1 / 4 : ℝ) (by norm_num) (by norm_num) conditional + dsimp only [safe] at chance + nlinarith + +#print axioms production_single_attempt_mass +#check production_single_attempt_mass +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeOriginalBound.lean b/verification/whir/Whir/PCSRewindKnowledgeOriginalBound.lean new file mode 100644 index 000000000..42da722e6 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeOriginalBound.lean @@ -0,0 +1,82 @@ +import Whir.PCSRewindKnowledgeOriginalRepeated +import Whir.PCSRewindSourceRelation +import Whir.ExtractorArithmeticCostSourceComparisons + +/-! Complete interactive reset-extraction endpoints for the original statement. +The acceptance probability chooses proof fuel, not an executable probability +estimator. Runtime charges the actual source machine and literal admitted reply +words, with external prover computation outside the unit-oracle boundary. -/ +namespace Whir.PCSRewindSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open PCSRewindExtractor SamplingProbability OriginalClaimsChecker +open scoped BigOperators + +set_option maxHeartbeats 4000000 +attribute [local irreducible] ParameterBounds.config + +theorem complete_original_knowledge {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) + (familyCap : m ≤ 2 ^ 64) (claimCap : points.size + 2 ≤ 2 ^ 64) (security : Nat) : + let κ := probability (accepted profile lanes family points anchorPoint anchorValue root strategy) + let gap := κ - (extractionCutoff : ℝ) + let attempts := sourceAttempts gap security + let rounds := sourceRounds profile gap + (∀ seed : RepeatedSeed profile attempts rounds, + ∀ w : Witness (ParameterBounds.config profile) lanes, + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).output = some w → + ExplainsOriginal (ParameterBounds.config profile) lanes root family points anchorPoint anchorValue w) ∧ + probability (failureEvent profile attempts rounds lanes family points anchorPoint anchorValue root strategy) ≤ + (extractionCutoff : ℝ) + (1 / 2 : ℝ) ^ security ∧ + (0 < gap → + (rounds : ℝ) ≤ ((8 * blockLength (ParameterBounds.config profile) : ℝ) / gap + 1) * + ((initialDepth profile : ℝ) + 2) ∧ + (attempts : ℝ) ≤ ((8 : ℝ) / gap + 1) * security) := by + dsimp only + refine ⟨?_, universal_knowledge_failure profile lanes family points anchorPoint anchorValue root strategy + familyCap claimCap security, ?_⟩ + · intro seed w output + exact run_output_explains profile _ _ lanes family points anchorPoint anchorValue root strategy seed w output + · intro positive + exact ⟨sourceRounds_polynomial profile _ positive, sourceAttempts_polynomial _ positive security⟩ + +/-- Profile tables discharge challenge-shape and redundancy requirements even for +malformed or withholding strategies. The root rectangle, occupied-lane limit, +and literal reply-word admission remain explicit physical input restrictions. -/ +theorem complete_original_resource {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seed : RepeatedSeed profile attempts rounds) (encodedWords : Nat) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (admitted : (ExtractorArithmeticCostSource.run profile attempts rounds lanes family points anchorPoint anchorValue + root strategy seed).encodedReplyWords ≤ encodedWords) : + let c := ParameterBounds.config profile + let measured := ExtractorArithmeticCostSource.run profile attempts rounds lanes family points anchorPoint anchorValue + root strategy seed + measured.fieldArithmetic + measured.responseCalls + measured.encodedReplyWords + + ExtractorArithmeticCostSource.originalReservation c lanes attempts family points anchorPoint anchorValue + + (∑ i, ExtractorArithmeticCostSource.retainedCharge profile rounds lanes family points anchorPoint anchorValue + prepared root strategy (seed i)) + + (∑ i, ExtractorArithmeticCostSource.commonComparisonReservation c + (ExtractorArithmeticCostSource.sourceRecords profile rounds lanes family points anchorPoint anchorValue + prepared root strategy (seed i)).length) ≤ + ExtractorArithmeticCostSource.physicalSourceFieldPolynomial (laneCount c) lanes (2 ^ c.logN) + (blockLength c) m points.size c.folds.size attempts rounds 6 256 256 c.logN + + attempts * ((rounds * streamLength c) * (streamLength c + 1)) + encodedWords + + ExtractorArithmeticCostSource.originalReservationPolynomial c m points.size attempts + + attempts * ExtractorArithmeticCost.retainedPreparationPolynomial c rounds lanes (points.size + 2) + + attempts * ExtractorArithmeticCostSource.commonComparisonPolynomial c rounds := by + exact ExtractorArithmeticCostSource.run_complete_physical_resource profile attempts rounds lanes family points + anchorPoint anchorValue prepared root strategy seed 6 256 256 (ParameterBounds.config profile).logN encodedWords + (production_challenge_input profile) (production_heavy_static profile).2.1 physicalRoot physicalLanes + prepared.guards.2.2.2.1 admitted + +#print axioms complete_original_knowledge +#print axioms complete_original_resource +#check complete_original_knowledge +#check complete_original_resource +end Whir.PCSRewindSource diff --git a/verification/whir/Whir/PCSRewindKnowledgeOriginalChance.lean b/verification/whir/Whir/PCSRewindKnowledgeOriginalChance.lean new file mode 100644 index 000000000..9f04dd3c2 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeOriginalChance.lean @@ -0,0 +1,185 @@ +import Whir.PCSRewindKnowledgeMass +import Whir.PCSRewindKnowledgeOriginalRecovery + +/-! Fresh public prefixes are averaged pointwise. A rare accepting bad map is +charged, never assumed away or given the overall acceptance advantage. -/ +namespace Whir.PCSRewindSource +open Concrete Protocol CausalGame KnowledgeExtraction OriginalClaimsChecker +open PCSRewindExtractor SamplingProbability AuthenticatedResetProbability +open SupportedCandidateExtraction +open scoped BigOperators + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 100000 +attribute [local irreducible] ParameterBounds.config + +theorem input_shapes {c : Config} {lanes m : Nat} + {family : Fin m → RingPCSGame.FamilyClaim} {points : Array RingPCSGame.PointClaim} + {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (r : RingPCSGame.Prefix) + (j : Fin (OriginalClaimsChecker.input prepared root r).claims.size) : + (OriginalClaimsChecker.input prepared root r).claims[j].weight.size = 2 ^ c.logN := by + have old : ∀ claim ∈ (RingPCSGame.transformedClaims (2 ^ c.logN) family points r).toList, + claim.weight.size = 2 ^ c.logN := by + intro claim member + obtain ⟨i, within, rfl⟩ := Array.mem_iff_getElem.mp (Array.mem_toList_iff.mp member) + exact RingPCSGame.transformedClaims_shapes _ family points r ⟨i, within⟩ + have all : ∀ claim ∈ (OriginalClaimsChecker.input prepared root r).claims.toList, + claim.weight.size = 2 ^ c.logN := by + intro claim member + rw [input_claims, Array.toList_push] at member + rcases List.mem_append.mp member with member | member + · exact old claim member + · have eq : claim = (⟨CommitmentAnchor.weight c lanes anchorPoint, anchorValue⟩ : Claim) := by + simpa using member + simp [eq, CommitmentAnchor.weight, ArrayLayout.size_tab] + exact all _ (by simp) + +theorem input_size {c : Config} {lanes m : Nat} + {family : Fin m → RingPCSGame.FamilyClaim} {points : Array RingPCSGame.PointClaim} + {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (r : RingPCSGame.Prefix) : + (OriginalClaimsChecker.input prepared root r).claims.size = points.size + 2 := by + rw [input_claims] + simp [RingPCSGame.transformedClaims_size, Nat.add_comm, Nat.add_left_comm] + +/-- Any actual returned word is separately covered by run_output_explains. -/ +def attemptSuccess {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : Seed profile rounds) : Prop := + ∃ w, (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output = some w + +open Classical in +/-- The probability bound is algebra on the actual product games, with no +per-prefix acceptance assumption hidden in its premise. -/ +theorem average_attempt_mass {R A S : Type*} [Fintype R] [Nonempty R] + [Fintype A] [Nonempty A] [Fintype S] [Nonempty S] + (accept : R × A → Prop) (success : R × S → Prop) (bad : R → Prop) (threshold : ℝ) + (pointwise : ∀ r, (probability (fun a => accept (r, a)) - threshold - + (if bad r then 1 else 0)) / 4 ≤ probability (fun s => success (r, s))) : + (probability accept - threshold - probability bad) / 4 ≤ probability success := by + classical + have badAverage : probability bad = (∑ r, if bad r then (1 : ℝ) else 0) / Fintype.card R := by + have single : ∀ r, probability (fun _ : Unit => bad r) = if bad r then (1 : ℝ) else 0 := by + intro r + by_cases h : bad r <;> simp [probability, h] + have avg := probability_average (fun seed : R × Unit => bad seed.1) + rw [product_left] at avg + simpa only [single] using avg + have sumBound := Finset.sum_le_sum (s := (Finset.univ : Finset R)) (fun r _ => pointwise r) + have cardPositive : (0 : ℝ) < Fintype.card R := by exact_mod_cast Fintype.card_pos + rw [probability_average accept, probability_average success, badAverage] + calc + ((∑ r, probability (fun a => accept (r, a))) / Fintype.card R - threshold - + (∑ r, if bad r then (1 : ℝ) else 0) / Fintype.card R) / 4 = + (∑ r, (probability (fun a => accept (r, a)) - threshold - + (if bad r then (1 : ℝ) else 0)) / 4) / Fintype.card R := by + simp only [← Finset.sum_div, Finset.sum_sub_distrib, Finset.sum_const, + Finset.card_univ, nsmul_eq_mul] + field_simp [ne_of_gt cardPositive] + _ ≤ (∑ r, probability (fun s => success (r, s))) / Fintype.card R := + div_le_div_of_nonneg_right sumBound cardPositive.le + +theorem original_attempt_mass {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (claimCap : points.size + 2 ≤ 2 ^ 64) (gap : ℝ) (gapPositive : 0 < gap) : + (probability (fun seed : RingPCSGame.Prefix × Tape (ParameterBounds.config profile) => + experiment (OriginalClaimsChecker.input prepared root seed.1) (strategy seed.1) seed.2 = true) - + ((knowledgeBadEnvelope : ℝ) + 2 * (heavyQueryLoss profile : ℝ) + gap) - + probability (RingPCSGame.Escape (ParameterBounds.config profile) lanes root family)) / 4 ≤ + probability (attemptSuccess profile (knowledgeRounds profile gap) lanes family points + anchorPoint anchorValue prepared root strategy) := by + classical + apply average_attempt_mass + intro r + let claims := (OriginalClaimsChecker.input prepared root r).claims + change (probability (fun tape : Tape (ParameterBounds.config profile) => + experiment (ExecutionShapes.Input profile lanes root claims) (strategy r) tape = true) - + ((knowledgeBadEnvelope : ℝ) + 2 * (heavyQueryLoss profile : ℝ) + gap) - + (if RingPCSGame.Escape (ParameterBounds.config profile) lanes root family r then 1 else 0)) / 4 ≤ + probability (fun seed : PCSRewindExtractor.Seed profile (knowledgeRounds profile gap) => + attemptSuccess profile (knowledgeRounds profile gap) lanes family points + anchorPoint anchorValue prepared root strategy (r, seed)) + have actualCap : claims.size ≤ 2 ^ 64 := by + dsimp only [claims] + rw [input_size] + exact claimCap + have actualShapes : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN := + input_shapes prepared root r + have acceptedLeOne := le_one (fun tape : Tape (ParameterBounds.config profile) => + experiment (ExecutionShapes.Input profile lanes root claims) (strategy r) tape = true) + have sourceNonnegative := nonneg (fun seed : PCSRewindExtractor.Seed profile (knowledgeRounds profile gap) => + attemptSuccess profile (knowledgeRounds profile gap) lanes family points + anchorPoint anchorValue prepared root strategy (r, seed)) + have thresholdNonnegative : (0 : ℝ) ≤ + (knowledgeBadEnvelope : ℝ) + 2 * (heavyQueryLoss profile : ℝ) + gap := by + have : (0 : ℝ) ≤ (heavyQueryLoss profile : ℝ) := by unfold heavyQueryLoss; positivity + have : (0 : ℝ) ≤ (knowledgeBadEnvelope : ℝ) := by norm_num [knowledgeBadEnvelope] + linarith + by_cases escaped : RingPCSGame.Escape (ParameterBounds.config profile) lanes root family r + · simp only [escaped, ite_true] + linarith + · simp only [escaped, ite_false, sub_zero] + by_cases large : (knowledgeBadEnvelope : ℝ) + 2 * (heavyQueryLoss profile : ℝ) + gap < + probability (fun tape : Tape (ParameterBounds.config profile) => + experiment (ExecutionShapes.Input profile lanes root claims) (strategy r) tape = true) + · have generic := production_single_attempt_mass profile lanes root claims (strategy r) + prepared.guards.2.2.2.1 actualShapes actualCap gap gapPositive large + have dominates := mono + (extractionSuccess (extractor profile (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy r⟩) + (fun seed => attemptSuccess profile (knowledgeRounds profile gap) lanes family points + anchorPoint anchorValue prepared root strategy (r, seed)) (by + intro seed success + obtain ⟨w, returned, _⟩ := success + exact ⟨w, runOne_recovers_generic profile _ lanes family points anchorPoint anchorValue + prepared root strategy (r, seed) escaped w returned⟩) + have heavyNonnegative : (0 : ℝ) ≤ (heavyQueryLoss profile : ℝ) := by unfold heavyQueryLoss; positivity + change (probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) (strategy r) tape = true) - + ((knowledgeBadEnvelope : ℝ) + 2 * (heavyQueryLoss profile : ℝ) + gap)) / 4 ≤ _ + linarith + · linarith + +/-- The extra public-map loss fits inside the already proved numerical margin; +the unchanged q56 cutoff is not rounded into a security level. -/ +theorem original_amplified_cutoff (profile : ParameterBounds.Profile) (m : Nat) (cap : m ≤ 2 ^ 64) : + (2 * heavyQueryLoss profile + knowledgeBadEnvelope + ringEscapeLoss m : ℚ) < extractionCutoff := by + have margin := production_amplified_cutoff profile + have ring := ringEscapeLoss_le m cap + have small : (1 / (2 ^ 95 : ℚ)) < 1 / (2 ^ 55 : ℚ) := by norm_num + linarith + +theorem original_single_attempt_chance {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (familyCap : m ≤ 2 ^ 64) (claimCap : points.size + 2 ≤ 2 ^ 64) + (gap : ℝ) (gapPositive : 0 < gap) + (advantage : (extractionCutoff : ℝ) + gap ≤ + probability (fun seed : RingPCSGame.Prefix × Tape (ParameterBounds.config profile) => + experiment (OriginalClaimsChecker.input prepared root seed.1) (strategy seed.1) seed.2 = true)) : + gap / 8 ≤ probability (attemptSuccess profile (knowledgeRounds profile (gap / 2)) lanes family points + anchorPoint anchorValue prepared root strategy) := by + have mass := original_attempt_mass profile lanes family points anchorPoint anchorValue prepared root strategy + claimCap (gap / 2) (by positivity) + have escape := ring_escape_probability profile lanes root family + have margin : 2 * (heavyQueryLoss profile : ℝ) + knowledgeBadEnvelope + ringEscapeLoss m < extractionCutoff := by + exact_mod_cast original_amplified_cutoff profile m familyCap + linarith + +#print axioms input_shapes +#print axioms input_size +#print axioms average_attempt_mass +#print axioms original_attempt_mass +#print axioms original_amplified_cutoff +#print axioms original_single_attempt_chance +#check original_single_attempt_chance +end Whir.PCSRewindSource diff --git a/verification/whir/Whir/PCSRewindKnowledgeOriginalProbability.lean b/verification/whir/Whir/PCSRewindKnowledgeOriginalProbability.lean new file mode 100644 index 000000000..b496e976b --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeOriginalProbability.lean @@ -0,0 +1,103 @@ +import Whir.RingPCSGame +import Whir.AnchorPrefixRefinementCaller +import Whir.PCSRewindKnowledgePrefix + +/-! Original-family truth is not inferred from a compressed claim alone. This +bridge uses the actual fixed-root ring escape event and the SAME supported word +returned by the authenticated collector. -/ +namespace Whir.PCSRewindSource +open Concrete Protocol CausalGame +open SamplingProbability AuthenticatedResetProbability + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 100000 + +noncomputable def ringEscapeLoss (families : Nat) : ℚ := + (2 ^ 32 : ℚ) * (((families - 1 : Nat) : ℚ) / 2 ^ 192 + 1 / 2 ^ 160) + +theorem ring_escape_probability {m : Nat} (p : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (family : Fin m → RingPCSGame.FamilyClaim) : + probability (RingPCSGame.Escape (ParameterBounds.config p) lanes root family) ≤ + (ringEscapeLoss m : ℝ) := by + classical + rw [probability_eq_uniformProb] + apply Rat.cast_le.mpr + exact RingPCSGame.escape_probability p lanes root family + +theorem ringEscapeLoss_le (m : Nat) (cap : m ≤ 2 ^ 64) : + ringEscapeLoss m ≤ 1 / (2 ^ 95 : ℚ) := by + have size : ((m - 1 : Nat) : ℚ) ≤ (2 ^ 64 : ℚ) := by + exact_mod_cast (Nat.sub_le m 1).trans cap + unfold ringEscapeLoss + calc + (2 ^ 32 : ℚ) * (((m - 1 : Nat) : ℚ) / 2 ^ 192 + 1 / 2 ^ 160) ≤ + (2 ^ 32 : ℚ) * ((2 ^ 64 : ℚ) / 2 ^ 192 + 1 / 2 ^ 160) := by + gcongr + _ ≤ 1 / (2 ^ 95 : ℚ) := by norm_num + +/-- Outside the actual compression escape, all transformed claims imply all +original family slices, every ordinary/strided point, and the literal retained +anchor, for the SAME root-list word. -/ +theorem original_truth_of_anchored_claims {m : Nat} (c : Config) + (record : AnchoredHeaderCodec.Record) (root : BaseOracle) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (r : RingPCSGame.Prefix) (w : Witness c record.shape.lanes) + (member : w ∈ InitialCandidates.witnesses c record.shape.lanes root) + (outside : ¬ RingPCSGame.Escape c record.shape.lanes root family r) + (pointShape : record.point.length = c.logN) + (truth : ∀ claim ∈ (AnchorPrefixRefinement.anchoredClaims c record family points r).toList, + dot (paddedWitness c record.shape.lanes w) claim.weight = claim.value) : + RingPCSGame.Honest c record.shape.lanes family points w ∧ + CommitmentAnchor.value c record.shape.lanes w record.point.toArray = record.value := by + classical + have oldTruth : ∀ claim ∈ (RingPCSGame.transformedClaims (2 ^ c.logN) family points r).toList, + dot (paddedWitness c record.shape.lanes w) claim.weight = claim.value := by + intro claim old + apply truth claim + simp only [AnchorPrefixRefinement.anchoredClaims, Array.toList_push, List.mem_append] + exact Or.inl old + have compressed := oldTruth (RingPCSGame.familyPublic (2 ^ c.logN) family r) + (by simp [RingPCSGame.transformedClaims]) + rw [RingPCSGame.dot_family] at compressed + have slices : (fun j => (family j).slices) = RingPCSGame.honestSlices c record.shape.lanes family w := by + by_contra different + exact outside ⟨w, member, different, compressed.symm⟩ + refine ⟨⟨slices, ?_⟩, ?_⟩ + · intro point present + apply oldTruth (RingPCSGame.publicPoint (2 ^ c.logN) point) + simp only [RingPCSGame.transformedClaims, Array.toList_append, Array.toList_map, + List.mem_append, List.mem_map] + exact Or.inr ⟨point, present, rfl⟩ + · have anchor := truth + (⟨CommitmentAnchor.weight c record.shape.lanes record.point.toArray, record.value⟩ : Claim) + (by simp [AnchorPrefixRefinement.anchoredClaims]) + rw [CommitmentAnchor.weight_value c record.shape.lanes w record.point.toArray + (by simpa using pointShape)] at anchor + exact anchor + +/-- The actual ring escape loss is unchanged when the adversary's complete +WHIR tape is included in the public-prefix experiment. -/ +theorem joint_ring_escape_probability {m : Nat} (p : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (family : Fin m → RingPCSGame.FamilyClaim) : + probability (fun seed : RingPCSGame.Prefix × Tape (ParameterBounds.config p) => + RingPCSGame.Escape (ParameterBounds.config p) lanes root family seed.1) ≤ + (ringEscapeLoss m : ℝ) := by + classical + rw [probability_eq_uniformProb] + apply Rat.cast_le.mpr + have bound := RingMapBatching.conditional_error + (RingPCSGame.Escape (ParameterBounds.config p) lanes root family) + (fun seed : RingPCSGame.Prefix × Tape (ParameterBounds.config p) => + RingPCSGame.Escape (ParameterBounds.config p) lanes root family seed.1) + (ringEscapeLoss m) 0 (by norm_num) + (RingPCSGame.escape_probability p lanes root family) + (by + intro r outside + simp [outside, Soundness.uniformProb]) + simpa using bound + +#print axioms ring_escape_probability +#print axioms ringEscapeLoss_le +#print axioms original_truth_of_anchored_claims +#print axioms joint_ring_escape_probability +end Whir.PCSRewindSource diff --git a/verification/whir/Whir/PCSRewindKnowledgeOriginalRecovery.lean b/verification/whir/Whir/PCSRewindKnowledgeOriginalRecovery.lean new file mode 100644 index 000000000..ca3b23d6c --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeOriginalRecovery.lean @@ -0,0 +1,83 @@ +import Whir.PCSRewindSourceRelation +import Whir.PCSRewindKnowledgeOriginalProbability + +/-! Outside the actual fixed-root compression escape, a generic recovered +candidate passes the actual original-family checker, not a compressed proxy. -/ +namespace Whir.PCSRewindSource +open Concrete Protocol CausalGame KnowledgeExtraction OriginalClaimsChecker +open PCSRewindExtractor + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 100000 +attribute [local irreducible] ParameterBounds.config + + theorem input_checked_of_explains {c : Config} {lanes m : Nat} + {family : Fin m → RingPCSGame.FamilyClaim} {points : Array RingPCSGame.PointClaim} + {anchorPoint : Array E} {anchorValue : E} + (prepared : Prepared c lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (r : RingPCSGame.Prefix) (w : Witness c lanes) + (outside : ¬ RingPCSGame.Escape c lanes root family r) + (explains : Explains (OriginalClaimsChecker.input prepared root r) w) : + OriginalClaimsChecker.check prepared w = true := by + classical + have allTruth : ∀ claim ∈ ((RingPCSGame.transformedClaims (2 ^ c.logN) family points r).push + ⟨CommitmentAnchor.weight c lanes anchorPoint, anchorValue⟩).toList, + dot (paddedWitness c lanes w) claim.weight = claim.value := by + rw [← input_claims prepared root r] + exact explains.2 + have oldTruth : ∀ claim ∈ (RingPCSGame.transformedClaims (2 ^ c.logN) family points r).toList, + dot (paddedWitness c lanes w) claim.weight = claim.value := by + intro claim member + apply allTruth claim + simp only [Array.toList_push, List.mem_append] + exact Or.inl member + have compressed := oldTruth (RingPCSGame.familyPublic (2 ^ c.logN) family r) + (by simp [RingPCSGame.transformedClaims]) + rw [RingPCSGame.dot_family] at compressed + have slices : (fun j => (family j).slices) = RingPCSGame.honestSlices c lanes family w := by + by_contra different + exact outside ⟨w, explains.1, different, compressed.symm⟩ + apply (check_iff prepared w).mpr + refine ⟨⟨slices, ?_⟩, ?_⟩ + · intro point member + apply oldTruth (RingPCSGame.publicPoint (2 ^ c.logN) point) + simp only [RingPCSGame.transformedClaims, Array.toList_append, Array.toList_map, + List.mem_append, List.mem_map] + exact Or.inr ⟨point, member, rfl⟩ + · have anchor := allTruth + (⟨CommitmentAnchor.weight c lanes anchorPoint, anchorValue⟩ : Claim) + (by simp) + rw [CommitmentAnchor.weight_value c lanes w anchorPoint prepared.guards.2.2.2.2.1] at anchor + exact anchor + + theorem runOne_recovers_generic {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : Seed profile rounds) + (outside : ¬ RingPCSGame.Escape (ParameterBounds.config profile) lanes root family seed.1) + (w : Witness (ParameterBounds.config profile) lanes) + (output : (runRewind (OriginalClaimsChecker.input prepared root seed.1) (strategy seed.1) + (extractor profile rounds).maxReplay (extractor profile rounds).rewindRounds + ((extractor profile rounds).program (OriginalClaimsChecker.input prepared root seed.1) seed.2)).output = some w) : + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output = some w := by + let claims := (OriginalClaimsChecker.input prepared root seed.1).claims + change (runRewind (ExecutionShapes.Input profile lanes root claims) (strategy seed.1) + (extractor profile rounds).maxReplay (extractor profile rounds).rewindRounds + ((extractor profile rounds).program (ExecutionShapes.Input profile lanes root claims) seed.2)).output = some w at output + have explains : Explains (OriginalClaimsChecker.input prepared root seed.1) w := by + change Explains (ExecutionShapes.Input profile lanes root claims) w + exact extractor_output_explains profile rounds lanes root claims (strategy seed.1) seed.2 + prepared.guards.2.2.2.1 w output + have checked := input_checked_of_explains prepared root seed.1 w outside explains + rw [extractor_run] at output + rw [runOne_value] + dsimp only at output ⊢ + apply decodedWithFinal_recover (OriginalClaimsChecker.input prepared root seed.1) _ _ _ w + · exact output + · exact checked + +#print axioms input_checked_of_explains +#print axioms runOne_recovers_generic +#check runOne_recovers_generic +end Whir.PCSRewindSource diff --git a/verification/whir/Whir/PCSRewindKnowledgeOriginalRepeated.lean b/verification/whir/Whir/PCSRewindKnowledgeOriginalRepeated.lean new file mode 100644 index 000000000..d6fe4aedd --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeOriginalRepeated.lean @@ -0,0 +1,216 @@ +import Whir.PCSRewindKnowledgeOriginalChance + +/-! The repeated source machine stops only on an original-checked word. Its +failure probability is derived from actual independent seeds, not a supplied +availability event. The fuel is proof-chosen; the executable machine does not +compute the unknown prover acceptance probability. -/ +namespace Whir.PCSRewindSource +open Concrete Protocol CausalGame KnowledgeExtraction OriginalClaimsChecker +open PCSRewindExtractor SupportedCandidateExtraction SamplingProbability +open AuthenticatedResetProbability ResetAcceptanceAmplification + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 100000 +attribute [local irreducible] ParameterBounds.config + +noncomputable instance sourceRepeatedSeedFintype (profile : ParameterBounds.Profile) (attempts rounds : Nat) : + Fintype (RepeatedSeed profile attempts rounds) := by + letI : Fintype (Seed profile rounds) := inferInstanceAs + (Fintype (RingPCSGame.Prefix × PCSRewindExtractor.Seed profile rounds)) + exact inferInstanceAs (Fintype (Fin attempts → Seed profile rounds)) + +noncomputable def sourceRounds (profile : ParameterBounds.Profile) (gap : ℝ) : Nat := + knowledgeRounds profile (gap / 2) + +noncomputable def sourceAttempts (gap : ℝ) (security : Nat) : Nat := + extractorAttempts (inverseGapBlock 8 gap) security + +abbrev AcceptanceSeed (profile : ParameterBounds.Profile) := + RingPCSGame.Prefix × Tape (ParameterBounds.config profile) + +/-- The actual source public preparation guard is part of the accepted event; +malformed dimensions are not granted generic dense-kernel acceptance. -/ +def accepted {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : AcceptanceSeed profile) : Prop := + match prepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue with + | none => False + | some prepared => experiment (OriginalClaimsChecker.input prepared root seed.1) (strategy seed.1) seed.2 = true + +def failureEvent {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) + (draw : RepeatedSeed profile attempts rounds × AcceptanceSeed profile) : Prop := + accepted profile lanes family points anchorPoint anchorValue root strategy draw.2 ∧ + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy draw.1).output = none + +theorem attempts_failure_probability {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) : + probability (fun seed : RepeatedSeed profile attempts rounds => + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy (List.ofFn seed)).output = none) = + (1 - probability (attemptSuccess profile rounds lanes family points anchorPoint anchorValue prepared root strategy)) ^ attempts := by + classical + have one : ∀ seed : Seed profile rounds, + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output = none ↔ + ¬ attemptSuccess profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed := by + intro seed + cases value : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output <;> + simp [attemptSuccess, value] + have events : (fun seed : RepeatedSeed profile attempts rounds => + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy (List.ofFn seed)).output = none) = + (fun seed => ∀ r, ¬ attemptSuccess profile rounds lanes family points anchorPoint anchorValue prepared root strategy (seed r)) := by + funext seed + apply propext + rw [runAttempts_output_none_iff] + constructor + · intro all r + exact (one (seed r)).mp (all _ (List.mem_ofFn.mpr ⟨r, rfl⟩)) + · intro all value member + obtain ⟨r, rfl⟩ := List.mem_ofFn.mp member + exact (one (seed r)).mpr (all r) + rw [events] + exact independent_misses _ attempts + +theorem prepared_repeated_failure {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (familyCap : m ≤ 2 ^ 64) (claimCap : points.size + 2 ≤ 2 ^ 64) + (gap : ℝ) (gapPositive : 0 < gap) (security : Nat) + (advantage : (extractionCutoff : ℝ) + gap ≤ + probability (fun seed : AcceptanceSeed profile => + experiment (OriginalClaimsChecker.input prepared root seed.1) (strategy seed.1) seed.2 = true)) : + probability (fun seed : RepeatedSeed profile (sourceAttempts gap security) (sourceRounds profile gap) => + (runAttempts profile (sourceRounds profile gap) lanes family points anchorPoint anchorValue prepared root strategy + (List.ofFn seed)).output = none) ≤ (1 / 2 : ℝ) ^ security := by + have chance : gap / 8 ≤ probability (attemptSuccess profile (sourceRounds profile gap) lanes family points + anchorPoint anchorValue prepared root strategy) := + original_single_attempt_chance profile lanes family points anchorPoint anchorValue prepared root strategy + familyCap claimCap gap gapPositive advantage + have sourceLeOne := le_one (attemptSuccess profile (sourceRounds profile gap) lanes family points + anchorPoint anchorValue prepared root strategy) + have gapLeOne : gap / 8 ≤ 1 := chance.trans sourceLeOne + rw [attempts_failure_probability] + have amplified := attempt_schedule_failure (gap / 8) (by positivity) gapLeOne + (inverseGapBlock 8 gap) security (inverseGapBlock_enough 8 (by decide) gap gapPositive) + exact (pow_le_pow_left₀ (sub_nonneg.mpr sourceLeOne) (sub_le_sub_left chance 1) _).trans amplified + +theorem repeated_knowledge_failure {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) + (familyCap : m ≤ 2 ^ 64) (claimCap : points.size + 2 ≤ 2 ^ 64) + (gap : ℝ) (gapPositive : 0 < gap) (security : Nat) + (advantage : (extractionCutoff : ℝ) + gap ≤ + probability (accepted profile lanes family points anchorPoint anchorValue root strategy)) : + probability (failureEvent profile (sourceAttempts gap security) (sourceRounds profile gap) lanes family points + anchorPoint anchorValue root strategy) ≤ (1 / 2 : ℝ) ^ security := by + classical + cases prepared : prepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue with + | none => + have noAcceptance : accepted profile lanes family points anchorPoint anchorValue root strategy = (fun _ => False) := by + funext seed + simp only [accepted, prepared] + have noFailure : failureEvent profile (sourceAttempts gap security) (sourceRounds profile gap) lanes family points + anchorPoint anchorValue root strategy = (fun _ => False) := by + funext draw + simp only [failureEvent, noAcceptance, false_and] + rw [noFailure] + have zero : probability (fun _ : RepeatedSeed profile (sourceAttempts gap security) (sourceRounds profile gap) × + AcceptanceSeed profile => False) = 0 := by simp [probability] + rw [zero] + positivity + | some cached => + have acceptedEq : accepted profile lanes family points anchorPoint anchorValue root strategy = + (fun seed : AcceptanceSeed profile => + experiment (OriginalClaimsChecker.input cached root seed.1) (strategy seed.1) seed.2 = true) := by + funext seed + simp only [accepted, prepared] + rw [acceptedEq] at advantage + have chance := prepared_repeated_failure profile lanes family points anchorPoint anchorValue cached root strategy + familyCap claimCap gap gapPositive security advantage + have dominated := mono (failureEvent profile (sourceAttempts gap security) (sourceRounds profile gap) lanes family points + anchorPoint anchorValue root strategy) + (fun draw => (runAttempts profile (sourceRounds profile gap) lanes family points anchorPoint anchorValue cached root strategy + (List.ofFn draw.1)).output = none) (by + intro draw failed + simpa only [run, prepared] using failed.2) + have projection : probability (fun draw : RepeatedSeed profile (sourceAttempts gap security) + (sourceRounds profile gap) × AcceptanceSeed profile => + (runAttempts profile (sourceRounds profile gap) lanes family points anchorPoint anchorValue cached root strategy + (List.ofFn draw.1)).output = none) = + probability (fun seed : RepeatedSeed profile (sourceAttempts gap security) (sourceRounds profile gap) => + (runAttempts profile (sourceRounds profile gap) lanes family points anchorPoint anchorValue cached root strategy + (List.ofFn seed)).output = none) := + product_left (A := RepeatedSeed profile (sourceAttempts gap security) (sourceRounds profile gap)) + (B := AcceptanceSeed profile) + (fun seed => (runAttempts profile (sourceRounds profile gap) lanes family points anchorPoint anchorValue + cached root strategy (List.ofFn seed)).output = none) + exact dominated.trans (projection.le.trans chance) + +theorem universal_knowledge_failure {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) + (familyCap : m ≤ 2 ^ 64) (claimCap : points.size + 2 ≤ 2 ^ 64) (security : Nat) : + let κ := probability (accepted profile lanes family points anchorPoint anchorValue root strategy) + let gap := κ - (extractionCutoff : ℝ) + probability (failureEvent profile (sourceAttempts gap security) (sourceRounds profile gap) lanes family points + anchorPoint anchorValue root strategy) ≤ (extractionCutoff : ℝ) + (1 / 2 : ℝ) ^ security := by + classical + dsimp only + let κ := probability (accepted profile lanes family points anchorPoint anchorValue root strategy) + by_cases high : (extractionCutoff : ℝ) < κ + · have bound := repeated_knowledge_failure profile lanes family points anchorPoint anchorValue root strategy + familyCap claimCap (κ - extractionCutoff) (by linarith) security (by dsimp only [κ]; linarith) + have cutoffNonnegative : (0 : ℝ) ≤ (extractionCutoff : ℝ) := by norm_num [extractionCutoff] + exact bound.trans (by linarith) + · have dominated := mono + (failureEvent profile (sourceAttempts (κ - extractionCutoff) security) (sourceRounds profile (κ - extractionCutoff)) + lanes family points anchorPoint anchorValue root strategy) + (fun draw => accepted profile lanes family points anchorPoint anchorValue root strategy draw.2) + (fun _ failed => failed.1) + have projection : probability (fun draw : RepeatedSeed profile (sourceAttempts (κ - extractionCutoff) security) + (sourceRounds profile (κ - extractionCutoff)) × AcceptanceSeed profile => + accepted profile lanes family points anchorPoint anchorValue root strategy draw.2) = κ := by + have swap := probability_equiv (Equiv.prodComm _ _) + (fun draw : AcceptanceSeed profile × RepeatedSeed profile (sourceAttempts (κ - extractionCutoff) security) + (sourceRounds profile (κ - extractionCutoff)) => + accepted profile lanes family points anchorPoint anchorValue root strategy draw.1) + exact swap.trans (product_left _) + rw [projection] at dominated + have noiseNonnegative : (0 : ℝ) ≤ (1 / 2 : ℝ) ^ security := by positivity + exact dominated.trans (by linarith) + + theorem sourceRounds_polynomial (profile : ParameterBounds.Profile) (gap : ℝ) (positive : 0 < gap) : + (sourceRounds profile gap : ℝ) ≤ + ((8 * blockLength (ParameterBounds.config profile) : ℝ) / gap + 1) * ((initialDepth profile : ℝ) + 2) := by + have bound := knowledgeRounds_polynomial profile (gap / 2) (by positivity) + calc + (sourceRounds profile gap : ℝ) ≤ + ((4 * blockLength (ParameterBounds.config profile) : ℝ) / (gap / 2) + 1) * + ((initialDepth profile : ℝ) + 2) := bound + _ = ((8 * blockLength (ParameterBounds.config profile) : ℝ) / gap + 1) * + ((initialDepth profile : ℝ) + 2) := by + field_simp [ne_of_gt positive]; ring + + theorem sourceAttempts_polynomial (gap : ℝ) (positive : 0 < gap) (security : Nat) : + (sourceAttempts gap security : ℝ) ≤ ((8 : ℝ) / gap + 1) * security := by + dsimp only [sourceAttempts, extractorAttempts] + rw [Nat.cast_mul] + exact mul_le_mul_of_nonneg_right (inverseGapBlock_polynomial 8 gap positive) (Nat.cast_nonneg security) + +#print axioms attempts_failure_probability +#print axioms prepared_repeated_failure +#print axioms repeated_knowledge_failure +#print axioms universal_knowledge_failure +#print axioms sourceRounds_polynomial +#print axioms sourceAttempts_polynomial +#check universal_knowledge_failure +end Whir.PCSRewindSource diff --git a/verification/whir/Whir/PCSRewindKnowledgeParameters.lean b/verification/whir/Whir/PCSRewindKnowledgeParameters.lean new file mode 100644 index 000000000..c33ab3126 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeParameters.lean @@ -0,0 +1,137 @@ +import Whir.PCSRewindKnowledgeHeavy + +/-! The extraction cutoff is evaluated AFTER safe-prefix κ/2 averaging and +unioning the actual protocol analysis losses. It is not a 128-bit claim. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open SamplingProbability AuthenticatedResetProbability AuthenticatedResetSupport + +/-- The production event ledger proves this conservative whole-tape bound. -/ +def knowledgeBadEnvelope : ℚ := 1 / 2 ^ 72 + +/-- All 56 source profiles retain a positive gap after the factor TWO from +prefix averaging, and after the complete bad-event envelope. -/ +theorem production_amplified_cutoff (profile : ParameterBounds.Profile) : + (1 / 2 ^ 55 : ℚ) < extractionCutoff - + (2 * heavyQueryLoss profile + knowledgeBadEnvelope) := by + have envelope := production_heavyQueryLoss profile + have gap : (1 / 2 ^ 55 : ℚ) < extractionCutoff - + (2 * radiusEnvelope + knowledgeBadEnvelope) := by + norm_num [extractionCutoff, radiusEnvelope, knowledgeBadEnvelope] + linarith + +/-- Real collector fuel is inverse-gap blocks times the coordinate/security +logarithms. These counts parameterize the executable machine itself. -/ +def collectorRounds (inverseAvailability coordinateLog security : Nat) : Nat := + inverseAvailability * (coordinateLog + 2 + security) + +def extractorAttempts (inverseChance security : Nat) : Nat := inverseChance * security + +/-- No logarithmic or field-size enumeration is hidden in the fuel schedule. -/ +theorem collector_schedule_failure (depth count : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) {Suffix : Type*} [Fintype Suffix] [Nonempty Suffix] + (accept : Trial depth count (Suffix := Suffix) → Prop) + (η : ℝ) (ηpositive : 0 < η) (ηle : η ≤ 1) + (block security : Nat) (enough : 1 ≤ (block : ℝ) * η) : + probability (fun seed => ¬ CoversHeavy depth count positive noWrap accept η + (collectorRounds block depth security) seed) ≤ (1 / 4 : ℝ) * (1 / 2 : ℝ) ^ security := by + have bound := polynomial_availability_schedule depth count positive noWrap accept + η ηpositive ηle block (depth + 2 + security) enough + have identity : ((2 ^ depth : Nat) : ℝ) * (1 / 2 : ℝ) ^ (depth + 2 + security) = + (1 / 4 : ℝ) * (1 / 2 : ℝ) ^ security := by + rw [pow_add, pow_add] + push_cast + calc + _ = ((2 : ℝ)^depth * (1/2 : ℝ)^depth) * (1/2 : ℝ)^2 * (1/2 : ℝ)^security := by ring + _ = _ := by rw [← mul_pow]; norm_num + exact bound.trans_eq identity + +/-- Independent verified attempts use inverse-chance blocks, not an observer +that terminates on the first accepted prefix. -/ +theorem attempt_schedule_failure (chance : ℝ) (positive : 0 < chance) (leOne : chance ≤ 1) + (block security : Nat) (enough : 1 ≤ (block : ℝ) * chance) : + (1 - chance) ^ (extractorAttempts block security) ≤ (1 / 2 : ℝ) ^ security := by + rw [extractorAttempts, pow_mul] + exact pow_le_pow_left₀ (pow_nonneg (sub_nonneg.mpr leOne) block) + (inverse_availability_block chance positive leOne block enough) security + +/-- The actual natural inverse-availability block. -/ +noncomputable def inverseGapBlock (scale : Nat) (gap : ℝ) : Nat := + Nat.ceil ((scale : ℝ) / gap) + +theorem inverseGapBlock_enough (scale : Nat) (scalePositive : 0 < scale) + (gap : ℝ) (gapPositive : 0 < gap) : + 1 ≤ (inverseGapBlock scale gap : ℝ) * (gap / scale) := by + have scaleReal : (0 : ℝ) < scale := by exact_mod_cast scalePositive + have bound := Nat.le_ceil ((scale : ℝ) / gap) + have multiply := mul_le_mul_of_nonneg_right bound (div_nonneg gapPositive.le scaleReal.le) + have reciprocal : ((scale : ℝ) / gap) * (gap / scale) = 1 := by + field_simp [ne_of_gt gapPositive, ne_of_gt scaleReal] + simpa only [inverseGapBlock, reciprocal] using multiply + +/-- Ceil introduces at most one extra inverse-gap unit, so the real fuel is +polynomial in N, inverse acceptance gap, and coordinate/security logarithms. -/ +theorem inverseGapBlock_polynomial (scale : Nat) (gap : ℝ) (gapPositive : 0 < gap) : + (inverseGapBlock scale gap : ℝ) ≤ (scale : ℝ) / gap + 1 := + (Nat.ceil_lt_add_one (div_nonneg (by positivity) gapPositive.le)).le + +/-- Availability and attempt schedules are parameters of the REAL extractor. +The acceptance gap is an explicit caller-supplied positive lower bound. Its +derivation from the actual causal acceptance mass is proved in production. -/ +noncomputable def heavyAvailability (profile : ParameterBounds.Profile) (gap : ℝ) : ℝ := + gap / (4 * blockLength (ParameterBounds.config profile) : Nat) + +noncomputable def availabilityBlock (profile : ParameterBounds.Profile) (gap : ℝ) : Nat := + inverseGapBlock (4 * blockLength (ParameterBounds.config profile)) gap + +noncomputable def knowledgeRounds (profile : ParameterBounds.Profile) (gap : ℝ) : Nat := + collectorRounds (availabilityBlock profile gap) (initialDepth profile) 0 + +noncomputable def knowledgeAttempts (gap : ℝ) (security : Nat) : Nat := + extractorAttempts (inverseGapBlock 4 gap) security + +theorem heavyAvailability_positive (profile : ParameterBounds.Profile) (gap : ℝ) + (positive : 0 < gap) : 0 < heavyAvailability profile gap := by + unfold heavyAvailability + exact div_pos positive (by positivity) + +theorem heavyAvailability_le_one (profile : ParameterBounds.Profile) (gap : ℝ) + (leOne : gap ≤ 1) : heavyAvailability profile gap ≤ 1 := by + unfold heavyAvailability + apply (div_le_one (by positivity)).mpr + have Npositive : (1 : Nat) ≤ blockLength (ParameterBounds.config profile) := by + exact Nat.succ_le_of_lt (by unfold blockLength; positivity) + have scale : (1 : ℝ) ≤ (4 * blockLength (ParameterBounds.config profile) : Nat) := by + exact_mod_cast (by omega : (1 : Nat) ≤ 4 * blockLength (ParameterBounds.config profile)) + exact leOne.trans scale + +theorem availabilityBlock_enough (profile : ParameterBounds.Profile) (gap : ℝ) (positive : 0 < gap) : + 1 ≤ (availabilityBlock profile gap : ℝ) * heavyAvailability profile gap := + inverseGapBlock_enough _ (by unfold blockLength; positivity) gap positive + +/-- Literal collector fuel is polynomial in the domain size and inverse +acceptance gap, including the bit-depth needed for complete coverage. -/ +theorem knowledgeRounds_polynomial (profile : ParameterBounds.Profile) (gap : ℝ) (positive : 0 < gap) : + (knowledgeRounds profile gap : ℝ) ≤ + ((4 * blockLength (ParameterBounds.config profile) : ℝ) / gap + 1) * + ((initialDepth profile : ℝ) + 2) := by + have bound := inverseGapBlock_polynomial (4 * blockLength (ParameterBounds.config profile)) gap positive + dsimp only [knowledgeRounds, collectorRounds, availabilityBlock, Nat.add_zero] + rw [Nat.cast_mul, Nat.cast_add, Nat.cast_ofNat] + simpa only [Nat.cast_mul, Nat.cast_ofNat] using + mul_le_mul_of_nonneg_right bound (by positivity : (0 : ℝ) ≤ (initialDepth profile : ℝ) + 2) + +/-- The actual independent-attempt fuel is linear in the desired failure +exponent and polynomial in the inverse acceptance gap. -/ +theorem knowledgeAttempts_polynomial (gap : ℝ) (positive : 0 < gap) (security : Nat) : + (knowledgeAttempts gap security : ℝ) ≤ ((4 : ℝ) / gap + 1) * security := by + dsimp only [knowledgeAttempts, extractorAttempts] + rw [Nat.cast_mul] + exact mul_le_mul_of_nonneg_right (inverseGapBlock_polynomial 4 gap positive) (Nat.cast_nonneg security) + +#print axioms production_amplified_cutoff +#print axioms collector_schedule_failure +#print axioms attempt_schedule_failure +#print axioms knowledgeRounds_polynomial +#print axioms knowledgeAttempts_polynomial +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgePrefix.lean b/verification/whir/Whir/PCSRewindKnowledgePrefix.lean new file mode 100644 index 000000000..bd891e168 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgePrefix.lean @@ -0,0 +1,53 @@ +import Whir.PCSRewindKnowledgeProbability + +/-! Averaging is applied to actual accepted AND analysis-safe full trials. +The executable collector still retains every accepted trial. Averaging the safe +event directly avoids an unnecessary conditional-bad-event Markov loss. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction +open SamplingProbability AuthenticatedResetProbability ResetAcceptanceAmplification + +variable {Prefix Suffix Trial : Type*} [Fintype Prefix] [Nonempty Prefix] + [Fintype Suffix] [Nonempty Suffix] [Fintype Trial] [Nonempty Trial] + +/-- Accepted safe mass loses only the actual bad event, with arbitrary overlap. -/ +theorem safe_acceptance_mass (accept bad : Trial → Prop) : + probability accept - probability bad ≤ probability (fun t => accept t ∧ ¬ bad t) := by + let events : Bool → Trial → Prop + | false => fun t => accept t ∧ ¬ bad t + | true => bad + have cover : ∀ t, accept t → ∃ b, events b t := by + intro t accepted + by_cases badHere : bad t + · exact ⟨true, badHere⟩ + · exact ⟨false, accepted, badHere⟩ + have bound := (mono _ _ cover).trans (union_le events) + simp only [Fintype.sum_bool, events] at bound + linarith + +/-- Safe-prefix mass derives from acceptance; no availability is supplied. -/ +theorem safe_good_prefix_mass (accept bad : Prefix × Suffix → Prop) : + (probability accept - probability bad) / 2 ≤ + probability (GoodPrefix (fun t => accept t ∧ ¬ bad t)) := by + exact (by linarith [safe_acceptance_mass accept bad] : + (probability accept - probability bad) / 2 ≤ + probability (fun t => accept t ∧ ¬ bad t) / 2).trans + (good_prefix_mass (fun t => accept t ∧ ¬ bad t)) + +/-- Whole safe acceptance yields a verified-output chance. The per-prefix +recovery premise is discharged by the actual heavy-coordinate certificate. -/ +theorem safe_prefix_attempt_chance (accept bad : Prefix × Suffix → Prop) + (success : Prefix × Trial → Prop) (δ : ℝ) (δnonneg : 0 ≤ δ) (δle : δ ≤ 1) + (recover : ∀ p, GoodPrefix (fun t => accept t ∧ ¬ bad t) p → + 1 - δ ≤ probability (fun seed => success (p, seed))) : + (probability accept - probability bad) / 2 * (1 - δ) ≤ probability success := by + exact (mul_le_mul_of_nonneg_right + (by linarith [safe_acceptance_mass accept bad] : + (probability accept - probability bad) / 2 ≤ + probability (fun t => accept t ∧ ¬ bad t) / 2) + (sub_nonneg.mpr δle)).trans + (prefix_attempt_chance (fun t => accept t ∧ ¬ bad t) success δ δnonneg δle recover) + +#print axioms safe_good_prefix_mass +#print axioms safe_prefix_attempt_chance +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeProbability.lean b/verification/whir/Whir/PCSRewindKnowledgeProbability.lean new file mode 100644 index 000000000..98d2de1ad --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeProbability.lean @@ -0,0 +1,134 @@ +import Whir.PCSRewindExtractorAttempts + +/-! Probability laws for the executable repeated extractor. The failure event +is actual runRewind failure, not an auxiliary first-verified observer. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction +open SamplingProbability AuthenticatedResetProbability ResetAcceptanceAmplification + +set_option maxHeartbeats 2000000 + +/-- Explicit composition breaks instance search at the deeply nested dependent +tape, without introducing any executable field enumeration. -/ +noncomputable instance repeatedSeedFintype (profile : ParameterBounds.Profile) (attempts rounds : Nat) : + Fintype (RepeatedSeed profile attempts rounds) := by + letI : Fintype (Seed profile rounds) := inferInstanceAs + (Fintype (Tape (ParameterBounds.config profile) × (Fin rounds → TrialSeed profile))) + exact inferInstanceAs (Fintype (Fin attempts → Seed profile rounds)) + +theorem firstOutput_none_iff {α : Type*} (outputs : List (Option α)) : + firstOutput outputs = none ↔ ∀ output ∈ outputs, output = none := by + induction outputs with + | nil => simp [firstOutput] + | cons output rest ih => cases output <;> simp [firstOutput, ih] + +/-- Soundness of the actual stop rule identifies successful execution with an +explaining output, for every seed and every adversarial strategy. -/ +theorem extractionSuccess_iff_output (profile : ParameterBounds.Profile) + (rounds lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (seed : Seed profile rounds) : + extractionSuccess (extractor profile rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ seed ↔ + (runRewind (ExecutionShapes.Input profile lanes root claims) strategy + (extractor profile rounds).maxReplay (extractor profile rounds).rewindRounds + ((extractor profile rounds).program (ExecutionShapes.Input profile lanes root claims) seed)).output ≠ none := by + constructor + · rintro ⟨w, output, _⟩; simp [output] + · intro output + obtain ⟨w, equal⟩ := Option.ne_none_iff_exists'.mp output + exact ⟨w, equal, extractor_output_explains profile rounds lanes root claims strategy seed laneBound w equal⟩ + +/-- Every attempt has fresh full prefix/suffix product randomness. Stopping +short on success preserves the all-attempts-fail event exactly. -/ +theorem repeatedExtractor_failure_iff (profile : ParameterBounds.Profile) + (attempts rounds lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (seed : RepeatedSeed profile attempts rounds) : + ¬ extractionSuccess (repeatedExtractor profile attempts rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ seed ↔ + ∀ i, ¬ extractionSuccess (extractor profile rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ (seed i) := by + have actual : extractionSuccess (repeatedExtractor profile attempts rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ seed ↔ + (runRewind (ExecutionShapes.Input profile lanes root claims) strategy + (repeatedExtractor profile attempts rounds).maxReplay (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program (ExecutionShapes.Input profile lanes root claims) seed)).output ≠ none := by + constructor + · rintro ⟨w, output, _⟩; simp [output] + · intro output + obtain ⟨w, equal⟩ := Option.ne_none_iff_exists'.mp output + exact ⟨w, equal, repeatedExtractor_output_explains profile attempts rounds lanes root claims strategy seed laneBound w equal⟩ + rw [actual, not_not, repeatedExtractor_output, firstOutput_none_iff, List.forall_mem_ofFn_iff] + simp only [extractionSuccess_iff_output profile rounds lanes root claims strategy laneBound, not_not] + +/-- The concrete machine inherits independent-attempt amplification. Its +single-attempt success lower bound is instantiated by the production heavy +certificate; it is not a prover-availability hypothesis. -/ +theorem repeatedExtractor_failure_probability (profile : ParameterBounds.Profile) + (attempts rounds lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (chance : ℝ) (chanceNonneg : 0 ≤ chance) + (lower : chance ≤ probability (extractionSuccess (extractor profile rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩)) : + probability (fun seed => ¬ extractionSuccess (repeatedExtractor profile attempts rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ seed) ≤ (1 - chance) ^ attempts := by + have bound := repeated_extraction_failure (extractor profile rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ chance chanceNonneg lower attempts + convert bound using 1 + congr 1 + funext seed + exact propext (repeatedExtractor_failure_iff profile attempts rounds lanes root claims strategy laneBound seed) + +/-- In the low-acceptance branch, the joint knowledge failure is bounded by +the actual causal verifier acceptance mass, regardless of extraction output. -/ +theorem knowledge_failure_le_acceptance {S : Type*} [Fintype S] [Nonempty S] + (machine : Extractor S) (prover : CommittedProver) : + (knowledgeFailureProbability machine prover : ℝ) ≤ + probability (fun tape => experiment prover.input prover.respond tape = true) := by + classical + have included := mono + (fun sample : Tape prover.input.config × S => + experiment prover.input prover.respond sample.1 = true ∧ ¬ extractionSuccess machine prover sample.2) + (fun sample => experiment prover.input prover.respond sample.1 = true) + (fun _ accepted => accepted.1) + have product := product_left (B := S) + (fun tape : Tape prover.input.config => experiment prover.input prover.respond tape = true) + rw [product] at included + rw [probability_eq_uniformProb] at included + exact included + +/-- The acceptance-plus-failure game uses independent verifier and extraction +randomness. This bound is about the actual knowledgeFailureProbability. -/ +theorem repeatedExtractor_knowledge_failure (profile : ParameterBounds.Profile) + (attempts rounds lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ 2 ^ (ParameterBounds.config profile).folds[0]!) + (chance : ℝ) (chanceNonneg : 0 ≤ chance) + (lower : chance ≤ probability (extractionSuccess (extractor profile rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩)) : + (knowledgeFailureProbability (repeatedExtractor profile attempts rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ : ℝ) ≤ (1 - chance) ^ attempts := by + classical + let prover : CommittedProver := ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ + have included := mono + (fun sample : Tape prover.input.config × RepeatedSeed profile attempts rounds => + experiment prover.input prover.respond sample.1 = true ∧ + ¬ extractionSuccess (repeatedExtractor profile attempts rounds) prover sample.2) + (fun sample => ¬ extractionSuccess (repeatedExtractor profile attempts rounds) prover sample.2) + (fun _ accepted => accepted.2) + have product := product_left (B := Tape prover.input.config) + (fun seed => ¬ extractionSuccess (repeatedExtractor profile attempts rounds) prover seed) + have swapped := SamplingProbability.probability_equiv (Equiv.prodComm _ _) + (fun sample : RepeatedSeed profile attempts rounds × Tape prover.input.config => + ¬ extractionSuccess (repeatedExtractor profile attempts rounds) prover sample.1) + change probability (fun sample : Tape prover.input.config × RepeatedSeed profile attempts rounds => + ¬ extractionSuccess (repeatedExtractor profile attempts rounds) prover sample.2) = + probability (fun sample : RepeatedSeed profile attempts rounds × Tape prover.input.config => + ¬ extractionSuccess (repeatedExtractor profile attempts rounds) prover sample.1) at swapped + rw [swapped, product] at included + rw [probability_eq_uniformProb] at included + exact included.trans (repeatedExtractor_failure_probability profile attempts rounds lanes root claims strategy laneBound chance chanceNonneg lower) + +#print axioms repeatedExtractor_failure_probability +#print axioms repeatedExtractor_knowledge_failure +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeProduction.lean b/verification/whir/Whir/PCSRewindKnowledgeProduction.lean new file mode 100644 index 000000000..307efdad7 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeProduction.lean @@ -0,0 +1,277 @@ +import Whir.PCSRewindKnowledgeSuccess +import Whir.SupportedCandidateProtocolProbability +import Whir.SupportedCandidateProtocolAccepted + +/-! The production safe event is the DERIVED causal/fold/cancellation/collision +ledger. Acceptance supplies safe-prefix mass and heavy support; no prover +availability or fixed-target proximity is assumed. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open SamplingProbability AuthenticatedResetProbability AuthenticatedResetSupport +open ResetAcceptanceAmplification + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 100000 +attribute [local irreducible] ParameterBounds.config + +noncomputable def productionBad (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) := + SupportedCandidateProtocol.KnowledgeBad profile lanes root claims strategy + +/-- The actual source ledger, including separately charged SAME-candidate +fold claim escape and row cancellation, supplies the whole bad-event budget. -/ +theorem production_bad_probability (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) : + probability (productionBad profile lanes root claims strategy) ≤ (knowledgeBadEnvelope : ℝ) := by + classical + rw [probability_eq_uniformProb] + apply Rat.cast_le.mpr + exact (SupportedCandidateProtocol.knowledgeBad_probability profile lanes root claims strategy laneBound claimShape).trans + (SupportedCandidateProtocol.production_knowledgeLedger profile claims.size claimCap) + +/-- Exact prefix/fullReset product law and the actual bad-event budget derive +safe accepted mass from the causal verifier's true acceptance probability. -/ +theorem production_safe_mass (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) : + probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) - + (knowledgeBadEnvelope : ℝ) ≤ + probability (fun draw : Tape (ParameterBounds.config profile) × TrialSeed profile => + safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) draw.1 draw.2) := by + rw [safeResetAccept_probability] + have safe := safe_acceptance_mass + (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) + (productionBad profile lanes root claims strategy) + have bad := production_bad_probability profile lanes root claims strategy laneBound claimShape claimCap + linarith + +/-- The κ/2 loss is fully accounted for BEFORE Gao heavy support is derived. -/ +theorem production_good_prefix_heavy_mass (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) (gap : ℝ) (gapPositive : 0 < gap) + (advantage : (extractionCutoff : ℝ) + gap ≤ + probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true)) + (base : Tape (ParameterBounds.config profile)) + (good : GoodPrefix (fun draw : Tape (ParameterBounds.config profile) × TrialSeed profile => + safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) draw.1 draw.2) base) : + (heavyQueryLoss profile : ℝ) + blockLength (ParameterBounds.config profile) * heavyAvailability profile gap < + probability (safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) base) := by + have mass := production_safe_mass profile lanes root claims strategy laneBound claimShape claimCap + have conditional := good + change probability _ / 2 ≤ probability _ at conditional + have cutoff : (2 * heavyQueryLoss profile + knowledgeBadEnvelope : ℚ) < extractionCutoff := by + linarith [production_amplified_cutoff profile] + have cutoffReal : (2 * (heavyQueryLoss profile : ℝ) + knowledgeBadEnvelope) < extractionCutoff := by + exact_mod_cast cutoff + have scale : (blockLength (ParameterBounds.config profile) : ℝ) * heavyAvailability profile gap = gap / 4 := by + unfold heavyAvailability + push_cast + field_simp [show (blockLength (ParameterBounds.config profile) : ℝ) ≠ 0 by positivity] + rw [scale] + linarith + +/-- Conversion from the stratified collector seed to the actual indivisible +query/lambda challenge message. The casts change only the index proof. -/ +def resetDraw (profile : ParameterBounds.Profile) (trial : TrialSeed profile) : + CausalProbability.Sample (.query (SupportedCandidateProtocol.initialLevel profile)) := + ((fun j => trial.1 (Fin.cast (initialChunks profile) j)), trial.2.1) + +theorem resetDraw_squeezes (profile : ParameterBounds.Profile) (trial : TrialSeed profile) : + Array.ofFn (resetDraw profile trial).1 = Array.ofFn trial.1 := by + apply Array.ext + · simp only [Array.size_ofFn] + exact initialChunks profile + · intro i hi hj + simp [resetDraw, Fin.cast] + +/-- Every safe accepted full reset hits one prefix-fixed scalar agreement set +under the EXACT collector query law, even with adversarial later replies. -/ +theorem safeReset_hits (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (base : Tape (ParameterBounds.config profile)) (target : Array E) + (matching : RewindBatchTarget.Target + (CausalExecution.followingCandidates (ExecutionShapes.Input profile lanes root claims) strategy base 0) + (challenges (ParameterBounds.config profile) base).levels[0]!.oodPoints[0]! + (CausalExecution.proof (ExecutionShapes.Input profile lanes root claims) strategy base).levels[0]!.oods[0]!.value target) + (separated : LevelBoundary.Separated + (CausalExecution.followingCandidates (ExecutionShapes.Input profile lanes root claims) strategy base 0) + (challenges (ParameterBounds.config profile) base).levels[0]!.oodPoints[0]!) + (trial : TrialSeed profile) + (accepted : safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) base trial) : + ∀ i, RewindCoverage.sampledPosition (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 trial.1 i ∈ + LevelBoundary.agreeingColumns ((ParameterBounds.config profile).logN - (ParameterBounds.config profile).folds[0]!) + (ParameterBounds.config profile).rates[0]! target + (QueryBatchSoundness.oldWord ((ParameterBounds.config profile).logN - (ParameterBounds.config profile).folds[0]!) + (ParameterBounds.config profile).rates[0]! (liftRoot root) true + (challenges (ParameterBounds.config profile) base).levels[0]!.folds) := by + have hit := SupportedCandidateProtocol.accepted_safe_hits profile lanes root claims strategy + base trial.2.2 (resetDraw profile trial) target matching separated accepted.1 accepted.2 + obtain ⟨qs, derived, agrees⟩ := hit + have squeezed := congrArg + (deriveQueries (remaining (ParameterBounds.config profile) 0 + (ParameterBounds.config profile).rates[0]!) + (ParameterBounds.config profile).queries[0]!) + (resetDraw_squeezes profile trial) + have derived' := squeezed.symm.trans derived + have hit' : SamplingProbability.allQueriesHit (initialDepth profile) + (ParameterBounds.config profile).queries[0]! + (LevelBoundary.agreeingColumns ((ParameterBounds.config profile).logN - (ParameterBounds.config profile).folds[0]!) + (ParameterBounds.config profile).rates[0]! target + (QueryBatchSoundness.oldWord ((ParameterBounds.config profile).logN - (ParameterBounds.config profile).folds[0]!) + (ParameterBounds.config profile).rates[0]! (liftRoot root) true + (challenges (ParameterBounds.config profile) base).levels[0]!.folds)) trial.1 := by + unfold SamplingProbability.allQueriesHit + refine ⟨qs, ?_, ?_⟩ + · simpa only [(InitialCandidates.production_initial_facts profile).1] using derived' + · exact Eq.mp (congrArg (fun n => + ∀ i : Fin (ParameterBounds.config profile).queries[0]!, qs[i.val]! ∈ + (LevelBoundary.agreeingColumns n (ParameterBounds.config profile).rates[0]! target + (QueryBatchSoundness.oldWord n (ParameterBounds.config profile).rates[0]! + (liftRoot root) true (challenges (ParameterBounds.config profile) base).levels[0]!.folds)).image + (@Fin.val (2 ^ (n + (ParameterBounds.config profile).rates[0]!)))) + (InitialCandidates.production_initial_facts profile).1) agrees + exact (allQueriesHit_iff (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 _ trial.1).mp hit' + +/-- Production SAME-K-w heavy certificate: existence, every dense input Claim, +and common-coordinate agreement are derived from actual safe acceptance. -/ +theorem production_heavy_witness (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (base : Tape (ParameterBounds.config profile)) + (η : ℝ) (ηpositive : 0 < η) + (large : (heavyQueryLoss profile : ℝ) + blockLength (ParameterBounds.config profile) * η < + probability (safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) base)) : + Nonempty (HeavyWitness profile lanes root claims + (heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) base) η)) := by + classical + have lossNonnegative : (0 : ℝ) ≤ (heavyQueryLoss profile : ℝ) := by + unfold heavyQueryLoss + positivity + have acceptedExists : ∃ trial, safeResetAccept profile lanes root claims strategy + (productionBad profile lanes root claims strategy) base trial := by + by_contra absent + have no := not_exists.mp absent + have empty : safeResetAccept profile lanes root claims strategy + (productionBad profile lanes root claims strategy) base = (fun _ => False) := by + funext trial + exact propext ⟨no trial, False.elim⟩ + rw [empty] at large + have zero : probability (fun _ : TrialSeed profile => False) = 0 := by simp [probability] + rw [zero] at large + have lightNonnegative : (0 : ℝ) ≤ blockLength (ParameterBounds.config profile) * η := by positivity + linarith + obtain ⟨trial, accepted⟩ := acceptedExists + obtain ⟨target, matching, separated, size, truth, prior, valid, laneBound⟩ := + SupportedCandidateProtocol.accepted_safe_target profile lanes root claims strategy base trial.2.2 + (resetDraw profile trial) accepted.1 accepted.2 + let H := heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) base) η + have included := heavy_subset_of_safe_hits (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) base) + η ηpositive _ (safeReset_hits profile lanes root claims strategy base target matching separated) + have sizes := production_heavy_size profile _ η ηpositive.le large + obtain ⟨w, explains, rows⟩ := SupportedCandidateProtocol.same_w_on_support profile lanes root claims strategy + base valid laneBound (fun j => (prior.1 j).1) (fun j => (prior.1 j).2) + prior.2.1 prior.2.2 target size truth H sizes.2 (by + intro q member + exact (Finset.mem_filter.mp (included member)).2) + exact ⟨⟨w, explains, rows⟩⟩ + +/-- A fresh actual prefix and polynomial full-reset collection have verified +success chance at least gap/4. No certificate, availability or goodness is a +theorem premise: the production SAME-w certificate is derived internally. -/ +theorem production_single_attempt_chance (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) (gap : ℝ) (gapPositive : 0 < gap) + (advantage : (extractionCutoff : ℝ) + gap ≤ + probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true)) : + gap / 4 ≤ probability (extractionSuccess (extractor profile (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩) := by + classical + have acceptanceLeOne := le_one + (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) + have cutoffNonnegative : (0 : ℝ) ≤ (extractionCutoff : ℝ) := by + norm_num [extractionCutoff] + have gapLeOne : gap ≤ 1 := by linarith + let safe := fun draw : Tape (ParameterBounds.config profile) × TrialSeed profile => + safeResetAccept profile lanes root claims strategy (productionBad profile lanes root claims strategy) draw.1 draw.2 + have conditional : ∀ base, GoodPrefix safe base → + 1 - (1 / 4 : ℝ) ≤ probability (fun seed : Fin (knowledgeRounds profile gap) → TrialSeed profile => + extractionSuccess (extractor profile (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ (base, seed)) := by + intro base good + have large := production_good_prefix_heavy_mass profile lanes root claims strategy + laneBound claimShape claimCap gap gapPositive advantage base good + let certificate := Classical.choice (production_heavy_witness profile lanes root claims strategy base + (heavyAvailability profile gap) (heavyAvailability_positive profile gap gapPositive) large) + have recovered := conditional_extractor_schedule profile lanes root claims strategy laneBound + (productionBad profile lanes root claims strategy) base (heavyAvailability profile gap) + (heavyAvailability_positive profile gap gapPositive) (heavyAvailability_le_one profile gap gapLeOne) + (availabilityBlock profile gap) 0 (availabilityBlock_enough profile gap gapPositive) large certificate + change 1 - (1 / 4 : ℝ) * (1 / 2 : ℝ) ^ 0 ≤ _ at recovered + convert recovered using 1 <;> simp only [knowledgeRounds, pow_zero, mul_one] + unfold probability + congr 1 + have chance := prefix_attempt_chance safe + (extractionSuccess (extractor profile (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩) + (1 / 4 : ℝ) (by norm_num) (by norm_num) conditional + have mass := production_safe_mass profile lanes root claims strategy laneBound claimShape claimCap + have budget : (knowledgeBadEnvelope : ℝ) ≤ (extractionCutoff : ℝ) := by + norm_num [knowledgeBadEnvelope, extractionCutoff] + dsimp only [safe] at chance + nlinarith + +/-- Acceptance PLUS failure for the actual repeated legal machine. Fuel uses +real inverse-gap blocks; the machine stops only on a verified explaining output. -/ +theorem production_repeated_knowledge_failure (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) (gap : ℝ) (gapPositive : 0 < gap) (security : Nat) + (advantage : (extractionCutoff : ℝ) + gap ≤ + probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true)) : + knowledgeFailureProbability + (repeatedExtractor profile (knowledgeAttempts gap security) (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ ≤ (1 / 2 : ℚ) ^ security := by + have chance := production_single_attempt_chance profile lanes root claims strategy laneBound + claimShape claimCap gap gapPositive advantage + have bound := repeatedExtractor_knowledge_failure profile (knowledgeAttempts gap security) + (knowledgeRounds profile gap) lanes root claims strategy laneBound + (gap / 4) (by positivity) chance + have gapLeOne : gap / 4 ≤ 1 := by + have acceptanceLeOne := le_one + (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) + have cutoffNonnegative : (0 : ℝ) ≤ (extractionCutoff : ℝ) := by norm_num [extractionCutoff] + linarith + have amplified := attempt_schedule_failure (gap / 4) (by positivity) gapLeOne + (inverseGapBlock 4 gap) security (inverseGapBlock_enough 4 (by decide) gap gapPositive) + apply (Rat.cast_le (K := ℝ)).mp + simpa only [knowledgeAttempts, Rat.cast_pow, Rat.cast_div, Rat.cast_one, Rat.cast_ofNat] using + bound.trans amplified + +#print axioms production_bad_probability +#print axioms production_safe_mass +#print axioms production_good_prefix_heavy_mass +#print axioms production_heavy_witness +#print axioms production_single_attempt_chance +#print axioms production_repeated_knowledge_failure +#check production_bad_probability +#check production_safe_mass +#check production_heavy_witness +#check production_single_attempt_chance +#check production_repeated_knowledge_failure +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeResources.lean b/verification/whir/Whir/PCSRewindKnowledgeResources.lean new file mode 100644 index 000000000..ec7b41123 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeResources.lean @@ -0,0 +1,138 @@ +import Whir.ExtractorArithmeticCostPolynomial +import Whir.PCSRewindKnowledgeHeavy + +/-! Source-derived resource guards for all production profiles. The arithmetic +counter is value-connected to the actual repeated run, including rejected +trials and every replay. Prover runtime and raw reply allocation are not field +arithmetic: callers must charge their encoded consumed input/reply lengths. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport ExtractorArithmeticCost +open scoped BigOperators + +set_option maxHeartbeats 0 +set_option maxRecDepth 100000 + +theorem production_challenge_static : ∀ p : ParameterBounds.Profile, + (ParameterBounds.config p).logN ≤ 64 ∧ + (∀ i : Fin (ParameterBounds.config p).folds.size, + (ParameterBounds.config p).folds[i.val]! ≤ (ParameterBounds.config p).logN ∧ + (ParameterBounds.config p).folds[i.val]! ≤ 6 ∧ + oodCount (ParameterBounds.config p) i.val ≤ 256 ∧ + (ParameterBounds.config p).queries[i.val]! ≤ 256) := by + decide +kernel + +/-- Generated source tapes meet the cost consumer guards even when the prover +returns malformed or withholding replies. No answer-shape goodness is needed. -/ +theorem production_challenge_input (profile : ParameterBounds.Profile) + (tape : Tape (ParameterBounds.config profile)) : + ChallengeInput (ParameterBounds.config profile) (challenges (ParameterBounds.config profile) tape) + (ParameterBounds.config profile).logN 6 256 256 (ParameterBounds.config profile).logN := by + let c := ParameterBounds.config profile + have stat := production_challenge_static profile + refine ⟨le_rfl, stat.1, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩ + · intro i within + simpa [challenges, getElem!_pos, within] using (stat.2 ⟨i, within⟩).1 + · intro i within + simpa [challenges, getElem!_pos, within] using (stat.2 ⟨i, within⟩).2.1 + · intro i within + simpa [challenges, getElem!_pos, within] using (stat.2 ⟨i, within⟩).2.2.1 + · intro i within point member + simp only [challenges, getElem!_pos, Array.size_ofFn, within, Array.getElem_ofFn, + Array.toList_ofFn, List.mem_ofFn] at member + obtain ⟨j, rfl⟩ := member + simp only [Array.size_ofFn] + exact Nat.sub_le _ _ + · intro i within + exact (stat.2 ⟨i, within⟩).2.2.2 + · simp [challenges] + · simp [challenges] + +/-- Whole repeated machine field arithmetic and actual black-box response calls, +with every source consumer hypothesis discharged for the production family. -/ +theorem production_repeated_resources (profile : ParameterBounds.Profile) + (rounds attempts lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) : + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength (ParameterBounds.config profile)) + (attempts * (rounds * streamLength (ParameterBounds.config profile))) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + measured.fieldArithmetic ≤ totalFieldPolynomial input attempts rounds + input.config.logN 6 256 256 input.config.logN ∧ + measured.responseCalls ≤ attempts * (rounds * streamLength input.config) * (streamLength input.config + 1) := + actualRepeated_cost profile rounds attempts lanes root claims strategy seed _ 6 256 256 _ + (production_challenge_input profile) (production_heavy_static profile).2.1 + +/-- Every actual prefix collector retains at most rounds·queries records. +Rejected trials contribute zero. Base projection only decreases this count. -/ +theorem production_collected_records (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (seed : Seed profile rounds) : + let input := ExecutionShapes.Input profile lanes root claims + (collectedRecords ⟨input, strategy⟩ (initialLevel profile) (initialDepth profile) + (seedTapes profile rounds input rfl seed)).length ≤ rounds * input.config.queries[0]! := by + dsimp only + have bound := collectedRecords_length_le + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ (initialLevel profile) (initialDepth profile) + (seedTapes profile rounds (ExecutionShapes.Input profile lanes root claims) rfl seed) + simpa [seedTapes, initialLevel] using bound + +/-- Summing all potential prefix collectors upper-bounds records for any actual +verified-output stopping prefix; the machine never retries a successful one. -/ +theorem production_all_records (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) : + let input := ExecutionShapes.Input profile lanes root claims + (∑ i, (collectedRecords ⟨input, strategy⟩ (initialLevel profile) (initialDepth profile) + (seedTapes profile rounds input rfl (seed i))).length) ≤ + attempts * (rounds * input.config.queries[0]!) := by + dsimp only + calc + _ ≤ ∑ _ : Fin attempts, rounds * (ParameterBounds.config profile).queries[0]! := + Finset.sum_le_sum (fun i _ => production_collected_records profile rounds lanes root claims strategy (seed i)) + _ = _ := by simp + +/-- Measured arithmetic, every actual replay response, and admitted encoded +input/reply words compose in literal resource units. U is charged, not assumed +to be free; the prover's internal computation remains outside this boundary. -/ +theorem production_repeated_physical_resource (profile : ParameterBounds.Profile) + (rounds attempts lanes : Nat) (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) (encodedInputWords : Nat) + (physicalRoot : root.size = blockLength (ParameterBounds.config profile)) + (physicalLanes : ∀ row ∈ root.toList, row.size = lanes) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (admittedInput : + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength input.config) + (attempts * (rounds * streamLength input.config)) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + measured.encodedReplyWords + CountedCandidateCheck.consumedWords input [] ≤ encodedInputWords) : + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength input.config) + (attempts * (rounds * streamLength input.config)) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + measured.fieldArithmetic + measured.responseCalls + + (measured.encodedReplyWords + CountedCandidateCheck.consumedWords input []) ≤ + physicalFieldPolynomial (laneCount input.config) lanes (blockLength input.config) + claims.size input.config.folds.size attempts rounds 6 256 256 input.config.logN + + attempts * (rounds * streamLength input.config) * (streamLength input.config + 1) + + encodedInputWords := by + have fullWidth : laneCount (ParameterBounds.config profile) * width (ParameterBounds.config profile) = + 2 ^ (ParameterBounds.config profile).logN := by + rw [← Nat.pow_add, Nat.add_sub_of_le (InitialCandidates.production_initial_facts profile).2.1] + have physicalClaims : ∀ claim ∈ claims.toList, + claim.weight.size = laneCount (ParameterBounds.config profile) * width (ParameterBounds.config profile) := by + intro claim member + obtain ⟨j, within, equal⟩ := Array.mem_iff_getElem.mp (Array.mem_toList_iff.mp member) + rw [← equal, fullWidth] + exact claimShape ⟨j, within⟩ + exact actualRepeated_total_resource profile rounds attempts lanes root claims strategy seed + 6 256 256 (ParameterBounds.config profile).logN encodedInputWords + (production_challenge_input profile) (production_heavy_static profile).2.1 + physicalRoot physicalLanes laneBound physicalClaims admittedInput + +#print axioms production_challenge_input +#print axioms production_repeated_resources +#print axioms production_all_records +#print axioms production_repeated_physical_resource +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeSuccess.lean b/verification/whir/Whir/PCSRewindKnowledgeSuccess.lean new file mode 100644 index 000000000..881e9f6df --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeSuccess.lean @@ -0,0 +1,77 @@ +import Whir.PCSRewindKnowledgeCollector +import Whir.PCSRewindKnowledgeParameters + +/-! Full independent suffix samples drive the actual collector. The failure +probability here refers to runRewind extractionSuccess, after every live lane +and all original claims are checked. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open SamplingProbability AuthenticatedResetProbability AuthenticatedResetSupport +open SupportedCandidateRecovery ResetAcceptanceAmplification + +set_option maxHeartbeats 4000000 + +/-- A proved heavy witness plus actual acceptance-dependent coverage gives a +conditional success probability for the REAL bounded rewind program. -/ +theorem conditional_extractor_success (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (bad : Tape (ParameterBounds.config profile) → Prop) (base : Tape (ParameterBounds.config profile)) + (η : ℝ) (ηnonnegative : 0 ≤ η) (ηleOne : η ≤ 1) + (large : (heavyQueryLoss profile : ℝ) + blockLength (ParameterBounds.config profile) * η < + probability (safeResetAccept profile lanes root claims strategy bad base)) + (certificate : HeavyWitness profile lanes root claims + (heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η)) : + 1 - blockLength (ParameterBounds.config profile) * (1 - η) ^ rounds ≤ + probability (fun seed : Fin rounds → TrialSeed profile => extractionSuccess (extractor profile rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ (base, seed)) := by + let covered := CoversHeavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η rounds + have failure := coverage_failure_le (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η ηnonnegative ηleOne rounds + have chance : 1 - blockLength (ParameterBounds.config profile) * (1 - η) ^ rounds ≤ probability covered := by + have total := complement covered + linarith + exact chance.trans (mono covered _ (fun seed coverage => + extractor_success_of_safe_coverage profile rounds lanes root claims strategy laneBound bad base + η ηnonnegative large certificate seed coverage)) + +/-- The real inverse-availability collector blocks reduce conditional failure +below one quarter, with optional further independent security blocks. -/ +theorem conditional_extractor_schedule (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (bad : Tape (ParameterBounds.config profile) → Prop) (base : Tape (ParameterBounds.config profile)) + (η : ℝ) (ηpositive : 0 < η) (ηleOne : η ≤ 1) (block security : Nat) + (enough : 1 ≤ (block : ℝ) * η) + (large : (heavyQueryLoss profile : ℝ) + blockLength (ParameterBounds.config profile) * η < + probability (safeResetAccept profile lanes root claims strategy bad base)) + (certificate : HeavyWitness profile lanes root claims + (heavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η)) : + 1 - (1 / 4 : ℝ) * (1 / 2 : ℝ) ^ security ≤ + probability (fun seed : Fin (collectorRounds block (initialDepth profile) security) → TrialSeed profile => + extractionSuccess (extractor profile (collectorRounds block (initialDepth profile) security)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ (base, seed)) := by + let rounds := collectorRounds block (initialDepth profile) security + let covered := CoversHeavy (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η rounds + have failure := collector_schedule_failure (initialDepth profile) (ParameterBounds.config profile).queries[0]! + (production_heavy_static profile).1 (InitialCandidates.production_initial_facts profile).2.2.1 + (safeResetAccept profile lanes root claims strategy bad base) η ηpositive ηleOne block security enough + have chance : 1 - (1 / 4 : ℝ) * (1 / 2 : ℝ) ^ security ≤ probability covered := by + have total := complement covered + linarith + exact chance.trans (mono covered _ (fun seed coverage => + extractor_success_of_safe_coverage profile rounds lanes root claims strategy laneBound bad base + η ηpositive.le large certificate seed coverage)) + +#print axioms conditional_extractor_success +#print axioms conditional_extractor_schedule +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindSourceProgram.lean b/verification/whir/Whir/PCSRewindSourceProgram.lean new file mode 100644 index 000000000..900ccc23e --- /dev/null +++ b/verification/whir/Whir/PCSRewindSourceProgram.lean @@ -0,0 +1,349 @@ +import Whir.CountedCandidateCheckOriginal +import Whir.PCSRewindExtractorAttempts + +/-! Actual source extraction checks every uncompressed binary slice, every +ordinary/strided point, and the retained anchor on the decoded K word. The +collector still accepts exactly ordinary verifier-accepted trials. Public +compression is freshly sampled at each outer attempt; all original source +statements and the commitment stay fixed. -/ +namespace Whir.PCSRewindSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction + +set_option maxHeartbeats 4000000 +set_option maxRecDepth 100000 +attribute [local irreducible] ParameterBounds.config +open PCSRewindExtractor OriginalClaimsChecker AuthenticatedResetSupport + +/-- The generic final predicate is used only for the common-coordinate and +shape certificate. Original source functionals are checked separately once. -/ +def decodedWithFinal (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checkOriginal : Witness input.config input.lanes → Bool) : Option (Witness input.config input.lanes) := + (decodeRecords input records noWrap).1.bind fun decoded => + (finish {input with claims := #[]} (paddedWitness input.config input.lanes decoded) records).bind fun certified => + if checkOriginal certified then some certified else none + +/-- Removing only the public functional checks preserves the same shape and +common-coordinate certificate and the literal projected witness. -/ +theorem finish_claimless (input : Public) (candidate : Array E) + (records : List (Record input.config)) (w : Witness input.config input.lanes) + (output : finish input candidate records = some w) : + finish {input with claims := #[]} candidate records = some w := by + unfold finish at output + split at output + · rename_i good + have retained : verified {input with claims := #[]} candidate records = true := by + simp only [verified, Bool.and_eq_true] at good + simp [verified, good.1.1, good.1.2] + simpa only [finish, retained, Bool.true_eq, ite_true] using output + · contradiction + +/-- Generic supported recovery transfers to the actual original checker. The +checker truth must be derived from the original statement, not assumed as an +extractor-success event. No decoder or support certificate is replaced. -/ +theorem decodedWithFinal_recover (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checkOriginal : Witness input.config input.lanes → Bool) (w : Witness input.config input.lanes) + (recovered : (decodeAndCheck input records noWrap).1 = some w) + (checked : checkOriginal w = true) : + decodedWithFinal input records noWrap checkOriginal = some w := by + simp only [decodeAndCheck] at recovered + obtain ⟨decoded, decodedOutput, certificate⟩ := Option.bind_eq_some_iff.mp recovered + have retained := finish_claimless input _ records w certificate + simp only [decodedWithFinal, decodedOutput, Option.bind, retained, checked, + ite_true] + +theorem decodedWithFinal_checked (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checkOriginal : Witness input.config input.lanes → Bool) (w : Witness input.config input.lanes) + (output : decodedWithFinal input records noWrap checkOriginal = some w) : + checkOriginal w = true := by + simp only [decodedWithFinal, Option.bind_eq_some_iff] at output + obtain ⟨decoded, _, certified, _, checked⟩ := output + split at checked + · rename_i good + have equal := Option.some.inj checked + subst w + exact good + · contradiction + +/-- The stop certificate enforces the actual fixed Root0 candidate relation; +checking unrelated public functionals alone is never considered extraction. -/ +theorem decodedWithFinal_root (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checkOriginal : Witness input.config input.lanes → Bool) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (threshold : width input.config - 1 < ParameterBounds.threshold input.config 0) + (w : Witness input.config input.lanes) + (output : decodedWithFinal input records noWrap checkOriginal = some w) : + Explains {input with claims := #[]} w := by + simp only [decodedWithFinal, Option.bind_eq_some_iff] at output + obtain ⟨decoded, _, certified, certificate, checked⟩ := output + split at checked + · have equal := Option.some.inj checked + subst w + exact finish_explains {input with claims := #[]} _ records authenticated + foldBound laneBound noWrap threshold certified certificate + · contradiction + +/-- No accepted-prefix or unchecked-decoder stop is allowed. -/ +def program (input : Public) (level : Fin input.config.folds.size) + (tapes : List (Tape input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (checkOriginal : Witness input.config input.lanes → Bool) : RewindProgram input.config input.lanes := + collectAcceptedProgram input level + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) tapes + (fun records => decodedWithFinal input (baseRecords records) noWrap checkOriginal) + +abbrev Seed (profile : ParameterBounds.Profile) (rounds : Nat) := + RingPCSGame.Prefix × PCSRewindExtractor.Seed profile rounds + +abbrev RepeatedSeed (profile : ParameterBounds.Profile) (attempts rounds : Nat) := + Fin attempts → Seed profile rounds + +/-- One legal public-compression prefix and the real Root0 reset collector. +The mutable prover is replayed through the existing strict-prefix machine. -/ +def runOne {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : Seed profile rounds) : + RewindResult (ParameterBounds.config profile) lanes := + let inp := OriginalClaimsChecker.input prepared root seed.1 + runRewind inp (strategy seed.1) (streamLength inp.config) + (rounds * streamLength inp.config) + (program inp (initialLevel profile) (seedTapes profile rounds inp rfl seed.2) + (InitialCandidates.production_initial_facts profile).2.2.1 + (OriginalClaimsChecker.check prepared)) + +/-- This loop stops only at an actually source-checked output. Failed original +family checks consume their real trial and continue to the next fresh prefix. -/ +def runAttempts {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) : + List (Seed profile rounds) → RewindResult (ParameterBounds.config profile) lanes + | [] => ⟨none, 0⟩ + | seed :: rest => + let first := runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed + match first.output with + | some w => ⟨some w, first.responseCalls⟩ + | none => + let later := runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy rest + ⟨later.output, first.responseCalls + later.responseCalls⟩ + +/-- Executable wrapper: fixed immutable originals, one cached preparation, and +fresh public-prefix plus actual legal collector randomness at each attempt. +Malformed source dimensions fail their literal preparation guard. -/ +def run {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : RepeatedSeed profile attempts rounds) : + RewindResult (ParameterBounds.config profile) lanes := + match prepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue with + | none => ⟨none, 0⟩ + | some prepared => runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy (List.ofFn seed) + +theorem program_run (prover : CommittedProver) + (level : Fin prover.input.config.folds.size) (tapes : List (Tape prover.input.config)) + (noWrap : prover.input.config.logN - prover.input.config.folds[0]! + prover.input.config.rates[0]! ≤ 64) + (checkOriginal : Witness prover.input.config prover.input.lanes → Bool) (maxReplay : Nat) + (within : ∀ tape ∈ tapes, + (visibleBatches prover.input.config tape.1 (challenges prover.input.config tape)).length ≤ maxReplay) : + runRewind prover.input prover.respond maxReplay (collectionFuel prover.input tapes) + (program prover.input level tapes noWrap checkOriginal) = + ⟨decodedWithFinal prover.input (baseRecords (collectedRecords prover level + (prover.input.config.logN - prover.input.config.folds[0]! + prover.input.config.rates[0]!) tapes)) + noWrap checkOriginal, collectionCalls prover.input tapes⟩ := + run_collectAcceptedProgram prover level _ maxReplay tapes within _ + +theorem runOne_value {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : Seed profile rounds) : + let inp := OriginalClaimsChecker.input prepared root seed.1 + let tapes := seedTapes profile rounds inp rfl seed.2 + runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed = + ⟨decodedWithFinal inp (baseRecords (collectedRecords ⟨inp, strategy seed.1⟩ + (initialLevel profile) (initialDepth profile) tapes)) + (InitialCandidates.production_initial_facts profile).2.2.1 + (OriginalClaimsChecker.check prepared), collectionCalls inp tapes⟩ := by + dsimp only + unfold runOne + dsimp only + rw [← collectionFuel_ofFn (OriginalClaimsChecker.input prepared root seed.1) rounds + (fun round => fullResetTape (OriginalClaimsChecker.input prepared root seed.1) + seed.2.1 (initialLevel profile) (initialDepth profile) (initialChunks profile) + (seed.2.2 round).1 (seed.2.2 round).2)] + dsimp only [seedTapes] + refine program_run ⟨OriginalClaimsChecker.input prepared root seed.1, strategy seed.1⟩ + (initialLevel profile) _ _ (OriginalClaimsChecker.check prepared) _ ?_ + intro tape member + exact (visible_length _ _).le + +theorem runOne_checked {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : Seed profile rounds) + (w : Witness (ParameterBounds.config profile) lanes) + (output : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output = some w) : + OriginalClaimsChecker.check prepared w = true := by + rw [runOne_value] at output + exact decodedWithFinal_checked (OriginalClaimsChecker.input prepared root seed.1) + _ _ (OriginalClaimsChecker.check prepared) w output + +theorem runOne_root {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) (seed : Seed profile rounds) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (w : Witness (ParameterBounds.config profile) lanes) + (output : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output = some w) : + Explains (ExecutionShapes.Input profile lanes root #[]) w := by + rw [runOne_value] at output + exact decodedWithFinal_root _ _ _ _ + (collected_base_authenticated profile lanes root + (OriginalClaimsChecker.input prepared root seed.1).claims (strategy seed.1) _) + (InitialCandidates.production_initial_facts profile).2.1 laneBound + (InitialCandidates.production_initial_facts profile).2.2.2 w output + +theorem runAttempts_checked {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seeds : List (Seed profile rounds)) (w : Witness (ParameterBounds.config profile) lanes) + (output : (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).output = some w) : + OriginalClaimsChecker.check prepared w = true := by + induction seeds with + | nil => simp [runAttempts] at output + | cons seed rest ih => + dsimp only [runAttempts] at output + cases first : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output with + | none => + simp only [first] at output + exact ih output + | some candidate => + simp only [first] at output + cases Option.some.inj output + exact runOne_checked _ _ _ _ _ _ _ _ _ _ _ w first + +theorem runAttempts_root {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (seeds : List (Seed profile rounds)) (w : Witness (ParameterBounds.config profile) lanes) + (output : (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).output = some w) : + Explains (ExecutionShapes.Input profile lanes root #[]) w := by + induction seeds with + | nil => simp [runAttempts] at output + | cons seed rest ih => + dsimp only [runAttempts] at output + cases first : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output with + | none => + simp only [first] at output + exact ih output + | some candidate => + simp only [first] at output + cases Option.some.inj output + exact runOne_root _ _ _ _ _ _ _ _ _ _ _ laneBound w first + +/-- Actual source attempts have the same first-success output law as generic +attempts; a failed original checker never stops the outer loop. -/ +theorem runAttempts_output {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seeds : List (Seed profile rounds)) : + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).output = + firstOutput (seeds.map fun seed => + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output) := by + induction seeds with + | nil => rfl + | cons seed rest ih => + dsimp only [runAttempts, List.map_cons] + cases first : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output <;> + simp only [List.map_cons, first, firstOutput, ih] + +/-- A source run fails exactly when every actual independently seeded attempt +fails, including attempts rejected only by an original-family check. -/ +theorem runAttempts_output_none_iff {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seeds : List (Seed profile rounds)) : + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).output = none ↔ + ∀ seed ∈ seeds, + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output = none := by + induction seeds with + | nil => simp [runAttempts] + | cons seed rest ih => + dsimp only [runAttempts] + cases first : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output <;> + simp [first, ih] + +/-- Early success charges only executed attempts; otherwise each actual +collector's full response count is added, including failed original checks. -/ +theorem runAttempts_responseCalls_le {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seeds : List (Seed profile rounds)) : + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).responseCalls ≤ + (seeds.map fun seed => + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).responseCalls).sum := by + induction seeds with + | nil => simp [runAttempts] + | cons seed rest ih => + dsimp only [runAttempts] + cases first : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output <;> + simp only [List.map_cons, List.sum_cons] + · exact Nat.add_le_add_left ih _ + · exact Nat.le_add_right _ _ + +/-- If no output is returned, every attempt ran and the response count is +exactly the sum of the actual per-attempt collector counts. -/ +theorem runAttempts_responseCalls_of_none {m : Nat} (profile : ParameterBounds.Profile) (rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (seeds : List (Seed profile rounds)) + (output : (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).output = none) : + (runAttempts profile rounds lanes family points anchorPoint anchorValue prepared root strategy seeds).responseCalls = + (seeds.map fun seed => + (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).responseCalls).sum := by + induction seeds with + | nil => rfl + | cons seed rest ih => + dsimp only [runAttempts] at output ⊢ + cases first : (runOne profile rounds lanes family points anchorPoint anchorValue prepared root strategy seed).output with + | none => + simp only [first] at output ⊢ + simp only [List.map_cons, List.sum_cons, ih output] + | some w => simp only [first, Option.some_ne_none] at output + +#print axioms decodedWithFinal_checked +#print axioms decodedWithFinal_root +#print axioms program_run +#print axioms runOne_value +#print axioms runAttempts_checked +#print axioms runAttempts_root +#print axioms finish_claimless +#print axioms decodedWithFinal_recover +#print axioms runAttempts_output +#print axioms runAttempts_output_none_iff +#print axioms runAttempts_responseCalls_le +#print axioms runAttempts_responseCalls_of_none +end Whir.PCSRewindSource diff --git a/verification/whir/Whir/PCSRewindSourceRelation.lean b/verification/whir/Whir/PCSRewindSourceRelation.lean new file mode 100644 index 000000000..975ee5563 --- /dev/null +++ b/verification/whir/Whir/PCSRewindSourceRelation.lean @@ -0,0 +1,51 @@ +import Whir.PCSRewindSourceProgram +import Whir.CountedCandidateCheckOriginalCorrectness + +/-! Deterministic source output correctness includes the fixed Root0 candidate +relation, all uncompressed family slices, all ordinary/strided claims, and the +same literal retained anchor. It is stronger than observing Option.some. -/ +namespace Whir.PCSRewindSource +open Concrete Protocol CausalGame KnowledgeExtraction OriginalClaimsChecker + +structure ExplainsOriginal {m : Nat} (c : Config) (lanes : Nat) (root : BaseOracle) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (w : Witness c lanes) : Prop where + rootCandidate : w ∈ InitialCandidates.witnesses c lanes root + original : RingPCSGame.Honest c lanes family points w + anchor : CommitmentAnchor.value c lanes w anchorPoint = anchorValue + +/-- Every actual returned output explains the original source statement and +belongs to the original Root0 list. No probability/certificate premise appears. -/ +theorem run_output_explains {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : RepeatedSeed profile attempts rounds) + (w : Witness (ParameterBounds.config profile) lanes) + (output : (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).output = some w) : + ExplainsOriginal (ParameterBounds.config profile) lanes root family points anchorPoint anchorValue w := by + cases prepared : prepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue with + | none => simp [run, prepared] at output + | some cached => + simp only [run, prepared] at output + have member := (runAttempts_root profile rounds lanes family points anchorPoint anchorValue cached root strategy + cached.guards.2.2.2.1 (List.ofFn seed) w output).1 + have original := (check_iff cached w).mp + (runAttempts_checked profile rounds lanes family points anchorPoint anchorValue cached root strategy + (List.ofFn seed) w output) + exact ⟨member, original.1, original.2⟩ + +/-- A returned word outside the Root0 relation or violating ANY original +functional is impossible, not hidden in a no-output probability predicate. -/ +theorem run_ne_wrong_output {m : Nat} (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (seed : RepeatedSeed profile attempts rounds) + (w : Witness (ParameterBounds.config profile) lanes) + (wrong : ¬ ExplainsOriginal (ParameterBounds.config profile) lanes root family points anchorPoint anchorValue w) : + (run profile attempts rounds lanes family points anchorPoint anchorValue root strategy seed).output ≠ some w := by + intro returned + exact wrong (run_output_explains _ _ _ _ _ _ _ _ _ _ _ w returned) + +#print axioms run_output_explains +#print axioms run_ne_wrong_output +end Whir.PCSRewindSource diff --git a/verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean b/verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean new file mode 100644 index 000000000..7073bb431 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean @@ -0,0 +1,94 @@ +import Whir.PCSRewindKnowledgeHeavy +import Whir.PCSRewindSourceRelation +import Whir.CountedCandidateCheckOriginalResources + +/-! Straight-line Root0 extraction. Root rows are indexed directly: no record +collection, reset, strategy, or verifier randomness is an input. The common +support check uses the unchanged dense encoder and the original list threshold. +Malformed physical roots and public metadata are rejected before decoding. -/ +namespace Whir.PCSRoundByRoundSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open scoped BigOperators +set_option maxHeartbeats 4000000 + +/-- Literal physical availability, not equality with an honest commitment. -/ +def FullRoot (c : Config) (lanes : Nat) (root : BaseOracle) : Prop := + root.size = blockLength c ∧ ∀ i : Fin root.size, root[i].size = lanes +instance (c : Config) (lanes : Nat) (root : BaseOracle) : Decidable (FullRoot c lanes root) := by + unfold FullRoot + infer_instance + +def receivedLane (input : Public) (lane : Fin input.lanes) : Fin (blockLength input.config) → E := + fun q => E.ofK (recordLane input.lanes input.root[q.val]! lane.val) + +/-- One counted Gao/novel/base-word run per occupied lane; only lane vectors +are materialized. Root leaves are neither copied nor searched. -/ +def decodeRoot (input : Public) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + Option (Witness input.config input.lanes) × Nat := + let decoded := Array.ofFn fun lane : Fin input.lanes => + ConcreteRowExtraction.countedExtractRow (input.config.logN - input.config.folds[0]!) + input.config.rates[0]! noWrap ⟨Array.ofFn (receivedLane input lane), by simp⟩ + (PCSRewindExtraction.assembleWitness input fun lane => + (decoded[lane.val]'(by simp [decoded])).1, + (decoded.map Prod.snd).toList.sum) + +def matchingRows (input : Public) (w : Witness input.config input.lanes) : + Finset (Fin (blockLength input.config)) := + let encoded := encodedLanes input.config (paddedWitness input.config input.lanes w) + Finset.univ.filter fun q => rowMatches input.config input.lanes encoded (q, input.root[q.val]!) + +/-- A deterministic common support predicate on the actual fixed Root0 array. -/ +def StrongRootSupport (profile : ParameterBounds.Profile) (lanes : Nat) (root : BaseOracle) + (w : Witness (ParameterBounds.config profile) lanes) : Prop := + PCSRewindExtractor.heavyAgreementCap profile < + (matchingRows ⟨ParameterBounds.config profile, lanes, root, #[]⟩ w).card + +/-- Instrument the actual source encoder; filtering visits each root coordinate +once and never constructs a full-root record table. -/ +def countedSupport (input : Public) (w : Witness input.config input.lanes) : Nat × Nat := + let encoded := CountedCandidateCheck.countedEncodedLanes input.config + (paddedWitness input.config input.lanes w) + ((Finset.univ.filter fun q : Fin (blockLength input.config) => + rowMatches input.config input.lanes encoded.1 (q, input.root[q.val]!)).card, encoded.2) + +theorem countedSupport_value (input : Public) (w : Witness input.config input.lanes) : + (countedSupport input w).1 = (matchingRows input w).card := by + simp [countedSupport, matchingRows, CountedCandidateCheck.countedEncodedLanes_value] + +theorem decodeRoot_cost (input : Public) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) : + (decodeRoot input noWrap).2 ≤ input.lanes * + ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) := by + simp only [decodeRoot, Array.toList_map, Array.toList_ofFn, List.map_ofFn, List.sum_ofFn] + calc + _ ≤ ∑ _lane : Fin input.lanes, + ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) := by + apply Finset.sum_le_sum + intro lane _ + exact ConcreteRowExtraction.countedExtractRow_polynomial_cost _ _ noWrap redundancy _ + _ = _ := by simp + +def runForConfig {m : Nat} (c : Config) + (noWrap : c.logN - c.folds[0]! + c.rates[0]! ≤ 64) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) : + Option (Witness c lanes) := + if m ≤ 2^64 ∧ points.size ≤ 2^64 ∧ FullRoot c lanes root then + (OriginalClaimsChecker.prepare c lanes family points anchorPoint anchorValue).bind fun prepared => + let input : Public := ⟨c, lanes, root, #[]⟩ + (decodeRoot input noWrap).1.bind fun w => + let support := countedSupport input w + if ParameterBounds.threshold input.config 0 ≤ support.1 ∧ + OriginalClaimsChecker.check prepared w = true then some w else none + else none + +def run {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) : + Option (Witness (ParameterBounds.config profile) lanes) := + runForConfig (ParameterBounds.config profile) (InitialCandidates.production_initial_facts profile).2.2.1 + lanes family points anchorPoint anchorValue root + +end Whir.PCSRoundByRoundSource diff --git a/verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean b/verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean new file mode 100644 index 000000000..e8446b9e8 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean @@ -0,0 +1,191 @@ +import Whir.PCSRoundByRoundSourceDecoder + +/-! Kernel-checked output correctness and same-word recovery for the executable +full Root0 decoder. Common support is computed, not supplied to the algorithm. -/ +namespace Whir.PCSRoundByRoundSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open scoped BigOperators +set_option maxHeartbeats 4000000 +attribute [local irreducible] ParameterBounds.config + + theorem support_member (input : Public) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (w : Witness input.config input.lanes) + (enough : ParameterBounds.threshold input.config 0 ≤ (matchingRows input w).card) : + w ∈ InitialCandidates.witnesses input.config input.lanes input.root := by + classical + have cube : laneCount input.config * width input.config = 2^input.config.logN := by + unfold laneCount width + rw [← Nat.pow_add, Nat.add_sub_of_le foldBound] + have member : paddedWitness input.config input.lanes w ∈ + InitialCandidates.extensionCandidates input.config input.lanes input.root := by + apply (CandidateFolding.arrayCandidates_mem_iff _ _ _ _ _).mpr + refine ⟨?_, matchingRows input w, enough, ?_⟩ + · simp [paddedWitness, ArrayLayout.size_tab, cube] + · intro lane q hq + have matched : rowMatches input.config input.lanes + (encodedLanes input.config (paddedWitness input.config input.lanes w)) + (q, input.root[q.val]!) = true := by + simpa [matchingRows] using hq + exact matches_sound _ _ _ _ matched lane + have projected : InitialCandidates.project input.config input.lanes + (paddedWitness input.config input.lanes w) = w := by + funext i + have limit : i.val < 2^input.config.logN := by + have occupied := Nat.mul_le_mul_right (width input.config) laneBound + rw [cube] at occupied + exact i.isLt.trans_le occupied + simp [InitialCandidates.project, paddedWitness, tab, getElem!_pos, limit, i.isLt, E.ofK] + exact Finset.mem_image.mpr ⟨_, member, projected⟩ + + theorem run_output_explains {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (w : Witness (ParameterBounds.config profile) lanes) + (output : run profile lanes family points anchorPoint anchorValue root = some w) : + PCSRewindSource.ExplainsOriginal (ParameterBounds.config profile) lanes root family points anchorPoint anchorValue w := by + unfold run runForConfig at output + split at output + · obtain ⟨prepared, _, output⟩ := Option.bind_eq_some_iff.mp output + obtain ⟨decoded, _, output⟩ := Option.bind_eq_some_iff.mp output + dsimp only at output + split at output + · rename_i checked + have same := Option.some.inj output + subst decoded + have original := (OriginalClaimsChecker.check_iff prepared w).mp checked.2 + refine ⟨support_member ⟨ParameterBounds.config profile, lanes, root, #[]⟩ + (InitialCandidates.production_initial_facts profile).2.1 + prepared.guards.2.2.2.1 w ?_, original.1, original.2⟩ + simpa only [countedSupport_value] using checked.1 + · contradiction + · contradiction + + theorem decodeRoot_recovers (input : Public) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) + (w : Witness input.config input.lanes) + (radius : ∀ lane : Fin input.lanes, + 2 * hammingDist + (Vector.mk (Array.ofFn (receivedLane input lane)) (by simp) : + Vector E (ConcreteRowExtraction.domain + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) noWrap).n).get + (fun i => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[i.val]!) ≤ + blockLength input.config - width input.config) : + (decodeRoot input noWrap).1 = some w := by + apply PCSRewindExtraction.assembleWitness_recovers + intro lane + simp only [Array.getElem_ofFn] + exact (ConcreteRowExtraction.countedExtractRow_recovers _ _ noWrap redundancy + (PCSRewindExtraction.witnessLane input w lane) (by simp [PCSRewindExtraction.witnessLane]) + _ (radius lane)).1 + + theorem receivedLane_distance (input : Public) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (w : Witness input.config input.lanes) (lane : Fin input.lanes) : + hammingDist (receivedLane input lane) + (fun q => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]!) ≤ + blockLength input.config - (matchingRows input w).card := by + classical + let target := fun q : Fin (blockLength input.config) => + (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]! + have subset : matchingRows input w ⊆ UniqueRadiusSampling.agreement + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (receivedLane input lane) target := by + intro q member + simp only [UniqueRadiusSampling.agreement, Finset.mem_filter, Finset.mem_univ, true_and] + apply SupportedCandidateRecovery.live_agrees_of_rowMatches input foldBound laneBound w q _ lane + simpa [matchingRows] using member + have card := Finset.card_le_card subset + have partition := UniqueRadiusSampling.agreement_add_distance + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (receivedLane input lane) target + change _ + hammingDist (receivedLane input lane) target = blockLength input.config at partition + change hammingDist (receivedLane input lane) target ≤ _ + omega + +private theorem hammingDist_index_cast {M N : Nat} (same : M = N) (received target : Fin N → E) : + hammingDist (fun q => received (Fin.cast same q)) (fun q => target (Fin.cast same q)) = + hammingDist received target := by + subst N + rfl + + theorem decodeRoot_recovers_heavy (profile : ParameterBounds.Profile) (lanes : Nat) (root : BaseOracle) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (w : Witness (ParameterBounds.config profile) lanes) + (heavy : StrongRootSupport profile lanes root w) : + (decodeRoot ⟨ParameterBounds.config profile, lanes, root, #[]⟩ + (InitialCandidates.production_initial_facts profile).2.2.1).1 = some w := by + let input : Public := ⟨ParameterBounds.config profile, lanes, root, #[]⟩ + have gao : PCSRewindExtractor.gaoAgreementCap profile < (matchingRows input w).card := + (Nat.le_max_left _ _).trans_lt heavy + have redundancy := (PCSRewindExtractor.production_heavy_static profile).2.1 + have card : (matchingRows input w).card ≤ blockLength input.config := by + exact (Finset.card_le_univ _).trans_eq (by simp) + have enough : 2 * (blockLength input.config - (matchingRows input w).card) ≤ + blockLength input.config - width input.config := by + unfold PCSRewindExtractor.gaoAgreementCap at gao + change (blockLength input.config + width input.config - 1) / 2 < _ at gao + change width input.config < blockLength input.config at redundancy + omega + apply decodeRoot_recovers input _ redundancy w + intro lane + have distance := receivedLane_distance input (InitialCandidates.production_initial_facts profile).2.1 + laneBound w lane + have size : (ConcreteRowExtraction.domain + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (InitialCandidates.production_initial_facts profile).2.2.1).n = blockLength input.config := + ConcreteRowExtraction.domain_size _ _ + have receivedEqual : (Vector.mk (Array.ofFn (receivedLane input lane)) (by simp) : + Vector E (ConcreteRowExtraction.domain + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (InitialCandidates.production_initial_facts profile).2.2.1).n).get = + fun q => receivedLane input lane (Fin.cast size q) := by + funext q + simp [Vector.get, Fin.cast] + rw [receivedEqual] + change 2 * hammingDist (fun q => receivedLane input lane (Fin.cast size q)) + (fun q => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[(Fin.cast size q).val]!) ≤ _ + rw [hammingDist_index_cast size (receivedLane input lane) + (fun q => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]!)] + exact (Nat.mul_le_mul_left 2 distance).trans enough + + theorem run_recovers_heavy {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config profile) lanes m family points anchorPoint anchorValue) + (familyCap : m ≤ 2^64) (pointCap : points.size ≤ 2^64) + (full : FullRoot (ParameterBounds.config profile) lanes root) + (w : Witness (ParameterBounds.config profile) lanes) + (heavy : StrongRootSupport profile lanes root w) + (original : RingPCSGame.Honest (ParameterBounds.config profile) lanes family points w) + (anchor : CommitmentAnchor.value (ParameterBounds.config profile) lanes w anchorPoint = anchorValue) : + run profile lanes family points anchorPoint anchorValue root = some w := by + have recovered := decodeRoot_recovers_heavy profile lanes root prepared.guards.2.2.2.1 w heavy + have threshold := (PCSRewindExtractor.production_heavy_static profile).2.2 + have enough : ParameterBounds.threshold (ParameterBounds.config profile) 0 ≤ + (matchingRows ⟨ParameterBounds.config profile, lanes, root, #[]⟩ w).card := by + unfold StrongRootSupport at heavy + omega + unfold run runForConfig + rw [ite_eq_left ⟨familyCap, pointCap, full⟩] + cases hp : OriginalClaimsChecker.prepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue with + | none => + have valid := (OriginalClaimsChecker.prepare_some_iff _ _ family points anchorPoint anchorValue).mpr prepared.guards + simp [hp] at valid + | some cached => + simp only [Option.bind_some, recovered] + rw [ite_eq_left ⟨by simpa only [countedSupport_value] using enough, + (OriginalClaimsChecker.check_iff cached w).mpr ⟨original, anchor⟩⟩] + +#print axioms run_output_explains +#print axioms decodeRoot_recovers_heavy +#print axioms run_recovers_heavy +end Whir.PCSRoundByRoundSource diff --git a/verification/whir/Whir/PCSRoundByRoundSourceDecoderCost.lean b/verification/whir/Whir/PCSRoundByRoundSourceDecoderCost.lean new file mode 100644 index 000000000..bda939951 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundSourceDecoderCost.lean @@ -0,0 +1,133 @@ +import Whir.PCSRoundByRoundSourceDecoder + +/-! Value-connected full-root field/resource accounting. Field operations use +actual Gao and dense encoder counters and the actual original-check counters. +The additional charge is a conservative reservation for physical root scanning, +lane-vector construction, common-coordinate comparisons, and witness assembly. +It does not charge a quadratic record lookup: no such operation exists here. -/ +namespace Whir.PCSRoundByRoundSource +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +set_option maxHeartbeats 4000000 +attribute [local irreducible] ParameterBounds.config + +/-- Word slots, reads, comparisons and loop visits outside the counted algebra +backends. A charge is reserved even when a guard short-circuits. -/ +def rootTableCharge (c : Config) (lanes : Nat) : Nat := + 16 * (blockLength c + 1) * (laneCount c + 1) + + 16 * (lanes + 1) * (blockLength c + width c + 1) + +/-- The instrumented counterpart runs each backend only once. Its first +projection is exactly `run`, including every malformed/original/support guard. -/ +def countedRun {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) : + Option (Witness (ParameterBounds.config profile) lanes) × Nat := + let c := ParameterBounds.config profile + if m ≤ 2^64 ∧ points.size ≤ 2^64 ∧ FullRoot c lanes root then + let prep := OriginalClaimsChecker.countedPrepare c lanes family points anchorPoint anchorValue + match prep.1 with + | none => (none, prep.2.total + rootTableCharge c lanes) + | some prepared => + let input : Public := ⟨c, lanes, root, #[]⟩ + let decoded := decodeRoot input (InitialCandidates.production_initial_facts profile).2.2.1 + match decoded.1 with + | none => (none, prep.2.total + decoded.2 + rootTableCharge c lanes) + | some w => + let support := countedSupport input w + let checked := OriginalClaimsChecker.countedCheck prepared w + (if ParameterBounds.threshold c 0 ≤ support.1 ∧ checked.1 = true then some w else none, + prep.2.total + decoded.2 + support.2 + checked.2.total + rootTableCharge c lanes) + else (none, 16) + + theorem countedRun_value {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) : + (countedRun profile lanes family points anchorPoint anchorValue root).1 = + run profile lanes family points anchorPoint anchorValue root := by + unfold countedRun run runForConfig + dsimp only + split + · rw [OriginalClaimsChecker.countedPrepare_value] + cases hp : OriginalClaimsChecker.prepare (ParameterBounds.config profile) lanes family points anchorPoint anchorValue + · simp + · simp only [Option.bind_some] + split <;> simp_all only [Option.bind_none, Option.bind_some, + OriginalClaimsChecker.countedCheck_value] + · rfl + +/-- Explicit polynomial in block length, full lane count, occupied lane count, +original families and points. The Gao term is degree seven. -/ +def resourcePolynomial (nodes fullLanes lanes families points : Nat) : Nat := + lanes * ConcreteRowExtraction.rowArithmeticPolynomial nodes + + fullLanes * nodes * (16576 + 5 * nodes) + + OriginalClaimsChecker.preparationPolynomial (fullLanes * nodes) families points + + OriginalClaimsChecker.checkPolynomial (fullLanes * nodes) families points + + 16 * (nodes + 1) * (fullLanes + 1) + 16 * (lanes + 1) * (2 * nodes + 1) + 16 + + theorem countedRun_polynomial_cost {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (root : BaseOracle) : + (countedRun profile lanes family points anchorPoint anchorValue root).2 ≤ + resourcePolynomial (blockLength (ParameterBounds.config profile)) + (laneCount (ParameterBounds.config profile)) lanes m points.size := by + let c := ParameterBounds.config profile + have noWrap := (InitialCandidates.production_initial_facts profile).2.2.1 + have redundancy := (PCSRewindExtractor.production_heavy_static profile).2.1 + have widthBound : width c ≤ blockLength c := redundancy.le + have cube : 2^c.logN ≤ laneCount c * blockLength c := by + have exactCube : 2^c.logN = laneCount c * width c := by + unfold laneCount width + rw [← Nat.pow_add, Nat.add_sub_of_le (InitialCandidates.production_initial_facts profile).2.1] + rw [exactCube] + exact Nat.mul_le_mul_left _ widthBound + have prep := OriginalClaimsChecker.countedPrepare_total c lanes family points anchorPoint anchorValue + have prepBound : (OriginalClaimsChecker.countedPrepare c lanes family points anchorPoint anchorValue).2.total ≤ + OriginalClaimsChecker.preparationPolynomial (laneCount c * blockLength c) m points.size := by + apply prep.trans + unfold OriginalClaimsChecker.preparationPolynomial + gcongr + have tableBound : rootTableCharge c lanes ≤ + 16 * (blockLength c + 1) * (laneCount c + 1) + 16 * (lanes + 1) * (2 * blockLength c + 1) := by + unfold rootTableCharge + gcongr + omega + have encodeBound : CountedCandidateCheck.encoderBound c ≤ + laneCount c * blockLength c * (16576 + 5 * blockLength c) := by + simpa [CountedCandidateCheck.checkerBound, CountedCandidateCheck.checkerPolynomial] using + CountedCandidateCheck.checkerBound_polynomial (⟨c, lanes, #[], #[]⟩ : Public) noWrap + unfold countedRun + dsimp only + split + · split + · dsimp only + unfold resourcePolynomial + change _ ≤ lanes * _ + _ + _ + _ + _ + _ + 16 + dsimp only [c] at prepBound tableBound + omega + · rename_i prepared hp + have decodeBound := decodeRoot_cost (⟨c, lanes, root, #[]⟩ : Public) noWrap redundancy + split + · dsimp only + unfold resourcePolynomial + dsimp only [c] at prepBound tableBound decodeBound + omega + · rename_i w hw + have supportBound : (countedSupport ⟨c, lanes, root, #[]⟩ w).2 ≤ + laneCount c * blockLength c * (16576 + 5 * blockLength c) := + (CountedCandidateCheck.countedEncodedLanes_cost c _).trans encodeBound + have checkBound := OriginalClaimsChecker.countedCheck_total prepared w + have checkBound' : (OriginalClaimsChecker.countedCheck prepared w).2.total ≤ + OriginalClaimsChecker.checkPolynomial (laneCount c * blockLength c) m points.size := + checkBound.trans (by unfold OriginalClaimsChecker.checkPolynomial; gcongr) + dsimp only + unfold resourcePolynomial + dsimp only [c] at prepBound tableBound decodeBound supportBound checkBound' + omega + · dsimp only + unfold resourcePolynomial + omega + +#print axioms decodeRoot_cost +#print axioms countedRun_value +#print axioms countedRun_polynomial_cost +end Whir.PCSRoundByRoundSource diff --git a/verification/whir/Whir/PCSRoundByRoundSourceDecoderSmoke.lean b/verification/whir/Whir/PCSRoundByRoundSourceDecoderSmoke.lean new file mode 100644 index 000000000..7ea0fe158 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundSourceDecoderSmoke.lean @@ -0,0 +1,47 @@ +import Whir.PCSRoundByRoundSourceDecoder + +/-! TOY GENERIC HELPER SMOKE, not a production-profile runtime benchmark. +Runs the exact `runForConfig` helper used by production `run`, with eight +nontrivial words, sixteen full-root rows, all64 slices, an ordinary and a +strided point, and the immutable original anchor. -/ +namespace Whir.PCSRoundByRoundSourceDecoderSmoke +open Concrete Protocol CausalGame SupportedCandidateExtraction PCSRoundByRoundSource + +def config : Config := ⟨3, #[1, 1], #[2, 2], #[16, 8], #[0, 1]⟩ +def words : Array K := #[3, 5, 7, 11, 13, 17, 19, 23] +def witness : Witness config 2 := fun i => words[i.val]! +def anchorPoint : Array E := #[E.ofK 29, E.ofK 31, E.ofK 37] +def family : Fin 1 → RingPCSGame.FamilyClaim := fun _ => + ⟨0, #[], fun bit => if RingPCSGame.wordBit 3 bit then 1 else 0⟩ +def points : Array RingPCSGame.PointClaim := + #[.point 1 #[] (E.ofK 5), .strided 0 1 1 #[] (E.ofK 5)] +def root : BaseOracle := + let encoded := encodedLanes config (paddedWitness config 2 witness) + Array.ofFn fun q : Fin 16 => #[(encoded[1]!)[q.val]!.c0, (encoded[0]!)[q.val]!.c0] + +def check (condition : Bool) (message : String) : IO Unit := + unless condition do throw (IO.userError message) + +def smoke : IO Unit := do + let anchorValue := CommitmentAnchor.value config 2 witness anchorPoint + let extract := fun original root => + (runForConfig config (by decide) 2 original points anchorPoint anchorValue root).map Array.ofFn + check (extract family root == some words) "toy full-root same-word extraction failed" + let corrupt := root.set! 0 ((root[0]!).map fun x => x + 1) + check (extract family corrupt == some words) "toy heavy-corrupted root recovery failed" + check ((matchingRows ⟨config, 2, corrupt, #[]⟩ witness).card == 15) + "toy common-support guard did not count actual corrupted rows" + let wrong : Fin 1 → RingPCSGame.FamilyClaim := fun j => + { family j with slices := fun bit => (family j).slices bit + 1 } + check ((extract wrong root).isNone) "toy wrong original slices accepted" + check ((extract family (root.pop)).isNone) "toy malformed root length accepted" + check ((extract family (root.set! 0 #[3])).isNone) "toy malformed root lane width accepted" + check ((runForConfig config (by decide) 2 family points #[] anchorValue root).isNone) + "toy malformed anchor metadata accepted" + check ((runForConfig config (by decide) 2 family points anchorPoint (anchorValue + 1) root).isNone) + "toy changed saved anchor accepted" + IO.println "TOY GENERIC HELPER SMOKE: 8 nontrivial words, 16 directly indexed rows; same word recovered with 1 corrupted row (15 common matches); malformed root/metadata, wrong originals and changed anchor rejected" + +end Whir.PCSRoundByRoundSourceDecoderSmoke + +def main : IO Unit := Whir.PCSRoundByRoundSourceDecoderSmoke.smoke diff --git a/verification/whir/Whir/PublicCompressionCoupling.lean b/verification/whir/Whir/PublicCompressionCoupling.lean new file mode 100644 index 000000000..5a27826e3 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCoupling.lean @@ -0,0 +1,238 @@ +import Whir.PublicMerkleProbability +import Whir.DuplexPublicSimulator + +/-! Actual finite-table collision probabilities for the public compression game. +The complete construction paths are included. These estimates alone do not +assert a real/ideal simulator coupling or the DMV distinguishing endpoint. -/ +namespace Whir.PublicCompressionCoupling +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram TypedOracleCompiler +open scoped BigOperators + +attribute [local instance] PublicMerkleLog.instDecidableEqNode + +private theorem average_fintype {α : Type*} (old new : Fintype α) (f : α → ℚ) : + @average α old f = @average α new f := by + cases Subsingleton.elim old new + rfl + +@[instance_reducible] +private noncomputable def tableFintype : Fintype PrimitiveOracle := + @Pi.instFintype Node (fun _ => Digest32) inferInstance inferInstance (fun _ => inferInstance) + +abbrev Log := PublicMerkleLog.PublicLog + +def outputs (log : Log) : Finset Digest32 := (log.map Prod.snd).toFinset + +theorem outputs_card (log : Log) : (outputs log).card ≤ log.length := by + exact (List.toFinset_card_le _).trans_eq (List.length_map ..) + +/-- Every continuation is monitored, including internal construction calls and +repeated public requests. Only genuinely fresh inputs can cause a collision. -/ +noncomputable def collisionAlarm {R : Type} (C : PrimitiveOracle) {Q : Nat} : + Computation R Q → Log → Bool + | .ret _, _ => false + | .draw n next, log => + decide (PublicMerkleLog.lookup log n = none ∧ C n ∈ outputs log) || + collisionAlarm C (next (C n)) ((n,C n)::log) + +noncomputable def collisionRisk {R : Type} {Q : Nat} : Computation R Q → Log → ℚ + | .ret _, _ => 0 + | .draw n next, log => + match PublicMerkleLog.lookup log n with + | some d => collisionRisk (next d) ((n,d)::log) + | none => average (fun d => if d ∈ outputs log then 1 + else collisionRisk (next d) ((n,d)::log)) + +/-- The exact remaining birthday ledger, retaining the exposed history length. -/ +def collisionLedger (remaining previous : Nat) : ℚ := + ((remaining : ℚ)*previous + remaining*(remaining-1)/2) / 2^256 + +private theorem collisionLedger_nonneg (remaining previous : Nat) : + 0 ≤ collisionLedger remaining previous := by + cases remaining with + | zero => simp [collisionLedger] + | succ n => + unfold collisionLedger + simp only [Nat.cast_add,Nat.cast_one,add_sub_cancel_right] + positivity + +private theorem collisionLedger_step (remaining previous : Nat) : + collisionLedger (remaining+1) previous = + (previous : ℚ)/2^256 + collisionLedger remaining (previous+1) := by + unfold collisionLedger + push_cast + ring + +theorem collisionRisk_bound {R : Type} {Q : Nat} (p : Computation R Q) (log : Log) : + collisionRisk p log ≤ collisionLedger Q log.length := by + classical + induction p generalizing log with + | ret value => exact collisionLedger_nonneg _ _ + | @draw n input next ih => + have hstep := collisionLedger_step n log.length + cases hit : PublicMerkleLog.lookup log input with + | some d => + simp only [collisionRisk,hit] + have ht := ih d ((input,d)::log) + simp only [List.length_cons] at ht + rw [hstep] + have hnon : (0 : ℚ) ≤ (log.length : ℚ)/2^256 := by positivity + linarith + | none => + simp only [collisionRisk,hit] + calc + _ ≤ average (fun d : Digest32 => + (if d ∈ outputs log then (1:ℚ) else 0) + + collisionLedger n (log.length+1)) := by + apply average_mono + intro d + have hn := collisionLedger_nonneg n (log.length+1) + have ht := ih d ((input,d)::log) + simp only [List.length_cons] at ht + by_cases bad : d ∈ outputs log + · simp only [bad,↓reduceIte] + linarith + · simpa only [bad,↓reduceIte,zero_add] using ht + _ = (outputs log).card / (2^256 : ℚ) + + collisionLedger n (log.length+1) := by + rw [average_add,PublicMerkleProbability.uniform_target_probability,average_const] + _ ≤ (log.length : ℚ)/2^256 + collisionLedger n (log.length+1) := by + apply add_le_add_left + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast outputs_card log + _ = _ := hstep.symm + +/-- Exact lazy sampling of the actual finite compression table. No stochastic +oracle premise or assumed bad-event certificate is used. -/ +theorem table_collisionAlarm_eq_risk {R : Type} {Q : Nat} + (p : Computation R Q) (log : Log) : + average (fun C : PrimitiveOracle => + if collisionAlarm (RawOracleCoupling.overlay (PublicMerkleLog.lookup log) C) p log + then 1 else 0) = collisionRisk p log := by + classical + rw [average_fintype _ tableFintype] + let _ := tableFintype + induction p generalizing log with + | ret value => simp [collisionAlarm,collisionRisk,average_const] + | draw n next ih => + cases hit : PublicMerkleLog.lookup log n with + | some d => + have cache := PublicMerkleProbability.lookup_cons_hit log n d hit + simp only [collisionRisk,hit] + rw [← ih d ((n,d)::log),cache] + apply congrArg average + funext C + simp [collisionAlarm,RawOracleCoupling.overlay,hit] + | none => + rw [RawOracleCoupling.overlay_average (PublicMerkleLog.lookup log) n hit + (fun oracle => if collisionAlarm oracle (.draw n next) log then (1:ℚ) else 0)] + simp only [collisionRisk,hit] + apply congrArg average + funext d + have cache := PublicMerkleProbability.lookup_cons log n d + by_cases bad : d ∈ outputs log + · simp [collisionAlarm,RawOracleCoupling.overlay,hit,bad,average_const] + · rw [← ih d ((n,d)::log),cache] + simp only [bad,↓reduceIte] + apply congrArg average + funext C + simp only [collisionAlarm,RawOracleCoupling.overlay,hit, + TypedFiatShamirGame.put_self,Option.getD_some,true_and,bad, + decide_false,Bool.false_or] + apply congrArg (fun oracle : PrimitiveOracle => + if collisionAlarm oracle (next d) ((n,d)::log) then (1:ℚ) else 0) + funext j + simp [RawOracleCoupling.overlay,TypedFiatShamirGame.put,Function.update] + +theorem actual_compression_collision_bound {R : Type} {Q : Nat} + (p : Computation R Q) : + average (fun C : PrimitiveOracle => if collisionAlarm C p [] then 1 else 0) ≤ + collisionLedger Q 0 := by + rw [average_fintype _ tableFintype] + let _ := tableFintype + have he := table_collisionAlarm_eq_risk p [] + rw [average_fintype _ tableFintype] at he + have hb := collisionRisk_bound p [] + have he' : average (fun C : PrimitiveOracle => if collisionAlarm C p [] then 1 else 0) = + collisionRisk p [] := by + trans average (fun C : PrimitiveOracle => + if collisionAlarm (RawOracleCoupling.overlay (PublicMerkleLog.lookup []) C) p [] + then (1:ℚ) else 0) + · apply congrArg average + funext C + have hc : RawOracleCoupling.overlay (PublicMerkleLog.lookup []) C = C := by + funext j + simp [RawOracleCoupling.overlay,PublicMerkleLog.lookup] + rw [hc] + · exact he + exact he'.trans_le hb + +/-- All counted adaptive mode continuations, with the actual complete uncached +construction path cost, are covered by the finite-table estimate. -/ +theorem actual_mode_collision_bound {R : Type} (iv : Digest32) (p : Program R) + (Q : Nat) (counted : Counts Q p) : + average (fun C : PrimitiveOracle => + if collisionAlarm C (compile iv p Q counted) [] then 1 else 0) ≤ + collisionLedger Q 0 := actual_compression_collision_bound _ + +theorem collisionLedger_zero (Q : Nat) : + collisionLedger Q 0 = (Q.choose 2 : ℚ) / 2^256 := by + rw [Nat.cast_choose_two] + simp [collisionLedger] + +theorem actual_mode_collision_bound_capped {R : Type} (iv : Digest32) (p : Program R) + (Q : Nat) (counted : Counts Q p) : + average (fun C : PrimitiveOracle => + if collisionAlarm C (compile iv p Q counted) [] then 1 else 0) ≤ compressionBirthdayLoss Q := by + apply le_min + · calc + _ ≤ average (fun _ : PrimitiveOracle => (1:ℚ)) := by + apply average_mono + intro C + split <;> norm_num + _ = 1 := average_const _ + · simpa only [collisionLedger_zero] using actual_mode_collision_bound iv p Q counted + +/-- A finite full-view coupling inequality. The actual pinned simulator coupling +is constructed in `PublicCompressionCouplingActualJoint`. -/ +theorem full_view_coupling_bound {Coins V : Type*} [Fintype Coins] [Nonempty Coins] + (real ideal : Coins → V) (bad : Coins → Prop) [DecidablePred bad] + (equal : ∀ coins, ¬bad coins → real coins = ideal coins) (D : V → Bool) : + |distinguishProbability real D - distinguishProbability ideal D| ≤ + average (fun coins => if bad coins then (1:ℚ) else 0) := by + rw [distinguish_average (inferInstance : Fintype Coins), + distinguish_average (inferInstance : Fintype Coins)] + apply abs_le.mpr + constructor + · have h : average (fun coins => if D (ideal coins) then (1:ℚ) else 0) ≤ + average (fun coins => if D (real coins) then (1:ℚ) else 0) + + average (fun coins => if bad coins then (1:ℚ) else 0) := by + rw [← average_add] + apply average_mono + intro coins + by_cases hb : bad coins + · simp only [hb,↓reduceIte] + cases D (real coins) <;> cases D (ideal coins) <;> norm_num + · rw [equal coins hb] + simp [hb] + linarith + · have h : average (fun coins => if D (real coins) then (1:ℚ) else 0) ≤ + average (fun coins => if D (ideal coins) then (1:ℚ) else 0) + + average (fun coins => if bad coins then (1:ℚ) else 0) := by + rw [← average_add] + apply average_mono + intro coins + by_cases hb : bad coins + · simp only [hb,↓reduceIte] + cases D (real coins) <;> cases D (ideal coins) <;> norm_num + · rw [equal coins hb] + simp [hb] + linarith + +#print axioms actual_mode_collision_bound_capped +#print axioms full_view_coupling_bound + +#print axioms table_collisionAlarm_eq_risk +#print axioms actual_mode_collision_bound +end Whir.PublicCompressionCoupling diff --git a/verification/whir/Whir/PublicCompressionCouplingActualCausalBound.lean b/verification/whir/Whir/PublicCompressionCouplingActualCausalBound.lean new file mode 100644 index 000000000..fbbdf7889 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingActualCausalBound.lean @@ -0,0 +1,65 @@ +import Whir.PublicCompressionCouplingActualMismatch +import Whir.PublicCompressionCouplingSourceStream + +/-! Actual duplex whole-view distinguishing bound from the causal event ledger. +The sharp birthday bounds control individual subevents, while `duplexModeLoss` +covers unrestricted adaptive whole Views under one aggregate Counts Q cap. -/ +namespace Whir.PublicCompressionCouplingActualJoint +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler (Sampling) +set_option maxRecDepth 4096 +open PublicCompressionCouplingMixed + +private theorem average_fintype {T : Type} (old new : Fintype T) (f : T → ℚ) : + @average T old f = @average T new f := by + cases Subsingleton.elim old new + rfl + +open Classical in +theorem actual_joint_mismatch_le_causalBad {R : Type} + (Q : Nat) (iv : Digest32) (p : Program R) (counted : Counts Q p) : + letI := mixedKeyFintype Q + Sampling.expectation viewMismatch (actualJoint Q iv p counted) ≤ + average (fun table : Key Q → Digest32 => + if causalBad Q iv p counted table then (1:ℚ) else 0) := by + let := mixedKeyFintype Q + apply actual_joint_mismatch_le_causalBad_of_alignment Q iv p counted + intro trace pair execution table quiet + exact PublicCompressionCouplingSourceStream.actual_joint_good_view Q iv p counted + execution table quiet + +open Classical in +/-- Every existing adversary and whole-View observer is covered, including an +empty adversary-coin type. No operational correspondence hypothesis remains. -/ +theorem actual_modeAdv_le_duplexModeLoss {AdvCoins R : Type} [Fintype AdvCoins] + (Q : Nat) (iv : Digest32) (adversary : AdvCoins → Program R) + (counted : ∀ a, Counts Q (adversary a)) (D : View R → Bool) : + letI := DuplexPublicSimulator.seedFintype + ModeAdv (DuplexPublicSimulator.simulator Q) iv adversary counted D ≤ duplexModeLoss Q := by + let := DuplexPublicSimulator.seedFintype + let := mixedKeyFintype Q + by_cases populated : Nonempty AdvCoins + swap + · let : IsEmpty AdvCoins := not_nonempty_iff.mp populated + have bound := actual_joint_observer_bound Q iv adversary counted D + simp [average] at bound + exact bound.trans (by unfold duplexModeLoss; apply le_min <;> positivity) + let := populated + calc + _ ≤ average (fun a => Sampling.expectation viewMismatch + (actualJoint Q iv (adversary a) (counted a))) := + actual_joint_observer_bound Q iv adversary counted D + _ ≤ average (fun _ : AdvCoins => duplexModeLoss Q) := by + apply average_mono + intro a + have mismatch := actual_joint_mismatch_le_causalBad Q iv (adversary a) (counted a) + have risk := actual_causalBad_probability (R := R) Q iv (adversary a) (counted a) + let canonical : Fintype (Key Q → Digest32) := inferInstance + conv at mismatch => rhs; rw [average_fintype _ canonical] + conv at risk => lhs; rw [average_fintype _ canonical] + exact le_trans mismatch risk + _ = duplexModeLoss Q := average_const _ + +#print axioms actual_joint_mismatch_le_causalBad +#print axioms actual_modeAdv_le_duplexModeLoss +end Whir.PublicCompressionCouplingActualJoint diff --git a/verification/whir/Whir/PublicCompressionCouplingActualJoint.lean b/verification/whir/Whir/PublicCompressionCouplingActualJoint.lean new file mode 100644 index 000000000..0774ba8bd --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingActualJoint.lean @@ -0,0 +1,115 @@ +import Whir.PublicCompressionCouplingJoint +import Whir.PublicCompressionCouplingCausalRisk +import Whir.RawOracleProvenance + +/-! Explicit shared-answer coupling marginals for the actual full-public-View +real and pinned ideal games. No observer, chosen-CV, or adversary restriction is +added. Good-cache alignment is proved in `PublicCompressionCouplingSourceStream`. -/ +namespace Whir.PublicCompressionCouplingActualJoint +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler (Sampling) +open RawOracleCoupling PublicCompressionCouplingJoint + +private theorem average_fintype {T : Type} (old new : Fintype T) (f : T → ℚ) : + @average T old f = @average T new f := by + cases Subsingleton.elim old new + rfl + +private theorem average_product {X Y : Type} [Fintype X] [Fintype Y] (f : X × Y → ℚ) : + average f = average (fun x => average (fun y => f (x,y))) := by + classical + simp only [average,Fintype.sum_prod_type,Finset.sum_div,Fintype.card_prod,Nat.cast_mul,div_div] + rw [mul_comm] + +open Classical in +noncomputable def actualJoint {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) := + joint (PublicCompressionProgram.compile iv p Q counted) (fun _ => none) + (PublicCompressionCouplingMixed.causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none) + +open Classical in + theorem actual_joint_real {AdvCoins R : Type} [Fintype AdvCoins] + (Q : Nat) (iv : Digest32) (adversary : AdvCoins → Program R) + (counted : ∀ a, Counts Q (adversary a)) (D : View R → Bool) : + average (fun a => Sampling.expectation + (fun pair => if D pair.1.1.view then (1:ℚ) else 0) + (actualJoint Q iv (adversary a) (counted a))) = realProbability iv adversary D := by + unfold realProbability + rw [distinguish_average (inferInstance : Fintype (PrimitiveOracle × AdvCoins)), + average_product,average_comm] + apply congrArg average + funext a + rw [actualJoint,joint_first (PublicCompressionProgram.compile iv (adversary a) Q (counted a)) + (fun _ => none) (PublicCompressionCouplingMixed.causalCompile Q iv [] (adversary a) + Q (by rfl) (counted a)) (fun _ => none) + (fun result => if D result.1.view then (1:ℚ) else 0), + ← empty_table_eq_memo (PublicCompressionProgram.compile iv (adversary a) Q (counted a)) + (fun result => if D result.view then (1:ℚ) else 0)] + let canonical : Fintype PrimitiveOracle := inferInstance + conv_lhs => rw [average_fintype _ canonical] + conv_rhs => rw [average_fintype _ canonical] + apply congrArg (@average PrimitiveOracle canonical) + funext C + simp only [PublicCompressionProgram.compile_eval] + +open Classical in + theorem actual_joint_ideal {AdvCoins R : Type} [Fintype AdvCoins] + (Q : Nat) (iv : Digest32) (adversary : AdvCoins → Program R) + (counted : ∀ a, Counts Q (adversary a)) (D : View R → Bool) : + letI := DuplexPublicSimulator.seedFintype + average (fun a => Sampling.expectation + (fun pair => if D pair.2.1.1 then (1:ℚ) else 0) + (actualJoint Q iv (adversary a) (counted a))) = + idealProbability (DuplexPublicSimulator.simulator Q) iv adversary counted D := by + let := DuplexPublicSimulator.seedFintype + let := rawOracleFintype Q + let := PublicCompressionCouplingMixed.mixedKeyFintype Q + have marginal (a : AdvCoins) : + Sampling.expectation (fun pair => if D pair.2.1.1 then (1:ℚ) else 0) + (actualJoint Q iv (adversary a) (counted a)) = + average (fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + if D (Sampling.eval table (PublicCompressionCouplingMixed.causalCompile Q iv [] + (adversary a) Q (by rfl) (counted a))).1 then (1:ℚ) else 0) := by + rw [actualJoint,joint_second (PublicCompressionProgram.compile iv (adversary a) Q (counted a)) + (fun _ => none) (PublicCompressionCouplingMixed.causalCompile Q iv [] (adversary a) + Q (by rfl) (counted a)) (fun _ => none) + (fun result => if D result.1.1 then (1:ℚ) else 0), + ← empty_table_eq_memo (PublicCompressionCouplingMixed.causalCompile Q iv [] + (adversary a) Q (by rfl) (counted a)) (fun result => if D result.1 then (1:ℚ) else 0)] + simp_rw [marginal] + rw [average_comm] + rw [← average_product + (fun coins : (PublicCompressionCouplingMixed.Key Q → Digest32) × AdvCoins => + if D (Sampling.eval coins.1 (PublicCompressionCouplingMixed.causalCompile Q iv [] + (adversary coins.2) Q (by rfl) (counted coins.2))).1 then (1:ℚ) else 0)] + let e : (PublicCompressionCouplingMixed.Key Q → Digest32) × AdvCoins ≃ + (RawKey Q → Digest32) × DuplexPublicSimulator.Seed × AdvCoins := + (Equiv.prodCongr ((PublicCompressionCouplingMixed.tableEquiv Q).trans + (Equiv.prodComm DuplexPublicSimulator.Seed (RawKey Q → Digest32))) (Equiv.refl AdvCoins)).trans + (Equiv.prodAssoc (RawKey Q → Digest32) DuplexPublicSimulator.Seed AdvCoins) + have eq := average_equiv e + (fun coins : (RawKey Q → Digest32) × DuplexPublicSimulator.Seed × AdvCoins => + if D (runIdeal (DuplexPublicSimulator.simulator Q) coins.1 iv + ((DuplexPublicSimulator.simulator Q).initial coins.2.1) (adversary coins.2.2) + Q (by rfl) (counted coins.2.2)).view then (1:ℚ) else 0) + unfold idealProbability + rw [distinguish_average (inferInstance : Fintype + ((RawKey Q → Digest32) × DuplexPublicSimulator.Seed × AdvCoins))] + apply Eq.trans _ eq + apply congrArg (fun f : ((PublicCompressionCouplingMixed.Key Q → Digest32) × AdvCoins) → ℚ => average f) + funext coins + rcases coins with ⟨table,a⟩ + have image : e (table,a) = ((fun key => table (.inr key)),(fun n => table (.inl n)),a) := rfl + rw [image] + have oracleEq : PublicCompressionCouplingMixed.oracle + (fun n => table (.inl n)) (fun key => table (.inr key)) = table := by + funext key + cases key <;> rfl + have viewEq := PublicCompressionCouplingMixed.causalCompile_public Q iv (adversary a) + (counted a) (fun n => table (.inl n)) (fun key => table (.inr key)) + rw [oracleEq] at viewEq + exact congrArg (fun view => if D view then (1:ℚ) else 0) viewEq + +#print axioms actual_joint_real +#print axioms actual_joint_ideal +end Whir.PublicCompressionCouplingActualJoint diff --git a/verification/whir/Whir/PublicCompressionCouplingActualJointBound.lean b/verification/whir/Whir/PublicCompressionCouplingActualJointBound.lean new file mode 100644 index 000000000..f48cd0e62 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingActualJointBound.lean @@ -0,0 +1,93 @@ +import Whir.PublicCompressionCouplingActualJoint + +/-! The whole-public-View fundamental inequality for the literal shared-answer +coupling. Its right side is the actual coupling's View mismatch, not a supplied +certificate or a primitive soundness assumption. -/ +namespace Whir.PublicCompressionCouplingActualJoint +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler (Sampling) + +private theorem expectation_mono {K R : Type} {n : Nat} + (p : Sampling K (fun _ => Digest32) R n) {f g : R → ℚ} (h : ∀ r, f r ≤ g r) : + Sampling.expectation f p ≤ Sampling.expectation g p := by + induction p with + | ret result => exact h result + | draw key next ih => exact average_mono (fun answer => ih answer) + +private theorem expectation_add {K R : Type} {n : Nat} + (p : Sampling K (fun _ => Digest32) R n) (f g : R → ℚ) : + Sampling.expectation (fun r => f r+g r) p = + Sampling.expectation f p+Sampling.expectation g p := by + induction p with + | ret result => rfl + | draw key next ih => + simp only [Sampling.expectation,ih,average_add] + +abbrev JointResult (Q : Nat) (R : Type) := + (Execution R × PublicCompressionCouplingJoint.Cache Node) × + ((View R × List PublicCompressionCouplingMixed.InspectedConstruction) × + PublicCompressionCouplingJoint.Cache (PublicCompressionCouplingMixed.Key Q)) + +open Classical in +noncomputable def viewMismatch {Q : Nat} {R : Type} (result : JointResult Q R) : ℚ := + if result.1.1.view = result.2.1.1 then 0 else 1 + +open Classical in + theorem actual_joint_observer_bound {AdvCoins R : Type} [Fintype AdvCoins] + (Q : Nat) (iv : Digest32) (adversary : AdvCoins → Program R) + (counted : ∀ a, Counts Q (adversary a)) (D : View R → Bool) : + letI := DuplexPublicSimulator.seedFintype + ModeAdv (DuplexPublicSimulator.simulator Q) iv adversary counted D ≤ + average (fun a => Sampling.expectation viewMismatch + (actualJoint Q iv (adversary a) (counted a))) := by + let := DuplexPublicSimulator.seedFintype + unfold ModeAdv + rw [← actual_joint_real Q iv adversary counted D,← actual_joint_ideal Q iv adversary counted D] + by_cases populated : Nonempty AdvCoins + swap + · let : IsEmpty AdvCoins := not_nonempty_iff.mp populated + simp [average] + let := populated + apply abs_le.mpr + constructor + · have bound : average (fun a => Sampling.expectation + (fun pair => if D pair.2.1.1 then (1:ℚ) else 0) + (actualJoint Q iv (adversary a) (counted a))) ≤ + average (fun a => Sampling.expectation + (fun pair => if D pair.1.1.view then (1:ℚ) else 0) + (actualJoint Q iv (adversary a) (counted a))) + + average (fun a => Sampling.expectation viewMismatch + (actualJoint Q iv (adversary a) (counted a))) := by + rw [← average_add] + apply average_mono + intro a + rw [← expectation_add] + apply expectation_mono + intro pair + by_cases equal : pair.1.1.view = pair.2.1.1 + · simp only [viewMismatch,equal,↓reduceIte,add_zero,le_refl] + · simp only [viewMismatch,equal,↓reduceIte] + cases D pair.1.1.view <;> cases D pair.2.1.1 <;> norm_num + linarith + · have bound : average (fun a => Sampling.expectation + (fun pair => if D pair.1.1.view then (1:ℚ) else 0) + (actualJoint Q iv (adversary a) (counted a))) ≤ + average (fun a => Sampling.expectation + (fun pair => if D pair.2.1.1 then (1:ℚ) else 0) + (actualJoint Q iv (adversary a) (counted a))) + + average (fun a => Sampling.expectation viewMismatch + (actualJoint Q iv (adversary a) (counted a))) := by + rw [← average_add] + apply average_mono + intro a + rw [← expectation_add] + apply expectation_mono + intro pair + by_cases equal : pair.1.1.view = pair.2.1.1 + · simp only [viewMismatch,equal,↓reduceIte,add_zero,le_refl] + · simp only [viewMismatch,equal,↓reduceIte] + cases D pair.1.1.view <;> cases D pair.2.1.1 <;> norm_num + linarith + +#print axioms actual_joint_observer_bound +end Whir.PublicCompressionCouplingActualJoint diff --git a/verification/whir/Whir/PublicCompressionCouplingActualMismatch.lean b/verification/whir/Whir/PublicCompressionCouplingActualMismatch.lean new file mode 100644 index 000000000..dc4e2cbe9 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingActualMismatch.lean @@ -0,0 +1,58 @@ +import Whir.PublicCompressionCouplingActualJointBound +import Whir.PublicCompressionCouplingJointResidual + +/-! Residual-cache accounting for the actual joint full-View mismatch. The +operational good-event implication is separated from the exact finite marginal +identity; the final distinguishing endpoint instantiates that implication. -/ +namespace Whir.PublicCompressionCouplingActualJoint +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler (Sampling) +open RawOracleCoupling PublicCompressionCouplingJoint PublicCompressionCouplingMixed + +open Classical in +theorem actual_joint_residual_causalBad {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) : + letI := mixedKeyFintype Q + Sampling.expectation (fun pair => average (fun table : Key Q → Digest32 => + if causalBad Q iv p counted (overlay pair.2.2 table) then (1:ℚ) else 0)) + (actualJoint Q iv p counted) = + average (fun table : Key Q → Digest32 => + if causalBad Q iv p counted table then (1:ℚ) else 0) := by + let := mixedKeyFintype Q + rw [actualJoint, joint_second_residual + (PublicCompressionProgram.compile iv p Q counted) (fun _ => none) + (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none) + (fun _ table => if causalBad Q iv p counted table then (1:ℚ) else 0)] + rfl + +open Classical in +/-- The operational premise is discharged by actual source alignment in the +closed endpoint, not supplied by an adversary or observer. -/ +theorem actual_joint_mismatch_le_causalBad_of_alignment {R : Type} + (Q : Nat) (iv : Digest32) (p : Program R) (counted : Counts Q p) + (alignment : ∀ trace pair, Sampling.Runs (actualJoint Q iv p counted) trace pair → + ∀ table : Key Q → Digest32, + causalBad Q iv p counted (overlay pair.2.2 table) = false → + pair.1.1.view = pair.2.1.1) : + letI := mixedKeyFintype Q + Sampling.expectation viewMismatch (actualJoint Q iv p counted) ≤ + average (fun table : Key Q → Digest32 => + if causalBad Q iv p counted table then (1:ℚ) else 0) := by + let := mixedKeyFintype Q + rw [← actual_joint_residual_causalBad Q iv p counted] + apply expectation_mono_runs + intro trace pair execution + calc + viewMismatch pair = average (fun _ : Key Q → Digest32 => viewMismatch pair) := + (average_const _).symm + _ ≤ average (fun table : Key Q → Digest32 => + if causalBad Q iv p counted (overlay pair.2.2 table) then (1:ℚ) else 0) := by + apply average_mono + intro table + cases bad : causalBad Q iv p counted (overlay pair.2.2 table) with + | false => simp [viewMismatch, alignment trace pair execution table bad] + | true => simp only [↓reduceIte, viewMismatch]; split <;> norm_num + +#print axioms actual_joint_residual_causalBad +#print axioms actual_joint_mismatch_le_causalBad_of_alignment +end Whir.PublicCompressionCouplingActualJoint diff --git a/verification/whir/Whir/PublicCompressionCouplingBirthday.lean b/verification/whir/Whir/PublicCompressionCouplingBirthday.lean new file mode 100644 index 000000000..d2dd8a013 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingBirthday.lean @@ -0,0 +1,122 @@ +import Whir.PublicCompressionCouplingTargets + +/-! Birthday probabilities for all distinct coordinates of the actual mixed +seed/RO table, including adaptively selected private prefix coordinates. -/ +namespace Whir.PublicCompressionCouplingBirthday +open FiatShamirGame TypedOracleCompiler TypedFiatShamirGame RawOracleCoupling +open PublicCompressionCoupling (collisionLedger) +variable {K R : Type} [DecidableEq K] +abbrev Computation (K R : Type) (n : Nat) := Sampling K (fun _ => Digest32) R n + +noncomputable def alarm (table : K → Digest32) {n : Nat} : + Computation K R n → (K → Option Digest32) → Finset Digest32 → Bool + | .ret _, _, _ => false + | .draw key next, cache, seen => match cache key with + | some answer => alarm table (next answer) cache seen + | none => decide (table key ∈ seen) || + alarm table (next (table key)) (put cache key (table key)) (insert (table key) seen) + +noncomputable def risk {n : Nat} : + Computation K R n → (K → Option Digest32) → Finset Digest32 → ℚ + | .ret _, _, _ => 0 + | .draw key next, cache, seen => match cache key with + | some answer => risk (next answer) cache seen + | none => average (fun answer : Digest32 => if answer ∈ seen then 1 else + risk (next answer) (put cache key answer) (insert answer seen)) + +private theorem ledger_nonneg (n k : Nat) : 0 ≤ collisionLedger n k := by + cases n with + | zero => simp [collisionLedger] + | succ n => + unfold collisionLedger + simp only [Nat.cast_add,Nat.cast_one,add_sub_cancel_right] + positivity + +private theorem ledger_step (n k : Nat) : + collisionLedger (n+1) k = (k:ℚ)/2^256 + collisionLedger n (k+1) := by + unfold collisionLedger + push_cast + ring + +private theorem ledger_mono_previous (n : Nat) {j k : Nat} (h : j ≤ k) : + collisionLedger n j ≤ collisionLedger n k := by + unfold collisionLedger + apply div_le_div_of_nonneg_right _ (by positivity) + apply add_le_add_left + exact mul_le_mul_of_nonneg_left (by exact_mod_cast h) (by positivity) + +theorem risk_bound {n : Nat} (p : Computation K R n) (cache : K → Option Digest32) + (seen : Finset Digest32) : risk p cache seen ≤ collisionLedger n seen.card := by + classical + induction p generalizing cache seen with + | ret r => exact ledger_nonneg _ _ + | @draw n key next ih => + have hs := ledger_step n seen.card + cases hit : cache key with + | some answer => + simp only [risk,hit] + have ht := le_trans (ih answer cache seen) (ledger_mono_previous n (Nat.le_succ seen.card)) + rw [hs] + have hn : (0:ℚ) ≤ (seen.card:ℚ)/2^256 := by positivity + linarith + | none => + simp only [risk,hit] + calc + _ ≤ average (fun answer : Digest32 => + (if answer ∈ seen then (1:ℚ) else 0) + collisionLedger n (seen.card+1)) := by + apply average_mono + intro answer + have ht := le_trans (ih answer (put cache key answer) (insert answer seen)) + (ledger_mono_previous n (Finset.card_insert_le _ _)) + have hn := ledger_nonneg n (seen.card+1) + by_cases bad : answer ∈ seen + · simp only [bad,↓reduceIte]; linarith + · simpa only [bad,↓reduceIte,zero_add] using ht + _ = (seen.card:ℚ)/2^256 + collisionLedger n (seen.card+1) := by + rw [average_add,PublicMerkleProbability.uniform_target_probability,average_const] + _ = _ := hs.symm + +variable [Fintype K] + +theorem table_alarm_eq_risk {n : Nat} (p : Computation K R n) + (cache : K → Option Digest32) (seen : Finset Digest32) : + average (fun table : K → Digest32 => + if alarm (overlay cache table) p cache seen then (1:ℚ) else 0) = risk p cache seen := by + classical + induction p generalizing cache seen with + | ret r => simp [alarm,risk,average_const] + | draw key next ih => + cases hit : cache key with + | some answer => simp only [alarm,risk,hit]; exact ih answer cache seen + | none => + rw [overlay_average cache key hit + (fun table => if alarm table (.draw key next) cache seen then (1:ℚ) else 0)] + simp only [risk,hit] + apply congrArg average + funext answer + by_cases bad : answer ∈ seen + · simp [alarm,hit,overlay,bad,average_const] + · rw [← ih answer (put cache key answer) (insert answer seen)] + simp only [bad,↓reduceIte] + apply congrArg average + funext table + simp [alarm,hit,overlay,bad] + +set_option backward.isDefEq.respectTransparency false in + theorem actual_mixed_birthday_bound {n : Nat} (p : Computation K R n) : + average (fun table : K → Digest32 => + if alarm table p (fun _ => none) ∅ then (1:ℚ) else 0) ≤ + min 1 ((n.choose 2:ℚ)/2^256) := by + apply le_min + · calc + _ ≤ average (fun _ : K → Digest32 => (1:ℚ)) := by + apply average_mono + intro table + split <;> norm_num + _ = 1 := average_const _ + · have h := risk_bound p (fun _ => none) ∅ + rw [← table_alarm_eq_risk] at h + simpa only [overlay_empty,Finset.card_empty,PublicCompressionCoupling.collisionLedger_zero] using h + +#print axioms actual_mixed_birthday_bound +end Whir.PublicCompressionCouplingBirthday diff --git a/verification/whir/Whir/PublicCompressionCouplingBirthdayCache.lean b/verification/whir/Whir/PublicCompressionCouplingBirthdayCache.lean new file mode 100644 index 000000000..44b67b93f --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingBirthdayCache.lean @@ -0,0 +1,88 @@ +import Whir.PublicCompressionCouplingBirthday + +/-! Actual memo-cache answer injectivity on the complement of the already +proved mixed-table birthday alarm. Coverage and injectivity are operational +cache invariants, discharged from the literal empty cache at the endpoint. -/ +namespace Whir.PublicCompressionCouplingBirthdayCache +open FiatShamirGame TypedOracleCompiler TypedFiatShamirGame RawOracleCoupling + +variable {K R : Type} [DecidableEq K] +abbrev Computation (K R : Type) (n : Nat) := Sampling K (fun _ => Digest32) R n + +def AnswerInjective (cache : K → Option Digest32) : Prop := + ∀ a b d, cache a=some d → cache b=some d → a=b + +def Covered (cache : K → Option Digest32) (seen : Finset Digest32) : Prop := + ∀ key answer, cache key=some answer → answer ∈ seen + + theorem put_covered (cache : K → Option Digest32) (seen : Finset Digest32) + (covered : Covered cache seen) (input : K) (value : Digest32) : + Covered (put cache input value) (insert value seen) := by + intro key answer stored + by_cases same : key=input + · subst key + simp only [put_self,Option.some.injEq] at stored + subst answer + exact Finset.mem_insert_self _ _ + · exact Finset.mem_insert_of_mem (covered key answer + (by simpa only [put_other _ _ _ _ same] using stored)) + + theorem put_injective (cache : K → Option Digest32) (seen : Finset Digest32) + (covered : Covered cache seen) (injective : AnswerInjective cache) + (input : K) (value : Digest32) (fresh : value ∉ seen) : + AnswerInjective (put cache input value) := by + intro a b d left right + by_cases sameA : a=input + · subst a + have actual : value=d := by simpa only [put_self,Option.some.injEq] using left + by_cases sameB : b=input + · exact sameB.symm + · have old : cache b=some d := by simpa only [put_other _ _ _ _ sameB] using right + exact False.elim (fresh (actual.symm ▸ covered b d old)) + · by_cases sameB : b=input + · subst b + have actual : value=d := by simpa only [put_self,Option.some.injEq] using right + have old : cache a=some d := by simpa only [put_other _ _ _ _ sameA] using left + exact False.elim (fresh (actual.symm ▸ covered a d old)) + · exact injective a b d + (by simpa only [put_other _ _ _ _ sameA] using left) + (by simpa only [put_other _ _ _ _ sameB] using right) + +/-- No cryptographic initial-injectivity premise is used at the empty-cache +specialization below. Both invariants are transported by actual memo steps. -/ +theorem alarm_false_cache_injective (table : K → Digest32) {n : Nat} + (p : Computation K R n) (cache : K → Option Digest32) (seen : Finset Digest32) + (covered : Covered cache seen) (injective : AnswerInjective cache) + (quiet : PublicCompressionCouplingBirthday.alarm table p cache seen=false) : + AnswerInjective (Sampling.eval table (memo p cache)).2 := by + induction p generalizing cache seen with + | ret r => exact injective + | draw input next ih => + cases hit : cache input with + | some value => + simp only [memo,hit,Sampling.eval_pad] + simp only [PublicCompressionCouplingBirthday.alarm,hit] at quiet + exact ih value cache seen covered injective quiet + | none => + simp only [memo,hit,Sampling.eval] + simp only [PublicCompressionCouplingBirthday.alarm,hit] at quiet + have parts := Bool.or_eq_false_iff.mp quiet + have fresh := of_decide_eq_false parts.1 + exact ih (table input) (put cache input (table input)) (insert (table input) seen) + (put_covered cache seen covered input (table input)) + (put_injective cache seen covered injective input (table input) fresh) parts.2 + + theorem birthday_cache_injective (table : K → Digest32) {n : Nat} + (p : Computation K R n) + (quiet : PublicCompressionCouplingBirthday.alarm table p (fun _ => none) ∅=false) : + ∀ a b d, (Sampling.eval table (memo p (fun _ => none))).2 a=some d → + (Sampling.eval table (memo p (fun _ => none))).2 b=some d → a=b := by + apply alarm_false_cache_injective table p (fun _ => none) ∅ _ _ quiet + · intro key answer impossible + cases impossible + · intro a b d impossible + cases impossible + +#print axioms alarm_false_cache_injective +#print axioms birthday_cache_injective +end Whir.PublicCompressionCouplingBirthdayCache diff --git a/verification/whir/Whir/PublicCompressionCouplingCache.lean b/verification/whir/Whir/PublicCompressionCouplingCache.lean new file mode 100644 index 000000000..1401bed39 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingCache.lean @@ -0,0 +1,89 @@ +import Whir.PublicCompressionCouplingKeys + +/-! The cached-missed-recognition case is a public-log invariant, not an +exception to the observer API. A previously incomplete terminal cannot acquire +a body when a newly published answer avoids the earlier chaining positions. +Chosen known CVs remain allowed; only actual late answer matches are bad. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator + +/-- Erasing one fresh answer record preserves every body whose chaining +positions avoid that answer. No restriction is placed on the new input CV. -/ + theorem PublicBody.erase_record {log : PublicLog} {input : Node} {answer cv : Digest32} + {ns : List Node} (tree : PublicBody (observe log input answer) cv ns) + (avoidInputs : ∀ n d, (n,d) ∈ log → answer ≠ n.cv) + (avoidRoot : answer ≠ cv) : PublicBody log cv ns := by + induction tree with + | seed member seed => + rcases List.mem_cons.mp member with equal | old + · have conflict := congrArg Prod.snd equal + exact False.elim (avoidRoot conflict.symm) + · exact PublicBody.seed old seed + | @step n d rest member internal child ih => + rcases List.mem_cons.mp member with equal | old + · have conflict := congrArg Prod.snd equal + exact False.elim (avoidRoot conflict.symm) + · exact PublicBody.step old internal (ih (avoidInputs n d old)) + +/-- A repeated record cannot create a body either. In particular, a repeated +cached terminal never requires fresh Seed or RO randomness. -/ + theorem PublicBody.erase_repeat {log : PublicLog} {input : Node} {answer cv : Digest32} + {ns : List Node} (old : (input,answer) ∈ log) + (tree : PublicBody (observe log input answer) cv ns) : PublicBody log cv ns := by + induction tree with + | seed member seed => + apply PublicBody.seed _ seed + rcases List.mem_cons.mp member with equal | prior + · simpa only [equal] using old + · exact prior + | step member internal child ih => + apply PublicBody.step _ internal ih + rcases List.mem_cons.mp member with equal | prior + · simpa only [equal] using old + · exact prior + +/-- When the newly recorded input is terminal it cannot be a body node, even +if its output coincides with a previous chosen chaining value. -/ + theorem PublicBody.erase_terminal {log : PublicLog} {input : Node} {answer cv : Digest32} + {ns : List Node} (terminal : isTerminal input) + (tree : PublicBody (observe log input answer) cv ns) : PublicBody log cv ns := by + induction tree with + | seed member seed => + rcases List.mem_cons.mp member with equal | prior + · have nodes := congrArg Prod.fst equal + dsimp only at nodes + exact False.elim (terminal_not_seed terminal (nodes ▸ seed)) + · exact PublicBody.seed prior seed + | step member internal child ih => + rcases List.mem_cons.mp member with equal | prior + · have nodes := congrArg Prod.fst equal + dsimp only at nodes + exact False.elim (terminal_not_internal terminal (nodes ▸ internal)) + · exact PublicBody.step prior internal ih + +/-- Precisely the cached missed-recognition case: if the terminal was +unrecognized before a non-late publication, it is still unrecognized after it. +The assumptions are structural facts about the previous actual log and the +single actual answer, not cryptographic or observer-exclusion premises. -/ + theorem recognized_none_after_nonlate {log : PublicLog} {input target : Node} + {answer : Digest32} (functional : Functional log) (clean : ¬OutputCollision log) + (incomplete : recognized log target = none) + (avoidInputs : ∀ n d, (n,d) ∈ log → answer ≠ n.cv) + (avoidTarget : answer ≠ target.cv) : + recognized (observe log input answer) target = none := by + cases found : recognized (observe log input answer) target with + | none => rfl + | some ns => + obtain ⟨rest,rfl,body⟩ := recognized_publicBody found + have old := PublicBody.erase_record body avoidInputs avoidTarget + have terminal := (recognized_sound found).1 + obtain ⟨t,tail,equal,ht,hb⟩ := terminal + have head : t = target := by simpa using (congrArg List.head? equal).symm + subst t + have prior := recognized_complete functional clean ht old + rw [incomplete] at prior + cases prior + +#print axioms PublicBody.erase_record +#print axioms recognized_none_after_nonlate +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingCausal.lean b/verification/whir/Whir/PublicCompressionCouplingCausal.lean new file mode 100644 index 000000000..54ba480cf --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingCausal.lean @@ -0,0 +1,166 @@ +import Whir.PublicCompressionCouplingInspection + +/-! Source-cost-bounded causal inspection of the pinned ideal simulator. Hidden +prefix calls precede their construction's RO call, but neither their answers nor +records enter the public log. This is the actual whole-view simulator, not a new +simulator or an assumed cache correspondence. -/ +namespace Whir.PublicCompressionCouplingMixed +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +/-- The actual ideal construction, with private seed prefixes sampled before +its terminal RO coordinate. Counts charges the prefix and terminal together. -/ +def causalConstruction (Q : Nat) (iv : Digest32) (coordinate : Coordinate) + (valid : DuplexEncoding.Admissible coordinate) (budget : pathCost coordinate ≤ Q) : + Computation Q InspectedConstruction (pathCost coordinate) := + Sampling.pad (n := (DuplexEncoding.plan coordinate).dropLast.length+1) (by + have positive := DuplexRawProgram.pathCost_pos coordinate + simp only [List.length_dropLast] + unfold pathCost at positive ⊢ + omega) + (Sampling.bind (bodyCalls Q iv (DuplexEncoding.plan coordinate).dropLast) + (fun body => .draw (.inr (constructionKey Q iv coordinate budget)) (fun answer => + .ret ⟨coordinate,valid,answer,body.1,body.2⟩))) + + theorem causalConstruction_eval (Q : Nat) (iv : Digest32) (coordinate : Coordinate) + (valid : DuplexEncoding.Admissible coordinate) (budget : pathCost coordinate ≤ Q) + (table : Key Q → Digest32) : + Sampling.eval table (causalConstruction Q iv coordinate valid budget) = + let body := Sampling.eval table (bodyCalls Q iv (DuplexEncoding.plan coordinate).dropLast) + ⟨coordinate,valid,table (.inr (constructionKey Q iv coordinate budget)),body.1,body.2⟩ := by + simp only [causalConstruction,Sampling.eval_pad,Sampling.eval_bind,Sampling.eval] + +/-- Every construction's hidden calls occur at its causal position. The sole +state passed between public calls remains the pinned public primitive log. -/ +def causalCompile (Q : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) : + (p : Program R) → (remaining : Nat) → remaining ≤ Q → Counts remaining p → + Computation Q (View R × List InspectedConstruction) remaining + | .done result, _, _, _ => .ret (⟨[],result⟩,[]) + | .ask (.primitive purpose input) next, remaining, cap, counted => + Sampling.pad (n := 1+(remaining-1)) (m := remaining) + (by have hc : 1 ≤ remaining := counted.1; omega) + (Sampling.bind (primitiveCalls Q log input) (fun result => + Computation.map (fun rest => + (DuplexRawProgram.observe (.primitive purpose input) result.2 rest.1,rest.2)) + (causalCompile Q iv result.1 (next result.2) (remaining-1) + (by omega) (counted.2 _)))) + | .ask (.construction coordinate valid) next, remaining, cap, counted => + Sampling.pad (n := pathCost coordinate+(remaining-pathCost coordinate)) (m := remaining) + (by have hc : pathCost coordinate ≤ remaining := counted.1; omega) + (Sampling.bind (causalConstruction Q iv coordinate valid (counted.1.trans cap)) + (fun construction => Computation.map (fun rest => + (DuplexRawProgram.observe (.construction coordinate valid) construction.advertised rest.1, + construction::rest.2)) + (causalCompile Q iv log (next construction.advertised) + (remaining-pathCost coordinate) (by omega) (counted.2 _)))) + +set_option backward.isDefEq.respectTransparency false in +/-- Exact causal/posthoc correspondence under the SAME memoized seed/RO table. +This is pointwise, including repeated queries and every adaptive continuation. -/ + theorem causalCompile_eval (Q : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (p : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) + (table : Key Q → Digest32) : + Sampling.eval table (causalCompile Q iv log p remaining cap counted) = + let view := Sampling.eval table (compile Q iv log p remaining cap counted) + (view,Sampling.eval table (inspect Q iv view.observations)) := by + induction p generalizing log remaining with + | done result => rfl + | ask query next ih => + cases query with + | primitive purpose input => + have viewEq : + Sampling.eval table (compile Q iv log (.ask (.primitive purpose input) next) + remaining cap counted) = + DuplexRawProgram.observe (.primitive purpose input) + (Sampling.eval table (primitiveCalls Q log input)).2 + (Sampling.eval table (compile Q iv + (Sampling.eval table (primitiveCalls Q log input)).1 + (next (Sampling.eval table (primitiveCalls Q log input)).2) + (remaining-1) (by omega) (counted.2 _))) := by + simp only [compile,Sampling.eval_pad,Sampling.eval_bind,Computation.eval_map] + rw [viewEq] + dsimp only + simp only [causalCompile,Sampling.eval_pad,Sampling.eval_bind,Computation.eval_map] + rw [ih] + simp only [DuplexRawProgram.observe,inspect] + | construction coordinate valid => + have viewEq : + Sampling.eval table (compile Q iv log (.ask (.construction coordinate valid) next) + remaining cap counted) = + DuplexRawProgram.observe (.construction coordinate valid) + (table (.inr (constructionKey Q iv coordinate (counted.1.trans cap)))) + (Sampling.eval table (compile Q iv log + (next (table (.inr (constructionKey Q iv coordinate (counted.1.trans cap))))) + (remaining-pathCost coordinate) (by omega) (counted.2 _))) := by + simp only [compile,Sampling.eval_pad,Sampling.eval,Computation.eval_map] + rw [viewEq] + dsimp only + simp only [causalCompile,Sampling.eval_pad,Sampling.eval_bind, + Computation.eval_map,causalConstruction_eval] + rw [ih] + simp only [DuplexRawProgram.observe,inspect,Sampling.eval_bind,Computation.eval_map] + + theorem causalCompile_public (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (seed : DuplexPublicSimulator.Seed) (ro : RawKey Q → Digest32) : + (Sampling.eval (oracle seed ro) (causalCompile Q iv [] p Q (by rfl) counted)).1 = + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv + ((DuplexPublicSimulator.simulator Q).initial seed) p Q (by rfl) counted).view := by + rw [causalCompile_eval] + exact compile_actual Q seed ro iv [] p Q (by rfl) counted + +/- Executable finite-table smoke of the actual construction, with two finite +table parameters. This checks interpreter behavior, not uniform 256-bit +probabilities or concrete BLAKE2s security. -/ +#eval do + let digest (n : Nat) : Digest32 := fun _ => ⟨n % 256,Nat.mod_lt _ (by decide)⟩ + let coordinate : Coordinate := ⟨⟨digest 3,digest 4,[]⟩,.output 0⟩ + have valid : DuplexEncoding.Admissible coordinate := by + simp [coordinate,DuplexEncoding.Admissible,DuplexEncoding.TerminalValid] + let seedNode : Node := ⟨digest 0, + ByteCodec.pairBytes (coordinate.history.domain,coordinate.history.statement), + UInt64.ofNat (2^56),true⟩ + let program : Program Digest32 := + .ask (.construction coordinate valid) (fun _ => + .ask (.construction coordinate valid) Program.done) + have counted : Counts 8 program := by + simp [program,Counts,Query.cost,pathCost,DuplexEncoding.plan,coordinate] + for x in List.range 4 do + for z in List.range 4 do + let seed : DuplexPublicSimulator.Seed := fun n => + if isSeed n then digest (x+1) else digest 7 + let ro : RawKey 8 → Digest32 := fun _ => digest (z+20) + let table := oracle seed ro + let causal := Sampling.eval table (causalCompile 8 (digest 0) [] program 8 (by omega) counted) + let actual := runIdeal (DuplexPublicSimulator.simulator 8) ro (digest 0) + ((DuplexPublicSimulator.simulator 8).initial seed) program 8 (by omega) counted + unless decide (causal.1.observations.map Observation.answer = + actual.view.observations.map Observation.answer) && + decide (causal.1.observations.map Observation.answer = [digest (z+20),digest (z+20)]) && + decide (causal.2.map InspectedConstruction.prefixEnd = [digest (x+1),digest (x+1)]) do + throw (IO.userError "causal repeated raw construction: FAILED") + let terminal := terminalNode (digest (x+1)) coordinate.terminal + let initial := (DuplexPublicSimulator.simulator 8).initial seed + let missed := runRO ro ((DuplexPublicSimulator.simulator 8).answer initial terminal) + let late := runRO ro ((DuplexPublicSimulator.simulator 8).answer missed.1.1 seedNode) + let cached := runRO ro ((DuplexPublicSimulator.simulator 8).answer late.1.1 terminal) + unless missed.2 == 0 && cached.2 == 0 && + decide (cached.1.2 = digest 7) && + (DuplexPublicSimulator.recognized late.1.1.publicLog terminal).isSome && + (DuplexPublicSimulator.privateKey 8 late.1.1.publicLog terminal).isNone && + decide (late.1.2 = terminal.cv) do + throw (IO.userError "cached missed recognition and actual late match: FAILED") + let chosen := { seedNode with cv := digest 42 } + let known := runRO ro ((DuplexPublicSimulator.simulator 8).answer initial chosen) + let forward := runRO ro ((DuplexPublicSimulator.simulator 8).answer known.1.1 terminal) + let repeated := runRO ro ((DuplexPublicSimulator.simulator 8).answer forward.1.1 terminal) + unless forward.2 == 1 && repeated.2 == 0 && + decide (forward.1.2 = digest (z+20)) && + decide (repeated.1.2 = forward.1.2) && + decide ((DuplexPublicSimulator.privateKey 8 known.1.1.publicLog terminal).map + (fun key => (expandKey key).message) = + some [(none,terminal.block),(some (digest 42),chosen.block)]) do + throw (IO.userError "legitimate chosen-known-CV forward probe: FAILED") + IO.println "causal finite-table smoke: 16 actual seed/RO cases passed" + +#print axioms causalCompile_eval +#print axioms causalCompile_public +end Whir.PublicCompressionCouplingMixed diff --git a/verification/whir/Whir/PublicCompressionCouplingCausalRisk.lean b/verification/whir/Whir/PublicCompressionCouplingCausalRisk.lean new file mode 100644 index 000000000..3b8b51475 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingCausalRisk.lean @@ -0,0 +1,78 @@ +import Whir.PublicCompressionCouplingCausal +import Whir.PublicCompressionCouplingBirthday +import Whir.PublicCompressionCouplingHidden +import Whir.PublicCompressionCouplingIdealLateLinks + +/-! The exact Q-dependent causal event ledger used by cache alignment. The +event-to-full-View implication is proved in `PublicCompressionCouplingSourceStream` +and its distinguishing consequence in `PublicCompressionCouplingActualCausalBound`. -/ +namespace Whir.PublicCompressionCouplingMixed +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +open Classical in +noncomputable def causalBad {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (table : Key Q → Digest32) : Bool := + PublicCompressionCouplingBirthday.alarm table (causalCompile Q iv [] p Q (by rfl) counted) + (fun _ => none) ∅ || + PublicCompressionCouplingIdealLateLinks.alarm PublicCompressionCouplingIdealLateLinks.mixedCV + table (compile Q iv [] p Q (by rfl) counted) (fun _ => none) [] || + hiddenGuess Q iv p counted table + +open Classical in + theorem actual_causalBad_probability {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) : + letI := mixedKeyFintype Q + average (fun table : Key Q → Digest32 => + if causalBad Q iv p counted table then (1:ℚ) else 0) ≤ duplexModeLoss Q := by + let := mixedKeyFintype Q + unfold duplexModeLoss + apply le_min + · calc + _ ≤ average (fun _ : Key Q → Digest32 => (1:ℚ)) := by + apply average_mono + intro table + split <;> norm_num + _ = 1 := average_const _ + · have birthday := PublicCompressionCouplingBirthday.actual_mixed_birthday_bound + (causalCompile Q iv [] p Q (by rfl) counted) + have late := PublicCompressionCouplingIdealLateLinks.actual_pinned_mixed_probability Q iv p counted + have hidden := actual_hiddenGuess_probability Q iv p counted + have birthday' := birthday.trans (min_le_right _ _) + have late' := late.trans (min_le_right _ _) + have hidden' := hidden.trans (min_le_right _ _) + have union : average (fun table : Key Q → Digest32 => + if causalBad Q iv p counted table then (1:ℚ) else 0) ≤ + average (fun table => + (if PublicCompressionCouplingBirthday.alarm table + (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none) ∅ then (1:ℚ) else 0) + + (if PublicCompressionCouplingIdealLateLinks.alarm PublicCompressionCouplingIdealLateLinks.mixedCV + table (compile Q iv [] p Q (by rfl) counted) (fun _ => none) [] then (1:ℚ) else 0) + + (if hiddenGuess Q iv p counted table then (1:ℚ) else 0)) := by + apply average_mono + intro table + unfold causalBad + cases PublicCompressionCouplingBirthday.alarm table + (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none) ∅ <;> + cases PublicCompressionCouplingIdealLateLinks.alarm PublicCompressionCouplingIdealLateLinks.mixedCV + table (compile Q iv [] p Q (by rfl) counted) (fun _ => none) [] <;> + cases hiddenGuess Q iv p counted table <;> norm_num + rw [average_add,average_add] at union + linarith + +open Classical in + theorem actual_ideal_causalBad_probability {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) : + letI := DuplexPublicSimulator.seedFintype + letI := rawOracleFintype Q + average (fun coins : (RawKey Q → Digest32) × DuplexPublicSimulator.Seed => + if causalBad Q iv p counted (oracle coins.2 coins.1) then (1:ℚ) else 0) ≤ duplexModeLoss Q := by + let := DuplexPublicSimulator.seedFintype + let := rawOracleFintype Q + let := mixedKeyFintype Q + have bound := actual_causalBad_probability Q iv p counted + rw [PublicCompressionCouplingIdealLateLinks.table_average_eq_ideal] at bound + exact bound + +#print axioms actual_causalBad_probability +#print axioms actual_ideal_causalBad_probability +end Whir.PublicCompressionCouplingMixed diff --git a/verification/whir/Whir/PublicCompressionCouplingCertified.lean b/verification/whir/Whir/PublicCompressionCouplingCertified.lean new file mode 100644 index 000000000..f0a661c27 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingCertified.lean @@ -0,0 +1,70 @@ +import Whir.PublicCompressionCouplingMixed + +/-! Operational postconditions for the pinned public simulator. Certificates +are proved for every adaptive continuation, not supplied by a cryptographic +hypothesis. They permit bounded private inspection after the public game. -/ +namespace Whir.PublicCompressionCouplingMixed +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +namespace Computation +variable {Q n : Nat} {R S : Type} + +theorem every_of_forall (p : Computation Q R n) (P : R → Prop) + (h : ∀ r, P r) : Sampling.Every P p := by + induction p with + | ret r => exact h r + | draw k next ih => exact fun d => ih d + +@[simp] theorem every_map (p : Computation Q R n) (f : R → S) (P : S → Prop) : + Sampling.Every P (map f p) ↔ Sampling.Every (fun r => P (f r)) p := by + induction p with + | ret r => rfl + | draw k next ih => simp only [map,Sampling.Every]; exact forall_congr' ih + +def certify {P : R → Prop} {n : Nat} : (p : Computation Q R n) → Sampling.Every P p → + Computation Q {r // P r} n + | .ret r, h => .ret ⟨r,h⟩ + | .draw k next, h => .draw k (fun d => certify (next d) (h d)) + +@[simp] theorem eval_certify (table : Key Q → Digest32) (p : Computation Q R n) + {P : R → Prop} (h : Sampling.Every P p) : + (Sampling.eval table (certify p h)).val = Sampling.eval table p := by + induction p with + | ret => rfl + | draw k next ih => exact ih (table k) _ +end Computation + +/-- The source call meter bounds every possible public view, including all +choices of replies at every adaptive continuation. -/ +theorem compile_every_viewCost {R : Type} (Q : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) : + Sampling.Every (fun view => viewCost view ≤ remaining) + (compile Q iv log p remaining cap counted) := by + induction p generalizing log remaining with + | done r => simp [compile,Sampling.Every,viewCost] + | ask query next ih => + cases query with + | primitive purpose input => + simp only [compile,Sampling.every_pad,Sampling.every_bind] + apply Computation.every_of_forall + intro result + apply (Computation.every_map _ _ _).mpr + apply (ih result.2 result.1 (remaining-1) (by omega) (counted.2 _)).mono + intro tail bound + have hc : 1 ≤ remaining := counted.1 + simpa only [DuplexRawProgram.observe,viewCost,List.map_cons,List.sum_cons,Query.cost] + using (show 1 + viewCost tail ≤ remaining by omega) + | construction coordinate valid => + simp only [compile,Sampling.every_pad,Sampling.Every] + intro answer + apply (Computation.every_map _ _ _).mpr + apply (ih answer log (remaining-pathCost coordinate) (by omega) (counted.2 _)).mono + intro tail bound + have hc : pathCost coordinate ≤ remaining := counted.1 + simpa only [DuplexRawProgram.observe,viewCost,List.map_cons,List.sum_cons,Query.cost] + using (show pathCost coordinate + viewCost tail ≤ remaining by omega) + +#print axioms compile_every_viewCost +#print axioms Computation.eval_certify +end Whir.PublicCompressionCouplingMixed diff --git a/verification/whir/Whir/PublicCompressionCouplingClosure.lean b/verification/whir/Whir/PublicCompressionCouplingClosure.lean new file mode 100644 index 000000000..e62744cd8 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingClosure.lean @@ -0,0 +1,55 @@ +import Whir.PublicCompressionCouplingPublicTrace +import Whir.PublicCompressionCouplingHidden + +/-! Backward public-body closure of actual seed trees. A target-matching private +seed answer is exposed only through an actual earlier public seed coordinate; +chosen CVs themselves are never forbidden. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed + +/-- Once target-matching nodes have been recovered from actual cache support, +closure is a deterministic induction on the actual seed compression tree. -/ + theorem Tree.publicBody_of_exposure {seedTable : Seed} {cv : Digest32} {ns : List Node} + (tree : Tree (compressionOf seedTable) cv ns) (log : PublicLog) (targets : Finset Digest32) + (publicInputs : ∀ n d, (n,d) ∈ log → n.cv ∈ targets) + (exposed : ∀ n ∈ ns, seedTable n ∈ targets → (n,seedTable n) ∈ log) + (rootTarget : cv ∈ targets) : PublicBody log cv ns := by + induction tree with + | seed node valid => + exact PublicBody.seed (exposed node (by simp) rootTarget) valid + | step node rest internal child ih => + have member := exposed node (by simp) rootTarget + apply PublicBody.step member internal + apply ih + · intro n hn hit + exact exposed n (List.mem_cons_of_mem _ hn) hit + · exact publicInputs node (seedTable node) member + + theorem publicCVTargets_contains (observations : List Observation) {input : Node} {answer : Digest32} + (member : (input,answer) ∈ finalLog [] observations) : input.cv ∈ publicCVTargets observations := by + suffices generalized : ∀ (log : PublicLog) (observations : List Observation), + (input,answer) ∈ finalLog log observations → + (input,answer) ∈ log ∨ input.cv ∈ publicCVTargets observations by + exact (generalized [] observations member).resolve_left (by simp) + intro log observations + induction observations generalizing log with + | nil => exact fun member => Or.inl member + | cons observation rest ih => + rcases observation with ⟨query,digest⟩ + cases query with + | primitive purpose node => + intro member + rcases ih (observe log node digest) member with prior | later + · rcases List.mem_cons.mp prior with equal | old + · have nodes := congrArg Prod.fst equal + dsimp only at nodes + subst node + exact Or.inr (Finset.mem_insert_self _ _) + · exact Or.inl old + · exact Or.inr (Finset.mem_insert_of_mem later) + | construction coordinate valid => exact ih log + +#print axioms Tree.publicBody_of_exposure +#print axioms publicCVTargets_contains +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingConstructionStream.lean b/verification/whir/Whir/PublicCompressionCouplingConstructionStream.lean new file mode 100644 index 000000000..5c3ba92fd --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingConstructionStream.lean @@ -0,0 +1,173 @@ +import Whir.PublicCompressionCouplingPrimitiveStream +import Whir.PublicCompressionCouplingPublicTrace + +/-! Operational alignment of hidden Seed prefix calls and the actual RO terminal. +Both interpreters consume the identical fresh stream, including cache hits. -/ +namespace Whir.PublicCompressionCouplingConstructionStream +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open TypedFiatShamirGame +open TypedOracleCompiler (Sampling) +open PublicCompressionCouplingMixed PublicCompressionCouplingJoint +open PublicCompressionCouplingStreams PublicCompressionCouplingRelabelCache +open PublicCompressionCouplingRecognition PublicCompressionCouplingPrimitiveStream +set_option backward.isDefEq.respectTransparency false + + theorem run_draw_split {K R : Type} [DecidableEq K] {n : Nat} (key : K) + (next : Digest32 → PublicCompressionCouplingJoint.Computation K R n) + (cache : PublicCompressionCouplingJoint.Cache K) (stream : List Digest32) + {result : R} {final : PublicCompressionCouplingJoint.Cache K} {remaining : List Digest32} + (execution : run (.draw key next) cache stream=some (result,final,remaining)) : + ∃ answer updated rest, + run (.draw key (fun d => .ret (n:=0) d)) cache stream=some (answer,updated,rest) ∧ + run (next answer) updated rest=some (result,final,remaining) := by + cases hit : cache key with + | some answer => + exact ⟨answer,cache,stream,by rw [run_hit hit]; rfl,by rwa [run_hit hit] at execution⟩ + | none => + cases stream with + | nil => rw [run_miss_nil hit] at execution; cases execution + | cons answer rest => + exact ⟨answer,put cache key answer,rest,by rw [run_miss_cons hit]; rfl, + by rwa [run_miss_cons hit] at execution⟩ + + theorem mixed_map_recover {Q n : Nat} {R S : Type} (f : R → S) + (p : PublicCompressionCouplingMixed.Computation Q R n) + (cache : PublicCompressionCouplingJoint.Cache (Key Q)) (stream : List Digest32) + {result : S} {final : PublicCompressionCouplingJoint.Cache (Key Q)} {remaining : List Digest32} + (execution : run (PublicCompressionCouplingMixed.Computation.map f p) cache stream= + some (result,final,remaining)) : + ∃ value, run p cache stream=some (value,final,remaining) ∧ f value=result := by + rw [run_mixed_map] at execution + cases found : run p cache stream with + | none => simp only [found,Option.map_none] at execution; cases execution + | some triple => + rcases triple with ⟨value,updated,rest⟩ + simp only [found,Option.map_some,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨valueEq,cacheEq,restEq⟩ := execution + exact ⟨value,by simp only [cacheEq,restEq],valueEq⟩ + + theorem body_stream_alignment (Q : Nat) (seedTable : Seed) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) + (pc : PublicCompressionCouplingJoint.Cache Node) + (qc final : PublicCompressionCouplingJoint.Cache (Key Q)) (stream : List Digest32) + (body : Digest32 × BodyLog) (updated : PublicCompressionCouplingJoint.Cache (Key Q)) + (remaining : List Digest32) + (execution : run (bodyCalls Q cv xs) qc stream=some (body,updated,remaining)) + (related : Related (coordinateLabel seedTable) pc qc) + (extension : Extends updated final) (injective : InjectiveOn (coordinateLabel seedTable) final) : + ∃ pc', run (PublicCompressionProgram.planCalls cv xs) pc stream=some (body.1,pc',remaining) ∧ + Related (coordinateLabel seedTable) pc' updated ∧ Extends updated final := by + induction xs generalizing cv pc qc stream body updated remaining with + | nil => + simp only [bodyCalls,run,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨bodyEq,cacheEq,restEq⟩ := execution + subst body; subst updated; subst remaining + exact ⟨pc,rfl,related,extension⟩ + | cons instruction xs ih => + simp only [bodyCalls] at execution + obtain ⟨answer,first,rest,draw,tail⟩ := run_draw_split _ _ qc stream execution + obtain ⟨tailBody,tailRun,bodyEq⟩ := mixed_map_recover _ _ first rest tail + have firstExtension : Extends first final := by + intro key digest stored + exact extension key digest (run_extends _ first rest tailRun stored) + obtain ⟨firstReal,realDraw,firstRelated,_,_⟩ := matched_draw (coordinateLabel seedTable) + (.inl ⟨cv,instruction.1,instruction.2,true⟩) pc qc final stream answer first rest draw related + firstExtension injective + simp only [coordinateLabel] at realDraw + obtain ⟨lastReal,realTail,lastRelated,lastExtension⟩ := + ih answer firstReal first rest tailBody updated remaining tailRun firstRelated extension + refine ⟨lastReal,?_,lastRelated,lastExtension⟩ + have viewEq := congrArg (fun p : Digest32 × BodyLog => p.1) bodyEq + dsimp only at viewEq + simp only [PublicCompressionProgram.planCalls] + cases hit : pc ⟨cv,instruction.1,instruction.2,true⟩ with + | some value => + rw [run_hit hit] at realDraw ⊢ + simp only [run,Option.some.injEq,Prod.mk.injEq] at realDraw + obtain ⟨rfl,rfl,rfl⟩ := realDraw + simpa only [viewEq] using realTail + | none => + cases stream with + | nil => rw [run_miss_nil hit] at realDraw; cases realDraw + | cons value restStream => + rw [run_miss_cons hit] at realDraw ⊢ + simp only [run,Option.some.injEq,Prod.mk.injEq] at realDraw + obtain ⟨rfl,rfl,rfl⟩ := realDraw + simpa only [viewEq] using realTail + + theorem plan_append_run (cv : Digest32) (xs ys : List DuplexEncoding.Instruction) + (cache : PublicCompressionCouplingJoint.Cache Node) (stream : List Digest32) : + run (PublicCompressionProgram.planCalls cv (xs++ys)) cache stream = + match run (PublicCompressionProgram.planCalls cv xs) cache stream with + | none => none + | some (value,updated,rest) => run (PublicCompressionProgram.planCalls value ys) updated rest := by + induction xs generalizing cv cache stream with + | nil => rfl + | cons instruction xs ih => + cases hit : cache ⟨cv,instruction.1,instruction.2,true⟩ with + | some answer => + simp only [List.cons_append,PublicCompressionProgram.planCalls] + rw [run_hit hit,run_hit hit] + exact ih answer cache stream + | none => + cases stream with + | nil => simp only [List.cons_append,PublicCompressionProgram.planCalls,run_miss_nil,hit] + | cons answer rest => + simpa only [List.cons_append,PublicCompressionProgram.planCalls,run_miss_cons,hit] using + ih answer (put cache ⟨cv,instruction.1,instruction.2,true⟩ answer) rest + +open Classical in + theorem actual_construction_stream_alignment (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (budget : pathCost coordinate ≤ Q) + (pc : PublicCompressionCouplingJoint.Cache Node) + (qc final : PublicCompressionCouplingJoint.Cache (Key Q)) (stream : List Digest32) + (construction : InspectedConstruction) (updated : PublicCompressionCouplingJoint.Cache (Key Q)) + (remaining : List Digest32) + (execution : run (causalConstruction Q iv coordinate valid budget) qc stream= + some (construction,updated,remaining)) + (related : Related (coordinateLabel seedTable) pc qc) + (extension : Extends updated final) (injective : InjectiveOn (coordinateLabel seedTable) final) + (consistent : ∀ key answer, final key=some answer → oracle seedTable ro key=answer) : + ∃ pc', run (PublicCompressionProgram.queryCalls iv (.construction coordinate valid)) pc stream= + some (construction.advertised,pc',remaining) ∧ + Related (coordinateLabel seedTable) pc' updated ∧ Extends updated final := by + simp only [causalConstruction,run_pad,run_bind] at execution + cases prefixRun : run (bodyCalls Q iv (DuplexEncoding.plan coordinate).dropLast) qc stream with + | none => simp only [prefixRun] at execution; cases execution + | some triple => + rcases triple with ⟨body,prefixCache,prefixRest⟩ + rw [prefixRun] at execution + obtain ⟨answer,lastCache,lastRest,terminalRun,finish⟩ := run_draw_split + (.inr (constructionKey Q iv coordinate budget)) _ prefixCache prefixRest execution + simp only [run,Option.some.injEq,Prod.mk.injEq] at finish + obtain ⟨constructionEq,cacheEq,restEq⟩ := finish + subst construction; subst updated; subst remaining + have prefixExtension : Extends prefixCache final := by + intro key digest stored + exact extension key digest (run_extends _ prefixCache prefixRest execution stored) + obtain ⟨prefixReal,realPrefix,prefixRelated,_⟩ := body_stream_alignment Q seedTable iv _ pc qc + final stream body prefixCache prefixRest prefixRun related prefixExtension injective + have prefixValue := congrArg Prod.fst (run_eval _ qc stream prefixRun (oracle seedTable ro) + (fun key digest stored => consistent key digest (prefixExtension key digest stored))) + rw [bodyCalls_eval,plan_prefix_evaluate] at prefixValue + have label : coordinateLabel seedTable (.inr (constructionKey Q iv coordinate budget))= + ⟨body.1,(DuplexEncoding.terminalPlan coordinate.terminal).1, + (DuplexEncoding.terminalPlan coordinate.terminal).2,true⟩ := by + have witness := terminalLabel_witness (construction_coordinateWitness Q seedTable iv coordinate valid budget) + rw [coordinateLabel,witness,← prefixValue] + cases coordinate.terminal <;> rfl + obtain ⟨lastReal,realTerminal,lastRelated,_,_⟩ := matched_draw (coordinateLabel seedTable) + (.inr (constructionKey Q iv coordinate budget)) prefixReal prefixCache final prefixRest answer + lastCache lastRest terminalRun prefixRelated extension injective + refine ⟨lastReal,?_,lastRelated,extension⟩ + have planEq : DuplexEncoding.plan coordinate=(DuplexEncoding.plan coordinate).dropLast ++ + [DuplexEncoding.terminalPlan coordinate.terminal] := by + unfold DuplexEncoding.plan + rw [List.dropLast_concat] + exact (congrArg (fun xs => run (PublicCompressionProgram.planCalls iv xs) pc stream) planEq).trans (by + rw [plan_append_run,realPrefix] + simpa only [PublicCompressionProgram.planCalls,label,run] using realTerminal) + +#print axioms actual_construction_stream_alignment +end Whir.PublicCompressionCouplingConstructionStream diff --git a/verification/whir/Whir/PublicCompressionCouplingCoordinates.lean b/verification/whir/Whir/PublicCompressionCouplingCoordinates.lean new file mode 100644 index 000000000..aa9d0343e --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingCoordinates.lean @@ -0,0 +1,87 @@ +import Whir.PublicCompressionCouplingCache + +/-! Actual mixed coordinates identify their public primitive node. The seed +case keeps the full chosen node; the terminal case retains the complete raw key +and its actual seed-tree witness. This is independent of output-collision or +observer restrictions. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed + +inductive CoordinateWitness (Q : Nat) (seed : Seed) (input : Node) : Key Q → Prop where + | fallback : CoordinateWitness Q seed input (.inl input) + | terminal (key : RawKey Q) (rest : List Node) + (complete : Complete (input::rest)) + (tree : Tree (compressionOf seed) input.cv rest) + (extracted : extract (input::rest) = some (expandKey key)) : + CoordinateWitness Q seed input (.inr key) + + theorem CoordinateWitness.node_unique {Q : Nat} {seed : Seed} {a b : Node} {key : Key Q} + (left : CoordinateWitness Q seed a key) (right : CoordinateWitness Q seed b key) : a=b := by + cases left with + | fallback => cases right; rfl + | terminal raw rest complete tree extracted => + cases right with + | terminal raw' rest' complete' tree' extracted' => + exact (complete_key_unique complete complete' tree tree' + (extracted.trans extracted'.symm)).1 + + theorem privateKey_coordinateWitness {Q : Nat} {log : PublicLog} {input : Node} + {key : RawKey Q} (seed : Seed) (auth : NonterminalAuthentic seed log) + (found : privateKey Q log input = some key) : + CoordinateWitness Q seed input (.inr key) := by + obtain ⟨rest,complete,tree,extracted⟩ := privateKey_seed_tree seed auth found + exact CoordinateWitness.terminal key rest complete tree extracted + + theorem plan_prefix_evaluate (c : Compression) (iv : Digest32) (coordinate : Coordinate) : + evalPlan c iv (DuplexEncoding.plan coordinate).dropLast = + evalHistory c iv coordinate.history := by + change evalPlan c iv + ((([(ByteCodec.pairBytes (coordinate.history.domain,coordinate.history.statement), + UInt64.ofNat (2^56))] ++ coordinate.history.frames.flatMap DuplexEncoding.framePlan) ++ + [DuplexEncoding.terminalPlan coordinate.terminal]).dropLast) = _ + rw [List.dropLast_concat] + change evalPlan c (seed c iv coordinate.history.domain coordinate.history.statement).cv + (coordinate.history.frames.flatMap DuplexEncoding.framePlan) = _ + exact framesPlan_evaluate c _ _ + + theorem construction_coordinateWitness (Q : Nat) (seedTable : Seed) (iv : Digest32) + (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (budget : pathCost coordinate ≤ Q) : + CoordinateWitness Q seedTable + (terminalNode (evalHistory (compressionOf seedTable) iv coordinate.history) coordinate.terminal) + (.inr (constructionKey Q iv coordinate budget)) := by + let c := compressionOf seedTable + let traced := traceHistory c iv coordinate.history + have stateEq := traceHistory_cv c iv coordinate.history + apply CoordinateWitness.terminal (constructionKey Q iv coordinate budget) traced.nodes + · simpa only [coordinateTree,stateEq] using coordinateTree_complete c iv coordinate valid.1 + · cases terminalEq : coordinate.terminal <;> + simpa only [terminalEq,terminalNode,stateEq] using + (traceHistory_valid c iv coordinate.history valid.1).1 + · simpa only [coordinateTree,stateEq,expand_constructionKey] using + coordinateTree_key c iv coordinate valid + +/-- A public record carries its actually consumed mixed coordinate. A repeated +record carries the same old coordinate, not a new private RO request. -/ +def Witnessed (Q : Nat) (seed : Seed) (cache : Key Q → Option Digest32) + (log : PublicLog) : Prop := + ∀ input answer, (input,answer) ∈ log → + ∃ key, CoordinateWitness Q seed input key ∧ cache key = some answer + +/-- Cache answer injectivity plus actual coordinate witnesses yields the +simulator's public no-output-collision fact, including recognized RO terminals. -/ + theorem Witnessed.no_outputCollision {Q : Nat} {seed : Seed} {cache : Key Q → Option Digest32} + {log : PublicLog} (witnessed : Witnessed Q seed cache log) + (injective : ∀ a b d, cache a = some d → cache b = some d → a=b) : + ¬OutputCollision log := by + rintro ⟨a,b,d,ha,hb,different⟩ + obtain ⟨ka,left,hitA⟩ := witnessed a d ha + obtain ⟨kb,right,hitB⟩ := witnessed b d hb + have keys := injective ka kb d hitA hitB + subst kb + exact different (CoordinateWitness.node_unique left right) + +#print axioms CoordinateWitness.node_unique +#print axioms Witnessed.no_outputCollision +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingGoodGraph.lean b/verification/whir/Whir/PublicCompressionCouplingGoodGraph.lean new file mode 100644 index 000000000..153d178e1 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingGoodGraph.lean @@ -0,0 +1,100 @@ +import Whir.PublicCompressionCouplingTerminalSupport +import Whir.PublicCompressionCouplingTerminalSeedOrigin +import Whir.PublicCompressionCouplingLateRecognition +import Whir.PublicCompressionCouplingCausalRisk +import Whir.PublicCompressionCouplingRelabelCache + +/-! Actual good-path full-key correspondence. Terminal fallback cells cannot +alias consumed RO cells, including cached missed recognition. Chosen seed CVs +are retained throughout; all public primitive observers remain admitted. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed PublicCompressionCouplingJoint RawOracleCoupling +open TypedOracleCompiler (Sampling) +set_option backward.isDefEq.respectTransparency false + +open Classical in + theorem actual_terminal_seed_ne_raw_label {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (quiet : causalBad Q iv p counted (oracle seedTable ro)=false) + {node : Node} {key : RawKey Q} {seedAnswer rawAnswer : Digest32} + (seedStored : (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 (.inl node)=some seedAnswer) + (rawStored : (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 (.inr key)=some rawAnswer) : + node ≠ terminalLabel seedTable key := by + simp only [causalBad,Bool.or_eq_false_eq_eq_false_and_eq_false] at quiet + have birthday := quiet.1.1 + have late := quiet.1.2 + have hidden := quiet.2 + obtain ⟨input,rest,complete,tree,extracted,stored,exposed⟩ := + actual_terminal_support Q iv p counted seedTable ro hidden rawStored + have label := terminalLabel_witness (CoordinateWitness.terminal key rest complete tree extracted) + intro same + have nodes : node=input := same.trans label + clear label + subst input + have parsed := (complete?_correct _).mpr complete + simp only [complete?,Bool.and_eq_true,decide_eq_true_eq] at parsed + have terminal : isTerminal node := parsed.1 + have publicStored := actual_terminal_seed_public_cache Q iv p counted seedTable ro terminal seedStored + have publicTrace := PublicCompressionCouplingTargetCache.memo_empty_trace _ _ publicStored + have publicRecord := compile_seed_record Q seedTable ro iv [] p Q (by rfl) counted node seedAnswer publicTrace + have target := publicCVTargets_contains _ publicRecord + have body := exposed target + have clean := actual_causal_public_noOutputCollision Q iv p counted seedTable ro birthday + have functional := finalLog_functional ro iv ⟨seedTable,[]⟩ p Q (by rfl) counted + (by intro a b d e impossible; cases impossible) + rw [← compile_actual Q seedTable ro iv [] p Q (by rfl) counted] at functional + have recognized := recognized_complete functional clean terminal body + have missedLaw := PublicCompressionCouplingLateRecognition.actual_cached_fallback_unrecognized + Q seedTable ro iv p counted late clean + have rawEq : (fun a b : RawKey Q => Classical.propDecidable (a=b)) = + (inferInstance : DecidableEq (RawKey Q)) := Subsingleton.elim _ _ + rw [rawEq] at missedLaw + have missed := missedLaw node seedAnswer publicStored terminal + rw [missed] at recognized + cases recognized + +open Classical in + theorem actual_good_cache_label_injective {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (quiet : causalBad Q iv p counted (oracle seedTable ro)=false) : + PublicCompressionCouplingRelabelCache.InjectiveOn (coordinateLabel seedTable) + (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 := by + intro left right d e leftStored rightStored same + cases left with + | inl node => + cases right with + | inl other => exact congrArg Sum.inl same + | inr key => + exact False.elim (actual_terminal_seed_ne_raw_label Q iv p counted seedTable ro quiet + leftStored rightStored same) + | inr key => + cases right with + | inl node => + exact False.elim (actual_terminal_seed_ne_raw_label Q iv p counted seedTable ro quiet + rightStored leftStored same.symm) + | inr other => + have events := quiet + simp only [causalBad,Bool.or_eq_false_eq_eq_false_and_eq_false] at events + obtain ⟨input,rest,complete,tree,extracted,stored,exposed⟩ := + actual_terminal_support Q iv p counted seedTable ro events.2 leftStored + obtain ⟨input',rest',complete',tree',extracted',stored',exposed'⟩ := + actual_terminal_support Q iv p counted seedTable ro events.2 rightStored + have label := terminalLabel_witness (CoordinateWitness.terminal key rest complete tree extracted) + have label' := terminalLabel_witness (CoordinateWitness.terminal other rest' complete' tree' extracted') + have nodes : input=input' := label.symm.trans (same.trans label') + clear label label' + subst input' + have rawEq : (fun a b : RawKey Q => Classical.propDecidable (a=b)) = + (inferInstance : DecidableEq (RawKey Q)) := Subsingleton.elim _ _ + rw [rawEq] at events + have injective := PublicCompressionCouplingBirthdayCache.birthday_cache_injective + (oracle seedTable ro) (causalCompile Q iv [] p Q (by rfl) counted) events.1.1 + exact congrArg Sum.inr (terminal_rawKey_unique tree tree' extracted extracted' _ stored stored' injective) + +#print axioms actual_terminal_seed_ne_raw_label +#print axioms actual_good_cache_label_injective +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingHidden.lean b/verification/whir/Whir/PublicCompressionCouplingHidden.lean new file mode 100644 index 000000000..b6a7f0007 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingHidden.lean @@ -0,0 +1,82 @@ +import Whir.PublicCompressionCouplingInspection +import Whir.PublicCompressionCouplingTargets + +/-! The actual pinned simulator's hidden-forward-guess event. Public chosen +chaining values are retained, not excluded. Fresh hidden prefix answers are +sampled from the residual of the same seed table that served public requests. -/ +namespace Whir.PublicCompressionCouplingMixed +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open TypedFiatShamirGame RawOracleCoupling + +@[instance_reducible] +noncomputable def mixedKeyFintype (Q : Nat) : Fintype (Key Q) := by + letI := rawKeyFintype Q + infer_instance + +noncomputable def publicCVTargets : List Observation → Finset Digest32 + | [] => ∅ + | observation :: rest => match observation.query with + | .primitive _ node => insert node.cv (publicCVTargets rest) + | .construction _ _ => publicCVTargets rest + + theorem publicCVTargets_card (observations : List Observation) : + (publicCVTargets observations).card ≤ + (observations.map (fun observation => observation.query.cost)).sum := by + classical + induction observations with + | nil => simp [publicCVTargets] + | cons observation rest ih => + have ih' := ih + simp only [Query.cost] at ih' + cases query : observation.query with + | primitive purpose node => + simp only [publicCVTargets,query,List.map_cons,List.sum_cons,Query.cost] + have hc := Finset.card_insert_le node.cv (publicCVTargets rest) + omega + | construction coordinate valid => + simp only [publicCVTargets,query,List.map_cons,List.sum_cons,Query.cost] + omega + +def certifiedPublic {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) : Computation Q {view : View R // viewCost view ≤ Q} Q := + Computation.certify (compile Q iv [] p Q (by rfl) counted) + (compile_every_viewCost Q iv [] p Q (by rfl) counted) + +def privateInspection {R : Type} (Q : Nat) (iv : Digest32) + (view : {view : View R // viewCost view ≤ Q}) : + Computation Q (List InspectedConstruction) Q := + Sampling.pad (le_trans (inspectionCost_le view.val.observations) view.property) + (inspect Q iv view.val.observations) + +open Classical in +noncomputable def hiddenGuess {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (table : Key Q → Digest32) : Bool := + let result := Sampling.eval table (memo (certifiedPublic Q iv p counted) (fun _ => none)) + PublicCompressionCouplingTargets.alarm table (publicCVTargets result.1.val.observations) + (privateInspection Q iv result.1) result.2 + +open Classical in +/-- A derived bound from actual conditional uniform table sampling, not an +assumed missed-recognition certificate. Every adaptive continuation is covered. -/ +theorem actual_hiddenGuess_probability {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) : + letI := mixedKeyFintype Q + average (fun table : Key Q → Digest32 => + if hiddenGuess Q iv p counted table then (1:ℚ) else 0) ≤ + min 1 ((Q:ℚ)*Q/2^256) := by + let _ := mixedKeyFintype Q + apply le_min + · calc + _ ≤ average (fun _ : Key Q → Digest32 => (1:ℚ)) := by + apply average_mono + intro table + split <;> norm_num + _ = 1 := average_const _ + · exact PublicCompressionCouplingTargets.adaptive_posthoc_bound + (certifiedPublic Q iv p counted) (privateInspection Q iv) + (fun view => publicCVTargets view.val.observations) + (fun view => le_trans (publicCVTargets_card _) view.property) + +#print axioms publicCVTargets_card +#print axioms actual_hiddenGuess_probability +end Whir.PublicCompressionCouplingMixed diff --git a/verification/whir/Whir/PublicCompressionCouplingIdealLateLinks.lean b/verification/whir/Whir/PublicCompressionCouplingIdealLateLinks.lean new file mode 100644 index 000000000..77741944a --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingIdealLateLinks.lean @@ -0,0 +1,204 @@ +import Whir.PublicCompressionCouplingHidden + +/-! Late links in actual uniform mixed seed/RO tables. Targets are exactly +chaining values of earlier inl compression inputs. Cached draws still publish +their input CV; inr RO draws publish no compression CV. A fresh output is +checked before publishing its own input, giving the actual birthday ledger. -/ +namespace Whir.PublicCompressionCouplingIdealLateLinks +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open TypedFiatShamirGame RawOracleCoupling +open PublicCompressionCoupling (collisionLedger) + +variable {K R : Type} [DecidableEq K] +abbrev Computation (K R : Type) (n : Nat) := Sampling K (fun _ => Digest32) R n + +def advance (inputCV : K → Option Digest32) (key : K) (history : List Digest32) : + List Digest32 := match inputCV key with + | none => history + | some cv => cv :: history + +omit [DecidableEq K] in + theorem advance_length (inputCV : K → Option Digest32) (key : K) (history : List Digest32) : + (advance inputCV key history).length ≤ history.length+1 := by + cases hit : inputCV key <;> simp [advance,hit] + +noncomputable def alarm (inputCV : K → Option Digest32) (table : K → Digest32) {n : Nat} : + Computation K R n → (K → Option Digest32) → List Digest32 → Bool + | .ret _, _, _ => false + | .draw key next, cache, history => match cache key with + | some answer => alarm inputCV table (next answer) cache (advance inputCV key history) + | none => decide (table key ∈ history.toFinset) || + alarm inputCV table (next (table key)) (put cache key (table key)) + (advance inputCV key history) + +noncomputable def risk (inputCV : K → Option Digest32) {n : Nat} : + Computation K R n → (K → Option Digest32) → List Digest32 → ℚ + | .ret _, _, _ => 0 + | .draw key next, cache, history => match cache key with + | some answer => risk inputCV (next answer) cache (advance inputCV key history) + | none => average (fun answer : Digest32 => if answer ∈ history.toFinset then 1 else + risk inputCV (next answer) (put cache key answer) (advance inputCV key history)) + +private theorem ledger_nonneg (n k : Nat) : 0 ≤ collisionLedger n k := by + cases n with + | zero => simp [collisionLedger] + | succ n => + unfold collisionLedger + simp only [Nat.cast_add,Nat.cast_one,add_sub_cancel_right] + positivity + +private theorem ledger_step (n k : Nat) : + collisionLedger (n+1) k = (k:ℚ)/2^256 + collisionLedger n (k+1) := by + unfold collisionLedger + push_cast + ring + +private theorem ledger_mono_previous (n : Nat) {j k : Nat} (h : j ≤ k) : + collisionLedger n j ≤ collisionLedger n k := by + unfold collisionLedger + apply div_le_div_of_nonneg_right _ (by positivity) + apply add_le_add_left + exact mul_le_mul_of_nonneg_left (by exact_mod_cast h) (by positivity) + + theorem risk_bound (inputCV : K → Option Digest32) {n : Nat} + (p : Computation K R n) (cache : K → Option Digest32) (history : List Digest32) : + risk inputCV p cache history ≤ collisionLedger n history.length := by + classical + induction p generalizing cache history with + | ret r => exact ledger_nonneg _ _ + | @draw n key next ih => + have hs := ledger_step n history.length + cases hit : cache key with + | some answer => + simp only [risk,hit] + have ht := le_trans (ih answer cache (advance inputCV key history)) + (ledger_mono_previous n (advance_length inputCV key history)) + rw [hs] + have hn : (0:ℚ) ≤ (history.length:ℚ)/2^256 := by positivity + linarith + | none => + simp only [risk,hit] + calc + _ ≤ average (fun answer : Digest32 => + (if answer ∈ history.toFinset then (1:ℚ) else 0) + + collisionLedger n (history.length+1)) := by + apply average_mono + intro answer + have ht := le_trans (ih answer (put cache key answer) (advance inputCV key history)) + (ledger_mono_previous n (advance_length inputCV key history)) + have hn := ledger_nonneg n (history.length+1) + by_cases bad : answer ∈ history.toFinset + · simp only [bad,↓reduceIte]; linarith + · simpa only [bad,↓reduceIte,zero_add] using ht + _ = (history.toFinset.card:ℚ)/2^256 + collisionLedger n (history.length+1) := by + rw [average_add,PublicMerkleProbability.uniform_target_probability,average_const] + _ ≤ (history.length:ℚ)/2^256 + collisionLedger n (history.length+1) := by + apply add_le_add_left + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast List.toFinset_card_le history + _ = _ := hs.symm + +variable [Fintype K] + +/-- Exact disintegration of the actual table; adaptive keys and cached requests +are processed by the existing memo semantics, not a supplied alarm bound. -/ +theorem table_alarm_eq_risk (inputCV : K → Option Digest32) {n : Nat} + (p : Computation K R n) (cache : K → Option Digest32) (history : List Digest32) : + average (fun table : K → Digest32 => + if alarm inputCV (overlay cache table) p cache history then (1:ℚ) else 0) = + risk inputCV p cache history := by + classical + induction p generalizing cache history with + | ret r => simp [alarm,risk,average_const] + | draw key next ih => + cases hit : cache key with + | some answer => + simp only [alarm,risk,hit] + exact ih answer cache (advance inputCV key history) + | none => + rw [overlay_average cache key hit + (fun table => if alarm inputCV table (.draw key next) cache history then (1:ℚ) else 0)] + simp only [risk,hit] + apply congrArg average + funext answer + by_cases bad : answer ∈ history.toFinset + · simp [alarm,hit,overlay,bad,average_const] + · rw [← ih answer (put cache key answer) (advance inputCV key history)] + simp only [bad,↓reduceIte] + apply congrArg average + funext table + simp [alarm,hit,overlay,bad] + +set_option backward.isDefEq.respectTransparency false in + theorem actual_table_bound (inputCV : K → Option Digest32) {n : Nat} + (p : Computation K R n) : + average (fun table : K → Digest32 => + if alarm inputCV table p (fun _ => none) [] then (1:ℚ) else 0) ≤ compressionBirthdayLoss n := by + unfold compressionBirthdayLoss + apply le_min + · calc + _ ≤ average (fun _ : K → Digest32 => (1:ℚ)) := by + apply average_mono + intro table + split <;> norm_num + _ = 1 := average_const _ + · have h := risk_bound inputCV p (fun _ => none) [] + rw [← table_alarm_eq_risk] at h + simpa only [overlay_empty,List.length_nil,PublicCompressionCoupling.collisionLedger_zero] using h + +def mixedCV {Q : Nat} : PublicCompressionCouplingMixed.Key Q → Option Digest32 + | .inl input => some input.cv + | .inr _ => none + +open Classical in +/-- The literal mixed-table public phase uses the PINNED simulator's lookup, +recognition and fallback, retaining all chosen public CVs and the full View. -/ +theorem actual_pinned_mixed_probability {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) : + letI := PublicCompressionCouplingMixed.mixedKeyFintype Q + average (fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + if alarm mixedCV table (PublicCompressionCouplingMixed.compile Q iv [] p Q (by rfl) counted) + (fun _ => none) [] then (1:ℚ) else 0) ≤ compressionBirthdayLoss Q := by + let _ := PublicCompressionCouplingMixed.mixedKeyFintype Q + exact actual_table_bound mixedCV _ + +open Classical in +/-- Exact uniform finite-product marginal, in the real ideal experiment's +RO-first coin order. The tables are not replaced by a stand-in simulator. -/ +theorem table_average_eq_ideal {Q : Nat} + [Fintype (PublicCompressionCouplingMixed.Key Q)] [Fintype DuplexPublicSimulator.Seed] + [Fintype (RawKey Q → Digest32)] + (payoff : (PublicCompressionCouplingMixed.Key Q → Digest32) → ℚ) : + average payoff = average (fun coins : (RawKey Q → Digest32) × DuplexPublicSimulator.Seed => + payoff (PublicCompressionCouplingMixed.oracle coins.2 coins.1)) := by + let e := (PublicCompressionCouplingMixed.tableEquiv Q).trans + (Equiv.prodComm DuplexPublicSimulator.Seed (RawKey Q → Digest32)) + have h := average_equiv e (fun coins => payoff (e.symm coins)) + have inverse (coins : (RawKey Q → Digest32) × DuplexPublicSimulator.Seed) : + e.symm coins = PublicCompressionCouplingMixed.oracle coins.2 coins.1 := rfl + simp only [Equiv.symm_apply_apply] at h + simpa only [inverse] using h + +open Classical in +/-- Actual uniformly sampled RO and pinned fallback seed, with no assumed bad +probability premise. Every counted adaptive Program continuation is covered. -/ +theorem actual_ideal_lateLink_probability {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) : + letI := DuplexPublicSimulator.seedFintype + letI := rawOracleFintype Q + average (fun coins : (RawKey Q → Digest32) × DuplexPublicSimulator.Seed => + if alarm mixedCV (PublicCompressionCouplingMixed.oracle coins.2 coins.1) + (PublicCompressionCouplingMixed.compile Q iv [] p Q (by rfl) counted) + (fun _ => none) [] then (1:ℚ) else 0) ≤ compressionBirthdayLoss Q := by + let _ := DuplexPublicSimulator.seedFintype + let _ := rawOracleFintype Q + let _ := PublicCompressionCouplingMixed.mixedKeyFintype Q + have h := actual_pinned_mixed_probability Q iv p counted + rw [table_average_eq_ideal] at h + exact h + +#print axioms table_alarm_eq_risk +#print axioms actual_table_bound +#print axioms table_average_eq_ideal +#print axioms actual_ideal_lateLink_probability +end Whir.PublicCompressionCouplingIdealLateLinks diff --git a/verification/whir/Whir/PublicCompressionCouplingInspection.lean b/verification/whir/Whir/PublicCompressionCouplingInspection.lean new file mode 100644 index 000000000..586375c4c --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingInspection.lean @@ -0,0 +1,113 @@ +import Whir.PublicCompressionCouplingCertified + +/-! Hidden construction prefixes are read from the very same pinned simulator +seed table, after fixing the full public view. No inspection result reaches the +adversary. All of these actual compression queries are explicitly charged. -/ +namespace Whir.PublicCompressionCouplingMixed +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +abbrev BodyLog := List (Node × Digest32) + +def bodyCalls (Q : Nat) (cv : Digest32) : + (xs : List DuplexEncoding.Instruction) → Computation Q (Digest32 × BodyLog) xs.length + | [] => .ret (cv,[]) + | instruction :: rest => + let node : Node := ⟨cv,instruction.1,instruction.2,true⟩ + .draw (.inl node) (fun answer => + Computation.map (fun result => (result.1,(node,answer)::result.2)) + (bodyCalls Q answer rest)) + + theorem bodyCalls_eval (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (cv : Digest32) (xs : List DuplexEncoding.Instruction) : + (Sampling.eval (oracle seed ro) (bodyCalls Q cv xs)).1 = + evalPlan (compressionOf seed) cv xs := by + induction xs generalizing cv with + | nil => rfl + | cons instruction rest ih => + simpa only [bodyCalls,Sampling.eval,Computation.eval_map,oracle,evalPlan, + List.foldl_cons,compressionOf] using ih _ + + theorem bodyCalls_length (Q : Nat) (table : Key Q → Digest32) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + (Sampling.eval table (bodyCalls Q cv xs)).2.length = xs.length := by + induction xs generalizing cv with + | nil => rfl + | cons instruction rest ih => + simp only [bodyCalls,Sampling.eval,Computation.eval_map,List.length_cons,ih] + +structure InspectedConstruction where + coordinate : Coordinate + valid : DuplexEncoding.Admissible coordinate + advertised : Digest32 + prefixEnd : Digest32 + prefixLog : BodyLog + +def inspectionCost : List Observation → Nat + | [] => 0 + | observation :: rest => + match observation.query with + | .primitive _ _ => inspectionCost rest + | .construction coordinate _ => + (DuplexEncoding.plan coordinate).dropLast.length + inspectionCost rest + +def inspect (Q : Nat) (iv : Digest32) : + (observations : List Observation) → + Computation Q (List InspectedConstruction) (inspectionCost observations) + | [] => .ret [] + | ⟨.primitive _ _,_⟩ :: rest => inspect Q iv rest + | ⟨.construction coordinate valid,answer⟩ :: rest => + Sampling.bind (bodyCalls Q iv (DuplexEncoding.plan coordinate).dropLast) + (fun result => Computation.map + (fun others => ⟨coordinate,valid,answer,result.1,result.2⟩::others) + (inspect Q iv rest)) + + theorem inspectionCost_le (observations : List Observation) : + inspectionCost observations ≤ + (observations.map (fun observation => observation.query.cost)).sum := by + induction observations with + | nil => rfl + | cons observation rest ih => + have ih' := ih + simp only [Query.cost] at ih' + cases query : observation.query with + | primitive => simp only [inspectionCost,query,List.map_cons,List.sum_cons,Query.cost]; omega + | construction coordinate valid => + simp only [inspectionCost,query,List.map_cons,List.sum_cons,Query.cost, + List.length_dropLast] + unfold pathCost at ih' ⊢ + omega + +/-- A literal finite adaptive mixed-table experiment: first execute the pinned +simulator, then inspect the actual seed-table prefixes of every construction. +The private cap follows from the proved operational postcondition. -/ +def inspectedGame {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) : + Computation Q (View R × List InspectedConstruction) (Q+Q) := + Sampling.bind + (Computation.certify (compile Q iv [] p Q (by rfl) counted) + (compile_every_viewCost Q iv [] p Q (by rfl) counted)) + (fun view => Sampling.pad + (le_trans (inspectionCost_le view.val.observations) view.property) + (Computation.map (fun bodies => (view.val,bodies)) + (inspect Q iv view.val.observations))) + + theorem inspectedGame_public {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) : + (Sampling.eval (oracle seed ro) (inspectedGame Q iv p counted)).1 = + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨seed,[]⟩ p Q (by rfl) counted).view := by + simp only [inspectedGame,Sampling.eval_bind,Sampling.eval_pad,Computation.eval_map, + Computation.eval_certify,compile_actual] + + theorem inspectedGame_private_count {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (table : Key Q → Digest32) : + inspectionCost (Sampling.eval table (inspectedGame Q iv p counted)).1.observations ≤ Q := by + simp only [inspectedGame,Sampling.eval_bind,Sampling.eval_pad,Computation.eval_map] + exact le_trans (inspectionCost_le _) (Sampling.eval table + (Computation.certify (compile Q iv [] p Q (by rfl) counted) + (compile_every_viewCost Q iv [] p Q (by rfl) counted))).property + +#print axioms bodyCalls_eval +#print axioms inspectedGame_public +#print axioms inspectedGame_private_count +end Whir.PublicCompressionCouplingMixed diff --git a/verification/whir/Whir/PublicCompressionCouplingInspectionSupport.lean b/verification/whir/Whir/PublicCompressionCouplingInspectionSupport.lean new file mode 100644 index 000000000..9715984b7 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingInspectionSupport.lean @@ -0,0 +1,85 @@ +import Whir.PublicCompressionCouplingPrefixTrace +import Whir.PublicCompressionCouplingClosure +import Whir.PublicCompressionCouplingTargetCache + +/-! Actual private-prefix target matches imply actual public primitive records. +This fills the hidden-prefix half of cache/trace correspondence using the +literal public memo cache, not a guessed primitive/RO coupling certificate. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed RawOracleCoupling +open TypedOracleCompiler (Sampling) + + theorem execute_certify_trace {Q n : Nat} {R : Type} {P : R → Prop} + (table : Key Q → Digest32) (p : Computation Q R n) (every : Sampling.Every P p) : + (Sampling.execute table (PublicCompressionCouplingMixed.Computation.certify p every)).2 = (Sampling.execute table p).2 := by + induction p with + | ret result => rfl + | draw key next ih => + simpa only [PublicCompressionCouplingMixed.Computation.certify,Sampling.execute] using + congrArg (⟨key,table key⟩ :: ·) (ih (table key) _) + +open Classical in + theorem actual_inspection_target_record {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (quiet : hiddenGuess Q iv p counted (oracle seedTable ro) = false) + {construction : InspectedConstruction} + (constructionMember : construction ∈ Sampling.eval (oracle seedTable ro) + (inspect Q iv (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations)) + {node : Node} {answer : Digest32} (record : (node,answer) ∈ construction.prefixLog) + (target : answer ∈ publicCVTargets (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) : + (node,answer) ∈ finalLog [] (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations := by + let table := oracle seedTable ro + have publicValue : (Sampling.eval table (memo (certifiedPublic Q iv p counted) + (fun _ => none))).1.val = Sampling.eval table (compile Q iv [] p Q (by rfl) counted) := by + simp only [memo_eval_first,overlay_empty,certifiedPublic,PublicCompressionCouplingMixed.Computation.eval_certify] + have inspected : (⟨.inl node,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute table (privateInspection Q iv + (Sampling.eval table (memo (certifiedPublic Q iv p counted) (fun _ => none))).1)).2 := by + simp only [privateInspection,Sampling.execute_pad] + rw [publicValue] + exact inspect_prefix_record Q iv table _ constructionMember record + have publicStored := PublicCompressionCouplingTargetCache.inspected_seed_target_public + Q iv p counted table quiet inspected (by simpa only [publicValue] using target) + have publicTrace := PublicCompressionCouplingTargetCache.memo_empty_trace + table (certifiedPublic Q iv p counted) publicStored + simp only [certifiedPublic,execute_certify_trace] at publicTrace + exact compile_seed_record Q seedTable ro iv [] p Q (by rfl) counted node answer publicTrace + +open Classical in +/-- Outside the actual hidden-guess alarm, every inspected seed-tree prefix +whose output is a chosen public CV is an actual body in the final public log. +Late-recognition stability is the separate chronological obligation. -/ + theorem actual_inspection_publicBody {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (quiet : hiddenGuess Q iv p counted (oracle seedTable ro) = false) + {construction : InspectedConstruction} + (constructionMember : construction ∈ Sampling.eval (oracle seedTable ro) + (inspect Q iv (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations)) + (target : evalHistory (compressionOf seedTable) iv construction.coordinate.history ∈ + publicCVTargets (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) : + PublicBody (finalLog [] (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) + (evalHistory (compressionOf seedTable) iv construction.coordinate.history) + (traceHistory (compressionOf seedTable) iv construction.coordinate.history).nodes := by + have tree := (traceHistory_valid (compressionOf seedTable) iv + construction.coordinate.history construction.valid.1).1 + rw [traceHistory_cv] at tree + apply Tree.publicBody_of_exposure tree _ _ + · intro node answer member + exact publicCVTargets_contains _ member + · intro node member hit + apply actual_inspection_target_record Q iv p counted seedTable ro quiet constructionMember _ hit + rw [inspect_construction_nodes Q seedTable ro iv _ constructionMember] + apply List.mem_map.mpr + exact ⟨node,by simpa only [List.mem_reverse] using member,rfl⟩ + · exact target + +#print axioms actual_inspection_target_record +#print axioms actual_inspection_publicBody +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingJoint.lean b/verification/whir/Whir/PublicCompressionCouplingJoint.lean new file mode 100644 index 000000000..875b7352d --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingJoint.lean @@ -0,0 +1,157 @@ +import Whir.PublicCompressionCoupling + +/-! A finite shared-answer coupling of actual globally memoized adaptive +programs. Each draw here is an independent uniform digest, not a primitive +oracle coordinate. Both marginals are the existing exact lazy-sampling +experiments. Cached requests consume no fresh randomness. -/ +namespace Whir.PublicCompressionCouplingJoint +open FiatShamirGame TypedOracleCompiler TypedFiatShamirGame + +abbrev Cache (K : Type) := K → Option Digest32 +abbrev Draws (R : Type) (n : Nat) := Sampling Unit (fun _ => Digest32) R n +abbrev Computation (K R : Type) (n : Nat) := + Sampling K (fun _ => Digest32) R n + +variable {A B R S : Type} [DecidableEq A] [DecidableEq B] + +noncomputable def joint {n m : Nat} (p : Computation A R n) (pc : Cache A) + (q : Computation B S m) (qc : Cache B) : Draws ((R × Cache A) × (S × Cache B)) (n+m) := + match p,q with + | .ret r,.ret s => .ret ((r,pc),(s,qc)) + | @Sampling.draw _ _ _ i a nextp,.ret s => + match pc a with + | some answer => Sampling.pad (by omega) (joint (nextp answer) pc (.ret (n:=m) s) qc) + | none => Sampling.pad (n:=i+m+1) (m:=i+1+m) (by omega) + (.draw () (fun answer => joint (nextp answer) (put pc a answer) (.ret (n:=m) s) qc)) + | .ret r,@Sampling.draw _ _ _ j b nextq => + match qc b with + | some answer => Sampling.pad (by omega) (joint (.ret (n:=n) r) pc (nextq answer) qc) + | none => Sampling.pad (n:=n+j+1) (m:=n+(j+1)) (by omega) + (.draw () (fun answer => joint (.ret (n:=n) r) pc (nextq answer) (put qc b answer))) + | @Sampling.draw _ _ _ i a nextp,@Sampling.draw _ _ _ j b nextq => + match pc a with + | some answer => Sampling.pad (by omega) + (joint (nextp answer) pc (.draw b nextq) qc) + | none => match qc b with + | some answer => Sampling.pad (by omega) + (joint (.draw a nextp) pc (nextq answer) qc) + | none => Sampling.pad (n:=i+j+1) (m:=i+1+(j+1)) (by omega) + (.draw () (fun answer => + joint (nextp answer) (put pc a answer) (nextq answer) (put qc b answer))) +termination_by n+m + +theorem joint_first {n m : Nat} (p : Computation A R n) (pc : Cache A) + (q : Computation B S m) (qc : Cache B) (payoff : R × Cache A → ℚ) : + Sampling.expectation (fun pair => payoff pair.1) (joint p pc q qc) = + Sampling.expectation payoff (RawOracleCoupling.memo p pc) := by + suffices aux : ∀ size n m, n+m=size → + ∀ (p : Computation A R n) (pc : Cache A) (q : Computation B S m) (qc : Cache B), + Sampling.expectation (fun pair => payoff pair.1) (joint p pc q qc) = + Sampling.expectation payoff (RawOracleCoupling.memo p pc) by + exact aux (n+m) n m rfl p pc q qc + intro size + induction size using Nat.strong_induction_on with + | h size ih => + intro n m h p pc q qc + cases p with + | ret r => + cases q with + | ret s => simp only [joint,RawOracleCoupling.memo,Sampling.expectation] + | @draw j b nextq => + cases hit : qc b with + | some answer => + simp only [joint,hit,Sampling.expectation_pad] + exact ih (n+j) (by omega) _ _ rfl _ _ _ _ + | none => + simp only [joint,hit,Sampling.expectation_pad,Sampling.expectation] + have eq (answer : Digest32) := + ih (n+j) (by omega) n j rfl (.ret r) pc (nextq answer) (put qc b answer) + simp only [eq,RawOracleCoupling.memo,Sampling.expectation] + exact average_const _ + | @draw i a nextp => + cases q with + | ret s => + cases hit : pc a with + | some answer => + simp only [joint,RawOracleCoupling.memo,hit,Sampling.expectation_pad] + exact ih (i+m) (by omega) _ _ rfl _ _ _ _ + | none => + simp only [joint,RawOracleCoupling.memo,hit,Sampling.expectation_pad,Sampling.expectation] + apply congrArg average + funext answer + exact ih (i+m) (by omega) _ _ rfl _ _ _ _ + | @draw j b nextq => + cases hp : pc a with + | some answer => + simp only [joint,RawOracleCoupling.memo,hp,Sampling.expectation_pad] + exact ih (i+(j+1)) (by omega) _ _ rfl _ _ _ _ + | none => + cases hq : qc b with + | some answer => + simp only [joint,hp,hq,Sampling.expectation_pad] + exact ih (i+1+j) (by omega) _ _ rfl _ _ _ _ + | none => + simp only [joint,RawOracleCoupling.memo,hp,hq,Sampling.expectation_pad,Sampling.expectation] + apply congrArg average + funext answer + exact ih (i+j) (by omega) _ _ rfl _ _ _ _ + +theorem joint_second {n m : Nat} (p : Computation A R n) (pc : Cache A) + (q : Computation B S m) (qc : Cache B) (payoff : S × Cache B → ℚ) : + Sampling.expectation (fun pair => payoff pair.2) (joint p pc q qc) = + Sampling.expectation payoff (RawOracleCoupling.memo q qc) := by + suffices aux : ∀ size n m, n+m=size → + ∀ (p : Computation A R n) (pc : Cache A) (q : Computation B S m) (qc : Cache B), + Sampling.expectation (fun pair => payoff pair.2) (joint p pc q qc) = + Sampling.expectation payoff (RawOracleCoupling.memo q qc) by + exact aux (n+m) n m rfl p pc q qc + intro size + induction size using Nat.strong_induction_on with + | h size ih => + intro n m h p pc q qc + cases p with + | ret r => + cases q with + | ret s => simp only [joint,RawOracleCoupling.memo,Sampling.expectation] + | @draw j b nextq => + cases hit : qc b with + | some answer => + simp only [joint,RawOracleCoupling.memo,hit,Sampling.expectation_pad] + exact ih (n+j) (by omega) _ _ rfl _ _ _ _ + | none => + simp only [joint,RawOracleCoupling.memo,hit,Sampling.expectation_pad,Sampling.expectation] + apply congrArg average + funext answer + exact ih (n+j) (by omega) _ _ rfl _ _ _ _ + | @draw i a nextp => + cases q with + | ret s => + cases hit : pc a with + | some answer => + simp only [joint,hit,Sampling.expectation_pad] + exact ih (i+m) (by omega) _ _ rfl _ _ _ _ + | none => + simp only [joint,hit,Sampling.expectation_pad,Sampling.expectation] + have eq (answer : Digest32) := + ih (i+m) (by omega) i m rfl (nextp answer) (put pc a answer) (.ret s) qc + simp only [eq,RawOracleCoupling.memo,Sampling.expectation] + exact average_const _ + | @draw j b nextq => + cases hp : pc a with + | some answer => + simp only [joint,hp,Sampling.expectation_pad] + exact ih (i+(j+1)) (by omega) _ _ rfl _ _ _ _ + | none => + cases hq : qc b with + | some answer => + simp only [joint,RawOracleCoupling.memo,hp,hq,Sampling.expectation_pad] + exact ih (i+1+j) (by omega) _ _ rfl _ _ _ _ + | none => + simp only [joint,RawOracleCoupling.memo,hp,hq,Sampling.expectation_pad,Sampling.expectation] + apply congrArg average + funext answer + exact ih (i+j) (by omega) _ _ rfl _ _ _ _ + +#print axioms joint_second +#print axioms joint_first +end Whir.PublicCompressionCouplingJoint diff --git a/verification/whir/Whir/PublicCompressionCouplingJointResidual.lean b/verification/whir/Whir/PublicCompressionCouplingJointResidual.lean new file mode 100644 index 000000000..df20ae0bf --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingJointResidual.lean @@ -0,0 +1,61 @@ +import Whir.PublicCompressionCouplingResidual +import Whir.PublicCompressionCouplingStreams + +/-! Exact residual disintegration of the second marginal of the actual +shared-answer coupling. Domination is checked only on operationally reachable +joint results, and averages every completion of their actual final cache. -/ +namespace Whir.PublicCompressionCouplingJoint +open FiatShamirGame TypedFiatShamirGame RawOracleCoupling +open TypedOracleCompiler (Sampling) + +variable {A B R S : Type} [DecidableEq A] [DecidableEq B] [Fintype B] + +/-- The untouched coordinates remain uniform after the adaptive second run. -/ +theorem joint_second_residual {n m : Nat} (p : Computation A R n) (pc : Cache A) + (q : Computation B S m) (qc : Cache B) + (payoff : (S × Cache B) → (B → Digest32) → ℚ) : + Sampling.expectation (fun pair => average (fun table : B → Digest32 => + payoff pair.2 (overlay pair.2.2 table))) (joint p pc q qc) = + average (fun table : B → Digest32 => + payoff (Sampling.eval (overlay qc table) (memo q qc)) (overlay qc table)) := by + rw [joint_second p pc q qc (fun result => average (fun table : B → Digest32 => + payoff result (overlay result.2 table)))] + exact (PublicCompressionCouplingResidual.memo_residual q qc payoff).symm + +/-- Reachability-aware monotonicity needs no condition on unused result values. -/ +theorem expectation_mono_runs {K T : Type} {n : Nat} + (p : Sampling K (fun _ => Digest32) T n) (f g : T → ℚ) + (bound : ∀ trace result, Sampling.Runs p trace result → f result ≤ g result) : + Sampling.expectation f p ≤ Sampling.expectation g p := by + induction p with + | ret result => exact bound [] result (.ret result) + | draw key next ih => + apply average_mono + intro answer + apply ih answer + intro trace result execution + apply bound (⟨key,answer⟩::trace) result + exact @Sampling.Runs.draw K (fun _ => Digest32) T _ key next trace result answer execution + +/-- A pointwise bound for every residual completion lifts to the exact second +marginal, without sampling a transcript certificate or restricting an observer. -/ +theorem joint_residual_domination {n m : Nat} (p : Computation A R n) (pc : Cache A) + (q : Computation B S m) (qc : Cache B) + (f : ((R × Cache A) × (S × Cache B)) → ℚ) + (payoff : (S × Cache B) → (B → Digest32) → ℚ) + (bound : ∀ trace pair, Sampling.Runs (joint p pc q qc) trace pair → + ∀ table : B → Digest32, f pair ≤ payoff pair.2 (overlay pair.2.2 table)) : + Sampling.expectation f (joint p pc q qc) ≤ + average (fun table : B → Digest32 => + payoff (Sampling.eval (overlay qc table) (memo q qc)) (overlay qc table)) := by + rw [← joint_second_residual p pc q qc payoff] + apply expectation_mono_runs + intro trace pair execution + calc + f pair = average (fun _ : B → Digest32 => f pair) := (average_const _).symm + _ ≤ average (fun table : B → Digest32 => payoff pair.2 (overlay pair.2.2 table)) := + average_mono (bound trace pair execution) + +#print axioms joint_second_residual +#print axioms joint_residual_domination +end Whir.PublicCompressionCouplingJoint diff --git a/verification/whir/Whir/PublicCompressionCouplingKeys.lean b/verification/whir/Whir/PublicCompressionCouplingKeys.lean new file mode 100644 index 000000000..7d19920ac --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingKeys.lean @@ -0,0 +1,72 @@ +import Whir.PublicCompressionCouplingRecognition + +/-! Raw message/template equality determines the entire actual seed-table tree. +This uses the retained chosen seed CV, not a fixed-CV observer restriction. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame + + theorem node_fields_equal {n m : Node} (cv : n.cv=m.cv) (block : n.block=m.block) + (tweak : n.tweak=m.tweak) (last : n.last=m.last) : n=m := by + cases n + cases m + simp_all + + theorem tree_key_unique {c : Compression} {a b : Digest32} {ns ms : List Node} + (left : Tree c a ns) (right : Tree c b ms) + (message : ns.map payload = ms.map payload) + (template : ns.map (fun n => (n.tweak,n.last)) = ms.map (fun n => (n.tweak,n.last))) : + ns=ms ∧ a=b := by + induction left generalizing b ms with + | seed n hn => + cases right with + | seed m hm => + have hm' : payload n=payload m := by simpa using message + have ht : (n.tweak,n.last)=(m.tweak,m.last) := by simpa using template + have hp : n.cv=m.cv ∧ n.block=m.block := by + simpa only [payload,hn,hm,↓reduceIte,Prod.mk.injEq,Option.some.injEq] using hm' + have eq := node_fields_equal hp.1 hp.2 (congrArg Prod.fst ht) (congrArg Prod.snd ht) + subst m + exact ⟨rfl,rfl⟩ + | step m rest hm child => + have length := congrArg List.length message + have nonempty := body_nonempty child.body + simp only [List.length_map,List.length_cons,List.length_nil] at length + cases rest with + | nil => exact False.elim (nonempty rfl) + | cons head tail => simp only [List.length_cons] at length; omega + | step n rest hn child ih => + cases right with + | seed m hm => + have length := congrArg List.length message + have nonempty := body_nonempty child.body + simp only [List.length_map,List.length_cons,List.length_nil] at length + cases rest with + | nil => exact False.elim (nonempty rfl) + | cons head tail => simp only [List.length_cons] at length; omega + | step m rest' hm child' => + simp only [List.map_cons,List.cons.injEq] at message template + obtain ⟨tails,cv⟩ := ih child' message.2 template.2 + have block := congrArg Prod.snd message.1 + have eq := node_fields_equal cv block (congrArg Prod.fst template.1) + (congrArg Prod.snd template.1) + subst m + subst rest' + exact ⟨rfl,rfl⟩ + + theorem complete_key_unique {c : Compression} {n m : Node} {ns ms : List Node} + (left : Complete (n::ns)) (right : Complete (m::ms)) + (leftTree : Tree c n.cv ns) (rightTree : Tree c m.cv ms) + (key : extract (n::ns)=extract (m::ms)) : n=m ∧ ns=ms := by + have leftParsed := (complete?_correct _).mpr left + have rightParsed := (complete?_correct _).mpr right + simp only [extract,leftParsed,rightParsed,↓reduceIte,Option.some.injEq] at key + have message := congrArg Extracted.message key + have template := congrArg Extracted.template key + simp only [List.map_cons,List.cons.injEq] at message template + obtain ⟨tails,cv⟩ := tree_key_unique leftTree rightTree message.2 template.2 + exact ⟨node_fields_equal cv (congrArg Prod.snd message.1) + (congrArg Prod.fst template.1) (congrArg Prod.snd template.1),tails⟩ + +#print axioms tree_key_unique +#print axioms complete_key_unique +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingLabels.lean b/verification/whir/Whir/PublicCompressionCouplingLabels.lean new file mode 100644 index 000000000..2c76cbb72 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingLabels.lean @@ -0,0 +1,48 @@ +import Whir.PublicCompressionCouplingTerminalUnique +import Whir.WHIRRealSimulator + +/-! A raw terminal coordinate has a deterministic full primitive-node label +from its actual seed body. This preserves chosen root CVs and all raw fields. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed + +/-- Terminal-first raw evaluation's first full primitive input. Malformed raw +names are totalized, but no protocol recognition rule is changed. -/ +def terminalLabel {Q : Nat} (seedTable : Seed) (key : RawKey Q) : Node := + match (expandKey key).message,(expandKey key).template with + | (leaf,block)::message,(tweak,last)::template => + ⟨leaf.getD (WHIRRealSimulator.evalRaw seedTable message template),block,tweak,last⟩ + | _,_ => ⟨zeroDigest,(fun _ => 0),0,false⟩ + +def coordinateLabel {Q : Nat} (seedTable : Seed) : Key Q → Node + | .inl node => node + | .inr key => terminalLabel seedTable key + + theorem terminalNode_cv (cv : Digest32) (terminal : Terminal) : + (terminalNode cv terminal).cv = cv := by + cases terminal <;> rfl + + theorem terminalLabel_witness {Q : Nat} {seedTable : Seed} {input : Node} {key : RawKey Q} + (witness : CoordinateWitness Q seedTable input (.inr key)) : + terminalLabel seedTable key = input := by + cases witness with + | terminal key rest complete tree extracted => + have parsed := (complete?_correct _).mpr complete + have terminal : isTerminal input := by + simp only [complete?,Bool.and_eq_true,decide_eq_true_eq] at parsed + exact parsed.1 + have nonseed := terminal_not_seed terminal + have fields : expandKey key = + ⟨(input::rest).map payload,(input::rest).map (fun n => (n.tweak,n.last))⟩ := by + simpa only [extract,(complete?_correct _).mpr complete,↓reduceIte,Option.some.injEq] using extracted.symm + simp only [terminalLabel,fields,List.map_cons,payload,nonseed,↓reduceIte, + Option.getD_none,WHIRRealSimulator.evalRaw_tree seedTable tree] + + theorem terminalLabel_same_key {Q : Nat} {seedTable : Seed} {a b : Node} {key : RawKey Q} + (left : CoordinateWitness Q seedTable a (.inr key)) + (right : CoordinateWitness Q seedTable b (.inr key)) : a=b := + (terminalLabel_witness left).symm.trans (terminalLabel_witness right) + +#print axioms terminalLabel_witness +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingLateRecognition.lean b/verification/whir/Whir/PublicCompressionCouplingLateRecognition.lean new file mode 100644 index 000000000..0c2a2c52b --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingLateRecognition.lean @@ -0,0 +1,579 @@ +import Whir.PublicCompressionCouplingCache +import Whir.PublicCompressionCouplingPublicTrace +import Whir.PublicCompressionCouplingIdealLateLinks +import Whir.PublicCompressionCouplingTargetCache + +/-! Actual public-phase preservation of missed terminal recognition. The +computed late alarm concerns public Seed queries, not hidden causal reads. +Recognized RO terminals are never body nodes and are erased structurally. -/ +namespace Whir.PublicCompressionCouplingLateRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open TypedFiatShamirGame RawOracleCoupling DuplexPublicSimulator +open PublicCompressionCouplingRecognition PublicCompressionCouplingMixed + +section Generic +variable {K R S : Type} [DecidableEq K] + + theorem alarm_pad (inputCV : K → Option Digest32) (table : K → Digest32) + {n m : Nat} (h : n ≤ m) (p : Sampling K (fun _ => Digest32) R n) + (cache : K → Option Digest32) (history : List Digest32) : + PublicCompressionCouplingIdealLateLinks.alarm inputCV table (Sampling.pad h p) cache history = + PublicCompressionCouplingIdealLateLinks.alarm inputCV table p cache history := by + induction p generalizing m cache history with + | ret r => simp only [Sampling.pad,PublicCompressionCouplingIdealLateLinks.alarm] + | @draw n key next ih => + cases m with + | zero => omega + | succ m => + simp only [Sampling.pad,PublicCompressionCouplingIdealLateLinks.alarm] + cases hit : cache key with + | some answer => exact ih answer (m:=m) (by omega) cache _ + | none => + exact congrArg (decide (table key ∈ history.toFinset) || ·) + (ih (table key) (m:=m) (by omega) (put cache key (table key)) _) + + theorem alarm_map {Q : Nat} [DecidableEq (Key Q)] + (inputCV : Key Q → Option Digest32) (table : Key Q → Digest32) + {n : Nat} (f : R → S) (p : Computation Q R n) + (cache : Key Q → Option Digest32) (history : List Digest32) : + PublicCompressionCouplingIdealLateLinks.alarm inputCV table + (PublicCompressionCouplingMixed.Computation.map f p) cache history = + PublicCompressionCouplingIdealLateLinks.alarm inputCV table p cache history := by + induction p generalizing cache history with + | ret r => rfl + | draw key next ih => + simp only [PublicCompressionCouplingMixed.Computation.map,PublicCompressionCouplingIdealLateLinks.alarm] + cases hit : cache key with + | some answer => exact ih answer cache _ + | none => + exact congrArg (decide (table key ∈ history.toFinset) || ·) + (ih (table key) (put cache key (table key)) _) + + theorem memo_pad (table : K → Digest32) {n m : Nat} (h : n ≤ m) + (p : Sampling K (fun _ => Digest32) R n) (cache : K → Option Digest32) : + Sampling.eval table (memo (Sampling.pad h p) cache) = Sampling.eval table (memo p cache) := by + induction p generalizing m cache with + | ret r => simp only [Sampling.pad,memo,Sampling.eval] + | @draw n key next ih => + cases m with + | zero => omega + | succ m => + simp only [Sampling.pad,memo] + cases hit : cache key with + | some answer => simp only [Sampling.eval_pad]; exact ih answer (m:=m) (by omega) cache + | none => simp only [Sampling.eval]; exact ih (table key) (m:=m) (by omega) _ + + theorem memo_map_cache {Q : Nat} [DecidableEq (Key Q)] (table : Key Q → Digest32) + {n : Nat} (f : R → S) (p : Computation Q R n) (cache : Key Q → Option Digest32) : + (Sampling.eval table (memo (PublicCompressionCouplingMixed.Computation.map f p) cache)).2 = + (Sampling.eval table (memo p cache)).2 := by + induction p generalizing cache with + | ret r => rfl + | draw key next ih => + simp only [PublicCompressionCouplingMixed.Computation.map,memo] + cases hit : cache key with + | some answer => simp only [Sampling.eval_pad]; exact ih answer cache + | none => simp only [Sampling.eval]; exact ih (table key) _ + + theorem memo_bind (table : K → Digest32) {n m : Nat} + (p : Sampling K (fun _ => Digest32) R n) (f : R → Sampling K (fun _ => Digest32) S m) + (cache : K → Option Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) : + Sampling.eval table (memo (Sampling.bind p f) cache) = + Sampling.eval table (memo (f (Sampling.eval table p)) (Sampling.eval table (memo p cache)).2) := by + induction p generalizing cache with + | ret r => simp only [Sampling.bind,memo_pad,memo,Sampling.eval] + | draw key next ih => + simp only [Sampling.bind,memo_pad,memo,Sampling.eval] + cases hit : cache key with + | some answer => + simp only [Sampling.eval_pad] + rw [consistent key answer hit] + exact ih answer cache consistent + | none => + simp only [Sampling.eval] + exact ih (table key) (put cache key (table key)) + (PublicCompressionCouplingTargetCache.put_consistent table cache consistent key) + + def historyTrace (inputCV : K → Option Digest32) (history : List Digest32) + (trace : List (Sigma (fun _ : K => Digest32))) : List Digest32 := + trace.foldl (fun prior entry => PublicCompressionCouplingIdealLateLinks.advance inputCV entry.1 prior) history + + theorem alarm_bind (inputCV : K → Option Digest32) (table : K → Digest32) {n m : Nat} + (p : Sampling K (fun _ => Digest32) R n) (f : R → Sampling K (fun _ => Digest32) S m) + (cache : K → Option Digest32) (history : List Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) : + PublicCompressionCouplingIdealLateLinks.alarm inputCV table (Sampling.bind p f) cache history = + (PublicCompressionCouplingIdealLateLinks.alarm inputCV table p cache history || + PublicCompressionCouplingIdealLateLinks.alarm inputCV table (f (Sampling.eval table p)) + (Sampling.eval table (memo p cache)).2 + (historyTrace inputCV history (Sampling.execute table p).2)) := by + induction p generalizing cache history with + | ret r => simp only [Sampling.bind,alarm_pad,PublicCompressionCouplingIdealLateLinks.alarm,memo, + Sampling.eval,Sampling.execute, + historyTrace,List.foldl_nil,Bool.false_or] + | draw key next ih => + simp only [Sampling.bind,alarm_pad,PublicCompressionCouplingIdealLateLinks.alarm,memo, + Sampling.eval,Sampling.execute, + historyTrace,List.foldl_cons] + cases hit : cache key with + | some answer => + simp only [Sampling.eval_pad] + rw [consistent key answer hit] + exact ih answer cache _ consistent + | none => + simp only [Sampling.eval] + rw [ih (table key) (put cache key (table key)) _ + (PublicCompressionCouplingTargetCache.put_consistent table cache consistent key)] + exact (Bool.or_assoc _ _ _).symm +end Generic + +/-- Only nonterminal previous inputs can be chaining positions of a body. +Earlier recognized RO terminals need not be included in the late history. -/ +theorem erase_nonlate_nonterminal {log : PublicLog} {input : Node} {answer cv : Digest32} + {ns : List Node} (tree : PublicBody (observe log input answer) cv ns) + (avoid : ∀ n d, (n,d)∈log → ¬isTerminal n → answer≠n.cv) + (root : answer≠cv) : PublicBody log cv ns := by + induction tree with + | seed member seed => + rcases List.mem_cons.mp member with equal | old + · exact False.elim (root (congrArg Prod.snd equal).symm) + · exact PublicBody.seed old seed + | @step n d rest member internal child ih => + rcases List.mem_cons.mp member with equal | old + · exact False.elim (root (congrArg Prod.snd equal).symm) + · exact PublicBody.step old internal (ih (avoid n d old (fun terminal => terminal_not_internal terminal internal))) + + theorem recognized_none_after_nonlate_nonterminal {log : PublicLog} {input target : Node} + {answer : Digest32} (functional : Functional log) (clean : ¬OutputCollision log) + (incomplete : recognized log target=none) + (avoid : ∀ n d, (n,d)∈log → ¬isTerminal n → answer≠n.cv) (root : answer≠target.cv) : + recognized (observe log input answer) target=none := by + cases found : recognized (observe log input answer) target with + | none => rfl + | some ns => + obtain ⟨rest,rfl,body⟩ := recognized_publicBody found + have old := erase_nonlate_nonterminal body avoid root + have terminal := (recognized_sound found).1 + obtain ⟨t,tail,equal,ht,hb⟩ := terminal + have head : t=target := by simpa using (congrArg List.head? equal).symm + subst t + have prior := recognized_complete functional clean ht old + rw [incomplete] at prior + cases prior + + theorem recognized_none_after_terminal {log : PublicLog} {input target : Node} {answer : Digest32} + (functional : Functional log) (clean : ¬OutputCollision log) (terminal : isTerminal input) + (incomplete : recognized log target=none) : recognized (observe log input answer) target=none := by + cases found : recognized (observe log input answer) target with + | none => rfl + | some ns => + obtain ⟨rest,rfl,body⟩ := recognized_publicBody found + have old := PublicBody.erase_terminal terminal body + obtain ⟨t,tail,equal,ht,hb⟩ := (recognized_sound found).1 + have head : t=target := by simpa using (congrArg List.head? equal).symm + subst t + have prior := recognized_complete functional clean ht old + rw [incomplete] at prior + cases prior + + theorem recognized_none_after_repeat {log : PublicLog} {input target : Node} {answer : Digest32} + (functional : Functional log) (clean : ¬OutputCollision log) (old : (input,answer)∈log) + (incomplete : recognized log target=none) : recognized (observe log input answer) target=none := by + cases found : recognized (observe log input answer) target with + | none => rfl + | some ns => + obtain ⟨rest,rfl,body⟩ := recognized_publicBody found + have priorBody := PublicBody.erase_repeat old body + obtain ⟨t,tail,equal,ht,hb⟩ := (recognized_sound found).1 + have head : t=target := by simpa using (congrArg List.head? equal).symm + subst t + have prior := recognized_complete functional clean ht priorBody + rw [incomplete] at prior + cases prior + + theorem privateKey_none_recognized_none {Q : Nat} {log : PublicLog} {input : Node} + (fresh : lookup log input=none) (missing : privateKey Q log input=none) + (budget : log.length+1≤Q) : recognized log input=none := by + cases found : recognized log input with + | none => rfl + | some nodes => + obtain ⟨key,hit,extracted⟩ := privateKey_of_recognized fresh found budget + rw [missing] at hit + cases hit + +def SeedRecorded {Q : Nat} (cache : Key Q → Option Digest32) (log : PublicLog) : Prop := + ∀ input answer, cache (.inl input)=some answer → (input,answer)∈log + +def InlCVTracked {Q : Nat} (cache : Key Q → Option Digest32) (history : List Digest32) : Prop := + ∀ input answer, cache (.inl input)=some answer → input.cv∈history.toFinset + +def NonterminalCVTracked (log : PublicLog) (history : List Digest32) : Prop := + ∀ input answer, (input,answer)∈log → ¬isTerminal input → input.cv∈history.toFinset + +def StableFallbacks {Q : Nat} (cache : Key Q → Option Digest32) (log : PublicLog) : Prop := + ∀ input answer, cache (.inl input)=some answer → isTerminal input → recognized log input=none + +open Classical in +theorem put_hit {K : Type} [DecidableEq K] (cache : K → Option Digest32) (key : K) (answer : Digest32) + (hit : cache key=some answer) : put cache key answer=cache := by + funext j + by_cases same : j=key + · subst j; simp only [put_self,hit] + · exact put_other _ _ _ _ same + +theorem seed_cache_fresh {Q : Nat} (cache : Key Q → Option Digest32) (log : PublicLog) + (recorded : SeedRecorded cache log) (input : Node) (fresh : lookup log input=none) : + cache (.inl input)=none := by + cases hit : cache (.inl input) with + | none => rfl + | some answer => + obtain ⟨value,stored⟩ := lookup_exists (recorded input answer hit) + rw [fresh] at stored + cases stored + +theorem history_insert {cv : Digest32} {history : List Digest32} {value : Digest32} + (member : value∈history.toFinset) : value∈(cv::history).toFinset := by + simp only [List.mem_toFinset] at member ⊢ + exact List.mem_cons_of_mem _ member + +theorem privateKey_terminal {Q : Nat} {log : PublicLog} {input : Node} {key : RawKey Q} + (found : privateKey Q log input=some key) : isTerminal input := by + obtain ⟨nodes,recognized,complete,extracted⟩ := privateKey_sound found + by_contra notTerminal + simp [DuplexPublicSimulator.recognized,notTerminal] at recognized + +open Classical in +theorem inl_put_inr {Q : Nat} (cache : Key Q → Option Digest32) (key : RawKey Q) + (value : Digest32) (input : Node) : + (put cache (.inr key) value) (.inl input)=cache (.inl input) := by + simp [put] + +open Classical in +theorem inr_preserves {Q : Nat} (cache : Key Q → Option Digest32) (log : PublicLog) + (history : List Digest32) (key : RawKey Q) (value : Digest32) + (recorded : SeedRecorded cache log) (tracked : InlCVTracked cache history) + (stable : StableFallbacks cache log) : + SeedRecorded (put cache (.inr key) value) log ∧ + InlCVTracked (put cache (.inr key) value) history ∧ + StableFallbacks (put cache (.inr key) value) log := by + constructor + · intro input answer stored + exact recorded input answer (by simpa only [inl_put_inr] using stored) + constructor + · intro input answer stored + exact tracked input answer (by simpa only [inl_put_inr] using stored) + · intro input answer stored terminal + exact stable input answer (by simpa only [inl_put_inr] using stored) terminal + +theorem repeat_preserves {Q : Nat} (cache : Key Q → Option Digest32) (log : PublicLog) + (history : List Digest32) (input : Node) (answer : Digest32) + (functional : Functional log) (clean : ¬OutputCollision log) (old : (input,answer)∈log) + (recorded : SeedRecorded cache log) (tracked : NonterminalCVTracked log history) + (stable : StableFallbacks cache log) : + SeedRecorded cache (observe log input answer) ∧ + NonterminalCVTracked (observe log input answer) history ∧ + StableFallbacks cache (observe log input answer) := by + constructor + · intro node digest stored + exact List.mem_cons_of_mem _ (recorded node digest stored) + constructor + · intro node digest member nonterminal + rcases List.mem_cons.mp member with equal | prior + · cases equal; exact tracked input answer old nonterminal + · exact tracked node digest prior nonterminal + · intro node digest stored terminal + exact recognized_none_after_repeat functional clean old (stable node digest stored terminal) + +theorem terminal_preserves {Q : Nat} (cache : Key Q → Option Digest32) (log : PublicLog) + (history : List Digest32) (input : Node) (answer : Digest32) + (functional : Functional log) (clean : ¬OutputCollision log) (terminal : isTerminal input) + (recorded : SeedRecorded cache log) (tracked : NonterminalCVTracked log history) + (stable : StableFallbacks cache log) : + SeedRecorded cache (observe log input answer) ∧ + NonterminalCVTracked (observe log input answer) history ∧ + StableFallbacks cache (observe log input answer) := by + constructor + · intro node digest stored + exact List.mem_cons_of_mem _ (recorded node digest stored) + constructor + · intro node digest member nonterminal + rcases List.mem_cons.mp member with equal | prior + · cases equal; exact False.elim (nonterminal terminal) + · exact tracked node digest prior nonterminal + · intro node digest stored nodeTerminal + exact recognized_none_after_terminal functional clean terminal (stable node digest stored nodeTerminal) + +open Classical in +theorem fallback_preserves {Q : Nat} (cache : Key Q → Option Digest32) (log : PublicLog) + (history : List Digest32) (input : Node) (answer : Digest32) + (functional : Functional log) (clean : ¬OutputCollision log) + (incomplete : recognized log input=none) (avoid : answer∉history.toFinset) + (recorded : SeedRecorded cache log) (tracked : InlCVTracked cache history) + (nonterminalTracked : NonterminalCVTracked log history) (stable : StableFallbacks cache log) : + SeedRecorded (put cache (.inl input) answer) (observe log input answer) ∧ + InlCVTracked (put cache (.inl input) answer) (input.cv::history) ∧ + NonterminalCVTracked (observe log input answer) (input.cv::history) ∧ + StableFallbacks (put cache (.inl input) answer) (observe log input answer) := by + constructor + · intro node digest stored + by_cases same : node=input + · subst node + simp only [put_self,Option.some.injEq] at stored + subst digest + exact List.mem_cons.mpr (Or.inl rfl) + · have keys : (Sum.inl node : Key Q)≠.inl input := by intro equal; exact same (Sum.inl.inj equal) + exact List.mem_cons_of_mem _ (recorded node digest (by simpa only [put_other _ _ _ _ keys] using stored)) + constructor + · intro node digest stored + by_cases same : node=input + · subst node; simp + · have keys : (Sum.inl node : Key Q)≠.inl input := by intro equal; exact same (Sum.inl.inj equal) + exact history_insert (tracked node digest (by simpa only [put_other _ _ _ _ keys] using stored)) + constructor + · intro node digest member nonterminal + rcases List.mem_cons.mp member with equal | prior + · cases equal; simp + · exact history_insert (nonterminalTracked node digest prior nonterminal) + · intro node digest stored terminal + by_cases inputTerminal : isTerminal input + · apply recognized_none_after_terminal functional clean inputTerminal + by_cases same : node=input + · subst node; exact incomplete + · have keys : (Sum.inl node : Key Q)≠.inl input := by intro equal; exact same (Sum.inl.inj equal) + exact stable node digest (by simpa only [put_other _ _ _ _ keys] using stored) terminal + · have same : node≠input := by intro equal; exact inputTerminal (equal ▸ terminal) + have keys : (Sum.inl node : Key Q)≠.inl input := by intro equal; exact same (Sum.inl.inj equal) + have old : cache (.inl node)=some digest := by simpa only [put_other _ _ _ _ keys] using stored + apply recognized_none_after_nonlate_nonterminal functional clean (stable node digest old terminal) + · intro prior value member nonterminal equal + exact avoid (equal ▸ nonterminalTracked prior value member nonterminal) + · intro equal + exact avoid (equal ▸ tracked node digest old) + +open Classical in +theorem memo_singleton {K R : Type} [DecidableEq K] (table : K → Digest32) (key : K) (payload : Digest32 → R) + (cache : K → Option Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) : + Sampling.eval table (memo (.draw key (fun d => .ret (n:=0) (payload d))) cache) = + (payload (table key),put cache key (table key)) := by + cases hit : cache key with + | some answer => + simp only [memo,hit,Sampling.eval_pad,Sampling.eval] + rw [consistent key answer hit,put_hit cache key answer hit] + | none => simp only [memo,hit,Sampling.eval] + +open Classical in +theorem primitive_preserves (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (cache : Key Q → Option Digest32) (log : PublicLog) (history : List Digest32) (input : Node) + (consistent : ∀ key answer, cache key=some answer → oracle seedTable ro key=answer) + (functional : Functional log) (clean : ¬OutputCollision log) (budget : log.length+1≤Q) + (recorded : SeedRecorded cache log) (tracked : InlCVTracked cache history) + (nonterminalTracked : NonterminalCVTracked log history) (stable : StableFallbacks cache log) + (quiet : PublicCompressionCouplingIdealLateLinks.alarm PublicCompressionCouplingIdealLateLinks.mixedCV + (oracle seedTable ro) (primitiveCalls Q log input) cache history=false) : + let result := Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input) + let finalCache := (Sampling.eval (oracle seedTable ro) (memo (primitiveCalls Q log input) cache)).2 + let finalHistory := historyTrace PublicCompressionCouplingIdealLateLinks.mixedCV history + (Sampling.execute (oracle seedTable ro) (primitiveCalls Q log input)).2 + SeedRecorded finalCache result.1 ∧ InlCVTracked finalCache finalHistory ∧ + NonterminalCVTracked result.1 finalHistory ∧ StableFallbacks finalCache result.1 := by + cases hit : lookup log input with + | some answer => + simp only [primitiveCalls,hit,Sampling.eval,memo,Sampling.execute,historyTrace,List.foldl_nil] + have preserved := repeat_preserves cache log history input answer functional clean (lookup_mem hit) + recorded nonterminalTracked stable + exact ⟨preserved.1,tracked,preserved.2.1,preserved.2.2⟩ + | none => + cases found : privateKey Q log input with + | some key => + have terminal := privateKey_terminal found + have changed := inr_preserves cache log history key (ro key) recorded tracked stable + have preserved := terminal_preserves (put cache (.inr key) (ro key)) log history input (ro key) + functional clean terminal changed.1 nonterminalTracked changed.2.2 + simpa only [primitiveCalls,hit,found,Sampling.eval,memo_singleton _ _ _ _ consistent, + Sampling.execute,oracle,historyTrace,List.foldl_cons,List.foldl_nil, + PublicCompressionCouplingIdealLateLinks.advance,PublicCompressionCouplingIdealLateLinks.mixedCV] + using (show SeedRecorded (put cache (.inr key) (ro key)) (observe log input (ro key)) ∧ + InlCVTracked (put cache (.inr key) (ro key)) history ∧ + NonterminalCVTracked (observe log input (ro key)) history ∧ + StableFallbacks (put cache (.inr key) (ro key)) (observe log input (ro key)) from + ⟨preserved.1,changed.2.1,preserved.2.1,preserved.2.2⟩) + | none => + have fresh := seed_cache_fresh cache log recorded input hit + simp only [primitiveCalls,hit,found,PublicCompressionCouplingIdealLateLinks.alarm,fresh, + PublicCompressionCouplingIdealLateLinks.alarm,oracle,Bool.or_false] at quiet + have avoid := of_decide_eq_false quiet + have incomplete := privateKey_none_recognized_none hit found budget + have preserved := fallback_preserves cache log history input (seedTable input) functional clean + incomplete avoid recorded tracked nonterminalTracked stable + simpa only [primitiveCalls,hit,found,Sampling.eval,memo,fresh,Sampling.execute,oracle, + historyTrace,List.foldl_cons,List.foldl_nil,PublicCompressionCouplingIdealLateLinks.advance, + PublicCompressionCouplingIdealLateLinks.mixedCV] using preserved + +open Classical in +theorem alarm_draw_quiet {K R : Type} [DecidableEq K] (inputCV : K → Option Digest32) + (table : K → Digest32) (key : K) {n : Nat} + (next : Digest32 → Sampling K (fun _ => Digest32) R n) (cache : K → Option Digest32) + (history : List Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) + (quiet : PublicCompressionCouplingIdealLateLinks.alarm inputCV table (.draw key next) cache history=false) : + PublicCompressionCouplingIdealLateLinks.alarm inputCV table (next (table key)) + (put cache key (table key)) (PublicCompressionCouplingIdealLateLinks.advance inputCV key history)=false := by + cases hit : cache key with + | some answer => + simp only [PublicCompressionCouplingIdealLateLinks.alarm,hit] at quiet + rw [consistent key answer hit,put_hit cache key answer hit] + exact quiet + | none => + simp only [PublicCompressionCouplingIdealLateLinks.alarm,hit,Bool.or_eq_false_iff] at quiet + exact quiet.2 + +open Classical in +theorem memo_draw {K R : Type} [DecidableEq K] (table : K → Digest32) (key : K) {n : Nat} + (next : Digest32 → Sampling K (fun _ => Digest32) R n) (cache : K → Option Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) : + Sampling.eval table (memo (.draw key next) cache) = + Sampling.eval table (memo (next (table key)) (put cache key (table key))) := by + cases hit : cache key with + | some answer => + simp only [memo,hit,Sampling.eval_pad] + rw [consistent key answer hit,put_hit cache key answer hit] + | none => simp only [memo,hit,Sampling.eval] + +theorem primitive_functional (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (input : Node) (functional : Functional log) : + Functional (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).1 := by + simpa only [primitiveCalls_actual] using + answer_functional Q ro ({seed:=seedTable,publicLog:=log} : DuplexPublicSimulator.State) input functional + +theorem primitive_result_log (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (input : Node) : + (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).1 = + DuplexPublicSimulator.observe log input + (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).2 := by + simpa only [primitiveCalls_actual] using + answer_publicLog Q ro ({seed:=seedTable,publicLog:=log} : DuplexPublicSimulator.State) input + +theorem primitive_log_length (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (input : Node) : + (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).1.length=log.length+1 := by + rw [primitive_result_log] + simp only [DuplexPublicSimulator.observe,List.length_cons] + +theorem clean_initial_log (log : PublicLog) (observations : List Observation) + (clean : ¬OutputCollision (finalLog log observations)) : ¬OutputCollision log := by + rintro ⟨a,b,d,ha,hb,ne⟩ + exact clean ⟨a,b,d,finalLog_contains log observations _ ha,finalLog_contains log observations _ hb,ne⟩ + +open Classical in +theorem compile_stable {R : Type} (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (p : Program R) : + ∀ (log : PublicLog) (remaining : Nat) (cap : remaining≤Q) (counted : Counts remaining p) + (cache : Key Q → Option Digest32) (history : List Digest32), + (∀ key answer, cache key=some answer → oracle seedTable ro key=answer) → + Functional log → log.length+remaining≤Q → + SeedRecorded cache log → InlCVTracked cache history → NonterminalCVTracked log history → + StableFallbacks cache log → + PublicCompressionCouplingIdealLateLinks.alarm PublicCompressionCouplingIdealLateLinks.mixedCV + (oracle seedTable ro) (compile Q iv log p remaining cap counted) cache history=false → + ¬OutputCollision (finalLog log + (Sampling.eval (oracle seedTable ro) (compile Q iv log p remaining cap counted)).observations) → + StableFallbacks + (Sampling.eval (oracle seedTable ro) (memo (compile Q iv log p remaining cap counted) cache)).2 + (finalLog log (Sampling.eval (oracle seedTable ro) (compile Q iv log p remaining cap counted)).observations) := by + induction p with + | done result => + intro log remaining cap counted cache history consistent functional budget recorded tracked nonterminalTracked stable quiet clean + simpa only [PublicCompressionCouplingMixed.compile,memo,Sampling.eval,finalLog] using stable + | ask query next ih => + intro log remaining cap counted cache history consistent functional budget recorded tracked nonterminalTracked stable quiet clean + have oldClean := clean_initial_log log _ clean + cases query with + | primitive purpose input => + simp only [PublicCompressionCouplingMixed.compile,alarm_pad,alarm_bind _ _ _ _ _ _ consistent,Bool.or_eq_false_iff] at quiet + let stage := primitiveCalls Q log input + let result := Sampling.eval (oracle seedTable ro) stage + let nextCache := (Sampling.eval (oracle seedTable ro) (memo stage cache)).2 + let nextHistory := historyTrace PublicCompressionCouplingIdealLateLinks.mixedCV history + (Sampling.execute (oracle seedTable ro) stage).2 + have stageBudget : log.length+1≤Q := by have hc : 1≤remaining := counted.1; omega + have preserved := primitive_preserves Q seedTable ro cache log history input consistent + functional oldClean stageBudget recorded tracked nonterminalTracked stable quiet.1 + have nextQuiet : PublicCompressionCouplingIdealLateLinks.alarm PublicCompressionCouplingIdealLateLinks.mixedCV + (oracle seedTable ro) + (compile Q iv result.1 (next result.2) (remaining-1) (by omega) (counted.2 _)) + nextCache nextHistory=false := by + simpa only [alarm_map] using quiet.2 + have nextBudget : result.1.length+(remaining-1)≤Q := by + dsimp only [result,stage] + rw [primitive_log_length] + have hc : 1≤remaining := counted.1 + omega + have nextClean : ¬OutputCollision (finalLog result.1 + (Sampling.eval (oracle seedTable ro) + (compile Q iv result.1 (next result.2) (remaining-1) (by omega) (counted.2 _))).observations) := by + simpa only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe,finalLog, + ←primitive_result_log Q seedTable ro log input] using clean + have child := ih result.2 result.1 (remaining-1) (by omega) (counted.2 _) nextCache nextHistory + (memo_eval_consistent stage cache (oracle seedTable ro) consistent) + (primitive_functional Q seedTable ro log input functional) nextBudget + preserved.1 preserved.2.1 preserved.2.2.1 preserved.2.2.2 nextQuiet nextClean + simpa only [PublicCompressionCouplingMixed.compile,memo_pad,memo_bind _ _ _ _ consistent,memo_map_cache, + Sampling.eval_pad,Sampling.eval_bind,PublicCompressionCouplingMixed.Computation.eval_map, + DuplexRawProgram.observe,finalLog,←primitive_result_log Q seedTable ro log input] using child + | construction coordinate valid => + let key := constructionKey Q iv coordinate (counted.1.trans cap) + let nextCache := put cache (.inr key) (ro key) + simp only [PublicCompressionCouplingMixed.compile,alarm_pad] at quiet + have nextQuiet := alarm_draw_quiet PublicCompressionCouplingIdealLateLinks.mixedCV + (oracle seedTable ro) (.inr key) _ cache history consistent quiet + simp only [alarm_map,PublicCompressionCouplingIdealLateLinks.advance, + PublicCompressionCouplingIdealLateLinks.mixedCV,oracle] at nextQuiet + have preserved := inr_preserves cache log history key (ro key) recorded tracked stable + have nextBudget : log.length+(remaining-pathCost coordinate)≤Q := by omega + have nextClean : ¬OutputCollision (finalLog log + (Sampling.eval (oracle seedTable ro) + (compile Q iv log (next (ro key)) (remaining-pathCost coordinate) (by omega) + (counted.2 _))).observations) := by + simpa only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval, + PublicCompressionCouplingMixed.Computation.eval_map,oracle,DuplexRawProgram.observe,finalLog] using clean + have child := ih (ro key) log (remaining-pathCost coordinate) (by omega) (counted.2 _) nextCache history + (PublicCompressionCouplingTargetCache.put_consistent (oracle seedTable ro) cache consistent (.inr key)) + functional nextBudget preserved.1 preserved.2.1 nonterminalTracked preserved.2.2 nextQuiet nextClean + simpa only [PublicCompressionCouplingMixed.compile,memo_pad,memo_draw _ _ _ _ consistent,memo_map_cache, + Sampling.eval_pad,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map, + oracle,DuplexRawProgram.observe,finalLog] using child + +open Classical in +theorem actual_cached_fallback_unrecognized {R : Type} (Q : Nat) (seedTable : Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (p : Program R) (counted : Counts Q p) + (quiet : PublicCompressionCouplingIdealLateLinks.alarm PublicCompressionCouplingIdealLateLinks.mixedCV + (oracle seedTable ro) (compile Q iv [] p Q (by omega) counted) (fun _ => none) []=false) + (clean : ¬OutputCollision (finalLog [] + (Sampling.eval (oracle seedTable ro) (compile Q iv [] p Q (by omega) counted)).observations)) : + ∀ input answer, + (Sampling.eval (oracle seedTable ro) + (memo (compile Q iv [] p Q (by omega) counted) (fun _ => none))).2 (.inl input)=some answer → + isTerminal input → + recognized (finalLog [] + (Sampling.eval (oracle seedTable ro) (compile Q iv [] p Q (by omega) counted)).observations) input=none := by + apply compile_stable Q seedTable ro iv p [] Q (by omega) counted (fun _ => none) [] + · intro key answer impossible; cases impossible + · intro a b d e first; cases first + · simp only [List.length_nil,Nat.zero_add,Nat.le_refl] + · intro input answer impossible; cases impossible + · intro input answer impossible; cases impossible + · intro input answer impossible; cases impossible + · intro input answer impossible; cases impossible + · exact quiet + · exact clean + +#print axioms actual_cached_fallback_unrecognized + +#print axioms primitive_preserves + +#print axioms alarm_bind +#print axioms recognized_none_after_nonlate_nonterminal +end Whir.PublicCompressionCouplingLateRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingMixed.lean b/verification/whir/Whir/PublicCompressionCouplingMixed.lean new file mode 100644 index 000000000..f5021c607 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingMixed.lean @@ -0,0 +1,140 @@ +import Whir.PublicCompressionCoupling +import Whir.DuplexRawProgram + +/-! Exact mixed-oracle lowering of the PINNED stateful public simulator. +Fallback seed coordinates and raw RO coordinates remain independent branches +of one finite oracle. Construction internals are deliberately not computed +in this public phase. This is a checked operational identity, not a DMV premise. -/ +namespace Whir.PublicCompressionCouplingMixed +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open scoped BigOperators + +abbrev Key (Q : Nat) := Sum Node (RawKey Q) +abbrev Computation (Q : Nat) (R : Type) (calls : Nat) := Sampling (Key Q) (fun _ => Digest32) R calls + +namespace Computation +variable {Q calls : Nat} {R S : Type} + +def map (f : R → S) {calls : Nat} : Computation Q R calls → Computation Q S calls + | .ret r => .ret (f r) + | .draw key next => .draw key (fun d => map f (next d)) + +@[simp] theorem eval_map (table : Key Q → Digest32) (f : R → S) (p : Computation Q R calls) : + Sampling.eval table (map f p) = f (Sampling.eval table p) := by + induction p with + | ret => rfl + | draw key next ih => exact ih (table key) +end Computation + +def oracle {Q : Nat} (seed : DuplexPublicSimulator.Seed) (ro : RawKey Q → Digest32) : + Key Q → Digest32 + | .inl input => seed input + | .inr key => ro key + +def tableEquiv (Q : Nat) : (Key Q → Digest32) ≃ + DuplexPublicSimulator.Seed × (RawKey Q → Digest32) where + toFun table := (fun n => table (.inl n),fun key => table (.inr key)) + invFun pair := oracle pair.1 pair.2 + left_inv table := by funext key; cases key <;> rfl + right_inv pair := rfl + +/-- Lookup, recognition, and fallback are exactly those of simulator.answer. +The continuation receives no fallback-table or raw-table access. -/ +def primitiveCalls (Q : Nat) (log : DuplexPublicSimulator.PublicLog) (input : Node) : + Computation Q (DuplexPublicSimulator.PublicLog × Digest32) 1 := + match DuplexPublicSimulator.lookup log input with + | some answer => .ret (DuplexPublicSimulator.observe log input answer,answer) + | none => + match DuplexPublicSimulator.privateKey Q log input with + | some key => .draw (.inr key) (fun answer => + .ret (DuplexPublicSimulator.observe log input answer,answer)) + | none => .draw (.inl input) (fun answer => + .ret (DuplexPublicSimulator.observe log input answer,answer)) + +theorem primitiveCalls_actual (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) (input : Node) : + (runRO ro ((DuplexPublicSimulator.simulator Q).answer ⟨seed,log⟩ input)).1 = + (⟨seed,(Sampling.eval (oracle seed ro) (primitiveCalls Q log input)).1⟩, + (Sampling.eval (oracle seed ro) (primitiveCalls Q log input)).2) := by + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => simp [DuplexPublicSimulator.simulator,primitiveCalls,hit,runRO,Sampling.eval] + | none => + cases key : DuplexPublicSimulator.privateKey Q log input <;> + simp [DuplexPublicSimulator.simulator,primitiveCalls,hit,key,runRO,Sampling.eval,oracle] + +/-- Source Counts charges each complete path, although the ideal public phase +makes one raw lookup for a construction and no hidden-prefix seed lookups. -/ +def compile (Q : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) : + (p : Program R) → (remaining : Nat) → remaining ≤ Q → Counts remaining p → + Computation Q (View R) remaining + | .done result, _, _, _ => .ret ⟨[],result⟩ + | .ask (.primitive purpose input) next, remaining, cap, counted => + Sampling.pad (n := 1+(remaining-1)) (m := remaining) + (by have hc : 1 ≤ remaining := counted.1; omega) + (Sampling.bind (primitiveCalls Q log input) (fun result => + Computation.map (DuplexRawProgram.observe (.primitive purpose input) result.2) + (compile Q iv result.1 (next result.2) (remaining-1) (by omega) (counted.2 _)))) + | .ask (.construction coordinate valid) next, remaining, cap, counted => + Sampling.pad (n := remaining-pathCost coordinate+1) (m := remaining) (by + have hc : pathCost coordinate ≤ remaining := counted.1 + have hp := DuplexRawProgram.pathCost_pos coordinate + omega) + (.draw (.inr (constructionKey Q iv coordinate (counted.1.trans cap))) (fun answer => + Computation.map (DuplexRawProgram.observe (.construction coordinate valid) answer) + (compile Q iv log (next answer) (remaining-pathCost coordinate) (by omega) (counted.2 _)))) + +theorem compile_actual (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (p : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + Sampling.eval (oracle seed ro) (compile Q iv log p remaining cap counted) = + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨seed,log⟩ + p remaining cap counted).view := by + induction p generalizing log remaining with + | done => rfl + | ask query next ih => + cases query with + | primitive purpose input => + simp only [compile,Sampling.eval_pad,Sampling.eval_bind,Computation.eval_map, + runIdeal,prepend] + simp only [primitiveCalls_actual] + have ht := ih (Sampling.eval (oracle seed ro) (primitiveCalls Q log input)).2 + (Sampling.eval (oracle seed ro) (primitiveCalls Q log input)).1 + (remaining-1) (by omega) (counted.2 _) + exact congrArg + (DuplexRawProgram.observe (.primitive purpose input) + (Sampling.eval (oracle seed ro) (primitiveCalls Q log input)).2) ht + | construction coordinate valid => + simp only [compile,Sampling.eval_pad,Sampling.eval,Computation.eval_map, + oracle,runIdeal,prepend] + rw [ih] + rfl + +/-- Every observed query is charged by its source cost, not ideal lookup cost. -/ +def viewCost {R : Type} (view : View R) : Nat := + (view.observations.map (fun observation => observation.query.cost)).sum + +theorem runIdeal_viewCost (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (p : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + viewCost (runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨seed,log⟩ + p remaining cap counted).view ≤ remaining := by + have costEq : ∀ (state : DuplexPublicSimulator.State) (p : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p), + viewCost (runIdeal (DuplexPublicSimulator.simulator Q) ro iv state + p remaining cap counted).view = + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv state + p remaining cap counted).primitiveCost := by + intro state p + induction p generalizing state with + | done => intro remaining cap counted; rfl + | ask query next ih => + intro remaining cap counted + cases query <;> simp [runIdeal,prepend,viewCost] + all_goals exact ih _ _ _ _ _ + rw [costEq] + exact runIdeal_counts _ _ _ _ _ _ _ counted + +#print axioms primitiveCalls_actual +#print axioms compile_actual +#print axioms runIdeal_viewCost +end Whir.PublicCompressionCouplingMixed diff --git a/verification/whir/Whir/PublicCompressionCouplingPrefixTrace.lean b/verification/whir/Whir/PublicCompressionCouplingPrefixTrace.lean new file mode 100644 index 000000000..2b7addf9b --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingPrefixTrace.lean @@ -0,0 +1,125 @@ +import Whir.PublicCompressionCouplingCausal +import Whir.PublicCompressionCouplingPublicTrace + +/-! Every private prefix query in causal and posthoc inspection is a literal +node of the same actual seed-table construction body, including the root CV. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed +open TypedOracleCompiler (Sampling) +set_option backward.isDefEq.respectTransparency false + + theorem bodyCalls_append (Q : Nat) (table : Key Q → Digest32) (cv : Digest32) + (xs ys : List DuplexEncoding.Instruction) : + Sampling.eval table (bodyCalls Q cv (xs++ys)) = + let left := Sampling.eval table (bodyCalls Q cv xs) + let right := Sampling.eval table (bodyCalls Q left.1 ys) + (right.1,left.2++right.2) := by + induction xs generalizing cv with + | nil => rfl + | cons instruction rest ih => + simp only [List.cons_append,bodyCalls,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map] + rw [ih] + + theorem bodyCalls_trace (Q : Nat) (table : Key Q → Digest32) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + (Sampling.execute table (bodyCalls Q cv xs)).2 = + (Sampling.eval table (bodyCalls Q cv xs)).2.map + (fun entry => (⟨.inl entry.1,entry.2⟩ : Sigma (fun _ : Key Q => Digest32))) := by + induction xs generalizing cv with + | nil => rfl + | cons instruction rest ih => + simp only [bodyCalls,Sampling.execute,execute_map_trace,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map, + List.map_cons] + rw [ih] + + theorem bodyCalls_tree {seedTable : Seed} {cv : Digest32} {ns : List Node} + (tree : Tree (compressionOf seedTable) cv ns) (Q : Nat) (iv : Digest32) + (anchored : Anchored iv ns) (ro : RawKey Q → Digest32) : + Sampling.eval (oracle seedTable ro) (bodyCalls Q iv (rawPlan ns)) = + (cv,ns.reverse.map (fun n => (n,seedTable n))) := by + induction tree with + | seed node valid => + have root := anchored node (by simp) valid + have fields : (⟨iv,node.block,node.tweak,true⟩ : Node) = node := + node_fields_equal root.symm rfl rfl valid.2.symm + have planEq : rawPlan [node] = [(node.block,node.tweak)] := by simp [rawPlan] + rw [planEq] + simp only [bodyCalls,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map, + oracle,fields,nodeValue,compressionOf,List.reverse_singleton,List.map_cons,List.map_nil] + | step node rest valid child ih => + have inherited : Anchored iv rest := fun n member seed => + anchored n (List.mem_cons_of_mem _ member) seed + have bodyEvaluation := ih inherited + have fields : (⟨node.cv,node.block,node.tweak,true⟩ : Node) = node := + node_fields_equal rfl rfl rfl valid.2.symm + have planEq : rawPlan (node::rest) = rawPlan rest ++ [(node.block,node.tweak)] := by + simp [rawPlan] + rw [planEq,bodyCalls_append,bodyEvaluation] + simp only [bodyCalls,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map,oracle, + fields,nodeValue,compressionOf,List.reverse_cons,List.map_append,List.map_cons,List.map_nil] + + theorem coordinate_body_plan (c : Compression) (iv : Digest32) (coordinate : Coordinate) : + rawPlan (traceHistory c iv coordinate.history).nodes = + (DuplexEncoding.plan coordinate).dropLast := by + have plan := congrArg List.dropLast (coordinateTree_plan c iv coordinate) + simpa only [coordinateTree,rawPlan,List.reverse_cons,List.map_append,List.map_cons, + List.map_nil,List.dropLast_concat] using plan + + theorem inspection_body_nodes (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) : + (Sampling.eval (oracle seedTable ro) + (bodyCalls Q iv (DuplexEncoding.plan coordinate).dropLast)).2 = + (traceHistory (compressionOf seedTable) iv coordinate.history).nodes.reverse.map + (fun n => (n,seedTable n)) := by + rw [← coordinate_body_plan (compressionOf seedTable) iv coordinate] + have anchored : Anchored iv (traceHistory (compressionOf seedTable) iv coordinate.history).nodes := + traceHistory_anchored (compressionOf seedTable) iv coordinate.history valid.1 + exact congrArg Prod.snd + (bodyCalls_tree (traceHistory_valid (compressionOf seedTable) iv coordinate.history valid.1).1 + Q iv anchored ro) + + theorem inspect_prefix_record (Q : Nat) (iv : Digest32) (table : Key Q → Digest32) + (observations : List Observation) {construction : InspectedConstruction} + (member : construction ∈ Sampling.eval table (inspect Q iv observations)) + {node : Node} {answer : Digest32} (record : (node,answer) ∈ construction.prefixLog) : + (⟨.inl node,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute table (inspect Q iv observations)).2 := by + induction observations with + | nil => simp [inspect,Sampling.eval] at member + | cons observation rest ih => + rcases observation with ⟨query,digest⟩ + cases query with + | primitive purpose input => exact ih member + | construction coordinate valid => + simp only [inspect,Sampling.eval_bind,PublicCompressionCouplingMixed.Computation.eval_map,List.mem_cons] at member + simp only [inspect,Sampling.execute_bind,execute_map_trace,List.mem_append] + rcases member with equal | later + · subst construction + apply Or.inl + rw [bodyCalls_trace] + exact List.mem_map.mpr ⟨(node,answer),record,rfl⟩ + · exact Or.inr (ih later) + + theorem inspect_construction_nodes (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (observations : List Observation) {construction : InspectedConstruction} + (member : construction ∈ Sampling.eval (oracle seedTable ro) (inspect Q iv observations)) : + construction.prefixLog = + (traceHistory (compressionOf seedTable) iv construction.coordinate.history).nodes.reverse.map + (fun n => (n,seedTable n)) := by + induction observations with + | nil => simp [inspect,Sampling.eval] at member + | cons observation rest ih => + rcases observation with ⟨query,digest⟩ + cases query with + | primitive purpose input => exact ih member + | construction coordinate valid => + simp only [inspect,Sampling.eval_bind,PublicCompressionCouplingMixed.Computation.eval_map,List.mem_cons] at member + rcases member with equal | later + · subst construction + exact inspection_body_nodes Q seedTable ro iv coordinate valid + · exact ih later + +#print axioms bodyCalls_tree +#print axioms inspection_body_nodes +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingPrimitiveStream.lean b/verification/whir/Whir/PublicCompressionCouplingPrimitiveStream.lean new file mode 100644 index 000000000..a28434c4c --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingPrimitiveStream.lean @@ -0,0 +1,151 @@ +import Whir.PublicCompressionCouplingLabels +import Whir.PublicCompressionCouplingRelabelCache + +/-! Actual one-query fresh-stream alignment. Public cached returns need no +mixed draw; recognized terminals retain their full raw-coordinate node label. +The cache and log premises are operational source-induction invariants. -/ +namespace Whir.PublicCompressionCouplingPrimitiveStream +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open TypedFiatShamirGame +open TypedOracleCompiler (Sampling) +open PublicCompressionCouplingMixed PublicCompressionCouplingJoint +open PublicCompressionCouplingStreams PublicCompressionCouplingRelabelCache +open PublicCompressionCouplingRecognition +set_option backward.isDefEq.respectTransparency false + +/-- Every public record is already stored in the actual real primitive cache. -/ +def LogCovered (pc : PublicCompressionCouplingJoint.Cache Node) (log : PublicLog) : Prop := + ∀ node answer, (node,answer) ∈ log → pc node=some answer + +/-- A single consumed coordinate uses exactly the same fresh digest cell on +both sides. Coordinate-label injectivity is required only on consumed cells. -/ +theorem matched_draw {A B : Type} [DecidableEq A] [DecidableEq B] + (label : B → A) (key : B) (pc : PublicCompressionCouplingJoint.Cache A) + (qc final : PublicCompressionCouplingJoint.Cache B) (stream : List Digest32) + (answer : Digest32) (updated : PublicCompressionCouplingJoint.Cache B) (remaining : List Digest32) + (execution : run (.draw key (fun d => .ret (n:=0) d)) qc stream=some (answer,updated,remaining)) + (related : Related label pc qc) (extension : Extends updated final) + (injective : InjectiveOn label final) : + ∃ pc', run (.draw (label key) (fun d => .ret (n:=0) d)) pc stream=some (answer,pc',remaining) ∧ + Related label pc' updated ∧ pc' (label key)=some answer ∧ Extends updated final := by + have initialExtension : Extends qc final := by + intro k d stored + exact extension k d (run_extends _ qc stream execution stored) + cases hit : qc key with + | some digest => + rw [run_hit hit] at execution + simp only [run,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨answerEq,cacheEq,streamEq⟩ := execution + subst answer + subst updated + subst remaining + have realHit := related.forward key digest hit + exact ⟨pc,by rw [run_hit realHit]; rfl,related,realHit,extension⟩ + | none => + cases stream with + | nil => rw [run_miss_nil hit] at execution; cases execution + | cons digest rest => + rw [run_miss_cons hit] at execution + simp only [run,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨answerEq,cacheEq,streamEq⟩ := execution + subst answer + subst updated + subst remaining + have present : final key=some digest := extension key digest (put_self _ _ _) + have realHit : pc (label key)=none := by + rw [related.lookup initialExtension injective present,hit] + exact ⟨put pc (label key) digest,by rw [run_miss_cons realHit]; rfl, + related.put initialExtension injective present,put_self _ _ _,extension⟩ + +open Classical in +private theorem draw_alignment (Q : Nat) (seedTable : Seed) (iv : Digest32) + (purpose : Purpose) (input : Node) (log : PublicLog) (key : Key Q) + (pc : PublicCompressionCouplingJoint.Cache Node) (qc final : PublicCompressionCouplingJoint.Cache (Key Q)) + (stream : List Digest32) (nextLog : PublicLog) (answer : Digest32) + (updated : PublicCompressionCouplingJoint.Cache (Key Q)) (remaining : List Digest32) + (label : coordinateLabel seedTable key=input) + (execution : run (.draw key (fun d => .ret (n:=0) (observe log input d,d))) qc stream= + some ((nextLog,answer),updated,remaining)) + (related : Related (coordinateLabel seedTable) pc qc) + (extension : Extends updated final) (injective : InjectiveOn (coordinateLabel seedTable) final) : + ∃ pc', run (PublicCompressionProgram.queryCalls iv (.primitive purpose input)) pc stream= + some (answer,pc',remaining) ∧ Related (coordinateLabel seedTable) pc' updated ∧ + pc' input=some answer ∧ Extends updated final ∧ nextLog=observe log input answer := by + let q : PublicCompressionCouplingMixed.Computation Q Digest32 1 := + .draw key (fun d => .ret d) + let payload := fun d => (DuplexPublicSimulator.observe log input d,d) + have mapped : (run q qc stream).map (fun result => (payload result.1,result.2.1,result.2.2)) = + some ((nextLog,answer),updated,remaining) := by + exact (run_mixed_map payload q qc stream).symm.trans + (by simpa only [q,payload,PublicCompressionCouplingMixed.Computation.map] using execution) + have recovered : run q qc stream=some (answer,updated,remaining) ∧ + nextLog=DuplexPublicSimulator.observe log input answer := by + cases result : run q qc stream with + | none => simp only [result,Option.map_none] at mapped; cases mapped + | some triple => + rcases triple with ⟨digest,cache,rest⟩ + simp only [result,Option.map_some,Option.some.injEq,Prod.mk.injEq,payload] at mapped + obtain ⟨⟨logEq,answerEq⟩,cacheEq,streamEq⟩ := mapped + exact ⟨by simp only [answerEq,cacheEq,streamEq], + logEq.symm.trans (congrArg (DuplexPublicSimulator.observe log input) answerEq)⟩ + obtain ⟨pc',realRun,newRelated,stored,newExtension⟩ := + matched_draw (coordinateLabel seedTable) key pc qc final stream answer updated remaining + recovered.1 related extension injective + exact ⟨pc',by simpa only [PublicCompressionProgram.queryCalls,label] using realRun, + newRelated,by simpa only [label] using stored,newExtension,recovered.2⟩ + +open Classical in +theorem actual_primitive_stream_alignment (Q : Nat) (seedTable : Seed) (iv : Digest32) + (purpose : Purpose) (input : Node) (log : PublicLog) + (pc : PublicCompressionCouplingJoint.Cache Node) (qc final : PublicCompressionCouplingJoint.Cache (Key Q)) + (stream : List Digest32) (nextLog : PublicLog) (answer : Digest32) + (updated : PublicCompressionCouplingJoint.Cache (Key Q)) (remaining : List Digest32) + (execution : run (primitiveCalls Q log input) qc stream=some ((nextLog,answer),updated,remaining)) + (related : Related (coordinateLabel seedTable) pc qc) + (extension : Extends updated final) (injective : InjectiveOn (coordinateLabel seedTable) final) + (authentic : NonterminalAuthentic seedTable log) (covered : LogCovered pc log) : + ∃ pc', run (PublicCompressionProgram.queryCalls iv (.primitive purpose input)) pc stream= + some (answer,pc',remaining) ∧ Related (coordinateLabel seedTable) pc' updated ∧ + LogCovered pc' nextLog ∧ Extends updated final := by + cases hit : lookup log input with + | some digest => + simp only [primitiveCalls,hit,run,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨⟨logEq,answerEq⟩,cacheEq,streamEq⟩ := execution + subst nextLog + subst answer + subst updated + subst remaining + have realHit := covered input digest (lookup_mem hit) + refine ⟨pc,by simp only [PublicCompressionProgram.queryCalls]; rw [run_hit realHit]; rfl,related,?_,extension⟩ + intro node value member + simp only [DuplexPublicSimulator.observe,List.mem_cons,Prod.mk.injEq] at member + rcases member with ⟨rfl,rfl⟩ | member + · exact realHit + · exact covered node value member + | none => + have draw : ∃ pc', run (PublicCompressionProgram.queryCalls iv (.primitive purpose input)) pc stream= + some (answer,pc',remaining) ∧ Related (coordinateLabel seedTable) pc' updated ∧ + pc' input=some answer ∧ Extends updated final ∧ nextLog=observe log input answer := by + cases found : privateKey Q log input with + | some key => + have label : coordinateLabel seedTable (.inr key)=input := + terminalLabel_witness (privateKey_coordinateWitness seedTable authentic found) + exact draw_alignment Q seedTable iv purpose input log (.inr key) pc qc final stream nextLog answer + updated remaining label (by simpa only [primitiveCalls,hit,found] using execution) + related extension injective + | none => + exact draw_alignment Q seedTable iv purpose input log (.inl input) pc qc final stream nextLog answer + updated remaining rfl (by simpa only [primitiveCalls,hit,found] using execution) + related extension injective + obtain ⟨pc',realExecution,newRelated,stored,newExtension,logEq⟩ := draw + refine ⟨pc',realExecution,newRelated,?_,newExtension⟩ + intro node value member + rw [logEq] at member + simp only [DuplexPublicSimulator.observe,List.mem_cons,Prod.mk.injEq] at member + rcases member with ⟨rfl,rfl⟩ | member + · exact stored + · exact run_extends _ pc stream realExecution (covered node value member) + +#print axioms matched_draw +#print axioms actual_primitive_stream_alignment +end Whir.PublicCompressionCouplingPrimitiveStream diff --git a/verification/whir/Whir/PublicCompressionCouplingPublicCache.lean b/verification/whir/Whir/PublicCompressionCouplingPublicCache.lean new file mode 100644 index 000000000..1645cb899 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingPublicCache.lean @@ -0,0 +1,149 @@ +import Whir.PublicCompressionCouplingPublicTrace +import Whir.PublicCompressionCouplingCausal +import Whir.PublicCompressionCouplingTargetCache +import Whir.PublicCompressionCouplingBirthdayCache +import Whir.PublicCompressionCouplingPrefixTrace + +/-! Public record witnesses in the literal causal ideal memo cache, and the +actual derived no-output-collision consequence of the causal birthday alarm. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed RawOracleCoupling +open TypedOracleCompiler (Sampling) + + theorem causalConstruction_trace (Q : Nat) (table : Key Q → Digest32) (iv : Digest32) + (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (budget : pathCost coordinate ≤ Q) : + (Sampling.execute table (causalConstruction Q iv coordinate valid budget)).2 = + (Sampling.execute table (bodyCalls Q iv (DuplexEncoding.plan coordinate).dropLast)).2 ++ + [⟨.inr (constructionKey Q iv coordinate budget),table (.inr (constructionKey Q iv coordinate budget))⟩] := by + simp only [causalConstruction,Sampling.execute_pad,Sampling.execute_bind,Sampling.execute] + +set_option backward.isDefEq.respectTransparency false in + theorem causalCompile_trace_covers (Q : Nat) (table : Key Q → Digest32) (iv : Digest32) + (log : PublicLog) (p : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining p) {entry : Sigma (fun _ : Key Q => Digest32)} + (member : entry ∈ (Sampling.execute table (compile Q iv log p remaining cap counted)).2) : + entry ∈ (Sampling.execute table (causalCompile Q iv log p remaining cap counted)).2 := by + induction p generalizing log remaining with + | done result => simp [compile,Sampling.execute] at member + | ask query next ih => + cases query with + | primitive purpose input => + simp only [compile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] at member + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] + rcases member with first | later + · exact Or.inl first + · exact Or.inr (ih _ _ _ _ _ later) + | construction coordinate valid => + simp only [compile,Sampling.execute_pad,Sampling.execute,execute_map_trace,List.mem_cons] at member + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace, + causalConstruction_trace,causalConstruction_eval,List.mem_append,List.mem_cons,List.not_mem_nil,or_false] + rcases member with first | later + · exact Or.inl (Or.inr first) + · exact Or.inr (ih _ log _ _ _ later) + +open Classical in + theorem actual_causal_cache_witnessed {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) : + Witnessed Q seedTable + (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 + (finalLog [] (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) := by + have witnessed := compile_traceWitnessed Q seedTable ro iv [] [] p Q (by rfl) counted + (by intro n d member; cases member) (by intro n d member; cases member) + intro input answer member + obtain ⟨key,coordinate,record⟩ := witnessed input answer member + refine ⟨key,coordinate,?_⟩ + apply PublicCompressionCouplingTargetCache.trace_recorded _ _ (fun _ => none) + (by intro k d impossible; cases impossible) + apply causalCompile_trace_covers + simpa only [List.nil_append] using record + +open Classical in + theorem actual_causal_public_noOutputCollision {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (quiet : PublicCompressionCouplingBirthday.alarm (oracle seedTable ro) + (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none) ∅ = false) : + ¬OutputCollision (finalLog [] (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) := by + apply Witnessed.no_outputCollision (actual_causal_cache_witnessed Q iv p counted seedTable ro) + exact PublicCompressionCouplingBirthdayCache.birthday_cache_injective _ _ quiet + + theorem causalConstruction_prefix_record (Q : Nat) (table : Key Q → Digest32) + (iv : Digest32) (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (budget : pathCost coordinate ≤ Q) {node : Node} {answer : Digest32} + (record : (node,answer) ∈ (Sampling.eval table + (causalConstruction Q iv coordinate valid budget)).prefixLog) : + (⟨.inl node,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute table (causalConstruction Q iv coordinate valid budget)).2 := by + simp only [causalConstruction_eval] at record + rw [causalConstruction_trace] + apply List.mem_append_left + rw [bodyCalls_trace] + exact List.mem_map.mpr ⟨(node,answer),record,rfl⟩ + +set_option backward.isDefEq.respectTransparency false in + theorem causalCompile_prefix_record (Q : Nat) (table : Key Q → Digest32) + (iv : Digest32) (log : PublicLog) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) {construction : InspectedConstruction} + (member : construction ∈ (Sampling.eval table (causalCompile Q iv log p remaining cap counted)).2) + {node : Node} {answer : Digest32} (record : (node,answer) ∈ construction.prefixLog) : + (⟨.inl node,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute table (causalCompile Q iv log p remaining cap counted)).2 := by + induction p generalizing log remaining with + | done result => simp [causalCompile,Sampling.eval] at member + | ask query next ih => + cases query with + | primitive purpose input => + simp only [causalCompile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map] at member + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] + exact Or.inr (ih _ _ _ _ _ member) + | construction coordinate valid => + simp only [causalCompile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,List.mem_cons] at member + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] + rcases member with equal | later + · subst construction + exact Or.inl (causalConstruction_prefix_record Q table iv coordinate valid _ record) + · exact Or.inr (ih _ log _ _ _ later) + +open Classical in + theorem actual_causal_prefix_stored {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (table : Key Q → Digest32) + {construction : InspectedConstruction} + (member : construction ∈ (Sampling.eval table (causalCompile Q iv [] p Q (by rfl) counted)).2) + {node : Node} {answer : Digest32} (record : (node,answer) ∈ construction.prefixLog) : + (Sampling.eval table (memo (causalCompile Q iv [] p Q (by rfl) counted) + (fun _ => none))).2 (.inl node) = some answer := by + apply PublicCompressionCouplingTargetCache.trace_recorded _ _ (fun _ => none) + (by intro key digest impossible; cases impossible) + exact causalCompile_prefix_record Q table iv [] p Q (by rfl) counted member record + + theorem CoordinateWitness.nonterminal_coordinate {Q : Nat} {seedTable : Seed} + {input : Node} {key : Key Q} (coordinate : CoordinateWitness Q seedTable input key) + (nonterminal : ¬isTerminal input) : key = .inl input := by + cases coordinate with + | fallback => rfl + | terminal raw rest complete tree extracted => + have parsed := (complete?_correct _).mpr complete + simp only [complete?,Bool.and_eq_true,decide_eq_true_eq] at parsed + exact False.elim (nonterminal parsed.1) + + theorem Witnessed.nonterminal_stored {Q : Nat} {seedTable : Seed} + {cache : Key Q → Option Digest32} {log : PublicLog} + (witnessed : Witnessed Q seedTable cache log) {input : Node} {answer : Digest32} + (member : (input,answer) ∈ log) (nonterminal : ¬isTerminal input) : + cache (.inl input) = some answer := by + obtain ⟨key,coordinate,stored⟩ := witnessed input answer member + rwa [CoordinateWitness.nonterminal_coordinate coordinate nonterminal] at stored + +#print axioms Witnessed.nonterminal_stored + +#print axioms actual_causal_prefix_stored + +#print axioms actual_causal_cache_witnessed +#print axioms actual_causal_public_noOutputCollision +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingPublicTrace.lean b/verification/whir/Whir/PublicCompressionCouplingPublicTrace.lean new file mode 100644 index 000000000..f641647e0 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingPublicTrace.lean @@ -0,0 +1,174 @@ +import Whir.PublicCompressionCouplingCoordinates + +/-! Public record provenance in the pinned simulator's actual mixed sampling +trace. Cached primitive calls retain their original witness; recognized terminal +coordinates have actual seed trees, not an asserted public/primitive coupling. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed +open TypedOracleCompiler (Sampling) + +abbrev MixedTrace (Q : Nat) := List (Sigma (fun _ : Key Q => Digest32)) + +def TraceWitnessed (Q : Nat) (seed : Seed) (trace : MixedTrace Q) (log : PublicLog) : Prop := + ∀ input answer, (input,answer) ∈ log → + ∃ key, CoordinateWitness Q seed input key ∧ (⟨key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ trace + + theorem TraceWitnessed.mono {Q : Nat} {seed : Seed} {a b : MixedTrace Q} {log : PublicLog} + (witnessed : TraceWitnessed Q seed a log) (subset : ∀ entry ∈ a, entry ∈ b) : + TraceWitnessed Q seed b log := by + intro input answer member + obtain ⟨key,coordinate,hit⟩ := witnessed input answer member + exact ⟨key,coordinate,subset _ hit⟩ + + theorem TraceWitnessed.observe {Q : Nat} {seed : Seed} {trace : MixedTrace Q} {log : PublicLog} + (witnessed : TraceWitnessed Q seed trace log) (input : Node) (answer : Digest32) (key : Key Q) + (coordinate : CoordinateWitness Q seed input key) + (hit : (⟨key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ trace) : + TraceWitnessed Q seed trace (observe log input answer) := by + intro node digest member + rcases List.mem_cons.mp member with equal | old + · cases equal + exact ⟨key,coordinate,hit⟩ + · exact witnessed node digest old + + theorem execute_map_trace {Q n : Nat} {R S : Type} (table : Key Q → Digest32) + (f : R → S) (p : Computation Q R n) : + (Sampling.execute table (PublicCompressionCouplingMixed.Computation.map f p)).2 = (Sampling.execute table p).2 := by + induction p with + | ret r => rfl + | draw key next ih => simpa only [PublicCompressionCouplingMixed.Computation.map,Sampling.execute] using congrArg (⟨key,table key⟩ :: ·) (ih (table key)) + + theorem primitiveCalls_traceWitnessed (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (trace : MixedTrace Q) (auth : NonterminalAuthentic seedTable log) + (witnessed : TraceWitnessed Q seedTable trace log) (input : Node) : + TraceWitnessed Q seedTable + (trace ++ (Sampling.execute (oracle seedTable ro) (primitiveCalls Q log input)).2) + (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).1 := by + cases hit : lookup log input with + | some answer => + simp only [primitiveCalls,hit,Sampling.execute,Sampling.eval,List.append_nil] + obtain ⟨key,coordinate,member⟩ := witnessed input answer (lookup_mem hit) + exact TraceWitnessed.observe witnessed input answer key coordinate member + | none => + cases found : privateKey Q log input with + | some key => + simp only [primitiveCalls,hit,found,Sampling.execute,Sampling.eval,oracle] + apply TraceWitnessed.observe + (TraceWitnessed.mono witnessed (fun entry member => List.mem_append_left _ member)) + input (ro key) (.inr key) (privateKey_coordinateWitness seedTable auth found) + exact List.mem_append_right _ (by simp) + | none => + simp only [primitiveCalls,hit,found,Sampling.execute,Sampling.eval,oracle] + apply TraceWitnessed.observe + (TraceWitnessed.mono witnessed (fun entry member => List.mem_append_left _ member)) + input (seedTable input) (.inl input) CoordinateWitness.fallback + exact List.mem_append_right _ (by simp) + + theorem primitiveCalls_authentic (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (auth : NonterminalAuthentic seedTable log) (input : Node) : + NonterminalAuthentic seedTable + (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).1 := by + have result := answer_nonterminal_authentic Q ro ⟨seedTable,log⟩ auth input + simpa only [primitiveCalls_actual] using result + + theorem primitiveCalls_log (Q : Nat) (table : Key Q → Digest32) + (log : PublicLog) (input : Node) : + (Sampling.eval table (primitiveCalls Q log input)).1 = + DuplexPublicSimulator.observe log input (Sampling.eval table (primitiveCalls Q log input)).2 := by + cases hit : lookup log input with + | some answer => simp only [primitiveCalls,hit,Sampling.eval] + | none => cases found : privateKey Q log input <;> + simp only [primitiveCalls,hit,found,Sampling.eval] + +set_option backward.isDefEq.respectTransparency false in + theorem compile_traceWitnessed (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (log : PublicLog) (trace : MixedTrace Q) (p : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) + (auth : NonterminalAuthentic seedTable log) (witnessed : TraceWitnessed Q seedTable trace log) : + TraceWitnessed Q seedTable + (trace ++ (Sampling.execute (oracle seedTable ro) (compile Q iv log p remaining cap counted)).2) + (finalLog log (Sampling.eval (oracle seedTable ro) (compile Q iv log p remaining cap counted)).observations) := by + induction p generalizing log trace remaining with + | done result => simpa only [compile,Sampling.execute,Sampling.eval,finalLog,List.append_nil] using witnessed + | ask query next ih => + cases query with + | primitive purpose input => + have nextWitness := primitiveCalls_traceWitnessed Q seedTable ro log trace auth witnessed input + have nextAuth := primitiveCalls_authentic Q seedTable ro log auth input + have result := ih (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).2 + (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).1 + (trace ++ (Sampling.execute (oracle seedTable ro) (primitiveCalls Q log input)).2) + (remaining-1) (by omega) (counted.2 _) nextAuth nextWitness + simpa only [compile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace, + Sampling.eval_pad,Sampling.eval_bind,PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe, + finalLog,List.append_assoc,primitiveCalls_log] using result + | construction coordinate valid => + have nextWitness := TraceWitnessed.mono witnessed (fun entry member => + List.mem_append_left [⟨.inr (constructionKey Q iv coordinate (counted.1.trans cap)), + ro (constructionKey Q iv coordinate (counted.1.trans cap))⟩] member) + have result := ih (ro (constructionKey Q iv coordinate (counted.1.trans cap))) log + (trace ++ [⟨.inr (constructionKey Q iv coordinate (counted.1.trans cap)), + ro (constructionKey Q iv coordinate (counted.1.trans cap))⟩]) + (remaining-pathCost coordinate) (by omega) (counted.2 _) auth nextWitness + simpa only [compile,Sampling.execute_pad,Sampling.execute,execute_map_trace, + Sampling.eval_pad,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map,oracle,DuplexRawProgram.observe, + finalLog,List.append_assoc,List.cons_append,List.nil_append] using result + + theorem primitiveCalls_seed_record (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (input node : Node) (answer : Digest32) + (member : (⟨.inl node,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (primitiveCalls Q log input)).2) : + (node,answer) ∈ (Sampling.eval (oracle seedTable ro) (primitiveCalls Q log input)).1 := by + cases hit : lookup log input with + | some digest => simp only [primitiveCalls,hit,Sampling.execute,List.not_mem_nil] at member + | none => + cases found : privateKey Q log input with + | some key => + simp [primitiveCalls,hit,found,Sampling.execute] at member + | none => + simp only [primitiveCalls,hit,found,Sampling.execute,oracle,List.mem_cons, + List.not_mem_nil,or_false] at member + have nodes : node = input := by + simpa using congrArg Sigma.fst member + subst node + have answers : answer = seedTable input := by simpa using member + subst answer + simp [primitiveCalls,hit,found,Sampling.eval,oracle,DuplexPublicSimulator.observe] + +set_option backward.isDefEq.respectTransparency false in +/-- Conversely, every seed coordinate sampled in the actual public phase is +a public primitive record. Construction requests do not sample hidden seeds. -/ + theorem compile_seed_record (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (log : PublicLog) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) (node : Node) (answer : Digest32) + (member : (⟨.inl node,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (compile Q iv log p remaining cap counted)).2) : + (node,answer) ∈ + finalLog log (Sampling.eval (oracle seedTable ro) (compile Q iv log p remaining cap counted)).observations := by + induction p generalizing log remaining with + | done result => simp [compile,Sampling.execute] at member + | ask query next ih => + cases query with + | primitive purpose input => + simp only [compile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace, + List.mem_append] at member + simp only [compile,Sampling.eval_pad,Sampling.eval_bind,PublicCompressionCouplingMixed.Computation.eval_map, + DuplexRawProgram.observe,finalLog] + rw [← primitiveCalls_log Q (oracle seedTable ro) log input] + rcases member with first | later + · apply finalLog_contains + exact primitiveCalls_seed_record Q seedTable ro log input node answer first + · exact ih _ _ _ _ _ later + | construction coordinate valid => + simp only [compile,Sampling.execute_pad,Sampling.execute,execute_map_trace,List.mem_cons] at member + rcases member with impossible | later + · have keys := congrArg Sigma.fst impossible + cases keys + · simpa only [compile,Sampling.eval_pad,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map,oracle, + DuplexRawProgram.observe,finalLog] using ih _ log _ _ _ later + +#print axioms compile_seed_record + +#print axioms compile_traceWitnessed +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingROOrigins.lean b/verification/whir/Whir/PublicCompressionCouplingROOrigins.lean new file mode 100644 index 000000000..c82e29ddb --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingROOrigins.lean @@ -0,0 +1,140 @@ +import Whir.PublicCompressionCouplingPublicCache + +/-! Origin of every raw RO coordinate actually consumed by the causal ideal +compiler: a publicly recognized terminal body or an actual construction whose +private prefix is in the same causal memo cache. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed +open TypedOracleCompiler (Sampling) +set_option backward.isDefEq.respectTransparency false + + theorem publicBody_mono {old new : PublicLog} {cv : Digest32} {ns : List Node} + (tree : PublicBody old cv ns) (subset : ∀ n d, (n,d) ∈ old → (n,d) ∈ new) : + PublicBody new cv ns := by + induction tree with + | seed member valid => exact PublicBody.seed (subset _ _ member) valid + | step member valid child ih => exact PublicBody.step (subset _ _ member) valid ih + + theorem bodyCalls_not_raw (Q : Nat) (table : Key Q → Digest32) (cv : Digest32) + (instructions : List DuplexEncoding.Instruction) (key : RawKey Q) (answer : Digest32) : + (⟨.inr key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∉ + (Sampling.execute table (bodyCalls Q cv instructions)).2 := by + rw [bodyCalls_trace] + rintro member + obtain ⟨entry,prior,equal⟩ := List.mem_map.mp member + have keys := congrArg Sigma.fst equal + cases keys + + theorem causalConstruction_raw_key (Q : Nat) (table : Key Q → Digest32) (iv : Digest32) + (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (budget : pathCost coordinate ≤ Q) {key : RawKey Q} {answer : Digest32} + (member : (⟨.inr key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute table (causalConstruction Q iv coordinate valid budget)).2) : + key = constructionKey Q iv coordinate budget := by + rw [causalConstruction_trace,List.mem_append] at member + rcases member with prefixMember | rawMember + · exact False.elim (bodyCalls_not_raw Q table iv _ key answer prefixMember) + · have equal := List.mem_singleton.mp rawMember + exact Sum.inr.inj (congrArg Sigma.fst equal) + + theorem primitiveCalls_raw_key (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (input : Node) {key : RawKey Q} {answer : Digest32} + (member : (⟨.inr key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (primitiveCalls Q log input)).2) : + privateKey Q log input = some key := by + cases hit : lookup log input with + | some digest => simp [primitiveCalls,hit,Sampling.execute] at member + | none => + cases found : privateKey Q log input with + | none => simp [primitiveCalls,hit,found,Sampling.execute] at member + | some raw => + simp only [primitiveCalls,hit,found,Sampling.execute,List.mem_cons,List.not_mem_nil,or_false] at member + have keys : key=raw := Sum.inr.inj (congrArg Sigma.fst member) + exact congrArg some keys.symm + + def PublicTerminalWitness (Q : Nat) (seedTable : Seed) (log : PublicLog) (key : RawKey Q) : Prop := + ∃ input rest, Complete (input::rest) ∧ Tree (compressionOf seedTable) input.cv rest ∧ + extract (input::rest) = some (expandKey key) ∧ PublicBody log input.cv rest + + theorem publicTerminalWitness_mono {Q : Nat} {seedTable : Seed} {old new : PublicLog} {key : RawKey Q} + (witness : PublicTerminalWitness Q seedTable old key) + (subset : ∀ n d, (n,d) ∈ old → (n,d) ∈ new) : + PublicTerminalWitness Q seedTable new key := by + obtain ⟨input,rest,complete,tree,extract,body⟩ := witness + exact ⟨input,rest,complete,tree,extract,publicBody_mono body subset⟩ + + theorem primitiveCalls_raw_witness (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (log : PublicLog) (auth : NonterminalAuthentic seedTable log) (input : Node) + {key : RawKey Q} {answer : Digest32} + (member : (⟨.inr key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (primitiveCalls Q log input)).2) : + PublicTerminalWitness Q seedTable log key := by + have found := primitiveCalls_raw_key Q seedTable ro log input member + obtain ⟨rest,complete,tree,extracted⟩ := privateKey_seed_tree seedTable auth found + obtain ⟨nodes,recognized,hc,he⟩ := privateKey_sound found + obtain ⟨rest',equal,body⟩ := recognized_publicBody recognized + subst nodes + have actual := PublicBody.seed_tree body seedTable auth + have same := (complete_key_unique complete hc tree actual (extracted.trans he.symm)).2 + subst rest' + exact ⟨input,rest,complete,tree,extracted,body⟩ + + theorem causalCompile_raw_origin (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (log : PublicLog) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) + (auth : NonterminalAuthentic seedTable log) {key : RawKey Q} {answer : Digest32} + (member : (⟨.inr key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (causalCompile Q iv log p remaining cap counted)).2) : + PublicTerminalWitness Q seedTable + (finalLog log (Sampling.eval (oracle seedTable ro) (compile Q iv log p remaining cap counted)).observations) key ∨ + ∃ construction ∈ (Sampling.eval (oracle seedTable ro) + (causalCompile Q iv log p remaining cap counted)).2, + ∃ budget : pathCost construction.coordinate ≤ Q, + key = constructionKey Q iv construction.coordinate budget := by + induction p generalizing log remaining with + | done result => simp [causalCompile,Sampling.execute] at member + | ask query next ih => + cases query with + | primitive purpose input => + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] at member + rcases member with first | later + · apply Or.inl + apply publicTerminalWitness_mono (primitiveCalls_raw_witness Q seedTable ro log auth input first) + exact fun n d stored => finalLog_contains _ _ _ stored + · have result := ih _ _ _ _ _ (primitiveCalls_authentic Q seedTable ro log auth input) later + simpa only [compile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe,finalLog, + primitiveCalls_log,causalCompile] using result + | construction coordinate valid => + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] at member + rcases member with first | later + · apply Or.inr + let construction := Sampling.eval (oracle seedTable ro) + (causalConstruction Q iv coordinate valid (counted.1.trans cap)) + have coordinateEq : construction.coordinate=coordinate := by + simp only [construction,causalConstruction_eval] + have budget : pathCost construction.coordinate ≤ Q := by + rw [coordinateEq] + exact counted.1.trans cap + refine ⟨construction,?_,budget,?_⟩ + · simp only [causalCompile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map] + exact List.mem_cons_self + · simpa only [coordinateEq] using causalConstruction_raw_key Q _ iv coordinate valid _ first + · have result := ih _ log _ _ _ auth later + rcases result with publicOrigin | privateOrigin + · apply Or.inl + simpa only [compile,Sampling.eval_pad,Sampling.eval, + PublicCompressionCouplingMixed.Computation.eval_map,oracle,DuplexRawProgram.observe,finalLog, + causalConstruction_eval] using publicOrigin + · apply Or.inr + obtain ⟨construction,constructionMember,budget,equal⟩ := privateOrigin + refine ⟨construction,?_,budget,equal⟩ + simpa only [causalCompile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,causalConstruction_eval] using + List.mem_cons_of_mem (Sampling.eval (oracle seedTable ro) + (causalConstruction Q iv coordinate valid (counted.1.trans cap))) constructionMember + +#print axioms causalCompile_raw_origin +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingRecognition.lean b/verification/whir/Whir/PublicCompressionCouplingRecognition.lean new file mode 100644 index 000000000..20c784a8a --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingRecognition.lean @@ -0,0 +1,60 @@ +import Whir.PublicCompressionCouplingInspection + +/-! Recognition lemmas for the actual pinned simulator. Every nonterminal +public reply is from its same seed table. Recognized raw keys therefore carry +actual seed-table trees, including chosen seed chaining values. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open DuplexPublicSimulator + + def NonterminalAuthentic (seed : Seed) (log : PublicLog) : Prop := + ∀ n d, (n,d) ∈ log → ¬isTerminal n → seed n = d + + theorem privateKey_notterminal (Q : Nat) (log : PublicLog) (input : Node) + (h : ¬isTerminal input) : privateKey Q log input = none := by + simp [privateKey,recognized,h] + + theorem answer_nonterminal (Q : Nat) (ro : RawKey Q → Digest32) (state : DuplexPublicSimulator.State) + (auth : NonterminalAuthentic state.seed state.publicLog) (input : Node) + (h : ¬isTerminal input) : + (runRO ro ((simulator Q).answer state input)).1.2 = state.seed input := by + cases hit : lookup state.publicLog input with + | some answer => + rw [repeated_no_query Q state input answer hit] + exact (auth _ _ (lookup_mem hit) h).symm + | none => simp [simulator,hit,privateKey_notterminal Q state.publicLog input h,runRO] + + theorem answer_nonterminal_authentic (Q : Nat) (ro : RawKey Q → Digest32) + (state : DuplexPublicSimulator.State) (auth : NonterminalAuthentic state.seed state.publicLog) (input : Node) : + NonterminalAuthentic (runRO ro ((simulator Q).answer state input)).1.1.seed + (runRO ro ((simulator Q).answer state input)).1.1.publicLog := by + rw [answer_seed,answer_publicLog] + intro node digest member nonterminal + rcases List.mem_cons.mp member with equal | old + · cases equal + exact (answer_nonterminal Q ro state auth input nonterminal).symm + · exact auth node digest old nonterminal + + theorem PublicBody.seed_tree {log : PublicLog} {cv : Digest32} {ns : List Node} + (tree : PublicBody log cv ns) (seed : Seed) (auth : NonterminalAuthentic seed log) : + Tree (compressionOf seed) cv ns := by + induction tree with + | seed member hs => + have eq := auth _ _ member (fun terminal => terminal_not_seed terminal hs) + simpa [nodeValue,compressionOf,eq] using Tree.seed (c:=compressionOf seed) _ hs + | step member hi child ih => + have eq := auth _ _ member (fun terminal => terminal_not_internal terminal hi) + simpa [nodeValue,compressionOf,eq] using Tree.step _ _ hi ih + + theorem privateKey_seed_tree {Q : Nat} {log : PublicLog} {input : Node} {key : RawKey Q} + (seed : Seed) (auth : NonterminalAuthentic seed log) + (found : privateKey Q log input = some key) : + ∃ rest, Complete (input::rest) ∧ Tree (compressionOf seed) input.cv rest ∧ + extract (input::rest) = some (expandKey key) := by + obtain ⟨ns,recognized,complete,extracted⟩ := privateKey_sound found + obtain ⟨rest,rfl,body⟩ := recognized_publicBody recognized + exact ⟨rest,complete,PublicBody.seed_tree body seed auth,extracted⟩ + +#print axioms answer_nonterminal_authentic +#print axioms privateKey_seed_tree +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingRelabelCache.lean b/verification/whir/Whir/PublicCompressionCouplingRelabelCache.lean new file mode 100644 index 000000000..87511b158 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingRelabelCache.lean @@ -0,0 +1,90 @@ +import Whir.PublicCompressionCouplingStreamFacts + +/-! The exact cache relation used by the source induction: stored cells, not +only sampled digests, correspond under consumed-coordinate relabeling. -/ +namespace Whir.PublicCompressionCouplingRelabelCache +open FiatShamirGame TypedFiatShamirGame PublicCompressionCouplingJoint + +variable {A B : Type} [DecidableEq A] [DecidableEq B] + +structure Related (label : B → A) (pc : Cache A) (qc : Cache B) : Prop where + forward : ∀ key answer, qc key=some answer → pc (label key)=some answer + backward : ∀ node answer, pc node=some answer → + ∃ key, qc key=some answer ∧ label key=node + +def Extends (qc final : Cache B) : Prop := + ∀ key answer, qc key=some answer → final key=some answer + +def InjectiveOn (label : B → A) (final : Cache B) : Prop := + ∀ left right d e, final left=some d → final right=some e → label left=label right → left=right + +omit [DecidableEq A] [DecidableEq B] in + theorem empty_related (label : B → A) : Related label (fun _ => none) (fun _ => none) := by + constructor + · intro key answer impossible; cases impossible + · intro node answer impossible; cases impossible + +omit [DecidableEq A] [DecidableEq B] in + theorem Related.lookup {label : B → A} {pc : Cache A} {qc final : Cache B} + (related : Related label pc qc) (extension : Extends qc final) + (injective : InjectiveOn label final) {key : B} {answer : Digest32} + (present : final key=some answer) : pc (label key)=qc key := by + cases hit : qc key with + | some digest => exact related.forward key digest hit + | none => + cases stored : pc (label key) with + | none => rfl + | some digest => + obtain ⟨other,cached,same⟩ := related.backward _ _ stored + have keys := injective other key digest answer (extension other digest cached) present same + subst other + rw [hit] at cached + cases cached + + theorem Related.put {label : B → A} {pc : Cache A} {qc final : Cache B} + (related : Related label pc qc) (extension : Extends qc final) + (injective : InjectiveOn label final) {key : B} {answer : Digest32} + (present : final key=some answer) : + Related label (put pc (label key) answer) (put qc key answer) := by + constructor + · intro other digest stored + by_cases same : other=key + · subst other + rw [put_self] at stored + cases stored + exact put_self _ _ _ + · rw [put_other _ _ _ _ same] at stored + have unequal : label other ≠ label key := by + intro nodes + exact same (injective other key digest answer (extension other digest stored) present nodes) + rw [put_other _ _ _ _ unequal] + exact related.forward other digest stored + · intro node digest stored + by_cases same : node=label key + · subst node + rw [put_self] at stored + cases stored + exact ⟨key,put_self _ _ _,rfl⟩ + · rw [put_other _ _ _ _ same] at stored + obtain ⟨other,cached,nodes⟩ := related.backward node digest stored + have unequal : other ≠ key := by + intro equal + subst other + exact same nodes.symm + exact ⟨other,by rw [put_other _ _ _ _ unequal]; exact cached,nodes⟩ + + theorem extends_put {qc final : Cache B} (extension : Extends qc final) + {key : B} {answer : Digest32} (present : final key=some answer) : + Extends (put qc key answer) final := by + intro other digest stored + by_cases same : other=key + · subst other + rw [put_self] at stored + cases stored + exact present + · rw [put_other _ _ _ _ same] at stored + exact extension other digest stored + +#print axioms Related.lookup +#print axioms Related.put +end Whir.PublicCompressionCouplingRelabelCache diff --git a/verification/whir/Whir/PublicCompressionCouplingResidual.lean b/verification/whir/Whir/PublicCompressionCouplingResidual.lean new file mode 100644 index 000000000..132d95518 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingResidual.lean @@ -0,0 +1,69 @@ +import Whir.PublicCompressionCoupling + +/-! Exact disintegration of an actual uniform finite table after an adaptive +public computation. It leaves a uniformly sampled completion behind the real +memo cache; this is what justifies private, post-public prefix inspection. -/ +namespace Whir.PublicCompressionCouplingResidual +open FiatShamirGame TypedOracleCompiler TypedFiatShamirGame RawOracleCoupling + +variable {K R : Type} [DecidableEq K] [Fintype K] +abbrev D := Digest32 +abbrev Table (K : Type) := K → D + + theorem table_residual {n : Nat} (p : Sampling K (fun _ => D) R n) + (cache : K → Option D) (payoff : R → Table K → ℚ) : + average (fun table : Table K => + payoff (Sampling.eval (overlay cache table) p) (overlay cache table)) = + Sampling.expectation (fun result => average (fun table : Table K => + payoff result.1 (overlay result.2 table))) (memo p cache) := by + induction p generalizing cache with + | ret r => rfl + | draw key next ih => + cases hit : cache key with + | some answer => + simp only [memo,hit,Sampling.expectation_pad] + rw [← ih answer cache] + apply congrArg average + funext table + simp [Sampling.eval,overlay,hit] + | none => + rw [overlay_average cache key hit + (fun table => payoff (Sampling.eval table (.draw key next)) table)] + simp only [memo,hit,Sampling.expectation] + apply congrArg average + funext answer + rw [← ih answer (put cache key answer)] + apply congrArg average + funext table + simp [Sampling.eval,overlay] + + +/-- The residual completion is conditional on the actual completed memo cache, +not an assumed transcript certificate. -/ +theorem memo_residual {n : Nat} (p : Sampling K (fun _ => D) R n) + (cache : K → Option D) (payoff : (R × (K → Option D)) → Table K → ℚ) : + average (fun table : Table K => + payoff (Sampling.eval (overlay cache table) (memo p cache)) (overlay cache table)) = + Sampling.expectation (fun result => average (fun table : Table K => + payoff result (overlay result.2 table))) (memo p cache) := by + induction p generalizing cache with + | ret r => rfl + | draw key next ih => + cases hit : cache key with + | some answer => + simp only [memo,hit,Sampling.expectation_pad,Sampling.eval_pad] + exact ih answer cache + | none => + rw [overlay_average cache key hit + (fun table => payoff (Sampling.eval table (memo (.draw key next) cache)) table)] + simp only [memo,hit,Sampling.expectation] + apply congrArg average + funext answer + rw [← ih answer (put cache key answer)] + apply congrArg average + funext table + simp [Sampling.eval,overlay] + +#print axioms memo_residual +#print axioms table_residual +end Whir.PublicCompressionCouplingResidual diff --git a/verification/whir/Whir/PublicCompressionCouplingSourceStream.lean b/verification/whir/Whir/PublicCompressionCouplingSourceStream.lean new file mode 100644 index 000000000..c3f5ae0a4 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingSourceStream.lean @@ -0,0 +1,163 @@ +import Whir.PublicCompressionCouplingConstructionStream +import Whir.PublicCompressionCouplingGoodGraph +import Whir.PublicCompressionCouplingActualJoint + +/-! Whole adaptive source alignment for the literal fresh-answer joint sampler. +Completed ideal cache tables instantiate every operational invariant. -/ +namespace Whir.PublicCompressionCouplingSourceStream +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open TypedFiatShamirGame RawOracleCoupling +open TypedOracleCompiler (Sampling) +open PublicCompressionCouplingMixed PublicCompressionCouplingJoint +open PublicCompressionCouplingStreams PublicCompressionCouplingRelabelCache +open PublicCompressionCouplingRecognition PublicCompressionCouplingPrimitiveStream +open PublicCompressionCouplingConstructionStream +set_option backward.isDefEq.respectTransparency false + + theorem run_bind_split {K R S : Type} [DecidableEq K] {n m : Nat} + (p : PublicCompressionCouplingJoint.Computation K R n) + (next : R → PublicCompressionCouplingJoint.Computation K S m) + (cache : PublicCompressionCouplingJoint.Cache K) (stream : List Digest32) + {result : S} {final : PublicCompressionCouplingJoint.Cache K} {remaining : List Digest32} + (execution : run (Sampling.bind p next) cache stream=some (result,final,remaining)) : + ∃ value updated rest, run p cache stream=some (value,updated,rest) ∧ + run (next value) updated rest=some (result,final,remaining) := by + rw [run_bind] at execution + cases found : run p cache stream with + | none => simp only [found] at execution; cases execution + | some triple => + rcases triple with ⟨value,updated,rest⟩ + exact ⟨value,updated,rest,rfl,by simpa only [found] using execution⟩ + +open Classical in + theorem actual_source_stream_alignment {R : Type} (Q : Nat) (seedTable : Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (p : Program R) + (log : PublicLog) (budget : Nat) (cap : budget ≤ Q) (counted : Counts budget p) + (pc : PublicCompressionCouplingJoint.Cache Node) + (qc final : PublicCompressionCouplingJoint.Cache (Key Q)) (stream : List Digest32) + (result : View R × List InspectedConstruction) + (updated : PublicCompressionCouplingJoint.Cache (Key Q)) (remaining : List Digest32) + (execution : run (causalCompile Q iv log p budget cap counted) qc stream= + some (result,updated,remaining)) + (related : Related (coordinateLabel seedTable) pc qc) + (extension : Extends updated final) (injective : InjectiveOn (coordinateLabel seedTable) final) + (consistent : ∀ key answer, final key=some answer → oracle seedTable ro key=answer) + (authentic : NonterminalAuthentic seedTable log) (covered : LogCovered pc log) : + ∃ realResult pc', run (PublicCompressionProgram.compile iv p budget counted) pc stream= + some (realResult,pc',remaining) ∧ realResult.view=result.1 ∧ + Related (coordinateLabel seedTable) pc' updated := by + induction p generalizing log budget pc qc stream result updated remaining with + | done value => + simp only [causalCompile,run,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨rfl,rfl,rfl⟩ := execution + exact ⟨⟨⟨[],value⟩,0,0,0⟩,pc,rfl,rfl,related⟩ + | ask query next ih => + cases query with + | primitive purpose input => + simp only [causalCompile,run_pad] at execution + obtain ⟨answer,first,rest,firstRun,tail⟩ := run_bind_split _ _ qc stream execution + obtain ⟨tailResult,tailRun,resultEq⟩ := mixed_map_recover _ _ first rest tail + have firstExtension : Extends first final := by + intro key digest stored + exact extension key digest (run_extends _ first rest tailRun stored) + obtain ⟨firstReal,realQuery,firstRelated,firstCovered,_⟩ := actual_primitive_stream_alignment + Q seedTable iv purpose input log pc qc final stream answer.1 answer.2 first rest firstRun + related firstExtension injective authentic covered + have evalEq := run_eval _ qc stream firstRun (oracle seedTable ro) + (fun key digest stored => consistent key digest (firstExtension key digest stored)) + have firstAuthentic : NonterminalAuthentic seedTable answer.1 := by + rw [← evalEq] + exact primitiveCalls_authentic Q seedTable ro log authentic input + obtain ⟨tailReal,lastReal,realTail,viewEq,lastRelated⟩ := ih answer.2 answer.1 + (budget-1) (by omega) (counted.2 _) firstReal first rest tailResult updated remaining + tailRun firstRelated extension firstAuthentic firstCovered + refine ⟨prepend (.primitive purpose input) answer.2 0 tailReal,lastReal,?_,?_,lastRelated⟩ + · simp only [PublicCompressionProgram.compile,run_pad,run_bind,realQuery,run_real_map,Query.cost,realTail,Option.map_some] + · have projected := congrArg (fun pair : View R × List InspectedConstruction => pair.1) resultEq + simpa only [prepend,DuplexRawProgram.observe,viewEq] using projected + | construction coordinate valid => + simp only [causalCompile,run_pad] at execution + obtain ⟨construction,first,rest,firstRun,tail⟩ := run_bind_split _ _ qc stream execution + obtain ⟨tailResult,tailRun,resultEq⟩ := mixed_map_recover _ _ first rest tail + have firstExtension : Extends first final := by + intro key digest stored + exact extension key digest (run_extends _ first rest tailRun stored) + obtain ⟨firstReal,realQuery,firstRelated,_⟩ := actual_construction_stream_alignment + Q seedTable ro iv coordinate valid (counted.1.trans cap) pc qc final stream construction + first rest firstRun related firstExtension injective consistent + have firstCovered : LogCovered firstReal log := by + intro node answer member + exact run_extends _ pc stream realQuery (covered node answer member) + obtain ⟨tailReal,lastReal,realTail,viewEq,lastRelated⟩ := ih construction.advertised log + (budget-pathCost coordinate) (by omega) (counted.2 _) firstReal first rest tailResult updated + remaining tailRun firstRelated extension authentic firstCovered + refine ⟨prepend (.construction coordinate valid) construction.advertised 0 tailReal,lastReal,?_,?_,lastRelated⟩ + · simp only [PublicCompressionProgram.compile,run_pad,run_bind,realQuery,run_real_map,Query.cost,realTail,Option.map_some] + · have projected := congrArg (fun pair : View R × List InspectedConstruction => pair.1) resultEq + simpa only [prepend,DuplexRawProgram.observe,viewEq] using projected + +open Classical in + theorem actual_good_source_stream_alignment {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (stream : List Digest32) (result : View R × List InspectedConstruction) + (final : PublicCompressionCouplingJoint.Cache (Key Q)) (remaining : List Digest32) + (execution : run (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none) stream= + some (result,final,remaining)) + (consistent : ∀ key answer, final key=some answer → oracle seedTable ro key=answer) + (quiet : causalBad Q iv p counted (oracle seedTable ro)=false) : + ∃ realResult pc', run (PublicCompressionProgram.compile iv p Q counted) (fun _ => none) stream= + some (realResult,pc',remaining) ∧ realResult.view=result.1 := by + have tableEq := run_table _ (fun _ => none) stream execution (oracle seedTable ro) consistent + have injective := actual_good_cache_label_injective Q iv p counted seedTable ro quiet + rw [tableEq] at injective + obtain ⟨realResult,pc',realRun,viewEq,_⟩ := actual_source_stream_alignment Q seedTable ro iv p [] + Q (by rfl) counted (fun _ => none) (fun _ => none) final stream result final remaining execution + (empty_related _) + (by intro key answer stored; exact stored) injective consistent + (by intro node answer impossible; cases impossible) (by intro node answer impossible; cases impossible) + exact ⟨realResult,pc',realRun,viewEq⟩ + +open Classical in + theorem actual_joint_good_view {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) {trace} {pair} + (execution : Sampling.Runs (PublicCompressionCouplingActualJoint.actualJoint Q iv p counted) trace pair) + (table : Key Q → Digest32) + (quiet : causalBad Q iv p counted (overlay pair.2.2 table)=false) : + pair.1.1.view=pair.2.1.1 := by + have shared := runs_draws execution + rw [PublicCompressionCouplingActualJoint.actualJoint,joint_stream] at shared + cases realRun : run (PublicCompressionProgram.compile iv p Q counted) + (fun _ => none) (trace.map (fun entry => entry.2)) with + | none => simp only [realRun] at shared; cases shared + | some realTriple => + rcases realTriple with ⟨realResult,realCache,realRemaining⟩ + cases idealRun : run (causalCompile Q iv [] p Q (by rfl) counted) + (fun _ => none) (trace.map (fun entry => entry.2)) with + | none => simp only [realRun,idealRun] at shared; cases shared + | some idealTriple => + rcases idealTriple with ⟨idealResult,idealCache,idealRemaining⟩ + simp only [realRun,idealRun,Option.some.injEq] at shared + subst pair + let completed := overlay idealCache table + let seedTable : Seed := fun node => completed (.inl node) + let ro : RawKey Q → Digest32 := fun key => completed (.inr key) + have split : oracle seedTable ro=completed := by + funext key + cases key <;> rfl + have consistent : ∀ key answer, idealCache key=some answer → oracle seedTable ro key=answer := by + intro key answer stored + rw [split] + simp only [completed,overlay,stored,Option.getD_some] + have good : causalBad Q iv p counted (oracle seedTable ro)=false := by + simpa only [split,completed] using quiet + obtain ⟨alignedResult,alignedCache,alignedRun,viewEq⟩ := actual_good_source_stream_alignment + Q iv p counted seedTable ro _ idealResult idealCache idealRemaining idealRun consistent good + have resultEq := realRun.symm.trans alignedRun + simp only [Option.some.injEq,Prod.mk.injEq] at resultEq + exact resultEq.1 ▸ viewEq + +#print axioms actual_joint_good_view + +#print axioms actual_source_stream_alignment +#print axioms actual_good_source_stream_alignment +end Whir.PublicCompressionCouplingSourceStream diff --git a/verification/whir/Whir/PublicCompressionCouplingSourceStreamSmoke.lean b/verification/whir/Whir/PublicCompressionCouplingSourceStreamSmoke.lean new file mode 100644 index 000000000..4e78dfab2 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingSourceStreamSmoke.lean @@ -0,0 +1,51 @@ +import Whir.PublicCompressionCouplingSourceStream + +/-! Executable actual-program fresh-stream checks. These finite cases are not a +proof of universal correspondence or a concrete compression security claim. -/ +namespace Whir.PublicCompressionCouplingSourceStreamSmoke +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed PublicCompressionCouplingStreams PublicCompressionCouplingJoint + +private def nodeDecEq (a b : Node) : Decidable (a=b) := + if h : a.cv=b.cv ∧ a.block=b.block ∧ a.tweak=b.tweak ∧ a.last=b.last then + isTrue (by cases a; cases b; simp_all) + else isFalse (by intro equal; apply h; cases equal; exact ⟨rfl,rfl,rfl,rfl⟩) + +private instance : DecidableEq Node := nodeDecEq + +def smoke : IO Unit := do + let digest (n : Nat) : Digest32 := fun _ => ⟨n % 256,Nat.mod_lt _ (by decide)⟩ + let coordinate : Coordinate := ⟨⟨digest 3,digest 4,[]⟩,.output 0⟩ + have valid : DuplexEncoding.Admissible coordinate := by + simp [coordinate,DuplexEncoding.Admissible,DuplexEncoding.TerminalValid] + let seedNode : Node := ⟨digest 0,ByteCodec.pairBytes (digest 3,digest 4),UInt64.ofNat (2^56),true⟩ + for x in List.range 4 do + for z in List.range 4 do + let terminal := terminalNode (digest (x+1)) coordinate.terminal + let program : Program Digest32 := .ask (.construction coordinate valid) (fun answer => + .ask (.primitive .direct seedNode) (fun _ => + .ask (.primitive .verification terminal) (fun _ => + .ask (.construction coordinate valid) (fun repeated => + .ask (.primitive .auxiliary terminal) (fun _ => Program.done (if answer= repeated then answer else digest 255)))))) + have counted : Counts 8 program := by + simp [program,Counts,Query.cost,pathCost,DuplexEncoding.plan,coordinate] + let stream := [digest (x+1),digest (z+20),digest 99] + let real := run (PublicCompressionProgram.compile (digest 0) program 8 counted) (fun _ => none) stream + let ideal := run (causalCompile 8 (digest 0) [] program 8 (by omega) counted) (fun _ => none) stream + match real,ideal with + | some (r,rc,rr),some (s,sc,sr) => + unless decide (r.view.observations.map Observation.answer=s.1.observations.map Observation.answer) && + decide (r.view.result=s.1.result) && decide (rr=sr) && decide (rr=[digest 99]) && + decide (rc seedNode=some (digest (x+1))) && decide (rc terminal=some (digest (z+20))) && + decide (sc (.inl seedNode)=some (digest (x+1))) && + decide (s.1.observations.map Observation.answer= + [digest (z+20),digest (x+1),digest (z+20),digest (z+20),digest (z+20)]) do + throw (IO.userError "actual source stream/cache/whole-view smoke: FAILED") + | _,_ => throw (IO.userError "actual source stream unexpectedly exhausted") + IO.println "actual source fresh-stream smoke: 16 adaptive construction/public-recognition/repetition cases passed" + +#eval smoke + +end Whir.PublicCompressionCouplingSourceStreamSmoke + +def main : IO Unit := Whir.PublicCompressionCouplingSourceStreamSmoke.smoke diff --git a/verification/whir/Whir/PublicCompressionCouplingStreamFacts.lean b/verification/whir/Whir/PublicCompressionCouplingStreamFacts.lean new file mode 100644 index 000000000..dce1dc19b --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingStreamFacts.lean @@ -0,0 +1,165 @@ +import Whir.PublicCompressionCouplingStreams +import Whir.PublicCompressionCouplingCausal + +/-! Exact lazy fresh-stream interpreter facts for source-aware alignment. +Completed caches recover actual memo execution under every consistent table; +no independent replay seed or oracle is introduced. -/ +namespace Whir.PublicCompressionCouplingStreams +open FiatShamirGame TypedFiatShamirGame RawOracleCoupling +open TypedOracleCompiler (Sampling) +open PublicCompressionCouplingJoint + +variable {K R : Type} [DecidableEq K] + + theorem run_extends {n : Nat} (p : Computation K R n) (cache : Cache K) (stream : List Digest32) + {result : R} {final : Cache K} {remaining : List Digest32} + (execution : run p cache stream=some (result,final,remaining)) {key : K} {answer : Digest32} + (stored : cache key=some answer) : final key=some answer := by + induction p generalizing cache stream with + | ret value => + simp only [run,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨_,equal,_⟩ := execution + simpa only [← equal] using stored + | draw input next ih => + cases hit : cache input with + | some value => + rw [run_hit hit] at execution + exact ih value cache stream execution stored + | none => + cases stream with + | nil => rw [run_miss_nil hit] at execution; cases execution + | cons value rest => + rw [run_miss_cons hit] at execution + apply ih value (put cache input value) rest execution + by_cases same : key=input + · subst key + rw [hit] at stored + cases stored + · simpa only [put_other _ _ _ _ same] using stored + + theorem run_table {n : Nat} (p : Computation K R n) (cache : Cache K) (stream : List Digest32) + {result : R} {final : Cache K} {remaining : List Digest32} + (execution : run p cache stream=some (result,final,remaining)) (table : K → Digest32) + (consistent : ∀ key answer, final key=some answer → table key=answer) : + Sampling.eval table (memo p cache)=(result,final) := by + induction p generalizing cache stream with + | ret value => + simp only [run,Option.some.injEq,Prod.mk.injEq] at execution + obtain ⟨equal,cacheEq,_⟩ := execution + simp only [memo,Sampling.eval,equal,cacheEq] + | draw input next ih => + cases hit : cache input with + | some value => + rw [run_hit hit] at execution + simp only [memo,hit,Sampling.eval_pad] + exact ih value cache stream execution + | none => + cases stream with + | nil => rw [run_miss_nil hit] at execution; cases execution + | cons value rest => + rw [run_miss_cons hit] at execution + have stored := run_extends (next value) (put cache input value) rest execution (put_self _ _ _) + have actual := consistent input value stored + simp only [memo,hit,Sampling.eval,actual] + exact ih value (put cache input value) rest execution + + theorem run_eval {n : Nat} (p : Computation K R n) (cache : Cache K) (stream : List Digest32) + {result : R} {final : Cache K} {remaining : List Digest32} + (execution : run p cache stream=some (result,final,remaining)) (table : K → Digest32) + (consistent : ∀ key answer, final key=some answer → table key=answer) : + Sampling.eval table p=result := by + have initial : ∀ key answer, cache key=some answer → table key=answer := by + intro key answer stored + exact consistent key answer (run_extends p cache stream execution stored) + have overlayEq : overlay cache table=table := by + funext key + cases hit : cache key with + | none => simp only [overlay,hit,Option.getD_none] + | some answer => + simp only [overlay,hit,Option.getD_some] + exact (initial key answer hit).symm + have pure := memo_eval_first p cache table + rw [overlayEq] at pure + exact pure.symm.trans (congrArg Prod.fst (run_table p cache stream execution table consistent)) + + theorem run_pad {n m : Nat} (bound : n ≤ m) (p : Computation K R n) + (cache : Cache K) (stream : List Digest32) : + run (Sampling.pad bound p) cache stream=run p cache stream := by + induction p generalizing m cache stream with + | ret result => simp only [Sampling.pad,run] + | draw key next ih => + cases m with + | zero => omega + | succ m => + cases hit : cache key with + | some answer => + simp only [Sampling.pad] + rw [run_hit hit,run_hit hit] + exact ih answer _ cache stream + | none => + cases stream with + | nil => simp only [Sampling.pad,run_miss_nil,hit] + | cons answer rest => + simpa only [Sampling.pad,run_miss_cons,hit] using ih answer _ (put cache key answer) rest + + theorem run_bind {S : Type} {n m : Nat} (p : Computation K R n) + (next : R → Computation K S m) (cache : Cache K) (stream : List Digest32) : + run (Sampling.bind p next) cache stream = + match run p cache stream with + | none => none + | some (value,updated,rest) => run (next value) updated rest := by + induction p generalizing cache stream with + | ret result => simp only [Sampling.bind,run_pad,run] + | draw key continuation ih => + cases hit : cache key with + | some answer => + simp only [Sampling.bind,run_pad] + rw [run_hit hit,run_hit hit] + exact ih answer cache stream + | none => + cases stream with + | nil => simp only [Sampling.bind,run_pad,run_miss_nil,hit] + | cons answer rest => + simpa only [Sampling.bind,run_pad,run_miss_cons,hit] using ih answer (put cache key answer) rest + + theorem run_mixed_map {Q n : Nat} [DecidableEq (PublicCompressionCouplingMixed.Key Q)] + {R S : Type} (f : R → S) + (p : PublicCompressionCouplingMixed.Computation Q R n) + (cache : Cache (PublicCompressionCouplingMixed.Key Q)) (stream : List Digest32) : + run (PublicCompressionCouplingMixed.Computation.map f p) cache stream = + (run p cache stream).map (fun result => (f result.1,result.2.1,result.2.2)) := by + induction p generalizing cache stream with + | ret result => rfl + | draw key next ih => + cases hit : cache key with + | some answer => + simp only [PublicCompressionCouplingMixed.Computation.map] + rw [run_hit hit,run_hit hit] + exact ih answer cache stream + | none => + cases stream with + | nil => simp only [PublicCompressionCouplingMixed.Computation.map,run_miss_nil,hit,Option.map_none] + | cons answer rest => + simpa only [PublicCompressionCouplingMixed.Computation.map,run_miss_cons,hit] using ih answer (put cache key answer) rest + + theorem run_real_map {n : Nat} [DecidableEq DuplexFraming.Node] {R S : Type} (f : R → S) + (p : PublicCompressionProgram.Computation R n) (cache : Cache DuplexFraming.Node) (stream : List Digest32) : + run (PublicCompressionProgram.mapResult f p) cache stream = + (run p cache stream).map (fun result => (f result.1,result.2.1,result.2.2)) := by + induction p generalizing cache stream with + | ret result => rfl + | draw key next ih => + cases hit : cache key with + | some answer => + simp only [PublicCompressionProgram.mapResult] + rw [run_hit hit,run_hit hit] + exact ih answer cache stream + | none => + cases stream with + | nil => simp only [PublicCompressionProgram.mapResult,run_miss_nil,hit,Option.map_none] + | cons answer rest => + simpa only [PublicCompressionProgram.mapResult,run_miss_cons,hit] using ih answer (put cache key answer) rest + +#print axioms run_table +#print axioms run_bind +end Whir.PublicCompressionCouplingStreams diff --git a/verification/whir/Whir/PublicCompressionCouplingStreams.lean b/verification/whir/Whir/PublicCompressionCouplingStreams.lean new file mode 100644 index 000000000..d2c4f81e3 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingStreams.lean @@ -0,0 +1,149 @@ +import Whir.PublicCompressionCouplingJoint + +/-! Deterministic path semantics for the existing shared-answer joint sampler. +A Unit draw is fresh randomness on each occurrence: it is NOT evaluated using +one memoized Unit table. Both marginals consume the same fresh digest stream. -/ +namespace Whir.PublicCompressionCouplingStreams +open FiatShamirGame TypedFiatShamirGame +open TypedOracleCompiler (Sampling) +open PublicCompressionCouplingJoint + +variable {K R : Type} [DecidableEq K] + +/-- The ordinary lazy-table interpreter, exposing its unconsumed stream solely +for deterministic cache/trace induction. -/ +def run {n : Nat} : Computation K R n → Cache K → List Digest32 → + Option (R × Cache K × List Digest32) + | .ret result, cache, stream => some (result,cache,stream) + | .draw key next, cache, stream => + match cache key with + | some answer => run (next answer) cache stream + | none => match stream with + | [] => none + | answer::rest => run (next answer) (put cache key answer) rest + + theorem run_hit {n : Nat} {key : K} {next : Digest32 → Computation K R n} + {cache : Cache K} {stream : List Digest32} {answer : Digest32} + (hit : cache key=some answer) : + run (.draw key next) cache stream=run (next answer) cache stream := by + rw [run.eq_def] + dsimp only + rw [hit] + + theorem run_miss_nil {n : Nat} {key : K} {next : Digest32 → Computation K R n} + {cache : Cache K} (hit : cache key=none) : + run (.draw key next) cache []=none := by + rw [run,hit] + + theorem run_miss_cons {n : Nat} {key : K} {next : Digest32 → Computation K R n} + {cache : Cache K} {answer : Digest32} {rest : List Digest32} (hit : cache key=none) : + run (.draw key next) cache (answer::rest)=run (next answer) (put cache key answer) rest := by + rw [run,hit] + +/-- Fresh independent draws, including repeated Unit coordinates in joint. -/ +def draws {K R : Type} {n : Nat} : Sampling K (fun _ => Digest32) R n → List Digest32 → Option R + | .ret result, _ => some result + | .draw _ next, [] => none + | .draw _ next, answer::rest => draws (next answer) rest + + theorem draws_pad {K R : Type} {n m : Nat} (bound : n ≤ m) + (p : Sampling K (fun _ => Digest32) R n) (stream : List Digest32) : + draws (Sampling.pad bound p) stream = draws p stream := by + induction p generalizing m stream with + | ret result => simp only [Sampling.pad,draws] + | draw key next ih => + cases m with + | zero => omega + | succ m => + cases stream with + | nil => simp only [Sampling.pad,draws] + | cons answer rest => simpa only [Sampling.pad,draws] using ih answer _ rest + +variable {A B S : Type} [DecidableEq A] [DecidableEq B] + + theorem joint_stream {n m : Nat} (p : Computation A R n) (pc : Cache A) + (q : Computation B S m) (qc : Cache B) (stream : List Digest32) : + draws (joint p pc q qc) stream = + match run p pc stream,run q qc stream with + | some (r,pc',_),some (s,qc',_) => some ((r,pc'),(s,qc')) + | _,_ => none := by + suffices aux : ∀ size n m, n+m=size → + ∀ (p : Computation A R n) (pc : Cache A) (q : Computation B S m) (qc : Cache B) stream, + draws (joint p pc q qc) stream = + match run p pc stream,run q qc stream with + | some (r,pc',_),some (s,qc',_) => some ((r,pc'),(s,qc')) + | _,_ => none by + exact aux (n+m) n m rfl p pc q qc stream + intro size + induction size using Nat.strong_induction_on with + | h size ih => + intro n m total p pc q qc stream + cases p with + | ret r => + cases q with + | ret s => simp only [joint,draws,run] + | @draw j key next => + cases hit : qc key with + | some answer => + simp only [joint,hit,draws_pad,run] + rw [run_hit (next := next) hit] + simpa only [run] using ih (n+j) (by omega) n j rfl (.ret r) pc (next answer) qc stream + | none => + cases stream with + | nil => simp only [joint,hit,draws_pad,draws,run] + | cons answer rest => + simp only [joint,hit,draws_pad,draws,run] + have equal := ih (n+j) (by omega) n j rfl (.ret r) pc (next answer) (put qc key answer) rest + cases finished : run (next answer) (put qc key answer) rest with + | none => simpa only [run,finished] using equal + | some result => + rcases result with ⟨value,cache,unused⟩ + simpa only [run,finished] using equal + | @draw i key next => + cases q with + | ret s => + cases hit : pc key with + | some answer => + simp only [joint,hit,draws_pad,run] + rw [run_hit (next := next) hit] + simpa only [run] using ih (i+m) (by omega) i m rfl (next answer) pc (.ret s) qc stream + | none => + cases stream with + | nil => simp only [joint,hit,draws_pad,draws,run] + | cons answer rest => + simp only [joint,hit,draws_pad,draws,run] + have equal := ih (i+m) (by omega) i m rfl (next answer) (put pc key answer) (.ret s) qc rest + cases finished : run (next answer) (put pc key answer) rest with + | none => simpa only [run,finished] using equal + | some result => + rcases result with ⟨value,cache,unused⟩ + simpa only [run,finished] using equal + | @draw j key' next' => + cases hit : pc key with + | some answer => + simp only [joint,hit,draws_pad] + rw [run_hit (next := next) hit] + simpa only [run] using ih (i+(j+1)) (by omega) i (j+1) rfl (next answer) pc (.draw key' next') qc stream + | none => + cases hit' : qc key' with + | some answer => + simp only [joint,hit,hit',draws_pad] + rw [run_hit (next := next') hit'] + simpa only [run] using ih ((i+1)+j) (by omega) (i+1) j rfl (.draw key next) pc (next' answer) qc stream + | none => + cases stream with + | nil => simp only [joint,hit,hit',draws_pad,draws,run] + | cons answer rest => + simp only [joint,hit,hit',draws_pad,draws,run] + simpa only [run] using ih (i+j) (by omega) i j rfl (next answer) (put pc key answer) (next' answer) (put qc key' answer) rest + + theorem runs_draws {K R : Type} {n : Nat} {p : Sampling K (fun _ => Digest32) R n} + {trace : List (Sigma (fun _ : K => Digest32))} {result : R} + (execution : Sampling.Runs p trace result) : + draws p (trace.map (fun entry => entry.2)) = some result := by + induction execution with + | ret result => rfl + | draw answer execution ih => simpa only [List.map_cons,draws] using ih + +#print axioms joint_stream +end Whir.PublicCompressionCouplingStreams diff --git a/verification/whir/Whir/PublicCompressionCouplingTargetCache.lean b/verification/whir/Whir/PublicCompressionCouplingTargetCache.lean new file mode 100644 index 000000000..7f2c6c7f4 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingTargetCache.lean @@ -0,0 +1,191 @@ +import Whir.PublicCompressionCouplingHidden + +/-! Operational consequences of the actual fresh-target alarm. A quiet private +run creates no new target-valued cache entries. These are cache/trace lemmas, +not a supplied stochastic certificate: the alarm probability is already derived +from the actual uniform finite experiment in PublicCompressionCouplingHidden. -/ +namespace Whir.PublicCompressionCouplingTargetCache +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open TypedFiatShamirGame RawOracleCoupling + +variable {K R : Type} [DecidableEq K] +abbrev Computation (K R : Type) (n : Nat) := Sampling K (fun _ => Digest32) R n + +/-- Memo execution never removes or changes an already populated coordinate. -/ +theorem memo_extends (table : K → Digest32) {n : Nat} (p : Computation K R n) + (cache : K → Option Digest32) {key : K} {answer : Digest32} + (stored : cache key = some answer) : + (Sampling.eval table (memo p cache)).2 key = some answer := by + induction p generalizing cache with + | ret r => exact stored + | draw input next ih => + cases hit : cache input with + | some value => + simp only [memo,hit,Sampling.eval_pad] + exact ih value cache stored + | none => + simp only [memo,hit,Sampling.eval] + apply ih (table input) + by_cases same : key=input + · subst key + simp only [hit] at stored + cases stored + · simpa only [put_other _ _ _ _ same] using stored + +/-- Stronger than the requested consistent-cache version: no consistency +premise is needed, since the alarm and memo follow identical cached answers. -/ +theorem target_support (table : K → Digest32) (targets : Finset Digest32) {n : Nat} + (p : Computation K R n) (cache : K → Option Digest32) + (quiet : PublicCompressionCouplingTargets.alarm table targets p cache = false) + {key : K} {answer : Digest32} + (stored : (Sampling.eval table (memo p cache)).2 key = some answer) + (target : answer ∈ targets) : cache key = some answer := by + induction p generalizing cache with + | ret r => exact stored + | draw input next ih => + cases hit : cache input with + | some value => + simp only [memo,hit,Sampling.eval_pad] at stored + simp only [PublicCompressionCouplingTargets.alarm,hit] at quiet + exact ih value cache quiet stored + | none => + simp only [PublicCompressionCouplingTargets.alarm,hit] at quiet + have parts := Bool.or_eq_false_iff.mp quiet + have fresh := of_decide_eq_false parts.1 + simp only [memo,hit,Sampling.eval] at stored + have old := ih (table input) (put cache input (table input)) parts.2 stored + by_cases same : key=input + · subst key + simp only [put_self,Option.some.injEq] at old + exact False.elim (fresh (old.symm ▸ target)) + · simpa only [put_other _ _ _ _ same] using old + + theorem put_consistent (table : K → Digest32) (cache : K → Option Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) (input : K) : + ∀ key answer, (put cache input (table input)) key=some answer → table key=answer := by + intro key answer stored + by_cases same : key=input + · subst key + simpa only [put_self,Option.some.injEq] using stored + · exact consistent key answer (by simpa only [put_other _ _ _ _ same] using stored) + +/-- All actual original-table trace entries are recorded by the completed memo +cache. Consistency is an interpreter invariant, proved for public execution +from its empty initial cache, not a soundness premise. -/ +theorem trace_recorded (table : K → Digest32) {n : Nat} (p : Computation K R n) + (cache : K → Option Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) + {key : K} {answer : Digest32} + (member : (⟨key,answer⟩ : Sigma (fun _ : K => Digest32)) ∈ (Sampling.execute table p).2) : + (Sampling.eval table (memo p cache)).2 key=some answer := by + induction p generalizing cache with + | ret r => simp [Sampling.execute] at member + | draw input next ih => + simp only [Sampling.execute,List.mem_cons] at member + cases hit : cache input with + | some value => + simp only [memo,hit,Sampling.eval_pad] + have actual := consistent input value hit + rcases member with equal | later + · have sameKey : key=input := congrArg Sigma.fst equal + have sameAnswer : answer=table input := + congrArg (fun entry : Sigma (fun _ : K => Digest32) => entry.2) equal + subst key + subst answer + apply memo_extends + simpa only [actual] using hit + · rw [← actual] + exact ih (table input) cache consistent later + | none => + simp only [memo,hit,Sampling.eval] + rcases member with equal | later + · have sameKey : key=input := congrArg Sigma.fst equal + have sameAnswer : answer=table input := + congrArg (fun entry : Sigma (fun _ : K => Digest32) => entry.2) equal + subst key + subst answer + apply memo_extends + exact put_self _ _ _ + · exact ih (table input) (put cache input (table input)) + (put_consistent table cache consistent input) later + +/-- Converse to trace_recorded: completed memo entries were either present +initially or were returned by an actual original-table execution query. -/ +theorem memo_trace_origin (table : K → Digest32) {n : Nat} (p : Computation K R n) + (cache : K → Option Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) + {key : K} {answer : Digest32} + (stored : (Sampling.eval table (memo p cache)).2 key=some answer) : + cache key=some answer ∨ + (⟨key,answer⟩ : Sigma (fun _ : K => Digest32)) ∈ (Sampling.execute table p).2 := by + induction p generalizing cache with + | ret r => exact Or.inl stored + | draw input next ih => + cases hit : cache input with + | some value => + simp only [memo,hit,Sampling.eval_pad] at stored + have actual := consistent input value hit + rcases ih value cache consistent stored with old | queried + · exact Or.inl old + · apply Or.inr + simp only [Sampling.execute] + apply List.mem_cons_of_mem + simpa only [actual] using queried + | none => + simp only [memo,hit,Sampling.eval] at stored + rcases ih (table input) (put cache input (table input)) + (put_consistent table cache consistent input) stored with old | queried + · by_cases same : key=input + · subst key + simp only [put_self,Option.some.injEq] at old + subst answer + exact Or.inr (by simp [Sampling.execute]) + · exact Or.inl (by simpa only [put_other _ _ _ _ same] using old) + · exact Or.inr (by simpa only [Sampling.execute] using List.mem_cons_of_mem _ queried) + +theorem memo_empty_trace (table : K → Digest32) {n : Nat} (p : Computation K R n) + {key : K} {answer : Digest32} + (stored : (Sampling.eval table (memo p (fun _ => none))).2 key=some answer) : + (⟨key,answer⟩ : Sigma (fun _ : K => Digest32)) ∈ (Sampling.execute table p).2 := by + rcases memo_trace_origin table p (fun _ => none) + (by intro key value impossible; cases impossible) stored with impossible | queried + · cases impossible + · exact queried + +#print axioms memo_trace_origin +#print axioms memo_empty_trace + + theorem trace_target_initial (table : K → Digest32) (targets : Finset Digest32) + {n : Nat} (p : Computation K R n) (cache : K → Option Digest32) + (consistent : ∀ key answer, cache key=some answer → table key=answer) + (quiet : PublicCompressionCouplingTargets.alarm table targets p cache=false) + {key : K} {answer : Digest32} + (member : (⟨key,answer⟩ : Sigma (fun _ : K => Digest32)) ∈ (Sampling.execute table p).2) + (target : answer ∈ targets) : cache key=some answer := + target_support table targets p cache quiet (trace_recorded table p cache consistent member) target + +open Classical in +/-- Any target-valued actual private seed inspection draw was already sampled +in the public pinned-simulator phase. The public cache consistency is derived +here from actual empty-cache memo execution. -/ +theorem inspected_seed_target_public {R : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) + (table : PublicCompressionCouplingMixed.Key Q → Digest32) + (quiet : PublicCompressionCouplingMixed.hiddenGuess Q iv p counted table=false) + {input : Node} {answer : Digest32} + (member : (⟨Sum.inl input,answer⟩ : Sigma (fun _ : PublicCompressionCouplingMixed.Key Q => Digest32)) ∈ + (Sampling.execute table (PublicCompressionCouplingMixed.privateInspection Q iv + (Sampling.eval table (memo (PublicCompressionCouplingMixed.certifiedPublic Q iv p counted) + (fun _ => none))).1)).2) + (target : answer ∈ PublicCompressionCouplingMixed.publicCVTargets + (Sampling.eval table (memo (PublicCompressionCouplingMixed.certifiedPublic Q iv p counted) + (fun _ => none))).1.val.observations) : + (Sampling.eval table (memo (PublicCompressionCouplingMixed.certifiedPublic Q iv p counted) + (fun _ => none))).2 (.inl input)=some answer := by + apply trace_target_initial table _ _ _ _ quiet member target + exact memo_eval_consistent _ _ table (by intro key value impossible; cases impossible) + +#print axioms target_support +#print axioms trace_recorded +#print axioms inspected_seed_target_public +end Whir.PublicCompressionCouplingTargetCache diff --git a/verification/whir/Whir/PublicCompressionCouplingTargets.lean b/verification/whir/Whir/PublicCompressionCouplingTargets.lean new file mode 100644 index 000000000..44c22d5f3 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingTargets.lean @@ -0,0 +1,121 @@ +import Whir.PublicCompressionCouplingResidual + +/-! Fresh-target probabilities for literal uniform finite tables and their +actual adaptive memo caches. In particular, these bounds apply to private +prefix inspection conditional on the entire public view. -/ +namespace Whir.PublicCompressionCouplingTargets +open FiatShamirGame TypedOracleCompiler TypedFiatShamirGame RawOracleCoupling + +variable {K R : Type} [DecidableEq K] +abbrev Computation (K R : Type) (n : Nat) := Sampling K (fun _ => Digest32) R n + +noncomputable def alarm (table : K → Digest32) (targets : Finset Digest32) {n : Nat} : + Computation K R n → (K → Option Digest32) → Bool + | .ret _, _ => false + | .draw key next, cache => + match cache key with + | some answer => alarm table targets (next answer) cache + | none => decide (table key ∈ targets) || + alarm table targets (next (table key)) (put cache key (table key)) + +noncomputable def risk (targets : Finset Digest32) {n : Nat} : + Computation K R n → (K → Option Digest32) → ℚ + | .ret _, _ => 0 + | .draw key next, cache => + match cache key with + | some answer => risk targets (next answer) cache + | none => average (fun answer : Digest32 => if answer ∈ targets then 1 else + risk targets (next answer) (put cache key answer)) + +theorem risk_bound (targets : Finset Digest32) {n : Nat} + (p : Computation K R n) (cache : K → Option Digest32) : + risk targets p cache ≤ (n : ℚ)*targets.card/2^256 := by + induction p generalizing cache with + | ret r => simp only [risk]; positivity + | @draw n key next ih => + cases hit : cache key with + | some answer => + simp only [risk,hit] + have h := ih answer cache + have hn : (0 : ℚ) ≤ (targets.card : ℚ)/2^256 := by positivity + push_cast + linarith + | none => + simp only [risk,hit] + calc + _ ≤ average (fun answer : Digest32 => + (if answer ∈ targets then (1:ℚ) else 0) + (n:ℚ)*targets.card/2^256) := by + apply average_mono + intro answer + have ht := ih answer (put cache key answer) + by_cases bad : answer ∈ targets + · simp only [bad,↓reduceIte] + have hn : (0:ℚ) ≤ (n:ℚ)*targets.card/2^256 := by positivity + linarith + · simpa only [bad,↓reduceIte,zero_add] using ht + _ = (targets.card : ℚ)/2^256 + (n:ℚ)*targets.card/2^256 := by + rw [average_add,PublicMerkleProbability.uniform_target_probability,average_const] + _ = _ := by push_cast; ring + +variable [Fintype K] + +theorem table_alarm_eq_risk (targets : Finset Digest32) {n : Nat} + (p : Computation K R n) (cache : K → Option Digest32) : + average (fun table : K → Digest32 => + if alarm (overlay cache table) targets p cache then (1:ℚ) else 0) = + risk targets p cache := by + classical + induction p generalizing cache with + | ret r => simp [alarm,risk,average_const] + | draw key next ih => + cases hit : cache key with + | some answer => simp only [alarm,risk,hit]; exact ih answer cache + | none => + rw [overlay_average cache key hit + (fun table => if alarm table targets (.draw key next) cache then (1:ℚ) else 0)] + simp only [risk,hit] + apply congrArg average + funext answer + by_cases bad : answer ∈ targets + · simp [alarm,hit,overlay,bad,average_const] + · rw [← ih answer (put cache key answer)] + simp only [bad,↓reduceIte] + apply congrArg average + funext table + simp [alarm,hit,overlay,bad] + +omit [DecidableEq K] [Fintype K] in + theorem expectation_le_const {T : Type} {n : Nat} + (p : Sampling K (fun _ => Digest32) T n) (payoff : T → ℚ) (bound : ℚ) + (h : ∀ result, payoff result ≤ bound) : Sampling.expectation payoff p ≤ bound := by + induction p with + | ret r => exact h r + | draw key next ih => + exact le_trans (average_mono (fun answer => ih answer)) (le_of_eq (average_const bound)) + +/-- Targets may depend on all public outputs, chosen inputs and the result. +Only the size cap is used, and inspection can branch on every private reply. -/ +theorem adaptive_posthoc_bound {T : Type} {publicCap privateCap targetCap : Nat} + (publicCalls : Computation K R publicCap) + (privateCalls : R → Computation K T privateCap) (targets : R → Finset Digest32) + (size : ∀ result, (targets result).card ≤ targetCap) : + average (fun table : K → Digest32 => + let result := Sampling.eval table (memo publicCalls (fun _ => none)) + if alarm table (targets result.1) (privateCalls result.1) result.2 then (1:ℚ) else 0) ≤ + (privateCap:ℚ)*targetCap/2^256 := by + have residual := PublicCompressionCouplingResidual.memo_residual publicCalls (fun _ => none) + (fun result table => if alarm table (targets result.1) (privateCalls result.1) + result.2 then (1:ℚ) else 0) + simp only [overlay_empty] at residual + dsimp only at residual ⊢ + apply le_trans residual.le + apply expectation_le_const + intro result + rw [table_alarm_eq_risk] + apply le_trans (risk_bound _ _ _) + apply div_le_div_of_nonneg_right _ (by positivity) + exact mul_le_mul_of_nonneg_left (by exact_mod_cast size result.1) (by positivity) + +#print axioms table_alarm_eq_risk +#print axioms adaptive_posthoc_bound +end Whir.PublicCompressionCouplingTargets diff --git a/verification/whir/Whir/PublicCompressionCouplingTerminalSeedOrigin.lean b/verification/whir/Whir/PublicCompressionCouplingTerminalSeedOrigin.lean new file mode 100644 index 000000000..e72bd9c66 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingTerminalSeedOrigin.lean @@ -0,0 +1,87 @@ +import Whir.PublicCompressionCouplingPublicCache + +/-! A terminal Seed coordinate in the causal cache can only come from an +actual public fallback call. Hidden construction prefix nodes are nonterminal; +thus causal/private sampling cannot manufacture cached-miss provenance. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed RawOracleCoupling +open TypedOracleCompiler (Sampling) +set_option backward.isDefEq.respectTransparency false + + theorem bodyCalls_no_terminal (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (input : Node) (terminal : isTerminal input) (answer : Digest32) : + (⟨.inl input,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∉ + (Sampling.execute (oracle seedTable ro) + (bodyCalls Q iv (DuplexEncoding.plan coordinate).dropLast)).2 := by + rw [bodyCalls_trace] + intro member + obtain ⟨entry,record,equal⟩ := List.mem_map.mp member + have nodes : entry.1=input := Sum.inl.inj (congrArg Sigma.fst equal) + rcases entry with ⟨node,digest⟩ + dsimp only at nodes + subst node + rw [inspection_body_nodes Q seedTable ro iv coordinate valid] at record + obtain ⟨node,nodeMember,equal⟩ := List.mem_map.mp record + have nodes := congrArg Prod.fst equal + dsimp only at nodes + subst node + have body := (traceHistory_valid (compressionOf seedTable) iv coordinate.history valid.1).1.body + exact body_no_terminal body input (List.mem_reverse.mp nodeMember) terminal + + theorem causalConstruction_no_terminal_seed (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (budget : pathCost coordinate ≤ Q) (input : Node) (terminal : isTerminal input) (answer : Digest32) : + (⟨.inl input,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∉ + (Sampling.execute (oracle seedTable ro) (causalConstruction Q iv coordinate valid budget)).2 := by + rw [causalConstruction_trace,List.mem_append] + rintro (prefixMember | rawMember) + · exact bodyCalls_no_terminal Q seedTable ro iv coordinate valid input terminal answer prefixMember + · have equal := List.mem_singleton.mp rawMember + have keys := congrArg Sigma.fst equal + cases keys + + theorem causal_terminal_seed_public_draw (Q : Nat) (seedTable : Seed) (ro : RawKey Q → Digest32) + (iv : Digest32) (log : PublicLog) (p : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining p) (input : Node) + (terminal : isTerminal input) (answer : Digest32) + (member : (⟨.inl input,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (causalCompile Q iv log p remaining cap counted)).2) : + (⟨.inl input,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (compile Q iv log p remaining cap counted)).2 := by + induction p generalizing log remaining with + | done result => simp [causalCompile,Sampling.execute] at member + | ask query next ih => + cases query with + | primitive purpose node => + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] at member + simp only [compile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] + rcases member with first | later + · exact Or.inl first + · exact Or.inr (ih _ _ _ _ _ later) + | construction coordinate valid => + simp only [causalCompile,Sampling.execute_pad,Sampling.execute_bind,execute_map_trace,List.mem_append] at member + rcases member with first | later + · exact False.elim (causalConstruction_no_terminal_seed Q seedTable ro iv coordinate valid + (counted.1.trans cap) input terminal answer first) + · have publicDraw := ih _ log _ _ _ later + simp only [causalConstruction_eval,oracle] at publicDraw + simp only [compile,Sampling.execute_pad,Sampling.execute,execute_map_trace] + exact List.mem_cons_of_mem _ publicDraw + + theorem actual_terminal_seed_public_cache {R : Type} (Q : Nat) [DecidableEq (Key Q)] + (iv : Digest32) (p : Program R) + (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + {input : Node} (terminal : isTerminal input) {answer : Digest32} + (stored : (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 (.inl input)=some answer) : + (Sampling.eval (oracle seedTable ro) + (memo (compile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 (.inl input)=some answer := by + have causal := PublicCompressionCouplingTargetCache.memo_empty_trace _ _ stored + have publicDraw := causal_terminal_seed_public_draw Q seedTable ro iv [] p Q (by rfl) counted input terminal answer causal + exact PublicCompressionCouplingTargetCache.trace_recorded _ _ (fun _ => none) + (by intro key digest impossible; cases impossible) publicDraw + +#print axioms actual_terminal_seed_public_cache +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingTerminalSupport.lean b/verification/whir/Whir/PublicCompressionCouplingTerminalSupport.lean new file mode 100644 index 000000000..d3229d2cc --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingTerminalSupport.lean @@ -0,0 +1,124 @@ +import Whir.PublicCompressionCouplingROOrigins +import Whir.PublicCompressionCouplingInspectionSupport +import Whir.PublicCompressionCouplingLabels + +/-! Actual consumed raw-key terminal witnesses have all seed nodes recorded in +the causal cache. Target-matching construction bodies are public on the actual +hidden-guess complement; publicly recognized bodies are public already. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed RawOracleCoupling +open TypedOracleCompiler (Sampling) +set_option backward.isDefEq.respectTransparency false + +private theorem actual_raw_key_dictionary (Q : Nat) : + (fun a b : RawKey Q => Classical.propDecidable (a=b)) = + (inferInstance : DecidableEq (RawKey Q)) := Subsingleton.elim _ _ + + theorem publicBody_cache_nodes {Q : Nat} {seedTable : Seed} {ro : RawKey Q → Digest32} + {cache : Key Q → Option Digest32} {log : PublicLog} {cv : Digest32} {ns : List Node} + (body : PublicBody log cv ns) (witnessed : Witnessed Q seedTable cache log) + (consistent : ∀ key answer, cache key=some answer → oracle seedTable ro key=answer) : + ∀ n ∈ ns, cache (.inl n)=some (seedTable n) := by + induction body with + | seed member valid => + intro n hn + have nodes := List.mem_singleton.mp hn + subst n + have stored := Witnessed.nonterminal_stored witnessed member + (fun terminal => terminal_not_seed terminal valid) + have actual := consistent _ _ stored + simp only [oracle] at actual + simpa only [actual] using stored + | step member internal child ih => + intro n hn + rcases List.mem_cons.mp hn with equal | later + · subst n + have stored := Witnessed.nonterminal_stored witnessed member + (fun terminal => terminal_not_internal terminal internal) + have actual := consistent _ _ stored + simp only [oracle] at actual + simpa only [actual] using stored + · exact ih n later + +open Classical in + theorem construction_cache_nodes {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + {construction : InspectedConstruction} + (member : construction ∈ (Sampling.eval (oracle seedTable ro) + (causalCompile Q iv [] p Q (by rfl) counted)).2) : + ∀ n ∈ (traceHistory (compressionOf seedTable) iv construction.coordinate.history).nodes, + (Sampling.eval (oracle seedTable ro) (memo (causalCompile Q iv [] p Q (by rfl) counted) + (fun _ => none))).2 (.inl n)=some (seedTable n) := by + have inspected : construction ∈ Sampling.eval (oracle seedTable ro) + (inspect Q iv (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) := by + simpa only [causalCompile_eval] using member + intro node nodeMember + have prefixStored := actual_causal_prefix_stored Q iv p counted _ member + (node := node) (answer := seedTable node) + rw [actual_raw_key_dictionary Q] at prefixStored + apply prefixStored + rw [inspect_construction_nodes Q seedTable ro iv _ inspected] + exact List.mem_map.mpr ⟨node,by simpa only [List.mem_reverse] using nodeMember,rfl⟩ + +/-- The complete consumed-terminal graph facts needed for source-aware joint +alignment. These are derived below from the actual compiler/cache, not supplied +as a primitive security hypothesis. -/ +def TerminalSupport (Q : Nat) (seedTable : Seed) (cache : Key Q → Option Digest32) + (log : PublicLog) (targets : Finset Digest32) (key : RawKey Q) : Prop := + ∃ input rest, Complete (input::rest) ∧ Tree (compressionOf seedTable) input.cv rest ∧ + extract (input::rest)=some (expandKey key) ∧ + (∀ n ∈ rest, cache (.inl n)=some (seedTable n)) ∧ + (input.cv ∈ targets → PublicBody log input.cv rest) + +open Classical in + theorem actual_terminal_support {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (quiet : hiddenGuess Q iv p counted (oracle seedTable ro)=false) + {key : RawKey Q} {answer : Digest32} + (stored : (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 (.inr key)=some answer) : + TerminalSupport Q seedTable + (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 + (finalLog [] (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) + (publicCVTargets (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) key := by + have trace := PublicCompressionCouplingTargetCache.memo_empty_trace _ _ stored + have origin := causalCompile_raw_origin Q seedTable ro iv [] p Q (by rfl) counted + (by intro n d member; cases member) trace + have witnessed := actual_causal_cache_witnessed Q iv p counted seedTable ro + rw [actual_raw_key_dictionary Q] at witnessed + have consistent := memo_eval_consistent (causalCompile Q iv [] p Q (by rfl) counted) + (fun _ => none) (oracle seedTable ro) (by intro k d impossible; cases impossible) + rcases origin with publicOrigin | privateOrigin + · obtain ⟨input,rest,complete,tree,extracted,body⟩ := publicOrigin + exact ⟨input,rest,complete,tree,extracted,publicBody_cache_nodes body witnessed consistent,fun _ => body⟩ + · obtain ⟨construction,member,budget,equal⟩ := privateOrigin + subst key + let c := compressionOf seedTable + let history := traceHistory c iv construction.coordinate.history + let input := terminalNode history.state.cv construction.coordinate.terminal + refine ⟨input,history.nodes,?_,?_,?_,construction_cache_nodes Q iv p counted seedTable ro member,?_⟩ + · exact coordinateTree_complete c iv construction.coordinate construction.valid.1 + · change Tree c (terminalNode history.state.cv construction.coordinate.terminal).cv history.nodes + rw [terminalNode_cv] + exact (traceHistory_valid c iv construction.coordinate.history construction.valid.1).1 + · simpa only [expand_constructionKey,coordinateTree,input,history,c] using + coordinateTree_key c iv construction.coordinate construction.valid + · intro target + have inspected : construction ∈ Sampling.eval (oracle seedTable ro) + (inspect Q iv (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) := by + simpa only [causalCompile_eval] using member + have rootTarget : evalHistory c iv construction.coordinate.history ∈ + publicCVTargets (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations := by + simpa only [input,history,terminalNode_cv,traceHistory_cv] using target + simpa only [input,history,c,terminalNode_cv,traceHistory_cv] using + actual_inspection_publicBody Q iv p counted seedTable ro quiet inspected rootTarget + +#print axioms actual_terminal_support +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionCouplingTerminalUnique.lean b/verification/whir/Whir/PublicCompressionCouplingTerminalUnique.lean new file mode 100644 index 000000000..9a6b89e9b --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingTerminalUnique.lean @@ -0,0 +1,76 @@ +import Whir.PublicCompressionCouplingCoordinates + +/-! Reverse terminal-coordinate uniqueness on actual consumed seed nodes. +Together with forward full-key uniqueness, this is the injective cache graph +needed to align repeated terminal calls and construction RO coordinates. -/ +namespace Whir.PublicCompressionCouplingRecognition +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingMixed + + theorem expandShort_injective {α : Type} {Q : Nat} : + Function.Injective (expandShort (α:=α) (Q:=Q)) := by + rintro ⟨n,f⟩ ⟨m,g⟩ equal + have lengths : n=m := Fin.ext (by simpa only [expandShort,List.length_ofFn] using congrArg List.length equal) + cases lengths + have functions : f=g := List.ofFn_injective equal + cases functions + rfl + + theorem expandKey_injective {Q : Nat} : Function.Injective (expandKey (Q:=Q)) := by + intro a b equal + apply Prod.ext + · exact expandShort_injective (congrArg Extracted.message equal) + · exact expandShort_injective (congrArg Extracted.template equal) + + theorem Tree.output_unique {seedTable : Seed} {a b : Digest32} {ns ms : List Node} + (left : Tree (compressionOf seedTable) a ns) (right : Tree (compressionOf seedTable) b ms) + (same : a=b) + (injective : ∀ n ∈ ns, ∀ m ∈ ms, seedTable n = seedTable m → n=m) : ns=ms := by + induction left generalizing b ms with + | seed node valid => + cases right with + | seed other valid' => + have nodes := injective node (by simp) other (by simp) same + subst other + rfl + | step other rest internal child => + have nodes := injective node (by simp) other (by simp) same + subst other + exact False.elim (seed_not_internal valid internal) + | step node rest valid child ih => + cases right with + | seed other seed => + have nodes := injective node (by simp) other (by simp) same + subst other + exact False.elim (seed_not_internal seed valid) + | step other rest' internal child' => + have nodes := injective node (by simp) other (by simp) same + subst other + have tails := ih child' rfl (fun n hn m hm values => + injective n (List.mem_cons_of_mem _ hn) m (List.mem_cons_of_mem _ hm) values) + subst rest' + rfl + +/-- A terminal's two complete seed-tree witnesses cannot allocate different +raw RO keys when the actually consumed mixed Seed cache is answer-injective. -/ + theorem terminal_rawKey_unique {Q : Nat} {seedTable : Seed} {input : Node} + {leftKey rightKey : RawKey Q} {ns ms : List Node} + (left : Tree (compressionOf seedTable) input.cv ns) + (right : Tree (compressionOf seedTable) input.cv ms) + (leftExtract : extract (input::ns) = some (expandKey leftKey)) + (rightExtract : extract (input::ms) = some (expandKey rightKey)) + (cache : Key Q → Option Digest32) + (leftStored : ∀ n ∈ ns, cache (.inl n) = some (seedTable n)) + (rightStored : ∀ n ∈ ms, cache (.inl n) = some (seedTable n)) + (injective : ∀ a b d, cache a=some d → cache b=some d → a=b) : leftKey=rightKey := by + have trees := Tree.output_unique left right rfl (by + intro n hn m hm values + have keys := injective (.inl n) (.inl m) (seedTable n) (leftStored n hn) + (by simpa only [values] using rightStored m hm) + exact Sum.inl.inj keys) + subst ms + apply expandKey_injective + exact Option.some.inj (leftExtract.symm.trans rightExtract) + +#print axioms terminal_rawKey_unique +end Whir.PublicCompressionCouplingRecognition diff --git a/verification/whir/Whir/PublicCompressionModeSecurity.lean b/verification/whir/Whir/PublicCompressionModeSecurity.lean new file mode 100644 index 000000000..94168a087 --- /dev/null +++ b/verification/whir/Whir/PublicCompressionModeSecurity.lean @@ -0,0 +1,44 @@ +import Whir.PublicCompressionCouplingActualCausalBound + +/-! Proved whole-view security of the pinned public-compression simulator. +The causal ledger charges output collisions, public late links, and hidden-state +guesses under the same aggregate `Counts Q` cap. Birthday bounds alone control +only subevents; the whole-view bound is `duplexModeLoss`. -/ +namespace Whir.FiatShamirGame + +/-- Closed form of the actual mode ledger. Subtraction takes place in ℚ, not ℕ. -/ +theorem duplexModeLoss_eq (Q : Nat) : + duplexModeLoss Q = min 1 ((2 * (Q : ℚ)^2 - (Q : ℚ)) / (2^256 : ℚ)) := by + unfold duplexModeLoss + rw [Nat.cast_choose_two] + congr 1 + ring + +theorem duplexModeLoss_nonneg (Q : Nat) : 0 ≤ duplexModeLoss Q := by + unfold duplexModeLoss + apply le_min <;> positivity + +theorem duplexModeLoss_le_one (Q : Nat) : duplexModeLoss Q ≤ 1 := + min_le_left _ _ + +end Whir.FiatShamirGame + +namespace Whir.DuplexPublicSimulator +open FiatShamirGame DuplexModeGame + +/-- The actual fixed simulator has a proved unrestricted adaptive whole-view +certificate. No external random-compression distinguishing premise is needed. -/ +theorem modeSecurity (Q : Nat) (iv : Digest32) : + letI := seedFintype + PublicCompressionModeBound Q Seed State (simulator Q) iv := by + let _ := seedFintype + constructor + intro AdvCoins Result _ adversary counted D + exact PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss + Q iv adversary counted D + +#print axioms modeSecurity +#print axioms FiatShamirGame.duplexModeLoss_eq +#print axioms FiatShamirGame.duplexModeLoss_nonneg +#print axioms FiatShamirGame.duplexModeLoss_le_one +end Whir.DuplexPublicSimulator diff --git a/verification/whir/Whir/ReedSolomonExtraction.lean b/verification/whir/Whir/ReedSolomonExtraction.lean new file mode 100644 index 000000000..1d0205a07 --- /dev/null +++ b/verification/whir/Whir/ReedSolomonExtraction.lean @@ -0,0 +1,1191 @@ +import Whir.AdditiveColumn +import CompPoly.Univariate.ReedSolomon.GaoCorrectness +import CompPoly.Univariate.ToPoly.Degree + +/-! Executable unique-radius decoding, separated from access to committed rows. +This invokes the proved CompPoly Gao algorithm, not a classical witness selector. +`countedDecode` composes actual nodal/Lagrange construction, coefficient +convolution, textbook division/remainder and Euclidean cofactors. Its value is +the original decoder and its field-arithmetic cost has a polynomial bound in +block length, deriving intermediate widths rather than assuming trace bounds. +An explicit parameter charges each field inverse. Comparisons, allocation, +copying and prover responses are not field arithmetic. A decoded polynomial +alone is not a base-word WHIR witness or an accessible committed row. -/ +namespace Whir.ReedSolomonExtraction +open Polynomial CompPoly +open scoped BigOperators + +variable {F : Type*} [Field F] [BEq F] [LawfulBEq F] [DecidableEq F] + +abbrev Domain := CompPoly.ReedSolomon.Domain F + +/-- The actual executable decoder on an explicitly supplied received word. -/ +def decode (k : Nat) (domain : Domain (F := F)) (received : Vector F domain.n) : + Option (CPolynomial F) := + CompPoly.ReedSolomon.Gao.decode k domain received + +/-- Turn a bounded executable polynomial into the message format used by Gao. -/ +def message (k : Nat) (p : CPolynomial F) : Vector F k := + Vector.ofFn fun i => p.coeff i + +omit [DecidableEq F] in +theorem message_polynomial (k : Nat) (p : CPolynomial F) (degree : p.degree < k) : + CompPoly.ReedSolomon.messagePoly (message k p) = p := + CompPoly.ReedSolomon.messagePoly_ofFn_coeff k p degree + +/-- This interface requires the whole received word. It supplies no digest-to-word oracle. -/ +theorem decode_recovers (k : Nat) (domain : Domain (F := F)) + (received : Vector F domain.n) (p : CPolynomial F) + (dimension : k < domain.n) (degree : p.degree < k) + (radius : 2 * hammingDist received.get (fun i => p.toPoly.eval domain.val[i]) ≤ + domain.n - k) : decode k domain received = some p := by + have encoded : (CompPoly.ReedSolomon.encode domain (message k p)).get = + fun i => p.toPoly.eval domain.val[i] := by + funext i + rw [CompPoly.ReedSolomon.encode_get, message_polynomial k p degree, + CPolynomial.eval_toPoly] + have result := CompPoly.ReedSolomon.Gao.decode_eq_some k domain received dimension + (message k p) (by rwa [encoded]) + simpa [decode, message_polynomial k p degree] using result + +/-- Success certifies unique-radius proximity, not the WHIR public-claim relation. -/ +theorem decode_proximity (k : Nat) (domain : Domain (F := F)) + (received : Vector F domain.n) (p : CPolynomial F) + (dimension : k < domain.n) (success : decode k domain received = some p) : + p.degree < k ∧ hammingDist received.get (fun i => p.toPoly.eval domain.val[i]) ≤ + (domain.n - k) / 2 := by + obtain ⟨msg, equal, distance⟩ := + CompPoly.ReedSolomon.Gao.decode_sound k domain received dimension p success + have encoded : (CompPoly.ReedSolomon.encode domain msg).get = + fun i => p.toPoly.eval domain.val[i] := by + funext i + rw [CompPoly.ReedSolomon.encode_get, equal, CPolynomial.eval_toPoly] + refine ⟨?_, by rwa [encoded] at distance⟩ + rw [← equal] + exact CompPoly.ReedSolomon.messagePoly_degree_lt msg + +/-- Interleaved lanes share a domain. Decoding does not mix observations from different candidate words. -/ +def decodeLanes (k lanes : Nat) (domain : Domain (F := F)) + (received : Fin lanes → Vector F domain.n) : Array (Option (CPolynomial F)) := + Array.ofFn fun lane => decode k domain (received lane) + +theorem decodeLanes_recovers (k lanes : Nat) (domain : Domain (F := F)) + (received : Fin lanes → Vector F domain.n) (p : Fin lanes → CPolynomial F) + (dimension : k < domain.n) (degree : ∀ lane, (p lane).degree < k) + (radius : ∀ lane, 2 * hammingDist (received lane).get + (fun i => (p lane).toPoly.eval domain.val[i]) ≤ domain.n - k) : + decodeLanes k lanes domain received = Array.ofFn (fun lane => some (p lane)) := by + unfold decodeLanes + congr 1 + funext lane + exact decode_recovers k domain (received lane) (p lane) dimension (degree lane) (radius lane) + +omit [BEq F] [LawfulBEq F] in +/-- A single common error support implies every lane's decoder radius. No random lane aggregation is assumed. -/ +theorem lane_radius_of_common_support (k lanes : Nat) (domain : Domain (F := F)) + (received : Fin lanes → Vector F domain.n) (p : Fin lanes → CPolynomial F) + (errors : Finset (Fin domain.n)) + (outside : ∀ lane i, i ∉ errors → (received lane).get i = (p lane).toPoly.eval domain.val[i]) + (radius : 2 * errors.card ≤ domain.n - k) (lane : Fin lanes) : + 2 * hammingDist (received lane).get (fun i => (p lane).toPoly.eval domain.val[i]) ≤ + domain.n - k := by + have subset : (Finset.univ.filter fun i => + (received lane).get i ≠ (p lane).toPoly.eval domain.val[i]) ⊆ errors := by + intro i hi + by_contra missing + exact (Finset.mem_filter.mp hi).2 (outside lane i missing) + have count := Finset.card_le_card subset + simp only [hammingDist] at * + omega + +/-! Coefficient-level refinement of the actual naive multiplication backend. +The count includes every scalar multiplication and every padded coefficient +addition in `Raw.mulRaw`, including zero coefficients. Trimming comparisons, +allocation, copying and word-level field instructions are separate costs. -/ + +/-- Instrument the convolution fold without substituting a faster, different +polynomial multiplication algorithm. -/ +def countedMulFold (q : CPolynomial.Raw F) : + List (F × Nat) → CPolynomial.Raw F → CPolynomial.Raw F × Nat + | [], acc => (acc, 0) + | (a, i) :: rest, acc => + let shifted := (CPolynomial.Raw.smul a q).mulPowX i + let tail := countedMulFold q rest (acc.addRaw shifted) + (tail.1, q.size + max acc.size shifted.size + tail.2) + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedMulFold_value (q : CPolynomial.Raw F) + (terms : List (F × Nat)) (acc : CPolynomial.Raw F) : + (countedMulFold q terms acc).1 = + terms.foldl (fun acc pair => + acc.addRaw ((CPolynomial.Raw.smul pair.1 q).mulPowX pair.2)) acc := by + induction terms generalizing acc with + | nil => rfl + | cons term rest ih => simp [countedMulFold, ih] + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +/-- The width is an actual upper bound on indices in the convolution, not the +field cardinality or a unit-cost polynomial-operation counter. -/ +theorem countedMulFold_cost (q : CPolynomial.Raw F) + (terms : List (F × Nat)) (acc : CPolynomial.Raw F) (width : Nat) + (indices : ∀ pair ∈ terms, pair.2 < width) + (accSize : acc.size ≤ width + q.size) : + (countedMulFold q terms acc).2 ≤ terms.length * (width + 2 * q.size) := by + induction terms generalizing acc with + | nil => simp [countedMulFold] + | cons term rest ih => + have index := indices term (by simp) + have shiftedSize : + ((CPolynomial.Raw.smul term.1 q).mulPowX term.2).size = term.2 + q.size := by + simp [CPolynomial.Raw.mulPowX, CPolynomial.Raw.smul] + have nextSize : (acc.addRaw + ((CPolynomial.Raw.smul term.1 q).mulPowX term.2)).size ≤ width + q.size := by + rw [CPolynomial.Raw.add_size, shiftedSize] + omega + have tail := ih (acc.addRaw + ((CPolynomial.Raw.smul term.1 q).mulPowX term.2)) + (fun pair hp => indices pair (by simp [hp])) nextSize + simp only [countedMulFold, List.length_cons, Nat.add_mul, shiftedSize] + omega + +def countedRawMul (p q : CPolynomial.Raw F) : CPolynomial.Raw F × Nat := + countedMulFold q p.zipIdx.toList #[] + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedRawMul_value (p q : CPolynomial.Raw F) : + (countedRawMul p q).1 = CPolynomial.Raw.mulRaw p q := by + rw [countedRawMul, countedMulFold_value] + simp only [CPolynomial.Raw.mulRaw, Array.foldl_toList] + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedRawMul_cost (p q : CPolynomial.Raw F) : + (countedRawMul p q).2 ≤ p.size * (p.size + 2 * q.size) := by + apply le_trans (countedMulFold_cost q p.zipIdx.toList #[] p.size ?_ (by simp)) ?_ + · intro pair hp + obtain ⟨i, hi, equal⟩ := List.mem_iff_getElem.mp hp + have bound : i < p.size := by simpa using hi + have pairIndex : pair.2 = i := by + rw [← equal] + simp + omega + · simp + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedRawMul_cost_of_size (p q : CPolynomial.Raw F) (width : Nat) + (left : p.size ≤ width) (right : q.size ≤ width) : + (countedRawMul p q).2 ≤ 3 * width ^ 2 := by + calc + _ ≤ p.size * (p.size + 2 * q.size) := countedRawMul_cost p q + _ ≤ width * (width + 2 * width) := + Nat.mul_le_mul left (Nat.add_le_add left (Nat.mul_le_mul_left 2 right)) + _ = 3 * width ^ 2 := by ring + +/-- Instrumented canonical multiplication returns exactly the polynomial used +by Gao and triangular extraction. Its field count is the raw convolution count. -/ +def countedMul (p q : CPolynomial F) : CPolynomial F × Nat := + let result := countedRawMul p.val q.val + (⟨result.1.trim, CPolynomial.Raw.Trim.isCanonical_trim _⟩, result.2) + +omit [DecidableEq F] in +theorem countedMul_value (p q : CPolynomial F) : + (countedMul p q).1 = p * q := by + apply CPolynomial.ext + change (countedRawMul p.val q.val).1.trim = _ + rw [countedRawMul_value] + rfl + +omit [DecidableEq F] in +theorem countedMul_cost (p q : CPolynomial F) (width : Nat) + (left : p.val.size ≤ width) (right : q.val.size ≤ width) : + (countedMul p q).2 ≤ 3 * width ^ 2 := + countedRawMul_cost_of_size p.val q.val width left right + +/-- Raw power uses the same repeated-multiplication specification as the +division backend, rather than pretending that constructing `X^k` is free. -/ +def countedRawPow (p : CPolynomial.Raw F) : Nat → CPolynomial.Raw F × Nat + | 0 => (CPolynomial.Raw.C 1, 0) + | n + 1 => + let previous := countedRawPow p n + let product := countedRawMul p previous.1 + (product.1.trim, previous.2 + product.2) + +omit [LawfulBEq F] [DecidableEq F] in +theorem countedRawPow_value (p : CPolynomial.Raw F) (n : Nat) : + (countedRawPow p n).1 = p ^ n := by + induction n with + | zero => rfl + | succ n ih => + simp only [countedRawPow, countedRawMul_value, ih, CPolynomial.Raw.pow_succ] + rfl + +theorem countedRawPow_X_cost (n : Nat) : + (countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) n).2 ≤ n * (4 * n + 8) := by + induction n with + | zero => simp [countedRawPow] + | succ n ih => + have sizePower : + (countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) n).1.size = n + 1 := by + rw [countedRawPow_value, CPolynomial.Raw.X_pow_eq_monomial_one] + simp [CPolynomial.Raw.monomial] + have product := countedRawMul_cost (CPolynomial.Raw.X : CPolynomial.Raw F) + (countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) n).1 + change (countedRawMul (CPolynomial.Raw.X : CPolynomial.Raw F) + (countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) n).1).2 ≤ + 2 * (2 + 2 * (countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) n).1.size) + at product + rw [sizePower] at product + change (countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) n).2 + + (countedRawMul CPolynomial.Raw.X + (countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) n).1).2 ≤ _ + nlinarith + +/-- Instrument the actual textbook long-division loop. Even the two powers +`X^k` in the source loop are charged, as are all coefficient negations and +padded additions. Fuel is the dividend's coefficient-array length. -/ +def countedDivAux : Nat → CPolynomial.Raw F → CPolynomial.Raw F → + (CPolynomial.Raw F × CPolynomial.Raw F) × Nat + | 0, p, _ => ((0, p), 0) + | n + 1, p, q => + if p.size < q.size then ((0, p), 0) else + let k := p.size - q.size + let power := countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) k + let shifted := countedRawMul q power.1 + let scaled := countedRawMul (CPolynomial.Raw.C p.leadingCoeff) shifted.1.trim + let residue := (p - scaled.1.trim).trim + let tail := countedDivAux n residue q + let term := countedRawMul (CPolynomial.Raw.C p.leadingCoeff) power.1 + ((tail.1.1 + term.1.trim, tail.1.2), + 2 * power.2 + shifted.2 + scaled.2 + term.2 + + scaled.1.trim.size + max p.size scaled.1.trim.size + + max tail.1.1.size term.1.trim.size + tail.2) + +omit [LawfulBEq F] [DecidableEq F] in +theorem countedDivAux_value (fuel : Nat) (p q : CPolynomial.Raw F) : + (countedDivAux fuel p q).1 = + CPolynomial.Raw.divModByMonicAux.go fuel p q := by + induction fuel generalizing p with + | zero => rfl + | succ fuel ih => + simp only [countedDivAux, CPolynomial.Raw.divModByMonicAux.go] + split_ifs + · rfl + · simp only [countedRawPow_value, countedRawMul_value] + rw [ih] + rfl + +omit [DecidableEq F] in +private theorem raw_trim_support (p : CPolynomial.Raw F) (width : Nat) + (zeros : ∀ i, width ≤ i → p.coeff i = 0) : p.trim.size ≤ width := by + let canonical : CPolynomial F := ⟨p.trim, CPolynomial.Raw.Trim.isCanonical_trim p⟩ + apply (CPolynomial.mem_degreeLT_iff_size_le (p := canonical)).mp + apply CPolynomial.mem_degreeLT.mpr + rw [CPolynomial.degree_lt_iff_coeff_zero] + intro i hi + exact (CPolynomial.Raw.Trim.coeff_eq_coeff p i).trans (zeros i hi) + +private theorem raw_shift_support (q : CPolynomial.Raw F) (k : Nat) : + (q * CPolynomial.Raw.X ^ k).size ≤ q.size + k := by + have support := raw_trim_support (q * CPolynomial.Raw.X ^ k) (q.size + k) (by + intro i hi + rw [CPolynomial.Raw.coeff_mul_X_pow] + split_ifs <;> simp_all; omega) + simpa only [CPolynomial.Raw.mul_is_trimmed] using support + +omit [DecidableEq F] in +private theorem raw_constant_support (a : F) (p : CPolynomial.Raw F) : + (CPolynomial.Raw.C a * p).size ≤ p.size := by + rw [CPolynomial.Raw.C_mul_eq_smul_trim] + exact (CPolynomial.Raw.Trim.size_le_size _).trans_eq (by + simp [CPolynomial.Raw.smul]) + +omit [DecidableEq F] in +private theorem raw_div_residual_support (p q : CPolynomial.Raw F) + (larger : q.size ≤ p.size) : + ((p - CPolynomial.Raw.C p.leadingCoeff * + (q * CPolynomial.Raw.X ^ (p.size - q.size))).trim).size ≤ p.size := by + rw [← CPolynomial.Raw.subScaledShift_eq_sub_C_mul_X_pow p q p.leadingCoeff + (p.size - q.size) (by omega)] + exact (CPolynomial.Raw.Trim.size_le_size _).trans_eq (by + simp) + +theorem countedDivAux_quotient_support (fuel width : Nat) (p q : CPolynomial.Raw F) + (inputSupport : p.size ≤ width) : + (countedDivAux fuel p q).1.1.size ≤ width + 1 := by + rw [countedDivAux_value] + induction fuel generalizing p with + | zero => simp [CPolynomial.Raw.divModByMonicAux.go] + | succ fuel ih => + simp only [CPolynomial.Raw.divModByMonicAux.go] + split_ifs with stop + · simp + · have residual := raw_div_residual_support p q (by omega) + have tail := ih _ (residual.trans inputSupport) + have term := raw_constant_support p.leadingCoeff + (CPolynomial.Raw.X ^ (p.size - q.size)) + have powerSize : (CPolynomial.Raw.X ^ (p.size - q.size) : + CPolynomial.Raw F).size = p.size - q.size + 1 := by + rw [CPolynomial.Raw.X_pow_eq_monomial_one] + simp [CPolynomial.Raw.monomial] + rw [powerSize] at term + change ((CPolynomial.Raw.divModByMonicAux.go fuel + ((p - CPolynomial.Raw.C p.leadingCoeff * + (q * CPolynomial.Raw.X ^ (p.size - q.size))).trim) q).1 + + CPolynomial.Raw.C p.leadingCoeff * CPolynomial.Raw.X ^ (p.size - q.size)).size ≤ _ + exact (CPolynomial.Raw.Trim.size_le_size _).trans + (CPolynomial.Raw.add_size.le.trans (max_le tail (by omega))) + +/-- Cubic coefficient-arithmetic budget for textbook long division when its +fuel is the dividend's length. This holds even without monicity or canonicality +assumptions: the same-size residual invariant suffices for the runtime bound. +Power construction, convolution, negation and padded additions are included; +trimming comparisons, allocation and copying remain separate. -/ +theorem countedDivAux_cost (fuel width : Nat) (p q : CPolynomial.Raw F) + (inputSupport : p.size ≤ width) (divisorSupport : q.size ≤ width) : + (countedDivAux fuel p q).2 ≤ fuel * (40 * (width + 1) ^ 2) := by + induction fuel generalizing p with + | zero => simp [countedDivAux] + | succ fuel ih => + by_cases stop : p.size < q.size + · simp [countedDivAux, stop] + · let k := p.size - q.size + let power := countedRawPow (CPolynomial.Raw.X : CPolynomial.Raw F) k + let shifted := countedRawMul q power.1 + let scaled := countedRawMul (CPolynomial.Raw.C p.leadingCoeff) shifted.1.trim + let term := countedRawMul (CPolynomial.Raw.C p.leadingCoeff) power.1 + let residual := (p - scaled.1.trim).trim + have powerSize : power.1.size = k + 1 := by + rw [countedRawPow_value, CPolynomial.Raw.X_pow_eq_monomial_one] + simp [CPolynomial.Raw.monomial] + have shiftedSize : shifted.1.trim.size ≤ width := by + change (countedRawMul q power.1).1.trim.size ≤ _ + rw [countedRawMul_value, countedRawPow_value] + exact (raw_shift_support q k).trans (by dsimp [k]; omega) + have scaledSize : scaled.1.trim.size ≤ width := by + rw [show scaled.1.trim = CPolynomial.Raw.C p.leadingCoeff * shifted.1.trim from by + simp only [scaled, countedRawMul_value]; rfl] + exact (raw_constant_support _ _).trans shiftedSize + have residualSize : residual.size ≤ width := by + dsimp only [residual, scaled, shifted, power] + rw [countedRawMul_value, countedRawMul_value, countedRawPow_value] + exact (raw_div_residual_support p q (by omega)).trans inputSupport + have termSize : term.1.trim.size ≤ width + 1 := by + change (countedRawMul (CPolynomial.Raw.C p.leadingCoeff) power.1).1.trim.size ≤ _ + rw [countedRawMul_value] + exact (raw_constant_support _ _).trans (by rw [powerSize]; dsimp [k]; omega) + have tailSize := countedDivAux_quotient_support fuel width residual q residualSize + have tailCost := ih residual residualSize + have powerCost := countedRawPow_X_cost (F := F) k + have shiftedCost := countedRawMul_cost q power.1 + have scaledCost := countedRawMul_cost (CPolynomial.Raw.C p.leadingCoeff) shifted.1.trim + have termCost := countedRawMul_cost (CPolynomial.Raw.C p.leadingCoeff) power.1 + change power.2 ≤ _ at powerCost + change shifted.2 ≤ _ at shiftedCost + change scaled.2 ≤ 1 * (1 + 2 * shifted.1.trim.size) at scaledCost + change term.2 ≤ 1 * (1 + 2 * power.1.size) at termCost + rw [powerSize] at shiftedCost termCost + have kBound : k ≤ width := by dsimp [k]; omega + have powerBudget : power.2 ≤ 12 * (width + 1) ^ 2 := by nlinarith + have shiftedBudget : shifted.2 ≤ 3 * (width + 1) ^ 2 := by + have := Nat.mul_le_mul divisorSupport + (Nat.add_le_add divisorSupport (Nat.mul_le_mul_left 2 (by omega : k + 1 ≤ width + 1))) + nlinarith + have scaledBudget : scaled.2 ≤ 1 + 2 * width := by omega + have termBudget : term.2 ≤ 3 + 2 * width := by omega + simp only [countedDivAux, stop, ↓reduceIte] + change 2 * power.2 + shifted.2 + scaled.2 + term.2 + + scaled.1.trim.size + max p.size scaled.1.trim.size + + max (countedDivAux fuel residual q).1.1.size term.1.trim.size + + (countedDivAux fuel residual q).2 ≤ _ + have firstMax : max p.size scaled.1.trim.size ≤ width := by omega + have secondMax : max (countedDivAux fuel residual q).1.1.size term.1.trim.size ≤ + width + 1 := by omega + rw [Nat.add_mul] + nlinarith + +/-- Include the field-normalization arithmetic surrounding long division. +Both occurrences of the inverse in `Raw.div` are charged. -/ +def countedRawDiv (inverseCost : Nat) (p q : CPolynomial.Raw F) : + CPolynomial.Raw F × Nat := + let scale := q.leadingCoeff⁻¹ + let numerator := CPolynomial.Raw.C scale • p + let denominator := CPolynomial.Raw.C scale * q + let core := countedDivAux numerator.size numerator denominator + (core.1.1, 2 * inverseCost + + (countedRawMul (CPolynomial.Raw.C scale) p).2 + + (countedRawMul (CPolynomial.Raw.C scale) q).2 + core.2) + +omit [LawfulBEq F] [DecidableEq F] in +theorem countedRawDiv_value (inverseCost : Nat) (p q : CPolynomial.Raw F) : + (countedRawDiv inverseCost p q).1 = CPolynomial.Raw.div p q := by + simp only [countedRawDiv, countedDivAux_value, CPolynomial.Raw.div, + CPolynomial.Raw.divByMonic, CPolynomial.Raw.divModByMonicAux] + +theorem countedRawDiv_cost (inverseCost width : Nat) (p q : CPolynomial.Raw F) + (left : p.size ≤ width) (right : q.size ≤ width) : + (countedRawDiv inverseCost p q).2 ≤ + 2 * inverseCost + 2 + 4 * width + 40 * width * (width + 1) ^ 2 := by + let scale := q.leadingCoeff⁻¹ + have numeratorSize : (CPolynomial.Raw.C scale • p).size ≤ width := by + rw [smul_eq_mul] + exact (raw_constant_support scale p).trans left + have denominatorSize := (raw_constant_support scale q).trans right + have core := countedDivAux_cost (CPolynomial.Raw.C scale • p).size width + (CPolynomial.Raw.C scale • p) (CPolynomial.Raw.C scale * q) + numeratorSize denominatorSize + have coreBudget := core.trans (Nat.mul_le_mul_right _ numeratorSize) + have numerator := countedRawMul_cost (CPolynomial.Raw.C scale) p + have denominator := countedRawMul_cost (CPolynomial.Raw.C scale) q + change (countedRawMul (CPolynomial.Raw.C scale) p).2 ≤ 1 * (1 + 2 * p.size) at numerator + change (countedRawMul (CPolynomial.Raw.C scale) q).2 ≤ 1 * (1 + 2 * q.size) at denominator + change 2 * inverseCost + (countedRawMul (CPolynomial.Raw.C scale) p).2 + + (countedRawMul (CPolynomial.Raw.C scale) q).2 + + (countedDivAux (CPolynomial.Raw.C scale • p).size + (CPolynomial.Raw.C scale • p) (CPolynomial.Raw.C scale * q)).2 ≤ _ + nlinarith + +def countedDiv (inverseCost : Nat) (p q : CPolynomial F) : CPolynomial F × Nat := + let result := countedRawDiv inverseCost p.val q.val + (CPolynomial.ofArray result.1, result.2) + +omit [DecidableEq F] in +theorem countedDiv_value (inverseCost : Nat) (p q : CPolynomial F) : + (countedDiv inverseCost p q).1 = p / q := by + apply CPolynomial.ext + simp only [countedDiv, CPolynomial.ofArray, countedRawDiv_value, + CPolynomial.Raw.div_canonical] + rfl + +theorem countedDiv_cost (inverseCost width : Nat) (p q : CPolynomial F) + (left : p.val.size ≤ width) (right : q.val.size ≤ width) : + (countedDiv inverseCost p q).2 ≤ + 2 * inverseCost + 2 + 4 * width + 40 * width * (width + 1) ^ 2 := + countedRawDiv_cost inverseCost width p.val q.val left right + +omit [DecidableEq F] in +theorem add_support (p q : CPolynomial F) : + (p + q).val.size ≤ max p.val.size q.val.size := by + exact (CPolynomial.Raw.Trim.size_le_size _).trans_eq CPolynomial.Raw.add_size + +omit [DecidableEq F] in +theorem sub_support (p q : CPolynomial F) : + (p - q).val.size ≤ max p.val.size q.val.size := by + change (p.val.addRaw (CPolynomial.Raw.neg q.val)).trim.size ≤ _ + exact (CPolynomial.Raw.Trim.size_le_size _).trans_eq (by + rw [CPolynomial.Raw.add_size]; simp [CPolynomial.Raw.neg]) + +omit [DecidableEq F] in +theorem mul_support (p q : CPolynomial F) : + (p * q).val.size ≤ p.val.size + q.val.size := by + apply CPolynomial.mem_degreeLT_iff_size_le.mp + apply CPolynomial.mem_degreeLT.mpr + rw [CPolynomial.degree_lt_iff_coeff_zero] + intro i hi + rw [CPolynomial.coeff_mul] + apply Finset.sum_eq_zero + intro j hj + by_cases left : p.val.size ≤ j + · rw [CPolynomial.coeff_eq_zero_of_size_le p left, zero_mul] + · rw [CPolynomial.coeff_eq_zero_of_size_le q (by omega), mul_zero] + +omit [DecidableEq F] in +theorem constant_support (a : F) : (CPolynomial.C a).val.size ≤ 1 := + (CPolynomial.Raw.Trim.size_le_size _).trans_eq (by rfl) + +omit [DecidableEq F] in +theorem constant_mul_support (a : F) (p : CPolynomial F) : + (CPolynomial.C a * p).val.size ≤ p.val.size := by + apply CPolynomial.mem_degreeLT_iff_size_le.mp + apply CPolynomial.mem_degreeLT.mpr + rw [CPolynomial.degree_lt_iff_coeff_zero] + intro i hi + rw [CPolynomial.coeff_C_mul, CPolynomial.coeff_eq_zero_of_size_le p hi, mul_zero] + +def countedAdd (p q : CPolynomial F) : CPolynomial F × Nat := + (p + q, max p.val.size q.val.size) + +def countedSub (p q : CPolynomial F) : CPolynomial F × Nat := + (p - q, q.val.size + max p.val.size q.val.size) + +def countedFieldPow (a : F) : Nat → F × Nat + | 0 => (1, 0) + | n + 1 => + let previous := countedFieldPow a n + (previous.1 * a, previous.2 + 1) + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedFieldPow_value (a : F) (n : Nat) : + (countedFieldPow a n).1 = a ^ n := by + induction n with + | zero => simp [countedFieldPow] + | succ n ih => simp [countedFieldPow, ih, pow_succ] + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedFieldPow_cost (a : F) (n : Nat) : + (countedFieldPow a n).2 = n := by + induction n with + | zero => rfl + | succ n ih => simp [countedFieldPow, ih] + +def countedEvalFold (point : F) : List (F × Nat) → F → F × Nat + | [], acc => (acc, 0) + | (a, i) :: rest, acc => + let power := countedFieldPow point i + let tail := countedEvalFold point rest (acc + a * power.1) + (tail.1, power.2 + 2 + tail.2) + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedEvalFold_value (point : F) (terms : List (F × Nat)) (acc : F) : + (countedEvalFold point terms acc).1 = + terms.foldl (fun acc pair => acc + pair.1 * point ^ pair.2) acc := by + induction terms generalizing acc with + | nil => rfl + | cons term rest ih => simp [countedEvalFold, countedFieldPow_value, ih] + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedEvalFold_cost (point : F) (terms : List (F × Nat)) (acc : F) + (width : Nat) (indices : ∀ pair ∈ terms, pair.2 < width) : + (countedEvalFold point terms acc).2 ≤ terms.length * (width + 2) := by + induction terms generalizing acc with + | nil => simp [countedEvalFold] + | cons term rest ih => + have head := indices term (by simp) + have tail := ih (acc + term.1 * (countedFieldPow point term.2).1) + (fun pair hp => indices pair (by simp [hp])) + simp only [countedEvalFold, countedFieldPow_cost, List.length_cons, Nat.add_mul] + omega + +def countedEval (p : CPolynomial F) (point : F) : F × Nat := + countedEvalFold point p.val.zipIdx.toList 0 + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedEval_value (p : CPolynomial F) (point : F) : + (countedEval p point).1 = p.eval point := by + rw [countedEval, countedEvalFold_value] + simp only [CPolynomial.eval, Array.foldl_toList] + +omit [BEq F] [LawfulBEq F] [DecidableEq F] in +theorem countedEval_cost (p : CPolynomial F) (point : F) (width : Nat) + (support : p.val.size ≤ width) : + (countedEval p point).2 ≤ width * (width + 2) := by + have bound := countedEvalFold_cost point p.val.zipIdx.toList 0 width (by + intro pair hp + obtain ⟨i, hi, equal⟩ := List.mem_iff_getElem.mp hp + have within : i < p.val.size := by simpa using hi + have index : pair.2 = i := by rw [← equal]; simp + omega) + have bound' : (countedEval p point).2 ≤ p.val.size * (width + 2) := by + simpa only [countedEval, Array.length_toList, Array.size_zipIdx] using bound + exact bound'.trans (Nat.mul_le_mul_right _ support) + +def countedRawMod (inverseCost : Nat) (p q : CPolynomial.Raw F) : + CPolynomial.Raw F × Nat := + let scale := q.leadingCoeff⁻¹ + let numerator := CPolynomial.Raw.C scale • p + let denominator := CPolynomial.Raw.C scale * q + let core := countedDivAux numerator.size numerator denominator + (core.1.2, 2 * inverseCost + + (countedRawMul (CPolynomial.Raw.C scale) p).2 + + (countedRawMul (CPolynomial.Raw.C scale) q).2 + core.2) + +omit [LawfulBEq F] [DecidableEq F] in +theorem countedRawMod_value (inverseCost : Nat) (p q : CPolynomial.Raw F) : + (countedRawMod inverseCost p q).1 = CPolynomial.Raw.mod p q := by + simp only [countedRawMod, countedDivAux_value, CPolynomial.Raw.mod, + CPolynomial.Raw.modByMonic, CPolynomial.Raw.divModByMonicAux] + +def countedMod (inverseCost : Nat) (p q : CPolynomial F) : CPolynomial F × Nat := + let result := countedRawMod inverseCost p.val q.val + (CPolynomial.ofArray result.1, result.2) + +omit [DecidableEq F] in +theorem countedMod_value (inverseCost : Nat) (p q : CPolynomial F) : + (countedMod inverseCost p q).1 = p.mod q := by + apply CPolynomial.ext + simp only [countedMod, CPolynomial.ofArray, countedRawMod_value, + CPolynomial.Raw.mod_canonical] + rfl + +theorem countedMod_cost (inverseCost width : Nat) (p q : CPolynomial F) + (left : p.val.size ≤ width) (right : q.val.size ≤ width) : + (countedMod inverseCost p q).2 ≤ + 2 * inverseCost + 2 + 4 * width + 40 * width * (width + 1) ^ 2 := + countedDiv_cost inverseCost width p q left right + +theorem div_support (p q : CPolynomial F) (width : Nat) (support : p.val.size ≤ width) : + (p / q).val.size ≤ width + 1 := by + let scale := q.val.leadingCoeff⁻¹ + have numeratorSize : (CPolynomial.Raw.C scale • p.val).size ≤ width := by + rw [smul_eq_mul] + exact (raw_constant_support scale p.val).trans support + have core := countedDivAux_quotient_support + (CPolynomial.Raw.C scale • p.val).size width + (CPolynomial.Raw.C scale • p.val) (CPolynomial.Raw.C scale * q.val) numeratorSize + rw [countedDivAux_value] at core + exact core + +omit [DecidableEq F] in +/-- Actual Euclidean remainder drop, independently of the fuel counter. -/ +theorem remainder_drop (previous r : CPolynomial F) (nonzero : r ≠ 0) : + (previous - (previous / r) * r).val.size < r.val.size := by + have degree : (previous - (previous / r) * r).degree < r.degree := by + rw [CPolynomial.degree_toPoly, CPolynomial.toPoly_sub, CPolynomial.toPoly_mul, + show previous / r = previous.div r from rfl, CPolynomial.div_toPoly_eq_div, + mul_comm, ← EuclideanDomain.mod_eq_sub_mul_div] + simpa only [CPolynomial.degree_toPoly] using + Polynomial.degree_mod_lt previous.toPoly ((CPolynomial.toPoly_eq_zero_iff r).not.mpr nonzero) + have positive : 0 < r.val.size := by + by_contra zero + have empty : r = 0 := CPolynomial.ext (Array.eq_empty_of_size_eq_zero (by omega)) + exact nonzero empty + have naturalDegree : r.degree = (r.val.size - 1 : Nat) := by + cases size : r.val.size with + | zero => omega + | succ n => simp [CPolynomial.degree, size] + have bound := CPolynomial.mem_degreeLT_iff_size_le.mp + (CPolynomial.mem_degreeLT.mpr (naturalDegree ▸ degree)) + omega + +def xgcdStepBudget (inverseCost width : Nat) : Nat := + 2 * inverseCost + 2 + 16 * width + 9 * width ^ 2 + + 40 * width * (width + 1) ^ 2 + +/-- Coefficient-arithmetic execution of the actual partial Euclidean loop. +This instruments each division, convolution and coefficient subtraction; +it does not count a polynomial operation as a constant-time field operation. -/ +def countedXgcdFieldAux (inverseCost threshold : Nat) : Nat → + CPolynomial F → CPolynomial F → CPolynomial F → + CPolynomial F → CPolynomial F → CPolynomial F → + (CPolynomial F × CPolynomial F × CPolynomial F) × Nat + | 0, _, _, _, previous, sPrevious, tPrevious => ((previous, sPrevious, tPrevious), 0) + | fuel + 1, r, s, t, previous, sPrevious, tPrevious => + if r.natDegree < threshold then ((r, s, t), 0) + else if r == 0 then ((previous, sPrevious, tPrevious), 0) + else + let division := countedDiv inverseCost previous r + let qr := countedMul division.1 r + let qs := countedMul division.1 s + let qt := countedMul division.1 t + let residual := countedSub previous qr.1 + let nextS := countedSub sPrevious qs.1 + let nextT := countedSub tPrevious qt.1 + let tail := countedXgcdFieldAux inverseCost threshold fuel + residual.1 nextS.1 nextT.1 r s t + (tail.1, division.2 + qr.2 + qs.2 + qt.2 + + residual.2 + nextS.2 + nextT.2 + tail.2) + +omit [DecidableEq F] in +theorem countedXgcdFieldAux_value (inverseCost threshold fuel : Nat) + (r s t previous sPrevious tPrevious : CPolynomial F) : + (countedXgcdFieldAux inverseCost threshold fuel r s t previous sPrevious tPrevious).1 = + CPolynomial.xgcdAux threshold fuel r s t previous sPrevious tPrevious := by + induction fuel generalizing r s t previous sPrevious tPrevious with + | zero => rfl + | succ fuel ih => + simp only [countedXgcdFieldAux, CPolynomial.xgcdAux] + split_ifs <;> simp [countedSub, countedDiv_value, countedMul_value, ih] + +set_option maxHeartbeats 1600000 in +/-- A polynomial support bound derived along the actual Euclidean execution. +Residues strictly shrink; quotient support is at most `residueWidth+1`. +Thus cofactors grow by at most that many coefficients per fueled step. +No hypothesis bounds an unobserved trace or assumes a desired resource count. -/ +theorem countedXgcdFieldAux_cost (inverseCost threshold fuel residueWidth cofactorWidth : Nat) + (r s t previous sPrevious tPrevious : CPolynomial F) + (rSupport : r.val.size ≤ residueWidth) (previousSupport : previous.val.size ≤ residueWidth) + (sSupport : s.val.size ≤ cofactorWidth) (tSupport : t.val.size ≤ cofactorWidth) + (sPreviousSupport : sPrevious.val.size ≤ cofactorWidth) + (tPreviousSupport : tPrevious.val.size ≤ cofactorWidth) : + (countedXgcdFieldAux inverseCost threshold fuel r s t previous sPrevious tPrevious).2 ≤ + fuel * xgcdStepBudget inverseCost + (residueWidth + cofactorWidth + fuel * (residueWidth + 1)) := by + induction fuel generalizing cofactorWidth r s t previous sPrevious tPrevious with + | zero => simp [countedXgcdFieldAux] + | succ fuel ih => + by_cases stop : r.natDegree < threshold + · simp [countedXgcdFieldAux, stop] + by_cases zero : r == 0 + · simp [countedXgcdFieldAux, stop, zero] + have nonzero : r ≠ 0 := by simpa only [beq_iff_eq] using zero + let quotient := previous / r + let width := residueWidth + cofactorWidth + (fuel + 1) * (residueWidth + 1) + let nextCofactorWidth := cofactorWidth + residueWidth + 1 + have qSupport : quotient.val.size ≤ residueWidth + 1 := div_support previous r _ previousSupport + have residualSupport : (previous - quotient * r).val.size ≤ residueWidth := + (remainder_drop previous r nonzero).le.trans rSupport + have nextSSupport : (sPrevious - quotient * s).val.size ≤ nextCofactorWidth := by + exact (sub_support _ _).trans (max_le (by dsimp [nextCofactorWidth]; omega) + ((mul_support _ _).trans (by dsimp [nextCofactorWidth]; omega))) + have nextTSupport : (tPrevious - quotient * t).val.size ≤ nextCofactorWidth := by + exact (sub_support _ _).trans (max_le (by dsimp [nextCofactorWidth]; omega) + ((mul_support _ _).trans (by dsimp [nextCofactorWidth]; omega))) + have nextSPrevious : s.val.size ≤ nextCofactorWidth := by dsimp [nextCofactorWidth]; omega + have nextTPrevious : t.val.size ≤ nextCofactorWidth := by dsimp [nextCofactorWidth]; omega + have tail := ih nextCofactorWidth (previous - quotient * r) + (sPrevious - quotient * s) (tPrevious - quotient * t) r s t + residualSupport rSupport nextSSupport nextTSupport nextSPrevious nextTPrevious + have sameWidth : residueWidth + nextCofactorWidth + fuel * (residueWidth + 1) = width := by + dsimp [nextCofactorWidth, width]; ring + rw [sameWidth] at tail + have rW : r.val.size ≤ width := by dsimp [width]; omega + have previousW : previous.val.size ≤ width := by dsimp [width]; omega + have qW : quotient.val.size ≤ width := by dsimp [width]; omega + have sW : s.val.size ≤ width := by dsimp [width]; omega + have tW : t.val.size ≤ width := by dsimp [width]; omega + have sPreviousW : sPrevious.val.size ≤ width := by dsimp [width]; omega + have tPreviousW : tPrevious.val.size ≤ width := by dsimp [width]; omega + have divCost := countedDiv_cost inverseCost width previous r previousW rW + have qrCost := countedMul_cost quotient r width qW rW + have qsCost := countedMul_cost quotient s width qW sW + have qtCost := countedMul_cost quotient t width qW tW + have qrSupport : (quotient * r).val.size ≤ 2 * width := + (mul_support _ _).trans (by omega) + have qsSupport : (quotient * s).val.size ≤ 2 * width := + (mul_support _ _).trans (by omega) + have qtSupport : (quotient * t).val.size ≤ 2 * width := + (mul_support _ _).trans (by omega) + simp only [countedXgcdFieldAux, stop, zero, ↓reduceIte, countedSub, + countedDiv_value, countedMul_value] + change (countedDiv inverseCost previous r).2 + + (countedMul quotient r).2 + (countedMul quotient s).2 + (countedMul quotient t).2 + + ((quotient * r).val.size + max previous.val.size (quotient * r).val.size) + + ((quotient * s).val.size + max sPrevious.val.size (quotient * s).val.size) + + ((quotient * t).val.size + max tPrevious.val.size (quotient * t).val.size) + + (countedXgcdFieldAux inverseCost threshold fuel (previous - quotient * r) + (sPrevious - quotient * s) (tPrevious - quotient * t) r s t).2 ≤ _ + have maxR : max previous.val.size (quotient * r).val.size ≤ 2 * width := by omega + have maxS : max sPrevious.val.size (quotient * s).val.size ≤ 2 * width := by omega + have maxT : max tPrevious.val.size (quotient * t).val.size ≤ 2 * width := by omega + change _ ≤ (fuel + 1) * xgcdStepBudget inverseCost width + rw [Nat.add_mul] + unfold xgcdStepBudget at * + omega + +def countedXgcd (inverseCost threshold : Nat) (p q : CPolynomial F) : + (CPolynomial F × CPolynomial F × CPolynomial F) × Nat := + countedXgcdFieldAux inverseCost threshold p.val.size p 1 0 q 0 1 + +omit [DecidableEq F] in +theorem countedXgcd_value (inverseCost threshold : Nat) (p q : CPolynomial F) : + (countedXgcd inverseCost threshold p q).1 = CPolynomial.xgcd p q threshold := + countedXgcdFieldAux_value inverseCost threshold p.val.size p 1 0 q 0 1 + +theorem countedXgcd_cost (inverseCost threshold width : Nat) (p q : CPolynomial F) + (left : p.val.size ≤ width) (right : q.val.size ≤ width) : + (countedXgcd inverseCost threshold p q).2 ≤ p.val.size * + xgcdStepBudget inverseCost (width + 1 + p.val.size * (width + 1)) := by + apply countedXgcdFieldAux_cost inverseCost threshold p.val.size width 1 + p 1 0 q 0 1 left right <;> first | exact Nat.le_refl 1 | exact Nat.zero_le 1 + +def countedProduct : List (CPolynomial F × Nat) → CPolynomial F × Nat + | [] => (1, 0) + | term :: rest => + let tail := countedProduct rest + let product := countedMul term.1 tail.1 + (product.1, term.2 + tail.2 + product.2) + +omit [DecidableEq F] in +theorem countedProduct_value (terms : List (CPolynomial F × Nat)) : + (countedProduct terms).1 = (terms.map Prod.fst).prod := by + induction terms with + | nil => rfl + | cons term rest ih => simp [countedProduct, countedMul_value, ih] + +omit [DecidableEq F] in +theorem countedProduct_support (terms : List (CPolynomial F × Nat)) + (supports : ∀ term ∈ terms, term.1.val.size ≤ 2) : + (countedProduct terms).1.val.size ≤ 2 * terms.length + 1 := by + induction terms with + | nil => exact Nat.le_refl 1 + | cons term rest ih => + have head := supports term (by simp) + have tail := ih (fun term hp => supports term (by simp [hp])) + rw [show (countedProduct (term :: rest)).1 = term.1 * (countedProduct rest).1 from + by simp [countedProduct, countedMul_value]] + exact (mul_support _ _).trans (by simp only [List.length_cons]; omega) + +omit [DecidableEq F] in +theorem countedProduct_cost (terms : List (CPolynomial F × Nat)) (width termBudget : Nat) + (length : terms.length ≤ width) + (supports : ∀ term ∈ terms, term.1.val.size ≤ 2) + (costs : ∀ term ∈ terms, term.2 ≤ termBudget) : + (countedProduct terms).2 ≤ terms.length * (termBudget + 3 * (2 * width + 1) ^ 2) := by + induction terms with + | nil => simp [countedProduct] + | cons term rest ih => + have headSupport := supports term (by simp) + have headCost := costs term (by simp) + have tailSupports : ∀ item ∈ rest, item.1.val.size ≤ 2 := by + intro item hp; exact supports item (by simp [hp]) + have tail := ih (by simp only [List.length_cons] at length; omega) + tailSupports (fun term hp => costs term (by simp [hp])) + have tailSupport := countedProduct_support rest tailSupports + have product := countedMul_cost term.1 (countedProduct rest).1 (2 * width + 1) + (by simp only [List.length_cons] at length; omega) + (by simp only [List.length_cons] at length; omega) + simp only [countedProduct, List.length_cons, Nat.add_mul] + omega + +def countedSum : List (CPolynomial F × Nat) → CPolynomial F × Nat + | [] => (0, 0) + | term :: rest => + let tail := countedSum rest + let sum := countedAdd term.1 tail.1 + (sum.1, term.2 + tail.2 + sum.2) + +omit [DecidableEq F] in +theorem countedSum_value (terms : List (CPolynomial F × Nat)) : + (countedSum terms).1 = (terms.map Prod.fst).sum := by + induction terms with + | nil => rfl + | cons term rest ih => simp [countedSum, countedAdd, ih] + +omit [DecidableEq F] in +theorem countedSum_support (terms : List (CPolynomial F × Nat)) (width : Nat) + (supports : ∀ term ∈ terms, term.1.val.size ≤ width) : + (countedSum terms).1.val.size ≤ width := by + induction terms with + | nil => exact Nat.zero_le width + | cons term rest ih => + exact (add_support _ _).trans (max_le (supports term (by simp)) + (ih (fun term hp => supports term (by simp [hp])))) + +omit [DecidableEq F] in +theorem countedSum_cost (terms : List (CPolynomial F × Nat)) (width termBudget : Nat) + (supports : ∀ term ∈ terms, term.1.val.size ≤ width) + (costs : ∀ term ∈ terms, term.2 ≤ termBudget) : + (countedSum terms).2 ≤ terms.length * (termBudget + width) := by + induction terms with + | nil => simp [countedSum] + | cons term rest ih => + have headSupport := supports term (by simp) + have headCost := costs term (by simp) + have tailSupports : ∀ item ∈ rest, item.1.val.size ≤ width := by + intro item hp; exact supports item (by simp [hp]) + have tailSupport := countedSum_support rest width tailSupports + have tail := ih tailSupports (fun term hp => costs term (by simp [hp])) + simp only [countedSum, countedAdd, List.length_cons, Nat.add_mul] + omega + +def countedBasisFactor (inverseCost : Nat) (node other : F) : CPolynomial F × Nat := + let difference := node - other + let linear := countedSub CPolynomial.X (CPolynomial.C other) + let product := countedMul (CPolynomial.C difference⁻¹) linear.1 + (product.1, 1 + inverseCost + linear.2 + product.2) + +omit [DecidableEq F] in +theorem countedBasisFactor_value (inverseCost : Nat) (node other : F) : + (countedBasisFactor inverseCost node other).1 = CPolynomial.CLagrange.basisDivisor node other := by + simp [countedBasisFactor, countedSub, countedMul_value, CPolynomial.CLagrange.basisDivisor] + +omit [DecidableEq F] in +theorem countedBasisFactor_support (inverseCost : Nat) (node other : F) : + (countedBasisFactor inverseCost node other).1.val.size ≤ 2 := by + rw [countedBasisFactor_value] + exact (constant_mul_support _ _).trans ((sub_support _ _).trans + (max_le (Nat.le_refl 2) ((constant_support other).trans (by omega)))) + +omit [DecidableEq F] in +theorem countedBasisFactor_cost (inverseCost : Nat) (node other : F) : + (countedBasisFactor inverseCost node other).2 ≤ inverseCost + 9 := by + have c := constant_support other + have factorSupport : (CPolynomial.X - CPolynomial.C other).val.size ≤ 2 := + (sub_support _ _).trans (max_le (Nat.le_refl 2) (c.trans (by omega))) + have scalar := constant_support (node - other)⁻¹ + have product := countedRawMul_cost (CPolynomial.C (node - other)⁻¹).val + (CPolynomial.X - CPolynomial.C other).val + have productBudget : (countedMul (CPolynomial.C (node - other)⁻¹) + (CPolynomial.X - CPolynomial.C other)).2 ≤ 5 := by + exact product.trans (by + calc + _ ≤ 1 * (1 + 2 * 2) := + Nat.mul_le_mul scalar (Nat.add_le_add scalar (Nat.mul_le_mul_left 2 factorSupport)) + _ = 5 := rfl) + change 1 + inverseCost + ((CPolynomial.C other).val.size + + max CPolynomial.X.val.size (CPolynomial.C other).val.size) + + (countedMul (CPolynomial.C (node - other)⁻¹) + (CPolynomial.X - CPolynomial.C other)).2 ≤ _ + rw [show (CPolynomial.X : CPolynomial F).val.size = 2 from rfl] + omega + +def basisIndices (n : Nat) (i : Fin n) : List (Fin n) := + (List.finRange n).filter (fun j => j ≠ i) + +def countedBasis (inverseCost : Nat) (n : Nat) (nodes : Fin n → F) (i : Fin n) : + CPolynomial F × Nat := + countedProduct ((basisIndices n i).map (fun j => countedBasisFactor inverseCost (nodes i) (nodes j))) + +omit [DecidableEq F] in +theorem countedBasis_value (inverseCost n : Nat) (nodes : Fin n → F) (i : Fin n) : + (countedBasis inverseCost n nodes i).1 = + CPolynomial.CLagrange.basis Finset.univ nodes i := by + apply CPolynomial.toPolyLinearEquiv.injective + simp only [CPolynomial.toPolyLinearEquiv_apply, countedBasis, countedProduct_value, + List.map_map, Function.comp_def, countedBasisFactor_value] + have enumeration : (basisIndices n i).toFinset = Finset.univ.erase i := by + ext j; simp [basisIndices] + have nodup : (basisIndices n i).Nodup := (List.nodup_finRange n).filter _ + rw [← List.prod_toFinset _ nodup, enumeration, CPolynomial.toPoly_prod, + CPolynomial.CLagrange.cbasis_eq_basis, Lagrange.basis] + simp [CPolynomial.CLagrange.cbasisDivisor_eq_basisDivisor] + +omit [DecidableEq F] in +theorem countedBasis_support (inverseCost n : Nat) (nodes : Fin n → F) (i : Fin n) : + (countedBasis inverseCost n nodes i).1.val.size ≤ 2 * n + 1 := by + have length : (basisIndices n i).length ≤ n := + (List.length_filter_le _ _).trans_eq List.length_finRange + exact (countedProduct_support _ (by + intro term ht + obtain ⟨j, hj, rfl⟩ := List.mem_map.mp ht + exact countedBasisFactor_support _ _ _)).trans (by simp; omega) + +omit [DecidableEq F] in +theorem countedBasis_cost (inverseCost n : Nat) (nodes : Fin n → F) (i : Fin n) : + (countedBasis inverseCost n nodes i).2 ≤ n * (inverseCost + 9 + 3 * (2 * n + 1) ^ 2) := by + have length : (basisIndices n i).length ≤ n := + (List.length_filter_le _ _).trans_eq List.length_finRange + have bound := countedProduct_cost + ((basisIndices n i).map (fun j => countedBasisFactor inverseCost (nodes i) (nodes j))) + n (inverseCost + 9) (by simpa using length) + (by intro term ht; obtain ⟨j, hj, rfl⟩ := List.mem_map.mp ht; exact countedBasisFactor_support _ _ _) + (by intro term ht; obtain ⟨j, hj, rfl⟩ := List.mem_map.mp ht; exact countedBasisFactor_cost _ _ _) + exact bound.trans (Nat.mul_le_mul_right _ (by simpa using length)) + +def countedInterpolant (inverseCost : Nat) (D : Domain (F := F)) (received : Vector F D.n) : + CPolynomial F × Nat := + countedSum ((List.finRange D.n).map fun i => + let basis := countedBasis inverseCost D.n (D.val[·]) i + let term := countedMul (CPolynomial.C (received.get i)) basis.1 + (term.1, basis.2 + term.2)) + +omit [DecidableEq F] in +theorem countedInterpolant_value (inverseCost : Nat) (D : Domain (F := F)) + (received : Vector F D.n) : + (countedInterpolant inverseCost D received).1 = + CompPoly.ReedSolomon.Gao.receivedInterpolant D received := by + apply CPolynomial.toPolyLinearEquiv.injective + rw [CPolynomial.toPolyLinearEquiv_apply, CPolynomial.toPolyLinearEquiv_apply, + countedInterpolant, countedSum_value] + simp only [List.map_map, countedMul_value, countedBasis_value] + rw [← List.sum_toFinset _ (List.nodup_finRange _)] + simp only [List.toFinset_finRange] + rw [CompPoly.ReedSolomon.Gao.receivedInterpolant, + CPolynomial.CLagrange.cinterpolate_eq_interpolate, Lagrange.interpolate] + simp [CPolynomial.toPoly_sum, CPolynomial.toPoly_mul, CPolynomial.C_toPoly, + CPolynomial.CLagrange.cbasis_eq_basis] + +def interpolationBudget (inverseCost n : Nat) : Nat := + n * (n * (inverseCost + 9 + 3 * (2 * n + 1) ^ 2) + + 3 * (2 * n + 1) ^ 2 + (2 * n + 1)) + +omit [DecidableEq F] in +theorem countedInterpolant_support (inverseCost : Nat) (D : Domain (F := F)) + (received : Vector F D.n) : + (countedInterpolant inverseCost D received).1.val.size ≤ 2 * D.n + 1 := by + apply countedSum_support + intro term ht + obtain ⟨i, hi, rfl⟩ := List.mem_map.mp ht + rw [countedMul_value] + exact (constant_mul_support _ _).trans (countedBasis_support _ _ _ _) + +omit [DecidableEq F] in +theorem countedInterpolant_cost (inverseCost : Nat) (D : Domain (F := F)) + (received : Vector F D.n) : + (countedInterpolant inverseCost D received).2 ≤ interpolationBudget inverseCost D.n := by + unfold countedInterpolant interpolationBudget + have bound := countedSum_cost + ((List.finRange D.n).map fun i => + let basis := countedBasis inverseCost D.n (D.val[·]) i + let term := countedMul (CPolynomial.C (received.get i)) basis.1 + (term.1, basis.2 + term.2)) + (2 * D.n + 1) + (D.n * (inverseCost + 9 + 3 * (2 * D.n + 1) ^ 2) + 3 * (2 * D.n + 1) ^ 2) + (by + intro term ht + obtain ⟨i, hi, rfl⟩ := List.mem_map.mp ht + rw [countedMul_value] + exact (constant_mul_support _ _).trans (countedBasis_support _ _ _ _)) + (by + intro term ht + obtain ⟨i, hi, rfl⟩ := List.mem_map.mp ht + exact Nat.add_le_add (countedBasis_cost _ _ _ _) + (countedMul_cost _ _ _ ((constant_support _).trans (by omega)) + (countedBasis_support _ _ _ _))) + simpa only [List.length_map, List.length_finRange] using bound + +def countedNodal (D : Domain (F := F)) : CPolynomial F × Nat := + countedProduct (D.val.toList.map fun node => countedSub CPolynomial.X (CPolynomial.C node)) + +omit [DecidableEq F] in +theorem countedNodal_value (D : Domain (F := F)) : + (countedNodal D).1 = CompPoly.ReedSolomon.Gao.nodalPoly D := by + rw [countedNodal, countedProduct_value] + simp only [List.map_map, Function.comp_def, countedSub] + rw [CompPoly.ReedSolomon.Gao.nodalPoly, ← Array.foldl_toList, + ← List.foldl_map (f := fun node => CPolynomial.X - CPolynomial.C node) (g := (· * ·)), + ← List.prod_eq_foldl] + +omit [DecidableEq F] in +theorem countedNodal_support (D : Domain (F := F)) : + (countedNodal D).1.val.size ≤ 2 * D.n + 1 := by + have bound := countedProduct_support + (D.val.toList.map fun node => countedSub CPolynomial.X (CPolynomial.C node)) (by + intro term ht + obtain ⟨node, hn, rfl⟩ := List.mem_map.mp ht + exact (sub_support _ _).trans (max_le (Nat.le_refl 2) + ((constant_support node).trans (by omega)))) + simpa only [countedNodal, List.length_map, Array.length_toList, + CompPoly.ReedSolomon.Domain.n] using bound + +omit [DecidableEq F] in +theorem countedNodal_cost (D : Domain (F := F)) : + (countedNodal D).2 ≤ D.n * (3 + 3 * (2 * D.n + 1) ^ 2) := by + have bound := countedProduct_cost + (D.val.toList.map fun node => countedSub CPolynomial.X (CPolynomial.C node)) + D.n 3 (by simp [CompPoly.ReedSolomon.Domain.n]) + (by + intro term ht + obtain ⟨node, hn, rfl⟩ := List.mem_map.mp ht + exact (sub_support _ _).trans (max_le (Nat.le_refl 2) + ((constant_support node).trans (by omega)))) + (by + intro term ht + obtain ⟨node, hn, rfl⟩ := List.mem_map.mp ht + have support := constant_support node + change (CPolynomial.C node).val.size + max 2 (CPolynomial.C node).val.size ≤ 3 + omega) + simpa only [countedNodal, List.length_map, Array.length_toList, + CompPoly.ReedSolomon.Domain.n] using bound + +theorem xgcdAux_support (threshold fuel residueWidth cofactorWidth : Nat) + (r s t previous sPrevious tPrevious : CPolynomial F) + (rSupport : r.val.size ≤ residueWidth) (previousSupport : previous.val.size ≤ residueWidth) + (sSupport : s.val.size ≤ cofactorWidth) (tSupport : t.val.size ≤ cofactorWidth) + (sPreviousSupport : sPrevious.val.size ≤ cofactorWidth) + (tPreviousSupport : tPrevious.val.size ≤ cofactorWidth) : + let result := CPolynomial.xgcdAux threshold fuel r s t previous sPrevious tPrevious + result.1.val.size ≤ residueWidth ∧ + result.2.1.val.size ≤ cofactorWidth + fuel * (residueWidth + 1) ∧ + result.2.2.val.size ≤ cofactorWidth + fuel * (residueWidth + 1) := by + induction fuel generalizing cofactorWidth r s t previous sPrevious tPrevious with + | zero => simpa [CPolynomial.xgcdAux] using ⟨previousSupport, sPreviousSupport, tPreviousSupport⟩ + | succ fuel ih => + simp only [CPolynomial.xgcdAux] + split_ifs with stop zero + · exact ⟨rSupport, sSupport.trans (by omega), tSupport.trans (by omega)⟩ + · exact ⟨previousSupport, sPreviousSupport.trans (by omega), tPreviousSupport.trans (by omega)⟩ + · have nonzero : r ≠ 0 := by simpa only [beq_iff_eq] using zero + let quotient := previous / r + have qSupport : quotient.val.size ≤ residueWidth + 1 := div_support previous r _ previousSupport + have residualSupport : (previous - quotient * r).val.size ≤ residueWidth := + (remainder_drop previous r nonzero).le.trans rSupport + have nextSSupport : (sPrevious - quotient * s).val.size ≤ cofactorWidth + residueWidth + 1 := + (sub_support _ _).trans (max_le (sPreviousSupport.trans (by omega)) + ((mul_support _ _).trans (by omega))) + have nextTSupport : (tPrevious - quotient * t).val.size ≤ cofactorWidth + residueWidth + 1 := + (sub_support _ _).trans (max_le (tPreviousSupport.trans (by omega)) + ((mul_support _ _).trans (by omega))) + have result := ih (cofactorWidth + residueWidth + 1) (previous - quotient * r) + (sPrevious - quotient * s) (tPrevious - quotient * t) r s t + residualSupport rSupport nextSSupport nextTSupport + (sSupport.trans (by omega)) (tSupport.trans (by omega)) + have equal : cofactorWidth + residueWidth + 1 + fuel * (residueWidth + 1) = + cofactorWidth + (fuel + 1) * (residueWidth + 1) := by ring + simpa only [equal] using result + +def decoderWidth (n : Nat) : Nat := + (2 * n + 1) + 1 + (2 * n + 1) * ((2 * n + 1) + 1) + +def divisionBudget (inverseCost width : Nat) : Nat := + 2 * inverseCost + 2 + 4 * width + 40 * width * (width + 1) ^ 2 + +def decoderBudget (inverseCost n : Nat) : Nat := + n * (3 + 3 * (2 * n + 1) ^ 2) + interpolationBudget inverseCost n + + (2 * n + 1) * xgcdStepBudget inverseCost (decoderWidth n) + + 2 * divisionBudget inverseCost (decoderWidth n) + +theorem xgcdStepBudget_mono (inverseCost : Nat) {a b : Nat} (bound : a ≤ b) : + xgcdStepBudget inverseCost a ≤ xgcdStepBudget inverseCost b := by + unfold xgcdStepBudget + gcongr + +/-- Complete coefficient-arithmetic instrumentation of Gao: nodal product, +Lagrange interpolation, partial xgcd and both final remainder/division calls. +The public-domain array construction itself uses no field arithmetic. -/ +def countedDecode (inverseCost k : Nat) (D : Domain (F := F)) (received : Vector F D.n) : + Option (CPolynomial F) × Nat := + let nodal := countedNodal D + let interpolant := countedInterpolant inverseCost D received + let gcd := countedXgcd inverseCost ((D.n + k + 1) / 2) nodal.1 interpolant.1 + let remainder := countedMod inverseCost gcd.1.1 gcd.1.2.2 + let cost := nodal.2 + interpolant.2 + gcd.2 + remainder.2 + if remainder.1 == 0 then + let quotient := countedDiv inverseCost gcd.1.1 gcd.1.2.2 + (if quotient.1.degree < k then some quotient.1 else none, cost + quotient.2) + else (none, cost) + +omit [DecidableEq F] in +theorem countedDecode_value (inverseCost k : Nat) (D : Domain (F := F)) + (received : Vector F D.n) : + (countedDecode inverseCost k D received).1 = decode k D received := by + simp only [countedDecode, countedNodal_value, countedInterpolant_value, countedXgcd_value, + countedMod_value, countedDiv_value, decode, CompPoly.ReedSolomon.Gao.decode, + CompPoly.ReedSolomon.Gao.partialGcd] + split_ifs <;> simp_all + all_goals simp_all only [← not_lt, ite_false] + +set_option maxHeartbeats 1600000 in +theorem countedDecode_cost (inverseCost k : Nat) (D : Domain (F := F)) + (received : Vector F D.n) : + (countedDecode inverseCost k D received).2 ≤ decoderBudget inverseCost D.n := by + let nodal := countedNodal D + let interpolant := countedInterpolant inverseCost D received + let threshold := (D.n + k + 1) / 2 + let gcd := countedXgcd inverseCost threshold nodal.1 interpolant.1 + let residueWidth := 2 * D.n + 1 + have nodalSupport : nodal.1.val.size ≤ residueWidth := countedNodal_support D + have interpolantSupport : interpolant.1.val.size ≤ residueWidth := + countedInterpolant_support inverseCost D received + have gcdCost := countedXgcd_cost inverseCost threshold residueWidth + nodal.1 interpolant.1 nodalSupport interpolantSupport + have gcdBudget : gcd.2 ≤ residueWidth * xgcdStepBudget inverseCost (decoderWidth D.n) := by + exact gcdCost.trans (Nat.mul_le_mul nodalSupport + (xgcdStepBudget_mono inverseCost (by + unfold decoderWidth; dsimp only [residueWidth] + exact Nat.add_le_add_left (Nat.mul_le_mul_right _ nodalSupport) _))) + have output := xgcdAux_support threshold nodal.1.val.size residueWidth 1 + nodal.1 1 0 interpolant.1 0 1 nodalSupport interpolantSupport + (Nat.le_refl 1) (Nat.zero_le 1) (Nat.zero_le 1) (Nat.le_refl 1) + have outputValue : gcd.1 = CPolynomial.xgcdAux threshold nodal.1.val.size + nodal.1 1 0 interpolant.1 0 1 := countedXgcd_value _ _ _ _ + have rSupport : gcd.1.1.val.size ≤ decoderWidth D.n := by + rw [outputValue] + exact output.1.trans (by unfold decoderWidth; dsimp [residueWidth]; omega) + have tSupport : gcd.1.2.2.val.size ≤ decoderWidth D.n := by + rw [outputValue] + exact output.2.2.trans (by + change 1 + nodal.1.val.size * (residueWidth + 1) ≤ + residueWidth + 1 + residueWidth * (residueWidth + 1) + exact Nat.add_le_add (by omega) (Nat.mul_le_mul_right _ nodalSupport)) + have remainderCost := countedMod_cost inverseCost (decoderWidth D.n) + gcd.1.1 gcd.1.2.2 rSupport tSupport + have quotientCost := countedDiv_cost inverseCost (decoderWidth D.n) + gcd.1.1 gcd.1.2.2 rSupport tSupport + have nodalCost := countedNodal_cost D + have interpolantCost := countedInterpolant_cost inverseCost D received + unfold countedDecode + change (if (countedMod inverseCost gcd.1.1 gcd.1.2.2).1 == 0 then + (if (countedDiv inverseCost gcd.1.1 gcd.1.2.2).1.degree < k then + some (countedDiv inverseCost gcd.1.1 gcd.1.2.2).1 else none, + nodal.2 + interpolant.2 + gcd.2 + (countedMod inverseCost gcd.1.1 gcd.1.2.2).2 + + (countedDiv inverseCost gcd.1.1 gcd.1.2.2).2) + else (none, nodal.2 + interpolant.2 + gcd.2 + + (countedMod inverseCost gcd.1.1 gcd.1.2.2).2)).2 ≤ _ + split_ifs <;> simp only + all_goals + unfold decoderBudget divisionBudget + change nodal.2 ≤ _ at nodalCost + change interpolant.2 ≤ _ at interpolantCost + dsimp only [residueWidth] at gcdBudget + omega + +end Whir.ReedSolomonExtraction diff --git a/verification/whir/Whir/ResetAcceptanceAmplification.lean b/verification/whir/Whir/ResetAcceptanceAmplification.lean new file mode 100644 index 000000000..6b692ccd8 --- /dev/null +++ b/verification/whir/Whir/ResetAcceptanceAmplification.lean @@ -0,0 +1,281 @@ +import Whir.AuthenticatedResetProbability +import Whir.KnowledgeExtraction +import Whir.AuthenticatedResetLaw + +/-! Prefix averaging and amplification over independent FULL attempts. The +stopping event is a verified explaining output, never a first accepted prefix. +Acceptance may depend arbitrarily on the entire suffix. -/ +namespace Whir.ResetAcceptanceAmplification +open SamplingProbability AuthenticatedResetProbability KnowledgeExtraction +open Concrete Protocol CausalGame +open scoped BigOperators + +variable {Prefix Suffix : Type*} [Fintype Prefix] [Nonempty Prefix] + [Fintype Suffix] [Nonempty Suffix] + +noncomputable def prefixAcceptance (accept : Prefix × Suffix → Prop) (p : Prefix) : ℝ := + probability (fun suffix => accept (p, suffix)) + +noncomputable def GoodPrefix (accept : Prefix × Suffix → Prop) (p : Prefix) : Prop := + probability accept / 2 ≤ prefixAcceptance accept p + +/-- Bounded averaging supplies unconditional good-prefix mass at least κ/2. +This does not claim that the first accepted prefix is good with overwhelming +probability. It can give only a conditional constant, so attempts must repeat. -/ +theorem good_prefix_mass (accept : Prefix × Suffix → Prop) : + probability accept / 2 ≤ probability (GoodPrefix accept) := by + classical + let κ := probability accept + have positive : (0 : ℝ) < Fintype.card Prefix := by exact_mod_cast Fintype.card_pos + have κnonneg : 0 ≤ κ := nonneg accept + have pointwise : ∀ p, prefixAcceptance accept p ≤ + κ / 2 + if GoodPrefix accept p then (1 : ℝ) else 0 := by + intro p + by_cases good : GoodPrefix accept p + · rw [ite_eq_left good] + exact (le_one _).trans (by linarith) + · rw [ite_eq_right good] + have low : prefixAcceptance accept p < κ / 2 := lt_of_not_ge good + linarith + have total := Finset.sum_le_sum (fun p (_ : p ∈ (Finset.univ : Finset Prefix)) => pointwise p) + have mean : κ * Fintype.card Prefix = ∑ p, prefixAcceptance accept p := by + exact (eq_div_iff (ne_of_gt positive)).mp (probability_average accept) + have goodCard : (∑ p : Prefix, if GoodPrefix accept p then (1 : ℝ) else 0) = + ((Finset.univ.filter (GoodPrefix accept)).card : ℝ) := by simp + simp only [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, nsmul_eq_mul, + goodCard] at total + rw [← mean] at total + rw [probability_eq_uniformProb (GoodPrefix accept)] + simp only [Soundness.uniformProb, Rat.cast_div, Rat.cast_natCast] + dsimp only [κ] at total + apply (le_div_iff₀ positive).mpr + nlinarith + +/-- Good prefixes carry at least half the accepted mass as well. In particular, +conditioning on acceptance yields only a constant guarantee, not exponential +failure reduction. -/ +theorem good_accepted_mass (accept : Prefix × Suffix → Prop) : + probability accept / 2 ≤ probability (fun t => accept t ∧ GoodPrefix accept t.1) := by + classical + have bad : probability (fun t => accept t ∧ ¬ GoodPrefix accept t.1) ≤ probability accept / 2 := by + rw [probability_average] + have positive : (0 : ℝ) < Fintype.card Prefix := by exact_mod_cast Fintype.card_pos + apply (div_le_iff₀ positive).mpr + calc + _ ≤ ∑ _ : Prefix, probability accept / 2 := by + apply Finset.sum_le_sum + intro p _ + by_cases good : GoodPrefix accept p + · simp [good, probability] + positivity + · have low : prefixAcceptance accept p < probability accept / 2 := lt_of_not_ge good + simpa only [good, not_false_eq_true, and_true, prefixAcceptance] using low.le + _ = _ := by simp [mul_comm] + let events : Bool → Prefix × Suffix → Prop + | false => fun t => accept t ∧ ¬ GoodPrefix accept t.1 + | true => fun t => accept t ∧ GoodPrefix accept t.1 + have included : ∀ t, accept t → ∃ b, events b t := by + intro t h + by_cases good : GoodPrefix accept t.1 + · exact ⟨true, h, good⟩ + · exact ⟨false, h, good⟩ + have bound := (mono _ _ included).trans (union_le events) + simp only [Fintype.sum_bool, events] at bound + linarith + +/-- Complete attempts use independent product seeds. The event here must be +actual verified-output success; mere acceptance is not a stopping condition. -/ +theorem repeated_attempt_failure {Attempt : Type*} [Fintype Attempt] [Nonempty Attempt] + (success : Attempt → Prop) (chance : ℝ) (_chanceNonneg : 0 ≤ chance) + (lower : chance ≤ probability success) (attempts : Nat) : + probability (fun seed : Fin attempts → Attempt => ∀ i, ¬ success (seed i)) ≤ + (1 - chance) ^ attempts := by + rw [independent_misses success attempts] + exact pow_le_pow_left₀ (sub_nonneg.mpr (le_one success)) (by linarith) attempts + +/-- Success is the actual reset-machine output together with Explains. -/ +theorem repeated_extraction_failure {Seed : Type*} [Fintype Seed] [Nonempty Seed] + (extractor : Extractor Seed) (prover : CommittedProver) (chance : ℝ) + (chanceNonneg : 0 ≤ chance) + (lower : chance ≤ probability (extractionSuccess extractor prover)) (attempts : Nat) : + probability (fun seed : Fin attempts → Seed => + ∀ i, ¬ extractionSuccess extractor prover (seed i)) ≤ (1 - chance) ^ attempts := + repeated_attempt_failure _ chance chanceNonneg lower attempts + +/-- A fresh prefix and fresh extraction seed form one attempt. Bounded-average +good-prefix mass combines with the actual per-good-prefix output guarantee. -/ +theorem prefix_attempt_chance {Seed : Type*} [Fintype Seed] [Nonempty Seed] + (accept : Prefix × Suffix → Prop) (success : Prefix × Seed → Prop) + (δ : ℝ) (_δnonneg : 0 ≤ δ) (δle : δ ≤ 1) + (goodSuccess : ∀ p, GoodPrefix accept p → + 1 - δ ≤ probability (fun seed => success (p, seed))) : + probability accept / 2 * (1 - δ) ≤ probability success := by + classical + have positive : (0 : ℝ) < Fintype.card Prefix := by exact_mod_cast Fintype.card_pos + have per : ∀ p, (if GoodPrefix accept p then (1 : ℝ) else 0) * (1 - δ) ≤ + probability (fun seed => success (p, seed)) := by + intro p + by_cases good : GoodPrefix accept p + · simpa [good] using goodSuccess p good + · simpa [good] using nonneg (fun seed => success (p, seed)) + have sum := Finset.sum_le_sum (fun p (_ : p ∈ (Finset.univ : Finset Prefix)) => per p) + have weighted : probability (GoodPrefix accept) * (1 - δ) ≤ probability success := by + rw [probability_average] + rw [probability_eq_uniformProb (GoodPrefix accept)] + simp only [Soundness.uniformProb, Rat.cast_div, Rat.cast_natCast] + apply (le_div_iff₀ positive).mpr + have boole : (∑ p : Prefix, if GoodPrefix accept p then (1 : ℝ) else 0) = + ((Finset.univ.filter (GoodPrefix accept)).card : ℝ) := by simp + rw [← Finset.sum_mul, boole] at sum + simpa only [div_mul_eq_mul_div, div_mul_cancel₀ _ (ne_of_gt positive)] using sum + exact (mul_le_mul_of_nonneg_right (good_prefix_mass accept) (sub_nonneg.mpr δle)).trans weighted + +def firstVerified {W : Type*} (check : W → Bool) : List (Option W) → Option W + | [] => none + | none :: rest => firstVerified check rest + | some w :: rest => if check w then some w else firstVerified check rest + +theorem firstVerified_none_iff {W : Type*} (check : W → Bool) (candidates : List (Option W)) : + firstVerified check candidates = none ↔ + ∀ candidate ∈ candidates, ¬ ∃ w, candidate = some w ∧ check w = true := by + induction candidates with + | nil => simp [firstVerified] + | cons candidate rest ih => + cases candidate with + | none => simp [firstVerified, ih] + | some w => + cases h : check w <;> simp [firstVerified, h, ih] + +theorem firstVerified_sound {W : Type*} (check : W → Bool) (relation : W → Prop) + (sound : ∀ w, check w = true → relation w) (candidates : List (Option W)) + (w : W) (output : firstVerified check candidates = some w) : relation w := by + induction candidates with + | nil => simp [firstVerified] at output + | cons candidate rest ih => + cases candidate with + | none => exact ih output + | some x => + simp only [firstVerified] at output + split at output + · rename_i checked + have same : x = w := Option.some.inj output + subst w + exact sound x checked + · exact ih output + +section Attempts +variable {Seed : Type*} [Fintype Seed] [Nonempty Seed] + (extractor : Extractor Seed) (prover : CommittedProver) + (check : Witness prover.input.config prover.input.lanes → Bool) + +def checkedSuccess (seed : Seed) : Prop := + ∃ w, (runRewind prover.input prover.respond extractor.maxReplay extractor.rewindRounds + (extractor.program prover.input seed)).output = some w ∧ check w = true + +/-- Every candidate comes from the actual black box. The algorithm tests output\n+certificates and does NOT stop at an accepted prefix or unchecked candidate. -/ +def attemptOutput (attempts : Nat) (seed : Fin attempts → Seed) : + Option (Witness prover.input.config prover.input.lanes) := + firstVerified check (List.ofFn fun i => + (runRewind prover.input prover.respond extractor.maxReplay extractor.rewindRounds + (extractor.program prover.input (seed i))).output) + +def attemptCalls (attempts : Nat) (seed : Fin attempts → Seed) : Nat := + ∑ i, (runRewind prover.input prover.respond extractor.maxReplay extractor.rewindRounds + (extractor.program prover.input (seed i))).responseCalls + +omit [Fintype Seed] [Nonempty Seed] in +theorem attemptCalls_le (attempts : Nat) (seed : Fin attempts → Seed) : + attemptCalls extractor prover attempts seed ≤ + attempts * (extractor.rewindRounds * (extractor.maxReplay + 1)) := by + calc + _ ≤ ∑ _ : Fin attempts, extractor.rewindRounds * (extractor.maxReplay + 1) := + Finset.sum_le_sum (fun i _ => responseCalls_le _ _ _ _ _) + _ = _ := by simp + +omit [Fintype Seed] [Nonempty Seed] in +theorem attemptOutput_explains + (sound : ∀ w, check w = true → Explains prover.input w) + (attempts : Nat) (seed : Fin attempts → Seed) (w) + (output : attemptOutput extractor prover check attempts seed = some w) : Explains prover.input w := + firstVerified_sound check _ sound _ w output + +theorem attemptOutput_failure (chance : ℝ) (chanceNonneg : 0 ≤ chance) + (lower : chance ≤ probability (checkedSuccess extractor prover check)) (attempts : Nat) : + probability (fun seed : Fin attempts → Seed => + attemptOutput extractor prover check attempts seed = none) ≤ (1 - chance) ^ attempts := by + have failure : ∀ seed, attemptOutput extractor prover check attempts seed = none ↔ + ∀ i, ¬ checkedSuccess extractor prover check (seed i) := by + intro seed + simp only [attemptOutput, firstVerified_none_iff, List.forall_mem_ofFn_iff, checkedSuccess] + convert repeated_attempt_failure (checkedSuccess extractor prover check) chance chanceNonneg lower attempts using 1 + congr 1 + funext seed + exact propext (failure seed) +end Attempts + +section ActualPrefix +open AuthenticatedResetSupport +variable (prover : CommittedProver) (level : Fin prover.input.config.folds.size) + (depth : Nat) + (chunks : CausalGame.queryChunks prover.input.config level = + ((prover.input.config.queries[level.val]! + 192 / depth - 1) / (192 / depth))) + +def fullPrefixAccept (p : CausalGame.Tape prover.input.config × + (RewindCoverage.QueryTape depth prover.input.config.queries[level.val]! × + (Concrete.E × CausalGame.Tape prover.input.config))) : Prop := + CausalGame.experiment prover.input prover.respond + (fullResetTape prover.input p.1 level depth chunks p.2.1 p.2.2) = true + +theorem actual_good_prefix_mass : + probability (fun t => CausalGame.experiment prover.input prover.respond t = true) / 2 ≤ + probability (GoodPrefix (fullPrefixAccept prover level depth chunks)) := by + have bound := good_prefix_mass (fullPrefixAccept prover level depth chunks) + have law := fullResetTape_probability prover.input level depth chunks + (fun t => CausalGame.experiment prover.input prover.respond t = true) + change probability (fullPrefixAccept prover level depth chunks) = _ at law + rwa [law] at bound + +theorem actual_prefix_attempt_chance {Seed : Type*} [Fintype Seed] [Nonempty Seed] + (success : CausalGame.Tape prover.input.config × Seed → Prop) + (δ : ℝ) (δnonneg : 0 ≤ δ) (δle : δ ≤ 1) + (goodSuccess : ∀ p, GoodPrefix (fullPrefixAccept prover level depth chunks) p → + 1 - δ ≤ probability (fun seed => success (p, seed))) : + probability (fun t => CausalGame.experiment prover.input prover.respond t = true) / 2 * (1 - δ) ≤ + probability success := by + have bound := prefix_attempt_chance (fullPrefixAccept prover level depth chunks) + success δ δnonneg δle goodSuccess + have law := fullResetTape_probability prover.input level depth chunks + (fun t => CausalGame.experiment prover.input prover.respond t = true) + change probability (fullPrefixAccept prover level depth chunks) = _ at law + rwa [law] at bound +/-- Complete fresh prefix+extraction attempts amplify only VERIFIED output +success. This is the exponential statement a first accepted prefix cannot give. -/ +theorem actual_repeated_prefix_failure {Seed : Type*} [Fintype Seed] [Nonempty Seed] + (success : CausalGame.Tape prover.input.config × Seed → Prop) + (δ : ℝ) (δnonneg : 0 ≤ δ) (δle : δ ≤ 1) + (goodSuccess : ∀ p, GoodPrefix (fullPrefixAccept prover level depth chunks) p → + 1 - δ ≤ probability (fun seed => success (p, seed))) (attempts : Nat) : + probability (fun seed : Fin attempts → CausalGame.Tape prover.input.config × Seed => + ∀ i, ¬ success (seed i)) ≤ + (1 - probability (fun t => CausalGame.experiment prover.input prover.respond t = true) / 2 * + (1 - δ)) ^ attempts := by + apply repeated_attempt_failure + · exact mul_nonneg (div_nonneg (nonneg _) (by norm_num)) (sub_nonneg.mpr δle) + · exact actual_prefix_attempt_chance prover level depth chunks success δ δnonneg δle goodSuccess + +#print axioms actual_repeated_prefix_failure +end ActualPrefix + +#print axioms actual_good_prefix_mass +#print axioms actual_prefix_attempt_chance + +#print axioms prefix_attempt_chance +#print axioms attemptCalls_le +#print axioms attemptOutput_explains +#print axioms attemptOutput_failure + +#print axioms good_prefix_mass +#print axioms good_accepted_mass +#print axioms repeated_attempt_failure +#print axioms repeated_extraction_failure +end Whir.ResetAcceptanceAmplification diff --git a/verification/whir/Whir/RewindBatchTarget.lean b/verification/whir/Whir/RewindBatchTarget.lean new file mode 100644 index 000000000..60d97230d --- /dev/null +++ b/verification/whir/Whir/RewindBatchTarget.lean @@ -0,0 +1,309 @@ +import Whir.RewindTrajectory +import Whir.QueryBatchSoundness + +/-! Witness-specific reset batching: authentication fixes rows even for a prover seeing the entire query tape and lambda. A nonzero batched-error collision is charged explicitly. Outside that event, restoration implies actual all-query-hit for a candidate selected by an already advertised OOD answer. Wrong advertised OOD answers remain permitted; they make successful restoration impossible outside the charged event when no candidate matches. -/ +namespace Whir.RewindBatchTarget +open Concrete Protocol CausalGame CausalExecution ExecutionShapes ParameterBounds VerifierInvariant +open LevelBoundary BatchingRefinement QueryBatchSoundness +open scoped BigOperators + +open CausalProbability Classical +set_option maxRecDepth 8192 +set_option maxHeartbeats 800000 +/-- Candidates, oracle, fold challenges, OOD points/answers and prior state are fixed before the adjacent query/lambda message. -/ +def Collision (n rate count i : Nat) (root : Oracle) (cs : LevelChallenges) + (p : LevelProof) (state : VerifierState E) (candidates : Finset (Array E)) + (tape : QueryTape (n + rate) count) (lambda : E) : Prop := + ∃ candidate ∈ candidates, + polynomial n rate count i root cs p state tape candidate ≠ 0 ∧ + (polynomial n rate count i root cs p state tape candidate).eval lambda = 0 + +/-- The OOD target is determined by the fixed list and the actual advertised point/value, not by queries or lambda. -/ +def Target (candidates : Finset (Array E)) (point : Array E) (answer : E) (candidate : Array E) : Prop := + candidate ∈ candidates ∧ Concrete.mle candidate point = answer + +theorem target_unique (candidates : Finset (Array E)) (point : Array E) (answer : E) + (separated : Separated candidates point) (left right : Array E) + (hl : Target candidates point answer left) (hr : Target candidates point answer right) : + left = right := separated left hl.1 right hr.1 (hl.2.trans hr.2.symm) + +/-- Every coefficient is interpreted using the real query sampler and actual authenticated oracle rows. -/ +theorem zero_error_hits (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (state : VerifierState E) + (tape : QueryTape (n + rate) count) (candidate : Array E) + (positive : 0 < n + rate) (noWrap : n + rate ≤ 64) + (zero : polynomial n rate count i root cs p state tape candidate = 0) : + dot candidate state.weight = state.claim ∧ + (∀ j < p.oods.size, Concrete.mle candidate cs.oodPoints[j]! = p.oods[j]!.value) ∧ + SamplingProbability.allQueriesHit (n + rate) count + (agreeingColumns n rate candidate (oldWord n rate root (i == 0) cs.folds)) tape := by + have coefficient := congrArg (fun x : Polynomial E => x.coeff 0) zero + have residual : dot candidate state.weight = state.claim := by + simpa [polynomial, errorPolynomial, batchPolynomial_coeff_zero, discrepancy, + sub_eq_zero] using coefficient + refine ⟨residual, ?_, queries (n + rate) count tape, + queries_actual _ _ _ positive noWrap, ?_⟩ + · intro j hj + have coefficient := congrArg (fun x : Polynomial E => x.coeff (j + 1)) zero + simpa only [polynomial, errorPolynomial, batchPolynomial_coeff_ood _ _ _ _ _ _ hj, + Polynomial.coeff_zero, oodError, Concrete.mle, sub_eq_zero] using coefficient + · intro j + have coefficient := congrArg (fun x : Polynomial E => x.coeff (p.oods.size + 1 + j.val)) zero + have hj : j.val < (queries (n + rate) count tape).size := by + rw [queries_size] + exact j.isLt + have error : queryError candidate n cs + {p with rows := (queries (n + rate) count tape).map (fun q => root[q]!)} + (queries (n + rate) count tape) (i == 0) j.val = 0 := by + simpa only [polynomial, errorPolynomial, + batchPolynomial_coeff_query _ _ _ _ _ _ hj, Polynomial.coeff_zero] using coefficient + classical + apply Finset.mem_image.mpr + refine ⟨⟨_, queries_bound _ _ _ _ j.isLt⟩, ?_, rfl⟩ + apply Finset.mem_filter.mpr + refine ⟨Finset.mem_univ _, ?_⟩ + change (encode n rate candidate)[(queries (n + rate) count tape)[j.val]!]! = _ + rw [encode, ArrayLayout.getElem!_tab _ _ _ (queries_bound _ _ _ _ j.isLt)] + simpa [queryError, oldWord, getElem!_pos, hj, sub_eq_zero] using error + +/-- This conclusion holds for arbitrary adaptive query replies; rows are fixed only by the actual authentication guard. -/ +theorem restores_zero_candidate (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (state : VerifierState E) + (candidates : Finset (Array E)) + (rowsAt : QueryTape (n + rate) count → E → Oracle) + (introAt : QueryTape (n + rate) count → E → Message E) + (sizes : ∀ f ∈ candidates, f.size = 2 ^ n) (weight : state.weight.size = 2 ^ n) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = 2 ^ n) + (draw : QueryTape (n + rate) count × E) + (restores : Restores n rate count i root cs p state candidates rowsAt introAt draw) + (outside : ¬ Collision n rate count i root cs p state candidates draw.1 draw.2) : + ∃ candidate ∈ candidates, polynomial n rate count i root cs p state draw.1 candidate = 0 := by + classical + obtain ⟨rows, auth, notLost⟩ := restores + simp only [Lost, not_forall, not_not] at notLost + obtain ⟨candidate, member, truth⟩ := notLost + have identity := authenticated_batch_vary_lambda candidate n i cs p + (queries (n + rate) count draw.1) root state (rowsAt draw.1) (introAt draw.1) + (sizes candidate member) (weight.trans (sizes candidate member).symm) + (by intro j hj; exact (oods j hj).trans (sizes candidate member).symm) draw.2 rows + ((OperationalRefinement.authentication_ok_iff _ _ _).mp auth) + have evaluated : (polynomial n rate count i root cs p state draw.1 candidate).eval draw.2 = 0 := by + change (errorPolynomial candidate n i cs + {p with rows := (queries (n + rate) count draw.1).map (fun q => root[q]!)} + (queries (n + rate) count draw.1) state).eval draw.2 = 0 + rw [← identity] + exact sub_eq_zero.mpr truth + refine ⟨candidate, member, ?_⟩ + by_contra nonzero + exact outside ⟨candidate, member, nonzero, evaluated⟩ + +/-- A restored candidate outside lambda collisions is the unique fixed advertised-OOD target and hits every actual query. No honest OOD-answer assumption is made. -/ +theorem restores_fixed_target (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (state : VerifierState E) + (candidates : Finset (Array E)) + (rowsAt : QueryTape (n + rate) count → E → Oracle) + (introAt : QueryTape (n + rate) count → E → Message E) + (sizes : ∀ f ∈ candidates, f.size = 2 ^ n) (weight : state.weight.size = 2 ^ n) + (oods : ∀ j < p.oods.size, (eqTable cs.oodPoints[j]!).size = 2 ^ n) + (positive : 0 < n + rate) (noWrap : n + rate ≤ 64) (first : 0 < p.oods.size) + (target : Array E) (matching : Target candidates cs.oodPoints[0]! p.oods[0]!.value target) + (separated : Separated candidates cs.oodPoints[0]!) + (draw : QueryTape (n + rate) count × E) + (restores : Restores n rate count i root cs p state candidates rowsAt introAt draw) + (outside : ¬ Collision n rate count i root cs p state candidates draw.1 draw.2) : + SamplingProbability.allQueriesHit (n + rate) count + (agreeingColumns n rate target (oldWord n rate root (i == 0) cs.folds)) draw.1 := by + obtain ⟨candidate, member, zero⟩ := restores_zero_candidate n rate count i root cs p state + candidates rowsAt introAt sizes weight oods draw restores outside + have hits := zero_error_hits n rate count i root cs p state draw.1 candidate positive noWrap zero + have same := target_unique candidates cs.oodPoints[0]! p.oods[0]!.value separated + candidate target ⟨member, hits.2.1 0 first⟩ matching + simpa only [same] using hits.2.2 + +private theorem batch_fields_congr (n i : Nat) (cs : LevelChallenges) + (p q : LevelProof) (qs : Array Nat) (state : VerifierState E) + (oods : p.oods = q.oods) (rows : p.rows = q.rows) (intro : p.intro = q.intro) : + queryBatch n i cs p qs (oodBatch cs p state) = + queryBatch n i cs q qs (oodBatch cs q state) := by + cases p + cases q + cases oods + cases rows + cases intro + rfl + +/-- Actual accepted reset continuations imply restoration in the same fixed-public causal interface. The committed next list, prior state and advertised OODs are fixed before the reset query draw; only adaptive rows and intro vary. -/ +theorem accepted_reset_restores (profile : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (tape : Tape (config profile)) + (level : Fin (config profile).folds.size) + (hasNext : level.val + 1 < (config profile).folds.size) + (draw : Sample (.query level)) + (accepted : experiment (Input profile lanes root claims) strategy (set (.query level) tape draw) = true) + (safe : ∀ q, ¬ CausalBadEvents.Bad (Input profile lanes root claims) strategy q + (set (.query level) tape draw)) : + Restores (remaining (config profile) level) (config profile).rates[level.val]! + (config profile).queries[level.val]! level + (levelAt (Input profile lanes root claims) strategy tape level).oracle + (challenges (config profile) tape).levels[level.val]! + (proof (Input profile lanes root claims) strategy tape).levels[level.val]! + (CausalBoundary.boundary (Input profile lanes root claims) strategy tape level).state + (followingCandidates (Input profile lanes root claims) strategy tape level) + (CausalBoundary.queryRows (Input profile lanes root claims) strategy tape level) + (CausalBoundary.queryIntro (Input profile lanes root claims) strategy tape level) draw := by + let input := Input profile lanes root claims + let reset := set (.query level) tape draw + have candidate := RewindTrajectory.accepted_following_candidate profile lanes root claims strategy + reset accepted level hasNext safe + have failure : ¬ Lost (followingCandidates input strategy reset level) + (levelAt input strategy reset (level.val + 1)).state := by + obtain ⟨witness, member, truth⟩ := candidate + intro lost + exact lost witness member truth + have checked := accepted_level input strategy reset accepted level level.isLt + have result := OperationalRefinement.verifyLevel_success _ _ _ level _ _ checked + dsimp only at result + have endEq := foldAt_end input strategy reset level level.isLt + dsimp only [block] at endEq + rw [← endEq] at result + have dims := (foldAt_shape profile lanes root claims strategy reset level + (config profile).folds[level.val]! le_rfl).1 + simp only [Nat.sub_self, Nat.add_zero] at dims + rw [dims, foldAt_oracle] at result + obtain ⟨_, _, qs, sampled, rows, auth, _⟩ := result + have derived : qs = (deriveQueries (remaining (config profile) level + + (config profile).rates[level.val]!) (config profile).queries[level.val]! + (challenges (config profile) reset).levels[level.val]!.querySqueezes).getD #[] := by + rw [sampled] + rfl + rw [derived] at rows auth + have bounds := CausalBoundary.production_boundary_facts profile level + have sampledReset : + (deriveQueries (remaining (config profile) level + (config profile).rates[level.val]!) + (config profile).queries[level.val]! + (challenges (config profile) reset).levels[level.val]!.querySqueezes).getD #[] = + queries (remaining (config profile) level + (config profile).rates[level.val]!) + (config profile).queries[level.val]! draw.1 := by + rw [CausalBoundary.query_challenges input tape level draw] + dsimp only + erw [queries_actual _ _ draw.1 bounds.1 bounds.2.1] + rfl + have fixed := CausalBoundary.followingCandidates_set input strategy tape (.query level) draw level + (by dsimp only [input]; rw [CausalPositions.position_query level tape]; omega) + have answers := CausalBoundary.oods_set input strategy tape (.query level) draw level + (by rw [CausalPositions.position_query]) + change ¬ Lost (followingCandidates input strategy (set (.query level) tape draw) level) + (levelAt input strategy (set (.query level) tape draw) (level.val + 1)).state at failure + have dimension : (CausalBoundary.boundary input strategy reset level).n = + remaining (config profile) level := dims + rw [CausalBoundary.next_state, dimension, sampledReset, fixed, + CausalBoundary.query_boundary_set, CausalBoundary.query_challenges] at failure + rw [sampledReset] at rows auth + rw [CausalBoundary.query_level_set] at auth + unfold Restores + dsimp only [CausalBoundary.queryRows, CausalBoundary.queryIntro] + refine ⟨rows, (OperationalRefinement.authentication_ok_iff _ _ _).mpr auth, ?_⟩ + have kernel := batch_fields_congr (remaining (config profile) level) level + { (challenges (config profile) tape).levels[level.val]! with + querySqueezes := Array.ofFn draw.1, lambda := draw.2 } + (proof input strategy reset).levels[level.val]! + { (proof input strategy tape).levels[level.val]! with + rows := (proof input strategy reset).levels[level.val]!.rows + intro := (proof input strategy reset).levels[level.val]!.intro } + (queries (remaining (config profile) level + (config profile).rates[level.val]!) + (config profile).queries[level.val]! draw.1) + (CausalBoundary.boundary input strategy tape level).state answers rfl rfl + erw [kernel] at failure + exact failure + +#print axioms accepted_reset_restores + +private theorem nonzero_collision_bound {F I : Type*} [CommRing F] [IsDomain F] [Fintype F] + [DecidableEq F] [DecidableEq I] (candidates : Finset I) (polynomials : I → Polynomial F) + (degree : Nat) (degrees : ∀ candidate ∈ candidates, (polynomials candidate).natDegree ≤ degree) + (event : F → Prop) [DecidablePred event] + (covered : ∀ lambda, event lambda → ∃ candidate ∈ candidates, polynomials candidate ≠ 0 ∧ + (polynomials candidate).eval lambda = 0) : + Soundness.uniformProb (Finset.univ.filter event) ≤ + (candidates.card : ℚ) * ((degree : ℚ) / Fintype.card F) := by + classical + let active := candidates.filter (fun candidate => polynomials candidate ≠ 0) + let errors (candidate : active) := polynomials candidate.val + have subset : Finset.univ.filter event ⊆ Finset.univ.biUnion (fun candidate : active => + Finset.univ.filter fun lambda : F => (errors candidate).eval lambda = 0) := by + intro lambda member + obtain ⟨candidate, belongs, nonzero, evaluated⟩ := + covered lambda (Finset.mem_filter.mp member).2 + exact Finset.mem_biUnion.mpr + ⟨⟨candidate, Finset.mem_filter.mpr ⟨belongs, nonzero⟩⟩, Finset.mem_univ _, + Finset.mem_filter.mpr ⟨Finset.mem_univ _, evaluated⟩⟩ + have nonzero (candidate : active) : errors candidate ≠ 0 := + (Finset.mem_filter.mp candidate.property).2 + have small (candidate : active) : (errors candidate).natDegree ≤ degree := + degrees candidate.val (Finset.mem_filter.mp candidate.property).1 + have first : Soundness.uniformProb (Finset.univ.filter event) ≤ + Soundness.uniformProb (Finset.univ.biUnion (fun candidate : active => + Finset.univ.filter fun lambda : F => (errors candidate).eval lambda = 0)) := by + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right + · exact_mod_cast Finset.card_le_card subset + · positivity + have roots (candidate : active) : + (Finset.univ.filter fun lambda : F => (errors candidate).eval lambda = 0).card ≤ degree := by + have rootCount : (Finset.univ.filter fun lambda : F => + (errors candidate).eval lambda = 0).card ≤ (errors candidate).natDegree := by + apply Polynomial.card_le_degree_of_subset_roots + intro lambda member + exact (Polynomial.mem_roots (nonzero candidate)).mpr (Finset.mem_filter.mp member).2 + exact rootCount.trans (small candidate) + have rootBound (candidate : active) : + Soundness.uniformProb (Finset.univ.filter fun lambda : F => + (errors candidate).eval lambda = 0) ≤ (degree : ℚ) / Fintype.card F := by + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast roots candidate) (by positivity) + have listBound : Soundness.uniformProb (Finset.univ.biUnion (fun candidate : active => + Finset.univ.filter fun lambda : F => (errors candidate).eval lambda = 0)) ≤ + (Fintype.card active : ℚ) * ((degree : ℚ) / Fintype.card F) := by + calc + _ ≤ ∑ candidate : active, Soundness.uniformProb + (Finset.univ.filter fun lambda : F => (errors candidate).eval lambda = 0) := + Soundness.union_bound _ + _ ≤ ∑ _candidate : active, (degree : ℚ) / Fintype.card F := + Finset.sum_le_sum (fun candidate _ => rootBound candidate) + _ = _ := by simp + have bound := first.trans listBound + rw [Fintype.card_coe] at bound + have countBound : (active.card : ℚ) ≤ candidates.card := by + exact_mod_cast Finset.card_le_card (Finset.filter_subset _ _) + have positive : (0 : ℚ) ≤ (degree : ℚ) / Fintype.card F := by positivity + simpa only [Fintype.card_coe] using + bound.trans (mul_le_mul_of_nonneg_right countBound positive) + +/-- Exact lambda loss for each permitted fixed query tape. Candidate count and the actual batch width are charged; no 128-bit claim is inferred. -/ +theorem collision_probability (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (p : LevelProof) (state : VerifierState E) + (candidates : Finset (Array E)) (tape : QueryTape (n + rate) count) : + Soundness.uniformProb (Finset.univ.filter + (Collision n rate count i root cs p state candidates tape)) ≤ + (candidates.card : ℚ) * ((p.oods.size + count : Nat) / (2 ^ 192 : ℚ)) := by + have bound := @nonzero_collision_bound E (Array E) FieldModel.instCommRingE + inferInstance inferInstance inferInstance inferInstance candidates + (polynomial n rate count i root cs p state tape) (p.oods.size + count) (by + intro candidate member + simpa [polynomial] using errorPolynomial_degree candidate n i cs + {p with rows := (queries (n + rate) count tape).map (fun q => root[q]!)} + (queries (n + rate) count tape) state) + (Collision n rate count i root cs p state candidates tape) inferInstance + (by + intro lambda member + exact member) + have card : (Fintype.card E : ℚ) = (2 ^ 192 : ℚ) := by + rw [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] + exact bound.trans_eq (by rw [card]) + +#print axioms collision_probability + +#print axioms target_unique +#print axioms zero_error_hits +#print axioms restores_zero_candidate +#print axioms restores_fixed_target +end Whir.RewindBatchTarget diff --git a/verification/whir/Whir/RewindCoverage.lean b/verification/whir/Whir/RewindCoverage.lean new file mode 100644 index 000000000..13f802f55 --- /dev/null +++ b/verification/whir/Whir/RewindCoverage.lean @@ -0,0 +1,207 @@ +import Whir.SamplingProbability + +/-! Coverage of actual stratified query positions across fresh independent reset tapes. These tapes do not change the committed statement or fixed prover coins. Coordinate coverage is not authenticated response availability: a malicious prover can withhold or malform its answer. No Fiat-Shamir reset interface is inferred. -/ +namespace Whir.RewindCoverage +open Concrete SamplingProbability +open scoped BigOperators + +abbrev QueryTape (depth count : Nat) := Fin ((count + 192 / depth - 1) / (192 / depth)) → E + +/-- The actual sampler misses a coordinate precisely when every sampled position lies in its complement. -/ +def Misses (depth count : Nat) (target : Fin (2 ^ depth)) (tape : QueryTape depth count) : Prop := + allQueriesHit depth count (Finset.univ.erase target) tape + +def MissesAll (depth count rounds : Nat) (target : Fin (2 ^ depth)) + (seed : Fin rounds → QueryTape depth count) : Prop := + ∀ round, Misses depth count target (seed round) + +private def splitUnit (A : Type*) : A ≃ Unit × A where + toFun a := ((), a) + invFun a := a.2 + left_inv _ := rfl + right_inv a := by cases a with | mk unitValue a => cases unitValue; rfl + +/-- Independence is proved from the product seed space, rather than asserted for adaptive prover replies. -/ +theorem missesAll_probability (depth count rounds : Nat) (target : Fin (2 ^ depth)) : + probability (MissesAll depth count rounds target) = + probability (Misses depth count target) ^ rounds := by + have product := coordinateEvent_probability + (splitUnit (Fin rounds → QueryTape depth count)) + (fun _ tape => Misses depth count target tape) + change probability (MissesAll depth count rounds target) = + ∏ _ : Fin rounds, probability (Misses depth count target) at product + simpa using product + +/-- Exact finite-size miss fraction for the AM-GM envelope of the actual stratified law. -/ +noncomputable def missFraction (depth : Nat) : ℝ := + ((2 ^ depth - 1 : Nat) : ℝ) / (2 ^ depth : Nat) + +theorem misses_probability_le (depth count : Nat) (positive : 0 < depth) (noWrap : depth ≤ 64) + (target : Fin (2 ^ depth)) : + probability (Misses depth count target) ≤ missFraction depth ^ count := by + have bound := actual_query_bound depth count positive noWrap (Finset.univ.erase target) + change probability (allQueriesHit depth count (Finset.univ.erase target)) ≤ _ + simpa only [Misses, StratifiedDensity.globalDensity, missFraction, + Finset.card_erase_of_mem (Finset.mem_univ target), Finset.card_univ, Fintype.card_fin] using bound + +/-- The response-call schedule can use these exact fresh tape shapes at the same prefix. This proves only coordinate coverage of the messages. -/ +theorem missesAll_probability_le (depth count rounds : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) (target : Fin (2 ^ depth)) : + probability (MissesAll depth count rounds target) ≤ missFraction depth ^ (count * rounds) := by + rw [missesAll_probability] + calc + probability (Misses depth count target) ^ rounds ≤ (missFraction depth ^ count) ^ rounds := + pow_le_pow_left₀ (by unfold probability; positivity) + (misses_probability_le depth count positive noWrap target) rounds + _ = missFraction depth ^ (count * rounds) := by rw [pow_mul] + +/-- A finite-domain query position from the same chunk and stratum used by the actual sampler. -/ +def sampledPosition (depth count : Nat) (positive : 0 < depth) (noWrap : depth ≤ 64) + (tape : QueryTape depth count) (i : Fin count) : Fin (2 ^ depth) := + StratifiedDensity.placed (queryStratum count depth i) + ((queryEquiv depth _ count + (squeezeCount_capacity depth count positive (by omega)) tape).2 i) + +theorem sampledPosition_actual (depth count : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) (tape : QueryTape depth count) (i : Fin count) : + (sampledPosition depth count positive noWrap tape i).val = + concretePlace count depth i.val + (Layout.rawQuery depth (fun j => (Array.ofFn tape)[j]!.toNat) i.val) := by + rw [concretePlace_eq] + change Layout.placeQuery (queryStratum count depth i) + (((queryEquiv depth _ count + (squeezeCount_capacity depth count positive (by omega)) tape).2 i).val) = _ + rw [queryEquiv_rawQuery] + +theorem misses_iff (depth count : Nat) (positive : 0 < depth) (noWrap : depth ≤ 64) + (target : Fin (2 ^ depth)) (tape : QueryTape depth count) : + Misses depth count target tape ↔ + ∀ i, sampledPosition depth count positive noWrap tape i ≠ target := by + classical + unfold Misses allQueriesHit + rw [deriveQueries_eq depth count positive noWrap] + simp only [Option.some.injEq] + constructor + · rintro ⟨qs, rfl, hit⟩ i equal + have member := hit i + rw [ArrayLayout.getElem!_tab _ _ _ i.isLt] at member + rw [← sampledPosition_actual depth count positive noWrap tape i, equal] at member + obtain ⟨q, hq, same⟩ := Finset.mem_image.mp member + have : q = target := Fin.ext same + simp [this] at hq + · intro misses + refine ⟨_, rfl, ?_⟩ + intro i + rw [ArrayLayout.getElem!_tab _ _ _ i.isLt] + rw [← sampledPosition_actual depth count positive noWrap tape i] + exact Finset.mem_image.mpr + ⟨_, Finset.mem_erase.mpr ⟨misses i, Finset.mem_univ _⟩, rfl⟩ + +/-- This is coordinate coverage; it deliberately does not promise that the prover answers those coordinates. -/ +def Covers (depth count rounds : Nat) (positive : 0 < depth) (noWrap : depth ≤ 64) + (seed : Fin rounds → QueryTape depth count) : Prop := + ∀ target : Fin (2 ^ depth), ∃ round i, + sampledPosition depth count positive noWrap (seed round) i = target + +theorem not_covers_iff (depth count rounds : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) (seed : Fin rounds → QueryTape depth count) : + ¬ Covers depth count rounds positive noWrap seed ↔ + ∃ target, MissesAll depth count rounds target seed := by + classical + simp only [Covers, MissesAll, misses_iff depth count positive noWrap] + push Not + rfl + +/-- Domain-wide coverage loss for the real stratified sampler, with no iid substitution. -/ +theorem coverage_failure_probability_le (depth count rounds : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) : + probability (fun seed : Fin rounds → QueryTape depth count => + ¬ Covers depth count rounds positive noWrap seed) ≤ + (2 ^ depth : Nat) * missFraction depth ^ (count * rounds) := by + classical + have union := Soundness.union_bound (fun target : Fin (2 ^ depth) => + Finset.univ.filter (MissesAll depth count rounds target)) + have events : + (Finset.univ.filter fun seed : Fin rounds → QueryTape depth count => + ¬ Covers depth count rounds positive noWrap seed) = + Finset.univ.biUnion (fun target : Fin (2 ^ depth) => + Finset.univ.filter (MissesAll depth count rounds target)) := by + ext seed + simp [not_covers_iff] + rw [probability_eq_uniformProb, events] + calc + _ ≤ ∑ target : Fin (2 ^ depth), + (Soundness.uniformProb (Finset.univ.filter + (MissesAll depth count rounds target)) : ℝ) := by exact_mod_cast union + _ = ∑ target : Fin (2 ^ depth), probability (MissesAll depth count rounds target) := by + simp only [probability_eq_uniformProb] + _ ≤ ∑ _ : Fin (2 ^ depth), missFraction depth ^ (count * rounds) := + Finset.sum_le_sum fun target _ => missesAll_probability_le depth count rounds positive noWrap target + _ = _ := by simp + +theorem missFraction_domain_power_le (depth : Nat) (positive : 0 < depth) : + missFraction depth ^ (2 ^ depth) ≤ (1 / 2 : ℝ) := by + let N := 2 ^ depth + have two : 2 ≤ N := by + dsimp [N] + simpa using Nat.pow_le_pow_right (by decide : 1 ≤ 2) positive + have predPositive : (0 : ℝ) < (N - 1 : Nat) := by exact_mod_cast (by omega : 0 < N - 1) + have predCast : ((N - 1 : Nat) : ℝ) = (N : ℝ) - 1 := by + rw [Nat.cast_sub (by omega : 1 ≤ N)] + norm_num + have nPositive : (0 : ℝ) < N := by exact_mod_cast (by omega : 0 < N) + have nonneg : 0 ≤ missFraction depth := by unfold missFraction; positivity + have atMostOne : missFraction depth ≤ 1 := by + unfold missFraction + exact (div_le_one nPositive).mpr (by exact_mod_cast (Nat.sub_le N 1)) + have bernoulli := one_add_mul_le_pow + (show (-2 : ℝ) ≤ 1 / (N - 1 : Nat) by + have : (0 : ℝ) ≤ 1 / (N - 1 : Nat) := by positivity + linarith) (N - 1) + have lower : (2 : ℝ) ≤ (1 + 1 / (N - 1 : Nat)) ^ (N - 1) := by + have cancelled : ((N - 1 : Nat) : ℝ) * (1 / (N - 1 : Nat)) = 1 := by + field_simp [ne_of_gt predPositive] + rw [cancelled] at bernoulli + norm_num only [one_add_one_eq_two] at bernoulli + exact bernoulli + have reciprocal : missFraction depth * (1 + 1 / (N - 1 : Nat)) = 1 := by + unfold missFraction + change ((N - 1 : Nat) : ℝ) / (N : ℝ) * (1 + 1 / (N - 1 : Nat)) = 1 + rw [predCast] + field_simp [ne_of_gt nPositive, show (N : ℝ) - 1 ≠ 0 by linarith] + ring + have multiplied := mul_le_mul_of_nonneg_left lower + (pow_nonneg nonneg (N - 1)) + have product : missFraction depth ^ (N - 1) * + (1 + 1 / (N - 1 : Nat)) ^ (N - 1) = 1 := by + rw [← mul_pow, reciprocal, one_pow] + rw [product] at multiplied + have predecessor : missFraction depth ^ (N - 1) ≤ (1 / 2 : ℝ) := by linarith + change missFraction depth ^ N ≤ _ + have successor : N = (N - 1) + 1 := by omega + rw [successor, pow_succ] + exact (mul_le_of_le_one_right (pow_nonneg nonneg _) atMostOne).trans predecessor + +/-- A polynomial reset schedule: N·security trials suffice for exponentially small coordinate-coverage loss. Answer availability and decoding proximity are not included. -/ +theorem polynomial_schedule_coverage (depth count security : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) : + probability (fun seed : Fin (2 ^ depth * security) → QueryTape depth count => + ¬ Covers depth count (2 ^ depth * security) positive noWrap seed) ≤ + (2 ^ depth : Nat) * (1 / 2 : ℝ) ^ (count * security) := by + refine (coverage_failure_probability_le depth count _ positive noWrap).trans ?_ + apply mul_le_mul_of_nonneg_left _ (by positivity) + rw [show count * (2 ^ depth * security) = 2 ^ depth * (count * security) by ring, pow_mul] + exact pow_le_pow_left₀ (by unfold missFraction; positivity) + (missFraction_domain_power_le depth positive) _ + +#print axioms missesAll_probability +#print axioms misses_probability_le +#print axioms missesAll_probability_le +#print axioms sampledPosition_actual +#print axioms misses_iff +#print axioms not_covers_iff +#print axioms coverage_failure_probability_le +#print axioms missFraction_domain_power_le +#print axioms polynomial_schedule_coverage + +end Whir.RewindCoverage diff --git a/verification/whir/Whir/RewindRadiusExtraction.lean b/verification/whir/Whir/RewindRadiusExtraction.lean new file mode 100644 index 000000000..d00816894 --- /dev/null +++ b/verification/whir/Whir/RewindRadiusExtraction.lean @@ -0,0 +1,114 @@ +import Whir.RewindBatchTarget +import Whir.UniqueRadiusSampling +import Whir.RewindCoverage + +/-! Actual accepted query resets hit a fixed Root1/OOD-selected target outside the explicitly charged causal and batched-polynomial collision events. The target is fixed before query squeezes/lambda. This is the projection step toward extraction, not an assumption that acceptance puts every initial base lane in the unique radius. -/ +namespace Whir.RewindRadiusExtraction +open Concrete Protocol CausalGame CausalExecution ExecutionShapes ParameterBounds VerifierInvariant +open CausalProbability LevelBoundary QueryBatchSoundness RewindBatchTarget Classical +set_option maxRecDepth 2048 +set_option maxHeartbeats 800000 + +theorem accepted_reset_fixed_target (profile : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (tape : Tape (config profile)) + (level : Fin (config profile).folds.size) + (hasNext : level.val + 1 < (config profile).folds.size) (draw : Sample (.query level)) + (target : Array E) + (matching : Target (followingCandidates (Input profile lanes root claims) strategy tape level) + (challenges (config profile) tape).levels[level.val]!.oodPoints[0]! + (proof (Input profile lanes root claims) strategy tape).levels[level.val]!.oods[0]!.value target) + (separated : Separated (followingCandidates (Input profile lanes root claims) strategy tape level) + (challenges (config profile) tape).levels[level.val]!.oodPoints[0]!) + (accepted : experiment (Input profile lanes root claims) strategy (set (.query level) tape draw) = true) + (safe : ∀ q, ¬ CausalBadEvents.Bad (Input profile lanes root claims) strategy q + (set (.query level) tape draw)) + (outside : ¬ Collision (remaining (config profile) level) (config profile).rates[level.val]! + (config profile).queries[level.val]! level + (levelAt (Input profile lanes root claims) strategy tape level).oracle + (challenges (config profile) tape).levels[level.val]! + (proof (Input profile lanes root claims) strategy tape).levels[level.val]! + (CausalBoundary.boundary (Input profile lanes root claims) strategy tape level).state + (followingCandidates (Input profile lanes root claims) strategy tape level) draw.1 draw.2) : + SamplingProbability.allQueriesHit + (remaining (config profile) level + (config profile).rates[level.val]!) + (config profile).queries[level.val]! + (agreeingColumns (remaining (config profile) level) (config profile).rates[level.val]! target + (oldWord (remaining (config profile) level) (config profile).rates[level.val]! + (levelAt (Input profile lanes root claims) strategy tape level).oracle + (level.val == 0) (challenges (config profile) tape).levels[level.val]!.folds)) draw.1 := by + let input := Input profile lanes root claims + have restored := accepted_reset_restores profile lanes root claims strategy tape level hasNext draw + accepted safe + have facts := CausalBoundary.production_boundary_facts profile level + have sizes := CausalBoundary.followingCandidates_sizes input strategy tape profile rfl level + (by intro impossible; exact (impossible hasNext).elim) + have weight : (CausalBoundary.boundary input strategy tape level).state.weight.size = + 2 ^ remaining (config profile) level := by + have shape := (foldAt_shape profile lanes root claims strategy tape level + (config profile).folds[level.val]! le_rfl).2 + simpa only [CausalBoundary.boundary, input, Nat.sub_self, Nat.add_zero] using shape + have oods : ∀ j < (proof input strategy tape).levels[level.val]!.oods.size, + (eqTable (challenges (config profile) tape).levels[level.val]!.oodPoints[j]!).size = + 2 ^ remaining (config profile) level := by + intro j bound + rw [CausalBoundary.decoded_oods_size] at bound + exact CausalBoundary.point_size input tape level j bound + have first : 0 < (proof input strategy tape).levels[level.val]!.oods.size := by + rw [CausalBoundary.decoded_oods_size] + exact (facts.2.2 hasNext).2 + exact restores_fixed_target _ _ _ _ _ _ _ _ _ _ _ sizes weight oods facts.1 facts.2.1 + first target matching separated draw restored outside + +/-- The adjacent fresh lambda does not change the fixed-target hit probability. This is a product-coordinate identity, not a Fiat Shamir independence assertion. -/ +theorem lifted_hit_probability (depth count : Nat) + (received target : Fin (2 ^ depth) → E) : + Soundness.uniformProb (Finset.univ.filter + (fun draw : RewindCoverage.QueryTape depth count × E => + SamplingProbability.allQueriesHit depth count + (UniqueRadiusSampling.agreement depth received target) draw.1)) = + UniqueRadiusSampling.hitProbability depth count received target := by + unfold UniqueRadiusSampling.hitProbability Soundness.uniformProb + rw [← Finset.univ_product_univ] + rw [Finset.filter_product_left + (s := (Finset.univ : Finset (RewindCoverage.QueryTape depth count))) + (t := (Finset.univ : Finset E)) + (SamplingProbability.allQueriesHit depth count + (UniqueRadiusSampling.agreement depth received target))] + rw [Finset.card_product, Fintype.card_prod, Finset.card_univ] + push_cast + have domainPositive : (Fintype.card (RewindCoverage.QueryTape depth count) : ℚ) ≠ 0 := by + positivity + have fieldPositive : (Fintype.card E : ℚ) ≠ 0 := by positivity + field_simp [domainPositive, fieldPositive] + +/-- A pointwise, already-derived actual-hit cover converts conditional accepted mass to the exact strict unique-decoding radius. It applies to the accepted-reset event proved above, not to unrestricted acceptance. -/ +theorem hit_cover_above_implies_radius (depth dimension count : Nat) + (positive : 0 < depth) (noWrap : depth ≤ 64) (dimensionBound : dimension ≤ 2 ^ depth) + (received target : Fin (2 ^ depth) → E) + (event : RewindCoverage.QueryTape depth count × E → Prop) + (cover : ∀ draw, event draw → SamplingProbability.allQueriesHit depth count + (UniqueRadiusSampling.agreement depth received target) draw.1) + (above : UniqueRadiusSampling.queryLoss depth dimension count < + Soundness.uniformProb (Finset.univ.filter event)) : + 2 * hammingDist received target ≤ 2 ^ depth - dimension := by + have subset : (Finset.univ.filter event) ⊆ + Finset.univ.filter (fun draw : RewindCoverage.QueryTape depth count × E => + SamplingProbability.allQueriesHit depth count + (UniqueRadiusSampling.agreement depth received target) draw.1) := by + intro draw member + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, cover draw (Finset.mem_filter.mp member).2⟩ + have mass : Soundness.uniformProb (Finset.univ.filter event) ≤ + UniqueRadiusSampling.hitProbability depth count received target := by + rw [← lifted_hit_probability] + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right + · exact_mod_cast Finset.card_le_card subset + · positivity + exact UniqueRadiusSampling.hitProbability_above_implies_radius depth dimension count + positive noWrap dimensionBound received target (above.trans_le mass) + +#print axioms lifted_hit_probability +#print axioms hit_cover_above_implies_radius + +#print axioms accepted_reset_fixed_target +end Whir.RewindRadiusExtraction diff --git a/verification/whir/Whir/RewindRowExtraction.lean b/verification/whir/Whir/RewindRowExtraction.lean new file mode 100644 index 000000000..e369ab5e5 --- /dev/null +++ b/verification/whir/Whir/RewindRowExtraction.lean @@ -0,0 +1,545 @@ +import Whir.KnowledgeExtraction +import Whir.CausalPrefix +import Whir.RewindCoverage + +/-! Fixed-input reset access and deterministic reconstruction from authenticated records. Every response is obtained by replaying the same committed prover history with fixed coins. Coverage and authentication are explicit access premises, not consequences of acceptance or primitive collision resistance. This interface cannot change public claims and grants no Fiat-Shamir reset ability. -/ +namespace Whir.RewindRowExtraction +open Concrete Protocol CausalGame KnowledgeExtraction + +structure QueryRequest where + level : Nat + squeezes : Array E + lambda : E + +def QueryRequest.batch (request : QueryRequest) : Batch := + .query request.level request.squeezes request.lambda + +structure Collected where + replies : List Reply + responseCalls : Nat + +/-- Replays are real black-box calls. A prefix is replayed once for each request; replies are never supplied by the extractor. -/ +def collect (input : Public) (strategy : Strategy) (historyPrefix : List Batch) : + List QueryRequest → Collected + | [] => ⟨[], 0⟩ + | request :: rest => + let past := replayPast input strategy [] historyPrefix + let answer := strategy input past request.batch + let result := collect input strategy historyPrefix rest + ⟨answer :: result.replies, result.responseCalls + historyPrefix.length + 1⟩ + +theorem collect_replies (input : Public) (strategy : Strategy) (historyPrefix : List Batch) + (requests : List QueryRequest) : + (collect input strategy historyPrefix requests).replies = requests.map (fun request => + strategy input (replayPast input strategy [] historyPrefix) request.batch) := by + induction requests with + | nil => rfl + | cons request rest ih => simp [collect, ih] + +theorem collect_responseCalls (input : Public) (strategy : Strategy) (historyPrefix : List Batch) + (requests : List QueryRequest) : + (collect input strategy historyPrefix requests).responseCalls = + requests.length * (historyPrefix.length + 1) := by + induction requests with + | nil => simp [collect] + | cons request rest ih => simp [collect, ih, Nat.add_mul, Nat.mul_add]; omega + +/-- The collector expressed in the bounded reset machine. Its continuation consumes replies actually returned by the black box. -/ +def collectProgram (input : Public) (historyPrefix : List Batch) : + List QueryRequest → (List Reply → Option (Witness input.config input.lanes)) → + RewindProgram input.config input.lanes + | [], finish => .finish (finish []) + | request :: rest, finish => + .query historyPrefix request.batch (fun reply => + collectProgram input historyPrefix rest (fun replies => finish (reply :: replies))) + +theorem run_collectProgram (input : Public) (strategy : Strategy) (historyPrefix : List Batch) + (maxReplay : Nat) (within : historyPrefix.length ≤ maxReplay) + (requests : List QueryRequest) (finish : List Reply → Option (Witness input.config input.lanes)) : + runRewind input strategy maxReplay requests.length + (collectProgram input historyPrefix requests finish) = + ⟨finish (collect input strategy historyPrefix requests).replies, + (collect input strategy historyPrefix requests).responseCalls⟩ := by + induction requests generalizing finish with + | nil => rfl + | cons request rest ih => + simp only [collectProgram, List.length_cons, runRewind, ite_eq_left within] + rw [ih] + rfl + + +open CausalProbability in +/-- The prefix is taken from the verifier's actual wire stream, not selected by an oracle-access assumption. -/ +def queryPrefix (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) : List Batch := + (visibleBatches input.config tape.1 (challenges input.config tape)).take + (position (.query level)) + +open CausalProbability in +def resetRequest (input : Public) (level : Fin input.config.folds.size) + (sample : Sample (.query level)) : QueryRequest := + ⟨level.val, Array.ofFn sample.1, sample.2⟩ + +open CausalProbability in +/-- An allowed reset changes only the current query coordinate. The committed input and all earlier verifier messages remain identical. -/ +theorem queryPrefix_reset (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) (sample : Sample (.query level)) : + queryPrefix input (set (.query level) tape sample) level = + queryPrefix input tape level := + visible_prefix (.query level) tape sample + +open CausalProbability in +theorem resetRequest_actual_batch (input : Public) (tape : Tape input.config) + (level : Fin input.config.folds.size) (sample : Sample (.query level)) : + (resetRequest input level sample).batch = + challengeBatch (.query level) (set (.query level) tape sample) := by + rw [challengeBatch_eq, get_set] + rfl + +open CausalProbability in +/-- Independent product-seed query coordinates are each replayed at this same real verifier prefix, with fixed prover coins. -/ +def collectResets (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (rounds : Nat) + (seed : Fin rounds → Sample (.query level)) : Collected := + collect prover.input prover.respond (queryPrefix prover.input tape level) + (List.ofFn fun round => resetRequest prover.input level (seed round)) + +open CausalProbability in +theorem collectResets_responseCalls (prover : CommittedProver) + (tape : Tape prover.input.config) (level : Fin prover.input.config.folds.size) + (rounds : Nat) (seed : Fin rounds → Sample (.query level)) : + (collectResets prover tape level rounds seed).responseCalls = + rounds * ((queryPrefix prover.input tape level).length + 1) := by + simp [collectResets, collect_responseCalls] + +open CausalProbability in +theorem collectResets_responseCalls_le (prover : CommittedProver) + (tape : Tape prover.input.config) (level : Fin prover.input.config.folds.size) + (rounds : Nat) (seed : Fin rounds → Sample (.query level)) : + (collectResets prover tape level rounds seed).responseCalls ≤ + rounds * (position (.query level) + 1) := by + rw [collectResets_responseCalls] + apply Nat.mul_le_mul_left + exact Nat.add_le_add_right (List.length_take_le _ _) 1 + +/-- Acceptance supplies authentic query rows through the actual verifier guard. This is an ideal-oracle equality, not a proof that a digest exposes its full preimage. -/ +theorem accepted_queries_authenticated (input : Public) (strategy : Strategy) + (tape : Tape input.config) (accepted : experiment input strategy tape = true) + (level : Fin input.config.folds.size) : + ∃ positions, + deriveQueries ((CausalExecution.foldAt input strategy tape level + input.config.folds[level.val]!).n + input.config.rates[level.val]!) + input.config.queries[level.val]! + (challenges input.config tape).levels[level.val]!.querySqueezes = some positions ∧ + (CausalExecution.proof input strategy tape).levels[level.val]!.rows.size = positions.size ∧ + ∀ j, j < positions.size → + ((CausalExecution.proof input strategy tape).levels[level.val]!.rows[j]! != + (CausalExecution.levelAt input strategy tape level).oracle[positions[j]!]!) = false := by + have result := OperationalRefinement.verifyLevel_success input.config + (challenges input.config tape) (CausalExecution.proof input strategy tape) level _ _ + (CausalExecution.accepted_level input strategy tape accepted level level.isLt) + dsimp only at result + have endEq := ExecutionShapes.foldAt_end input strategy tape level level.isLt + dsimp only [CausalExecution.block] at endEq + rw [← endEq] at result + obtain ⟨_, _, positions, sampled, rowCount, auth, _⟩ := result + exact ⟨positions, sampled, rowCount, by simpa only [ExecutionShapes.foldAt_oracle] using auth⟩ + +open CausalProbability in +/-- All accepted reset trials at a query authenticate against this same prefix-fixed oracle. Current query randomness cannot replace it. -/ +theorem reset_oracle_fixed (input : Public) (strategy : Strategy) (tape : Tape input.config) + (level : Fin input.config.folds.size) (sample : Sample (.query level)) : + (CausalExecution.levelAt input strategy (set (.query level) tape sample) level).oracle = + (CausalExecution.levelAt input strategy tape level).oracle := by + have fixed := CausalStateCausality.levelAt_set input strategy (.query level) tape sample + level level.isLt.le (by rw [CausalPositions.position_query level tape]; omega) + exact congrArg CheckedState.oracle fixed +/-- Parsing is restricted to actual query replies. A malformed tag supplies no row. -/ +def rows (reply : Reply) : Option Oracle := + match reply with + | .query rows _ => some rows + | _ => none + +section Records +variable {F : Type*} [Zero F] {N : Nat} +omit [Zero F] + +/-- Coordinates refer to one fixed committed word. This is not an oracle call. -/ +def lookup : List (Fin N × F) → Fin N → Option F + | [], _ => none + | (position, value) :: rest, target => + if target = position then some value else lookup rest target + +/-- Count the coordinate comparisons executed by exactly the same lookup. -/ +def countedLookup : List (Fin N × F) → Fin N → Option F × Nat + | [], _ => (none, 0) + | (position, value) :: rest, target => + if target = position then (some value, 1) + else + let result := countedLookup rest target + (result.1, result.2 + 1) + +omit [Zero F] in +theorem countedLookup_value (records : List (Fin N × F)) (target : Fin N) : + (countedLookup records target).1 = lookup records target := by + induction records with + | nil => rfl + | cons record rest ih => + rcases record with ⟨position, value⟩ + simp only [countedLookup, lookup] + split_ifs <;> simp_all + +omit [Zero F] in +theorem countedLookup_comparisons (records : List (Fin N × F)) (target : Fin N) : + (countedLookup records target).2 ≤ records.length := by + induction records with + | nil => simp [countedLookup] + | cons record rest ih => + rcases record with ⟨position, value⟩ + simp only [countedLookup] + split_ifs <;> simp_all + +omit [Zero F] in +theorem lookup_authenticated (records : List (Fin N × F)) (committed : Fin N → F) + (authenticated : ∀ record ∈ records, record.2 = committed record.1) + (target : Fin N) (covered : ∃ record ∈ records, record.1 = target) : + lookup records target = some (committed target) := by + induction records with + | nil => simp at covered + | cons record rest ih => + rcases record with ⟨position, value⟩ + simp only [lookup] + split_ifs with same + · subst target + simpa using congrArg some (authenticated (position, value) (by simp)) + · apply ih (fun record member => authenticated record (by simp [member])) + obtain ⟨record, member, positionEq⟩ := covered + rcases List.mem_cons.mp member with first | later + · subst record + exact False.elim (same positionEq.symm) + · exact ⟨record, later, positionEq⟩ + +/-- Missing coordinates fail. The complete-word interface does not invent authenticated answers or fill erasures with guessed values. -/ +def assemble (records : List (Fin N × F)) : Option (Vector F N) := + if complete : ∀ i, (lookup records i).isSome = true then + some (Vector.ofFn fun i => (lookup records i).get (complete i)) + else none + +theorem assemble_eq_committed (records : List (Fin N × F)) (committed : Fin N → F) + (authenticated : ∀ record ∈ records, record.2 = committed record.1) + (covered : ∀ target, ∃ record ∈ records, record.1 = target) : + assemble records = some (Vector.ofFn committed) := by + have complete : ∀ i, (lookup records i).isSome = true := by + intro target + rw [lookup_authenticated records committed authenticated target (covered target)] + rfl + simp only [assemble, dite_eq_left complete] + congr 2 + funext target + simp [lookup_authenticated records committed authenticated target (covered target)] + +/-- One coordinate-by-coordinate pass. Assembly may scan twice, once for coverage and once for values, so the complete assembler uses at most twice this bound. Field arithmetic and verifier work are not included. -/ +def assemblyComparisons (records : List (Fin N × F)) : Nat := + ∑ i : Fin N, (countedLookup records i).2 + +theorem assemblyComparisons_le (records : List (Fin N × F)) : + assemblyComparisons records ≤ N * records.length := by + calc + assemblyComparisons records ≤ ∑ _ : Fin N, records.length := + Finset.sum_le_sum fun i _ => countedLookup_comparisons records i + _ = N * records.length := by simp + +end Records + +/-- Compose authenticated access-log reconstruction with the actual supported-row decoder. No dense-root reads occur inside this algorithm. Coverage remains a caller obligation, not an assumed sampling probability. -/ +def extractRecords (n rate : Nat) (noWrap : n + rate ≤ 64) + (records : List (Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n × E)) : + Option (Array K) := + (assemble records).bind (ConcreteRowExtraction.extractRow n rate noWrap) + +/-- Execute the certified counter of the same complete source-row decoder after real record assembly. Incomplete access performs no decoder arithmetic. Comparisons, memory and reset response calls remain separately charged. -/ +def countedExtractRecords (n rate : Nat) (noWrap : n + rate ≤ 64) + (records : List (Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n × E)) : + Option (Array K) × Nat := + match assemble records with + | none => (none, 0) + | some received => ConcreteRowExtraction.countedExtractRow n rate noWrap received + +theorem countedExtractRecords_value (n rate : Nat) (noWrap : n + rate ≤ 64) + (records : List (Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n × E)) : + (countedExtractRecords n rate noWrap records).1 = extractRecords n rate noWrap records := by + unfold countedExtractRecords extractRecords + cases assembled : assemble records with + | none => rfl + | some received => + simpa using ConcreteRowExtraction.countedExtractRow_value n rate noWrap received + +theorem countedExtractRecords_polynomial_cost (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) + (records : List (Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n × E)) : + (countedExtractRecords n rate noWrap records).2 ≤ + ConcreteRowExtraction.rowArithmeticPolynomial (2 ^ (n + rate)) := by + unfold countedExtractRecords + cases assembled : assemble records with + | none => exact Nat.zero_le _ + | some received => + exact ConcreteRowExtraction.countedExtractRow_polynomial_cost n rate noWrap redundancy received + +#print axioms countedExtractRecords_value +#print axioms countedExtractRecords_polynomial_cost + +theorem extractRecords_recovers (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) (a : Array K) (shape : a.size = 2 ^ n) + (committed : Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n → E) + (records : List (Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n × E)) + (authenticated : ∀ record ∈ records, record.2 = committed record.1) + (covered : ∀ target, ∃ record ∈ records, record.1 = target) + (radius : 2 * hammingDist committed + (fun i => (encode n rate (a.map E.ofK))[i.val]!) ≤ 2 ^ (n + rate) - 2 ^ n) : + extractRecords n rate noWrap records = some a := by + rw [extractRecords, assemble_eq_committed records committed authenticated covered, + Option.bind_some] + apply ConcreteRowExtraction.extractRow_recovers n rate noWrap redundancy a shape + have getEq : (Vector.ofFn committed).get = committed := by + funext i + simp + rwa [getEq] + +/-- Parse a queried leaf lane without inspecting the public dense root. Invalid tags, indices, counts, or missing lane entries fail. Authentication must be established by the access reduction. -/ +def parseLane (depth count lane : Nat) (request : QueryRequest) (reply : Reply) : + Option (List (Fin (2 ^ depth) × E)) := do + let positions ← deriveQueries depth count request.squeezes + let leaves ← rows reply + if valid : positions.size = count ∧ leaves.size = count ∧ + ∀ i : Fin count, positions[i.val]! < 2 ^ depth ∧ lane < leaves[i.val]!.size then + return List.ofFn fun i : Fin count => + (⟨positions[i.val]!, (valid.2.2 i).1⟩, (leaves[i.val]!)[lane]!) + else none + +theorem parseLane_length (depth count lane : Nat) (request : QueryRequest) (reply : Reply) + (records : List (Fin (2 ^ depth) × E)) + (parsed : parseLane depth count lane request reply = some records) : + records.length = count := by + unfold parseLane at parsed + cases hp : deriveQueries depth count request.squeezes <;> simp [hp] at parsed + cases hr : rows reply <;> simp [hr] at parsed + obtain ⟨valid, rfl⟩ := parsed + simp + +/-- Every returned coordinate/value is from the actual query reply, with its order and repeated positions preserved. -/ +theorem parseLane_authenticated (depth count lane : Nat) (request : QueryRequest) + (reply : Reply) (records : List (Fin (2 ^ depth) × E)) + (committed : Fin (2 ^ depth) → E) + (parsed : parseLane depth count lane request reply = some records) + (auth : ∀ positions leaves, + deriveQueries depth count request.squeezes = some positions → rows reply = some leaves → + ∀ i : Fin count, ∀ bound : positions[i.val]! < 2 ^ depth, + (leaves[i.val]!)[lane]! = committed ⟨positions[i.val]!, bound⟩) : + ∀ record ∈ records, record.2 = committed record.1 := by + unfold parseLane at parsed + cases hp : deriveQueries depth count request.squeezes <;> simp [hp] at parsed + cases hr : rows reply <;> simp [hr] at parsed + obtain ⟨valid, rfl⟩ := parsed + intro record member + obtain ⟨i, rfl⟩ := List.mem_ofFn.mp member + exact auth _ _ hp hr i _ + +theorem parseLane_contains_sampled (depth count lane : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) (request : QueryRequest) (reply : Reply) + (tape : RewindCoverage.QueryTape depth count) (squeezes : request.squeezes = Array.ofFn tape) + (records : List (Fin (2 ^ depth) × E)) + (parsed : parseLane depth count lane request reply = some records) (i : Fin count) : + ∃ record ∈ records, record.1 = RewindCoverage.sampledPosition depth count positive noWrap tape i := by + unfold parseLane at parsed + rw [squeezes, SamplingProbability.deriveQueries_eq depth count positive noWrap] at parsed + cases hr : rows reply <;> simp [hr] at parsed + obtain ⟨valid, rfl⟩ := parsed + refine ⟨_, List.mem_ofFn.mpr ⟨i, rfl⟩, ?_⟩ + apply Fin.ext + exact (RewindCoverage.sampledPosition_actual depth count positive noWrap tape i).symm + +/-- The extractor consumes only the returned reset answers, not a freely readable committed word. A failed parse fails the whole extraction. -/ +def parseReplies (depth count lane : Nat) : + List QueryRequest → List Reply → Option (List (Fin (2 ^ depth) × E)) + | [], [] => some [] + | request :: requests, reply :: replies => do + let first ← parseLane depth count lane request reply + let rest ← parseReplies depth count lane requests replies + return first ++ rest + | _, _ => none + +/-- Every parsed record from a selected real response remains in the aggregate access log. -/ +theorem parseReplies_map_contains (depth count lane : Nat) (requests : List QueryRequest) + (answer : QueryRequest → Reply) (records : List (Fin (2 ^ depth) × E)) + (parsed : parseReplies depth count lane requests (requests.map answer) = some records) + (request : QueryRequest) (member : request ∈ requests) + (first : List (Fin (2 ^ depth) × E)) + (parsedFirst : parseLane depth count lane request (answer request) = some first) + (record : Fin (2 ^ depth) × E) (inFirst : record ∈ first) : record ∈ records := by + induction requests generalizing records with + | nil => simp at member + | cons head rest ih => + simp only [List.map_cons, parseReplies] at parsed + cases hf : parseLane depth count lane head (answer head) <;> simp [hf] at parsed + cases ht : parseReplies depth count lane rest (rest.map answer) <;> simp [ht] at parsed + cases parsed + rcases List.mem_cons.mp member with same | later + · subst request + have equal := Option.some.inj (hf.symm.trans parsedFirst) + subst first + exact List.mem_append_left _ inFirst + · exact List.mem_append_right _ (ih _ ht later) + +theorem parseReplies_map_parsed (depth count lane : Nat) (requests : List QueryRequest) + (answer : QueryRequest → Reply) (records : List (Fin (2 ^ depth) × E)) + (parsed : parseReplies depth count lane requests (requests.map answer) = some records) + (request : QueryRequest) (member : request ∈ requests) : + ∃ first, parseLane depth count lane request (answer request) = some first := by + induction requests generalizing records with + | nil => simp at member + | cons head rest ih => + simp only [List.map_cons, parseReplies] at parsed + cases hf : parseLane depth count lane head (answer head) <;> simp [hf] at parsed + cases ht : parseReplies depth count lane rest (rest.map answer) <;> simp [ht] at parsed + rcases List.mem_cons.mp member with same | later + · subst request + exact ⟨_, hf⟩ + · exact ih _ ht later + +/-- Successful real-response parsing converts sampler coverage to complete access-log coverage. No missing answer is silently substituted. -/ +theorem parsed_cover_of_sampler (depth count lane rounds : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) (seed : Fin rounds → RewindCoverage.QueryTape depth count) + (requests : Fin rounds → QueryRequest) (squeezes : ∀ round, (requests round).squeezes = Array.ofFn (seed round)) + (answer : QueryRequest → Reply) (records : List (Fin (2 ^ depth) × E)) + (parsed : parseReplies depth count lane (List.ofFn requests) + ((List.ofFn requests).map answer) = some records) + (coverage : RewindCoverage.Covers depth count rounds positive noWrap seed) : + ∀ target, ∃ record ∈ records, record.1 = target := by + intro target + obtain ⟨round, i, hit⟩ := coverage target + have member : requests round ∈ List.ofFn requests := List.mem_ofFn.mpr ⟨round, rfl⟩ + obtain ⟨first, parsedFirst⟩ := parseReplies_map_parsed depth count lane _ answer records parsed _ member + obtain ⟨record, inFirst, position⟩ := parseLane_contains_sampled depth count lane positive noWrap + (requests round) (answer (requests round)) (seed round) (squeezes round) first parsedFirst i + exact ⟨record, parseReplies_map_contains depth count lane _ answer records parsed _ member + first parsedFirst record inFirst, position.trans hit⟩ + +theorem parseReplies_length (depth count lane : Nat) (requests : List QueryRequest) + (replies : List Reply) (records : List (Fin (2 ^ depth) × E)) + (parsed : parseReplies depth count lane requests replies = some records) : + records.length = requests.length * count := by + induction requests generalizing replies records with + | nil => + cases replies <;> simp [parseReplies] at parsed + cases parsed + simp + | cons request requests ih => + cases replies with + | nil => simp [parseReplies] at parsed + | cons reply replies => + simp only [parseReplies] at parsed + cases hf : parseLane depth count lane request reply <;> simp [hf] at parsed + cases ht : parseReplies depth count lane requests replies <;> simp [ht] at parsed + cases parsed + simp [parseLane_length _ _ _ _ _ _ hf, ih _ _ ht, Nat.add_mul, Nat.add_comm] + +def castRecords {N M : Nat} (same : N = M) (records : List (Fin N × E)) : + List (Fin M × E) := + records.map fun record => (Fin.cast same record.1, record.2) + +theorem castRecords_cancel {N M : Nat} (same : N = M) (records : List (Fin N × E)) : + castRecords same.symm (castRecords same records) = records := by + subst M + simp [castRecords] + +def extractReplies (n rate : Nat) (noWrap : n + rate ≤ 64) (count lane : Nat) + (requests : List QueryRequest) (replies : List Reply) : Option (Array K) := + (parseReplies (n + rate) count lane requests replies).bind + (fun records => extractRecords n rate noWrap + (castRecords (ConcreteRowExtraction.domain_size (n + rate) noWrap).symm records)) + +theorem extractReplies_recovers (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) (count lane : Nat) + (requests : List QueryRequest) (replies : List Reply) + (a : Array K) (shape : a.size = 2 ^ n) + (committed : Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n → E) + (records : List (Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n × E)) + (parsed : parseReplies (n + rate) count lane requests replies = + some (castRecords (ConcreteRowExtraction.domain_size (n + rate) noWrap) records)) + (authenticated : ∀ record ∈ records, record.2 = committed record.1) + (covered : ∀ target, ∃ record ∈ records, record.1 = target) + (radius : 2 * hammingDist committed + (fun i => (encode n rate (a.map E.ofK))[i.val]!) ≤ 2 ^ (n + rate) - 2 ^ n) : + extractReplies n rate noWrap count lane requests replies = some a := by + rw [extractReplies, parsed, Option.bind_some, castRecords_cancel] + exact extractRecords_recovers n rate noWrap redundancy a shape committed records + authenticated covered radius + +open CausalProbability in +/-- Actual fixed-public reset-and-decode algorithm. The caller provides only fresh challenge coordinates and a tape whose already-sent prefix is replayed. -/ +def extractResetLane (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (rounds : Nat) + (seed : Fin rounds → Sample (.query level)) (n rate : Nat) (noWrap : n + rate ≤ 64) + (lane : Nat) : Option (Array K) := + extractReplies n rate noWrap prover.input.config.queries[level.val]! lane + (List.ofFn fun round => resetRequest prover.input level (seed round)) + (collectResets prover tape level rounds seed).replies + +open CausalProbability in +/-- Correctness for the actual black-box reset collector. Successful authenticated access and proximity remain separate premises; no dense-root access is performed by the function. -/ +theorem extractResetLane_recovers (prover : CommittedProver) (tape : Tape prover.input.config) + (level : Fin prover.input.config.folds.size) (rounds : Nat) + (seed : Fin rounds → Sample (.query level)) (n rate : Nat) (noWrap : n + rate ≤ 64) + (redundancy : 2 ^ n < 2 ^ (n + rate)) (lane : Nat) + (a : Array K) (shape : a.size = 2 ^ n) + (committed : Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n → E) + (records : List (Fin (ConcreteRowExtraction.domain (n + rate) noWrap).n × E)) + (parsed : parseReplies (n + rate) prover.input.config.queries[level.val]! lane + (List.ofFn fun round => resetRequest prover.input level (seed round)) + (collectResets prover tape level rounds seed).replies = + some (castRecords (ConcreteRowExtraction.domain_size (n + rate) noWrap) records)) + (authenticated : ∀ record ∈ records, record.2 = committed record.1) + (covered : ∀ target, ∃ record ∈ records, record.1 = target) + (radius : 2 * hammingDist committed + (fun i => (encode n rate (a.map E.ofK))[i.val]!) ≤ 2 ^ (n + rate) - 2 ^ n) : + extractResetLane prover tape level rounds seed n rate noWrap lane = some a := + extractReplies_recovers n rate noWrap redundancy _ lane _ _ a shape committed records + parsed authenticated covered radius + +/-- At most two coordinate lookup passes in the implemented assembly. This counts comparisons, separately from decoder field and polynomial operations. -/ +theorem parsed_assemblyComparisons_le (depth count lane : Nat) + (requests : List QueryRequest) (replies : List Reply) + (records : List (Fin (2 ^ depth) × E)) + (parsed : parseReplies depth count lane requests replies = some records) : + 2 * assemblyComparisons records ≤ 2 * (2 ^ depth * (requests.length * count)) := by + apply Nat.mul_le_mul_left + simpa [parseReplies_length depth count lane requests replies records parsed] using + assemblyComparisons_le records + +#print axioms collect_replies +#print axioms collect_responseCalls +#print axioms run_collectProgram +#print axioms queryPrefix_reset +#print axioms resetRequest_actual_batch +#print axioms collectResets_responseCalls +#print axioms collectResets_responseCalls_le +#print axioms accepted_queries_authenticated +#print axioms reset_oracle_fixed +#print axioms countedLookup_value +#print axioms countedLookup_comparisons +#print axioms lookup_authenticated +#print axioms assemble_eq_committed +#print axioms assemblyComparisons_le +#print axioms extractRecords_recovers +#print axioms parseLane_length +#print axioms parseLane_authenticated +#print axioms parseReplies_length +#print axioms parseLane_contains_sampled +#print axioms parseReplies_map_contains +#print axioms parseReplies_map_parsed +#print axioms parsed_cover_of_sampler +#print axioms castRecords_cancel +#print axioms extractReplies_recovers +#print axioms extractResetLane_recovers +#print axioms parsed_assemblyComparisons_le +end Whir.RewindRowExtraction diff --git a/verification/whir/Whir/RewindTrajectory.lean b/verification/whir/Whir/RewindTrajectory.lean new file mode 100644 index 000000000..4afeed4d4 --- /dev/null +++ b/verification/whir/Whir/RewindTrajectory.lean @@ -0,0 +1,119 @@ +import Whir.InteractiveSoundness + +/-! Actual accepted continuations recover a generic extension-field list candidate at any chosen level, not merely an initial base-word candidate. The proof reuses the actual causal fold/query transitions and terminal collision cover. It does not assert that different reset executions choose the same candidate; the separate OOD/batching argument is needed for that. -/ +namespace Whir.RewindTrajectory +open Concrete Protocol CausalGame CausalExecution ExecutionShapes ParameterBounds VerifierInvariant + +/-- Loss may begin at any level: no initial candidate or initial batching assumption is needed. -/ +theorem accepted_level_lost_cover (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (start : Fin (config p).folds.size) + (incoming : Lost (foldCandidates (Input p lanes root claims) strategy tape start 0) + (levelAt (Input p lanes root claims) strategy tape start).state) : + ∃ q, CausalBadEvents.Bad (Input p lanes root claims) strategy q tape := by + classical + apply Classical.byContradiction + intro noBad + have safe (q) : ¬ CausalBadEvents.Bad (Input p lanes root claims) strategy q tape := + fun h => noBad ⟨q, h⟩ + have entering (j : Nat) (hj : j < (config p).folds.size) (after : start.val ≤ j) : + Lost (foldCandidates (Input p lanes root claims) strategy tape j 0) + (levelAt (Input p lanes root claims) strategy tape j).state := by + induction j with + | zero => + have initial : start.val = 0 := by omega + simpa only [initial] using incoming + | succ j ih => + by_cases initial : start.val = j + 1 + · simpa only [initial] using incoming + · have previous : j < (config p).folds.size := by omega + have before : start.val ≤ j := by omega + let index : Fin (config p).folds.size := ⟨j, previous⟩ + have folded := InteractiveSoundness.folds_preserve_lost p lanes root claims strategy tape + index (ih previous before) (fun k => safe (.fold index k)) + have queried := InteractiveSoundness.query_preserves_lost p lanes root claims strategy tape + accepted index folded (fun k => safe (.ood index k)) (safe (.query index)) + rw [following_eq_next _ _ _ j hj] at queried + exact queried + have positive := (production_config_valid p).2.1 + let last : Fin (config p).folds.size := ⟨(config p).folds.size - 1, by omega⟩ + have lastEnd : last.val + 1 = (config p).folds.size := by dsimp [last]; omega + have noNext : ¬ last.val + 1 < (config p).folds.size := by omega + have after : start.val ≤ last.val := by dsimp [last]; omega + have folded := InteractiveSoundness.folds_preserve_lost p lanes root claims strategy tape last + (entering last last.isLt after) (fun j => safe (.fold last j)) + have queried := InteractiveSoundness.query_preserves_lost p lanes root claims strategy tape + accepted last folded (fun j => safe (.ood last j)) (safe (.query last)) + have beforeState := (accepted_execution (Input p lanes root claims) strategy tape accepted).2.2 + have incoming : dot (proof (Input p lanes root claims) strategy tape).residual + (CausalTerminal.before (Input p lanes root claims) strategy tape).weight ≠ + (CausalTerminal.before (Input p lanes root claims) strategy tape).claim := by + have member : (proof (Input p lanes root claims) strategy tape).residual ∈ + followingCandidates (Input p lanes root claims) strategy tape last := by + simp only [followingCandidates, noNext, ↓reduceIte, Finset.mem_singleton] + have lost := queried _ member + simpa only [lastEnd, beforeState] using lost + have checked := accepted_level (Input p lanes root claims) strategy tape accepted last last.isLt + have terminalShape := boundary_shape (config p) (challenges (config p) tape) + (proof (Input p lanes root claims) strategy tape) last _ _ checked + dsimp only at terminalShape + rw [← foldAt_end (Input p lanes root claims) strategy tape last last.isLt] at terminalShape + have dims := (foldAt_shape p lanes root claims strategy tape last (config p).folds[last.val]! le_rfl).1 + simp only [Nat.sub_self, Nat.add_zero] at dims + rw [dims] at terminalShape + have shapeLast : (proof (Input p lanes root claims) strategy tape).residual.size = + 2 ^ remaining (config p) last := by + have pair : (proof (Input p lanes root claims) strategy tape).levels[last.val]!.nextOracle = none ∧ + (proof (Input p lanes root claims) strategy tape).residual.size = 2 ^ remaining (config p) last := by + simpa only [noNext, ↓reduceIte] using terminalShape + exact pair.2 + have remainingLast : remaining (config p) last = (config p).logN - (config p).folds.toList.sum := by + unfold remaining + rw [lastEnd, ← Array.length_toList, List.take_length] + rw [remainingLast] at shapeLast + have weight := (levelAt_shape p lanes root claims strategy tape (config p).folds.size le_rfl).2 + rw [beforeState] at weight + simp only [before] at weight + have takeAll : (config p).folds.toList.take (config p).folds.size = (config p).folds.toList := by + rw [← Array.length_toList, List.take_length] + rw [takeAll] at weight + have weightShape : (CausalTerminal.before (Input p lanes root claims) strategy tape).weight.size = + (proof (Input p lanes root claims) strategy tape).residual.size := weight.trans shapeLast.symm + obtain ⟨j, escaped⟩ := CausalTerminal.event_has_collision (Input p lanes root claims) strategy tape + ⟨accepted, shapeLast, weightShape, incoming⟩ + exact safe (.tail j) escaped + +/-- A genuine generic-E candidate exists at every level of an accepted continuation outside the already charged actual prefix events. -/ +theorem accepted_level_candidate (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (start : Fin (config p).folds.size) + (safe : ∀ q, ¬ CausalBadEvents.Bad (Input p lanes root claims) strategy q tape) : + ∃ witness ∈ foldCandidates (Input p lanes root claims) strategy tape start 0, + dot witness (levelAt (Input p lanes root claims) strategy tape start).state.weight = + (levelAt (Input p lanes root claims) strategy tape start).state.claim := by + classical + by_contra missing + have lost : Lost (foldCandidates (Input p lanes root claims) strategy tape start 0) + (levelAt (Input p lanes root claims) strategy tape start).state := by + simpa only [Lost, not_exists, not_and] using missing + obtain ⟨q, bad⟩ := accepted_level_lost_cover p lanes root claims strategy tape accepted start lost + exact safe q bad + +/-- In particular, Root1 has its own fixed generic-E list, rather than an assumed Root0 decoder radius. -/ +theorem accepted_following_candidate (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (tape : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy tape = true) + (level : Fin (config p).folds.size) (hasNext : level.val + 1 < (config p).folds.size) + (safe : ∀ q, ¬ CausalBadEvents.Bad (Input p lanes root claims) strategy q tape) : + ∃ witness ∈ followingCandidates (Input p lanes root claims) strategy tape level, + dot witness (levelAt (Input p lanes root claims) strategy tape (level.val + 1)).state.weight = + (levelAt (Input p lanes root claims) strategy tape (level.val + 1)).state.claim := by + rw [following_eq_next _ _ _ level hasNext] + exact accepted_level_candidate p lanes root claims strategy tape accepted ⟨level.val + 1, hasNext⟩ safe + +#print axioms accepted_level_lost_cover +#print axioms accepted_level_candidate +#print axioms accepted_following_candidate +end Whir.RewindTrajectory diff --git a/verification/whir/Whir/Root0FixedTarget.lean b/verification/whir/Whir/Root0FixedTarget.lean new file mode 100644 index 000000000..9c4e58d32 --- /dev/null +++ b/verification/whir/Whir/Root0FixedTarget.lean @@ -0,0 +1,194 @@ +import Whir.AuthenticatedResetLaw +import Whir.RewindRadiusExtraction + +/-! Full-suffix legal resets preserve the whole following coefficient table list, +not merely a query-only replacement. Root1 replay at j=0 reads no future fold +scalar, even though its type mentions the future fold array. -/ +namespace Whir.Root0FixedTarget +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open AuthenticatedResetSupport CausalStateCausality ParameterBounds RewindBatchTarget + +set_option maxRecDepth 100000 +set_option maxHeartbeats 200000 +attribute [local irreducible] ParameterBounds.config + +noncomputable def snapshot (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Fin input.config.folds.size) : + Finset (Array E) × CheckedState × Oracle × Array OodClaim × Array E × Array (Array E) := + (followingCandidates input strategy t i, + CausalBoundary.boundary input strategy t i, + (levelAt input strategy t i).oracle, + (proof input strategy t).levels[i.val]!.oods, + (challenges input.config t).levels[i.val]!.folds, + (challenges input.config t).levels[i.val]!.oodPoints) + +theorem snapshot_set (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Fin input.config.folds.size) (q : Coordinate input.config) (x : Sample q) + (later : position (.query i) ≤ position q) : + snapshot input strategy (set q t x) i = snapshot input strategy t i := by + have cut := CausalPositions.position_query i t + have folds : (challenges input.config (set q t x)).levels[i.val]!.folds = + (challenges input.config t).levels[i.val]!.folds := by + simp only [challenges, _root_.getElem!_pos, Array.size_ofFn, i.isLt, Array.getElem_ofFn] + apply congrArg Array.ofFn + funext j + change get (.fold i j) (set q t x) = get (.fold i j) t + apply get_set_ne q (.fold i j) t x + intro equal + have hp := congrArg position equal + rw [CausalPositions.position_fold i j t] at hp + omega + have oods : (challenges input.config (set q t x)).levels[i.val]!.oodPoints = + (challenges input.config t).levels[i.val]!.oodPoints := by + simp only [challenges, _root_.getElem!_pos, Array.size_ofFn, i.isLt, Array.getElem_ofFn] + apply congrArg Array.ofFn + funext j + apply congrArg Array.ofFn + change get (.ood i j) (set q t x) = get (.ood i j) t + apply get_set_ne q (.ood i j) t x + intro equal + have hp := congrArg position equal + rw [CausalPositions.position_ood i j t] at hp + omega + unfold snapshot CausalBoundary.boundary + rw [CausalBoundary.followingCandidates_set input strategy t q x i (by omega), + foldAt_set input strategy q t x i _ le_rfl (by omega), + levelAt_set input strategy q t x i i.isLt.le (by omega), + CausalBoundary.oods_set input strategy t q x i (by omega), folds, oods] + +theorem snapshot_resetCoordinates (input : Public) (strategy : Strategy) + (base fresh : Tape input.config) (i : Fin input.config.folds.size) + (qs : List (Coordinate input.config)) : + snapshot input strategy (resetCoordinates (position (.query i)) fresh qs base) i = + snapshot input strategy base i := by + induction qs generalizing base with + | nil => rfl + | cons q qs ih => + unfold resetCoordinates + rw [ih] + split_ifs with later + · exact snapshot_set input strategy base i q (get q fresh) later + · rfl + +theorem snapshot_fullReset (input : Public) (strategy : Strategy) + (base fresh : Tape input.config) (i : Fin input.config.folds.size) + (draw : Sample (.query i)) : + snapshot input strategy (set (.query i) (resetSuffix (position (.query i)) base fresh) draw) i = + snapshot input strategy base i := by + rw [snapshot_set input strategy _ i (.query i) _ le_rfl] + exact snapshot_resetCoordinates input strategy base fresh i _ + +theorem snapshot_fullResetTape (input : Public) (strategy : Strategy) + (base : Tape input.config) (i : Fin input.config.folds.size) (depth : Nat) + (chunks) (query) (suffix) : + snapshot input strategy (fullResetTape input base i depth chunks query suffix) i = + snapshot input strategy base i := by + unfold fullResetTape + rw [snapshot_set input strategy _ i (.query i) _ le_rfl] + exact snapshot_resetCoordinates input strategy base suffix.2 i _ + +/-- Every accepted safe full reset hits the SAME prefix-fixed OOD target. +The separately charged lambda event uses the incoming suffix-reset tape; its +polynomial is prefix-fixed and does not assume honest OOD advertisements. -/ +theorem accepted_full_reset_hits (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (base fresh : Tape (config p)) + (i : Fin (config p).folds.size) (hasNext : i.val+1 < (config p).folds.size) + (draw : Sample (.query i)) (target : Array E) + (matching : Target (followingCandidates (Input p lanes root claims) strategy base i) + (challenges (config p) base).levels[i.val]!.oodPoints[0]! + (proof (Input p lanes root claims) strategy base).levels[i.val]!.oods[0]!.value target) + (separated : LevelBoundary.Separated (followingCandidates (Input p lanes root claims) strategy base i) + (challenges (config p) base).levels[i.val]!.oodPoints[0]!) + (accepted : experiment (Input p lanes root claims) strategy + (set (.query i) (resetSuffix (position (.query i)) base fresh) draw) = true) + (safe : ∀ q, ¬ CausalBadEvents.Bad (Input p lanes root claims) strategy q + (set (.query i) (resetSuffix (position (.query i)) base fresh) draw)) + (outside : ¬ Collision (remaining (config p) i) (config p).rates[i.val]! + (config p).queries[i.val]! i + (levelAt (Input p lanes root claims) strategy (resetSuffix (position (.query i)) base fresh) i).oracle + (challenges (config p) (resetSuffix (position (.query i)) base fresh)).levels[i.val]! + (proof (Input p lanes root claims) strategy (resetSuffix (position (.query i)) base fresh)).levels[i.val]! + (CausalBoundary.boundary (Input p lanes root claims) strategy + (resetSuffix (position (.query i)) base fresh) i).state + (followingCandidates (Input p lanes root claims) strategy + (resetSuffix (position (.query i)) base fresh) i) draw.1 draw.2) : + SamplingProbability.allQueriesHit (remaining (config p) i + (config p).rates[i.val]!) + (config p).queries[i.val]! + (LevelBoundary.agreeingColumns (remaining (config p) i) (config p).rates[i.val]! target + (QueryBatchSoundness.oldWord (remaining (config p) i) (config p).rates[i.val]! + (levelAt (Input p lanes root claims) strategy base i).oracle (i.val == 0) + (challenges (config p) base).levels[i.val]!.folds)) draw.1 := by + let input := Input p lanes root claims + have fixed := snapshot_resetCoordinates input strategy base fresh i + (visibleCoordinates input.config ++ List.ofFn (fun j : Fin (input.config.logN-input.config.folds.toList.sum) => Coordinate.tail j)) + change snapshot input strategy (resetSuffix (position (.query i)) base fresh) i = snapshot input strategy base i at fixed + have list := congrArg (fun s => s.1) fixed + have oracle := congrArg (fun s => s.2.2.1) fixed + have answers := congrArg (fun s => s.2.2.2.1) fixed + have folds := congrArg (fun s => s.2.2.2.2.1) fixed + have points := congrArg (fun s => s.2.2.2.2.2) fixed + dsimp only [snapshot] at list oracle answers folds points + have matchingSuffix : Target (followingCandidates input strategy (resetSuffix (position (.query i)) base fresh) i) + (challenges (config p) (resetSuffix (position (.query i)) base fresh)).levels[i.val]!.oodPoints[0]! + (proof input strategy (resetSuffix (position (.query i)) base fresh)).levels[i.val]!.oods[0]!.value target := by + unfold Target at matching ⊢ + rw [list, points, answers] + exact matching + have separatedSuffix : LevelBoundary.Separated + (followingCandidates input strategy (resetSuffix (position (.query i)) base fresh) i) + (challenges (config p) (resetSuffix (position (.query i)) base fresh)).levels[i.val]!.oodPoints[0]! := by + rw [list, points] + exact separated + have hits := RewindRadiusExtraction.accepted_reset_fixed_target p lanes root claims strategy + (resetSuffix (position (.query i)) base fresh) i hasNext draw target + matchingSuffix separatedSuffix accepted safe outside + rw [oracle, folds] at hits + exact hits + +/-- An arbitrary advertised OOD value is allowed. A safe accepted continuation +itself produces a matching candidate with the pre-query running claim; if the +advertised value matches none, such a continuation cannot exist. -/ +theorem accepted_reset_target_exists (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (i : Fin (config p).folds.size) (hasNext : i.val+1 < (config p).folds.size) + (draw : Sample (.query i)) + (accepted : experiment (Input p lanes root claims) strategy (set (.query i) t draw) = true) + (safe : ∀ q, ¬ CausalBadEvents.Bad (Input p lanes root claims) strategy q (set (.query i) t draw)) + (outside : ¬ Collision (remaining (config p) i) (config p).rates[i.val]! + (config p).queries[i.val]! i (levelAt (Input p lanes root claims) strategy t i).oracle + (challenges (config p) t).levels[i.val]! + (proof (Input p lanes root claims) strategy t).levels[i.val]! + (CausalBoundary.boundary (Input p lanes root claims) strategy t i).state + (followingCandidates (Input p lanes root claims) strategy t i) draw.1 draw.2) : + ∃ target, Target (followingCandidates (Input p lanes root claims) strategy t i) + (challenges (config p) t).levels[i.val]!.oodPoints[0]! + (proof (Input p lanes root claims) strategy t).levels[i.val]!.oods[0]!.value target ∧ + dot target (CausalBoundary.boundary (Input p lanes root claims) strategy t i).state.weight = + (CausalBoundary.boundary (Input p lanes root claims) strategy t i).state.claim := by + let input := Input p lanes root claims + have restored := accepted_reset_restores p lanes root claims strategy t i hasNext draw accepted safe + have facts := CausalBoundary.production_boundary_facts p i + have sizes := CausalBoundary.followingCandidates_sizes input strategy t p rfl i + (by intro impossible; exact (impossible hasNext).elim) + have weight : (CausalBoundary.boundary input strategy t i).state.weight.size = + 2 ^ remaining (config p) i := by + have shape := (foldAt_shape p lanes root claims strategy t i (config p).folds[i.val]! le_rfl).2 + simpa only [CausalBoundary.boundary, input, Nat.sub_self, Nat.add_zero] using shape + have oods : ∀ j < (proof input strategy t).levels[i.val]!.oods.size, + (eqTable (challenges (config p) t).levels[i.val]!.oodPoints[j]!).size = + 2 ^ remaining (config p) i := by + intro j bound + rw [CausalBoundary.decoded_oods_size] at bound + exact CausalBoundary.point_size input t i j bound + have first : 0 < (proof input strategy t).levels[i.val]!.oods.size := by + rw [CausalBoundary.decoded_oods_size] + exact (facts.2.2 hasNext).2 + obtain ⟨target, member, zero⟩ := restores_zero_candidate _ _ _ _ _ _ _ _ _ _ _ + sizes weight oods draw restored outside + have hits := zero_error_hits _ _ _ _ _ _ _ _ draw.1 target facts.1 facts.2.1 zero + exact ⟨target, ⟨member, hits.2.1 0 first⟩, hits.1⟩ + +#print axioms snapshot_fullResetTape +#print axioms accepted_full_reset_hits +#print axioms accepted_reset_target_exists +end Whir.Root0FixedTarget diff --git a/verification/whir/Whir/SupportedCandidateCancellation.lean b/verification/whir/Whir/SupportedCandidateCancellation.lean new file mode 100644 index 000000000..b38622617 --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateCancellation.lean @@ -0,0 +1,104 @@ +import Whir.SupportedCandidateFolding +import Whir.ExecutableOOD + +/-! Fixed-list row cancellation, charged once before resetting any queries. +The witness list and both full row tables must be fixed before the fold seed. +The event ranges over the actual committed initial list, not extracted choices. -/ +namespace Whir.SupportedCandidateExtraction +open Concrete +open scoped BigOperators + +variable {F W Q : Type*} [Field F] [Fintype F] [DecidableEq F] [Inhabited F] + [Fintype Q] [DecidableEq Q] [DecidableEq W] [CharP F 2] + +noncomputable def RowCancellation (folds : Nat) (list : Finset W) + (committed : Q → Array F) (encoded : W → Q → Array F) (seed : Fin folds → F) : Prop := + ∃ w ∈ list, ∃ q, committed q ≠ encoded w q ∧ + Concrete.mle (committed q) (Array.ofFn seed) = + Concrete.mle (encoded w q) (Array.ofFn seed) + +omit [DecidableEq Q] [DecidableEq W] in +open Classical in +/-- One nonzero multilinear difference per fixed witness and domain coordinate. +For Root0's six folds this is exactly L*N*6/|E|, rather than L² or a +post-extraction union over adversarially chosen witnesses. -/ +theorem rowCancellation_probability (folds : Nat) (list : Finset W) + (committed : Q → Array F) (encoded : W → Q → Array F) + (committedShape : ∀ q, (committed q).size = 2 ^ folds) + (encodedShape : ∀ w ∈ list, ∀ q, (encoded w q).size = 2 ^ folds) : + Soundness.uniformProb (Finset.univ.filter (RowCancellation folds list committed encoded)) ≤ + (list.card : ℚ) * Fintype.card Q * ((folds : ℚ) / Fintype.card F) := by + classical + let events (i : list × Q) : Finset (Fin folds → F) := Finset.univ.filter fun seed => + committed i.2 ≠ encoded i.1 i.2 ∧ + Concrete.mle (committed i.2) (Array.ofFn seed) = + Concrete.mle (encoded i.1 i.2) (Array.ofFn seed) + have equal : Finset.univ.filter (RowCancellation folds list committed encoded) = + Finset.univ.biUnion events := by + ext seed + simp [RowCancellation, events] + rw [equal] + calc + _ ≤ ∑ i, Soundness.uniformProb (events i) := Soundness.union_bound events + _ ≤ ∑ _i : list × Q, ((folds : ℚ) / Fintype.card F) := by + apply Finset.sum_le_sum + intro i _ + by_cases different : committed i.2 ≠ encoded i.1 i.2 + · simpa [events, different] using ExecutableOOD.mle_collision_probability + (committed i.2) (encoded i.1 i.2) (committedShape i.2) + (encodedShape i.1 i.1.2 i.2) different + · simp [events, different, Soundness.uniformProb] + positivity + _ = _ := by simp [Fintype.card_prod, mul_assoc] + +omit [Fintype F] [Fintype Q] [DecidableEq Q] [DecidableEq W] [CharP F 2] in +/-- Outside the charged event, equality of the folded scalar forces literal +row equality for EVERY coordinate and EVERY member of the fixed initial list. -/ +theorem rowEquality_of_not_cancellation (folds : Nat) (list : Finset W) + (committed : Q → Array F) (encoded : W → Q → Array F) (seed : Fin folds → F) + (safe : ¬ RowCancellation folds list committed encoded seed) + (w : W) (member : w ∈ list) (q : Q) + (equal : Concrete.mle (committed q) (Array.ofFn seed) = + Concrete.mle (encoded w q) (Array.ofFn seed)) : committed q = encoded w q := by + by_contra different + exact safe ⟨w, member, q, different, equal⟩ + +def committedRow (input : CausalGame.Public) (q : Fin (blockLength input.config)) : Array E := + Array.ofFn fun lane : Fin (laneCount input.config) => + E.ofK (InitialCandidates.fullRow input.config input.lanes input.root lane q) + +def witnessRow (input : CausalGame.Public) (w : CausalGame.Witness input.config input.lanes) + (q : Fin (blockLength input.config)) : Array E := + Array.ofFn fun lane : Fin (laneCount input.config) => + (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + (Array.ofFn (CandidateFolding.unpack true (laneCount input.config) (width input.config) + (CausalGame.paddedWitness input.config input.lanes w) lane)))[q.val]! + +noncomputable def initialRowCancellation (input : CausalGame.Public) + (seed : Fin input.config.folds[0]! → E) : Prop := + RowCancellation input.config.folds[0]! + (InitialCandidates.witnesses input.config input.lanes input.root) + (committedRow input) (witnessRow input) seed + +open Classical in +theorem production_rowCancellation_probability (profile : ParameterBounds.Profile) + (lanes : Nat) (root : CausalGame.BaseOracle) (claims : Array CausalGame.Claim) : + let input := ExecutionShapes.Input profile lanes root claims + Soundness.uniformProb (Finset.univ.filter (initialRowCancellation input)) ≤ + (2 ^ 32 : ℚ) * blockLength input.config * ((input.config.folds[0]! : ℚ) / 2 ^ 192) := by + dsimp only + let input := ExecutionShapes.Input profile lanes root claims + have bound := rowCancellation_probability input.config.folds[0]! + (InitialCandidates.witnesses input.config input.lanes input.root) + (committedRow input) (witnessRow input) (by intro q; simp [committedRow]) + (by intro w hw q; simp [witnessRow]) + rw [FieldModel.card_E] at bound + simp only [Nat.cast_pow, Nat.cast_ofNat] at bound + apply bound.trans + simp only [Fintype.card_fin] + gcongr + exact_mod_cast InitialCandidates.production_witnesses_card profile lanes root + +#print axioms rowCancellation_probability +#print axioms rowEquality_of_not_cancellation +end Whir.SupportedCandidateExtraction diff --git a/verification/whir/Whir/SupportedCandidateClaims.lean b/verification/whir/Whir/SupportedCandidateClaims.lean new file mode 100644 index 000000000..abc6da0ba --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateClaims.lean @@ -0,0 +1,122 @@ +import Whir.SupportedCandidateFolding + +/-! Candidate-specific claim restoration. The existing all-candidates-Lost +causal event is too weak to certify that the SAME lifted witness explains the +original claims; the guarded event below is separately charged. -/ +namespace Whir.SupportedCandidateExtraction +open Concrete Protocol CandidateFolding VerifierInvariant + +set_option maxRecDepth 100000 + +variable {F : Type*} [Field F] [Fintype F] [DecidableEq F] [Inhabited F] [CharP F 2] + +noncomputable def candidateRoundEscape (candidates : Finset (Array F)) + (state : VerifierState F) (block : Nat) : Finset F := by + classical + exact roundBad (candidates.filter (fun witness => dot witness state.weight ≠ state.claim)) state block + +/-- Guarding each false candidate makes its polynomial nonzero without an +all-candidates-Lost premise. -/ +theorem candidateRoundEscape_probability (candidates : Finset (Array F)) + (state : VerifierState F) (block : Nat) : + Soundness.uniformProb (candidateRoundEscape candidates state block) ≤ + (candidates.card : ℚ) * (2 / Fintype.card F) := by + classical + have bounded := roundBad_probability + (candidates.filter (fun witness => dot witness state.weight ≠ state.claim)) state block (by + intro witness member + exact (Finset.mem_filter.mp member).2) + apply bounded.trans + gcongr + exact Finset.filter_subset _ _ + +/-- ANY specific lift whose folded target has the running claim inherits that +claim outside the separately charged guarded round event. -/ +theorem backward_claim (candidates : Finset (Array F)) (state : VerifierState F) + (block lanes : Nat) (r : F) (next : Message F) + (witness : Array F) (member : witness ∈ candidates) + (shape : witness.size = (lanes * 2) * block) (weightShape : state.weight.size = witness.size) + (safe : r ∉ candidateRoundEscape candidates state block) + (targetClaim : dot (foldValues witness block r) (state.fold block r next).weight = + (state.fold block r next).claim) : dot witness state.weight = state.claim := by + by_contra falseClaim + apply safe + apply Finset.mem_filter.mpr + refine ⟨Finset.mem_univ _, witness, Finset.mem_filter.mpr ⟨member, falseClaim⟩, ?_⟩ + have fold := ArrayAlgebra.honest_foldLane witness state.weight block lanes shape weightShape r + rw [← ReplayRefinement.foldValues_eq_lane, ← ReplayRefinement.foldValues_eq_lane] at fold + exact fold.trans targetClaim + +variable {I : Type*} + +inductive SafeClaimFoldSchedule {k : Nat} (top : Bool) + (enc : (Fin k → F) →ₗ[F] (I → F)) (C : Submodule F (I → F)) (threshold : Nat) : + {start finish : Nat} → (Fin start → I → F) → (Fin finish → I → F) → + VerifierState F → VerifierState F → (Array F → Array F) → Prop + | done {lanes : Nat} (oracle : Fin lanes → I → F) (state : VerifierState F) : + SafeClaimFoldSchedule top enc C threshold oracle oracle state state id + | step {lanes finish : Nat} (oracle : Fin (lanes * 2) → I → F) + (state : VerifierState F) (r : F) (next : Message F) + (weightShape : state.weight.size = (lanes * 2) * k) + (good : ¬ MutualAgreement.RowBad MutualAgreement.foldGenerator C threshold + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)] r) + (claimSafe : r ∉ candidateRoundEscape (arrayCandidates top enc oracle threshold) + state (foldBlock top k)) + {last : Fin finish → I → F} {endState : VerifierState F} {transform : Array F → Array F} + (rest : SafeClaimFoldSchedule top enc C threshold (foldOracle oracle r) last + (state.fold (foldBlock top k) r next) endState transform) : + SafeClaimFoldSchedule top enc C threshold oracle last state endState + (fun a => transform (foldValues a (foldBlock top k) r)) + +/-- SAME-target lifting with candidate-specific claim preservation through +every actual compact round. No honest message is required. -/ +theorem same_target_claim_lifts {k start finish : Nat} (top : Bool) + (enc : (Fin k → F) →ₗ[F] (I → F)) (C : Submodule F (I → F)) + (rangeEq : LinearMap.range enc = C) (threshold : Nat) + (oracle : Fin start → I → F) (last : Fin finish → I → F) + (state endState : VerifierState F) (transform : Array F → Array F) + (schedule : SafeClaimFoldSchedule top enc C threshold oracle last state endState transform) + (target : Array F) (member : target ∈ arrayCandidates top enc last threshold) + (targetClaim : dot target endState.weight = endState.claim) : + ∃ original ∈ arrayCandidates top enc oracle threshold, + transform original = target ∧ dot original state.weight = state.claim := by + induction schedule with + | done oracle state => exact ⟨target, member, rfl, targetClaim⟩ + | @step lanes finish oracle state r next weightShape good claimSafe last endState transform rest ih => + obtain ⟨middle, hmiddle, hequal, hclaim⟩ := ih member targetClaim + obtain ⟨original, horiginal, hfold⟩ := array_lifts top enc C rangeEq oracle threshold r good middle hmiddle + refine ⟨original, horiginal, by simpa only [← hfold] using hequal, ?_⟩ + apply backward_claim (arrayCandidates top enc oracle threshold) state (foldBlock top k) + (if top then lanes else lanes * k) r next original horiginal + (arrayCandidates_round_shape top enc oracle threshold original horiginal) + (weightShape.trans (arrayCandidates_size top enc oracle threshold original horiginal).symm) + claimSafe + simpa only [← hfold] using hclaim + +/-- The separately charged initial batching event transfers a TRUE batched +claim of the very lifted candidate to ALL original public claims. -/ +theorem all_claims_of_safe_batch (candidates : Finset (Array E)) (claims : Array CausalGame.Claim) + (lambda : E) (original : Array E) (member : original ∈ candidates) + (safe : lambda ∉ InitialBatching.candidateEscape candidates claims) + (batched : dot original (CausalGame.batchClaims original.size claims lambda).weight = + (CausalGame.batchClaims original.size claims lambda).value) : + ∀ claim ∈ claims.toList, dot original claim.weight = claim.value := by + classical + have each : ∀ j : Fin claims.size, dot original claims[j].weight = claims[j].value := by + intro j + by_contra falseClaim + apply safe + apply Finset.mem_biUnion.mpr + refine ⟨original, member, ?_⟩ + simp only [InitialBatching.escape, Finset.mem_filter, Finset.mem_univ, true_and] + exact ⟨⟨j, falseClaim⟩, batched⟩ + intro claim memberClaim + obtain ⟨j, hj, equal⟩ := List.mem_iff_getElem.mp memberClaim + have bound : j < claims.size := by simpa using hj + have result := each ⟨j, bound⟩ + change dot original claims[j].weight = claims[j].value at result + simpa only [← equal, Array.getElem_toList] using result + +#print axioms candidateRoundEscape_probability +#print axioms backward_claim +end Whir.SupportedCandidateExtraction diff --git a/verification/whir/Whir/SupportedCandidateExtraction.lean b/verification/whir/Whir/SupportedCandidateExtraction.lean new file mode 100644 index 000000000..1efe9d6e6 --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateExtraction.lean @@ -0,0 +1,120 @@ +import Whir.InitialCandidates +import Whir.KnowledgeExtraction + +/-! Executable common-coordinate certification. Only supplied response records +are read; the ideal root is used in soundness statements, never in the checker. +The certificate is shared by every lane, including the zero-padded lanes. -/ +namespace Whir.SupportedCandidateExtraction +open Concrete Protocol CausalGame CandidateFolding + +abbrev width (c : Config) := 2 ^ (c.logN - c.folds[0]!) +abbrev laneCount (c : Config) := 2 ^ c.folds[0]! +abbrev blockLength (c : Config) := 2 ^ (c.logN - c.folds[0]! + c.rates[0]!) +abbrev Record (c : Config) := Fin (blockLength c) × Array K + +/-- Occupied authenticated leaves have verifier order, opposite coefficient order. -/ +def recordLane (lanes : Nat) (row : Array K) (l : Nat) : K := + if l < lanes then row[lanes - 1 - l]! else 0 + +/-- Cache each dense lane encoding once, independently of the record count. -/ +def encodedLanes (c : Config) (candidate : Array E) : Array (Array E) := + Array.ofFn fun lane : Fin (laneCount c) => + encode (c.logN - c.folds[0]!) c.rates[0]! + (Array.ofFn (unpack true (laneCount c) (width c) candidate lane)) + +/-- The dense source encoder, not a recomputed commitment, checks the certificate. -/ +def rowMatches (c : Config) (lanes : Nat) (encoded : Array (Array E)) (record : Record c) : Bool := + record.2.size == lanes && + (List.finRange (laneCount c)).all (fun lane => + (encoded[lane.val]!)[record.1.val]! == E.ofK (recordLane lanes record.2 lane.val)) + +/-- Deduplicate coordinates, not rows: repeated queries cannot inflate support. -/ +def commonCoordinates (c : Config) (lanes : Nat) (candidate : Array E) + (records : List (Record c)) : Finset (Fin (blockLength c)) := + let encoded := encodedLanes c candidate + ((records.filter (rowMatches c lanes encoded)).map Prod.fst).toFinset + +def verified (input : Public) (candidate : Array E) (records : List (Record input.config)) : Bool := + candidate.size == laneCount input.config * width input.config && + decide (ParameterBounds.threshold input.config 0 ≤ + (commonCoordinates input.config input.lanes candidate records).card) && + input.claims.all (fun claim => dot candidate claim.weight == claim.value) + +/-- Deterministic verified-output stop. No list membership or root-preimage test is evaluated. -/ +def finish (input : Public) (candidate : Array E) (records : List (Record input.config)) : + Option (Witness input.config input.lanes) := + if verified input candidate records then + some (InitialCandidates.project input.config input.lanes candidate) else none + +theorem matches_sound (c : Config) (lanes : Nat) (candidate : Array E) (record : Record c) + (matched : rowMatches c lanes (encodedLanes c candidate) record = true) (lane : Fin (laneCount c)) : + concreteEncoder (c.logN - c.folds[0]!) c.rates[0]! + (unpack true (laneCount c) (width c) candidate lane) record.1 = + E.ofK (recordLane lanes record.2 lane.val) := by + have h : (List.finRange (laneCount c)).all (fun lane => + ((encodedLanes c candidate)[lane.val]!)[record.1.val]! == + E.ofK (recordLane lanes record.2 lane.val)) = true := by + have h := matched + simp only [rowMatches, Bool.and_eq_true] at h + exact h.2 + have hrow := beq_iff_eq.mp (List.all_eq_true.mp h lane (List.mem_finRange lane)) + rw [ConcreteCandidates.concreteEncoder_ofFn] + simpa [encodedLanes, getElem!_pos, lane.isLt] using hrow + +/-- Authentication connects a finite output certificate to the commitment-only +mathematical list. Authentication must come from actual accepted verifier trials. -/ +theorem verified_member (input : Public) (candidate : Array E) + (records : List (Record input.config)) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (checked : verified input candidate records = true) : + candidate ∈ InitialCandidates.extensionCandidates input.config input.lanes input.root := by + obtain ⟨hshape, henough, _⟩ : + candidate.size = laneCount input.config * width input.config ∧ + ParameterBounds.threshold input.config 0 ≤ + (commonCoordinates input.config input.lanes candidate records).card ∧ + input.claims.all (fun claim => dot candidate claim.weight == claim.value) = true := by + simpa only [verified, Bool.and_eq_true, beq_iff_eq, decide_eq_true_eq, and_assoc] using checked + apply (arrayCandidates_mem_iff _ _ _ _ _).mpr + refine ⟨hshape, commonCoordinates input.config input.lanes candidate records, henough, ?_⟩ + intro lane q hq + obtain ⟨record, hrecord, rfl⟩ := List.mem_map.mp (List.mem_toFinset.mp hq) + obtain ⟨member, matched⟩ := List.mem_filter.mp hrecord + have equality := matches_sound input.config input.lanes candidate record matched lane + rw [authenticated record member] at equality + exact equality + +/-- Literal K reconstruction preserves the very candidate checked by the stop rule. -/ +theorem finish_explains (input : Public) (candidate : Array E) + (records : List (Record input.config)) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (depth : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (threshold : width input.config - 1 < ParameterBounds.threshold input.config 0) + (w : Witness input.config input.lanes) + (output : finish input candidate records = some w) : + KnowledgeExtraction.Explains input w := by + unfold finish at output + split at output + · rename_i checked + have equal := Option.some.inj output + subst w + have member := verified_member input candidate records authenticated checked + refine ⟨Finset.mem_image.mpr ⟨candidate, member, rfl⟩, ?_⟩ + have reconstructed := InitialCandidates.reconstruction input.config input.lanes input.root + foldBound laneBound depth threshold candidate member + have claims : input.claims.all (fun claim => dot candidate claim.weight == claim.value) = true := by + have h := checked + simp only [verified, Bool.and_eq_true] at h + exact h.2 + intro claim memberClaim + rw [← reconstructed] + have hc := List.all_eq_true.mp (show input.claims.toList.all + (fun claim => dot candidate claim.weight == claim.value) = true by + simpa using claims) claim memberClaim + exact beq_iff_eq.mp hc + · contradiction + +#print axioms verified_member +#print axioms finish_explains +end Whir.SupportedCandidateExtraction diff --git a/verification/whir/Whir/SupportedCandidateFolding.lean b/verification/whir/Whir/SupportedCandidateFolding.lean new file mode 100644 index 000000000..937546861 --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateFolding.lean @@ -0,0 +1,78 @@ +import Whir.SupportedCandidateExtraction + +/-! Same-target reconstruction along an explicitly supplied actual fold schedule. +Each schedule step excludes exactly the same-set MCA RowBad event; no new +existence or honest-prover assumption is introduced. -/ +namespace Whir.SupportedCandidateExtraction +open Concrete Protocol CandidateFolding MutualAgreement + +variable {F I : Type*} [Field F] [Fintype F] [Inhabited F] [CharP F 2] + +/-- The function index is the actual composition of executable coefficient folds. +The schedule carries all MCA exclusions separately from decoder proximity. -/ +inductive SafeFoldSchedule {k : Nat} (top : Bool) + (enc : (Fin k → F) →ₗ[F] (I → F)) (C : Submodule F (I → F)) (threshold : Nat) : + {start finish : Nat} → (Fin start → I → F) → (Fin finish → I → F) → + (Array F → Array F) → Prop + | done {lanes : Nat} (oracle : Fin lanes → I → F) : + SafeFoldSchedule top enc C threshold oracle oracle id + | step {lanes finish : Nat} (oracle : Fin (lanes * 2) → I → F) (z : F) + (good : ¬ RowBad foldGenerator C threshold + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)] z) + {last : Fin finish → I → F} {transform : Array F → Array F} + (rest : SafeFoldSchedule top enc C threshold (foldOracle oracle z) last transform) : + SafeFoldSchedule top enc C threshold oracle last + (fun a => transform (foldValues a (foldBlock top k) z)) + +/-- The GIVEN target is lifted, not replaced by another final-list candidate. -/ +theorem same_target_lifts {k start finish : Nat} (top : Bool) + (enc : (Fin k → F) →ₗ[F] (I → F)) (C : Submodule F (I → F)) + (rangeEq : LinearMap.range enc = C) (threshold : Nat) + (oracle : Fin start → I → F) (last : Fin finish → I → F) + (transform : Array F → Array F) + (schedule : SafeFoldSchedule top enc C threshold oracle last transform) + (target : Array F) (member : target ∈ arrayCandidates top enc last threshold) : + ∃ original ∈ arrayCandidates top enc oracle threshold, transform original = target := by + induction schedule with + | done oracle => exact ⟨target, member, rfl⟩ + | step oracle z good rest ih => + obtain ⟨middle, hmiddle, hequal⟩ := ih member + obtain ⟨original, horiginal, hfold⟩ := array_lifts top enc C rangeEq oracle threshold z good + middle hmiddle + exact ⟨original, horiginal, by simpa only [← hfold] using hequal⟩ + +/-- Once instantiated at the initial committed rows, lifting yields a literal +occupied K witness whose folded image is exactly the fixed OOD-selected target. -/ +theorem initial_same_target (input : CausalGame.Public) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (depth : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (threshold : width input.config - 1 < ParameterBounds.threshold input.config 0) + {finish : Nat} (last : Fin finish → Fin (blockLength input.config) → E) + (transform : Array E → Array E) + (schedule : SafeFoldSchedule true + (concreteEncoder (input.config.logN - input.config.folds[0]!) + input.config.rates[0]!) + (LinearMap.range (concreteEncoder + (input.config.logN - input.config.folds[0]!) input.config.rates[0]!)) + (ParameterBounds.threshold input.config 0) + (fun lane q => E.ofK (InitialCandidates.fullRow input.config input.lanes input.root lane q)) + last transform) + (target : Array E) + (member : target ∈ arrayCandidates true + (concreteEncoder (input.config.logN - input.config.folds[0]!) + input.config.rates[0]!) last (ParameterBounds.threshold input.config 0)) : + ∃ w ∈ InitialCandidates.witnesses input.config input.lanes input.root, + transform (CausalGame.paddedWitness input.config input.lanes w) = target := by + obtain ⟨original, horiginal, equal⟩ := same_target_lifts true _ _ rfl _ _ _ _ schedule target member + have initial : original ∈ InitialCandidates.extensionCandidates input.config input.lanes input.root := + horiginal + have reconstruction := InitialCandidates.reconstruction input.config input.lanes input.root + foldBound laneBound depth threshold original initial + refine ⟨InitialCandidates.project input.config input.lanes original, + Finset.mem_image.mpr ⟨original, initial, rfl⟩, ?_⟩ + simpa only [← reconstruction] using equal + +#print axioms same_target_lifts +#print axioms initial_same_target +end Whir.SupportedCandidateExtraction diff --git a/verification/whir/Whir/SupportedCandidateMCA.lean b/verification/whir/Whir/SupportedCandidateMCA.lean new file mode 100644 index 000000000..8c0ef330b --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateMCA.lean @@ -0,0 +1,57 @@ +import Whir.SupportedCandidateFolding +import Whir.ProductionTransitions + +/-! Raw same-set MCA exclusions required for SAME-target lifting. These are +stronger than the existing all-candidates-lost restoration event and are charged +explicitly; no accepted-prover availability premise is hidden in their bound. -/ +namespace Whir.SupportedCandidateExtraction +open Concrete Protocol CandidateFolding MutualAgreement ParameterBounds + +open Classical in +noncomputable def mcaSeeds (profile : Profile) (level : Fin (config profile).folds.size) + {lanes : Nat} (oracle : Fin (lanes * 2) → Fin (length (config profile) level) → E) : Finset E := + Finset.univ.filter (RowBad foldGenerator + (LinearMap.range (concreteEncoder (CausalGame.remaining (config profile) level) + (config profile).rates[level.val]!)) (threshold (config profile) level) + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)]) + +/-- Per actual fresh fold scalar, for ANY fixed prefix row oracle and ANY lane +count, the separately charged SAME-target MCA event costs at most 2^-84. -/ +theorem mcaSeeds_probability (profile : Profile) (level : Fin (config profile).folds.size) + {lanes : Nat} (oracle : Fin (lanes * 2) → Fin (length (config profile) level) → E) : + Soundness.uniformProb (mcaSeeds profile level oracle) ≤ (2 ^ 108 : ℚ) / 2 ^ 192 := by + classical + obtain ⟨depth, degreePositive, degreeBound⟩ := ProductionTransitions.production_fold_facts profile level + let n := CausalGame.remaining (config profile) level + let rate := (config profile).rates[level.val]! + let domain := AdditiveCode.concreteDomain (n + rate) depth + have rangeEq : LinearMap.range (concreteEncoder n rate) = rsCode domain (2 ^ n) := by + unfold concreteEncoder + exact novelEncoder_range _ _ (AdditiveCode.concrete_bitBasis_independent n (by omega)) _ + have johnson := (production_radius profile level).2 + simp only [rho_cast, dimension, length, Nat.cast_pow, Nat.cast_ofNat] at johnson + change 1 ≤ 2 ^ n - 1 at degreePositive + change 2 ^ n - 1 ≤ 2 ^ (n + rate) - 2 at degreeBound + have estimate := johnson_row_bad_probability domain degreePositive degreeBound + (radius (config profile) level) (production_radius profile level).1.le + (by simpa only [n, rate, Nat.cast_pow, Nat.cast_ofNat] using johnson) + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)] + have degree : 2 ^ n - 1 + 1 = 2 ^ n := by + have positive : 0 < 2 ^ n := by positivity + omega + rw [degree] at estimate + have eventEq : mcaSeeds profile level oracle = Finset.univ.filter + (RowBad foldGenerator (rsCode domain (2 ^ n)) + ⌈(length (config profile) level : ℝ) * (1 - radius (config profile) level)⌉₊ + ![fun lane => oracle (evenLane lane), fun lane => oracle (oddLane lane)]) := by + dsimp only [n, rate] at rangeEq ⊢ + simp only [mcaSeeds, rangeEq, ProductionTransitions.threshold_real] + simp only [length, n, rate] at eventEq + erw [← eventEq] at estimate + have bounded := estimate.trans (div_le_div_of_nonneg_right + (production_johnsonNumerator profile level) (by positivity)) + simp only [FieldModel.card_E, Nat.cast_pow, Nat.cast_ofNat] at bounded + exact (Rat.cast_le (K := ℝ)).mp (by simpa only [Rat.cast_div, Rat.cast_pow, Rat.cast_ofNat] using bounded) + +#print axioms mcaSeeds_probability +end Whir.SupportedCandidateExtraction diff --git a/verification/whir/Whir/SupportedCandidateParameters.lean b/verification/whir/Whir/SupportedCandidateParameters.lean new file mode 100644 index 000000000..156900c57 --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateParameters.lean @@ -0,0 +1,34 @@ +import Whir.UniqueRadiusSampling + +/-! Exact initial-root source-profile cutoff. Query counts vary with rate and +size: 56 is used only at rate four. The extraction cutoff is not 128-bit. -/ +namespace Whir.SupportedCandidateExtraction + +def initialRadiusLoss (profile : ParameterBounds.Profile) : ℚ := + let c := ParameterBounds.config profile + UniqueRadiusSampling.queryLoss + (c.logN - c.folds[0]! + c.rates[0]!) (2 ^ (c.logN - c.folds[0]!)) c.queries[0]! + +def radiusEnvelope : ℚ := (17 / 32) ^ 56 +def extractionCutoff : ℚ := 1 / 2 ^ 50 + +set_option maxHeartbeats 0 in +set_option maxRecDepth 100000 in +/-- Kernel certificate on ALL actual production profiles, not a substituted +rate-four query count. Finite-size parity corrections are retained. -/ +theorem production_initialRadiusLoss : ∀ profile : ParameterBounds.Profile, + initialRadiusLoss profile ≤ radiusEnvelope := by + decide +kernel + +theorem extractionCutoff_gap (profile : ParameterBounds.Profile) : + (1 / 2 ^ 51 : ℚ) < extractionCutoff - initialRadiusLoss profile := by + have bound := production_initialRadiusLoss profile + have envelope := UniqueRadiusSampling.rate_four_envelope_bits.2 + change radiusEnvelope < (1 / 2 ^ 51 : ℚ) at envelope + unfold extractionCutoff + norm_num at * + linarith + +#print axioms production_initialRadiusLoss +#print axioms extractionCutoff_gap +end Whir.SupportedCandidateExtraction diff --git a/verification/whir/Whir/SupportedCandidateProtocol.lean b/verification/whir/Whir/SupportedCandidateProtocol.lean new file mode 100644 index 000000000..3a787cf55 --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateProtocol.lean @@ -0,0 +1,141 @@ +import Whir.InitialKnowledgeSchedule +import Whir.AcceptedShapes +import Whir.SupportedCandidateCancellation + +/-! Initial Root0 production knowledge certificate, with actual causal fold +exclusions instead of an abstract safe-schedule hypothesis. -/ +namespace Whir.SupportedCandidateProtocol +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open CandidateFolding SupportedCandidateExtraction ParameterBounds InitialKnowledgeSchedule + +set_option maxRecDepth 100000 +set_option maxHeartbeats 400000 +attribute [local irreducible] ParameterBounds.config + +abbrev initialLevel (p : Profile) : Fin (config p).folds.size := + ⟨0, (production_config_valid p).2.1⟩ + +/-- A large folded agreement set places the GIVEN whole Root1 coefficient +target in the Root0 postfold list. The Root1 target is not a compact message. -/ +theorem target_member_of_agreement (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (valid : oracleValid (liftRoot root) (length (config p) 0) lanes = true) + (laneBound : lanes ≤ 2 ^ (config p).folds[0]!) + (target : Array E) (size : target.size = 2 ^ remaining (config p) 0) + (H : Finset (Fin (length (config p) 0))) (enough : threshold (config p) 0 ≤ H.card) + (agree : ∀ q ∈ H, + (encode (remaining (config p) 0) (config p).rates[0]! target)[q.val]! = + QueryBatchSoundness.oldWord (remaining (config p) 0) (config p).rates[0]! + (liftRoot root) true (challenges (config p) t).levels[0]!.folds q) : + target ∈ foldCandidates (Input p lanes root claims) strategy t 0 (config p).folds[0]! := by + unfold foldCandidates + change target ∈ arrayCandidates true (concreteEncoder (remaining (config p) 0) (config p).rates[0]!) + (OracleReplay.oracleAt true (config p).folds[0]! (liftRoot root) + (challenges (config p) t).levels[0]!.folds (config p).folds[0]!) (threshold (config p) 0) + rw [AcceptedShapes.terminal_candidates true (config p).folds[0]! (remaining (config p) 0) + (config p).rates[0]! (threshold (config p) 0) (liftRoot root) (challenges (config p) t).levels[0]!.folds + (CausalStateCausality.challenge_folds_size (config p) t (initialLevel p)) + (by intro q; exact (OracleReplay.oracleValid_row _ _ _ valid q.val q.isLt).le.trans laneBound)] + apply (arrayCandidates_mem_iff _ _ _ _ _).mpr + refine ⟨by simpa using size, H, enough, ?_⟩ + intro lane q hq + have zero : lane = 0 := Subsingleton.elim _ _ + subst lane + have unpacked : Array.ofFn (unpack true 1 (2 ^ remaining (config p) 0) target 0) = target := by + apply Array.ext + · simpa using size.symm + · intro j hj hj' + simp [unpack, topIndex, getElem!_pos, hj'] + rw [ConcreteCandidates.concreteEncoder_ofFn, unpacked] + exact agree q hq + +/-- Literal initial K witness, SAME folded target, and every original public +claim. The committed root shape is an actual verifier initialization guard. -/ +theorem initial_same_target (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (valid : oracleValid (liftRoot root) (length (config p) 0) lanes = true) + (laneBound : lanes ≤ 2 ^ (config p).folds[0]!) + (mca : ∀ j : Fin (config p).folds[0]!, + ¬ RawMCA (Input p lanes root claims) strategy (initialLevel p) j t) + (guard : ∀ j : Fin (config p).folds[0]!, + ¬ ClaimEscape (Input p lanes root claims) strategy (initialLevel p) j t) + (batchSafe : t.1 ∉ InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) lanes root) claims) + (target : Array E) + (member : target ∈ foldCandidates (Input p lanes root claims) strategy t 0 (config p).folds[0]!) + (truth : dot target (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state.weight = + (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state.claim) : + ∃ w : Witness (config p) lanes, + KnowledgeExtraction.Explains (Input p lanes root claims) w ∧ + foldFrom (Input p lanes root claims) t 0 0 (config p).folds[0]! + (paddedWitness (config p) lanes w) = target := by + obtain ⟨original, ho, hf, hc⟩ := InitialKnowledgeSchedule.same_target_lifts p lanes root claims strategy t + (initialLevel p) 0 (config p).folds[0]! (by change 0 + (config p).folds[0]! ≤ (config p).folds[0]!; omega) + (by intro j _ _; exact mca j) (by intro j _ _; exact guard j) target + (by simpa only [initialLevel, Nat.zero_add] using member) + (by simpa only [initialLevel, Nat.zero_add, CausalBoundary.boundary] using truth) + rw [AcceptedShapes.initial_candidates p lanes root claims strategy t valid] at ho + have reconstruct := InitialCandidates.production_reconstruction p lanes root laneBound original ho + have originalSize : original.size = 2 ^ (config p).logN := by + rw [reconstruct] + simp [paddedWitness] + refine ⟨InitialCandidates.project (config p) lanes original, ⟨?_, ?_⟩, ?_⟩ + · exact Finset.mem_image.mpr ⟨original, ho, rfl⟩ + · rw [← reconstruct] + apply all_claims_of_safe_batch _ claims t.1 original ho batchSafe + rw [originalSize] + simpa only [initialLevel, foldAt_zero, levelAt_zero, initial] using hc + · simpa only [← reconstruct] using hf + +/-- The actual accepted execution supplies both initialization premises; its +pending-message table is not used as a candidate coefficient table. -/ +theorem accepted_initial_same_target (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (accepted : experiment (Input p lanes root claims) strategy t = true) + (mca : ∀ j : Fin (config p).folds[0]!, + ¬ RawMCA (Input p lanes root claims) strategy (initialLevel p) j t) + (guard : ∀ j : Fin (config p).folds[0]!, + ¬ ClaimEscape (Input p lanes root claims) strategy (initialLevel p) j t) + (batchSafe : t.1 ∉ InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) lanes root) claims) + (target : Array E) + (member : target ∈ foldCandidates (Input p lanes root claims) strategy t 0 (config p).folds[0]!) + (truth : dot target (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state.weight = + (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state.claim) : + ∃ w : Witness (config p) lanes, + KnowledgeExtraction.Explains (Input p lanes root claims) w ∧ + foldFrom (Input p lanes root claims) t 0 0 (config p).folds[0]! + (paddedWitness (config p) lanes w) = target := + initial_same_target p lanes root claims strategy t + (by simpa only [initialLevel, levelAt_zero, initial, beq_self_eq_true, ↓reduceIte] using + AcceptedShapes.accepted_oracle p lanes root claims strategy t accepted (initialLevel p)) + (AcceptedShapes.accepted_lane_bound _ _ _ accepted) mca guard batchSafe target member truth + +/-- Cancellation forces every full padded encoded lane at a fixed coordinate, +including occupied K leaves and zero padding. -/ +theorem rowMatches_of_folded_equality (input : Public) + (seed : Fin input.config.folds[0]! → E) + (safe : ¬ initialRowCancellation input seed) + (w : Witness input.config input.lanes) + (member : w ∈ InitialCandidates.witnesses input.config input.lanes input.root) + (q : Fin (blockLength input.config)) + (shape : input.root[q.val]!.size = input.lanes) + (equal : Concrete.mle (committedRow input q) (Array.ofFn seed) = + Concrete.mle (witnessRow input w q) (Array.ofFn seed)) : + rowMatches input.config input.lanes (encodedLanes input.config (paddedWitness input.config input.lanes w)) + (q, input.root[q.val]!) = true := by + have rows := rowEquality_of_not_cancellation input.config.folds[0]! + (InitialCandidates.witnesses input.config input.lanes input.root) + (committedRow input) (witnessRow input) seed safe w member q equal + simp only [rowMatches, Bool.and_eq_true, beq_iff_eq, shape, true_and] + apply List.all_eq_true.mpr + intro lane _ + apply beq_iff_eq.mpr + have entry := congrArg (fun row => row[lane.val]!) rows + simpa [committedRow, witnessRow, encodedLanes, InitialCandidates.fullRow, + recordLane, getElem!_pos, lane.isLt] using entry.symm + +#print axioms initial_same_target +#print axioms accepted_initial_same_target +#print axioms rowMatches_of_folded_equality +end Whir.SupportedCandidateProtocol diff --git a/verification/whir/Whir/SupportedCandidateProtocolAccepted.lean b/verification/whir/Whir/SupportedCandidateProtocolAccepted.lean new file mode 100644 index 000000000..05b77ac3f --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateProtocolAccepted.lean @@ -0,0 +1,133 @@ +import Whir.SupportedCandidateProtocolHeavy +import Whir.SupportedCandidateProtocolProbability + +/-! Derived deterministic interfaces for safe accepted FULL suffix resets. +No advertised-value correctness or acceptance bad-event cover is assumed. -/ +namespace Whir.SupportedCandidateProtocol +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open CandidateFolding SupportedCandidateExtraction ParameterBounds InitialKnowledgeSchedule +open AuthenticatedResetSupport RewindBatchTarget +set_option maxRecDepth 100000 +set_option maxHeartbeats 400000 +attribute [local irreducible] ParameterBounds.config + +theorem production_initial_next : ∀ p : Profile, 1 < (config p).folds.size := by + decide +kernel + +abbrev firstOOD (p : Profile) : Fin (oodCount (config p) 0) := + ⟨0, production_ood_positive p (initialLevel p) (production_initial_next p)⟩ + +def reset (p : Profile) (base fresh : Tape (config p)) + (draw : Sample (.query (initialLevel p))) : Tape (config p) := + set (.query (initialLevel p)) (resetSuffix (position (.query (initialLevel p))) base fresh) draw + +/-- A single safe accepted continuation derives the prefix's unique advertised +OOD target and true boundary claim, plus all immutable guards. Arbitrary +malicious OOD answers with no matching target admit no such continuation. -/ +theorem accepted_safe_target (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (base fresh : Tape (config p)) + (draw : Sample (.query (initialLevel p))) + (accepted : experiment (Input p lanes root claims) strategy (reset p base fresh draw) = true) + (safe : ¬ KnowledgeBad p lanes root claims strategy (reset p base fresh draw)) : + ∃ target : Array E, + Target (followingCandidates (Input p lanes root claims) strategy base 0) + (challenges (config p) base).levels[0]!.oodPoints[0]! + (proof (Input p lanes root claims) strategy base).levels[0]!.oods[0]!.value target ∧ + LevelBoundary.Separated (followingCandidates (Input p lanes root claims) strategy base 0) + (challenges (config p) base).levels[0]!.oodPoints[0]! ∧ + target.size = width (config p) ∧ + dot target (CausalBoundary.boundary (Input p lanes root claims) strategy base (initialLevel p)).state.weight = + (CausalBoundary.boundary (Input p lanes root claims) strategy base (initialLevel p)).state.claim ∧ + PriorGood p lanes root claims strategy base ∧ + oracleValid (liftRoot root) (length (config p) 0) lanes = true ∧ + lanes ≤ 2 ^ (config p).folds[0]! := by + let input := Input p lanes root claims + let i := initialLevel p + let t := reset p base fresh draw + have causal : ∀ q, ¬ CausalBadEvents.Bad input strategy q t := by + intro q bad + exact safe (Or.inl ⟨q, bad⟩) + have collision : ¬ CollisionEvent p lanes root claims strategy t := by + intro bad + exact safe (Or.inr (Or.inr (Or.inr bad))) + have collisionPrior := (collisionEvent_set p lanes root claims strategy + (resetSuffix (position (.query i)) base fresh) draw).not.mp collision + obtain ⟨target, matching, truth⟩ := Root0FixedTarget.accepted_reset_target_exists p lanes root claims + strategy (resetSuffix (position (.query i)) base fresh) i (production_initial_next p) draw + accepted causal collisionPrior + have fixed := Root0FixedTarget.snapshot_fullReset input strategy base fresh i draw + have suffixFixed := Root0FixedTarget.snapshot_resetCoordinates input strategy base fresh i + (visibleCoordinates input.config ++ List.ofFn (fun j : Fin (input.config.logN-input.config.folds.toList.sum) => Coordinate.tail j)) + change Root0FixedTarget.snapshot input strategy (resetSuffix (position (.query i)) base fresh) i = + Root0FixedTarget.snapshot input strategy base i at suffixFixed + have list := congrArg (fun s => s.1) suffixFixed + have boundary := congrArg (fun s => s.2.1) suffixFixed + have answers := congrArg (fun s => s.2.2.2.1) suffixFixed + have points := congrArg (fun s => s.2.2.2.2.2) suffixFixed + dsimp only [Root0FixedTarget.snapshot] at list boundary answers points + have matchingBase : Target (followingCandidates input strategy base i) + (challenges (config p) base).levels[i.val]!.oodPoints[0]! + (proof input strategy base).levels[i.val]!.oods[0]!.value target := by + unfold Target at matching ⊢ + rw [list, points, answers] at matching + exact matching + have separated : LevelBoundary.Separated (followingCandidates input strategy t i) + (challenges (config p) t).levels[i.val]!.oodPoints[0]! := by + by_contra bad + exact causal (.ood i (firstOOD p)) bad + have separatedBase : LevelBoundary.Separated (followingCandidates input strategy base i) + (challenges (config p) base).levels[i.val]!.oodPoints[0]! := by + have list := congrArg (fun s => s.1) fixed + have points := congrArg (fun s => s.2.2.2.2.2) fixed + dsimp only [Root0FixedTarget.snapshot] at list points + unfold t reset at separated + rw [list, points] at separated + exact separated + have size := CausalBoundary.followingCandidates_sizes input strategy base p rfl i + (by intro impossible; exact (impossible (production_initial_next p)).elim) target matchingBase.1 + have prior := priorGood_of_not_bad p lanes root claims strategy t safe + have basePrior : PriorGood p lanes root claims strategy base := by + unfold t reset at prior + rw [priorGood_set p lanes root claims strategy _ (.query i) _ le_rfl] at prior + exact (priorGood_resetCoordinates p lanes root claims strategy base fresh _).mp prior + have valid := AcceptedShapes.accepted_oracle p lanes root claims strategy t accepted i + have laneBound := AcceptedShapes.accepted_lane_bound input strategy t accepted + refine ⟨target, matchingBase, separatedBase, ?_, ?_, basePrior, ?_, laneBound⟩ + · simpa only [input, i, initialLevel, width, (InitialCandidates.production_initial_facts p).1] using size + · change dot target + (CausalBoundary.boundary input strategy (resetSuffix (position (.query i)) base fresh) i).state.weight = + (CausalBoundary.boundary input strategy (resetSuffix (position (.query i)) base fresh) i).state.claim at truth + rw [boundary] at truth + exact truth + · simpa only [i, initialLevel, levelAt_zero, initial, beq_self_eq_true, ↓reduceIte] using valid + +/-- Every other safe accepted full reset hits this same prefix-fixed target, +including when all future folds, OODs, queries and tail coins are replaced. -/ +theorem accepted_safe_hits (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (base fresh : Tape (config p)) + (draw : Sample (.query (initialLevel p))) (target : Array E) + (matching : Target (followingCandidates (Input p lanes root claims) strategy base 0) + (challenges (config p) base).levels[0]!.oodPoints[0]! + (proof (Input p lanes root claims) strategy base).levels[0]!.oods[0]!.value target) + (separated : LevelBoundary.Separated (followingCandidates (Input p lanes root claims) strategy base 0) + (challenges (config p) base).levels[0]!.oodPoints[0]!) + (accepted : experiment (Input p lanes root claims) strategy (reset p base fresh draw) = true) + (safe : ¬ KnowledgeBad p lanes root claims strategy (reset p base fresh draw)) : + SamplingProbability.allQueriesHit (remaining (config p) 0 + (config p).rates[0]!) (config p).queries[0]! + (LevelBoundary.agreeingColumns (remaining (config p) 0) (config p).rates[0]! target + (QueryBatchSoundness.oldWord (remaining (config p) 0) (config p).rates[0]! + (liftRoot root) true (challenges (config p) base).levels[0]!.folds)) draw.1 := by + have causal : ∀ q, ¬ CausalBadEvents.Bad (Input p lanes root claims) strategy q (reset p base fresh draw) := by + intro q bad + exact safe (Or.inl ⟨q, bad⟩) + have outside : ¬ CollisionEvent p lanes root claims strategy (reset p base fresh draw) := by + intro bad + exact safe (Or.inr (Or.inr (Or.inr bad))) + have collision := (collisionEvent_set p lanes root claims strategy + (resetSuffix (position (.query (initialLevel p))) base fresh) draw).not.mp outside + exact Root0FixedTarget.accepted_full_reset_hits p lanes root claims strategy base fresh + (initialLevel p) (production_initial_next p) draw target matching separated accepted causal collision + +#print axioms accepted_safe_target +#print axioms accepted_safe_hits +end Whir.SupportedCandidateProtocol diff --git a/verification/whir/Whir/SupportedCandidateProtocolHeavy.lean b/verification/whir/Whir/SupportedCandidateProtocolHeavy.lean new file mode 100644 index 000000000..ac6b4fec3 --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateProtocolHeavy.lean @@ -0,0 +1,81 @@ +import Whir.SupportedCandidateProtocolRows + +/-! One actual initial witness explains all claims and every heavy authenticated +Root0 coordinate. Non-heavy authenticated rows are not asserted honest. -/ +namespace Whir.SupportedCandidateProtocol +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open CandidateFolding SupportedCandidateExtraction ParameterBounds InitialKnowledgeSchedule +set_option maxRecDepth 100000 +set_option maxHeartbeats 400000 +attribute [local irreducible] ParameterBounds.config + +/-- Production SAME-w bridge. The set H is any common support derived from +safe accepted full resets; only its actual cardinality and scalar-hit projection +are consumed. Raw MCA and guarded round events instantiate the six causal +steps internally. No abstract safe-fold-schedule premise occurs. -/ +theorem same_w_on_support (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (valid : oracleValid (liftRoot root) (length (config p) 0) lanes = true) + (laneBound : lanes ≤ 2 ^ (config p).folds[0]!) + (mca : ∀ j : Fin (config p).folds[0]!, + ¬ RawMCA (Input p lanes root claims) strategy (initialLevel p) j t) + (guard : ∀ j : Fin (config p).folds[0]!, + ¬ ClaimEscape (Input p lanes root claims) strategy (initialLevel p) j t) + (batchSafe : t.1 ∉ InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) lanes root) claims) + (cancelSafe : ¬ initialRowCancellation (Input p lanes root claims) (t.2.1 (initialLevel p)).1) + (target : Array E) (size : target.size = width (config p)) + (truth : dot target (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state.weight = + (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state.claim) + (H : Finset (Fin (blockLength (config p)))) (enough : threshold (config p) 0 ≤ H.card) + (agree : ∀ q ∈ H, + (encode ((config p).logN-(config p).folds[0]!) (config p).rates[0]! target)[q.val]! = + QueryBatchSoundness.oldWord ((config p).logN-(config p).folds[0]!) (config p).rates[0]! + (liftRoot root) true (challenges (config p) t).levels[0]!.folds q) : + ∃ w : Witness (config p) lanes, + KnowledgeExtraction.Explains (Input p lanes root claims) w ∧ + ∀ q ∈ H, rowMatches (config p) lanes + (encodedLanes (config p) (paddedWitness (config p) lanes w)) (q, root[q.val]!) = true := by + have dims := (InitialCandidates.production_initial_facts p).1 + have targetMember : target ∈ foldCandidates (Input p lanes root claims) strategy t 0 (config p).folds[0]! := by + let lift : Fin (blockLength (config p)) ↪ Fin (length (config p) 0) := + { toFun := fun q => ⟨q.val, by simpa only [length, dims] using q.isLt⟩ + inj' := by + intro a b equality + apply Fin.ext + exact congrArg (fun q : Fin (length (config p) 0) => q.val) equality } + let support := H.map lift + apply target_member_of_agreement p lanes root claims strategy t valid laneBound target + (by simpa only [dims, width] using size) support + · simpa only [support, Finset.card_map] using enough + · intro q hq + change q ∈ H.map lift at hq + obtain ⟨original, inside, equality⟩ := Finset.mem_map.mp hq + subst q + have scalar := agree original inside + change (encode (remaining (config p) 0) (config p).rates[0]! target)[original.val]! = + dot ((liftRoot root)[original.val]!.reverse) (eqTable (challenges (config p) t).levels[0]!.folds) + simpa only [dims, QueryBatchSoundness.oldWord, ↓reduceIte] using scalar + obtain ⟨w, explains, folded⟩ := initial_same_target p lanes root claims strategy t valid laneBound + mca guard batchSafe target targetMember truth + refine ⟨w, explains, ?_⟩ + intro q hq + have qs : q.val < length (config p) 0 := by simpa only [length, dims] using q.isLt + have rowSize := OracleReplay.oracleValid_row _ _ _ valid q.val qs + have rs : q.val < root.size := by + have shape := valid + simp only [oracleValid, Bool.and_eq_true, beq_iff_eq, liftRoot, Array.size_map] at shape + exact qs.trans_eq shape.1.symm + have shape : root[q.val]!.size = lanes := by simpa [liftRoot, getElem!_pos, rs] using rowSize + apply rowMatches_of_folded_equality (Input p lanes root claims) (t.2.1 (initialLevel p)).1 + cancelSafe w explains.1 q shape + have seed : Array.ofFn (t.2.1 (initialLevel p)).1 = + (challenges (config p) t).levels[0]!.folds := by + simp [challenges, initialLevel, _root_.getElem!_pos, (production_config_valid p).2.1] + rw [seed, committed_folded_word p lanes root claims t valid laneBound q] + have encoded := witness_folded_encode p lanes root claims t w q + rw [folded] at encoded + exact (agree q hq).symm.trans encoded + +#print axioms same_w_on_support +end Whir.SupportedCandidateProtocol diff --git a/verification/whir/Whir/SupportedCandidateProtocolProbability.lean b/verification/whir/Whir/SupportedCandidateProtocolProbability.lean new file mode 100644 index 000000000..afb9bb56b --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateProtocolProbability.lean @@ -0,0 +1,328 @@ +import Whir.Root0FixedTarget +import Whir.SupportedCandidateProtocol +import Whir.RingMapBatching + +/-! Knowledge-only exclusions on the actual finite causal tape. These are +source-independent fixed-list events, not assumed acceptance-failure covers. -/ +namespace Whir.SupportedCandidateProtocol +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open CandidateFolding SupportedCandidateExtraction ParameterBounds InitialKnowledgeSchedule +open SamplingProbability AuthenticatedResetProbability RewindBatchTarget +open scoped BigOperators +set_option maxRecDepth 100000 +set_option maxHeartbeats 400000 +attribute [local irreducible] ParameterBounds.config +attribute [local irreducible] RawMCA ClaimEscape + +abbrev FoldRest (c : Config) (i : Fin c.folds.size) := + E × (Fin (oodCount c i.val) → Fin (remaining c i.val) → E) × + (Fin (queryChunks c i.val) → E) × E × + (∀ j : {j : Fin c.folds.size // j ≠ i}, LevelTape c j.val) × + (Fin (c.logN-c.folds.toList.sum) → E) + +noncomputable def foldSeedEquiv (c : Config) (i : Fin c.folds.size) : + Tape c ≃ (Fin c.folds[i.val]! → E) × FoldRest c i where + toFun t := ((t.2.1 i).1, t.1, (t.2.1 i).2.1, (t.2.1 i).2.2.1, + (t.2.1 i).2.2.2, (Equiv.piSplitAt i (LevelTape c) t.2.1).2, t.2.2) + invFun x := (x.2.1, + (Equiv.piSplitAt i (LevelTape c)).symm + ((x.1, x.2.2.1, x.2.2.2.1, x.2.2.2.2.1), x.2.2.2.2.2.1), x.2.2.2.2.2.2) + left_inv t := by + rcases t with ⟨batch, levels, tail⟩ + change (batch, (Equiv.piSplitAt i (LevelTape c)).symm + ((Equiv.piSplitAt i (LevelTape c)) levels), tail) = (batch, levels, tail) + rw [Equiv.symm_apply_apply] + right_inv x := by + dsimp only + let pair := ((x.1, x.2.2.1, x.2.2.2.1, x.2.2.2.2.1), x.2.2.2.2.2.1) + have inverse := (Equiv.piSplitAt i (LevelTape c)).apply_symm_apply pair + have selected := congrArg Prod.fst inverse + change ((Equiv.piSplitAt i (LevelTape c)).symm pair) i = pair.1 at selected + have other := congrArg Prod.snd inverse + rw [selected, other] + +noncomputable def CancellationEvent (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (t : Tape (config p)) : Prop := + initialRowCancellation (Input p lanes root claims) (t.2.1 (initialLevel p)).1 + +open Classical in + theorem cancellation_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) : + Soundness.uniformProb (Finset.univ.filter (CancellationEvent p lanes root claims)) ≤ + (2 ^ 32 : ℚ) * blockLength (config p) * (6 / 2 ^ 192) := by + have law := probability_equiv (foldSeedEquiv (config p) (initialLevel p)) + (fun x => initialRowCancellation (Input p lanes root claims) x.1) + rw [product_left] at law + change probability (CancellationEvent p lanes root claims) = _ at law + rw [probability_eq_uniformProb, probability_eq_uniformProb] at law + have rational := (Rat.cast_inj (α := ℝ)).mp law + rw [rational] + calc + _ ≤ (2 ^ 32 : ℚ) * blockLength (config p) * ((config p).folds[0]! / (2 ^ 192 : ℚ)) := + production_rowCancellation_probability p lanes root claims + _ = _ := congrArg (fun n : Nat => + (2 ^ 32 : ℚ) * blockLength (config p) * (n / (2 ^ 192 : ℚ))) (production_initial_six p) + +/-- Full actual-query lambda collision event; adaptive response rows disappear +from its error polynomial by authenticated substitution. -/ +noncomputable def CollisionEvent (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) : Prop := + Collision (remaining (config p) 0) (config p).rates[0]! (config p).queries[0]! 0 + (levelAt (Input p lanes root claims) strategy t 0).oracle + (challenges (config p) t).levels[0]! + (proof (Input p lanes root claims) strategy t).levels[0]! + (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state + (followingCandidates (Input p lanes root claims) strategy t 0) + (get (.query (initialLevel p)) t).1 (get (.query (initialLevel p)) t).2 + +theorem collisionEvent_set (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (draw : Sample (.query (initialLevel p))) : + CollisionEvent p lanes root claims strategy (set (.query (initialLevel p)) t draw) ↔ + Collision (remaining (config p) 0) (config p).rates[0]! (config p).queries[0]! 0 + (levelAt (Input p lanes root claims) strategy t 0).oracle + (challenges (config p) t).levels[0]! + (proof (Input p lanes root claims) strategy t).levels[0]! + (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state + (followingCandidates (Input p lanes root claims) strategy t 0) draw.1 draw.2 := by + let input := Input p lanes root claims + let i := initialLevel p + have fixed := Root0FixedTarget.snapshot_set input strategy t i (.query i) draw le_rfl + have list := congrArg (fun s => s.1) fixed + have boundary := congrArg (fun s => s.2.1) fixed + have oracle := congrArg (fun s => s.2.2.1) fixed + have answers := congrArg (fun s => s.2.2.2.1) fixed + have folds := congrArg (fun s => s.2.2.2.2.1) fixed + have points := congrArg (fun s => s.2.2.2.2.2) fixed + dsimp only [Root0FixedTarget.snapshot, i, initialLevel] at list boundary oracle answers folds points + unfold CollisionEvent Collision QueryBatchSoundness.polynomial BatchingRefinement.errorPolynomial + BatchingRefinement.oodError BatchingRefinement.queryError + rw [get_set, list, boundary, oracle, answers, folds, points] + +open Classical in +theorem collisionEvent_fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun draw : Sample (.query (initialLevel p)) => + CollisionEvent p lanes root claims strategy (set (.query (initialLevel p)) t draw)) ≤ + (2 ^ 32 : ℚ) * ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2 ^ 192) := by + simp_rw [collisionEvent_set] + let event := fun draw : Sample (.query (initialLevel p)) => + Collision (remaining (config p) 0) (config p).rates[0]! (config p).queries[0]! 0 + (levelAt (Input p lanes root claims) strategy t 0).oracle + (challenges (config p) t).levels[0]! + (proof (Input p lanes root claims) strategy t).levels[0]! + (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state + (followingCandidates (Input p lanes root claims) strategy t 0) draw.1 draw.2 + change Soundness.uniformProb (Finset.univ.filter event) ≤ _ + have average := RingMapBatching.uniform_product event + have cap : ((followingCandidates (Input p lanes root claims) strategy t 0).card : ℚ) ≤ 2 ^ 32 := by + exact_mod_cast CausalBoundary.followingCandidates_card (Input p lanes root claims) strategy t p rfl (initialLevel p) + have each (query : LevelBoundary.QueryTape (remaining (config p) 0 + (config p).rates[0]!) + (config p).queries[0]!) : + Soundness.uniformProb (Finset.univ.filter fun lambda => event (query, lambda)) ≤ + (2 ^ 32 : ℚ) * ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2 ^ 192) := by + have bound := collision_probability (remaining (config p) 0) (config p).rates[0]! + (config p).queries[0]! 0 (levelAt (Input p lanes root claims) strategy t 0).oracle + (challenges (config p) t).levels[0]! (proof (Input p lanes root claims) strategy t).levels[0]! + (CausalBoundary.boundary (Input p lanes root claims) strategy t (initialLevel p)).state + (followingCandidates (Input p lanes root claims) strategy t 0) query + rw [CausalBoundary.decoded_oods_size (Input p lanes root claims) strategy t (initialLevel p)] at bound + exact bound.trans (mul_le_mul_of_nonneg_right cap (by positivity)) + rw [average] + apply (div_le_iff₀ (by positivity : (0 : ℚ) < + Fintype.card (Fin (queryChunks (config p) (initialLevel p).val) → E))).mpr + calc + _ ≤ ∑ _query, ((2 ^ 32 : ℚ) * + ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2 ^ 192)) := + Finset.sum_le_sum (by intro query _; exact each query) + _ = _ := by simp only [Finset.sum_const, Finset.card_univ, nsmul_eq_mul]; ring + +open Classical in +theorem collisionEvent_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) : + Soundness.uniformProb (Finset.univ.filter (CollisionEvent p lanes root claims strategy)) ≤ + (2 ^ 32 : ℚ) * ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2 ^ 192) := by + apply fiber_event_bound (.query (initialLevel p)) + intro rest + exact collisionEvent_fiber_bound p lanes root claims strategy rest.val + +noncomputable def KnowledgeBad (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) : Prop := + (∃ q, CausalBadEvents.Bad (Input p lanes root claims) strategy q t) ∨ + InitialFoldBad p lanes root claims strategy t ∨ + CancellationEvent p lanes root claims t ∨ CollisionEvent p lanes root claims strategy t + +/-- Exact production ledger, retaining the real initial query/OOD batch width. -/ +def knowledgeLedger (p : Profile) (claims : Nat) : ℚ := + GroupedChallenges.interactiveError (config p) (estimates (config p)) claims + + 6 * ((2 ^ 108 : ℚ) / 2 ^ 192 + 2 ^ 33 / 2 ^ 192) + + (2 ^ 32 : ℚ) * blockLength (config p) * (6 / 2 ^ 192) + + (2 ^ 32 : ℚ) * ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2 ^ 192) + +open Classical in +theorem knowledgeBad_probability (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) : + Soundness.uniformProb (Finset.univ.filter (KnowledgeBad p lanes root claims strategy)) ≤ + knowledgeLedger p claims.size := by + have tail := uniform_or_bound (CancellationEvent p lanes root claims) + (CollisionEvent p lanes root claims strategy) + ((2 ^ 32 : ℚ) * blockLength (config p) * (6 / 2 ^ 192)) + ((2 ^ 32 : ℚ) * ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2 ^ 192)) + (cancellation_probability p lanes root claims) + (collisionEvent_probability p lanes root claims strategy) + have folds := uniform_or_bound (InitialFoldBad p lanes root claims strategy) + (fun t => CancellationEvent p lanes root claims t ∨ CollisionEvent p lanes root claims strategy t) + (6 * ((2 ^ 108 : ℚ) / 2 ^ 192 + 2 ^ 33 / 2 ^ 192)) _ + (initialFoldBad_probability p lanes root claims strategy) tail + have all := uniform_or_family_bound (KnowledgeBad p lanes root claims strategy) + (fun _ : Unit => fun t : Tape (config p) => + ∃ q, CausalBadEvents.Bad (Input p lanes root claims) strategy q t) + (fun _ : Unit => fun t => InitialFoldBad p lanes root claims strategy t ∨ + CancellationEvent p lanes root claims t ∨ CollisionEvent p lanes root claims strategy t) + (by intro t; simp only [KnowledgeBad, exists_const]) + (GroupedChallenges.interactiveError (config p) (estimates (config p)) claims.size) _ + (fun _ => CausalBadEvents.bad_probability p lanes root claims strategy laneBound shape) + (fun _ => folds) + simpa only [Fintype.card_unique, Nat.cast_one, one_mul, knowledgeLedger, add_assoc, + Nat.cast_ofNat, Nat.cast_pow] using all + +/-- Kernel-checked arithmetic for every actual supported configuration. -/ +theorem production_extra_ledger : ∀ p : Profile, + 6 * ((2 ^ 108 : ℚ) / 2 ^ 192 + 2 ^ 33 / 2 ^ 192) + + (2 ^ 32 : ℚ) * blockLength (config p) * (6 / 2 ^ 192) + + (2 ^ 32 : ℚ) * ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2 ^ 192) ≤ + (1 / 2 ^ 80 : ℚ) := by + decide +kernel + +/-- Conservative derived event budget, distinct from the success cutoff and +from any whole-system cryptographic security claim. The public source claims +may number up to the existing actual source cap 2^64. -/ +theorem production_knowledgeLedger (p : Profile) (claims : Nat) (cap : claims ≤ 2 ^ 64) : + knowledgeLedger p claims ≤ (1 / 2 ^ 72 : ℚ) := by + have main := production_interactive p claims cap + have extra := production_extra_ledger p + unfold knowledgeLedger + have total := add_le_add main extra + have arithmetic : (1 / 2 ^ 73 : ℚ) + 1 / 2 ^ 80 ≤ 1 / 2 ^ 72 := by norm_num + calc + _ ≤ (1 / 2 ^ 73 : ℚ) + 1 / 2 ^ 80 := by + simpa only [add_assoc, Nat.cast_ofNat, Nat.cast_pow] using total + _ ≤ _ := arithmetic + +open Classical in +theorem production_knowledgeBad (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) + (cap : claims.size ≤ 2 ^ 64) : + Soundness.uniformProb (Finset.univ.filter (KnowledgeBad p lanes root claims strategy)) ≤ + (1 / 2 ^ 72 : ℚ) := + (knowledgeBad_probability p lanes root claims strategy laneBound shape).trans + (production_knowledgeLedger p claims.size cap) + +noncomputable def PriorGood (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) : Prop := + (∀ j : Fin (config p).folds[0]!, + ¬ RawMCA (Input p lanes root claims) strategy (initialLevel p) j t ∧ + ¬ ClaimEscape (Input p lanes root claims) strategy (initialLevel p) j t) ∧ + t.1 ∉ InitialBatching.candidateEscape + (InitialCandidates.extensionCandidates (config p) lanes root) claims ∧ + ¬ CancellationEvent p lanes root claims t + +theorem priorGood_of_not_bad (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (safe : ¬ KnowledgeBad p lanes root claims strategy t) : + PriorGood p lanes root claims strategy t := by + refine ⟨?_, ?_, ?_⟩ + · intro j + constructor + · intro bad + apply safe + apply Or.inr + apply Or.inl + refine ⟨j, Or.inl ?_⟩ + simpa only [initialLevel] using bad + · intro bad + apply safe + apply Or.inr + apply Or.inl + refine ⟨j, Or.inr ?_⟩ + simpa only [initialLevel] using bad + · intro bad + exact safe (Or.inl ⟨.initial, bad⟩) + · intro bad + exact safe (Or.inr (Or.inr (Or.inl bad))) + +theorem priorGood_set (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (q : Coordinate (config p)) (x : Sample q) + (later : position (.query (initialLevel p)) ≤ position q) : + PriorGood p lanes root claims strategy (set q t x) ↔ PriorGood p lanes root claims strategy t := by + have cut := CausalPositions.position_query (initialLevel p) t + have first : (set q t x).1 = t.1 := by + change get .initial (set q t x) = get .initial t + apply get_set_ne q .initial t x + intro same + subst q + change position (.query (initialLevel p)) ≤ 0 at later + rw [cut] at later + change levelStart (challenges (config p) t) 0 + + (config p).folds[0]! + oodCount (config p) 0 ≤ 0 at later + have positive := CausalStateCausality.levelStart_pos (challenges (config p) t) 0 + omega + have seeds : ((set q t x).2.1 (initialLevel p)).1 = (t.2.1 (initialLevel p)).1 := by + funext j + change get (.fold (initialLevel p) j) (set q t x) = get (.fold (initialLevel p) j) t + apply get_set_ne q (.fold (initialLevel p) j) t x + intro same + have hp := congrArg position same + rw [CausalPositions.position_fold (initialLevel p) j t] at hp + omega + unfold PriorGood CancellationEvent + rw [first, seeds] + apply and_congr_left + intro _ + apply forall_congr' + intro j + have foldPosition := CausalPositions.position_fold (initialLevel p) j t + exact and_congr + (not_congr (knowledgeEvents_set_future (Input p lanes root claims) strategy t + (initialLevel p) j q x (by + change levelStart (challenges (config p) t) (initialLevel p).val+j.val+1 ≤ position q + omega)).1) + (not_congr (knowledgeEvents_set_future (Input p lanes root claims) strategy t + (initialLevel p) j q x (by + change levelStart (challenges (config p) t) (initialLevel p).val+j.val+1 ≤ position q + omega)).2) + +theorem priorGood_resetCoordinates (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (base fresh : Tape (config p)) + (qs : List (Coordinate (config p))) : + PriorGood p lanes root claims strategy + (AuthenticatedResetSupport.resetCoordinates (position (.query (initialLevel p))) fresh qs base) ↔ + PriorGood p lanes root claims strategy base := by + induction qs generalizing base with + | nil => rfl + | cons q qs ih => + unfold AuthenticatedResetSupport.resetCoordinates + rw [ih] + split_ifs with later + · exact priorGood_set p lanes root claims strategy base q (get q fresh) later + · rfl + +theorem priorGood_fullResetTape (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (base : Tape (config p)) + (depth : Nat) (chunks) (query) (suffix) : + PriorGood p lanes root claims strategy + (AuthenticatedResetSupport.fullResetTape (Input p lanes root claims) base + (initialLevel p) depth chunks query suffix) ↔ PriorGood p lanes root claims strategy base := by + unfold AuthenticatedResetSupport.fullResetTape + rw [priorGood_set p lanes root claims strategy _ (.query (initialLevel p)) _ le_rfl] + exact priorGood_resetCoordinates p lanes root claims strategy base suffix.2 _ + +#print axioms knowledgeBad_probability +#print axioms production_knowledgeLedger + +end Whir.SupportedCandidateProtocol diff --git a/verification/whir/Whir/SupportedCandidateProtocolRows.lean b/verification/whir/Whir/SupportedCandidateProtocolRows.lean new file mode 100644 index 000000000..1c0ddf51c --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateProtocolRows.lean @@ -0,0 +1,180 @@ +import Whir.SupportedCandidateProtocol + +/-! Dense source encoding commutes with the actual chronological Root0 +coefficient folds. This supplies the scalar equality used by row cancellation. -/ +namespace Whir.SupportedCandidateProtocol +open Concrete Protocol CandidateFolding SupportedCandidateExtraction +open scoped BigOperators +set_option maxRecDepth 100000 +set_option maxHeartbeats 400000 +attribute [local irreducible] ParameterBounds.config + +noncomputable def column {k N : Nat} (enc : (Fin k → E) →ₗ[E] (Fin N → E)) + (lanes : Nat) (a : Array E) (q : Fin N) : Array E := + Array.ofFn fun lane : Fin lanes => enc (unpack true lanes k a lane) q + +theorem column_fold {k N lanes : Nat} (enc : (Fin k → E) →ₗ[E] (Fin N → E)) + (a : Array E) (shape : a.size = (lanes*2)*k) (q : Fin N) (r : E) : + column enc lanes (foldValues a k r) q = foldLow (column enc (lanes*2) a q) r := by + let table := unpack true (lanes*2) k a + have packed : pack true table = a := pack_unpack true a shape + change column enc lanes (foldValues a (foldBlock true k) r) q = _ + rw [← packed, ← pack_fold true table r] + simp only [column, unpack_pack] + rw [← foldOracle_column (fun lane q => enc (table lane) q) r q] + apply congrArg Array.ofFn + funext lane + have linear := congrFun (encode_foldTable enc table r lane) q + exact linear + +private def foldList (k : Nat) (points : List E) (a : Array E) : Array E := + points.foldl (fun a r => foldValues a k r) a + +private theorem foldList_size (k : Nat) (points : List E) (a : Array E) + (shape : a.size = 2 ^ points.length * k) : (foldList k points a).size = k := by + induction points generalizing a with + | nil => simpa only [foldList, List.foldl_nil, List.length_nil, pow_zero, one_mul] using shape + | cons r points ih => + apply ih + change (foldValues a k r).size = 2 ^ points.length * k + rw [ReplayRefinement.foldValues_eq_lane, ArrayLayout.size_foldLane, shape] + simp only [List.length_cons, pow_succ] + rw [Nat.mul_right_comm, Nat.mul_div_left _ (by decide : 0 < 2)] + +private theorem column_foldList {k N : Nat} (enc : (Fin k → E) →ₗ[E] (Fin N → E)) + (points : List E) (a : Array E) (shape : a.size = 2 ^ points.length * k) (q : Fin N) : + column enc 1 (foldList k points a) q = + #[Concrete.mle (column enc (2 ^ points.length) a q) points.toArray] := by + induction points generalizing a with + | nil => + change column enc 1 a q = #[Concrete.mle (column enc 1 a q) #[]] + rw [TerminalRefinement.mle_empty _ (by simp [column])] + apply Array.ext + · simp [column] + · intro j hj hj' + have zero : j = 0 := by simpa [column] using hj + subst j + simp [column] + | cons r points ih => + have nextShape : (foldValues a k r).size = 2 ^ points.length * k := by + rw [ReplayRefinement.foldValues_eq_lane, ArrayLayout.size_foldLane, shape] + simp only [List.length_cons, pow_succ] + rw [Nat.mul_right_comm, Nat.mul_div_left _ (by decide : 0 < 2)] + change column enc 1 (foldList k points (foldValues a k r)) q = _ + rw [ih _ nextShape] + have nextColumn := column_fold (lanes := 2 ^ points.length) enc a + (by simpa [List.length_cons, pow_succ] using shape) q r + have mle := @TerminalRefinement.mle_cons E FieldModel.instCommRingE inferInstance + (column enc (2 ^ (points.length+1)) a q) + points.toArray r (by simp [column]) + rw [nextColumn, List.length_cons, pow_succ, List.toArray_cons] + rw [pow_succ] at mle + rw [← List.toArray_cons r points] at mle + exact congrArg (fun x : E => #[x]) mle.symm + +/-- Real executable dense encoding at one coordinate after all lane folds. -/ +theorem encoded_foldList (n rate : Nat) (points : Array E) (a : Array E) + (shape : a.size = 2 ^ points.size * 2 ^ n) + (q : Fin (2 ^ (n+rate))) : + (encode n rate (points.foldl (fun a r => foldValues a (2 ^ n) r) a))[q.val]! = + Concrete.mle (column (concreteEncoder n rate) (2 ^ points.size) a q) points := by + have cols := column_foldList (concreteEncoder n rate) points.toList a (by simpa using shape) q + have size := foldList_size (2 ^ n) points.toList a (by simpa using shape) + have entry := congrArg (fun row : Array E => row[0]!) cols + have unpacked : unpack true 1 (2 ^ n) (foldList (2 ^ n) points.toList a) 0 = + fun j => (foldList (2 ^ n) points.toList a)[j.val]! := by + funext j + simp [unpack, topIndex] + have linear := ConcreteCandidates.concreteEncoder_ofFn n rate + (unpack true 1 (2 ^ n) (foldList (2 ^ n) points.toList a) 0) q + have coeffs : Array.ofFn (fun j : Fin (2 ^ n) => (foldList (2 ^ n) points.toList a)[j.val]!) = + foldList (2 ^ n) points.toList a := by + apply Array.ext + · simpa using size.symm + · intro j hj hj' + simp [getElem!_pos, hj'] + rw [unpacked] at linear + simp [column] at entry + rw [unpacked, linear, coeffs] at entry + simpa only [foldList, Array.foldl_toList, Array.toArray_toList, Array.length_toList, column] using entry + +open CausalGame CausalExecution CausalProbability ExecutionShapes ParameterBounds InitialKnowledgeSchedule + +theorem foldFrom_initial (input : Public) (t : Tape input.config) + (hasLevel : 0 < input.config.folds.size) (a : Array E) : + foldFrom input t 0 0 input.config.folds[0]! a = + (challenges input.config t).levels[0]!.folds.foldl + (fun a r => foldValues a (width input.config) r) a := by + have count := CausalStateCausality.challenge_folds_size input.config t ⟨0, hasLevel⟩ + have mapped : (List.range input.config.folds[0]!).map + (fun j => (challenges input.config t).levels[0]!.folds[j]!) = + (challenges input.config t).levels[0]!.folds.toList := by + apply List.ext_getElem + · simp [count] + · intro j hj hj' + simp only [List.getElem_map, List.getElem_range, Array.getElem_toList] + rw [getElem!_pos _ _ (by simpa [count] using hj')] + unfold foldFrom + simp only [Nat.zero_add, block, beq_self_eq_true, ↓reduceIte] + rw [← List.foldl_map, mapped, Array.foldl_toList] + +theorem witness_folded_encode (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (t : Tape (config p)) (w : Witness (config p) lanes) + (q : Fin (blockLength (config p))) : + (encode ((config p).logN-(config p).folds[0]!) (config p).rates[0]! + (foldFrom (Input p lanes root claims) t 0 0 (config p).folds[0]! + (paddedWitness (config p) lanes w)))[q.val]! = + Concrete.mle (witnessRow (Input p lanes root claims) w q) + (challenges (config p) t).levels[0]!.folds := by + rw [foldFrom_initial _ _ (production_config_valid p).2.1] + have shape : (paddedWitness (config p) lanes w).size = + 2 ^ (challenges (config p) t).levels[0]!.folds.size * + 2 ^ ((config p).logN-(config p).folds[0]!) := by + rw [CausalStateCausality.challenge_folds_size (config p) t (initialLevel p)] + simp only [paddedWitness, ArrayLayout.size_tab, ← Nat.pow_add, + Nat.add_sub_of_le (InitialCandidates.production_initial_facts p).2.1] + rw [encoded_foldList _ _ _ _ shape] + congr 1 + rw [CausalStateCausality.challenge_folds_size (config p) t (initialLevel p)] + unfold column witnessRow + apply congrArg Array.ofFn + funext lane + exact ConcreteCandidates.concreteEncoder_ofFn _ _ _ q + +theorem committed_folded_word (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (t : Tape (config p)) + (valid : oracleValid (liftRoot root) (length (config p) 0) lanes = true) + (laneBound : lanes ≤ 2 ^ (config p).folds[0]!) + (q : Fin (blockLength (config p))) : + Concrete.mle (committedRow (Input p lanes root claims) q) + (challenges (config p) t).levels[0]!.folds = + QueryBatchSoundness.oldWord ((config p).logN-(config p).folds[0]!) (config p).rates[0]! + (liftRoot root) true (challenges (config p) t).levels[0]!.folds q := by + have dims := (InitialCandidates.production_initial_facts p).1 + have qs : q.val < length (config p) 0 := by simpa only [length, dims] using q.isLt + have live := OracleReplay.oracleValid_row _ _ _ valid q.val qs + have rs : q.val < root.size := by + have shape := valid + simp only [oracleValid, Bool.and_eq_true, beq_iff_eq, liftRoot, Array.size_map] at shape + exact qs.trans_eq shape.1.symm + have rootShape : root[q.val]!.size = lanes := by + simpa [liftRoot, getElem!_pos, rs] using live + have row : committedRow (Input p lanes root claims) q = + OracleReplay.ascendingRow true (config p).folds[0]! (liftRoot root)[q.val]! := by + apply Array.ext + · simp [committedRow] + · intro j hj hj' + have lane : j < laneCount (config p) := by simpa [committedRow] using hj + have entry := OracleReplay.initial_fullRow (config p) lanes root + (challenges (config p) t).levels[0]!.folds q rs rootShape ⟨j, lane⟩ + simpa [committedRow, OracleReplay.oracleAt, getElem!_pos, lane] using entry.symm + rw [row] + unfold Concrete.mle QueryBatchSoundness.oldWord + apply OracleReplay.ascendingRow_dot true (config p).folds[0]! _ + · exact live.le.trans laneBound + · simp [CausalStateCausality.challenge_folds_size (config p) t (initialLevel p)] + +#print axioms witness_folded_encode +#print axioms committed_folded_word + +end Whir.SupportedCandidateProtocol diff --git a/verification/whir/Whir/SupportedCandidateRecovery.lean b/verification/whir/Whir/SupportedCandidateRecovery.lean new file mode 100644 index 000000000..7f00f4816 --- /dev/null +++ b/verification/whir/Whir/SupportedCandidateRecovery.lean @@ -0,0 +1,247 @@ +import Whir.PCSRewindExtractor +import Whir.UniqueRadiusSampling + +/-! Deterministic recovery from authenticated heavy coordinates. All records are +retained, including accepted records outside the heavy agreement set. Such +coordinates may be erroneous; the radius charges their entire complement. -/ +namespace Whir.SupportedCandidateRecovery +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open PCSRewindExtractor + +set_option maxHeartbeats 2000000 + +/-- The occupied lane in the padded table is exactly the Gao decoder's input +coefficient ordering; there is no reversal or extension projection shortcut. -/ +theorem encodedLane_witness (input : Public) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (w : Witness input.config input.lanes) (lane : Fin input.lanes) : + (encodedLanes input.config (paddedWitness input.config input.lanes w))[lane.val]! = + encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK) := by + have live : lane.val < laneCount input.config := lane.isLt.trans_le laneBound + simp only [encodedLanes, getElem!_pos, Array.size_ofFn, live, Array.getElem_ofFn] + congr 1 + apply Array.ext + · simp [PCSRewindExtraction.witnessLane, PCSRewindExtraction.rowWidth] + · intro j hj hk + have jBound : j < width input.config := by simpa using hj + have occupied : lane.val * width input.config + j < input.lanes * width input.config := + (Nat.add_lt_add_left jBound _).trans_le (by + rw [← Nat.succ_mul] + exact Nat.mul_le_mul_right _ lane.isLt) + have full : lane.val * width input.config + j < 2 ^ input.config.logN := by + have bound := Nat.mul_le_mul_right (width input.config) laneBound + have size : laneCount input.config * width input.config = 2 ^ input.config.logN := by + rw [← Nat.pow_add, Nat.add_sub_of_le foldBound] + exact occupied.trans_le (size ▸ bound) + simp only [Array.getElem_ofFn, Array.getElem_map, + PCSRewindExtraction.witnessLane, PCSRewindExtraction.rowWidth] + change (paddedWitness input.config input.lanes w)[j + width input.config * lane.val]! = + E.ofK (w ⟨lane.val * width input.config + j, occupied⟩) + have index : j + width input.config * lane.val = lane.val * width input.config + j := by + rw [Nat.mul_comm]; omega + rw [index] + unfold paddedWitness + rw [ArrayLayout.getElem!_tab _ _ _ full] + simp [occupied] + +/-- A full common-coordinate check entails agreement for each live Gao lane. -/ +theorem live_agrees_of_rowMatches (input : Public) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (w : Witness input.config input.lanes) (q : Fin (blockLength input.config)) + (matched : rowMatches input.config input.lanes + (encodedLanes input.config (paddedWitness input.config input.lanes w)) + (q, input.root[q.val]!) = true) (lane : Fin input.lanes) : + E.ofK (recordLane input.lanes input.root[q.val]! lane.val) = + (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]! := by + have all : (List.finRange (laneCount input.config)).all (fun l => + ((encodedLanes input.config (paddedWitness input.config input.lanes w))[l.val]!)[q.val]! == + E.ofK (recordLane input.lanes input.root[q.val]! l.val)) = true := by + have guard := matched + simp only [rowMatches, Bool.and_eq_true] at guard + exact guard.2 + have equal := beq_iff_eq.mp (List.all_eq_true.mp all + ⟨lane.val, lane.isLt.trans_le laneBound⟩ (List.mem_finRange _)) + rw [encodedLane_witness input foldBound laneBound w lane] at equal + exact equal.symm + +/-- A covered authenticated coordinate is read from the actual record lookup. -/ +theorem receivedLane_at_covered (input : Public) (records : List (Record input.config)) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (q : Fin (blockLength input.config)) + (covered : ∃ record ∈ records, record.1 = q) (lane : Fin input.lanes) : + receivedLane input records lane q = E.ofK (recordLane input.lanes input.root[q.val]! lane.val) := by + have found := RewindRowExtraction.lookup_authenticated records + (fun q => input.root[q.val]!) authenticated q covered + simp [receivedLane, receivedLaneCached, filledRecords, getElem!_pos, q.isLt, found] + +/-- Missing observations are explicitly zero-filled, not obtained from a +root preimage or from an out-of-bounds access to a fabricated empty leaf. -/ +theorem receivedLane_at_missing (input : Public) (records : List (Record input.config)) + (q : Fin (blockLength input.config)) (missing : RewindRowExtraction.lookup records q = none) + (lane : Fin input.lanes) : receivedLane input records lane q = 0 := by + simp [receivedLane, receivedLaneCached, filledRecords, getElem!_pos, q.isLt, missing] + +/-- No honesty is claimed away from H, even for other authenticated records. -/ +theorem receivedLane_distance (input : Public) (records : List (Record input.config)) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (H : Finset (Fin (blockLength input.config))) + (covered : ∀ q ∈ H, ∃ record ∈ records, record.1 = q) + (w : Witness input.config input.lanes) + (agrees : ∀ q ∈ H, ∀ lane : Fin input.lanes, + E.ofK (recordLane input.lanes input.root[q.val]! lane.val) = + (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]!) + (lane : Fin input.lanes) : + hammingDist (receivedLane input records lane) + (fun q => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]!) ≤ + blockLength input.config - H.card := by + classical + let target := fun q : Fin (blockLength input.config) => + (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]! + have subset : H ⊆ UniqueRadiusSampling.agreement + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (receivedLane input records lane) target := by + intro q member + simp only [UniqueRadiusSampling.agreement, Finset.mem_filter, Finset.mem_univ, true_and] + exact (receivedLane_at_covered input records authenticated q (covered q member) lane).trans + (agrees q member lane) + have card := Finset.card_le_card subset + have partition := UniqueRadiusSampling.agreement_add_distance + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) + (receivedLane input records lane) target + change hammingDist (receivedLane input records lane) target ≤ + blockLength input.config - H.card + change _ + hammingDist (receivedLane input records lane) target = + blockLength input.config at partition + omega + +private theorem hammingDist_index_cast {M N : Nat} (same : M = N) (received target : Fin N → E) : + hammingDist (fun q => received (Fin.cast same q)) (fun q => target (Fin.cast same q)) = + hammingDist received target := by + subst N + rfl + +/-- Actual authenticated records covering a common agreement set inside the Gao +radius recover every live lane. No fixed-target proximity is assumed. -/ +theorem decodeRecords_of_heavy (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (redundancy : width input.config < blockLength input.config) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (H : Finset (Fin (blockLength input.config))) + (covered : ∀ q ∈ H, ∃ record ∈ records, record.1 = q) + (enough : 2 * (blockLength input.config - H.card) ≤ blockLength input.config - width input.config) + (w : Witness input.config input.lanes) + (agrees : ∀ q ∈ H, ∀ lane : Fin input.lanes, + E.ofK (recordLane input.lanes input.root[q.val]! lane.val) = + (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]!) : + (decodeRecords input records noWrap).1 = some w := by + apply decodeRecords_recovers input records noWrap redundancy w + intro lane + have distance := receivedLane_distance input records authenticated H covered w agrees lane + have size : (ConcreteRowExtraction.domain + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) noWrap).n = + blockLength input.config := ConcreteRowExtraction.domain_size _ _ + have receivedEqual : (Vector.mk (Array.ofFn (receivedLane input records lane)) (by simp) : + Vector E (ConcreteRowExtraction.domain + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) noWrap).n).get = + fun q => receivedLane input records lane (Fin.cast size q) := by + funext q + simp [Vector.get, Fin.cast] + rw [receivedEqual] + change 2 * hammingDist (fun q => receivedLane input records lane (Fin.cast size q)) + (fun q => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[(Fin.cast size q).val]!) ≤ _ + rw [hammingDist_index_cast size (receivedLane input records lane) + (fun q => (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]!)] + exact (Nat.mul_le_mul_left 2 distance).trans enough + +/-- Coverage supplies the deduplicated common-coordinate certificate used by +finish, not merely independent per-lane agreement sets. -/ +theorem commonCoordinates_of_heavy (input : Public) (records : List (Record input.config)) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (H : Finset (Fin (blockLength input.config))) + (covered : ∀ q ∈ H, ∃ record ∈ records, record.1 = q) + (candidate : Array E) + (matching : ∀ q ∈ H, rowMatches input.config input.lanes + (encodedLanes input.config candidate) (q, input.root[q.val]!) = true) : + H ⊆ commonCoordinates input.config input.lanes candidate records := by + intro q member + obtain ⟨record, recorded, coordinate⟩ := covered q member + have value := authenticated record recorded + have matched : rowMatches input.config input.lanes (encodedLanes input.config candidate) record = true := by + rcases record with ⟨position, row⟩ + dsimp only at coordinate value + subst position + simpa only [value] using matching q member + exact List.mem_toFinset.mpr (List.mem_map.mpr + ⟨record, List.mem_filter.mpr ⟨recorded, matched⟩, coordinate⟩) + +/-- Every original claim is checked after recovering the same witness. -/ +theorem decodeAndCheck_of_heavy (input : Public) (records : List (Record input.config)) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (foldBound : input.config.folds[0]! ≤ input.config.logN) + (laneBound : input.lanes ≤ laneCount input.config) + (redundancy : width input.config < blockLength input.config) + (authenticated : ∀ record ∈ records, record.2 = input.root[record.1.val]!) + (H : Finset (Fin (blockLength input.config))) + (covered : ∀ q ∈ H, ∃ record ∈ records, record.1 = q) + (radiusSize : 2 * (blockLength input.config - H.card) ≤ blockLength input.config - width input.config) + (certificateSize : ParameterBounds.threshold input.config 0 ≤ H.card) + (w : Witness input.config input.lanes) + (agrees : ∀ q ∈ H, ∀ lane : Fin input.lanes, + E.ofK (recordLane input.lanes input.root[q.val]! lane.val) = + (encode (input.config.logN - input.config.folds[0]!) input.config.rates[0]! + ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[q.val]!) + (matching : ∀ q ∈ H, rowMatches input.config input.lanes + (encodedLanes input.config (paddedWitness input.config input.lanes w)) + (q, input.root[q.val]!) = true) + (claims : ∀ claim ∈ input.claims.toList, + dot (paddedWitness input.config input.lanes w) claim.weight = claim.value) : + (decodeAndCheck input records noWrap).1 = some w := by + have recovered := decodeRecords_of_heavy input records noWrap redundancy + authenticated H covered radiusSize w agrees + have support := (Finset.card_le_card + (commonCoordinates_of_heavy input records authenticated H covered _ matching)) + have size : (paddedWitness input.config input.lanes w).size = + laneCount input.config * width input.config := by + simp only [paddedWitness, tab, Array.size_map, List.size_toArray, List.length_range] + rw [← Nat.pow_add, Nat.add_sub_of_le foldBound] + have checked : verified input (paddedWitness input.config input.lanes w) records = true := by + simp only [verified, Bool.and_eq_true, beq_iff_eq, decide_eq_true_eq] + refine ⟨⟨size, certificateSize.trans support⟩, ?_⟩ + rw [← Array.all_toList] + exact List.all_eq_true.mpr (fun claim member => beq_iff_eq.mpr (claims claim member)) + have projected : InitialCandidates.project input.config input.lanes + (paddedWitness input.config input.lanes w) = w := by + funext i + have limit : i.val < 2 ^ input.config.logN := by + have occupied := Nat.mul_le_mul_right (width input.config) laneBound + rw [← size] at occupied + simp only [paddedWitness, tab, Array.size_map, List.size_toArray, List.length_range] at occupied + exact i.isLt.trans_le occupied + simp [InitialCandidates.project, paddedWitness, tab, getElem!_pos, limit, i.isLt, E.ofK] + simp only [decodeAndCheck, recovered, Option.bind_some, finish, ite_eq_left checked, projected] + +/-- Zero-filled missing observations cannot substitute for a certificate. +In particular a withholding/rejected collector with no records cannot finish. -/ +theorem decodeAndCheck_empty (input : Public) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) + (thresholdPositive : 0 < ParameterBounds.threshold input.config 0) : + (decodeAndCheck input [] noWrap).1 = none := by + simp only [decodeAndCheck] + cases result : (decodeRecords input [] noWrap).1 with + | none => rfl + | some w => + simp [finish, verified, commonCoordinates, not_le.mpr thresholdPositive] + +#print axioms decodeRecords_of_heavy +#print axioms commonCoordinates_of_heavy +end Whir.SupportedCandidateRecovery diff --git a/verification/whir/Whir/TriangularExtraction.lean b/verification/whir/Whir/TriangularExtraction.lean new file mode 100644 index 000000000..16d78ec18 --- /dev/null +++ b/verification/whir/Whir/TriangularExtraction.lean @@ -0,0 +1,455 @@ +import Whir.ReedSolomonExtraction +import CompPoly.Univariate.ToPoly.Degree + +/-! Executable coefficient recovery in a supplied triangular polynomial basis. +This avoids a classical inverse of the novel-basis linear equivalence. +`countedPeel` bounds peeling with a supplied basis; `countedPreparedPeel` +additionally executes and charges all recursive novel-basis, subspace, +evaluation and normalization preparation at each peeling step. Both have +checked value correspondence to the original implementation. Inverses have +an explicit implementation charge. Comparisons, allocation and copying are +separate from field arithmetic; this is not a machine-time certificate. -/ +namespace Whir.TriangularExtraction +open CompPoly +open scoped BigOperators + +variable {F : Type*} [Field F] [BEq F] [LawfulBEq F] [DecidableEq F] +omit [DecidableEq F] + +/-- Strip the highest coefficient first. Output is descending; a single final reversal puts it in coefficient order. -/ +def peel (basis : Nat → CPolynomial F) : Nat → CPolynomial F → List F + | 0, _ => [] + | n + 1, p => + let currentBasis := basis n + let coefficient := p.coeff n / currentBasis.coeff n + coefficient :: peel basis n (p - CPolynomial.C coefficient * currentBasis) + +def recover (basis : Nat → CPolynomial F) (size : Nat) (p : CPolynomial F) : Array F := + (peel basis size p).reverse.toArray + +omit [DecidableEq F] in +/-- The basis hypotheses are algebraic triangularity, not an assumption that the decoder succeeds. -/ +theorem peel_recovers (basis : Nat → CPolynomial F) (size : Nat) (a : Nat → F) + (triangular : ∀ i j, i < size → i < j → (basis i).coeff j = 0) + (diagonal : ∀ i < size, (basis i).coeff i ≠ 0) : + peel basis size (∑ i ∈ Finset.range size, CPolynomial.C (a i) * basis i) = + (List.range size).reverse.map a := by + induction size with + | zero => simp [peel] + | succ n ih => + have lowerCoefficient : + (∑ i ∈ Finset.range n, CPolynomial.C (a i) * basis i).coeff n = 0 := by + rw [CPolynomial.coeff_finset_sum] + apply Finset.sum_eq_zero + intro i hi + have lower := Finset.mem_range.mp hi + rw [CPolynomial.coeff_C_mul, triangular i n (by omega) lower, mul_zero] + have topCoefficient : + (∑ i ∈ Finset.range (n + 1), CPolynomial.C (a i) * basis i).coeff n / + (basis n).coeff n = a n := by + rw [Finset.sum_range_succ, CPolynomial.coeff_add, lowerCoefficient, + CPolynomial.coeff_C_mul, zero_add] + exact mul_div_cancel_right₀ (a n) (diagonal n (by omega)) + rw [peel] + rw [topCoefficient, Finset.sum_range_succ, add_sub_cancel_right] + rw [ih (fun i j hi hij => triangular i j (by omega) hij) + (fun i hi => diagonal i (by omega))] + simp [List.range_succ, List.reverse_append] + +theorem recover_recovers (basis : Nat → CPolynomial F) (size : Nat) (a : Nat → F) + (triangular : ∀ i j, i < size → i < j → (basis i).coeff j = 0) + (diagonal : ∀ i < size, (basis i).coeff i ≠ 0) : + recover basis size (∑ i ∈ Finset.range size, CPolynomial.C (a i) * basis i) = + ((List.range size).map a).toArray := by + simp [recover, peel_recovers basis size a triangular diagonal, List.map_reverse] + +/-- Executable preparation of exactly the additive subspace polynomials used by WHIR. -/ +def subspace (v : Nat → F) : Nat → CPolynomial F + | 0 => CPolynomial.X + | n + 1 => + let previous := subspace v n + previous * (previous + CPolynomial.C (previous.eval (v n))) + +def normalized (v : Nat → F) (n : Nat) : CPolynomial F := + let p := subspace v n + CPolynomial.C (p.eval (v n))⁻¹ * p + +def novel (v : Nat → F) : Nat → Nat → CPolynomial F + | 0, _ => 1 + | n + 1, j => if j < 2 ^ n then novel v n j + else novel v n (j - 2 ^ n) * normalized v n + +omit [DecidableEq F] in +theorem subspace_toPoly (v : Nat → F) (n : Nat) : + (subspace v n).toPoly = AdditiveCode.subspace v n := by + induction n with + | zero => simp [subspace, AdditiveCode.subspace, CPolynomial.X_toPoly] + | succ n ih => + simp [subspace, AdditiveCode.subspace, CPolynomial.toPoly_mul, + CPolynomial.toPoly_add, CPolynomial.C_toPoly, CPolynomial.eval_toPoly, ih] + +theorem normalized_toPoly (v : Nat → F) (n : Nat) : + (normalized v n).toPoly = AdditiveCode.normalized v n := by + simp [normalized, AdditiveCode.normalized, CPolynomial.toPoly_mul, + CPolynomial.C_toPoly, CPolynomial.eval_toPoly, subspace_toPoly] + +theorem novel_toPoly (v : Nat → F) (n j : Nat) : + (novel v n j).toPoly = AdditiveCode.novel v n j := by + induction n generalizing j with + | zero => simp [novel, AdditiveCode.novel, CPolynomial.toPoly_one] + | succ n ih => + simp only [novel, AdditiveCode.novel] + split_ifs <;> simp [CPolynomial.toPoly_mul, normalized_toPoly, ih] + +/-- The implemented triangular inverse recovers novel coefficients. The proof never enumerates field-valued witnesses. -/ +theorem recover_novel [CharP F 2] (v : Nat → F) (n : Nat) + (independent : AdditiveCode.Independent v n) (a : Nat → F) (p : CPolynomial F) + (representation : p.toPoly = ∑ i ∈ Finset.range (2 ^ n), + Polynomial.C (a i) * AdditiveCode.novel v n i) : + recover (novel v n) (2 ^ n) p = ((List.range (2 ^ n)).map a).toArray := by + have equal : p = ∑ i ∈ Finset.range (2 ^ n), CPolynomial.C (a i) * novel v n i := by + apply CPolynomial.eq_iff_coeff.mpr + intro j + rw [CPolynomial.coeff_toPoly, CPolynomial.coeff_toPoly, representation] + apply congrArg (fun q : Polynomial F => q.coeff j) + rw [CPolynomial.toPoly_sum] + apply Finset.sum_congr rfl + intro i hi + rw [CPolynomial.toPoly_mul, CPolynomial.C_toPoly, novel_toPoly] + rw [equal] + apply recover_recovers + · intro i j hi hij + rw [CPolynomial.coeff_toPoly, novel_toPoly] + exact Polynomial.coeff_eq_zero_of_natDegree_lt + ((AdditiveCode.novel_degree independent hi).1.trans_lt hij) + · intro i hi + rw [CPolynomial.coeff_toPoly, novel_toPoly] + have degree := AdditiveCode.novel_degree independent hi + have leading : (AdditiveCode.novel v n i).coeff i = + (AdditiveCode.novel v n i).leadingCoeff := by + simpa only [degree.1] using + (Polynomial.coeff_natDegree (p := AdditiveCode.novel v n i)) + rw [leading] + exact degree.2 + +omit [DecidableEq F] in +private theorem constant_mul_size (a : F) (p : CPolynomial F) (width : Nat) + (support : p.val.size ≤ width) : + (CPolynomial.C a * p).val.size ≤ width := by + apply CPolynomial.mem_degreeLT_iff_size_le.mp + apply CPolynomial.mem_degreeLT.mpr + rw [CPolynomial.degree_lt_iff_coeff_zero] + intro j hj + rw [CPolynomial.coeff_C_mul, + CPolynomial.coeff_eq_zero_of_size_le p (support.trans hj), mul_zero] + +private theorem subtract_size (p q : CPolynomial F) (width : Nat) + (left : p.val.size ≤ width) (right : q.val.size ≤ width) : + (p - q).val.size ≤ width := by + apply CPolynomial.mem_degreeLT_iff_size_le.mp + apply CPolynomial.mem_degreeLT.mpr + rw [CPolynomial.degree_lt_iff_coeff_zero] + intro j hj + rw [CPolynomial.coeff_sub, + CPolynomial.coeff_eq_zero_of_size_le p (left.trans hj), + CPolynomial.coeff_eq_zero_of_size_le q (right.trans hj), sub_self] + +/-- Field-arithmetic instrumentation of actual triangular peeling, including +the naive convolution used even for constant multiplication. `inverseCost` +charges the supplied field implementation; for `E` the ladder costs 382 +multiplications. Prepared basis generation, coefficient lookups, trimming, +allocation and list reversal are not included in this counter. -/ +def countedPeel (inverseCost : Nat) (basis : Nat → CPolynomial F) : + Nat → CPolynomial F → List F × Nat + | 0, _ => ([], 0) + | n + 1, p => + let currentBasis := basis n + let coefficient := p.coeff n / currentBasis.coeff n + let product := ReedSolomonExtraction.countedMul (CPolynomial.C coefficient) currentBasis + let tail := countedPeel inverseCost basis n (p - product.1) + (coefficient :: tail.1, + inverseCost + 1 + product.2 + + product.1.val.size + max p.val.size product.1.val.size + tail.2) + +theorem countedPeel_value (inverseCost : Nat) (basis : Nat → CPolynomial F) + (size : Nat) (p : CPolynomial F) : + (countedPeel inverseCost basis size p).1 = peel basis size p := by + induction size generalizing p with + | zero => rfl + | succ size ih => + simp [countedPeel, peel, ReedSolomonExtraction.countedMul_value, ih] + +/-- A real quadratic coefficient-arithmetic bound for the peeling phase, not +merely a bound on its number of polynomial operations. All intermediate +supports are derived from these initial input and prepared-basis supports. -/ +theorem countedPeel_cost (inverseCost : Nat) (basis : Nat → CPolynomial F) + (size width : Nat) (p : CPolynomial F) + (inputSupport : p.val.size ≤ width) + (basisSupport : ∀ i < size, (basis i).val.size ≤ width) : + (countedPeel inverseCost basis size p).2 ≤ + size * (4 * width + inverseCost + 2) := by + induction size generalizing p with + | zero => simp [countedPeel] + | succ size ih => + let a := p.coeff size / (basis size).coeff size + have basisSize := basisSupport size (by omega) + have constantSize : (CPolynomial.C a).val.size ≤ 1 := by + exact (CPolynomial.Raw.Trim.size_le_size _).trans_eq (by rfl) + have productCost : + (ReedSolomonExtraction.countedMul (CPolynomial.C a) (basis size)).2 ≤ + 1 + 2 * width := by + calc + _ ≤ (CPolynomial.C a).val.size * + ((CPolynomial.C a).val.size + 2 * (basis size).val.size) := + ReedSolomonExtraction.countedRawMul_cost _ _ + _ ≤ 1 * (1 + 2 * width) := + Nat.mul_le_mul constantSize + (Nat.add_le_add constantSize (Nat.mul_le_mul_left 2 basisSize)) + _ = _ := by omega + have productSize : (ReedSolomonExtraction.countedMul + (CPolynomial.C a) (basis size)).1.val.size ≤ width := by + rw [ReedSolomonExtraction.countedMul_value] + exact constant_mul_size a (basis size) width basisSize + have residualSize := subtract_size p + (ReedSolomonExtraction.countedMul (CPolynomial.C a) (basis size)).1 + width inputSupport productSize + have tail := ih (p - (ReedSolomonExtraction.countedMul + (CPolynomial.C a) (basis size)).1) residualSize + (fun i hi => basisSupport i (by omega)) + change inverseCost + 1 + + (ReedSolomonExtraction.countedMul (CPolynomial.C a) (basis size)).2 + + (ReedSolomonExtraction.countedMul (CPolynomial.C a) (basis size)).1.val.size + + max p.val.size + (ReedSolomonExtraction.countedMul (CPolynomial.C a) (basis size)).1.val.size + + (countedPeel inverseCost basis size + (p - (ReedSolomonExtraction.countedMul (CPolynomial.C a) (basis size)).1)).2 ≤ _ + rw [Nat.add_mul] + omega + +open ReedSolomonExtraction + +/-- Preparation costs are executed inside the instrumented novel-basis +constructor; they are not supplied as an external or assumed budget. -/ +def countedSubspace (v : Nat → F) : Nat → CPolynomial F × Nat + | 0 => (CPolynomial.X, 0) + | n + 1 => + let previous := countedSubspace v n + let evaluation := countedEval previous.1 (v n) + let added := countedAdd previous.1 (CPolynomial.C evaluation.1) + let product := countedMul previous.1 added.1 + (product.1, previous.2 + evaluation.2 + added.2 + product.2) + +theorem countedSubspace_value (v : Nat → F) (n : Nat) : + (countedSubspace v n).1 = subspace v n := by + induction n with + | zero => rfl + | succ n ih => + simp [countedSubspace, subspace, countedMul_value, countedAdd, countedEval_value, ih] + +def countedNormalized (inverseCost : Nat) (v : Nat → F) (n : Nat) : CPolynomial F × Nat := + let p := countedSubspace v n + let evaluation := countedEval p.1 (v n) + let product := countedMul (CPolynomial.C evaluation.1⁻¹) p.1 + (product.1, p.2 + evaluation.2 + inverseCost + product.2) + +theorem countedNormalized_value (inverseCost : Nat) (v : Nat → F) (n : Nat) : + (countedNormalized inverseCost v n).1 = normalized v n := by + simp [countedNormalized, normalized, countedMul_value, countedEval_value, countedSubspace_value] + +def countedNovel (inverseCost : Nat) (v : Nat → F) : Nat → Nat → CPolynomial F × Nat + | 0, _ => (1, 0) + | n + 1, j => + if j < 2 ^ n then countedNovel inverseCost v n j else + let previous := countedNovel inverseCost v n (j - 2 ^ n) + let normalized := countedNormalized inverseCost v n + let product := countedMul previous.1 normalized.1 + (product.1, previous.2 + normalized.2 + product.2) + +theorem countedNovel_value (inverseCost : Nat) (v : Nat → F) (n j : Nat) : + (countedNovel inverseCost v n j).1 = novel v n j := by + induction n generalizing j with + | zero => rfl + | succ n ih => + simp only [countedNovel, novel] + split_ifs <;> simp [countedMul_value, countedNormalized_value, ih] + +theorem subspace_support (v : Nat → F) (n : Nat) : + (subspace v n).val.size ≤ 2 ^ (n + 1) := by + induction n with + | zero => exact Nat.le_refl 2 + | succ n ih => + have positive : 1 ≤ 2 ^ (n + 1) := Nat.one_le_pow _ _ (by omega) + have added := (add_support (subspace v n) + (CPolynomial.C ((subspace v n).eval (v n)))).trans + (max_le ih ((constant_support _).trans positive)) + have product := mul_support (subspace v n) + (subspace v n + CPolynomial.C ((subspace v n).eval (v n))) + change _ ≤ 2 ^ (n + 1 + 1) + rw [Nat.pow_succ] + exact product.trans (by omega) + +theorem normalized_support (v : Nat → F) (n : Nat) : + (normalized v n).val.size ≤ 2 ^ (n + 1) := by + exact (constant_mul_support _ _).trans (subspace_support v n) + +theorem novel_support (v : Nat → F) (n j : Nat) : + (novel v n j).val.size ≤ 2 ^ (n + 1) := by + induction n generalizing j with + | zero => exact (Nat.le_refl 1).trans (by norm_num) + | succ n ih => + simp only [novel] + split_ifs + · exact (ih j).trans (Nat.pow_le_pow_right (by omega) (by omega)) + · exact (mul_support _ _).trans (by + have left := ih (j - 2 ^ n) + have right := normalized_support v n + rw [Nat.pow_succ] + omega) + +def preparationUnit (width : Nat) : Nat := 8 * (width + 1) ^ 2 + +theorem countedSubspace_cost (v : Nat → F) (n width : Nat) + (limit : 2 ^ (n + 1) ≤ width) : + (countedSubspace v n).2 ≤ n * preparationUnit width := by + induction n with + | zero => simp [countedSubspace] + | succ n ih => + have lowerLimit : 2 ^ (n + 1) ≤ width := + (Nat.pow_le_pow_right (by omega) (by omega)).trans limit + have previousSupport : (countedSubspace v n).1.val.size ≤ width := by + rw [countedSubspace_value]; exact (subspace_support v n).trans lowerLimit + have positive : 1 ≤ width := (Nat.one_le_pow _ _ (by omega)).trans lowerLimit + have addedSupport : ((countedSubspace v n).1 + + CPolynomial.C ((countedSubspace v n).1.eval (v n))).val.size ≤ width := + (add_support _ _).trans (max_le previousSupport ((constant_support _).trans positive)) + have evaluationCost := countedEval_cost (countedSubspace v n).1 (v n) width previousSupport + have productCost := countedMul_cost (countedSubspace v n).1 + ((countedSubspace v n).1 + CPolynomial.C ((countedSubspace v n).1.eval (v n))) + width previousSupport addedSupport + have previousCost := ih lowerLimit + have addedCost : max (countedSubspace v n).1.val.size + (CPolynomial.C ((countedSubspace v n).1.eval (v n))).val.size ≤ width := + max_le previousSupport ((constant_support _).trans positive) + have step : (countedEval (countedSubspace v n).1 (v n)).2 + + max (countedSubspace v n).1.val.size + (CPolynomial.C ((countedSubspace v n).1.eval (v n))).val.size + + (countedMul (countedSubspace v n).1 + ((countedSubspace v n).1 + CPolynomial.C ((countedSubspace v n).1.eval (v n)))).2 ≤ + preparationUnit width := by + unfold preparationUnit + nlinarith + simp only [countedSubspace, countedAdd, countedEval_value] + rw [Nat.add_mul] + omega + +theorem countedNormalized_cost (inverseCost : Nat) (v : Nat → F) (n width : Nat) + (limit : 2 ^ (n + 1) ≤ width) : + (countedNormalized inverseCost v n).2 ≤ (n + 1) * preparationUnit width + inverseCost := by + have support : (countedSubspace v n).1.val.size ≤ width := by + rw [countedSubspace_value]; exact (subspace_support v n).trans limit + have positive : 1 ≤ width := (Nat.one_le_pow _ _ (by omega)).trans limit + have previous := countedSubspace_cost v n width limit + have evaluation := countedEval_cost (countedSubspace v n).1 (v n) width support + have product := countedMul_cost + (CPolynomial.C ((countedSubspace v n).1.eval (v n))⁻¹) + (countedSubspace v n).1 width ((constant_support _).trans positive) support + have step : (countedEval (countedSubspace v n).1 (v n)).2 + + (countedMul (CPolynomial.C ((countedSubspace v n).1.eval (v n))⁻¹) + (countedSubspace v n).1).2 ≤ preparationUnit width := by + unfold preparationUnit; nlinarith + simp only [countedNormalized, countedEval_value] + rw [Nat.add_mul] + omega + +def novelBudget (inverseCost depth width : Nat) : Nat := + depth * ((depth + 1) * preparationUnit width + 3 * (width + 1) ^ 2 + inverseCost) + +theorem countedNovel_cost (inverseCost : Nat) (v : Nat → F) (n j width : Nat) + (limit : 2 ^ (n + 1) ≤ width) : + (countedNovel inverseCost v n j).2 ≤ novelBudget inverseCost n width := by + induction n generalizing j with + | zero => simp [countedNovel, novelBudget] + | succ n ih => + have lowerLimit : 2 ^ (n + 1) ≤ width := + (Nat.pow_le_pow_right (by omega) (by omega)).trans limit + have previous := ih (j - 2 ^ n) lowerLimit + have normalization := countedNormalized_cost inverseCost v n width lowerLimit + have previousSupport : (countedNovel inverseCost v n (j - 2 ^ n)).1.val.size ≤ width := by + rw [countedNovel_value]; exact (novel_support _ _ _).trans lowerLimit + have normalizedSupport : (countedNormalized inverseCost v n).1.val.size ≤ width := by + rw [countedNormalized_value]; exact (normalized_support _ _).trans lowerLimit + have product := countedMul_cost (countedNovel inverseCost v n (j - 2 ^ n)).1 + (countedNormalized inverseCost v n).1 width previousSupport normalizedSupport + have square : width ^ 2 ≤ (width + 1) ^ 2 := by nlinarith + have positive : 0 ≤ preparationUnit width := Nat.zero_le _ + simp only [countedNovel] + split_ifs + · have smaller := ih j lowerLimit + unfold novelBudget at smaller ⊢ + have budgetMono : (n + 1) * preparationUnit width + 3 * (width + 1) ^ 2 + inverseCost ≤ + (n + 1 + 1) * preparationUnit width + 3 * (width + 1) ^ 2 + inverseCost := by + gcongr; omega + exact smaller.trans (Nat.mul_le_mul (by omega) budgetMono) + · unfold novelBudget at previous ⊢ + have budgetMono : (n + 1) * preparationUnit width + 3 * (width + 1) ^ 2 + inverseCost ≤ + (n + 1 + 1) * preparationUnit width + 3 * (width + 1) ^ 2 + inverseCost := by + gcongr; omega + have previousBudget := previous.trans (Nat.mul_le_mul_left n budgetMono) + rw [Nat.add_mul] + omega + +/-- Prepare each novel polynomial exactly where the original peeling algorithm +calls `basis i`, and charge that preparation before the scalar division. -/ +def countedPreparedPeel (inverseCost : Nat) (v : Nat → F) (depth : Nat) : + Nat → CPolynomial F → List F × Nat + | 0, _ => ([], 0) + | size + 1, p => + let basis := countedNovel inverseCost v depth size + let coefficient := p.coeff size / basis.1.coeff size + let product := countedMul (CPolynomial.C coefficient) basis.1 + let tail := countedPreparedPeel inverseCost v depth size (p - product.1) + (coefficient :: tail.1, basis.2 + inverseCost + 1 + product.2 + + product.1.val.size + max p.val.size product.1.val.size + tail.2) + +theorem countedPreparedPeel_value (inverseCost : Nat) (v : Nat → F) (depth size : Nat) + (p : CPolynomial F) : + (countedPreparedPeel inverseCost v depth size p).1 = peel (novel v depth) size p := by + induction size generalizing p with + | zero => rfl + | succ size ih => + simp [countedPreparedPeel, peel, countedNovel_value, countedMul_value, ih] + +theorem countedPreparedPeel_cost (inverseCost : Nat) (v : Nat → F) (depth size width : Nat) + (p : CPolynomial F) (limit : 2 ^ (depth + 1) ≤ width) (support : p.val.size ≤ width) : + (countedPreparedPeel inverseCost v depth size p).2 ≤ + size * (novelBudget inverseCost depth width + 4 * width + inverseCost + 2) := by + induction size generalizing p with + | zero => simp [countedPreparedPeel] + | succ size ih => + let basis := countedNovel inverseCost v depth size + let coefficient := p.coeff size / basis.1.coeff size + have basisSupport : basis.1.val.size ≤ width := by + rw [countedNovel_value]; exact (novel_support _ _ _).trans limit + have basisCost := countedNovel_cost inverseCost v depth size width limit + have productSupport : (countedMul (CPolynomial.C coefficient) basis.1).1.val.size ≤ width := by + rw [countedMul_value]; exact (constant_mul_support _ _).trans basisSupport + have productCost : (countedMul (CPolynomial.C coefficient) basis.1).2 ≤ 1 + 2 * width := by + exact (countedRawMul_cost _ _).trans (by + calc + _ ≤ 1 * (1 + 2 * width) := + Nat.mul_le_mul (constant_support coefficient) + (Nat.add_le_add (constant_support coefficient) (Nat.mul_le_mul_left 2 basisSupport)) + _ = _ := by omega) + have residualSupport := subtract_size p + (countedMul (CPolynomial.C coefficient) basis.1).1 width support productSupport + have tail := ih (p - (countedMul (CPolynomial.C coefficient) basis.1).1) residualSupport + change basis.2 + inverseCost + 1 + (countedMul (CPolynomial.C coefficient) basis.1).2 + + (countedMul (CPolynomial.C coefficient) basis.1).1.val.size + + max p.val.size (countedMul (CPolynomial.C coefficient) basis.1).1.val.size + + (countedPreparedPeel inverseCost v depth size + (p - (countedMul (CPolynomial.C coefficient) basis.1).1)).2 ≤ _ + change basis.2 ≤ _ at basisCost + rw [Nat.add_mul] + omega + +end Whir.TriangularExtraction diff --git a/verification/whir/Whir/UniqueRadiusSampling.lean b/verification/whir/Whir/UniqueRadiusSampling.lean new file mode 100644 index 000000000..32ef55d03 --- /dev/null +++ b/verification/whir/Whir/UniqueRadiusSampling.lean @@ -0,0 +1,102 @@ +import Whir.SamplingProbability +import Whir.ConcreteRowExtraction +import Whir.ParameterBounds + +/-! Exact stratified query loss outside the unique-decoding radius. The target word is fixed before the query tape. This module proves a converse for the actual all-queries-agree event, not for arbitrary WHIR verifier acceptance. Connecting that event to the adaptive protocol trajectory is a separate obligation. -/ +namespace Whir.UniqueRadiusSampling +open Concrete + +/-- Agreement of one fixed received word with one fixed supported target. -/ +def agreement (depth : Nat) (received target : Fin (2 ^ depth) → E) : + Finset (Fin (2 ^ depth)) := + Finset.univ.filter fun i => received i = target i + +theorem agreement_add_distance (depth : Nat) (received target : Fin (2 ^ depth) → E) : + (agreement depth received target).card + hammingDist received target = 2 ^ depth := by + classical + simpa [agreement, hammingDist] using + (Finset.card_filter_add_card_filter_not (s := (Finset.univ : Finset (Fin (2 ^ depth)))) + (fun i => received i = target i)) + +noncomputable def hitProbability (depth count : Nat) + (received target : Fin (2 ^ depth) → E) : ℚ := by + classical + exact Soundness.uniformProb (Finset.univ.filter + (SamplingProbability.allQueriesHit depth count (agreement depth received target))) + +/-- The exact integer agreement cap outside Gao's radius, including the parity correction. -/ +def queryLoss (depth dimension count : Nat) : ℚ := + (((((2 ^ depth + dimension - 1) / 2 : Nat) : ℚ) / (2 ^ depth : Nat)) ^ count) + +/-- No iid replacement: the starting bound is the proved actual stratified sampler law. -/ +theorem far_hitProbability_le (depth dimension count : Nat) (positive : 0 < depth) + (noWrap : depth ≤ 64) (dimensionBound : dimension ≤ 2 ^ depth) + (received target : Fin (2 ^ depth) → E) + (far : 2 ^ depth - dimension < 2 * hammingDist received target) : + hitProbability depth count received target ≤ queryLoss depth dimension count := by + classical + have partition := agreement_add_distance depth received target + have cap : (agreement depth received target).card ≤ (2 ^ depth + dimension - 1) / 2 := by + have sizePositive : 0 < 2 ^ depth := by positivity + omega + have sampled := SamplingProbability.actual_query_bound_rat depth count positive noWrap + (agreement depth received target) + calc + hitProbability depth count received target ≤ + (((agreement depth received target).card : ℚ) / (2 ^ depth : Nat)) ^ count := sampled + _ ≤ queryLoss depth dimension count := by + apply pow_le_pow_left₀ (by positivity) + apply div_le_div_of_nonneg_right (by exact_mod_cast cap) (by positivity) + +/-- Nonnegligible agreement-event mass above the explicit loss forces the decoder radius for this fixed supported word. This is not an acceptance-to-radius theorem. -/ +theorem hitProbability_above_implies_radius (depth dimension count : Nat) + (positive : 0 < depth) (noWrap : depth ≤ 64) (dimensionBound : dimension ≤ 2 ^ depth) + (received target : Fin (2 ^ depth) → E) + (above : queryLoss depth dimension count < hitProbability depth count received target) : + 2 * hammingDist received target ≤ 2 ^ depth - dimension := by + by_contra far + exact (not_lt_of_ge (far_hitProbability_le depth dimension count positive noWrap dimensionBound + received target (by omega))) above + +/-- The actual rate-four production profile uses 56 initial stratified queries. -/ +theorem rate_four_first_queries (size : Fin 14) : + (ParameterBounds.config (size, (⟨3, by decide⟩ : Fin 4))).queries[0]! = 56 := by + have all : ∀ size : Fin 14, + (ParameterBounds.config (size, (⟨3, by decide⟩ : Fin 4))).queries[0]! = 56 := by + decide +kernel + exact all size + +/-- Exact finite-size unique-radius sampling loss is no larger than the rate-four envelope. This is a fixed-target agreement event, not WHIR acceptance. -/ +theorem rate_four_queryLoss_le (n : Nat) : + queryLoss (n + 4) (2 ^ n) 56 ≤ (17 / 32 : ℚ) ^ 56 := by + unfold queryLoss + apply pow_le_pow_left₀ (by positivity) + have size : 2 ^ (n + 4) = 16 * 2 ^ n := by + rw [Nat.pow_add] + norm_num + omega + have cap : 2 * ((2 ^ (n + 4) + 2 ^ n - 1) / 2) ≤ 17 * 2 ^ n := by + have divided := Nat.mul_div_le (2 ^ (n + 4) + 2 ^ n - 1) 2 + omega + apply (div_le_iff₀ (by positivity : (0 : ℚ) < (2 ^ (n + 4) : Nat))).mpr + rw [size] + have castCap : (2 : ℚ) * (((2 ^ (n + 4) + 2 ^ n - 1) / 2 : Nat) : ℚ) ≤ + 17 * (2 ^ n : Nat) := by exact_mod_cast cap + rw [size] at castCap + push_cast at castCap ⊢ + linarith + +/-- This envelope is between 2^-52 and 2^-51, and must not be advertised as a 128-bit bound. -/ +theorem rate_four_envelope_bits : + (1 / 2 ^ 52 : ℚ) < (17 / 32 : ℚ) ^ 56 ∧ + (17 / 32 : ℚ) ^ 56 < (1 / 2 ^ 51 : ℚ) := by + norm_num + +#print axioms agreement_add_distance +#print axioms far_hitProbability_le +#print axioms hitProbability_above_implies_radius +#print axioms rate_four_first_queries +#print axioms rate_four_queryLoss_le +#print axioms rate_four_envelope_bits + +end Whir.UniqueRadiusSampling diff --git a/verification/whir/Whir/WHIRCallerSupport.lean b/verification/whir/Whir/WHIRCallerSupport.lean index 2c419f766..eb3f44190 100644 --- a/verification/whir/Whir/WHIRCallerSupport.lean +++ b/verification/whir/Whir/WHIRCallerSupport.lean @@ -699,6 +699,22 @@ theorem decoded_geometry (model : ProductionLayout) (entry : FiatShamirGame.Fram (columnFits_mono model.sources) (ringFits_mono model.sources) model.layout model.geometry tokens claims rest trace +theorem geometry_support (model : ProductionLayout) (claims : CallerClaims) + (geometry : WHIRCallerGeometry.ClaimsValid + (fun i d => columnFits model.sources i d = true) + (fun o d => ringFits model.sources o d = true) (callerPlacements model.layout) claims) : + (∀ ring ∈ claims.families, ring.offset + 2^ring.point.size ≤ callerWords model.layout) ∧ + (∀ point ∈ claims.points.toList, ∀ v, callerWords model.layout ≤ v → pointWeight point v = 0) := by + obtain ⟨rings,points⟩ := geometry + rw [callerWords_placementsOf model.sources model.layout model.constructed] + constructor + · intro ring mem + exact ringFits_bound model.sources ring.offset ring.point.size (rings ring mem) + · intro point mem v hv + obtain ⟨column,placed,atColumn,claimed,fits⟩ := points point mem + exact production_point_support model.sources (callerPlacements model.layout) + model.constructed column placed atColumn fits point claimed v hv + /-- Support of every actual decoded family/plain/strided claim is a consequence of production placement and parser provenance, not a decoder-correctness axiom. -/ theorem decoded_support (model : ProductionLayout) (entry : FiatShamirGame.FramedHistory) @@ -708,15 +724,7 @@ theorem decoded_support (model : ProductionLayout) (entry : FiatShamirGame.Frame ring.offset + 2^ring.point.size ≤ callerWords model.layout) ∧ (∀ point ∈ claims.points.toList, ∀ v, callerWords model.layout ≤ v → pointWeight point v = 0) := by - obtain ⟨rings,points⟩ := decoded_geometry model entry answers claims accepted - rw [callerWords_placementsOf model.sources model.layout model.constructed] - constructor - · intro ring mem - exact ringFits_bound model.sources ring.offset ring.point.size (rings ring mem) - · intro point mem v hv - obtain ⟨column,placed,atColumn,claimed,fits⟩ := points point mem - exact production_point_support model.sources (callerPlacements model.layout) - model.constructed column placed atColumn fits point claimed v hv + exact geometry_support model claims (decoded_geometry model entry answers claims accepted) /-- Each original transformed claim passes the actual causal experiment's shape check, including the unencoded lane tail. -/ @@ -834,18 +842,16 @@ theorem openingMatches_words_bound (layout : CallerLayout) (p : ParameterBounds. rw [← Nat.pow_add, Nat.add_sub_of_le hn] at hb exact occupied.trans hb -/-- Every source-decoded selector has the dimension, alignment, cube range, -and port-slot bounds needed by the native caller-weight equality. -/ -theorem decoded_nativeShapes (model : ProductionLayout) (p : ParameterBounds.Profile) +theorem geometry_nativeShapes (model : ProductionLayout) (p : ParameterBounds.Profile) (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) - (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) - (entry : FiatShamirGame.FramedHistory) - (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) - (accepted : decodeCaller model.layout entry answers = some claims) : + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) (claims : CallerClaims) + (geometry : WHIRCallerGeometry.ClaimsValid + (fun i d => columnFits model.sources i d = true) + (fun o d => ringFits model.sources o d = true) (callerPlacements model.layout) claims) : SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN (fun i : Fin claims.families.length => claims.families[i]) ∧ (∀ point ∈ claims.points.toList, SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by - obtain ⟨rings,points⟩ := decoded_geometry model entry answers claims accepted + obtain ⟨rings,points⟩ := geometry have bound : placedWords model.sources ≤ 2^(ParameterBounds.config p).logN := by rw [← callerWords_placementsOf model.sources model.layout model.constructed] exact openingMatches_words_bound model.layout p lanes metadata laneBound @@ -857,6 +863,20 @@ theorem decoded_nativeShapes (model : ProductionLayout) (p : ParameterBounds.Pro exact production_point_nativeShape model.sources (callerPlacements model.layout) model.constructed column placed atColumn fits point claimed _ bound +/-- Every source-decoded selector has the dimension, alignment, cube range, +and port-slot bounds needed by the native caller-weight equality. -/ +theorem decoded_nativeShapes (model : ProductionLayout) (p : ParameterBounds.Profile) + (lanes : Nat) (metadata : openingMatches p lanes model.layout = true) + (laneBound : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) (claims : CallerClaims) + (accepted : decodeCaller model.layout entry answers = some claims) : + SuccinctRingWeight.FamilyShape (ParameterBounds.config p).logN + (fun i : Fin claims.families.length => claims.families[i]) ∧ + (∀ point ∈ claims.points.toList, SuccinctPointWeight.Shape (ParameterBounds.config p).logN point) := by + exact geometry_nativeShapes model p lanes metadata laneBound claims + (decoded_geometry model entry answers claims accepted) + theorem decodeRequest_nativeShapes (model : ProductionLayout) (cap : Nat) (p : ParameterBounds.Profile) (lanes : Nat) (entry : FiatShamirGame.FramedHistory) (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) diff --git a/verification/whir/Whir/WHIRNativeEvent.lean b/verification/whir/Whir/WHIRNativeEvent.lean index 26e521a97..ce03f4ae6 100644 --- a/verification/whir/Whir/WHIRNativeEvent.lean +++ b/verification/whir/Whir/WHIRNativeEvent.lean @@ -2,7 +2,7 @@ import Whir.WHIRPhysicalDriver import Whir.WHIRObservableSource namespace Whir.WHIRNativeEvent -open DuplexModeGame WHIRPhysicalDriver +open DuplexModeGame WHIRPhysicalDriver WHIRPhysicalDriver.Unanchored abbrev Output (registry : ProductionRegistry) (Q cap : Nat) := WHIRPublicBackfill.Completed (WHIRCallerRegistry.context registry.publicRegistry) Q diff --git a/verification/whir/Whir/WHIRNativeSecurity.lean b/verification/whir/Whir/WHIRNativeSecurity.lean index db38ff000..599901a9e 100644 --- a/verification/whir/Whir/WHIRNativeSecurity.lean +++ b/verification/whir/Whir/WHIRNativeSecurity.lean @@ -4,7 +4,7 @@ import Whir.WHIRSourceMerkleSecurity import Whir.WHIRPhysicalBinding namespace Whir.WHIRNativeSecurity -open FiatShamirGame DuplexModeGame WHIRPhysicalDriver WHIRSourceChronology +open FiatShamirGame DuplexModeGame WHIRPhysicalDriver WHIRPhysicalDriver.Unanchored WHIRSourceChronology open RawOracleCoupling.Concrete TypedOracleCompiler set_option maxRecDepth 100000 set_option maxHeartbeats 800000 @@ -92,7 +92,6 @@ private theorem real_union_bound [Fintype Coins] [Nonempty Coins] split <;> split <;> norm_num private theorem random_of_reduction [Fintype Coins] [Nonempty Coins] - [Fintype DuplexPublicSimulator.Seed] (registry : ProductionRegistry) (Q a b Mf free : Nat) (attackers : Coins → Source cap (Input registry.context Q)) (before : ∀ coins, Counts a (attackers coins)) @@ -104,15 +103,13 @@ private theorem random_of_reduction [Fintype Coins] [Nonempty Coins] (erase (attackers coins))) (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (sources registry Q attackers coins)) (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) - (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State - (DuplexPublicSimulator.simulator Q) registry.iv) (reduction : ∀ (whole : ∀ coins, DuplexModeGame.Counts Q (adversary registry Q attackers coins)) C coins, WHIRNativeEvent.Failure registry Q (runReal C registry.iv (adversary registry Q attackers coins)).view.result → WHIRObservableSource.Failure registry.publicRegistry Q select (runReal C registry.iv (adversary registry Q attackers coins)).view.result ∨ MerkleFailure registry Q attackers whole C coins) : realProbability registry.iv (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ - WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + dmvLoss Q + + WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + duplexModeLoss Q + WHIRSourceMerkleSecurity.loss Q free := by have sourceA : ∀ coins, Counts (a+b) (sources registry Q attackers coins) := fun coins => verifyAfter_counted cap registry Q (attackers coins) a b (before coins) (verifierBudget coins) @@ -123,14 +120,13 @@ private theorem random_of_reduction [Fintype Coins] [Nonempty Coins] have whole := counted registry Q a b Mf attackers before verifierBudget paths envelope have unionBound := real_union_bound registry Q attackers whole (reduction whole) have rawBound := WHIRObservableSecurity.random_compression_list_binding registry.publicRegistry Q (a+b) Mf - (sources registry Q attackers) select sourceA finalPaths envelope security + (sources registry Q attackers) select sourceA finalPaths envelope have merkleBound := WHIRSourceMerkleSecurity.probability_bound registry.publicRegistry Q free (sources registry Q attackers) select sourceQ announcements whole exact unionBound.trans (add_le_add rawBound merkleBound) -/-- Actual native verification, original CPU/recursion decoding, first-frozen candidates, adaptive public Fiat-Shamir, and ordinary Merkle transport compose in the shared random-compression experiment. The only cryptographic premise is DMV for the pinned public mode; the remaining premises are source-only resource budgets. -/ +/-- Actual native verification, original CPU/recursion decoding, first-frozen candidates, adaptive public Fiat-Shamir, and ordinary Merkle transport compose in the shared random-compression experiment. The adaptive whole-view public-mode coupling is proved; the remaining premises are reachable source-only resource budgets in the formal valid-shape model, not universal #599/#555 implementation correspondence. -/ theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] - [Fintype DuplexPublicSimulator.Seed] (registry : ProductionRegistry) (Q a b Mf free : Nat) (attackers : Coins → Source cap (Input registry.context Q)) (before : ∀ coins, Counts a (attackers coins)) @@ -141,13 +137,11 @@ theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] (fun input => DuplexFraming.pathCost (RawWHIRKeys.coordinate registry.context input.packet.val 0) ≤ Mf) (erase (attackers coins))) (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (sources registry Q attackers coins)) - (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) - (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State - (DuplexPublicSimulator.simulator Q) registry.iv) : + (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) : realProbability registry.iv (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ - WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + dmvLoss Q + + WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + duplexModeLoss Q + WHIRSourceMerkleSecurity.loss Q free := by - apply random_of_reduction registry Q a b Mf free attackers before verifierBudget paths announcements envelope security + apply random_of_reduction registry Q a b Mf free attackers before verifierBudget paths announcements envelope intro whole C coins failed have sourceA := verifyAfter_counted cap registry Q (attackers coins) a b (before coins) (verifierBudget coins) have sourceQ := WHIRObservableSecurity.source_counted registry.publicRegistry Q (a+b) Mf @@ -160,7 +154,6 @@ replacement premise is not a standard efficient-adversary hash assumption: unit loss when its class contains the elementary known-answer observer. No correctness/coverage premise is delegated to this replacement game. -/ theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] - [Fintype DuplexPublicSimulator.Seed] (registry : ProductionRegistry) (Q a b Mf free : Nat) (attackers : Coins → Source cap (Input registry.context Q)) (before : ∀ coins, Counts a (attackers coins)) @@ -172,17 +165,15 @@ theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] (erase (attackers coins))) (announcements : ∀ coins, WHIRSourceRootPolicy.FreeAnnouncements free (sources registry Q attackers coins)) (envelope : WHIRSourceBackfill.budget registry.context (a+b) Mf ≤ Q) - (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State - (DuplexPublicSimulator.simulator Q) registry.iv) (Allowed : (C : Type) → [Fintype C] → (Output : Type) → (C → Program Output) → (View Output → Bool) → Prop) (primitiveLoss : ℚ) (primitive : ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed) (permitted : Allowed Coins _ (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap)) : concreteProbability registry.iv (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) ≤ - WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + dmvLoss Q + + WHIRObservableSecurity.romBound registry.publicRegistry (a+b) cap + duplexModeLoss Q + WHIRSourceMerkleSecurity.loss Q free + primitiveLoss := by have randomBound := random_compression_list_binding registry Q a b Mf free attackers - before verifierBudget paths announcements envelope security + before verifierBudget paths announcements envelope have replaced := (abs_le.mp (primitive Coins _ (adversary registry Q attackers) (WHIRNativeEvent.distinguisher registry Q cap) permitted (counted registry Q a b Mf attackers before verifierBudget paths envelope))).2 diff --git a/verification/whir/Whir/WHIRObservableSecurity.lean b/verification/whir/Whir/WHIRObservableSecurity.lean index 67e5f8fcb..207fa4475 100644 --- a/verification/whir/Whir/WHIRObservableSecurity.lean +++ b/verification/whir/Whir/WHIRObservableSecurity.lean @@ -1,5 +1,6 @@ import Whir.WHIRObservableSource import Whir.WHIRRealSimulator +import Whir.PublicCompressionModeSecurity namespace Whir.WHIRObservableSecurity open FiatShamirGame DuplexModeGame RawOracleCoupling.Concrete @@ -13,6 +14,9 @@ private instance : Finite UInt64 := Finite.of_injective ByteCodec.encodeK ByteCodec.encodeK_injective private noncomputable instance : Fintype UInt64 := Fintype.ofFinite _ +noncomputable local instance : Fintype DuplexPublicSimulator.Seed := + DuplexPublicSimulator.seedFintype + /-- The public event never receives the adversary program, adversary coins, simulator seed, or a total raw oracle. -/ noncomputable def distinguisher (registry : Public) (Q : Nat) (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) : @@ -58,7 +62,7 @@ theorem average_product {X Y : Type} [Fintype X] [Fintype Y] (f : X × Y → ℚ rw [mul_comm] /-- Averaging over independent raw tables, simulator coins and adversary coins preserves the checked source-budgeted ROM bound. -/ -theorem ideal_list_binding [Fintype Coins] [Nonempty Coins] [Fintype DuplexPublicSimulator.Seed] +theorem ideal_list_binding [Fintype Coins] [Nonempty Coins] (registry : Public) (Q A : Nat) (sources : Coins → Source cap R) (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) (sourceQ : ∀ coins, Counts Q (sources coins)) (before : ∀ coins, Counts A (sources coins)) @@ -82,9 +86,8 @@ theorem ideal_list_binding [Fintype Coins] [Nonempty Coins] [Fintype DuplexPubli A (before coins.2) select _ = _ := average_const _ -/-- This conditional statement is only about the pinned #552 public-compression mode. It does not apply DMV to the older keyed transcript. -/ +/-- The actual adaptive whole-view coupling bounds the pinned #552 public-compression mode. It does not cover the older keyed transcript. -/ theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] - [Fintype DuplexPublicSimulator.Seed] (registry : Public) (Q A Mf : Nat) (sources : Coins → Source cap R) (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) (before : ∀ coins, Counts A (sources coins)) @@ -92,19 +95,18 @@ theorem random_compression_list_binding [Fintype Coins] [Nonempty Coins] (fun result => ∀ packet, select result = some packet → DuplexFraming.pathCost (RawWHIRKeys.coordinate (context registry) packet.val 0) ≤ Mf) (erase (sources coins))) - (envelope : WHIRSourceBackfill.budget (context registry) A Mf ≤ Q) - (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State - (DuplexPublicSimulator.simulator Q) registry.iv) : + (envelope : WHIRSourceBackfill.budget (context registry) A Mf ≤ Q) : realProbability registry.iv (adversary registry Q sources select) (distinguisher registry Q select) ≤ - romBound registry A cap + dmvLoss Q := by - apply randomCompression_transfer (DuplexPublicSimulator.simulator Q) registry.iv security + romBound registry A cap + duplexModeLoss Q := by + apply randomCompression_transfer (DuplexPublicSimulator.simulator Q) registry.iv + (DuplexPublicSimulator.modeSecurity Q registry.iv) (adversary registry Q sources select) (adversary_counted registry Q A Mf sources select before paths envelope) (distinguisher registry Q select) exact ideal_list_binding registry Q A sources select (fun coins => source_counted registry Q A Mf (sources coins) (before coins) envelope) before _ -/-- Concrete BLAKE2s requires its own explicit replacement gap for this actual public event, separate from DMV and the algebraic ROM bound. -/ -theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] [Fintype DuplexPublicSimulator.Seed] +/-- Concrete BLAKE2s retains an explicit full-public-view replacement gap, not a justified computational hash assumption; the mode coupling and algebraic ROM bound are proved separately. -/ +theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] (registry : Public) (Q A Mf : Nat) (sources : Coins → Source cap R) (select : R → Option (RawWHIRKeys.Packet (context registry) Q)) (before : ∀ coins, Counts A (sources coins)) @@ -113,15 +115,14 @@ theorem concrete_list_binding [Fintype Coins] [Nonempty Coins] [Fintype DuplexPu DuplexFraming.pathCost (RawWHIRKeys.coordinate (context registry) packet.val 0) ≤ Mf) (erase (sources coins))) (envelope : WHIRSourceBackfill.budget (context registry) A Mf ≤ Q) - (security : PublicRandomCompressionDMV Q DuplexPublicSimulator.Seed DuplexPublicSimulator.State - (DuplexPublicSimulator.simulator Q) registry.iv) (Allowed : (C : Type) → [Fintype C] → (Output : Type) → (C → Program Output) → (View Output → Bool) → Prop) (primitiveLoss : ℚ) (primitive : ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed) (permitted : Allowed Coins _ (adversary registry Q sources select) (distinguisher registry Q select)) : concreteProbability registry.iv (adversary registry Q sources select) (distinguisher registry Q select) ≤ - romBound registry A cap + dmvLoss Q + primitiveLoss := by - apply concrete_transfer (DuplexPublicSimulator.simulator Q) registry.iv security Allowed primitive + romBound registry A cap + duplexModeLoss Q + primitiveLoss := by + apply concrete_transfer (DuplexPublicSimulator.simulator Q) registry.iv + (DuplexPublicSimulator.modeSecurity Q registry.iv) Allowed primitive (adversary registry Q sources select) (adversary_counted registry Q A Mf sources select before paths envelope) (distinguisher registry Q select) permitted exact ideal_list_binding registry Q A sources select diff --git a/verification/whir/Whir/WHIRPhysicalBinding.lean b/verification/whir/Whir/WHIRPhysicalBinding.lean index 82f7a1282..a9c7870b7 100644 --- a/verification/whir/Whir/WHIRPhysicalBinding.lean +++ b/verification/whir/Whir/WHIRPhysicalBinding.lean @@ -226,32 +226,32 @@ The attacker supplies only input bytes/proofs; the trusted native verifier runs once. Its accepted false fixed-list claim forces either the public ROM failure or an explicitly witnessed ordinary Merkle failure on the same full-C trace. -/ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistry) (Q cap : Nat) - (C : PrimitiveOracle) (attacker : WHIRSourceChronology.Source cap (WHIRPhysicalDriver.Input registry.context Q)) - (counted : WHIRSourceChronology.Counts Q (WHIRPhysicalDriver.verifyAfter cap registry Q attacker)) + (C : PrimitiveOracle) (attacker : WHIRSourceChronology.Source cap (WHIRPhysicalDriver.Unanchored.Input registry.context Q)) + (counted : WHIRSourceChronology.Counts Q (WHIRPhysicalDriver.Unanchored.verifyAfter cap registry Q attacker)) (whole : Counts Q (WHIRSourceBackfill.instrument registry.context Q - (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select)) + (WHIRPhysicalDriver.Unanchored.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.Unanchored.select)) (failed : WHIRNativeEvent.Failure registry Q (runReal C registry.iv (WHIRSourceBackfill.instrument registry.context Q - (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select)).view.result) : - WHIRObservableSource.Failure registry.publicRegistry Q WHIRPhysicalDriver.select + (WHIRPhysicalDriver.Unanchored.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.Unanchored.select)).view.result) : + WHIRObservableSource.Failure registry.publicRegistry Q WHIRPhysicalDriver.Unanchored.select (runReal C registry.iv (WHIRSourceBackfill.instrument registry.context Q - (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select)).view.result ∨ + (WHIRPhysicalDriver.Unanchored.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.Unanchored.select)).view.result ∨ PublicMerkleProbability.FrozenOpeningBad C - (WHIRSourceRootPolicy.policy registry.publicRegistry Q WHIRPhysicalDriver.select - (WHIRPhysicalDriver.verifyAfter cap registry Q attacker)) + (WHIRSourceRootPolicy.policy registry.publicRegistry Q WHIRPhysicalDriver.Unanchored.select + (WHIRPhysicalDriver.Unanchored.verifyAfter cap registry Q attacker)) (PublicCompressionProgram.primitiveLog C registry.iv (WHIRSourceBackfill.instrument registry.context Q - (WHIRPhysicalDriver.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.select) Q whole) := by - let source := WHIRPhysicalDriver.verifyAfter cap registry Q attacker + (WHIRPhysicalDriver.Unanchored.verifyAfter cap registry Q attacker) WHIRPhysicalDriver.Unanchored.select) Q whole) := by + let source := WHIRPhysicalDriver.Unanchored.verifyAfter cap registry Q attacker let state := WHIRSourceFrozenPrefix.replayState registry.publicRegistry Q C source counted - (WHIRSourceFrozenPrefix.allocationTrace registry.publicRegistry Q WHIRPhysicalDriver.select C source) + (WHIRSourceFrozenPrefix.allocationTrace registry.publicRegistry Q WHIRPhysicalDriver.Unanchored.select C source) have sourceResultEq := congrArg (fun output : WHIRNativeEvent.Output registry Q cap => output.result) - (WHIRSourceBackfill.real_result registry.context Q C source WHIRPhysicalDriver.select) - have observedEq := real_observation registry.publicRegistry Q C source counted WHIRPhysicalDriver.select whole + (WHIRSourceBackfill.real_result registry.context Q C source WHIRPhysicalDriver.Unanchored.select) + have observedEq := real_observation registry.publicRegistry Q C source counted WHIRPhysicalDriver.Unanchored.select whole obtain ⟨observed,seen,wrong⟩ := failed have same := Option.some.inj (seen.symm.trans observedEq) subst observed erw [real_observation_state,sourceResultEq] at wrong - change WHIRPhysicalDriver.nativeWrong state + change WHIRPhysicalDriver.Unanchored.nativeWrong state (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value at wrong cases returned : (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value with | none => @@ -260,7 +260,7 @@ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistr | some accepted => rw [returned] at wrong obtain ⟨input,v,chosen,nativeReturned,acceptedEq,events⟩ := - WHIRPhysicalDriver.real_native_segment C registry.iv cap registry Q attacker accepted returned + WHIRPhysicalDriver.Unanchored.real_native_segment C registry.iv cap registry Q attacker accepted returned cases acceptedEq let nativeSource := verifySource cap (registry.packetModel Q input.packet) registry.context rfl Q (registry.packetLanes Q input.packet) input.packet input.proofs @@ -281,8 +281,8 @@ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistr rw [← chosen] at prefixRun apply (WHIRSourceChronology.Source.map_counted nativeSource _ Q).mp exact WHIRSourceChronology.Source.bind_suffix_counted attacker - (WHIRPhysicalDriver.verifier cap registry Q) Q _ input prefixRun counted - have selected : WHIRPhysicalDriver.select + (WHIRPhysicalDriver.Unanchored.verifier cap registry Q) Q _ input prefixRun counted + have selected : WHIRPhysicalDriver.Unanchored.select (runReal C registry.iv (WHIRSourceChronology.compile source)).view.result.value = some input.packet := by rw [returned] rfl @@ -296,13 +296,13 @@ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistr simpa only [WHIRPhysicalDriver.ProductionRegistry.packetLanes,registry.packetModel_layout, WHIRRawReplay.callerEntry] using decoded have captured := WHIRSourceCatalog.final_catalog_real registry.publicRegistry Q cap C source counted - input.packet WHIRPhysicalDriver.select selected nativeSource nativeCounted before after callerTrace queries + input.packet WHIRPhysicalDriver.Unanchored.select selected nativeSource nativeCounted before after callerTrace queries v.request registeredDecode have prepared := WHIRSourceCatalog.final_prepared_real registry.publicRegistry Q cap C source counted - input.packet WHIRPhysicalDriver.select selected [] + input.packet WHIRPhysicalDriver.Unanchored.select selected [] obtain ⟨past,cursor,_⟩ := WHIRSourceFrozenPrefix.allocation_prefix_cursor registry.publicRegistry Q - WHIRPhysicalDriver.select C source counted - (WHIRSourceFrozenPrefix.allocationTrace registry.publicRegistry Q WHIRPhysicalDriver.select C source) [] + WHIRPhysicalDriver.Unanchored.select C source counted + (WHIRSourceFrozenPrefix.allocationTrace registry.publicRegistry Q WHIRPhysicalDriver.Unanchored.select C source) [] (by simp) have execution := verifySource_execution cap (registry.packetModel Q input.packet) registry.context rfl Q (registry.packetLanes Q input.packet) input.packet input.proofs nativeObs v nativeRun @@ -319,7 +319,7 @@ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistr state _ found bound wrong rw [verifySource_completed_history C cap (registry.packetModel Q input.packet) registry.context rfl Q (registry.packetLanes Q input.packet) input.packet input.proofs nativeObs v nativeAnswers nativeRun] at nativeFailed - apply real_mode_failure_public registry.publicRegistry Q C source counted WHIRPhysicalDriver.select whole + apply real_mode_failure_public registry.publicRegistry Q C source counted WHIRPhysicalDriver.Unanchored.select whole dsimp only erw [real_observation_state,selected] exact ⟨input.packet,rfl,nativeFailed⟩ @@ -328,7 +328,7 @@ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistr obtain ⟨snapshot,known⟩ := trace_opening_registered input.packet v.request.root (completion_chain registry.context Q input.packet) execution.1 state captured.2 prepared opening member obtain ⟨_,newLog,before,after,_,newFrozen,freeze,prior,ordinary,registered,_⟩ := - WHIRSourceFrozenPrefix.actual_backfill_retained registry.publicRegistry Q WHIRPhysicalDriver.select + WHIRSourceFrozenPrefix.actual_backfill_retained registry.publicRegistry Q WHIRPhysicalDriver.Unanchored.select C source counted Q whole opening.root snapshot known have logs : oldLog = newLog := Option.some.inj (frozen.symm.trans newFrozen) subst newLog @@ -339,7 +339,7 @@ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistr exact List.mem_append_right _ present have executed : ∀ n d, (⟨.primitive .verification n,d⟩ : Observation) ∈ nativeObs → (n,d) ∈ PublicCompressionProgram.primitiveLog C registry.iv - (WHIRSourceBackfill.instrument registry.context Q source WHIRPhysicalDriver.select) Q whole := by + (WHIRSourceBackfill.instrument registry.context Q source WHIRPhysicalDriver.Unanchored.select) Q whole := by intro n d present have expanded := WHIRSourceFrozenPrefix.primitive_expand C registry.iv (runReal C registry.iv (WHIRSourceChronology.compile source)).view.observations @@ -348,7 +348,7 @@ theorem nativeFailure_or_frozen (registry : WHIRPhysicalDriver.ProductionRegistr rw [WHIRSourceFrozenPrefix.expand_real C registry.iv (WHIRSourceChronology.compile source) Q ((WHIRSourceChronology.compile_counted source Q).mpr counted)] at expanded obtain ⟨suffix,equal⟩ := WHIRSourceFrozenPrefix.backfill_prefix registry.publicRegistry Q - WHIRPhysicalDriver.select C source counted Q whole + WHIRPhysicalDriver.Unanchored.select C source counted Q whole erw [← equal] exact List.mem_append_left suffix expanded exact observed_frozen_bad (execution.2 opening member) C registry.iv nativeAnswers _ _ before after oldLog diff --git a/verification/whir/Whir/WHIRPhysicalDriver.lean b/verification/whir/Whir/WHIRPhysicalDriver.lean index b974fa1ec..5772b88c7 100644 --- a/verification/whir/Whir/WHIRPhysicalDriver.lean +++ b/verification/whir/Whir/WHIRPhysicalDriver.lean @@ -61,6 +61,9 @@ def ProductionRegistry.packetLanes (registry : ProductionRegistry) (Q : Nat) (packet : RawWHIRKeys.Packet registry.context Q) : Nat := WHIRCallerClaims.callerLanes (registry.packetModel Q packet).layout +/- Historical unanchored endpoint retained only for its underlying physical list-binding theorem chain. The 32c public endpoint is AnchoredSourcePacket.receiveAndVerify. -/ +namespace Unanchored + /-- An attacker chooses transport bytes and opening proofs, not a verifier result or its acceptance evidence. -/ structure Input (ctx : RawWHIRKeys.Context) (Q : Nat) where @@ -219,4 +222,6 @@ theorem real_native_segment (C : PrimitiveOracle) (iv : Digest32) (cap : Nat) obtain ⟨verified,native,equal⟩ := Option.map_eq_some_iff.mp returned exact ⟨_,verified,rfl,native,equal.symm,congrArg Result.events whole⟩ +end Unanchored + end Whir.WHIRPhysicalDriver diff --git a/verification/whir/Whir/WHIRROM.lean b/verification/whir/Whir/WHIRROM.lean index 9d0e94539..9024a5a2b 100644 --- a/verification/whir/Whir/WHIRROM.lean +++ b/verification/whir/Whir/WHIRROM.lean @@ -5,9 +5,10 @@ import Whir.DuplexRefinement import Whir.WHIRReplay import Whir.WHIRHistoryKey -/-! Source-pinned mode interface for the classical typed full-transcript game. -The mode assumption is a real-versus-ideal oracle-view distinguishing bound, -not an assumption about a PCS acceptance predicate. -/ +/-! Source-pinned streaming interface and classical typed stopped-ROM game. +The full-public-view random-compression mode coupling is proved separately in +`PublicCompressionModeSecurity`; this module proves the typed ROM list bound, +not deterministic primitive security or universal deployed-source refinement. -/ namespace Whir.WHIRROM open Concrete Protocol CausalGame CausalProbability ParameterBounds open FiatShamirGame WHIRFiatShamir diff --git a/verification/whir/lakefile.toml b/verification/whir/lakefile.toml index bd83592b2..3abf6382d 100644 --- a/verification/whir/lakefile.toml +++ b/verification/whir/lakefile.toml @@ -18,3 +18,35 @@ name = "Whir" [[lean_exe]] name = "whirModel" root = "Main" + +[[lean_exe]] +name = "whirExtractionSmoke" +root = "Whir.PCSRewindExtractorFixtures" + +[[lean_exe]] +name = "whirAnchorPrefixSmoke" +root = "Whir.AnchorPrefixRefinementSmoke" + +[[lean_exe]] +name = "whirCountedExtractionSmoke" +root = "Whir.CountedCandidateCheckSmoke" + +[[lean_exe]] +name = "whirByteStreamSmoke" +root = "Whir.AnchoredByteStreamSmoke" + +[[lean_exe]] +name = "whirFreshCallerSmoke" +root = "Whir.AnchoredSourceFreshCallerSmoke" + +[[lean_exe]] +name = "whirPhysicalSmoke" +root = "Whir.AnchoredPhysicalSmoke" + +[[lean_exe]] +name = "whirActualSourceStreamSmoke" +root = "Whir.PublicCompressionCouplingSourceStreamSmoke" + +[[lean_exe]] +name = "whirRoundByRoundDecoderSmoke" +root = "Whir.PCSRoundByRoundSourceDecoderSmoke" From 9a7b13de3f8ec7b05495a46d686c51d0a55d0e6f Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 23:10:53 +0100 Subject: [PATCH 13/28] Prove literal additive RBR knowledge and frozen query-log extraction --- verification/whir/README.md | 12 +- verification/whir/Whir.lean | 6 + .../whir/Whir/MerkleQueryLogExtraction.lean | 256 +++++++++++++++ .../Whir/MerkleQueryLogExtractionCodec.lean | 110 +++++++ .../Whir/MerkleQueryLogExtractionCost.lean | 197 ++++++++++++ .../MerkleQueryLogExtractionPublicCost.lean | 222 +++++++++++++ ...kleQueryLogExtractionResourceContract.lean | 66 ++++ .../Whir/MerkleQueryLogExtractionRows.lean | 170 ++++++++++ ...MerkleQueryLogExtractionRowsAgreement.lean | 131 ++++++++ ...erkleQueryLogExtractionSaturationCost.lean | 125 +++++++ .../Whir/MerkleQueryLogExtractionSmoke.lean | 57 ++++ .../whir/Whir/PCSBCSMerkleOpenedTable.lean | 43 +++ .../whir/Whir/PCSBCSMerkleQueryLog.lean | 138 ++++++++ .../whir/Whir/PCSBCSMerkleRootCache.lean | 65 ++++ .../whir/Whir/PCSBCSMerkleSourceRows.lean | 74 +++++ verification/whir/Whir/PCSBCSRounds.lean | 138 ++++++++ .../whir/Whir/PCSBCSRoundsByteHistory.lean | 240 ++++++++++++++ .../whir/Whir/PCSBCSRoundsParameters.lean | 87 +++++ verification/whir/Whir/PCSBCSRoundsSmoke.lean | 111 +++++++ .../Whir/PCSRoundByRoundCancellation.lean | 304 ++++++++++++++++++ .../Whir/PCSRoundByRoundCausalEvents.lean | 17 + .../whir/Whir/PCSRoundByRoundEnvelope.lean | 297 +++++++++++++++++ .../whir/Whir/PCSRoundByRoundKnowledge.lean | 291 +++++++++++++++++ .../Whir/PCSRoundByRoundKnowledgeLedger.lean | 270 ++++++++++++++++ .../Whir/PCSRoundByRoundKnowledgeQuery.lean | 159 +++++++++ .../PCSRoundByRoundKnowledgeRecovery.lean | 120 +++++++ .../Whir/PCSRoundByRoundKnowledgeState.lean | 66 ++++ .../PCSRoundByRoundPublicCertificate.lean | 48 +++ .../Whir/PCSRoundByRoundPublicEndpoint.lean | 77 +++++ .../Whir/PCSRoundByRoundPublicEvents.lean | 84 +++++ .../whir/Whir/PCSRoundByRoundPublicQuery.lean | 124 +++++++ .../whir/Whir/PCSRoundByRoundPublicState.lean | 108 +++++++ .../whir/Whir/PCSRoundByRoundPublicTrace.lean | 83 +++++ .../Whir/PCSRoundByRoundPublicTransition.lean | 72 +++++ .../Whir/PCSRoundByRoundTranscriptReplay.lean | 192 +++++++++++ verification/whir/lakefile.toml | 8 + 36 files changed, 4567 insertions(+), 1 deletion(-) create mode 100644 verification/whir/Whir/MerkleQueryLogExtraction.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionCodec.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionCost.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionPublicCost.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionResourceContract.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionRows.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionRowsAgreement.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionSaturationCost.lean create mode 100644 verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleOpenedTable.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleQueryLog.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleRootCache.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleSourceRows.lean create mode 100644 verification/whir/Whir/PCSBCSRounds.lean create mode 100644 verification/whir/Whir/PCSBCSRoundsByteHistory.lean create mode 100644 verification/whir/Whir/PCSBCSRoundsParameters.lean create mode 100644 verification/whir/Whir/PCSBCSRoundsSmoke.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundCancellation.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundCausalEvents.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundEnvelope.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundKnowledge.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundKnowledgeLedger.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundKnowledgeQuery.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundKnowledgeRecovery.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundKnowledgeState.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundPublicCertificate.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundPublicEndpoint.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundPublicEvents.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundPublicQuery.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundPublicState.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundPublicTrace.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundPublicTransition.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundTranscriptReplay.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index 0cc64f224..42b224588 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -151,7 +151,7 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: -- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. A coin-free full-root decoder is separately implemented and checked, but a complete public-transcript RBR knowledge theorem, Merkle-query-log extraction and the PCS byte-duplex BCS adapter must be proved before claiming Fiat-Shamir knowledge soundness. +- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. @@ -171,6 +171,16 @@ The fresh completed dependency closure passed `lake build --wfail +Whir:olean +M Actual compiled execution accepted the honest multilevel model and rejected its malformed and tampered cases. The reset extractor recovered eight nonzero base-field coefficients through legal response calls, checked every original family and point claim plus the saved anchor, and rejected withholding, malformed rows and a deliberately false uncompressed family even when its compressed claim passed. Its counted original-statement execution agreed with the same result and exercised all 64 ring slices, strided claims and the anchor. The source-stream executable checked adaptive construction, public recognition and repeated cache access. The separate full-root Gao helper recovered the same word from a directly indexed raw table with one corrupted row and rejected malformed shape, wrong original claims and a changed anchor. Finite executions are regression evidence, not substitutes for the universal checked theorems. +## Completed source RBR, round grouping and query-log extraction + +The completed characteristic-two additive source protocol has a coin-free straight-line full-root decoder with original-statement output correctness and a degree-seven source-operation bound. Its literal state predicate takes only the immutable original statement, frozen raw Root0 and observed public trace. Unobserved challenges are filled with zero only inside reconstruction; strict-prefix congruence proves that hidden future challenges and following prover responses do not affect the state. The initial grouped draw has a proved transition bound, every noninitial coordinate has an incoming-history conditional transition bound, and accepted extraction failure forces the final literal state to be one. Root rectangularity is derived from the accepting verifier guard, not an honest-root or recovery-oracle premise. The relation includes every original ring slice, ordinary and strided point claim and saved anchor. The guarded prepared-input domain, family cap `m <= 2^64` and claim cap `points.size + 2 <= 2^64` remain explicit. + +The exact uniform round error is `(17/32)^56 + 1/2^78`. The grouped round count is `1 + sum_i(folds_i + oodCount_i + 1) + tailCount`, including the final full-E draw that has no following prover response. The checked PCS raw alphabets have minimum entropy exactly 192 bits, with the initial gamma, six maps and lambda forming one eight-E message and queries retaining their full E squeezes before positional projection. The source regrouping is causal and preserves acceptance and rejection in its modeled domain. The unchanged PCS profiles have `k <= 40` and maximal raw message length at most 5760 bits. These are protocol and resource statements, not a security level or a whole-system entropy conclusion. + +Merkle-query-log reconstruction builds one preimage index, produces raw compact occupied rows in physical leaf order and freezes the table at first registration. Repeated registration cannot overwrite or re-extract it. Accepted pruned openings agree with that table or trigger the separately proved compression-game bad event. Missing or malformed leaves use explicit default rows and are not treated as authenticated data. The occupied-lane reversal belongs only to the first-fold consumer, not to the raw table supplied to the decoder. This provides a checked extraction component, not a Fiat-Shamir knowledge theorem for arbitrary BLAKE2s or a universal Rust refinement. + +The integrated completed closure passed `lake build --wfail +Whir:olean +Main:olean`, and `Audit.lean` checked **10402 exported Whir theorem declarations** with only the three permitted standard axioms. Actual compiled execution passed the multilevel accepted/rejected model, nontrivial full-root Gao extraction with a corrupted row, PCS grouped round and byte-cache behavior, and real-BLAKE2s Merkle-log extraction with honest, tampered, absent, malformed and lane-order cases. The inconsistent-output log fixture exercises collision handling without claiming a BLAKE2s collision. Unfinished restoration and source-duplex composition modules are not imported by this audited root. + ## Historical source refresh validation The previously published native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean`. Its fresh `lake env lean -E warning Audit.lean` census reported **7488 exported theorem declarations**, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound`. That historical inspection included both native endpoint types, the then-external `PublicRandomCompressionDMV` coupling certificate and `ConcretePrimitiveGap`. It did not discharge the external coupling certificate, which the completed finite-game coupling above has now removed; the separate concrete primitive premise remains as stated. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index a90c7515b..7ba7094af 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -153,3 +153,9 @@ import Whir.AnchorPrefixRefinementCost import Whir.AnchorPrefixRefinementRows import Whir.PCSRoundByRoundSourceDecoderCorrectness import Whir.PCSRoundByRoundSourceDecoderCost +import Whir.PCSRoundByRoundPublicTransition +import Whir.PCSBCSRoundsParameters +import Whir.PCSBCSRoundsByteHistory +import Whir.PCSBCSMerkleRootCache +import Whir.PCSBCSMerkleOpenedTable +import Whir.MerkleQueryLogExtractionResourceContract diff --git a/verification/whir/Whir/MerkleQueryLogExtraction.lean b/verification/whir/Whir/MerkleQueryLogExtraction.lean new file mode 100644 index 000000000..5246923c4 --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtraction.lean @@ -0,0 +1,256 @@ +import Whir.PublicMerkleBinding +import Std.Data.ExtHashMap.Lemmas + +/-! Deterministic extraction from exposed input/answer records. The runtime +never evaluates a hash oracle. Depth is retained even when leaf and pair bytes +coincide. Absence and malformed preimages are data, not witness defaults. -/ +namespace Whir.MerkleQueryLogExtraction +open Concrete FiatShamirGame MerkleBinding MerkleTransport +open MerkleTransport.Commitments + +abbrev Key := List Byte +abbrev Index := Std.ExtHashMap Key (List Byte) +def key (d : Digest32) : Key := List.ofFn d + +theorem key_injective : Function.Injective key := List.ofFn_injective + +/-- Final index retains the earliest record for each output. Each record is +indexed once; tree descent does not scan the records. -/ +def build : Records → Index + | [] => ∅ + | (bytes,d) :: rest => (build rest).insert (key d) bytes + +/-- Online registration does not replace an already cached preimage. -/ +def register (index : Index) (bytes : List Byte) (d : Digest32) : Index := + index.insertIfNew (key d) bytes + +theorem register_preserves (index : Index) (bytes old : List Byte) (d target : Digest32) + (known : index[key target]? = some old) : + (register index bytes d)[key target]? = some old := by + rw [register, Std.ExtHashMap.getElem?_insertIfNew] + split + next h => + have eq : key d = key target := by simpa using h.1 + have mem : key d ∈ index := by + rw [eq, Std.ExtHashMap.mem_iff_isSome_getElem?, known]; rfl + exact (h.2 mem).elim + next => exact known + +def inverseLookup (d : Digest32) : Records → Option (List Byte) + | [] => none + | (bytes,e) :: rest => if key e = key d then some bytes else inverseLookup d rest + +theorem build_lookup (records : Records) (d : Digest32) : + (build records)[key d]? = inverseLookup d records := by + induction records with + | nil => simp [build, inverseLookup] + | cons e rest ih => + rcases e with ⟨bytes,e⟩ + simp [build, inverseLookup, Std.ExtHashMap.getElem?_insert, ih] + +theorem inverseLookup_mem {records : Records} {d : Digest32} {bytes : List Byte} + (hit : inverseLookup d records = some bytes) : (bytes,d) ∈ records := by + induction records with + | nil => simp [inverseLookup] at hit + | cons e rest ih => + rcases e with ⟨bs,e⟩ + simp only [inverseLookup] at hit + split at hit + next eq => + have ed := key_injective eq + cases ed + cases Option.some.inj hit + exact List.mem_cons_self + next => exact List.mem_cons_of_mem _ (ih hit) + +theorem build_mem {records : Records} {d : Digest32} {bytes : List Byte} + (hit : (build records)[key d]? = some bytes) : (bytes,d) ∈ records := + inverseLookup_mem (by simpa only [build_lookup] using hit) + +theorem build_complete {records : Records} {d : Digest32} {bytes : List Byte} + (member : (bytes,d) ∈ records) : ∃ selected, (build records)[key d]? = some selected := by + rw [build_lookup] + induction records with + | nil => cases member + | cons e rest ih => + rcases e with ⟨bs,e⟩ + by_cases eq : key e = key d + · exact ⟨bs, by simp [inverseLookup,eq]⟩ + · have mem : (bytes,d) ∈ rest := by + rcases List.mem_cons.mp member with he | he + · cases he; exact (eq rfl).elim + · exact he + obtain ⟨selected,hs⟩ := ih mem + exact ⟨selected,by simp [inverseLookup,eq,hs]⟩ + +/-- Codec obligations, not cryptographic assumptions. A decoder must reject +malformed byte strings and be a left inverse on every canonical preimage. -/ +structure Codec where + leaf : List Byte → Option (List K) + pair : List Byte → Option (Digest32 × Digest32) + leaf_sound : ∀ bytes row, leaf bytes = some row → ByteCodec.wordsBytes row = bytes + leaf_complete : ∀ row, leaf (ByteCodec.wordsBytes row) = some row + pair_sound : ∀ bytes p, pair bytes = some p → List.ofFn (ByteCodec.pairBytes p) = bytes + pair_complete : ∀ p, pair (List.ofFn (ByteCodec.pairBytes p)) = some p + +/-- A subtree may be absent without making other occupied rows unavailable. +The leaf case is distinguished from the branch case by requested height. -/ +inductive Tree where + | absent + | leaf (row : List K) + | branch (left right : Tree) + +def extract (codec : Codec) (index : Index) : Nat → Digest32 → Tree + | 0, d => match index[key d]? with + | none => .absent + | some bytes => match codec.leaf bytes with + | none => .absent + | some row => .leaf row + | height + 1, d => match index[key d]? with + | none => .absent + | some bytes => match codec.pair bytes with + | none => .absent + | some (l,r) => .branch (extract codec index height l) (extract codec index height r) + +def Tree.get : Tree → List Bool → Option (List K) + | .leaf row, [] => some row + | .branch l r, b :: address => (if b then r else l).get address + | _, _ => none + +/-- Book default is applied only at the consumer boundary, and is visibly +marked by `get = none`. It is not an authenticated witness. -/ +def Tree.row (tree : Tree) (fallback : List K) (address : List Bool) : List K := + (tree.get address).getD fallback + +theorem domain_mem {records : Records} {bytes : List Byte} {d : Digest32} + (hm : (bytes,d) ∈ records) : bytes ∈ recordDomain records := + List.mem_toFinset.mpr (List.mem_map.mpr ⟨(bytes,d),hm,rfl⟩) + +theorem selected_unique (hash : Primitive) (records : Records) + (auth : Authentic hash records) (clean : ¬ Collision (hashing hash) (recordDomain records)) + {bytes : List Byte} {d : Digest32} (hm : (bytes,d) ∈ records) : + (build records)[key d]? = some bytes := by + obtain ⟨selected,hit⟩ := build_complete hm + have hs := build_mem hit + have eq : selected = bytes := by + by_contra hn + exact clean ⟨selected,domain_mem hs,bytes,domain_mem hm,hn, + (auth _ _ hs).trans (auth _ _ hm).symm⟩ + simpa only [eq] using hit + +/-- Extraction succeeds on a recorded authenticated path outside the literal +collision event. No log-completeness premise is used: this is about the exact +finite domain, and unrecorded opening inputs are charged separately. -/ +theorem extract_complete (codec : Codec) (hash : Primitive) (records : Records) + (auth : Authentic hash records) (clean : ¬ Collision (hashing hash) (recordDomain records)) + {address : List Bool} (path : Opening (List K) Digest32 address) + (covered : path.inputs (hashing hash) ⊆ recordDomain records) : + (extract codec (build records) address.length (path.digest (hashing hash))).get address = + some path.row := by + induction path with + | leaf row => + have mem : ByteCodec.wordsBytes row ∈ recordDomain records := + covered (Finset.mem_singleton_self _) + obtain ⟨d,hd⟩ := recordLookup_exists records _ mem + have hm := recordLookup_mem _ _ _ hd + have he := auth _ _ hm + have hit := selected_unique hash records auth clean hm + change hash (ByteCodec.wordsBytes row) = d at he + change (extract codec (build records) 0 (hash (ByteCodec.wordsBytes row))).get [] = some row + rw [he] + simp only [extract,hit,codec.leaf_complete,Tree.get] + | node b sibling child ih => + have cc : child.inputs (hashing hash) ⊆ recordDomain records := + fun x hx => covered (Finset.mem_insert_of_mem hx) + let pair := if b then (sibling,child.digest (hashing hash)) else (child.digest (hashing hash),sibling) + have cp : List.ofFn (ByteCodec.pairBytes pair) ∈ recordDomain records := + covered (Finset.mem_insert_self _ _) + obtain ⟨d,hd⟩ := recordLookup_exists records _ cp + have hm := recordLookup_mem _ _ _ hd + have he := auth _ _ hm + have hit := selected_unique hash records auth clean hm + change hash (List.ofFn (ByteCodec.pairBytes pair)) = d at he + have hc := ih cc + change (extract codec (build records) (_ + 1) + (hash (List.ofFn (ByteCodec.pairBytes pair)))).get (b :: _) = _ + rw [he] + simp only [extract,hit,codec.pair_complete] + cases b <;> exact hc + +/-- Every successful extraction supplies a genuinely recorded authenticated +path. Failed parsing is never disguised as a witness. -/ +theorem extract_sound (codec : Codec) (hash : Primitive) (records : Records) + (auth : Authentic hash records) (address : List Bool) (d : Digest32) (row : List K) + (hit : (extract codec (build records) address.length d).get address = some row) : + ∃ path : Opening (List K) Digest32 address, + path.row = row ∧ path.inputs (hashing hash) ⊆ recordDomain records ∧ + path.digest (hashing hash) = d := by + induction address generalizing d with + | nil => + cases hi : (build records)[key d]? with + | none => simp [extract,hi,Tree.get] at hit + | some bytes => + cases hl : codec.leaf bytes with + | none => simp [extract,hi,hl,Tree.get] at hit + | some selected => + have eq : selected = row := by simpa [extract,hi,hl,Tree.get] using hit + subst selected + have hb := codec.leaf_sound bytes row hl + have hm := build_mem hi + refine ⟨.leaf row,rfl,?_,?_⟩ + · simpa [Opening.inputs,hashing,hb] using domain_mem hm + · simpa [Opening.digest,hashing,hb] using auth _ _ hm + | cons b address ih => + cases hi : (build records)[key d]? with + | none => simp [extract,hi,Tree.get] at hit + | some bytes => + cases hp : codec.pair bytes with + | none => simp [extract,hi,hp,Tree.get] at hit + | some pair => + rcases pair with ⟨l,r⟩ + have hb := codec.pair_sound bytes (l,r) hp + have hm := build_mem hi + cases b + · obtain ⟨child,hrow,hcovered,hd⟩ := ih l (by simpa [extract,hi,hp,Tree.get] using hit) + refine ⟨.node false r child,hrow,?_,?_⟩ + · simp only [Opening.inputs, Bool.false_eq_true, ↓reduceIte, hd] + change insert (List.ofFn (ByteCodec.pairBytes (l,r))) + (child.inputs (hashing hash)) ⊆ recordDomain records + rw [hb] + exact Finset.insert_subset (domain_mem hm) hcovered + · simp only [Opening.digest, Bool.false_eq_true, ↓reduceIte, hd] + change hash (List.ofFn (ByteCodec.pairBytes (l,r))) = d + rw [hb] + exact auth _ _ hm + · obtain ⟨child,hrow,hcovered,hd⟩ := ih r (by simpa [extract,hi,hp,Tree.get] using hit) + refine ⟨.node true l child,hrow,?_,?_⟩ + · simp only [Opening.inputs, ↓reduceIte, hd] + change insert (List.ofFn (ByteCodec.pairBytes (l,r))) + (child.inputs (hashing hash)) ⊆ recordDomain records + rw [hb] + exact Finset.insert_subset (domain_mem hm) hcovered + · simp only [Opening.digest, ↓reduceIte, hd] + change hash (List.ofFn (ByteCodec.pairBytes (l,r))) = d + rw [hb] + exact auth _ _ hm + +theorem extract_eq_ideal (codec : Codec) (hash : Primitive) (records : Records) + (auth : Authentic hash records) (clean : ¬ Collision (hashing hash) (recordDomain records)) + (root : Digest32) (fallback : List K) (address : List Bool) : + (extract codec (build records) address.length root).row fallback address = + idealRow (hashing hash) (recordDomain records) root fallback address := by + classical + by_cases hex : ∃ path : Opening (List K) Digest32 address, + path.inputs (hashing hash) ⊆ recordDomain records ∧ path.digest (hashing hash) = root + · have hit := extract_complete codec hash records auth clean hex.choose hex.choose_spec.1 + rw [hex.choose_spec.2] at hit + simp only [Tree.row,hit,Option.getD_some,idealRow,dite_eq_left hex] + · have absent : (extract codec (build records) address.length root).get address = none := by + cases hit : (extract codec (build records) address.length root).get address with + | none => rfl + | some row => + obtain ⟨path,_,hc,hd⟩ := extract_sound codec hash records auth address root row hit + exact (hex ⟨path,hc,hd⟩).elim + simp only [Tree.row,absent,Option.getD_none,idealRow,dite_eq_right hex] + +end Whir.MerkleQueryLogExtraction diff --git a/verification/whir/Whir/MerkleQueryLogExtractionCodec.lean b/verification/whir/Whir/MerkleQueryLogExtractionCodec.lean new file mode 100644 index 000000000..cb9725fab --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionCodec.lean @@ -0,0 +1,110 @@ +import Whir.MerkleQueryLogExtraction + +/-! Canonical untagged Merkle byte parsing. These inverse proofs concern the +Lean byte codec; they are not a new Rust parser refinement claim. -/ +namespace Whir.MerkleQueryLogExtraction +open Concrete FiatShamirGame + +/-- Decode eight bytes at a time. Any non-word-aligned input is rejected. -/ +def decodeWords : List Byte → Option (List K) + | [] => some [] + | a :: b :: c :: d :: e :: f :: g :: h :: rest => + (decodeWords rest).map (ByteCodec.decodeK (fun i => + (#[a,b,c,d,e,f,g,h])[i.val]!) :: ·) + | _ => none + +private theorem word_array (x : K) : + (fun i : Fin 8 => (#[ByteCodec.encodeK x 0,ByteCodec.encodeK x 1, + ByteCodec.encodeK x 2,ByteCodec.encodeK x 3,ByteCodec.encodeK x 4, + ByteCodec.encodeK x 5,ByteCodec.encodeK x 6,ByteCodec.encodeK x 7])[i.val]!) = + ByteCodec.encodeK x := by + funext i + fin_cases i <;> rfl + +theorem decodeWords_complete (row : List K) : + decodeWords (ByteCodec.wordsBytes row) = some row := by + induction row with + | nil => rfl + | cons x xs ih => + change decodeWords (List.ofFn (ByteCodec.encodeK x) ++ ByteCodec.wordsBytes xs) = _ + have first : List.ofFn (ByteCodec.encodeK x) = + [ByteCodec.encodeK x 0,ByteCodec.encodeK x 1,ByteCodec.encodeK x 2, + ByteCodec.encodeK x 3,ByteCodec.encodeK x 4,ByteCodec.encodeK x 5, + ByteCodec.encodeK x 6,ByteCodec.encodeK x 7] := by rfl + rw [first] + change (decodeWords (ByteCodec.wordsBytes xs)).map + (ByteCodec.decodeK (fun i : Fin 8 => (#[ByteCodec.encodeK x 0,ByteCodec.encodeK x 1, + ByteCodec.encodeK x 2,ByteCodec.encodeK x 3,ByteCodec.encodeK x 4, + ByteCodec.encodeK x 5,ByteCodec.encodeK x 6,ByteCodec.encodeK x 7])[i.val]!) :: ·) = _ + rw [ih,word_array,ByteCodec.decodeK_encodeK] + rfl + +private theorem bytes_array (a b c d e f g h : Byte) : + List.ofFn (fun i : Fin 8 => (#[a,b,c,d,e,f,g,h])[i.val]!) = [a,b,c,d,e,f,g,h] := by + rfl + +theorem decodeWords_sound (bytes : List Byte) (row : List K) + (decoded : decodeWords bytes = some row) : ByteCodec.wordsBytes row = bytes := by + induction bytes using decodeWords.induct generalizing row with + | case1 => + have eq : row = [] := Option.some.inj decoded.symm + subst row + rfl + | case2 a b c d e f g h rest ih => + simp only [decodeWords,Option.map_eq_some_iff] at decoded + obtain ⟨tail,ht,eq⟩ := decoded + subst row + change List.ofFn (ByteCodec.encodeK (ByteCodec.decodeK + (fun i : Fin 8 => (#[a,b,c,d,e,f,g,h])[i.val]!))) ++ ByteCodec.wordsBytes tail = _ + rw [ByteCodec.encodeK_decodeK,bytes_array,ih tail ht] + rfl + | case3 bytes he => simp [decodeWords] at decoded + +/-- Convert once to an array. The final equality guard rejects wrong lengths +and guarantees exact canonical bytes without a choice of digest halves. -/ +def parsePair (bytes : List Byte) : Option (Digest32 × Digest32) := + let array := bytes.toArray + let pair : Digest32 × Digest32 := + (fun i => array[i.val]?.getD 0, fun i => array[32+i.val]?.getD 0) + if List.ofFn (ByteCodec.pairBytes pair) = bytes then some pair else none + +theorem parsePair_sound (bytes : List Byte) (pair : Digest32 × Digest32) + (decoded : parsePair bytes = some pair) : List.ofFn (ByteCodec.pairBytes pair) = bytes := by + dsimp only [parsePair] at decoded + split at decoded + next he => cases Option.some.inj decoded; exact he + next => contradiction + +theorem parsePair_complete (pair : Digest32 × Digest32) : + parsePair (List.ofFn (ByteCodec.pairBytes pair)) = some pair := by + have eq : ((fun i : Fin 32 => + (List.ofFn (ByteCodec.pairBytes pair)).toArray[i.val]?.getD 0), + (fun i : Fin 32 => + (List.ofFn (ByteCodec.pairBytes pair)).toArray[32+i.val]?.getD 0)) = pair := by + apply Prod.ext + · funext i + have bound : i.val < 64 := by omega + simp only [List.getElem?_toArray,List.getElem?_ofFn,dite_eq_left bound,Option.getD_some, + ByteCodec.pairBytes,dite_eq_left i.isLt] + · funext i + have bound : 32+i.val < 64 := by omega + have above : ¬32+i.val < 32 := by omega + simp only [List.getElem?_toArray,List.getElem?_ofFn,dite_eq_left bound,Option.getD_some, + ByteCodec.pairBytes,dite_eq_right above] + apply congrArg pair.2 + apply Fin.ext + change 32+i.val-32 = i.val + omega + dsimp only [parsePair] + rw [eq] + simp + +def canonicalCodec : Codec where + leaf := decodeWords + pair := parsePair + leaf_sound := decodeWords_sound + leaf_complete := decodeWords_complete + pair_sound := parsePair_sound + pair_complete := parsePair_complete + +end Whir.MerkleQueryLogExtraction diff --git a/verification/whir/Whir/MerkleQueryLogExtractionCost.lean b/verification/whir/Whir/MerkleQueryLogExtractionCost.lean new file mode 100644 index 000000000..50bc002f7 --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionCost.lean @@ -0,0 +1,197 @@ +import Whir.MerkleQueryLogExtractionRows +import Whir.PublicMerkleProbability + +/-! Structural resource certificates. A visit is one preindexed digest lookup +and at most one codec invocation. This is not a unit-cost cryptographic/hash +assumption: hash-table bucket comparisons and public-log saturation are separate. +Record byte lengths are bounded from actual public recovery fuel. -/ +namespace Whir.MerkleQueryLogExtraction +open Concrete FiatShamirGame MerkleTransport.Commitments PublicMerkleLog + +/-- Instrument the same descent, without per-row log scans. -/ +def countedExtract (codec : Codec) (index : Index) : Nat → Digest32 → Tree × Nat + | 0, d => (extract codec index 0 d,1) + | h+1, d => match index[key d]? with + | none => (.absent,1) + | some bytes => match codec.pair bytes with + | none => (.absent,1) + | some (l,r) => + let left := countedExtract codec index h l + let right := countedExtract codec index h r + (.branch left.1 right.1,1+left.2+right.2) + +theorem countedExtract_value (codec : Codec) (index : Index) (height : Nat) (root : Digest32) : + (countedExtract codec index height root).1 = extract codec index height root := by + induction height generalizing root with + | zero => rfl + | succ h ih => + simp only [countedExtract,extract] + cases hi : index[key root]? with + | none => rfl + | some bytes => + cases hp : codec.pair bytes with + | none => simp only [hp] + | some pair => rcases pair with ⟨l,r⟩; simp only [hp,ih] + +theorem countedExtract_visits (codec : Codec) (index : Index) (height : Nat) (root : Digest32) : + (countedExtract codec index height root).2 + 1 ≤ 2^(height+1) := by + induction height generalizing root with + | zero => simp [countedExtract] + | succ h ih => + simp only [countedExtract] + cases hi : index[key root]? with + | none => + have positive : 0 < 2^(h+1) := by positivity + simp only [pow_succ] + omega + | some bytes => + cases hp : codec.pair bytes with + | none => + have positive : 0 < 2^(h+1) := by positivity + simp only [hp,pow_succ] + omega + | some pair => + rcases pair with ⟨l,r⟩ + have hl := ih l + have hr := ih r + simp only [hp] + rw [pow_succ] + omega + +/-- No extracted tree contains more live nodes than this exact full-depth +visit bound. Missing/malformed nodes short-circuit, not scan additional rows. -/ +theorem fixed_depth_visit_budget (codec : Codec) (index : Index) (height : Nat) (root : Digest32) + (N : Nat) (shape : N = 2^height) : + (countedExtract codec index height root).2 < 2*N := by + have h := countedExtract_visits codec index height root + rw [pow_succ,← shape] at h + omega + +theorem build_size (records : Records) : (build records).size ≤ records.length := by + induction records with + | nil => simp [build] + | cons e rest ih => + rcases e with ⟨bytes,d⟩ + have h := Std.ExtHashMap.size_insert_le (m := build rest) (k := key d) (v := bytes) + simp only [build,List.length_cons] + omega + +theorem public_index_size (log : PublicLog) : (build (records log)).size ≤ log.length := + (build_size (records log)).trans (PublicMerkleProbability.records_length log) + +theorem public_record_bytes (log : PublicLog) (bytes : List Byte) (d : Digest32) + (hm : (bytes,d) ∈ records log) : bytes.length ≤ 64*(log.length+2) := by + obtain ⟨n,_,hp⟩ := PublicMerkleBinding.records_origin hm + exact PublicMerkleLog.parse_resource_bound hp + +/-- Actual retained reconstructed payload, not a guessed width budget. -/ +theorem public_payload_bytes (log : PublicLog) : + ((records log).map (fun record => record.1.length)).sum ≤ + log.length * (64*(log.length+2)) := by + have sum := List.sum_le_length_nsmul + ((records log).map (fun record => record.1.length)) (64*(log.length+2)) (by + intro size hm + obtain ⟨⟨bytes,d⟩,member,rfl⟩ := List.mem_map.mp hm + exact public_record_bytes log bytes d member) + have count := PublicMerkleProbability.records_length log + simp only [List.length_map,smul_eq_mul] at sum + exact sum.trans (Nat.mul_le_mul_right _ count) + +theorem public_selected_bytes (log : PublicLog) (root : Digest32) (bytes : List Byte) + (hit : (build (records log))[key root]? = some bytes) : + bytes.length ≤ 64*(log.length+2) := public_record_bytes log bytes root (build_mem hit) + + +def countedFill (default : Array K) : Nat → Array (Array K) × Nat → Array (Array K) × Nat + | 0, state => state + | n+1, state => countedFill default n (state.1.push default,state.2+1) + +theorem countedFill_value (default : Array K) (n : Nat) (state : Array (Array K) × Nat) : + (countedFill default n state).1 = fill default n state.1 := by + induction n generalizing state with + | zero => rfl + | succ n ih => simpa only [countedFill,fill] using ih (state.1.push default,state.2+1) + +theorem countedFill_pushes (default : Array K) (n : Nat) (state : Array (Array K) × Nat) : + (countedFill default n state).2 = state.2+n := by + induction n generalizing state with + | zero => simp [countedFill] + | succ n ih => simp [countedFill,ih,Nat.add_comm,Nat.add_left_comm] + +def countedEmit (width : Nat) (default : Array K) : + Nat → Tree → Array (Array K) × Nat → Array (Array K) × Nat + | 0, .leaf row, state => + (state.1.push (if row.length = width then row.toArray else default),state.2+1) + | h+1, .branch l r, state => + countedEmit width default h r (countedEmit width default h l state) + | h, _, state => countedFill default (2^h) state + +theorem countedEmit_value (width : Nat) (default : Array K) (height : Nat) (tree : Tree) + (state : Array (Array K) × Nat) : + (countedEmit width default height tree state).1 = emit width default height tree state.1 := by + induction height generalizing tree state with + | zero => cases tree <;> simp only [countedEmit,emit,countedFill_value] + | succ h ih => cases tree <;> simp only [countedEmit,emit,countedFill_value,ih] + +theorem countedEmit_pushes (width : Nat) (default : Array K) (height : Nat) (tree : Tree) + (state : Array (Array K) × Nat) : + (countedEmit width default height tree state).2 = state.2+2^height := by + induction height generalizing tree state with + | zero => cases tree <;> simp [countedEmit,countedFill_pushes] + | succ h ih => cases tree <;> + simp only [countedEmit,countedFill_pushes,ih,pow_succ,Nat.mul_two,Nat.add_assoc] + +/-- Exact N output pushes, even for missing subtrees; shared default rows are +allocated once by the wrapper rather than copying a width-sized row N times. -/ +theorem full_materialization_pushes (width height : Nat) (tree : Tree) : + (countedEmit width (Array.replicate width 0) height tree (#[],0)).2 = 2^height := by + simpa only [Nat.zero_add] using countedEmit_pushes width (Array.replicate width 0) + height tree (#[],0) + +def countedRows (codec : Codec) (index : Index) (width : Nat) (default : Array K) : + Nat → Digest32 → Array (Array K) → Array (Array K) × Nat + | 0, root, out => (extractRows codec index width default 0 root out,1) + | h+1, root, out => match index[key root]? with + | none => (fill default (2^(h+1)) out,1) + | some bytes => match codec.pair bytes with + | none => (fill default (2^(h+1)) out,1) + | some (l,r) => + let left := countedRows codec index width default h l out + let right := countedRows codec index width default h r left.1 + (right.1,1+left.2+right.2) + +theorem countedRows_value (codec : Codec) (index : Index) (width : Nat) (default : Array K) + (height : Nat) (root : Digest32) (out : Array (Array K)) : + (countedRows codec index width default height root out).1 = + extractRows codec index width default height root out := by + induction height generalizing root out with + | zero => rfl + | succ h ih => + cases hi : index[key root]? with + | none => simp [countedRows,extractRows,hi] + | some bytes => + cases hp : codec.pair bytes with + | none => simp [countedRows,extractRows,hi,hp] + | some pair => rcases pair with ⟨l,r⟩; simp only [countedRows,extractRows,hi,hp,ih] + +theorem countedRows_visits (codec : Codec) (index : Index) (width : Nat) (default : Array K) + (height : Nat) (root : Digest32) (out : Array (Array K)) : + (countedRows codec index width default height root out).2 = + (countedExtract codec index height root).2 := by + induction height generalizing root out with + | zero => rfl + | succ h ih => + cases hi : index[key root]? with + | none => simp [countedRows,countedExtract,hi] + | some bytes => + cases hp : codec.pair bytes with + | none => simp [countedRows,countedExtract,hi,hp] + | some pair => rcases pair with ⟨l,r⟩; simp only [countedRows,countedExtract,hi,hp,ih] + +theorem fused_visit_budget (codec : Codec) (index : Index) (width height : Nat) (root : Digest32) + (out : Array (Array K)) : + (countedRows codec index width (Array.replicate width 0) height root out).2 < 2*2^height := by + rw [countedRows_visits] + exact fixed_depth_visit_budget codec index height root (2^height) rfl + +end Whir.MerkleQueryLogExtraction diff --git a/verification/whir/Whir/MerkleQueryLogExtractionPublicCost.lean b/verification/whir/Whir/MerkleQueryLogExtractionPublicCost.lean new file mode 100644 index 000000000..db23b3530 --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionPublicCost.lean @@ -0,0 +1,222 @@ +import Whir.MerkleQueryLogExtractionCost + +/-! Actual public-compression saturation accounting. Counters charge one +fixed-size node comparison plus copied/list-visited bytes; the 256-bit digest, +64-byte block and 64-bit counter have fixed size. They do NOT charge calls to a +whole-hash oracle. Every counted interpreter below executes only public answers. +This is an explicit data-operation model, not a wall-clock/compiler cost claim. -/ +namespace Whir.MerkleQueryLogExtraction.PublicCost +open Concrete FiatShamirGame DuplexModeGame DuplexRefinement DuplexFraming PublicMerkleLog + +/-- First public answer, with actual record comparisons counted. -/ +def lookup : PublicLog → Node → Option Digest32 × Nat + | [], _ => (none,0) + | (m,d)::rest, n => if n = m then (some d,1) else + let later := lookup rest n + (later.1,later.2+1) + +theorem lookup_value (log : PublicLog) (n : Node) : (lookup log n).1 = PublicMerkleLog.lookup log n := by + induction log with + | nil => rfl + | cons e rest ih => rcases e with ⟨m,d⟩; simp only [lookup,PublicMerkleLog.lookup]; split <;> simp [ih] + +theorem lookup_steps (log : PublicLog) (n : Node) : (lookup log n).2 ≤ log.length := by + induction log with + | nil => rfl + | cons e rest ih => + rcases e with ⟨m,d⟩ + simp only [lookup,List.length_cons] + split <;> simp only [] <;> omega + +def predecessor : PublicLog → Nat → Digest32 → Option Node × Nat + | [], _, _ => (none,0) + | (n,d)::rest, count, cv => + if d = cv ∧ n.tweak.toNat = count ∧ n.last = false then (some n,1) else + let later := predecessor rest count cv + (later.1,later.2+1) + +theorem predecessor_value (log : PublicLog) (count : Nat) (cv : Digest32) : + (predecessor log count cv).1 = PublicMerkleLog.predecessor log count cv := by + induction log with + | nil => rfl + | cons e rest ih => rcases e with ⟨n,d⟩; simp only [predecessor,PublicMerkleLog.predecessor]; split <;> simp [ih] + +theorem predecessor_steps (log : PublicLog) (count : Nat) (cv : Digest32) : + (predecessor log count cv).2 ≤ log.length := by + induction log with + | nil => rfl + | cons e rest ih => + rcases e with ⟨n,d⟩ + simp only [predecessor,List.length_cons] + split <;> simp only [] <;> omega + +/-- Recovery counts every predecessor scan and the actual prefix copy. -/ +def recover (log : PublicLog) : Nat → Nat → Digest32 → Option (List Byte) × Nat + | 0, _, _ => (none,1) + | fuel+1, count, cv => + if count = 0 then (if cv = DuplexCompression.parameterIV then some [] else none,1) + else if count % 64 = 0 then + let previous := predecessor log count cv + match previous.1 with + | none => (none,previous.2+1) + | some n => + let prior := recover log fuel (count-64) n.cv + match prior.1 with + | none => (none,previous.2+prior.2+1) + | some bytes => (some (bytes ++ List.ofFn n.block),previous.2+prior.2+bytes.length+65) + else (none,1) + +theorem recover_value (log : PublicLog) (fuel count : Nat) (cv : Digest32) : + (recover log fuel count cv).1 = PublicMerkleLog.recover log fuel count cv := by + induction fuel generalizing count cv with + | zero => rfl + | succ fuel ih => + simp only [recover,PublicMerkleLog.recover] + split + next zero => split <;> rfl + next positive => + split + next aligned => + rw [← predecessor_value] + cases hp : (predecessor log count cv).1 with + | none => simp + | some n => + simp only [Option.bind_eq_bind,Option.bind_some] + rw [← ih (count-64) n.cv] + cases (recover log fuel (count-64) n.cv).1 <;> simp + next unaligned => rfl + +def recoverBudget (Q fuel : Nat) : Nat := fuel*(Q+3)+64*fuel*fuel+1 + +theorem recover_steps (log : PublicLog) (fuel count : Nat) (cv : Digest32) : + (recover log fuel count cv).2 ≤ recoverBudget log.length fuel := by + induction fuel generalizing count cv with + | zero => simp [recover,recoverBudget] + | succ fuel ih => + have scan := predecessor_steps log count cv + simp only [recover] + split + next zero => simp [recoverBudget] + next positive => + split + next aligned => + cases hp : (predecessor log count cv).1 with + | none => simp only []; unfold recoverBudget; nlinarith + | some n => + have prior := ih (count-64) n.cv + cases hr : (recover log fuel (count-64) n.cv).1 with + | none => simp only [hr]; unfold recoverBudget at *; nlinarith + | some bytes => + have size := PublicMerkleLog.recover_bound + (by rw [← recover_value]; exact hr) + simp only [hr] + unfold recoverBudget at * + nlinarith + next unaligned => simp [recoverBudget] + +/-- Construct the same chunks, counting list-length scans and bounded take/ +drop work. The 128 charge covers both 64-byte traversals. -/ +def chunks (bytes : List Byte) : List (List Byte) × Nat := + if bytes.length ≤ 64 then ([bytes],bytes.length+1) else + let rest := chunks (bytes.drop 64) + (bytes.take 64 :: rest.1,bytes.length+129+rest.2) +termination_by bytes.length +decreasing_by simp; omega + +theorem chunks_value (bytes : List Byte) : (chunks bytes).1 = PublicMerkleLog.chunks bytes := by + induction bytes using (measure List.length).wf.induction with + | h bytes ih => + rw [chunks,PublicMerkleLog.chunks] + split + next short => rfl + next long => + simp only [] + rw [ih (bytes.drop 64) (by + change (bytes.drop 64).length < bytes.length + simp only [List.length_drop] + omega)] + +theorem chunks_count (bytes : List Byte) : (PublicMerkleLog.chunks bytes).length ≤ bytes.length+1 := by + induction bytes using (measure List.length).wf.induction with + | h bytes ih => + rw [PublicMerkleLog.chunks] + split + next short => simp + next long => + have rest := ih (bytes.drop 64) (by + change (bytes.drop 64).length < bytes.length + simp only [List.length_drop] + omega) + simp only [List.length_cons,List.length_drop] at * + omega + +theorem chunks_steps (bytes : List Byte) : + (chunks bytes).2 ≤ (bytes.length+1)*(bytes.length+130) := by + induction bytes using (measure List.length).wf.induction with + | h bytes ih => + rw [chunks] + split + next short => simp only []; nlinarith + next long => + have rest := ih (bytes.drop 64) (by + change (bytes.drop 64).length < bytes.length + simp only [List.length_drop] + omega) + simp only [List.length_drop] at rest + simp only [] + have length : bytes.length-64+64 = bytes.length := by omega + nlinarith + +/-- Ordinary replay against only recorded answers. Node preparation charges +its actual input length plus 64 padded block slots. -/ +def run (log : PublicLog) (cv : Digest32) (count : Nat) : + List (List Byte) → Option Digest32 × Nat + | [] => (none,1) + | [bytes] => + let answer := lookup log (node cv count bytes true) + (answer.1,answer.2+bytes.length+65) + | bytes :: next :: rest => + let answer := lookup log (node cv count bytes false) + match answer.1 with + | none => (none,answer.2+bytes.length+65) + | some d => + let later := run log d (count+bytes.length) (next::rest) + (later.1,answer.2+bytes.length+65+later.2) + +theorem run_value (log : PublicLog) (cv : Digest32) (count : Nat) (bs : List (List Byte)) : + (run log cv count bs).1 = PublicMerkleLog.run (PublicMerkleLog.lookup log) cv count bs := by + induction bs generalizing cv count with + | nil => rfl + | cons bytes rest ih => + cases rest with + | nil => exact lookup_value log _ + | cons next rest => + simp only [run,PublicMerkleLog.run] + rw [← lookup_value] + cases ha : (lookup log (node cv count bytes false)).1 <;> simp [ih] + +theorem run_steps (log : PublicLog) (cv : Digest32) (count : Nat) (bs : List (List Byte)) : + (run log cv count bs).2 ≤ bs.flatten.length+(bs.length+1)*(log.length+65) := by + induction bs generalizing cv count with + | nil => simp [run] + | cons bytes rest ih => + cases rest with + | nil => + have scan := lookup_steps log (node cv count bytes true) + simp only [run,List.length_cons,List.length_nil,List.flatten_cons,List.flatten_nil, + List.append_nil] + nlinarith + | cons next rest => + have scan := lookup_steps log (node cv count bytes false) + have later := ih + simp only [run] + cases ha : (lookup log (node cv count bytes false)).1 with + | none => + simp only [List.flatten_cons,List.length_append,List.length_cons] + nlinarith + | some d => + have budget := later d (count+bytes.length) + simp only [List.flatten_cons,List.length_append,List.length_cons] at * + nlinarith + +end Whir.MerkleQueryLogExtraction.PublicCost diff --git a/verification/whir/Whir/MerkleQueryLogExtractionResourceContract.lean b/verification/whir/Whir/MerkleQueryLogExtractionResourceContract.lean new file mode 100644 index 000000000..f8e4858f8 --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionResourceContract.lean @@ -0,0 +1,66 @@ +import Whir.MerkleQueryLogExtractionSaturationCost +import Whir.PCSBCSMerkleQueryLog + +/-! End-to-end resource contract in the explicit public-log data-operation +model. Hash-map insertion/lookup invocations are stated separately from the +standard library's internal bucket/instruction costs. Worst-case bucket work +is bounded by resident Q fixed-32-byte keys, not an assumed random digest hash. +No claim is made about wall-clock timings or a Rust allocator refinement. -/ +namespace Whir.MerkleQueryLogExtraction +open Concrete FiatShamirGame PublicMerkleLog MerkleTransport.Commitments PCSBCSMerkleQueryLog + +def countedBuild : Records → Index × Nat + | [] => (∅,0) + | (bytes,d)::rest => + let previous := countedBuild rest + (previous.1.insert (key d) bytes,previous.2+1) + +theorem countedBuild_value (records : Records) : (countedBuild records).1 = build records := by + induction records with + | nil => rfl + | cons e rest ih => rcases e with ⟨bytes,d⟩; simp only [countedBuild,build,ih] + +theorem countedBuild_steps (records : Records) : (countedBuild records).2 = records.length := by + induction records with + | nil => rfl + | cons e rest ih => rcases e with ⟨bytes,d⟩; simp only [countedBuild,List.length_cons,ih] + +theorem rawRoot0_word_slots (log : PublicLog) (root : Digest32) (height width : Nat) : + ((rawRoot0 log root height width).toList.map Array.size).sum ≤ 2^height*width := by + have shape := rawRoot0_shape log root height width + have bound := List.sum_le_length_nsmul + ((rawRoot0 log root height width).toList.map Array.size) width (by + intro size member + obtain ⟨row,hr,rfl⟩ := List.mem_map.mp member + exact le_of_eq (shape.2 row hr)) + simpa only [List.length_map,Array.length_toList,shape.1,smul_eq_mul] using bound + +/-- Cubic one-time compression-log saturation; Q preindex insertions; fewer +than 2N digest lookups/codec invocations; N row pushes; at most N*width occupied +word slots. These are ACTUAL counted computations or actual output sizes. -/ +theorem actual_resource_contract (log : PublicLog) (root : Digest32) (height width Q N : Nat) + (queries : log.length ≤ Q) (rows : N = 2^height) : + (PublicCost.recordsFrom log log).2 ≤ Q*(20000*(Q+2)*(Q+2)+1) ∧ + (countedBuild (records log)).2 ≤ Q ∧ + (build (records log)).size ≤ Q ∧ + ((records log).map (fun record => record.1.length)).sum ≤ Q*(64*(Q+2)) ∧ + (countedRows canonicalCodec (build (records log)) width (Array.replicate width 0) + height root #[]).2 < 2*N ∧ + (rawRoot0 log root height width).size = N ∧ + ((rawRoot0 log root height width).toList.map Array.size).sum ≤ N*width := by + have saturation := PublicCost.actual_saturation_steps log + have saturationCap : log.length*(20000*(log.length+2)*(log.length+2)+1) ≤ + Q*(20000*(Q+2)*(Q+2)+1) := by gcongr + have inserts : (countedBuild (records log)).2 ≤ Q := by + rw [countedBuild_steps] + exact (PublicMerkleProbability.records_length log).trans queries + have storage := public_payload_bytes log + have storageCap : log.length*(64*(log.length+2)) ≤ Q*(64*(Q+2)) := by gcongr + have visits := fused_visit_budget canonicalCodec (build (records log)) width height root #[] + have shape := rawRoot0_shape log root height width + have words := rawRoot0_word_slots log root height width + rw [← rows] at visits shape words + exact ⟨saturation.trans saturationCap,inserts,(public_index_size log).trans queries, + storage.trans storageCap,visits,shape.1,words⟩ + +end Whir.MerkleQueryLogExtraction diff --git a/verification/whir/Whir/MerkleQueryLogExtractionRows.lean b/verification/whir/Whir/MerkleQueryLogExtractionRows.lean new file mode 100644 index 000000000..0845b786e --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionRows.lean @@ -0,0 +1,170 @@ +import Whir.MerkleQueryLogExtractionCodec + +/-! Full fixed-height row materialization. The extractor traverses the tree +once and uses a single mutable array accumulator. Shape defaults remain marked +by the extracted tree's absence/width branch; they are not witness fallbacks. +Initial Merkle/decoder rows are RAW. Coefficient/fold order is separate. -/ +namespace Whir.MerkleQueryLogExtraction +open Concrete FiatShamirGame MerkleTransport + +def normalize (width : Nat) (row : List K) : Array K := + if row.length = width then row.toArray else Array.replicate width 0 + +theorem normalize_size (width : Nat) (row : List K) : (normalize width row).size = width := by + simp only [normalize] + split <;> simp_all + +def fill (default : Array K) : Nat → Array (Array K) → Array (Array K) + | 0, out => out + | n+1, out => fill default n (out.push default) + +theorem fill_list (default : Array K) (n : Nat) (out : Array (Array K)) : + (fill default n out).toList = out.toList ++ List.replicate n default := by + induction n generalizing out with + | zero => simp [fill] + | succ n ih => + simp only [fill,ih,Array.toList_push,List.append_assoc,List.replicate_succ, + List.singleton_append] + +/-- Specification only. The executable accumulator does not construct or +concatenate this list. -/ +def rowsSpec (width : Nat) : Nat → Tree → List (Array K) + | 0, .leaf row => [normalize width row] + | h+1, .branch l r => rowsSpec width h l ++ rowsSpec width h r + | h, _ => List.replicate (2^h) (Array.replicate width 0) + +def emit (width : Nat) (default : Array K) : Nat → Tree → Array (Array K) → Array (Array K) + | 0, .leaf row, out => out.push (if row.length = width then row.toArray else default) + | h+1, .branch l r, out => emit width default h r (emit width default h l out) + | h, _, out => fill default (2^h) out + +def fullRows (width height : Nat) (tree : Tree) : Array (Array K) := + emit width (Array.replicate width 0) height tree #[] + +/-- Production full-row extraction fuses preimage descent and emission. +No intermediate tree or per-row root-to-leaf path is allocated. -/ +def extractRows (codec : Codec) (index : Index) (width : Nat) (default : Array K) : + Nat → Digest32 → Array (Array K) → Array (Array K) + | 0, root, out => match index[key root]? with + | none => out.push default + | some bytes => match codec.leaf bytes with + | none => out.push default + | some row => out.push (if row.length = width then row.toArray else default) + | h+1, root, out => match index[key root]? with + | none => fill default (2^(h+1)) out + | some bytes => match codec.pair bytes with + | none => fill default (2^(h+1)) out + | some (l,r) => extractRows codec index width default h r + (extractRows codec index width default h l out) + +theorem extractRows_eq_emit (codec : Codec) (index : Index) (width : Nat) (default : Array K) + (height : Nat) (root : Digest32) (out : Array (Array K)) : + extractRows codec index width default height root out = + emit width default height (extract codec index height root) out := by + induction height generalizing root out with + | zero => + cases hi : index[key root]? with + | none => simp [extractRows,extract,hi,emit,fill] + | some bytes => + cases hl : codec.leaf bytes <;> simp [extractRows,extract,hi,hl,emit,fill] + | succ h ih => + cases hi : index[key root]? with + | none => simp [extractRows,extract,hi,emit] + | some bytes => + cases hp : codec.pair bytes with + | none => simp [extractRows,extract,hi,hp,emit] + | some pair => + rcases pair with ⟨l,r⟩ + simp only [extractRows,extract,hi,hp,emit,ih] + +theorem emit_spec (width height : Nat) (tree : Tree) (out : Array (Array K)) : + (emit width (Array.replicate width 0) height tree out).toList = + out.toList ++ rowsSpec width height tree := by + induction height generalizing tree out with + | zero => cases tree <;> simp [emit,rowsSpec,fill_list,normalize] + | succ h ih => + cases tree <;> simp only [emit,rowsSpec,fill_list,ih,List.append_assoc] + +theorem fullRows_spec (width height : Nat) (tree : Tree) : + (fullRows width height tree).toList = rowsSpec width height tree := by + simpa [fullRows] using emit_spec width height tree #[] + +theorem rowsSpec_length (width height : Nat) (tree : Tree) : + (rowsSpec width height tree).length = 2^height := by + induction height generalizing tree with + | zero => cases tree <;> simp [rowsSpec] + | succ h ih => cases tree <;> simp [rowsSpec,ih,pow_succ,Nat.mul_two] + +theorem fullRows_size (width height : Nat) (tree : Tree) : + (fullRows width height tree).size = 2^height := by + have length := congrArg List.length (fullRows_spec width height tree) + simpa only [Array.length_toList,rowsSpec_length] using length + +theorem rowsSpec_width (width height : Nat) (tree : Tree) : + ∀ row ∈ rowsSpec width height tree, row.size = width := by + induction height generalizing tree with + | zero => cases tree <;> simp [rowsSpec,normalize_size] + | succ h ih => + cases tree with + | absent => simp [rowsSpec] + | leaf row => simp [rowsSpec] + | branch l r => + intro row hm + rcases List.mem_append.mp hm with hl | hr + · exact ih l row hl + · exact ih r row hr + +theorem fullRows_width (width height : Nat) (tree : Tree) : + ∀ row ∈ (fullRows width height tree).toList, row.size = width := by + rw [fullRows_spec] + exact rowsSpec_width width height tree + +/-- Coefficient-ascending order, NOT the decoder input. The decoder accepts +raw occupied leaves and its receivedLane/fullRow apply the reversal internally. -/ +def root0CoefficientOrder (raw : Array (Array K)) : Array (Array K) := raw.map Array.reverse + +theorem root0CoefficientOrder_size (raw : Array (Array K)) : + (root0CoefficientOrder raw).size = raw.size := by simp [root0CoefficientOrder] + +theorem root0CoefficientOrder_width (occupied : Nat) (raw : Array (Array K)) + (shape : ∀ row ∈ raw.toList, row.size = occupied) : + ∀ row ∈ (root0CoefficientOrder raw).toList, row.size = occupied := by + intro row hm + simp only [root0CoefficientOrder,Array.toList_map,List.mem_map] at hm + obtain ⟨source,hs,rfl⟩ := hm + simpa using shape source hs + +theorem root0CoefficientOrder_raw (raw : Array (Array K)) (index : Nat) (bound : index < raw.size) : + (root0CoefficientOrder raw)[index]'(by simpa [root0CoefficientOrder_size] using bound) = + raw[index].reverse := by + simp [root0CoefficientOrder] + +theorem root0CoefficientOrder_involutive (raw : Array (Array K)) : + root0CoefficientOrder (root0CoefficientOrder raw) = raw := by + simp [root0CoefficientOrder,Array.map_map,Function.comp_def] + +/-- Separate first-fold boundary, NOT the compact decoder input: reverse +occupied raw lanes then append virtual zero lanes. Never use this operation on +an already-normalized logical Snapshot. -/ +def root0Consumer (occupied padded : Nat) (raw : Array (Array K)) : Array (Array K) := + raw.map fun row => row.reverse ++ Array.replicate (padded-occupied) 0 + +theorem root0Consumer_size (occupied padded : Nat) (raw : Array (Array K)) : + (root0Consumer occupied padded raw).size = raw.size := by simp [root0Consumer] + +theorem root0Consumer_width (occupied padded : Nat) (fits : occupied ≤ padded) + (raw : Array (Array K)) (shape : ∀ row ∈ raw.toList, row.size = occupied) : + ∀ row ∈ (root0Consumer occupied padded raw).toList, row.size = padded := by + intro row hm + simp only [root0Consumer,Array.toList_map,List.mem_map] at hm + obtain ⟨source,hs,rfl⟩ := hm + simp only [Array.size_append,Array.size_reverse,Array.size_replicate,shape source hs] + omega + +theorem root0Consumer_raw (occupied padded : Nat) (raw : Array (Array K)) + (index : Nat) (bound : index < raw.size) : + (root0Consumer occupied padded raw)[index]'(by simpa [root0Consumer_size] using bound) = + raw[index].reverse ++ Array.replicate (padded-occupied) 0 := by + simp [root0Consumer] + +end Whir.MerkleQueryLogExtraction diff --git a/verification/whir/Whir/MerkleQueryLogExtractionRowsAgreement.lean b/verification/whir/Whir/MerkleQueryLogExtractionRowsAgreement.lean new file mode 100644 index 000000000..a67c89f4f --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionRowsAgreement.lean @@ -0,0 +1,131 @@ +import Whir.MerkleQueryLogExtractionRows + +/-! The emitted table is in ascending physical leaf-index order. This is a +checked agreement with the existing ideal full Snapshot table, not a different +address enumeration convention. -/ +namespace Whir.MerkleQueryLogExtraction +open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments + +private theorem address_top (index h : Nat) (below : List Bool) : + addressAbove index (h+1) below = + right (index / 2^h) :: addressAbove index h below := by + induction h generalizing index below with + | zero => simp [addressAbove] + | succ h ih => + rw [addressAbove,ih] + simp only [Nat.div_div_eq_div_mul,pow_succ,Nat.mul_comm] + rfl + +private theorem address_mod (index h : Nat) (below : List Bool) : + addressAbove (index % 2^h) h below = addressAbove index h below := by + induction h generalizing index below with + | zero => rfl + | succ h ih => + rw [addressAbove,addressAbove] + have parity : right (index % 2^(h+1)) = right index := by + simp only [right,MerkleLevels.right,pow_succ,Nat.mul_comm (2^h) 2, + Nat.mod_mul_right_mod] + rw [parity] + rw [pow_succ,Nat.mod_mul_left_div_self,ih] + +private theorem normalize_default (width : Nat) : + normalize width (List.replicate width 0) = Array.replicate width 0 := by + simp [normalize] + +/-- Optional indexing avoids invented rows outside the full fixed tree. -/ +theorem rowsSpec_get (width height : Nat) (tree : Tree) (index : Nat) + (inside : index < 2^height) : + (rowsSpec width height tree)[index]? = + some (normalize width (tree.row (List.replicate width 0) (addressAbove index height []))) := by + induction height generalizing tree index with + | zero => + have eq : index = 0 := by simpa using inside + subst index + cases tree <;> simp [rowsSpec,Tree.row,Tree.get,addressAbove,normalize_default] + | succ h ih => + have pos : 0 < 2^h := by positivity + have full : index < 2^h*2 := by simpa [pow_succ] using inside + rw [address_top] + cases tree with + | absent => simp [rowsSpec,Tree.row,Tree.get,inside,normalize_default] + | leaf row => simp [rowsSpec,Tree.row,Tree.get,inside,normalize_default] + | branch l r => + by_cases lower : index < 2^h + · have hd : index / 2^h = 0 := Nat.div_eq_of_lt lower + simp only [rowsSpec,Tree.row,Tree.get,hd,right,MerkleLevels.right, + Nat.reduceMod,Nat.reduceBEq] + rw [List.getElem?_append_left (by simpa [rowsSpec_length] using lower)] + exact ih l index lower + · have upper : index-2^h < 2^h := by omega + have hd : index / 2^h = 1 := + Nat.div_eq_of_lt_le (by simpa using Nat.le_of_not_gt lower) + (by simpa [Nat.mul_comm] using full) + have hm : index % 2^h = index-2^h := by + rw [Nat.mod_eq_sub_mod (Nat.le_of_not_gt lower),Nat.mod_eq_of_lt upper] + have ha : addressAbove index h [] = addressAbove (index-2^h) h [] := by + rw [← hm] + exact (address_mod index h []).symm + simp only [rowsSpec,Tree.row,Tree.get,hd,right,MerkleLevels.right, + Nat.reduceMod,Nat.reduceBEq,↓reduceIte] + rw [List.getElem?_append_right (by simpa [rowsSpec_length] using Nat.le_of_not_gt lower)] + rw [rowsSpec_length,ha] + exact ih r (index-2^h) upper + +theorem fullRows_get (width height : Nat) (tree : Tree) (index : Nat) + (inside : index < 2^height) : + (fullRows width height tree)[index]? = + some (normalize width (tree.row (List.replicate width 0) (addressAbove index height []))) := by + rw [← Array.getElem?_toList,fullRows_spec] + exact rowsSpec_get width height tree index inside + +/-- A zero-default Snapshot agrees at EVERY index, including absent paths and +malformed-width paths. No availability assumption is present. -/ +theorem fullRows_eq_snapshot (codec : Codec) (hash : Primitive) (records : Records) + (auth : Authentic hash records) + (clean : ¬ MerkleBinding.Collision (hashing hash) (recordDomain records)) + (root : Digest32) (height width : Nat) : + fullRows width height (extract codec (build records) height root) = + baseOracle hash ⟨recordDomain records,List.replicate width 0⟩ root height (2^height) width := by + apply Array.ext + · simp [fullRows_size,baseOracle_size] + · intro index left right + have inside : index < 2^height := by simpa only [fullRows_size] using left + have hg := fullRows_get width height (extract codec (build records) height root) index inside + have he := extract_eq_ideal codec hash records auth clean root (List.replicate width 0) + (addressAbove index height []) + rw [addressAbove_length] at he + simp only [List.length_nil,Nat.add_zero] at he + have hn : normalize width + ((extract codec (build records) height root).row (List.replicate width 0) + (addressAbove index height [])) = + (baseRow hash ⟨recordDomain records,List.replicate width 0⟩ root height index width).toArray := by + rw [he] + unfold normalize baseRow row oracle + split <;> simp_all + rw [hn] at hg + have hl := Option.some.inj ((Array.getElem?_eq_getElem left).symm.trans hg) + simpa only [baseOracle,Array.getElem_ofFn] using hl + +private theorem baseRow_empty_default (hash : Primitive) (table : Finset (List Byte)) + (root : Digest32) (height index width : Nat) : + baseRow hash ⟨table,List.replicate width 0⟩ root height index width = + baseRow hash ⟨table,[]⟩ root height index width := by + classical + by_cases recorded : ∃ path : MerkleBinding.Opening (List K) Digest32 + (addressAbove index height []), + path.inputs (hashing hash) ⊆ table ∧ path.digest (hashing hash) = root + · simp only [baseRow,row,oracle,MerkleBinding.idealRow,dite_eq_left recorded] + · cases width <;> simp [baseRow,row,oracle,MerkleBinding.idealRow,recorded] + +/-- The existing registry's empty book-default convention gives the same +shape-normalized full table, including absent leaves. -/ +theorem fullRows_eq_empty_snapshot (codec : Codec) (hash : Primitive) (records : Records) + (auth : Authentic hash records) + (clean : ¬ MerkleBinding.Collision (hashing hash) (recordDomain records)) + (root : Digest32) (height width : Nat) : + fullRows width height (extract codec (build records) height root) = + baseOracle hash ⟨recordDomain records,[]⟩ root height (2^height) width := by + rw [fullRows_eq_snapshot codec hash records auth clean root height width] + simp only [baseOracle,baseRow_empty_default] + +end Whir.MerkleQueryLogExtraction diff --git a/verification/whir/Whir/MerkleQueryLogExtractionSaturationCost.lean b/verification/whir/Whir/MerkleQueryLogExtractionSaturationCost.lean new file mode 100644 index 000000000..cff975503 --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionSaturationCost.lean @@ -0,0 +1,125 @@ +import Whir.MerkleQueryLogExtractionPublicCost + +/-! Polynomial cost of saturating the ACTUAL public compression log once. +The counted parser's value is exactly PublicMerkleLog.records, including +rejection of incomplete/malformed chains. No availability assumption is used. +Together with fused_visit_budget/N pushes this is polynomial in Q,N,width. -/ +namespace Whir.MerkleQueryLogExtraction.PublicCost +open Concrete FiatShamirGame DuplexModeGame DuplexRefinement DuplexFraming PublicMerkleLog +open MerkleTransport.Commitments + +/-- Replay and reconstruction are executed once, with their actual counters. -/ +def parse (log : PublicLog) (n : Node) (answer : Digest32) : Option (List Byte) × Nat := + if n.last != true then (none,1) else + let size := finalLength n.tweak.toNat + let recovered := recover log (log.length+1) (n.tweak.toNat-size) n.cv + match recovered.1 with + | none => (none,recovered.2+1) + | some prior => + let bytes := prior ++ (List.ofFn n.block).take size + let pieces := chunks bytes + let replay := run log DuplexCompression.parameterIV 0 pieces.1 + (if replay.1 = some answer then some bytes else none, + recovered.2+prior.length+64+pieces.2+replay.2+34) + +theorem parse_value (log : PublicLog) (n : Node) (answer : Digest32) : + (parse log n answer).1 = PublicMerkleLog.parse log n answer := by + unfold parse PublicMerkleLog.parse + split + next rejected => rfl + next final => + dsimp only + rw [← recover_value] + cases hp : (recover log (log.length+1) + (n.tweak.toNat-finalLength n.tweak.toNat) n.cv).1 with + | none => simp + | some prior => + simp only [Option.bind_eq_bind,Option.bind_some] + rw [chunks_value,run_value] + +def parseBudget (Q : Nat) : Nat := 20000*(Q+2)*(Q+2) + +theorem parse_steps (log : PublicLog) (n : Node) (answer : Digest32) : + (parse log n answer).2 ≤ parseBudget log.length := by + have prefixCost := recover_steps log (log.length+1) + (n.tweak.toNat-finalLength n.tweak.toNat) n.cv + unfold parse + split + next rejected => simp only [parseBudget]; nlinarith + next final => + dsimp only + cases hp : (recover log (log.length+1) + (n.tweak.toNat-finalLength n.tweak.toNat) n.cv).1 with + | none => simp only []; unfold recoverBudget at prefixCost; unfold parseBudget; nlinarith + | some prior => + have priorSize := PublicMerkleLog.recover_bound (by rw [← recover_value]; exact hp) + let bytes := prior ++ (List.ofFn n.block).take (finalLength n.tweak.toNat) + have byteSize : bytes.length ≤ 64*(log.length+2) := by + have tail : ((List.ofFn n.block).take (finalLength n.tweak.toNat)).length ≤ 64 := by + simp only [List.length_take,List.length_ofFn]; exact Nat.min_le_right _ _ + dsimp only [bytes] + simp only [List.length_append] + omega + have chunkCost := chunks_steps bytes + have chunkBudget : (chunks bytes).2 ≤ + (64*(log.length+2)+1)*(64*(log.length+2)+130) := + chunkCost.trans (Nat.mul_le_mul (by omega) (by omega)) + have replayCost := run_steps log DuplexCompression.parameterIV 0 (chunks bytes).1 + rw [chunks_value,PublicMerkleLog.chunks_flatten] at replayCost + have count := chunks_count bytes + have replayBudget : (run log DuplexCompression.parameterIV 0 (chunks bytes).1).2 ≤ + 64*(log.length+2)+(64*(log.length+2)+2)*(log.length+65) := by + rw [chunks_value] + apply replayCost.trans + apply Nat.add_le_add byteSize + apply Nat.mul_le_mul_right + omega + simp only [] + change (recover log (log.length+1) + (n.tweak.toNat-finalLength n.tweak.toNat) n.cv).2 + prior.length + 64 + + (chunks bytes).2 + (run log DuplexCompression.parameterIV 0 (chunks bytes).1).2 + 34 ≤ _ + unfold recoverBudget at prefixCost + unfold parseBudget + nlinarith + +def recordsFrom (log : PublicLog) : PublicLog → Records × Nat + | [] => ([],0) + | (n,d)::rest => + let current := parse log n d + let later := recordsFrom log rest + (match current.1 with + | none => later.1 + | some bytes => (bytes,d)::later.1, + current.2+later.2+1) + +theorem recordsFrom_value (log entries : PublicLog) : + (recordsFrom log entries).1 = entries.filterMap + (fun (n,d) => (PublicMerkleLog.parse log n d).map (fun bytes => (bytes,d))) := by + induction entries with + | nil => rfl + | cons e rest ih => + rcases e with ⟨n,d⟩ + simp only [recordsFrom,List.filterMap_cons] + rw [← parse_value log n d] + cases hp : (parse log n d).1 <;> simp only [Option.map_none,Option.map_some,ih] + +theorem recordsFrom_steps (log entries : PublicLog) : + (recordsFrom log entries).2 ≤ entries.length*(parseBudget log.length+1) := by + induction entries with + | nil => simp [recordsFrom] + | cons e rest ih => + rcases e with ⟨n,d⟩ + have current := parse_steps log n d + simp only [recordsFrom,List.length_cons] + nlinarith + +/-- Complete saturation is cubic in the actual shared compression budget. +This cost is paid ONCE before preindexing/tree descent, never per output row. -/ +theorem actual_records_value (log : PublicLog) : + (recordsFrom log log).1 = PublicMerkleLog.records log := recordsFrom_value log log + +theorem actual_saturation_steps (log : PublicLog) : + (recordsFrom log log).2 ≤ log.length*(20000*(log.length+2)*(log.length+2)+1) := + recordsFrom_steps log log + +end Whir.MerkleQueryLogExtraction.PublicCost diff --git a/verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean b/verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean new file mode 100644 index 000000000..03c50a426 --- /dev/null +++ b/verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean @@ -0,0 +1,57 @@ +import Whir.PCSBCSMerkleRootCache + +/-! Native executable smoke: actual BLAKE2s compression records, including a +multiblock occupied row, repeated registration, tampering, absence, malformed +bytes, and an explicit inconsistent-output record set. No native_decide proof. -/ +namespace Whir.MerkleQueryLogExtractionSmoke +open Concrete FiatShamirGame DuplexModeGame PublicMerkleLog +open MerkleQueryLogExtraction PCSBCSMerkleQueryLog + +private def require (condition : Bool) (message : String) : IO Unit := + unless condition do throw (IO.userError message) + +def smoke : IO Unit := do + let left : List K := (List.range 9).map fun n => UInt64.ofNat (n+1) + let right : List K := (List.range 9).map fun n => UInt64.ofNat (n+21) + let lb := ByteCodec.wordsBytes left + let rb := ByteCodec.wordsBytes right + let ld := hashBlake2s lb + let rd := hashBlake2s rb + let pb := List.ofFn (ByteCodec.pairBytes (ld,rd)) + let root := hashBlake2s pb + let honest := plan blake2sOracle lb ++ plan blake2sOracle rb ++ plan blake2sOracle pb + let table := rawRoot0 honest root 1 9 + require (table.toList.map Array.toList == [left,right]) "honest full Root0 rows differ" + require ((root0Consumer 9 16 table)[0]!.toList == left.reverse ++ List.replicate 7 0) + "separate first-fold occupied-lane reversal/padding differs" + let missing := plan blake2sOracle rb ++ plan blake2sOracle pb + let mt := fromPublic missing root 1 + require (mt.get [false] == none && mt.get [true] == some right) + "missing preimage was forged or available sibling was lost" + require ((rawRoot0 missing root 1 9).toList.map Array.toList == + [List.replicate 9 0,right]) "explicit absence default or full table order differs" + require ((rawRoot0 honest root 1 8).toList.map Array.toList == + [List.replicate 8 0,List.replicate 8 0]) "malformed width was not defaulted" + let registry := PCSBCSMerkleRootCache.register ∅ honest root ⟨1,9⟩ + let repeated := PCSBCSMerkleRootCache.register registry missing root ⟨0,8⟩ + require ((repeated[key root]?).map (fun frozen => frozen.raw.toList.map Array.toList) == + some [left,right]) "first root registration was recomputed or replaced" + let tampered : PublicLog := honest.map fun e => + if e.1 = node DuplexCompression.parameterIV 0 pb true then (e.1,ld) else e + require ((fromPublic tampered root 1).get [false] == none) + "tampered final root answer was accepted" + require (decodeWords [0] == none && parsePair [0] == none) + "malformed leaf/pair bytes were accepted" + let collisionRecords : MerkleTransport.Commitments.Records := [(lb,ld),(rb,ld)] + let indexed := build collisionRecords + require (indexed[key ld]? == some lb) "first collision registration was not retained" + require ((register indexed rb ld)[key ld]? == some lb) "cached registration was overwritten" + require ((extract canonicalCodec indexed 0 ld).get [] == some left) + "collision case was not deterministic" + require ((fromPublic honest root 0).get [] != some left) + "untagged digest depth was silently erased" + IO.println "Merkle query-log extraction smoke PASS (honest/tampered/missing/malformed/collision/lane-order)" + +end Whir.MerkleQueryLogExtractionSmoke + +def main : IO Unit := Whir.MerkleQueryLogExtractionSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSMerkleOpenedTable.lean b/verification/whir/Whir/PCSBCSMerkleOpenedTable.lean new file mode 100644 index 000000000..1bd7a0e88 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleOpenedTable.lean @@ -0,0 +1,43 @@ +import Whir.PCSBCSMerkleSourceRows + +/-! Actual accepted Root0 transport rows agree with the executable full table, +in query occurrence order including duplicate queries. No ideal oracle is +passed to the runtime decoder; the table consists solely of frozen log data. -/ +namespace Whir.PCSBCSMerkleSourceRows +open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments +open MerkleQueryLogExtraction PCSBCSMerkleQueryLog PublicMerkleLog PublicMerkleBinding + +theorem pruned_opened_table (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (root : Digest32) (proof : PrunedMerklePaths) + (numLeaves occupied : Nat) (queries : List Nat) (output : List RawPath) + (accepted : proof.open (hash C) root numLeaves queries occupied occupied = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : + List.Forall₂ (fun q p => (rawRoot0 log root numLeaves.log2 occupied)[q]! = p.leafData.toArray) + queries output ∨ OpenPrimitiveBad C log root output := by + have refined := open_refines (hash C) proof root numLeaves queries occupied occupied output accepted + have conditions := ((open_spec (hash C) proof root numLeaves queries occupied occupied output).mp accepted).1 + rcases pruned_opened_rows C log auth root proof numLeaves occupied queries output accepted bounds with good | bad + · left + apply List.forall₂_of_length_eq_of_get refined.length_eq + intro i hi ho + obtain ⟨stored,hs,hw,hindex,hdata,hlen,hdepth,hroot⟩ := refined.get hi ho + have hq := conditions.range (queries.get ⟨i,hi⟩) (List.get_mem _ _) + have inside : queries.get ⟨i,hi⟩ < 2^numLeaves.log2 := by + simpa only [conditions.power] using hq + have tree := good (output.get ⟨i,ho⟩) (List.get_mem _ _) + rw [hindex] at tree + have table := fullRows_get occupied numLeaves.log2 (fromPublic log root numLeaves.log2) + (queries.get ⟨i,hi⟩) inside + simp only [Tree.row,tree,Option.getD_some,MerkleQueryLogExtraction.normalize,hlen,↓reduceIte] at table + have bound : queries.get ⟨i,hi⟩ < + (fullRows occupied numLeaves.log2 (fromPublic log root numLeaves.log2)).size := by + simpa only [fullRows_size] using inside + rw [Array.getElem?_eq_getElem bound] at table + have result := Option.some.inj table + rw [rawRoot0_eq_fullRows] + simpa only [getElem!_pos + (fullRows occupied numLeaves.log2 (fromPublic log root numLeaves.log2)) + (queries.get ⟨i,hi⟩) bound] using result + · exact Or.inr bad + +end Whir.PCSBCSMerkleSourceRows diff --git a/verification/whir/Whir/PCSBCSMerkleQueryLog.lean b/verification/whir/Whir/PCSBCSMerkleQueryLog.lean new file mode 100644 index 000000000..b7356f1c7 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleQueryLog.lean @@ -0,0 +1,138 @@ +import Whir.MerkleQueryLogExtractionRows +import Whir.PublicMerkleProbability + +/-! PCS-only deterministic Merkle slice. Runtime input is the ordinary public +compression trace, not a whole-hash oracle. Probability is the existing shared +256-bit random-compression game, with actual root policy and compression budget. +This module makes no claim about real BLAKE2s or whole-system Fiat-Shamir. -/ +namespace Whir.PCSBCSMerkleQueryLog +open Concrete FiatShamirGame DuplexModeGame PublicMerkleLog PublicMerkleBinding +open MerkleTransport MerkleTransport.Commitments MerkleBinding +open MerkleQueryLogExtraction PublicMerkleProbability PublicCompressionProgram +open DuplexFraming TypedOracleCompiler + +/-- Saturate the frozen public compression trace once, preindex the completed +ordinary hash records once, then traverse the fixed-depth tree once. -/ +def fromPublic (log : PublicLog) (root : Digest32) (height : Nat) : Tree := + extract canonicalCodec (build (records log)) height root + +/-- Literal raw occupied leaves, prepared for the source decoder. Its +`receivedLane`/`fullRow` perform the source lane reversal themselves. Passing +the coefficient-order or padded first-fold table instead would double reverse. -/ +def rawRoot0 (log : PublicLog) (root : Digest32) (height occupied : Nat) : Array (Array K) := + extractRows canonicalCodec (build (records log)) occupied (Array.replicate occupied 0) height root #[] + +theorem rawRoot0_eq_fullRows (log : PublicLog) (root : Digest32) (height occupied : Nat) : + rawRoot0 log root height occupied = fullRows occupied height (fromPublic log root height) := by + exact extractRows_eq_emit canonicalCodec (build (records log)) occupied + (Array.replicate occupied 0) height root #[] + +theorem rawRoot0_shape (log : PublicLog) (root : Digest32) (height occupied : Nat) : + (rawRoot0 log root height occupied).size = 2^height ∧ + ∀ row ∈ (rawRoot0 log root height occupied).toList, row.size = occupied := by + rw [rawRoot0_eq_fullRows] + exact ⟨fullRows_size occupied height _,fullRows_width occupied height _⟩ + +/-- Collision exclusion is the concrete observed compression event. It is +DERIVED into whole-hash preimage uniqueness rather than assumed as a field. -/ +theorem public_eq_snapshot (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) + (root : Digest32) (fallback : List K) (address : List Bool) : + (fromPublic log root address.length).row fallback address = + idealRow (hashing (hash C)) (recordDomain (records log)) root fallback address := + extract_eq_ideal canonicalCodec (hash C) (records log) (records_authentic C log auth) + (fun bad => clean (reconstructed_collision C log auth bad)) root fallback address + +/-- Full-height accepted raw rows agree with the executable frozen tree, or +expose the existing collision/fresh-target compression witness. The statement +also covers absence and malformed preimages: they cannot pass silently. -/ +theorem opened_rows (C : PrimitiveOracle) (log : PublicLog) (auth : AuthenticLog C log) + (root : Digest32) (height : Nat) (output : List RawPath) + (depth : ∀ p ∈ output, p.path.length = height) + (accepted : ∀ p ∈ output, p.root (hash C) = root) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : + (∀ p ∈ output, (fromPublic log root height).get + (addressAbove p.leafIndex height []) = some p.leafData) ∨ + OpenPrimitiveBad C log root output := by + classical + by_cases collision : OutputCollision log + · exact Or.inr (Or.inl collision) + have clean : ¬ Collision (hashing (hash C)) (recordDomain (records log)) := + fun bad => collision (reconstructed_collision C log auth bad) + by_cases fresh : ∃ p ∈ output, FreshHit (hashing (hash C)) (recordDomain (records log)) root + (p.opening.inputs (hashing (hash C))) + · obtain ⟨p,hp,hfresh⟩ := fresh + rcases freshHit_primitive C log auth root _ (bounds p hp) hfresh with hc | hf + · exact Or.inr (Or.inl hc) + · exact Or.inr (Or.inr ⟨p,hp,hf⟩) + · left + intro p hp + have noFresh : ¬ FreshHit (hashing (hash C)) (recordDomain (records log)) root + (p.opening.inputs (hashing (hash C))) := fun bad => fresh ⟨p,hp,bad⟩ + have recorded := (recorded_or_fresh (hashing (hash C)) (recordDomain (records log)) root + p.opening (Or.inl ((p.opening_digest (hash C)).trans (accepted p hp)))).resolve_right noFresh + have result := extract_complete canonicalCodec (hash C) (records log) + (records_authentic C log auth) clean p.opening recorded + simpa only [fromPublic,RawPath.opening_digest,accepted p hp,RawPath.opening_row, + addressAbove_length,List.length_nil,Nat.add_zero,depth p hp] using result + +/-- A single causal terminal event covers ANY freeze/configuration/extraction +in the one actual trace. There is no union factor for rows or clones, and no +assumed multi-extractability interface. -/ +def FrozenExtractionBad (C : PrimitiveOracle) (roots : RootPolicy) (trace : PublicLog) : Prop := + ∃ (before after oldLog : PublicLog) (root : Digest32) (height : Nat) (output : List RawPath), + trace = before ++ after ∧ + (∀ e ∈ oldLog, e ∈ before) ∧ + (∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ oldLog) ∧ + root ∈ roots before.reverse ∧ + (∀ p ∈ output, p.path.length = height) ∧ + (∀ p ∈ output, p.root (hash C) = root) ∧ + (∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^56) ∧ + (∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), + ∀ e ∈ PublicMerkleLog.plan C bytes, e ∈ trace) ∧ + ∃ p ∈ output, (fromPublic oldLog root height).get + (addressAbove p.leafIndex height []) ≠ some p.leafData + +theorem extraction_bad_opening_bad (C : PrimitiveOracle) (roots : RootPolicy) + (trace : PublicLog) (auth : AuthenticLog C trace) (bad : FrozenExtractionBad C roots trace) : + FrozenOpeningBad C roots trace := by + obtain ⟨before,after,oldLog,root,height,output,he,sub,ordinary,registered, + depth,accepted,bounds,plans,p,hp,mismatch⟩ := bad + have oldAuth : AuthenticLog C oldLog := by + intro n d hm + apply auth n d + rw [he] + exact List.mem_append_left _ (sub _ hm) + have wider : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64 := by + intro p hp bytes hb + exact lt_of_lt_of_le (bounds p hp bytes hb) (by norm_num) + have primitive : OpenPrimitiveBad C oldLog root output := by + rcases opened_rows C oldLog oldAuth root height output depth accepted wider with good | bad + · exact (mismatch (good p hp)).elim + · exact bad + exact ⟨before,after,oldLog,root,output,he,sub,ordinary,registered,bounds,plans,primitive⟩ + +noncomputable def extractionProbability {T : Type} (roots : RootPolicy) {Q : Nat} + (p : Computation T Q) : ℚ := by + classical + exact average (fun C : PrimitiveOracle => + if FrozenExtractionBad C roots (toLog (Sampling.execute C p).2) then 1 else 0) + +/-- Q is the actual full shared compression-call budget, not the number of +whole hashes. Q+1 is the independently checked root-announcement cap. The +root policy retains announced roots across causal public-call boundaries. -/ +theorem multi_extraction_probability {T : Type} (roots : RootPolicy) (Q : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ Q+1) + (grow : RootsGrow roots) (p : Computation T Q) : + extractionProbability roots p ≤ bound Q (Q+1) := by + classical + apply le_trans _ (opening_probability_bound roots Q (Q+1) rootCap grow p) + apply average_mono + intro C + by_cases bad : FrozenExtractionBad C roots (toLog (Sampling.execute C p).2) + · have covered := extraction_bad_opening_bad C roots _ (execute_authentic C p) bad + simp only [bad,covered,↓reduceIte,le_refl] + · simp only [bad,↓reduceIte] + split <;> norm_num + +end Whir.PCSBCSMerkleQueryLog diff --git a/verification/whir/Whir/PCSBCSMerkleRootCache.lean b/verification/whir/Whir/PCSBCSMerkleRootCache.lean new file mode 100644 index 000000000..912e7616a --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleRootCache.lean @@ -0,0 +1,65 @@ +import Whir.PCSBCSMerkleQueryLog + +/-! At the commitment/oracle-message boundary, first registration freezes the +CURRENT public-query prefix and its full extracted table. This API is called by +the causal caller, not with a final transcript log. Repeat announcements/clones +retain the literal same prefix and table; later fresh queries do not fill absent +rows retroactively. Agreement with later openings is charged by OpenPrimitiveBad. -/ +namespace Whir.PCSBCSMerkleRootCache +open Concrete FiatShamirGame PublicMerkleLog MerkleQueryLogExtraction PCSBCSMerkleQueryLog + +structure Shape where + height : Nat + occupied : Nat + +structure Frozen where + shape : Shape + queryPrefix : PublicLog + raw : Array (Array K) + +abbrev Registry := Std.ExtHashMap Key Frozen + +/-- `queryPrefix` is already public at the announcement. It is retained by +reference, not recopied; extraction never consults later answers. -/ +def freeze (queryPrefix : PublicLog) (root : Digest32) (shape : Shape) : Frozen := + ⟨shape,queryPrefix,rawRoot0 queryPrefix root shape.height shape.occupied⟩ + +theorem freeze_prefix (queryPrefix : PublicLog) (root : Digest32) (shape : Shape) : + (freeze queryPrefix root shape).queryPrefix = queryPrefix := rfl + +/-- Runtime branches BEFORE invoking extraction; existing roots do no work. -/ +def register (registry : Registry) (log : PublicLog) (root : Digest32) (shape : Shape) : Registry := + match registry[key root]? with + | some _ => registry + | none => registry.insert (key root) (freeze log root shape) + +theorem register_existing (registry : Registry) (log : PublicLog) (root : Digest32) + (shape : Shape) (frozen : Frozen) (known : registry[key root]? = some frozen) : + register registry log root shape = registry := by simp [register,known] + +theorem register_preserves (registry : Registry) (log : PublicLog) (root other : Digest32) + (shape : Shape) (frozen : Frozen) (known : registry[key root]? = some frozen) : + (register registry log other shape)[key root]? = some frozen := by + unfold register + split + next => exact known + next miss => + rw [Std.ExtHashMap.getElem?_insert] + split + next eq => + have hk : key other = key root := by simpa using eq + rw [hk,known] at miss + contradiction + next => exact known + +theorem register_first (registry : Registry) (log : PublicLog) (root : Digest32) + (shape : Shape) (absent : registry[key root]? = none) : + (register registry log root shape)[key root]? = some (freeze log root shape) := by + simp [register,absent] + +theorem freeze_shape (log : PublicLog) (root : Digest32) (shape : Shape) : + (freeze log root shape).raw.size = 2^shape.height ∧ + ∀ row ∈ (freeze log root shape).raw.toList, row.size = shape.occupied := by + exact rawRoot0_shape log root shape.height shape.occupied + +end Whir.PCSBCSMerkleRootCache diff --git a/verification/whir/Whir/PCSBCSMerkleSourceRows.lean b/verification/whir/Whir/PCSBCSMerkleSourceRows.lean new file mode 100644 index 000000000..bdd89ed89 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleSourceRows.lean @@ -0,0 +1,74 @@ +import Whir.PCSBCSMerkleQueryLog +import Whir.MerkleQueryLogExtractionRowsAgreement +import Whir.WHIRPhysicalRows +import Whir.SupportedCandidateExtraction + +/-! PR600 source-width boundary: authenticated initial leaves contain occupied +lanes, not the generic model's leading zero-prefix encoding to the max fold +width. The source decoder consumes literal raw compact rows and internally uses +lanes-1-l. The verifier first fold reverses once and pads separately. These two +orders are never conflated. The Lean codecs are checked; Rust codec/asm/source +refinement remains an explicit external interface, not a security axiom here. -/ +namespace Whir.PCSBCSMerkleSourceRows +open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments +open MerkleQueryLogExtraction PCSBCSMerkleQueryLog PublicMerkleLog PublicMerkleBinding + +/-- Exact agreement with `compactBaseOracle` at ACTUAL leafWords=occupied. +No claim is made for the legacy padded leafWords=max-fold-width convention. -/ +theorem rawRoot0_eq_compactBaseOracle (C : DuplexModeGame.PrimitiveOracle) + (log : PublicLog) (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) + (root : Digest32) (height occupied : Nat) : + rawRoot0 log root height occupied = + WHIRPhysicalRows.compactBaseOracle (hash C) + ⟨recordDomain (records log),[]⟩ root height (2^height) occupied occupied := by + have full := fullRows_eq_empty_snapshot canonicalCodec (hash C) (records log) + (records_authentic C log auth) (fun bad => clean (reconstructed_collision C log auth bad)) + root height occupied + simpa only [rawRoot0_eq_fullRows,fromPublic,WHIRPhysicalRows.compactBaseOracle, + WHIRPhysicalRows.compactBaseRow,Nat.sub_self,List.drop_zero,baseOracle] using full + +/-- The compiled extractor prepares the exact raw FullRoot shape, independently +of availability. Shape-default rows do NOT authenticate absent leaves. -/ +theorem prepared_source_shape (log : PublicLog) (root : Digest32) (height occupied rows : Nat) + (count : rows = 2^height) : + (rawRoot0 log root height occupied).size = rows ∧ + ∀ row ∈ (rawRoot0 log root height occupied).toList, row.size = occupied := by + subst rows + exact rawRoot0_shape log root height occupied + +/-- A coefficient-ascending view agrees with the decoder's intrinsic raw-row +lane access. This theorem does not reverse the oracle supplied to the decoder. -/ +theorem coefficient_lane (raw : Array (Array K)) (occupied index lane : Nat) + (inside : index < raw.size) (shape : raw[index].size = occupied) (live : lane < occupied) : + ((root0CoefficientOrder raw)[index]!)[lane]! = + SupportedCandidateExtraction.recordLane occupied raw[index] lane := by + rw [show (root0CoefficientOrder raw)[index]! = raw[index].reverse by + simpa only [getElem!_pos (root0CoefficientOrder raw) index (by simpa [root0CoefficientOrder_size] using inside)] + using root0CoefficientOrder_raw raw index inside] + simp only [SupportedCandidateExtraction.recordLane,live,↓reduceIte] + rw [getElem!_pos _ lane (by simpa [shape] using live),Array.getElem_reverse] + have reverseInside : occupied-1-lane < raw[index].size := by rw [shape]; omega + simp only [shape] + rw [getElem!_pos (raw[index]) (occupied-1-lane) reverseInside] + +/-- Actual accepted flat transport supplies the fixed-depth Root0 paths. +The only failure branch is the existing observed compression game event. -/ +theorem pruned_opened_rows (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (root : Digest32) (proof : PrunedMerklePaths) + (numLeaves occupied : Nat) (queries : List Nat) (output : List RawPath) + (accepted : proof.open (hash C) root numLeaves queries occupied occupied = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : + (∀ p ∈ output, (fromPublic log root numLeaves.log2).get + (addressAbove p.leafIndex numLeaves.log2 []) = some p.leafData) ∨ + OpenPrimitiveBad C log root output := by + have refined := open_refines (hash C) proof root numLeaves queries occupied occupied output accepted + apply opened_rows C log auth root numLeaves.log2 output + · intro p hp + obtain ⟨q,hq,row,hr,hw,hi,hd,hl,hdepth,hroot⟩ := forall₂_mem_right refined hp + exact hdepth + · intro p hp + obtain ⟨q,hq,row,hr,hw,hi,hd,hl,hdepth,hroot⟩ := forall₂_mem_right refined hp + exact hroot + · exact bounds + +end Whir.PCSBCSMerkleSourceRows diff --git a/verification/whir/Whir/PCSBCSRounds.lean b/verification/whir/Whir/PCSBCSRounds.lean new file mode 100644 index 000000000..7253c3905 --- /dev/null +++ b/verification/whir/Whir/PCSBCSRounds.lean @@ -0,0 +1,138 @@ +import Whir.WHIRCallerPrefix +import Whir.SamplingProbability + +/-! PCS-only raw-message adapter for the chronological operations audited at +`8a7afbd01e592f2058f348852daa0f428d411e64`: stack/ring_switch initial +sampling and whir/verify.rs:461–469, whir/mod.rs:111–132. The existing +modeled wire compiler is reused, not asserted to be a universal Rust refinement. +The first message is gamma, six map draws, lambda; query messages retain every +full E squeeze before projection and the adjacent lambda. The book's raw +alphabet lower bound is 192, independently of the 256-bit Merkle/mode terms. +This is an IOP message adapter, not an application of the book's compiler theorem +or a whole-VM entropy/security theorem. -/ +namespace Whir.PCSBCSRounds +open Concrete Protocol CausalGame CausalProbability WHIRHistory +open scoped BigOperators + +noncomputable instance {c : Config} (q : Coordinate c) : Fintype (StackSample q) := by + cases q <;> unfold StackSample Sample <;> infer_instance + +/-- The actual dependent raw verifier alphabet, with the initial group replaced, +not followed by a second initial round. -/ +abbrev Raw {c : Config} (q : Coordinate c) := StackSample q + +def rawWidth {c : Config} (q : Coordinate c) : Nat := stackScalarCount q + +/-- Exact number of book-style verifier messages, including the last tail draw. -/ +def k (c : Config) : Nat := Fintype.card (Coordinate c) + +/-- Exact maximal verifier message length in bits, before projection. -/ +def rmax (c : Config) : Nat := + 192 * ((schedule c).map rawWidth).foldl max 0 + +@[simp] theorem raw_card {c : Config} (q : Coordinate c) : + Fintype.card (Raw q) = (2 ^ 192) ^ rawWidth q := by + cases q <;> simp only [Raw, StackSample, Sample, rawWidth, stackScalarCount, + scalarCount, Fintype.card_fun, Fintype.card_prod, Fintype.card_fin, + FieldModel.card_E, pow_one] + · norm_num + · exact (pow_succ (2 ^ 192) _).symm + +/-- Every production alphabet has at least 192 raw bits; zero-OOD levels +introduce no coordinate, and existing OOD coordinates have nonempty vectors. -/ +theorem raw_entropy192 (p : ParameterBounds.Profile) + (q : Coordinate (ParameterBounds.config p)) : + 2 ^ 192 ≤ Fintype.card (Raw q) := by + rw [raw_card] + have positive := (WHIRHistoryKey.production_sample_counts p q).2 + have bound : 1 ≤ rawWidth q := positive + simpa using (Nat.pow_le_pow_right (by decide : 1 ≤ 2 ^ 192) bound) + +theorem depth_eq_k (c : Config) : depth c = k c := by + classical + have all : (schedule c).toFinset = Finset.univ := by + ext q + simp [coordinate_mem_schedule q] + have card := congrArg Finset.card all + simpa only [List.toFinset_card_of_nodup (schedule_nodup c), Finset.card_univ, + depth, k] using card + +/-- Canonical chronological enumeration: no duplicated initial stage or missing +final draw. Its inverse is the actual causal position. -/ +def rounds (c : Config) : Fin (k c) ≃ Coordinate c where + toFun n := (schedule c)[n.val]'(by change n.val < depth c; rw [depth_eq_k]; exact n.isLt) + invFun q := ⟨position q, by simpa [depth_eq_k] using position_lt_depth q⟩ + left_inv n := by + apply Fin.ext + exact position_schedule_get c ⟨n.val, by rw [depth_eq_k]; exact n.isLt⟩ + right_inv q := by + have h := schedule_get_position q + rw [List.getElem?_eq_getElem (position_lt_depth q)] at h + exact Option.some.inj h + +/-- One and only one initial verifier message; its components retain source order. -/ +theorem first_message {c : Config} (gamma lambda : E) (maps : Fin 6 → E) : + stackSampleScalars (c := c) .initial ((gamma,maps),lambda) = + [gamma] ++ List.ofFn maps ++ [lambda] := rfl + +theorem query_message {c : Config} (i : Fin c.folds.size) + (squeezes : Fin (queryChunks c i.val) → E) (lambda : E) : + stackSampleScalars (.query i) (squeezes,lambda) = + List.ofFn squeezes ++ [lambda] := rfl + +/-- The source nonce is a prover string and a rejecting transition, not a +small verifier alphabet or an entropy contribution. All rows/intro replies +occur strictly after the complete query/lambda squeeze. -/ +theorem query_operations {c : Config} (i : Fin c.folds.size) (bits : Nat) + (nonce : E) : challengeEvents (.query i) bits nonce = + [.nonce bits nonce, .squeeze (24 * (queryChunks c i.val + 1))] := rfl + +theorem query_before_reply {c : Config} (i : Fin c.folds.size) + (digests : Nat → FiatShamirGame.Digest32) (bits : Nat → Nat) (nonces : Nat → E) + (rows : Oracle) (intro : Message E) (qs : List (Coordinate c)) (rs : List Reply) : + visibleEvents digests bits nonces (.query i :: qs) (.query rows intro :: rs) = + (visibleEvents digests bits nonces qs rs).map (fun rest => + [.nonce (bits i.val) (nonces i.val), + .squeeze (24 * (queryChunks c i.val + 1)), + .observe (messageScalars intro)] ++ rest) := by + simp [visibleEvents, replyScalars, challengeEvents, scalarCount, coordinateLevel] + cases visibleEvents digests bits nonces qs rs <;> rfl + +/-- Projection to the stratified query law, retaining discarded high bits and +unused chunks in the actual raw domain. No iid-query or padding premise. -/ +theorem projected_query_law (depth count : Nat) (positive : 0 < depth) + (bounded : depth ≤ 64) (P : Fin count → Nat → Prop) : + SamplingProbability.probability + (fun t : Fin ((count + 192 / depth - 1) / (192 / depth)) → E => + ∃ qs, deriveQueries depth count (Array.ofFn t) = some qs ∧ + ∀ i : Fin count, P i qs[i.val]!) = + ∏ i, SamplingProbability.probability (fun raw : Fin (2 ^ depth) => + P i (SamplingProbability.concretePlace count depth i.val raw.val)) := + SamplingProbability.deriveQueries_probability depth count positive bounded P + +/-- Actual causal replies before the query message do not depend on any of +its full squeezes or its lambda, even on malformed/rejecting branches. -/ +theorem query_causality {c : Config} (i : Fin c.folds.size) (t : Tape c) + (x : Sample (.query i)) (strategy : Strategy) (input : Public) : + (run strategy input [] (visibleBatches c (set (.query i) t x).1 + (challenges c (set (.query i) t x)))).take (position (.query i)) = + (run strategy input [] (visibleBatches c t.1 (challenges c t))).take + (position (.query i)) := response_prefix (.query i) t x strategy input + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- All 56 profiles have actual nonempty folds/tails, bounded chunk depth, and +nonempty existing OOD messages; absent OOD points do not create empty rounds. -/ +theorem production_edges : ∀ p : ParameterBounds.Profile, + 0 < (ParameterBounds.config p).logN - (ParameterBounds.config p).folds.toList.sum ∧ + ∀ i : Fin (ParameterBounds.config p).folds.size, + 0 < (ParameterBounds.config p).folds[i.val]! ∧ + 0 < remaining (ParameterBounds.config p) i.val ∧ + 0 < remaining (ParameterBounds.config p) i.val + (ParameterBounds.config p).rates[i.val]! ∧ + remaining (ParameterBounds.config p) i.val + (ParameterBounds.config p).rates[i.val]! ≤ 64 := by + decide +kernel + +#print axioms raw_entropy192 +#print axioms depth_eq_k +#print axioms projected_query_law +end Whir.PCSBCSRounds diff --git a/verification/whir/Whir/PCSBCSRoundsByteHistory.lean b/verification/whir/Whir/PCSBCSRoundsByteHistory.lean new file mode 100644 index 000000000..4124ae4b5 --- /dev/null +++ b/verification/whir/Whir/PCSBCSRoundsByteHistory.lean @@ -0,0 +1,240 @@ +import Whir.PCSBCSRounds + +/-! Adjacent source squeezes form one book-style verifier message without an +intervening prover string. This proves the actual modeled full-history/byte-cursor +operation and the executable byte loop, rather than assuming seed stretching. +Nonce checking is a prover-message rejection and carries no verifier entropy. -/ +namespace Whir.PCSBCSRounds +open Concrete Protocol CausalGame CausalProbability WHIRHistory DuplexRefinement +open scoped BigOperators + +/-- Exact canonical-history and byte-cursor grouping, including empty squeezes. -/ +theorem model_squeeze_add (m : Model) (a b : Nat) : + modelSqueeze (modelSqueeze m a) b = modelSqueeze m (a+b) := by + by_cases ha : a = 0 + · subst a; simp [modelSqueeze] + by_cases hb : b = 0 + · subst b; simp [modelSqueeze] + have hab : a+b ≠ 0 := by omega + have closed : closeRun {closeRun m with consumed := m.consumed+a} = + {closeRun m with consumed := m.consumed+a} := by + have empty : ({closeRun m with consumed := m.consumed+a} : Model).run = [] := + closeRun_empty m + rw [closeRun, ite_eq_left empty] + simp only [modelSqueeze, ha, hb, hab, ↓reduceIte, closed] + simp only [Nat.add_assoc] + +/-- Gamma (24 bytes), six maps (144), lambda (24) share one maximal squeeze. +No prover absorb, transcript reset, or second initial IOP round is inserted. -/ +theorem initial_byte_group (m : Model) : + modelSqueeze (modelSqueeze (modelSqueeze m 24) 144) 24 = modelSqueeze m 192 := by + rw [model_squeeze_add, model_squeeze_add] + +/-- Actual query raw squeezes then lambda, before authentication/intro. +Zero queries still carry the genuine independently sampled lambda. -/ +theorem query_byte_group (m : Model) (chunks : Nat) : + modelSqueeze (modelSqueeze m (24*chunks)) 24 = + modelSqueeze m (24*(chunks+1)) := by + rw [model_squeeze_add] + congr 1 + +/-- Executable underlying byte-loop state and output concatenation agree exactly. +Flush/limit and reachability checks remain the explicit source preconditions of +the existing squeeze implementation; there is no claimed universal Rust bridge. -/ +theorem executable_byte_group (compress : Compression) (s : State) (a b : Nat) : + squeezeLoop compress (a+b) s = + let first := squeezeLoop compress a s + let second := squeezeLoop compress b first.1 + (second.1,first.2 ++ second.2) := squeezeLoop_append compress a b s + +/-- Every actual full chunk lies within the 192-bit field representation. A +cross-limb chunk may read the next limb, but never limb three. -/ +theorem query_chunk_no_wrap (depth : Nat) (positive : 0 < depth) + (bounded : depth ≤ 64) (j : Fin (192 / depth)) : + j.val * depth + depth ≤ 192 ∧ j.val * depth / 64 < 3 ∧ + (64 < j.val * depth % 64 + depth → j.val * depth / 64 + 1 < 3) := by + have full : (j.val+1)*depth ≤ 192 := + (Nat.le_div_iff_mul_le positive).mp (by omega) + rw [Nat.add_mul, one_mul] at full + have split := Nat.mod_add_div (j.val*depth) 64 + omega + +/-- Discarded high bits are a counted factor of the real raw alphabet, not +manufactured padding to meet the book's entropy condition. -/ +theorem unused_query_bits (depth : Nat) (chunks : Fin (192 / depth) → Fin (2^depth)) : + Fintype.card {a : E // (SamplingProbability.chunkEquiv depth a).2 = chunks} = + 2 ^ (192 % depth) := SamplingProbability.chunk_fiber depth chunks + +private theorem product_probability {A B : Type*} [Fintype A] [Fintype B] + (P : A → Prop) (Q : B → Prop) : + SamplingProbability.probability (fun x : A × B => P x.1 ∧ Q x.2) = + SamplingProbability.probability P * SamplingProbability.probability Q := by + classical + let e : {x : A × B // P x.1 ∧ Q x.2} ≃ {a : A // P a} × {b : B // Q b} := + { toFun := fun x => (⟨x.val.1,x.property.1⟩,⟨x.val.2,x.property.2⟩) + invFun := fun x => ⟨(x.1.val,x.2.val),x.1.property,x.2.property⟩ + left_inv := fun _ => rfl + right_inv := fun _ => rfl } + unfold SamplingProbability.probability + simp only [← Nat.card_eq_fintype_card] + rw [Nat.card_congr e, Nat.card_prod, Nat.card_prod] + simp only [Nat.cast_mul, div_eq_mul_inv, mul_inv_rev] + ring + +/-- Exact joint query/lambda law on the unsplit raw verifier message. The +stratified query projection has the proved coset law, independently of lambda. -/ +theorem query_lambda_joint_law (depth count : Nat) (positive : 0 < depth) + (bounded : depth ≤ 64) (P : Fin count → Nat → Prop) (L : E → Prop) : + SamplingProbability.probability + (fun x : (Fin ((count+192/depth-1)/(192/depth)) → E) × E => + (∃ qs, deriveQueries depth count (Array.ofFn x.1) = some qs ∧ + ∀ i : Fin count, P i qs[i.val]!) ∧ L x.2) = + (∏ i, SamplingProbability.probability (fun raw : Fin (2^depth) => + P i (SamplingProbability.concretePlace count depth i.val raw.val))) * + SamplingProbability.probability L := by + rw [product_probability + (fun t : Fin ((count+192/depth-1)/(192/depth)) → E => + ∃ qs, deriveQueries depth count (Array.ofFn t) = some qs ∧ + ∀ i : Fin count, P i qs[i.val]!) L, + projected_query_law depth count positive bounded P] + +/-- A failing source nonce check rejects rather than resampling the PCS coins. -/ +theorem nonce_rejected (compress : Compression) + (powOK : FiatShamirGame.Digest32 → FiatShamirGame.Scalar24 → Nat → Bool) + (s t : State) (bits : Nat) (nonce : E) + (failed : verifyNonce compress powOK s (ByteCodec.encodeE nonce) bits = .ok (t,false)) : + executeEvent compress powOK s (.nonce bits nonce) = none := by + simp [executeEvent,failed] + +/-- Every parsed visible PCS reply absorbs at least its two polynomial +coefficients; OOD additionally absorbs its value. No empty reply creates a +cross-round continuation of the preceding output cache. -/ +theorem reply_boundary_nonempty {c : Config} (q : Coordinate c) + (digest : FiatShamirGame.Digest32) (reply : Reply) (xs : List E) + (parsed : replyScalars q digest reply = some xs) : xs ≠ [] := by + cases q <;> cases reply <;> simp only [replyScalars] at parsed <;> try contradiction + all_goals + cases Option.some.inj parsed + simp [messageScalars] + +theorem reply_boundary_bytes_nonempty {c : Config} (q : Coordinate c) + (digest : FiatShamirGame.Digest32) (reply : Reply) (xs : List E) + (parsed : replyScalars q digest reply = some xs) : scalarBytes xs ≠ [] := by + intro empty + have size := congrArg List.length empty + rw [scalarBytes_length, List.length_nil] at size + have nonempty := reply_boundary_nonempty q digest reply xs parsed + have positive : 0 < xs.length := List.length_pos_iff.mpr nonempty + omega + +private theorem absorbByte_cursor_reset (compress : Compression) (s : State) + (byte : FiatShamirGame.Byte) : (absorbByte compress s byte).consumed = 0 := by + simp only [absorbByte] + split <;> split <;> simp_all + +private theorem absorb_cursor_zero (compress : Compression) (s : State) + (bytes : List FiatShamirGame.Byte) (zero : s.consumed = 0) : + (absorb compress s bytes).consumed = 0 := by + induction bytes generalizing s with + | nil => exact zero + | cons byte bytes ih => + exact ih (absorbByte compress s byte) (absorbByte_cursor_reset compress s byte) + +/-- The executable absorb resets the cursor on any nonempty reply. Cached +bytes may remain stored, but are unreachable at the next positive squeeze. -/ +theorem nonempty_absorb_cursor_reset (compress : Compression) (s : State) + (bytes : List FiatShamirGame.Byte) (nonempty : bytes ≠ []) : + (absorb compress s bytes).consumed = 0 := by + cases bytes with + | nil => contradiction + | cons byte bytes => + exact absorb_cursor_zero compress (absorbByte compress s byte) bytes + (absorbByte_cursor_reset compress s byte) + +theorem parsed_reply_cursor_reset {c : Config} (compress : Compression) (s : State) + (q : Coordinate c) (digest : FiatShamirGame.Digest32) (reply : Reply) (xs : List E) + (parsed : replyScalars q digest reply = some xs) : + (absorb compress s (scalarBytes xs)).consumed = 0 := + nonempty_absorb_cursor_reset compress s _ (reply_boundary_bytes_nonempty q digest reply xs parsed) + +/-- Special nonce binding resets at every difficulty, including canonical +bits=0. No claim that the nonce contributes verifier entropy is made. -/ +theorem nonce_cursor_reset (compress : Compression) (s : State) + (nonce : FiatShamirGame.Scalar24) (bits : Nat) : + (bindNonce compress s nonce bits).consumed = 0 := rfl + +/-- At a zero cursor the first byte comes from outputBlock(0), not stored +unused bytes from the preceding public compression output. -/ +theorem squeezeByte_old_cache_irrelevant (compress : Compression) (s : State) + (zero : s.consumed = 0) (left right : FiatShamirGame.Digest32) : + squeezeByte compress {s with output := left} = + squeezeByte compress {s with output := right} := by + simp [squeezeByte, zero] + +theorem positive_squeezeLoop_old_cache_irrelevant (compress : Compression) + (s : State) (zero : s.consumed = 0) (left right : FiatShamirGame.Digest32) (n : Nat) : + squeezeLoop compress (n+1) {s with output := left} = + squeezeLoop compress (n+1) {s with output := right} := by + simp only [squeezeLoop] + rw [squeezeByte_old_cache_irrelevant compress s zero left right] + +private theorem finish_setOutput (compress : Compression) (s : State) + (output : FiatShamirGame.Digest32) : + finish compress {s with output := output} = {finish compress s with output := output} := by + simp only [finish] + split <;> rfl + +/-- The actual guarded squeeze, including pending-input finalization and limit +rejection, cannot use the old cache after a round boundary cursor reset. -/ +theorem positive_squeeze_old_cache_irrelevant (compress : Compression) + (s : State) (zero : s.consumed = 0) (left right : FiatShamirGame.Digest32) (n : Nat) : + squeeze compress {s with output := left} (n+1) = + squeeze compress {s with output := right} (n+1) := by + simp only [squeeze, Nat.add_one_ne_zero, ↓reduceIte] + by_cases limit : s.consumed + (n+1) ≤ maxCursor + · simp only [limit, ↓reduceIte, finish_setOutput] + exact congrArg Except.ok (positive_squeezeLoop_old_cache_irrelevant compress + (finish compress s) ((finish_consumed compress s).trans zero) left right n) + · simp only [limit, ↓reduceIte] + +/-- This is the modeled cursor boundary of every admitted book message, +including malformed values and nonce rejection branches. Initial caller-entry +normalization/physical representation is a separate explicit precondition. -/ +theorem scheduled_round_cursor_zero (p : ParameterBounds.Profile) + (entry : FiatShamirGame.FramedHistory) (messages : List Pending) + (nonempty : messages ≠ []) + (admitted : scheduledAdmissible (ParameterBounds.config p) messages = true) : + (WHIRCallerPrefix.beforeModelFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + entry messages).consumed = 0 := + WHIRCallerPrefix.beforeModelFrom_consumed _ (WHIRHistoryKey.stackWidth_positive p) + entry (WHIRHistoryKey.scheduled_normal _ _ nonempty admitted) + +/-- Operative no-cross-round unused-cache bridge for the actual executable +state representing an admitted canonical source byte history. Representation +is explicit; independence of fresh compression outputs is NOT inferred here. -/ +theorem physical_round_old_cache_irrelevant (compress : Compression) + (iv : FiatShamirGame.Digest32) (p : ParameterBounds.Profile) + (entry : FiatShamirGame.FramedHistory) (messages : List Pending) + (nonempty : messages ≠ []) + (admitted : scheduledAdmissible (ParameterBounds.config p) messages = true) + (s : State) + (represents : Represents compress iv + (WHIRCallerPrefix.beforeModelFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + entry messages) s) + (left right : FiatShamirGame.Digest32) (n : Nat) : + squeeze compress {s with output := left} (n+1) = + squeeze compress {s with output := right} (n+1) := by + apply positive_squeeze_old_cache_irrelevant + have cursor := materialize_consumed compress iv + (WHIRCallerPrefix.beforeModelFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + entry messages) s.output represents.1 + rw [← represents.2.1] at cursor + exact cursor.trans (scheduled_round_cursor_zero p entry messages nonempty admitted) + +#print axioms initial_byte_group +#print axioms query_byte_group +#print axioms executable_byte_group +#print axioms nonce_rejected +#print axioms physical_round_old_cache_irrelevant +#print axioms parsed_reply_cursor_reset +end Whir.PCSBCSRounds diff --git a/verification/whir/Whir/PCSBCSRoundsParameters.lean b/verification/whir/Whir/PCSBCSRoundsParameters.lean new file mode 100644 index 000000000..f7d34dfce --- /dev/null +++ b/verification/whir/Whir/PCSBCSRoundsParameters.lean @@ -0,0 +1,87 @@ +import Whir.PCSBCSRounds + +/-! Exact PCS-only BCS resource parameters from the audited modeled schedule, +not the two-stage ring proof decomposition and not the whole-system transcript. -/ +namespace Whir.PCSBCSRounds +open Concrete Protocol CausalGame CausalProbability WHIRHistory +open scoped BigOperators + +/-- Joint initial message contributes exactly one. Zero-OOD levels add zero +OOD rounds; every tail scalar, including the response-free last, contributes one. -/ +theorem k_exact (c : Config) : + k c = 1 + (∑ i : Fin c.folds.size, (c.folds[i.val]! + oodCount c i.val + 1)) + + (c.logN - c.folds.toList.sum) := by + unfold k + rw [Fintype.card_congr (Coordinate.proxyTypeEquiv c).symm] + simp only [Fintype.card_sum, Fintype.card_sigma, Fintype.card_fin, Fintype.card_unit] + simp only [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, + Fintype.card_fin, nsmul_eq_mul, mul_one, Nat.cast_id] + omega + +private theorem fold_max_le (xs : List Nat) (a b : Nat) : + xs.foldl max a ≤ b ↔ a ≤ b ∧ ∀ n ∈ xs, n ≤ b := by + induction xs generalizing a with + | nil => simp + | cons n xs ih => simp [List.foldl_cons, ih, and_assoc] + +/-- Universal and converse bound: rmax is the actual maximum of the raw field +widths, not merely a convenient overestimate. -/ +theorem rmax_le_iff (c : Config) (fields : Nat) : + rmax c ≤ 192 * fields ↔ ∀ q : Coordinate c, rawWidth q ≤ fields := by + unfold rmax + rw [mul_le_mul_iff_of_pos_left (by decide : 0 < (192 : Nat)), fold_max_le] + simp only [Nat.zero_le, true_and, List.mem_map, forall_exists_index, and_imp] + constructor + · intro h q + exact h (rawWidth q) q (coordinate_mem_schedule q) rfl + · intro h n q member equal + subst n + exact h q + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Exact production round cap, checked over all 56 actual configurations. -/ +theorem production_k_cap : ∀ p : ParameterBounds.Profile, + k (ParameterBounds.config p) ≤ 40 := by + intro p + rw [k_exact] + revert p + decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Exact maximum raw message length over the 56 schedules: 30 full E draws. +The cap and attainment are kernel checked, not inferred from a benchmark. -/ +theorem production_rmax_exact : + (∀ p : ParameterBounds.Profile, rmax (ParameterBounds.config p) ≤ 5760) ∧ + (∃ p : ParameterBounds.Profile, rmax (ParameterBounds.config p) = 5760) := by + decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- The production k cap is attained, without counting the first group twice. -/ +theorem production_k_attained : + ∃ p : ParameterBounds.Profile, k (ParameterBounds.config p) = 40 := by + simp_rw [k_exact] + decide +kernel + +/-- Raw min-entropy is 192 and does not acquire the separate Merkle/mode 256-bit +budget. The book constructor must sample the entire dependent raw alphabet. -/ +theorem book_raw_requirement (p : ParameterBounds.Profile) : + ∀ q : Coordinate (ParameterBounds.config p), 2^192 ≤ Fintype.card (Raw q) := + raw_entropy192 p + +/-- The minimum is exactly 192, not just at least 192: every production tail +contains a genuine single-E draw. Hence one cannot borrow 256-bit hash entropy. -/ +theorem book_raw_min_exact (p : ParameterBounds.Profile) : + (∀ q : Coordinate (ParameterBounds.config p), 2^192 ≤ Fintype.card (Raw q)) ∧ + ∃ q : Coordinate (ParameterBounds.config p), Fintype.card (Raw q) = 2^192 := by + refine ⟨book_raw_requirement p, ?_⟩ + let j : Fin ((ParameterBounds.config p).logN - + (ParameterBounds.config p).folds.toList.sum) := ⟨0,(production_edges p).1⟩ + exact ⟨.tail j, by simp⟩ + +#print axioms k_exact +#print axioms rmax_le_iff +#print axioms production_k_cap +end Whir.PCSBCSRounds diff --git a/verification/whir/Whir/PCSBCSRoundsSmoke.lean b/verification/whir/Whir/PCSBCSRoundsSmoke.lean new file mode 100644 index 000000000..f033facea --- /dev/null +++ b/verification/whir/Whir/PCSBCSRoundsSmoke.lean @@ -0,0 +1,111 @@ +import Whir.PCSBCSRoundsAdapter +import Whir.PCSBCSRoundsByteHistory +import Whir.DuplexCompression + +/-! Actual compiled field/byte/sampler smoke for the modeled PCS adapter. It does +not use a mock transcript oracle or claim Merkle authentication/Rust refinement. -/ +namespace Whir.PCSBCSRoundsSmoke +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds + +def check (condition : Bool) (message : String) : IO Unit := + unless condition do throw (IO.userError message) + +def toy : Config := ⟨3, #[1,1], #[2,2], #[16,8], #[0,1]⟩ +def e (n : Nat) : E := ⟨UInt64.ofNat n,UInt64.ofNat (n+100),UInt64.ofNat (n+200)⟩ + +def draw (s : DuplexRefinement.State) (n : Nat) : + IO (DuplexRefinement.State × List FiatShamirGame.Byte) := + match DuplexRefinement.squeeze DuplexCompression.compress s n with + | .ok result => pure result + | .error _ => throw (IO.userError "native duplex squeeze unexpectedly rejected") + +/-- Uses actual BLAKE2s compression, not a mock transcript oracle. Within one +group the 8 cached bytes after a 24-byte E remain usable; across each absorbed +reply or bits-zero nonce they are not used by the next group's squeeze. -/ +def cacheBoundarySmoke : IO Unit := do + let initial := DuplexRefinement.seed DuplexCompression.compress DuplexCompression.parameterIV + DuplexRefinement.zeroDigest DuplexRefinement.zeroDigest + let prior ← draw initial 24 + check (prior.1.consumed == 24) "E must consume exactly 24 bytes" + let tail ← draw prior.1 8 + check (tail.2 == (List.ofFn prior.1.output).drop 24) + "within-group unused 8 bytes were incorrectly discarded" + let changed : FiatShamirGame.Digest32 := fun i => + ⟨((prior.1.output i).val+1)%256,Nat.mod_lt _ (by decide)⟩ + for (name,reply) in [("fold",[e 131,e 132]),("OOD",[e 133,e 134,e 135]), + ("query intro",[e 136,e 137]),("nonfinal tail",[e 138,e 139])] do + let bytes := scalarBytes reply + let left := DuplexRefinement.absorb DuplexCompression.compress prior.1 bytes + let right := DuplexRefinement.absorb DuplexCompression.compress + {prior.1 with output := changed} bytes + check (left.consumed == 0 && right.consumed == 0) s!"{name} did not reset cursor" + let leftDraw ← draw left 24 + let rightDraw ← draw right 24 + check (leftDraw.2 == rightDraw.2) s!"{name} reused prior unused cache bytes" + let nonce := ByteCodec.encodeE E.zero + let checked := DuplexRefinement.verifyNonce DuplexCompression.compress DuplexCompression.powOK + prior.1 nonce 0 + match checked with + | .error _ => throw (IO.userError "canonical bits-zero nonce rejected") + | .ok (bound,ok) => + check (ok && bound.consumed == 0) "bits-zero nonce did not bind/reset" + let leftDraw ← draw bound 24 + let rightDraw ← draw {bound with output := changed} 24 + check (leftDraw.2 == rightDraw.2) "bits-zero nonce reused old cache" + check ((WHIRHistory.executeEvent DuplexCompression.compress DuplexCompression.powOK + prior.1 (.nonce 0 E.one)).isNone) "malformed bits-zero nonce did not reject" + IO.println "PCS byte boundary PASS: E=24/32, within-group tail8 retained; fold/OOD/query-intro/nonfinal-tail reply absorbs and canonical nonce(bits=0) reset old-cache use" + +def smoke : IO Unit := do + let gamma := e 1 + let maps : Fin 6 → E := fun i => e (i.val+2) + let lambda := e 8 + let first := stackSampleScalars (c := toy) .initial ((gamma,maps),lambda) + check (first == (List.range 8).map (fun i => e (i+1))) + "gamma/six-maps/lambda source order mismatch" + check (List.ofFn (initialEight (c := toy) ((gamma,maps),lambda)) == first) + "literal Fin8 source ordering mismatch" + check (parseExact 8 (scalarBytes first) == some first) + "joint 8E byte codec order mismatch" + check ((parseExact 8 ((scalarBytes first).dropLast)).isNone) + "truncated initial bytes accepted" + let squeezes : Fin (queryChunks toy 0) → E := fun i => e (i.val+21) + let query := stackSampleScalars (.query (⟨0,by decide⟩ : Fin toy.folds.size)) (squeezes,lambda) + check (query == List.ofFn squeezes ++ [lambda]) "query lambda was reordered" + check (parseExact (queryChunks toy 0+1) (scalarBytes query) == some query) + "fullE query vector lost unused bits" + let raw : Array E := #[⟨0xfedcba9876543210,0x0123456789abcdef,0x9988776655443322⟩, + ⟨0x55aa33cc77ee11ff,0x123456789abcdef0,0xf0e1d2c3b4a59687⟩] + for depth in [13,26,63] do + let count := 192/depth+1 + let actual := deriveQueries depth count raw + let expected := some (tab count fun i => SamplingProbability.concretePlace count depth i + (Layout.rawQuery depth (fun j => raw[j]!.toNat) i)) + check (actual == expected) s!"cross-limb/stratum query mismatch at depth {depth}" + let tape : Tape toy := (lambda,fun i => + (fun j => e (40+i.val+j.val),fun j k => e (60+i.val+j.val+k.val), + fun j => e (80+i.val+j.val),e (100+i.val)),fun j => e (120+j.val)) + let source : SourceTape toy := ((gamma,maps),tape) + let restored := (tapeAdapter toy).symm (tapeAdapter toy source) + check (restored.1.1 == gamma && restored.2.1 == lambda) + "joint initial tape adapter mismatch" + check (!(CausalGame.opening toy (challenges toy restored.2) #[]).isOk) + "missing modeled replies accepted" + check (!(CausalGame.opening toy (challenges toy restored.2) #[.query #[] ⟨0,0⟩]).isOk) + "malformed initial reply tag accepted" + cacheBoundarySmoke + let mut maximumBits := 0 + let mut maximumRounds := 0 + for n in List.finRange 14 do + for rate in List.finRange 4 do + let p : ParameterBounds.Profile := (n,rate) + let c := ParameterBounds.config p + maximumBits := max maximumBits (rmax c) + maximumRounds := max maximumRounds (depth c) + check (c.valid && (schedule c).all (fun q => decide (0 < rawWidth q))) + "production empty-round edge" + IO.println s!"PCS grouped smoke PASS: joint 8E, query fullE+lambda, byte order/truncation, cross-limb strata, causal tape regrouping, malformed replies; 56 profiles: max k={maximumRounds}, max rmax={maximumBits} bits" + +end Whir.PCSBCSRoundsSmoke + +def main : IO Unit := Whir.PCSBCSRoundsSmoke.smoke diff --git a/verification/whir/Whir/PCSRoundByRoundCancellation.lean b/verification/whir/Whir/PCSRoundByRoundCancellation.lean new file mode 100644 index 000000000..a7d880af0 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundCancellation.lean @@ -0,0 +1,304 @@ +import Whir.SupportedCandidateProtocolProbability + +/-! Causal first-collapse localization of the fixed Root0 row cancellation event. +Each stage charges one fresh scalar, not the marginal six-coordinate loss. -/ +namespace Whir.PCSRoundByRoundCancellation +open Concrete Protocol CausalGame CausalProbability ExecutionShapes ParameterBounds +open InitialKnowledgeSchedule SupportedCandidateExtraction SupportedCandidateProtocol +open scoped BigOperators +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 +attribute [local irreducible] ParameterBounds.config + +variable {F : Type*} [Field F] [Inhabited F] [CharP F 2] + +def partialRow (row : Array F) (seed : Nat → F) (k : Nat) : Array F := + (List.range k).foldl (fun a i => foldLow a (seed i)) row + +omit [CharP F 2] in +@[simp] theorem partialRow_zero (row : Array F) (seed : Nat → F) : + partialRow row seed 0 = row := rfl + +omit [CharP F 2] in + theorem partialRow_succ (row : Array F) (seed : Nat → F) (k : Nat) : + partialRow row seed (k+1) = foldLow (partialRow row seed k) (seed k) := by + simp [partialRow, List.range_succ, List.foldl_append] + +omit [CharP F 2] in + theorem partialRow_congr (row : Array F) (a b : Nat → F) (k : Nat) + (h : ∀ i < k, a i = b i) : partialRow row a k = partialRow row b k := by + induction k with + | zero => rfl + | succ k ih => rw [partialRow_succ, partialRow_succ, ih (fun i hi => h i (by omega)), h k (by omega)] + +omit [CharP F 2] in + theorem partialRow_size (row : Array F) (seed : Nat → F) (n k : Nat) + (shape : row.size = 2^n) (hk : k ≤ n) : + (partialRow row seed k).size = 2^(n-k) := by + induction k with + | zero => simpa using shape + | succ k ih => + rw [partialRow_succ, ArrayLayout.size_foldLow, ih (by omega)] + rw [show n-k = (n-(k+1))+1 by omega, pow_succ] + simp + +omit [CharP F 2] in + theorem partialRow_terminal (row point : Array F) (shape : row.size = 2^point.size) : + partialRow row (fun i => point[i]!) point.size = #[Concrete.mle row point] := by + have mapped : (List.range point.size).map (fun i => point[i]!) = point.toList := by + apply List.ext_getElem + · simp + · intro i hi hi' + simp only [List.getElem_map, List.getElem_range, Array.getElem_toList] + simp only [getElem!_pos point i (by simpa using hi')] + unfold partialRow + rw [← List.foldl_map, mapped, Array.foldl_toList] + exact TerminalRefinement.foldLow_terminal row point shape + +omit [Inhabited F] [CharP F 2] in +private theorem pair_recover (a b c d r s : F) (different : r ≠ s) + (hr : foldPair a b r = foldPair c d r) + (hs : foldPair a b s = foldPair c d s) : a = c ∧ b = d := by + have product : (r-s) * ((a+b)-(c+d)) = 0 := by + unfold foldPair at hr hs + linear_combination hr - hs + have sums : a+b = c+d := by + exact sub_eq_zero.mp ((mul_eq_zero.mp product).resolve_left (sub_ne_zero.mpr different)) + have ac : a = c := by + unfold foldPair at hr + rw [sums] at hr + exact add_right_cancel hr + exact ⟨ac, by simpa [ac] using sums⟩ + +/-- A nonzero incoming row difference has at most one collapsing scalar. -/ + theorem foldLow_collision_unique {n : Nat} (a b : Array F) + (ha : a.size = 2^(n+1)) (hb : b.size = 2^(n+1)) (hne : a ≠ b) + (r s : F) (hr : foldLow a r = foldLow b r) (hs : foldLow a s = foldLow b s) : r = s := by + by_contra different + apply hne + apply congrArg Subtype.val (ExecutableOOD.decode_injective (n+1) (a₁ := ⟨a,ha⟩) (a₂ := ⟨b,hb⟩) ?_) + have hrf := congrArg (ExecutableOOD.decode n) hr + have hsf := congrArg (ExecutableOOD.decode n) hs + rw [ExecutableOOD.decode_foldLow a r ha, ExecutableOOD.decode_foldLow b r hb] at hrf + rw [ExecutableOOD.decode_foldLow a s ha, ExecutableOOD.decode_foldLow b s hb] at hsf + funext u + let tail : Cube n := fun i => u i.succ + have pair := pair_recover (ExecutableOOD.decode (n+1) a (Fin.cons false tail)) + (ExecutableOOD.decode (n+1) a (Fin.cons true tail)) + (ExecutableOOD.decode (n+1) b (Fin.cons false tail)) + (ExecutableOOD.decode (n+1) b (Fin.cons true tail)) r s different + (by simpa only [foldFirst_charTwo, foldPair] using congrFun hrf tail) + (by simpa only [foldFirst_charTwo, foldPair] using congrFun hsf tail) + have cons : Fin.cons (u 0) tail = u := by funext i; exact Fin.cases rfl (fun _ => rfl) i + rw [← cons] + cases u 0 + · exact pair.1 + · exact pair.2 + +noncomputable def Stage {W Q : Type*} (list : Finset W) (committed : Q → Array F) + (encoded : W → Q → Array F) (seed : Nat → F) (j : Nat) : Prop := + ∃ w ∈ list, ∃ q, + partialRow (committed q) seed j ≠ partialRow (encoded w q) seed j ∧ + partialRow (committed q) seed (j+1) = partialRow (encoded w q) seed (j+1) + +omit [CharP F 2] in +/-- The first equality cannot be stage zero when the committed row differs. -/ + theorem first_collapse {n : Nat} (a b : Array F) (seed : Nat → F) + (different : a ≠ b) (terminal : partialRow a seed n = partialRow b seed n) : + ∃ j < n, partialRow a seed j ≠ partialRow b seed j ∧ + partialRow a seed (j+1) = partialRow b seed (j+1) := by + induction n with + | zero => exact False.elim (different terminal) + | succ n ih => + by_cases previous : partialRow a seed n = partialRow b seed n + · obtain ⟨j,hj,hn,he⟩ := ih previous + exact ⟨j, by omega, hn, he⟩ + · exact ⟨n, by omega, previous, terminal⟩ + +omit [CharP F 2] in +/-- Equality persists under the actual linear folds; a nonzero incoming +difference therefore certifies every earlier partial row was nonzero too. -/ +theorem partialRow_equal_mono (a b : Array F) (seed : Nat → F) (j k : Nat) + (hjk : j ≤ k) (equal : partialRow a seed j = partialRow b seed j) : + partialRow a seed k = partialRow b seed k := by + induction k with + | zero => + have hj : j = 0 := by omega + simpa [hj] using equal + | succ k ih => + by_cases same : j = k+1 + · simpa [same] using equal + · rw [partialRow_succ, partialRow_succ, ih (by omega)] + +omit [CharP F 2] in +theorem stage_is_first {W Q : Type*} (list : Finset W) + (committed : Q → Array F) (encoded : W → Q → Array F) (seed : Nat → F) + (j : Nat) (event : Stage list committed encoded seed j) : + ∃ w ∈ list, ∃ q, (∀ k ≤ j, + partialRow (committed q) seed k ≠ partialRow (encoded w q) seed k) ∧ + partialRow (committed q) seed (j+1) = partialRow (encoded w q) seed (j+1) := by + obtain ⟨w,hw,q,different,collapse⟩ := event + exact ⟨w,hw,q,fun k hk equal => different + (partialRow_equal_mono _ _ _ k j hk equal),collapse⟩ + +variable [Fintype F] [DecidableEq F] + +open Classical in + theorem stage_fiber_bound {W Q : Type*} [Fintype Q] [DecidableEq W] [DecidableEq Q] + (n : Nat) (list : Finset W) (committed : Q → Array F) (encoded : W → Q → Array F) + (committedShape : ∀ q, (committed q).size = 2^n) + (encodedShape : ∀ w ∈ list, ∀ q, (encoded w q).size = 2^n) + (seed : Nat → F) (j : Nat) (hj : j < n) : + Soundness.uniformProb (Finset.univ.filter fun r : F => + Stage list committed encoded (Function.update seed j r) j) ≤ + (list.card : ℚ) * Fintype.card Q / Fintype.card F := by + let events (i : list × Q) : Finset F := Finset.univ.filter fun r => + partialRow (committed i.2) seed j ≠ partialRow (encoded i.1 i.2) seed j ∧ + foldLow (partialRow (committed i.2) seed j) r = + foldLow (partialRow (encoded i.1 i.2) seed j) r + have fixed (row : Array F) (r : F) : + partialRow row (Function.update seed j r) j = partialRow row seed j := + partialRow_congr _ _ _ _ (fun i hi => Function.update_of_ne (by omega) _ _) + have equal : (Finset.univ.filter fun r : F => + Stage list committed encoded (Function.update seed j r) j) = Finset.univ.biUnion events := by + ext r + simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_biUnion, + Stage, partialRow_succ, fixed, Function.update_self] + simp [events] + have each (i : list × Q) : Soundness.uniformProb (events i) ≤ 1 / Fintype.card F := by + have card : (events i).card ≤ 1 := by + apply Finset.card_le_one.mpr + intro r hr s hs + have rmem := (Finset.mem_filter.mp hr).2 + have smem := (Finset.mem_filter.mp hs).2 + apply foldLow_collision_unique (n := n-(j+1)) _ _ _ _ rmem.1 r s rmem.2 smem.2 + · simpa [show n-j = (n-(j+1))+1 by omega] using + partialRow_size (committed i.2) seed n j (committedShape i.2) hj.le + · simpa [show n-j = (n-(j+1))+1 by omega] using + partialRow_size (encoded i.1 i.2) seed n j (encodedShape i.1 i.1.2 i.2) hj.le + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (by exact_mod_cast card) (by positivity) + rw [equal] + calc + _ ≤ ∑ i, Soundness.uniformProb (events i) := Soundness.union_bound events + _ ≤ ∑ _i : list × Q, (1 / Fintype.card F : ℚ) := Finset.sum_le_sum (fun i _ => each i) + _ = _ := by simp only [Finset.sum_const, Finset.card_univ, Fintype.card_prod, + Fintype.card_coe, Nat.cast_mul, nsmul_eq_mul]; ring + +def initialSeed (p : Profile) (t : Tape (config p)) (k : Nat) : E := + (Array.ofFn (t.2.1 (initialLevel p)).1)[k]! + +noncomputable def Event (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (j : Fin (config p).folds[0]!) (t : Tape (config p)) : Prop := + Stage (InitialCandidates.witnesses (config p) lanes root) + (committedRow (Input p lanes root claims)) (witnessRow (Input p lanes root claims)) + (initialSeed p t) j.val + +theorem initialSeed_get (p : Profile) (t : Tape (config p)) (k : Nat) + (hk : k < (config p).folds[0]!) : + initialSeed p t k = get (.fold (initialLevel p) ⟨k,hk⟩) t := by + simp [initialSeed, CausalProbability.get, initialLevel, hk] + +theorem initialSeed_set (p : Profile) (t : Tape (config p)) + (j : Fin (config p).folds[0]!) (r : E) (k : Nat) (hk : k < (config p).folds[0]!) : + initialSeed p (set (.fold (initialLevel p) j) t r) k = + Function.update (initialSeed p t) j.val r k := by + rw [initialSeed_get _ _ _ hk] + by_cases equal : k = j.val + · subst k + rw [show (⟨j.val,hk⟩ : Fin (config p).folds[0]!) = j from Fin.ext rfl, get_set] + simp + · rw [get_set_ne _ _ _ _ (by intro h; cases h; exact equal rfl), + ← initialSeed_get _ _ _ hk, Function.update_of_ne equal] + +open Classical in +/-- Any fixed previous history, including malformed execution histories, has the +same one-scalar bound. Both row sizes are unconditional `Array.ofFn` sizes: +no input-validity, no-wrap, or lane-cap assumption is hidden in this fiber. -/ +theorem fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (j : Fin (config p).folds[0]!) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun r : Sample (.fold (initialLevel p) j) => + Event p lanes root claims j (set (.fold (initialLevel p) j) t r)) ≤ + (2^32 : ℚ) * blockLength (config p) / 2^192 := by + let input := Input p lanes root claims + have equal (r : E) : Event p lanes root claims j (set (.fold (initialLevel p) j) t r) ↔ + Stage (InitialCandidates.witnesses (config p) lanes root) (committedRow input) + (witnessRow input) (Function.update (initialSeed p t) j.val r) j.val := by + unfold Event Stage + have fixed (row : Array E) (k : Nat) (hk : k ≤ j.val+1) : + partialRow row (initialSeed p (set (.fold (initialLevel p) j) t r)) k = + partialRow row (Function.update (initialSeed p t) j.val r) k := + partialRow_congr _ _ _ _ (fun i hi => initialSeed_set p t j r i (by omega)) + simp only [fixed _ j.val (by omega), fixed _ (j.val+1) le_rfl, input] + simp_rw [equal] + have bound := stage_fiber_bound (config p).folds[0]! + (InitialCandidates.witnesses (config p) lanes root) (committedRow input) (witnessRow input) + (by intro q; simp [committedRow, input, Input, laneCount]) + (by intro w hw q; simp [witnessRow, input, Input, laneCount]) + (initialSeed p t) j.val j.isLt + rw [FieldModel.card_E] at bound + simp only [Fintype.card_fin, Nat.cast_pow, Nat.cast_ofNat] at bound + dsimp only [input, Input] at bound + simp only [blockLength, Nat.cast_pow, Nat.cast_ofNat] + apply bound.trans + gcongr + exact_mod_cast InitialCandidates.production_witnesses_card p lanes root + +theorem cover (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (t : Tape (config p)) (bad : CancellationEvent p lanes root claims t) : + ∃ j : Fin (config p).folds[0]!, Event p lanes root claims j t := by + obtain ⟨w,hw,q,different,collision⟩ := bad + let input := Input p lanes root claims + have terminal : partialRow (committedRow input q) (initialSeed p t) (config p).folds[0]! = + partialRow (witnessRow input w q) (initialSeed p t) (config p).folds[0]! := by + have shapeA : (committedRow input q).size = 2^(config p).folds[0]! := by + simp [committedRow, input, Input, laneCount] + have shapeB : (witnessRow input w q).size = 2^(config p).folds[0]! := by + simp [witnessRow, input, Input, laneCount] + change partialRow _ (fun i => (Array.ofFn (t.2.1 (initialLevel p)).1)[i]!) _ = + partialRow _ (fun i => (Array.ofFn (t.2.1 (initialLevel p)).1)[i]!) _ + simpa only [Array.size_ofFn] using + (partialRow_terminal (committedRow input q) (Array.ofFn (t.2.1 (initialLevel p)).1) + (by simpa using shapeA)).trans + ((congrArg (fun x : E => #[x]) collision).trans + (partialRow_terminal (witnessRow input w q) (Array.ofFn (t.2.1 (initialLevel p)).1) + (by simpa using shapeB)).symm) + obtain ⟨j,hj,hn,he⟩ := first_collapse _ _ _ different terminal + exact ⟨⟨j,hj⟩,w,hw,q,hn,he⟩ + +/-- Dependence stops at the current initial-fold coordinate, inclusive. -/ +theorem prefix_invariant (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (j : Fin (config p).folds[0]!) (t u : Tape (config p)) + (same : ∀ k ≤ j.val, initialSeed p t k = initialSeed p u k) : + Event p lanes root claims j t ↔ Event p lanes root claims j u := by + unfold Event Stage + have fixed (row : Array E) (k : Nat) (hk : k ≤ j.val+1) : + partialRow row (initialSeed p t) k = partialRow row (initialSeed p u) k := + partialRow_congr _ _ _ _ (fun i hi => same i (by omega)) + simp only [fixed _ j.val (by omega), fixed _ (j.val+1) le_rfl] + +theorem future_invariant (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (j : Fin (config p).folds[0]!) (q : Coordinate (config p)) + (t : Tape (config p)) (x : Sample q) + (later : position (.fold (initialLevel p) j) < position q) : + Event p lanes root claims j (set q t x) ↔ Event p lanes root claims j t := by + apply prefix_invariant + intro k hk + have hkn : k < (config p).folds[0]! := by omega + rw [initialSeed_get _ _ _ hkn, initialSeed_get _ _ _ hkn] + apply get_set_ne + intro equal + have bound : position (.fold (initialLevel p) (⟨k,hkn⟩ : Fin (config p).folds[0]!)) ≤ + position (.fold (initialLevel p) j) := by + rw [CausalPositions.position_fold _ _ t, CausalPositions.position_fold _ _ t] + change levelStart (challenges (config p) t) (initialLevel p).val + k ≤ + levelStart (challenges (config p) t) (initialLevel p).val + j.val + exact Nat.add_le_add_left hk _ + rw [equal] at bound + omega + +#print axioms fiber_bound +#print axioms cover +#print axioms future_invariant + +end Whir.PCSRoundByRoundCancellation diff --git a/verification/whir/Whir/PCSRoundByRoundCausalEvents.lean b/verification/whir/Whir/PCSRoundByRoundCausalEvents.lean new file mode 100644 index 000000000..e173ba77d --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundCausalEvents.lean @@ -0,0 +1,17 @@ +import Whir.CausalPrefix + +/-! The cumulative RBR state uses the actual causal-prefix provider, including +the final tail scalar with no following prover reply. -/ +namespace Whir.PCSRoundByRoundCausalEvents +open Concrete Protocol CausalGame CausalProbability + +/-- Consolidated actual bad-event invariance, without acceptance, availability, +or a supplied cover. The existing provider derives every coordinate case. -/ +theorem bad_set_future (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) (r q : Coordinate input.config) + (t : Tape input.config) (x : Sample q) (later : position r < position q) : + CausalBadEvents.Bad input strategy r (set q t x) ↔ CausalBadEvents.Bad input strategy r t := + CausalPrefix.event_set_future input strategy valid r q t x later + +#print axioms bad_set_future +end Whir.PCSRoundByRoundCausalEvents diff --git a/verification/whir/Whir/PCSRoundByRoundEnvelope.lean b/verification/whir/Whir/PCSRoundByRoundEnvelope.lean new file mode 100644 index 000000000..3ad63d42e --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundEnvelope.lean @@ -0,0 +1,297 @@ +import Whir.WHIRFiatShamir +import Whir.PCSRoundByRoundCausalEvents + +/-! General response-independent WHIR envelopes. There is no public claim-count +cap here: the local loss retains the actual public claim count. -/ +namespace Whir.PCSRoundByRoundEnvelope +open Concrete Protocol CausalGame CausalProbability CausalExecution ParameterBounds +open CausalPositions CausalStateCausality WHIRFiatShamir +open scoped BigOperators +open Classical +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 +attribute [local irreducible] ParameterBounds.config + +noncomputable def core (input : Public) (strategy : Strategy) (q : Coordinate input.config) + (t : Tape input.config) : Prop := Envelope input strategy q t (get q t) + + theorem query_bad_cover (p : Profile) (input : Public) (profile : input.config = config p) + (strategy : Strategy) (i : Fin input.config.folds.size) (t : Tape input.config) + (x : Sample (.query i)) + (bad : CausalBoundary.QueryEvent input strategy i (set (.query i) t x)) : + QueryEnvelope input strategy i t x := by + rcases input with ⟨c,lanes,root,claims⟩ + dsimp only at profile + subst c + let input : Public := ⟨config p,lanes,root,claims⟩ + have facts := CausalBoundary.production_boundary_facts p i + obtain ⟨prior,restores⟩ := CausalBoundary.query_event_fiber input strategy t i x facts.1 facts.2.1 bad + exact ⟨prior,canonical_query_restores _ _ _ _ _ _ _ _ _ _ _ _ restores⟩ + + theorem query_fiber_bound (p : Profile) (input : Public) (profile : input.config = config p) + (strategy : Strategy) (i : Fin input.config.folds.size) (t : Tape input.config) : + Soundness.uniformProb (Finset.univ.filter (QueryEnvelope input strategy i t)) ≤ + GroupedChallenges.queryBatchError input.config (ParameterBounds.estimates input.config) i := by + classical + by_cases prior : CausalBoundary.QueryPrior input strategy i t + · have bound := CausalBoundary.actual_transition input strategy t p profile i + (fun tape _ => (QueryBatchSoundness.queries + (remaining input.config i + input.config.rates[i.val]!) input.config.queries[i.val]! tape).map + (fun q => (levelAt input strategy t i).oracle[q]!)) + (fun _ _ => default) prior.2.1 prior.2.2.1 prior.2.2.2 + unfold QueryEnvelope + simp only [prior,true_and] + exact bound + · have empty : (Finset.univ.filter (QueryEnvelope input strategy i t)) = ∅ := by + apply Finset.filter_eq_empty_iff.mpr + intro x hx event + exact prior event.1 + rw [empty] + simp only [Soundness.uniformProb, Finset.card_empty, Nat.cast_zero, zero_div] + have alphaBound : 0 < ParameterBounds.alpha input.config.rates[i.val]! := by + rcases input with ⟨c,lanes,root,claims⟩ + dsimp only at profile + subst c + exact (production_level_facts p i).2.2.2.2.2.2.1 + unfold GroupedChallenges.queryBatchError ParameterBounds.estimates GroupedChallenges.fieldSize + split_ifs <;> positivity + +/-- Raw bad-event cover derived from the authenticated actual transition. -/ +theorem bad_cover (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (q : Coordinate (config p)) (t : Tape (config p)) + (bad : CausalBadEvents.Bad (ExecutionShapes.Input p lanes root claims) strategy q t) : + core (ExecutionShapes.Input p lanes root claims) strategy q t := by + unfold core + cases q with + | query i => + change CausalBoundary.QueryEvent (ExecutionShapes.Input p lanes root claims) strategy i t at bad + apply query_bad_cover p _ rfl + simpa only [set_get] using bad + | initial => simpa only [Envelope,set_get] using bad + | fold i j => simpa only [Envelope,set_get] using bad + | ood i j => simpa only [Envelope,set_get] using bad + | tail j => simpa only [Envelope,set_get] using bad + +private theorem restores_fields (n rate count i : Nat) (root : Oracle) + (cs ds : LevelChallenges) (p q : LevelProof) (state : VerifierState E) + (candidates : Finset (Array E)) + (rowsAt : LevelBoundary.QueryTape (n+rate) count → E → Oracle) + (introAt : LevelBoundary.QueryTape (n+rate) count → E → Message E) + (x : LevelBoundary.QueryTape (n+rate) count × E) + (folds : cs.folds = ds.folds) (points : cs.oodPoints = ds.oodPoints) + (oods : p.oods = q.oods) : + QueryBatchSoundness.Restores n rate count i root cs p state candidates rowsAt introAt x ↔ + QueryBatchSoundness.Restores n rate count i root ds q state candidates rowsAt introAt x := by + cases cs + cases ds + cases p + cases q + cases folds + cases points + cases oods + rfl + +/-- Replacing the current tape draw cannot reveal a current prover response in +an envelope: query rows are canonical, and the current intro is overwritten. -/ +theorem Envelope_self_set (input : Public) (strategy : Strategy) (q : Coordinate input.config) + (t : Tape input.config) (x y : Sample q) : + Envelope input strategy q (set q t x) y ↔ Envelope input strategy q t y := by + cases q with + | query i => + change QueryEnvelope input strategy i (set (.query i) t x) y ↔ QueryEnvelope input strategy i t y + dsimp only [QueryEnvelope] + rw [CausalBoundary.query_prior_set, CausalBoundary.query_level_set, + CausalBoundary.query_boundary_set, + CausalBoundary.followingCandidates_set input strategy t (.query i) x i (by + rw [position_query i t]; omega)] + apply and_congr_right + intro prior + apply restores_fields + · rw [CausalBoundary.query_challenges] + · rw [CausalBoundary.query_challenges] + · apply CausalBoundary.oods_set + rw [position_query i t] + | initial => simp only [Envelope,set_set] + | fold i j => simp only [Envelope,set_set] + | ood i j => simp only [Envelope,set_set] + | tail j => simp only [Envelope,set_set] + +open Classical in + theorem envelope_fiber (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (laneBound : lanes ≤ 2^(config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2^(config p).logN) + (strategy : Strategy) (q : Coordinate (config p)) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter + (Envelope (ExecutionShapes.Input p lanes root claims) strategy q t)) ≤ + CausalBadEvents.localError (ExecutionShapes.Input p lanes root claims) q := by + cases q with + | query i => + convert query_fiber_bound p (ExecutionShapes.Input p lanes root claims) rfl strategy i t using 1 <;> rfl + | initial => exact CausalBadEvents.fiber_bound p lanes root claims laneBound shape strategy .initial t + | fold i j => exact CausalBadEvents.fiber_bound p lanes root claims laneBound shape strategy (.fold i j) t + | ood i j => exact CausalBadEvents.fiber_bound p lanes root claims laneBound shape strategy (.ood i j) t + | tail j => exact CausalBadEvents.fiber_bound p lanes root claims laneBound shape strategy (.tail j) t + +open Classical in + theorem fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (laneBound : lanes ≤ 2^(config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2^(config p).logN) + (strategy : Strategy) (q : Coordinate (config p)) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => + core (ExecutionShapes.Input p lanes root claims) strategy q (set q t x)) ≤ + CausalBadEvents.localError (ExecutionShapes.Input p lanes root claims) q := by + unfold core + simp_rw [get_set,Envelope_self_set] + exact envelope_fiber p lanes root claims laneBound shape strategy q t + +private theorem set_comm {c : Config} (q r : Coordinate c) (t : Tape c) + (x : Sample q) (y : Sample r) (different : r ≠ q) : + set r (set q t x) y = set q (set r t y) x := by + apply (coordinates c).injective + funext s + change get s (set r (set q t x) y) = get s (set q (set r t y) x) + by_cases sr : s = r + · subst s + rw [get_set, get_set_ne _ _ _ _ different, get_set] + · by_cases sq : s = q + · subst s + rw [get_set_ne _ _ _ _ (Ne.symm different),get_set,get_set] + · rw [get_set_ne _ _ _ _ sr,get_set_ne _ _ _ _ sq, + get_set_ne _ _ _ _ sq,get_set_ne _ _ _ _ sr] + +private theorem query_future (input : Public) (strategy : Strategy) + (i : Fin input.config.folds.size) (q : Coordinate input.config) (t : Tape input.config) + (x : Sample q) (y : Sample (.query i)) (later : position (.query i) < position q) : + QueryEnvelope input strategy i (set q t x) y ↔ QueryEnvelope input strategy i t y := by + have endBefore : levelStart (challenges input.config t) (i.val+1) ≤ position q := by + rw [position_query i t] at later + rw [CausalRefinement.levelStart_succ,challenge_folds_size,challenge_oods_size] + omega + have before : levelStart (challenges input.config t) i.val + input.config.folds[i.val]! ≤ position q := by + rw [position_query i t] at later + omega + have level := levelAt_set input strategy q t x i i.isLt.le (by omega) + have state := foldAt_set input strategy q t x i input.config.folds[i.val]! le_rfl before + change CausalBoundary.boundary input strategy (set q t x) i = CausalBoundary.boundary input strategy t i at state + have list := CausalBoundary.followingCandidates_set input strategy t q x i before + have cs := challenge_level_set input.config q t x i endBefore + have proofLevel := proof_level_set input strategy q t x i endBefore + dsimp only [QueryEnvelope,CausalBoundary.QueryPrior] + simp only [level,state,list,cs,proofLevel] + by_cases last : i.val+1 < input.config.folds.size + · simp only [last,ite_true] + · simp only [last,ite_false,CausalBoundary.residual_set input strategy t q x i last before] + +/-- The whole envelope function is invariant under every future coordinate. -/ +theorem envelope_future (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) (r q : Coordinate input.config) + (t : Tape input.config) (x : Sample q) (y : Sample r) (later : position r < position q) : + Envelope input strategy r (set q t x) y ↔ Envelope input strategy r t y := by + have different : r ≠ q := by intro h; subst r; omega + cases r with + | query i => exact query_future input strategy i q t x y later + | initial => + dsimp only [Envelope] + rw [set_comm q .initial t x y different] + exact PCSRoundByRoundCausalEvents.bad_set_future input strategy valid .initial q _ x later + | fold i j => + dsimp only [Envelope] + rw [set_comm q (.fold i j) t x y different] + exact PCSRoundByRoundCausalEvents.bad_set_future input strategy valid (.fold i j) q _ x later + | ood i j => + dsimp only [Envelope] + rw [set_comm q (.ood i j) t x y different] + exact PCSRoundByRoundCausalEvents.bad_set_future input strategy valid (.ood i j) q _ x later + | tail j => + dsimp only [Envelope] + rw [set_comm q (.tail j) t x y different] + exact PCSRoundByRoundCausalEvents.bad_set_future input strategy valid (.tail j) q _ x later + + theorem future_invariant (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (r q : Coordinate (config p)) (t : Tape (config p)) + (x : Sample q) (later : position r < position q) : + core (ExecutionShapes.Input p lanes root claims) strategy r (set q t x) ↔ + core (ExecutionShapes.Input p lanes root claims) strategy r t := by + unfold core + rw [get_set_ne q r t x (by intro h; subst r; omega)] + exact envelope_future (ExecutionShapes.Input p lanes root claims) strategy + (production_config_valid p).1 r q t x (get r t) later + +private theorem finite_pred_congr {I : Type*} [Fintype I] [DecidableEq I] {A : I → Type*} + (P : ((i : I) → A i) → Prop) (locked : I → Prop) + (step : ∀ f i, ¬ locked i → ∀ x, P (Function.update f i x) ↔ P f) + (f g : (i : I) → A i) (same : ∀ i, locked i → f i = g i) : P f ↔ P g := by + have repair (s : Finset I) : ∀ f g : (i : I) → A i, + (∀ i, i ∉ s → f i = g i) → + (∀ i, locked i → f i = g i) → (P f ↔ P g) := by + induction s using Finset.induction_on with + | empty => + intro f g outside _ + have equal : f = g := funext fun i => outside i (by simp) + rw [equal] + | @insert i s absent ih => + intro f g outside fixed + by_cases equal : f i = g i + · apply ih f g ?_ fixed + intro j hj + by_cases ji : j = i + · subst j; exact equal + · exact outside j (by simp [hj,ji]) + · have unlocked : ¬ locked i := fun h => equal (fixed i h) + let mid := Function.update f i (g i) + have outside' : ∀ j, j ∉ s → mid j = g j := by + intro j hj + by_cases ji : j = i + · subst j; simp [mid] + · simpa only [mid,Function.update_of_ne ji] using outside j (by simp [hj,ji]) + have fixed' : ∀ j, locked j → mid j = g j := by + intro j hj + have ji : j ≠ i := by intro equal; subst j; exact unlocked hj + simpa only [mid,Function.update_of_ne ji] using fixed j hj + exact (step f i unlocked (g i)).symm.trans (ih mid g outside' fixed') + exact repair Finset.univ f g (by intro i impossible; simp at impossible) same + +/-- The envelope function sees only strict-past draws. In particular neither +the current response nor any later random draw participates in allocation. -/ +theorem Envelope_prefix_congr (input : Public) (strategy : Strategy) + (valid : input.config.valid = true) (q : Coordinate input.config) + (t u : Tape input.config) (y : Sample q) + (same : ∀ r, position r < position q → get r t = get r u) : + Envelope input strategy q t y ↔ Envelope input strategy q u y := by + let P := fun f : (r : Coordinate input.config) → Sample r => + Envelope input strategy q ((coordinates input.config).symm f) y + have step : ∀ f r, ¬ position r < position q → ∀ x, + P (Function.update f r x) ↔ P f := by + intro f r later x + have replaced : (coordinates input.config).symm (Function.update f r x) = + set r ((coordinates input.config).symm f) x := by + simp only [CausalProbability.set,Equiv.apply_symm_apply] + dsimp only [P] + rw [replaced] + by_cases equal : r = q + · subst r + exact Envelope_self_set input strategy q _ x y + · have distinct : position r ≠ position q := + fun h => equal (CausalPrefix.position_injective input.config h) + exact envelope_future input strategy valid q r _ x y (by omega) + have result := finite_pred_congr P (fun r => position r < position q) step + (coordinates input.config t) (coordinates input.config u) same + simpa only [P,Equiv.symm_apply_apply] using result + +theorem prefix_invariant (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (strategy : Strategy) (q : Coordinate (config p)) (t u : Tape (config p)) + (same : ∀ r, position r ≤ position q → get r t = get r u) : + core (ExecutionShapes.Input p lanes root claims) strategy q t ↔ + core (ExecutionShapes.Input p lanes root claims) strategy q u := by + unfold core + rw [same q le_rfl] + exact Envelope_prefix_congr (ExecutionShapes.Input p lanes root claims) strategy + (production_config_valid p).1 q t u (get q u) (fun r hr => same r hr.le) + +#print axioms bad_cover +#print axioms fiber_bound +#print axioms Envelope_self_set +#print axioms future_invariant +#print axioms Envelope_prefix_congr +#print axioms prefix_invariant +end Whir.PCSRoundByRoundEnvelope diff --git a/verification/whir/Whir/PCSRoundByRoundKnowledge.lean b/verification/whir/Whir/PCSRoundByRoundKnowledge.lean new file mode 100644 index 000000000..cc5bba861 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundKnowledge.lean @@ -0,0 +1,291 @@ +import Whir.PCSRoundByRoundKnowledgeState +import Whir.PCSRoundByRoundKnowledgeLedger +import Whir.PCSRoundByRoundKnowledgeRecovery +import Whir.PCSRewindKnowledgeOriginalChance +import Whir.PCSRoundByRoundSourceDecoderCost + +/-! The ideal additive characteristic-two source IOP's causal RBR knowledge +endpoint. This is not the interactive reset extractor and not a BCS, Merkle, +Fiat-Shamir, or duplex transport theorem. Extractor inputs are the immutable +original public statement and the prover's full Root0 string only. -/ +namespace Whir.PCSRoundByRoundKnowledge +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open PCSRoundByRoundSource +open scoped BigOperators +open Classical + +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +attribute [local irreducible] ParameterBounds.config +attribute [local irreducible] roundBad RingPCSGame.Escape + +private theorem uniform_implication {A : Type} [Fintype A] (P Q : A → Prop) + [DecidablePred P] [DecidablePred Q] (cover : ∀ x, P x → Q x) : + Soundness.uniformProb (Finset.univ.filter P) ≤ + Soundness.uniformProb (Finset.univ.filter Q) := by + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast Finset.card_le_card (show Finset.univ.filter P ⊆ Finset.univ.filter Q from + fun x member => Finset.mem_filter.mpr + ⟨Finset.mem_univ _, cover x (Finset.mem_filter.mp member).2⟩) + +section Source +variable {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + +/-- There is no verifier randomness, strategy, transcript suffix, or reset +access in the implemented straight-line extractor's type. -/ +def extract : Option (Witness (config p) lanes) := + PCSRoundByRoundSource.run p lanes family points anchorPoint anchorValue root + +noncomputable def sourceState (ringSeen : Bool) (completed : Finset (Coordinate (config p))) + (publicPrefix : RingPCSGame.Prefix) (t : Tape (config p)) : Bool := + if ringSeen = true ∧ RingPCSGame.Escape (config p) lanes root family publicPrefix then true else + state (roundBad p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims + (strategy publicPrefix)) completed t +attribute [local irreducible] sourceState + +@[simp] theorem sourceState_initial (publicPrefix : RingPCSGame.Prefix) (t : Tape (config p)) : + sourceState p lanes family points anchorPoint anchorValue prepared root strategy false ∅ publicPrefix t = false := by + simp [sourceState] + +/-- Physical rectangularity is an actual accepting-verifier guard, not an +availability assumption or an honest-root equality. -/ +theorem accepted_root_shape (publicPrefix : RingPCSGame.Prefix) (t : Tape (config p)) + (accepted : experiment (OriginalClaimsChecker.input prepared root publicPrefix) (strategy publicPrefix) t = true) : + FullRoot (config p) lanes root := by + let claims := (OriginalClaimsChecker.input prepared root publicPrefix).claims + let i := SupportedCandidateProtocol.initialLevel p + have valid : oracleValid (liftRoot root) (length (config p) 0) lanes = true := by + simpa only [i, SupportedCandidateProtocol.initialLevel, CausalExecution.levelAt_zero, + CausalExecution.initial, beq_self_eq_true, ↓reduceIte] using + AcceptedShapes.accepted_oracle p lanes root claims (strategy publicPrefix) t accepted i + have shape := valid + simp only [oracleValid, Bool.and_eq_true, beq_iff_eq, liftRoot, Array.size_map] at shape + have lengthEq : length (config p) 0 = SupportedCandidateExtraction.blockLength (config p) := by + have dims : remaining (config p) 0 = (config p).logN - (config p).folds[0]! := + (InitialCandidates.production_initial_facts p).1 + change 2 ^ (remaining (config p) 0 + (config p).rates[0]!) = + 2 ^ ((config p).logN - (config p).folds[0]! + (config p).rates[0]!) + rw [dims] + refine ⟨shape.1.trans lengthEq, ?_⟩ + intro j + have row := OracleReplay.oracleValid_row _ _ _ valid j.val (j.isLt.trans_eq shape.1) + simpa [liftRoot, getElem!_pos, j.isLt] using row + +/-- Acceptance together with failure of the actual implemented full-root +extractor implies final state one. All original slices, ordinary/strided point +claims and the saved original anchor occur in the conclusion's relation. -/ +theorem accepted_extraction_failure_final + (familyCap : m ≤ 2^64) (pointCap : points.size ≤ 2^64) (full : FullRoot (config p) lanes root) + (publicPrefix : RingPCSGame.Prefix) (t : Tape (config p)) + (accepted : experiment (OriginalClaimsChecker.input prepared root publicPrefix) (strategy publicPrefix) t = true) + (failure : ¬ ∃ w, extract p lanes family points anchorPoint anchorValue root = some w ∧ + PCSRewindSource.ExplainsOriginal (config p) lanes root family points anchorPoint anchorValue w) : + sourceState p lanes family points anchorPoint anchorValue prepared root strategy true Finset.univ publicPrefix t = true := by + classical + by_cases ringBad : RingPCSGame.Escape (config p) lanes root family publicPrefix + · simp [sourceState, ringBad] + · by_cases any : ∃ q, roundBad p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims + (strategy publicPrefix) q t + · simp only [sourceState, ringBad, and_false, ↓reduceIte] + exact (state_final _ t).mpr any + · have safe : ¬ SupportedCandidateProtocol.KnowledgeBad p lanes root + (OriginalClaimsChecker.input prepared root publicPrefix).claims (strategy publicPrefix) t := + fun bad => any (knowledgeBad_cover _ _ _ _ _ _ bad) + have notLow : ¬ LowSupportQuery p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims + (strategy publicPrefix) t := fun low => any ⟨_, lowSupport_cover _ _ _ _ _ _ low⟩ + exact (failure (accepted_safe_run p lanes family points anchorPoint anchorValue prepared root publicPrefix + (strategy publicPrefix) t familyCap pointCap full accepted ringBad safe notLow)).elim + +/-- Actual accepting-path endpoint: rectangularity is derived from the verifier +guard. No availability, safe-event cover, or RBR-soundness premise remains. -/ +theorem accepted_extraction_failure_final_actual + (familyCap : m ≤ 2^64) (claimCap : points.size + 2 ≤ 2^64) + (publicPrefix : RingPCSGame.Prefix) (t : Tape (config p)) + (accepted : experiment (OriginalClaimsChecker.input prepared root publicPrefix) (strategy publicPrefix) t = true) + (failure : ¬ ∃ w, extract p lanes family points anchorPoint anchorValue root = some w ∧ + PCSRewindSource.ExplainsOriginal (config p) lanes root family points anchorPoint anchorValue w) : + sourceState p lanes family points anchorPoint anchorValue prepared root strategy true Finset.univ publicPrefix t = true := + accepted_extraction_failure_final p lanes family points anchorPoint anchorValue prepared root strategy + familyCap (by omega) (accepted_root_shape p lanes family points anchorPoint anchorValue prepared root strategy + publicPrefix t accepted) publicPrefix t accepted failure + +open Classical in +/-- Ring gamma and the six actual map scalars are one grouped public-coin +message: no prover string is sent between them. Root0 and original metadata +are fixed before this message, while the subsequent strategy may depend on it. -/ +theorem ring_conditional_transition (t : Tape (config p)) (failure : RingPCSGame.Prefix → Prop) : + Soundness.uniformProb (Finset.univ.filter fun publicPrefix : RingPCSGame.Prefix => + failure publicPrefix ∧ sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true ∅ publicPrefix t = true) ≤ PCSRewindSource.ringEscapeLoss m := by + apply le_trans ?_ (RingPCSGame.escape_probability p lanes root family) + apply uniform_implication + intro publicPrefix event + by_contra absent + have doomed := event.2 + simp [sourceState, absent] at doomed + +open Classical in +/-- The exact Def31.1.6 fiber: arbitrary fixed previous public history, state +zero before the fresh message, arbitrary subsequent malicious continuation and +extractor failure. The bound is conditional, not a whole-game marginal. -/ +theorem source_conditional_transition + (completed : Finset (Coordinate (config p))) (q : Coordinate (config p)) + (publicPrefix : RingPCSGame.Prefix) (t : Tape (config p)) (failure : Sample q → Prop) + (earlier : ∀ r ∈ completed, position r < position q) + (before : sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true completed publicPrefix t = false) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => failure x ∧ + sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true (insert q completed) publicPrefix (set q t x) = true) ≤ + epsilon p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims q := by + have ringSafe : ¬ RingPCSGame.Escape (config p) lanes root family publicPrefix := by + intro bad + simp [sourceState, bad] at before + have bodyBefore : state (roundBad p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims + (strategy publicPrefix)) completed t = false := by + simpa only [sourceState, ringSafe, and_false, ↓reduceIte] using before + simp only [sourceState, ringSafe, and_false, ↓reduceIte] + apply conditional_state_transition _ completed q t failure _ bodyBefore + · intro r member x + exact roundBad_set_future p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims + (strategy publicPrefix) r q t x (earlier r member) + · exact roundBad_fiber_bound p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims + (strategy publicPrefix) prepared.guards.2.2.2.1 (PCSRewindSource.input_shapes prepared root publicPrefix) q t + +theorem source_conditional_transition_uniform + (claimCap : points.size + 2 ≤ 2^64) + (completed : Finset (Coordinate (config p))) (q : Coordinate (config p)) + (publicPrefix : RingPCSGame.Prefix) (t : Tape (config p)) (failure : Sample q → Prop) + (earlier : ∀ r ∈ completed, position r < position q) + (before : sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true completed publicPrefix t = false) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => failure x ∧ + sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true (insert q completed) publicPrefix (set q t x) = true) ≤ rbrError := + (source_conditional_transition p lanes family points anchorPoint anchorValue prepared root strategy + completed q publicPrefix t failure earlier before).trans + (epsilon_le_rbrError p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims + (by simpa only [PCSRewindSource.input_size] using claimCap) q) + +theorem ring_conditional_transition_uniform (familyCap : m ≤ 2^64) + (t : Tape (config p)) (failure : RingPCSGame.Prefix → Prop) : + Soundness.uniformProb (Finset.univ.filter fun publicPrefix : RingPCSGame.Prefix => + failure publicPrefix ∧ sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true ∅ publicPrefix t = true) ≤ rbrError := by + apply (ring_conditional_transition p lanes family points anchorPoint anchorValue prepared root strategy t failure).trans + apply (PCSRewindSource.ringEscapeLoss_le m familyCap).trans + norm_num [rbrError, SupportedCandidateExtraction.radiusEnvelope] + +/-- Exact loss for the unchanged first wire message: gamma, six map scalars, +and the initial stacking lambda form one grouped eight-field draw. -/ +noncomputable def initialLoss : ℚ := PCSRewindSource.ringEscapeLoss m + + GroupedChallenges.initialBatch (config p) (estimates (config p)) (points.size + 2) + +theorem initial_grouped_transition (t : Tape (config p)) + (failure : RingPCSGame.Prefix × E → Prop) : + Soundness.uniformProb (Finset.univ.filter fun draw : RingPCSGame.Prefix × E => + failure draw ∧ sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true {.initial} draw.1 (set .initial t draw.2) = true) ≤ initialLoss (m := m) p points := by + let ring : RingPCSGame.Prefix × E → Prop := fun draw => + RingPCSGame.Escape (config p) lanes root family draw.1 + let initialBad : RingPCSGame.Prefix × E → Prop := fun draw => + roundBad p lanes root (OriginalClaimsChecker.input prepared root draw.1).claims + (strategy draw.1) .initial (set .initial t draw.2) + have ringBound : Soundness.uniformProb (Finset.univ.filter ring) ≤ PCSRewindSource.ringEscapeLoss m := by + have law := AuthenticatedResetProbability.product_left (B := E) + (RingPCSGame.Escape (config p) lanes root family) + rw [SamplingProbability.probability_eq_uniformProb, + SamplingProbability.probability_eq_uniformProb] at law + have exactLaw := (Rat.cast_inj (α := ℝ)).mp law + exact exactLaw.trans_le (RingPCSGame.escape_probability p lanes root family) + have initialBound : Soundness.uniformProb (Finset.univ.filter initialBad) ≤ + GroupedChallenges.initialBatch (config p) (estimates (config p)) (points.size + 2) := by + rw [RingMapBatching.uniform_product initialBad] + apply (div_le_iff₀ (by positivity : (0 : ℚ) < Fintype.card RingPCSGame.Prefix)).mpr + calc + _ ≤ ∑ _publicPrefix : RingPCSGame.Prefix, + GroupedChallenges.initialBatch (config p) (estimates (config p)) (points.size + 2) := by + apply Finset.sum_le_sum + intro publicPrefix _ + have fiber := roundBad_fiber_bound p lanes root + (OriginalClaimsChecker.input prepared root publicPrefix).claims (strategy publicPrefix) + prepared.guards.2.2.2.1 (PCSRewindSource.input_shapes prepared root publicPrefix) .initial t + simpa only [initialBad, epsilon, extraLoss, CausalBadEvents.localError, + ExecutionShapes.Input, PCSRewindSource.input_size, add_zero] using fiber + _ = _ := by simp [mul_comm] + apply le_trans ?_ (InitialKnowledgeSchedule.uniform_or_bound ring initialBad _ _ ringBound initialBound) + apply uniform_implication + intro draw event + have doomed := event.2 + by_cases escaped : ring draw + · exact Or.inl escaped + · apply Or.inr + simpa only [sourceState, ring, escaped, and_false, ↓reduceIte, state, + Finset.mem_singleton, exists_eq_left, ite_eq_left_iff, + Bool.false_eq_true, imp_false, not_not, initialBad] using doomed + +theorem initialLoss_le_rbrError (familyCap : m ≤ 2^64) (claimCap : points.size + 2 ≤ 2^64) : + initialLoss (m := m) p points ≤ rbrError := by + have ring := PCSRewindSource.ringEscapeLoss_le m familyCap + have initial := (le_max_left + (GroupedChallenges.initialBatch (config p) (estimates (config p)) (points.size + 2)) _).trans + (production_grouped p (points.size + 2) claimCap) + have radiusNonnegative : (0 : ℚ) ≤ SupportedCandidateExtraction.radiusEnvelope := by + unfold SupportedCandidateExtraction.radiusEnvelope + positivity + unfold initialLoss rbrError + linarith + +/-- The implemented extractor never outputs a word failing the original source +relation; this includes Root0 candidate membership and the literal anchor. -/ +theorem extract_output_explains (w : Witness (config p) lanes) + (output : extract p lanes family points anchorPoint anchorValue root = some w) : + PCSRewindSource.ExplainsOriginal (config p) lanes root family points anchorPoint anchorValue w := + PCSRoundByRoundSource.run_output_explains _ _ _ _ _ _ _ w output + +/-- Value-connected polynomial accounting for this very extractor. The actual +Gao backend, original checker and physical root scans are counted; the field +arithmetic term has degree seven. No record search or verifier tape is present. -/ +theorem extract_polynomial_cost : + (PCSRoundByRoundSource.countedRun p lanes family points anchorPoint anchorValue root).1 = + extract p lanes family points anchorPoint anchorValue root ∧ + (PCSRoundByRoundSource.countedRun p lanes family points anchorPoint anchorValue root).2 ≤ + PCSRoundByRoundSource.resourcePolynomial (SupportedCandidateExtraction.blockLength (config p)) + (SupportedCandidateExtraction.laneCount (config p)) lanes m points.size := + ⟨PCSRoundByRoundSource.countedRun_value _ _ _ _ _ _ _, + PCSRoundByRoundSource.countedRun_polynomial_cost _ _ _ _ _ _ _⟩ + +end Source + +/-- The unchanged first message groups the ring prefix and stacking lambda; +each remaining coordinate is one actual message, including the last tail +draw. The external BCS/ROM budget does not alter this source round count. -/ +def k (p : Profile) : Nat := Fintype.card (Coordinate (config p)) + +theorem k_exact (p : Profile) : + k p = 1 + (∑ i : Fin (config p).folds.size, + ((config p).folds[i.val]! + oodCount (config p) i.val + 1)) + + ((config p).logN - (config p).folds.toList.sum) := by + unfold k + rw [Fintype.card_congr (Coordinate.proxyTypeEquiv (config p)).symm] + simp only [Fintype.card_sum, Fintype.card_sigma, Fintype.card_fin, Fintype.card_unit] + simp only [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, + Fintype.card_fin, nsmul_eq_mul, mul_one, Nat.cast_id] + omega + +#print axioms accepted_extraction_failure_final +#print axioms ring_conditional_transition +#print axioms source_conditional_transition +#print axioms extract_output_explains +#print axioms accepted_extraction_failure_final_actual +#print axioms initial_grouped_transition +#print axioms initialLoss_le_rbrError +#print axioms source_conditional_transition_uniform +#print axioms k_exact +#print axioms extract_polynomial_cost +end Whir.PCSRoundByRoundKnowledge diff --git a/verification/whir/Whir/PCSRoundByRoundKnowledgeLedger.lean b/verification/whir/Whir/PCSRoundByRoundKnowledgeLedger.lean new file mode 100644 index 000000000..9166b88c6 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundKnowledgeLedger.lean @@ -0,0 +1,270 @@ +import Whir.PCSRoundByRoundKnowledgeQuery +import Whir.PCSRoundByRoundCancellation +import Whir.PCSRoundByRoundEnvelope + +/-! Strict incoming-history envelopes for the actual additive characteristic-two +events. Current query replies cannot toggle the state. The six-fold row +cancellation is localized at its first collapsing scalar. -/ +namespace Whir.PCSRoundByRoundKnowledge +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open ParameterBounds SupportedCandidateProtocol RewindBatchTarget InitialKnowledgeSchedule +open PCSRewindExtractor (heavyQueryLoss) +open SupportedCandidateExtraction (blockLength) +open Classical + +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +attribute [local irreducible] ParameterBounds.config +attribute [local irreducible] RawMCA ClaimEscape PCSRoundByRoundEnvelope.core + +private theorem uniform_false {A : Type} [Fintype A] : + Soundness.uniformProb (Finset.univ.filter fun _ : A => False) = 0 := by + have empty : (Finset.univ.filter fun _ : A => False) = ∅ := + Finset.filter_eq_empty_iff.mpr (by intro x hx impossible; exact impossible) + rw [empty] + simp only [Soundness.uniformProb, Finset.card_empty, Nat.cast_zero, zero_div] + + +noncomputable def extraBad (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (q : Coordinate (config p)) + (t : Tape (config p)) : Prop := + match q with + | .fold i j => + if h : i = initialLevel p then + let j0 : Fin (config p).folds[0]! := ⟨j.val, by simpa only [h, initialLevel] using j.isLt⟩ + RawMCA (Input p lanes root claims) strategy (initialLevel p) j0 t ∨ + ClaimEscape (Input p lanes root claims) strategy (initialLevel p) j0 t ∨ + PCSRoundByRoundCancellation.Event p lanes root claims j0 t + else False + | .query i => i = initialLevel p ∧ + (CollisionEvent p lanes root claims strategy t ∨ LowSupportQuery p lanes root claims strategy t) + | _ => False + +noncomputable def roundBad (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (q : Coordinate (config p)) + (t : Tape (config p)) : Prop := + PCSRoundByRoundEnvelope.core (Input p lanes root claims) strategy q t ∨ + extraBad p lanes root claims strategy q t +attribute [local irreducible] extraBad roundBad + + +def extraLoss (p : Profile) (q : Coordinate (config p)) : ℚ := + match q with + | .fold i _ => if i = initialLevel p then + (2^108 : ℚ)/2^192 + (2^33 : ℚ)/2^192 + (2^32 : ℚ)*blockLength (config p)/2^192 + else 0 + | .query i => if i = initialLevel p then + (2^32 : ℚ) * ((oodCount (config p) 0 + (config p).queries[0]! : Nat)/2^192) + heavyQueryLoss p + else 0 + | _ => 0 + +def epsilon (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (q : Coordinate (config p)) : ℚ := + CausalBadEvents.localError (Input p lanes root claims) q + extraLoss p q + +open Classical in +theorem extraBad_fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (q : Coordinate (config p)) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => + extraBad p lanes root claims strategy q (set q t x)) ≤ extraLoss p q := by + cases q with + | fold i j => + by_cases same : i = initialLevel p + · subst i + simp only [extraBad, extraLoss, dite_true, ite_true] + apply (uniform_or_bound _ _ _ _ + (rawMCA_fiber_bound p lanes root claims strategy t (initialLevel p) j) + (uniform_or_bound _ _ _ _ + (claimEscape_fiber_bound p lanes root claims strategy t (initialLevel p) j) + (PCSRoundByRoundCancellation.fiber_bound p lanes root claims j t))).trans_eq + ring + · simp only [extraBad, extraLoss, same, dite_false, ite_false] + rw [uniform_false] + | query i => + by_cases same : i = initialLevel p + · subst i + simpa only [extraBad, extraLoss, true_and, ite_true] using + uniform_or_bound _ _ _ _ + (collisionEvent_fiber_bound p lanes root claims strategy t) + (lowSupportQuery_fiber_bound p lanes root claims strategy t) + · simp only [extraBad, extraLoss, same, false_and, ite_false] + rw [uniform_false] + | initial => + simp only [extraBad, extraLoss] + rw [uniform_false] + | ood i j => + simp only [extraBad, extraLoss] + rw [uniform_false] + | tail j => + simp only [extraBad, extraLoss] + rw [uniform_false] + +open Classical in +/-- Exact local loss on every arbitrary fixed incoming execution history. -/ +theorem roundBad_fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ 2 ^ (config p).folds[0]!) + (shape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (config p).logN) + (q : Coordinate (config p)) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => + roundBad p lanes root claims strategy q (set q t x)) ≤ epsilon p lanes root claims q := by + let A := Finset.univ.filter fun x : Sample q => + roundBad p lanes root claims strategy q (set q t x) + let B := Finset.univ.filter fun x : Sample q => + PCSRoundByRoundEnvelope.core (Input p lanes root claims) strategy q (set q t x) + let C := Finset.univ.filter fun x : Sample q => + extraBad p lanes root claims strategy q (set q t x) + have cover : A ⊆ B ∪ C := by + intro x member + have event := (Finset.mem_filter.mp member).2 + unfold roundBad at event + rcases event with core | extra + · exact Finset.mem_union.mpr (Or.inl (Finset.mem_filter.mpr ⟨Finset.mem_univ _, core⟩)) + · exact Finset.mem_union.mpr (Or.inr (Finset.mem_filter.mpr ⟨Finset.mem_univ _, extra⟩)) + have card : A.card ≤ B.card + C.card := + (Finset.card_le_card cover).trans (Finset.card_union_le B C) + have unionBound : Soundness.uniformProb A ≤ Soundness.uniformProb B + Soundness.uniformProb C := by + unfold Soundness.uniformProb + rw [← add_div] + apply div_le_div_of_nonneg_right _ (by positivity) + exact_mod_cast card + exact unionBound.trans (add_le_add + (PCSRoundByRoundEnvelope.fiber_bound p lanes root claims laneBound shape strategy q t) + (extraBad_fiber_bound p lanes root claims strategy q t)) + +theorem knowledgeBad_cover (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (bad : KnowledgeBad p lanes root claims strategy t) : + ∃ q, roundBad p lanes root claims strategy q t := by + unfold roundBad + rcases bad with causal | folds | cancellation | collision + · obtain ⟨q, event⟩ := causal + exact ⟨q, Or.inl (PCSRoundByRoundEnvelope.bad_cover p lanes root claims strategy q t event)⟩ + · obtain ⟨j, event⟩ := folds + refine ⟨.fold (initialLevel p) j, Or.inr ?_⟩ + simp only [extraBad, dite_true] + rcases event with raw | claim + · exact Or.inl raw + · exact Or.inr (Or.inl claim) + · obtain ⟨j, event⟩ := PCSRoundByRoundCancellation.cover p lanes root claims t cancellation + exact ⟨.fold (initialLevel p) j, Or.inr (by simp only [extraBad, dite_true]; exact Or.inr (Or.inr event))⟩ + · refine ⟨.query (initialLevel p), Or.inr ?_⟩ + unfold extraBad + exact ⟨rfl, Or.inl collision⟩ + +theorem lowSupport_cover (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (low : LowSupportQuery p lanes root claims strategy t) : + roundBad p lanes root claims strategy (.query (initialLevel p)) t := by + unfold roundBad extraBad + exact Or.inr ⟨rfl, Or.inr low⟩ + +theorem collisionEvent_set_future (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (q : Coordinate (config p)) (x : Sample q) + (later : position (.query (initialLevel p)) < position q) : + CollisionEvent p lanes root claims strategy (set q t x) ↔ + CollisionEvent p lanes root claims strategy t := by + have fixed := Root0FixedTarget.snapshot_set (Input p lanes root claims) strategy t + (initialLevel p) q x later.le + have list := congrArg (fun s => s.1) fixed + have boundary := congrArg (fun s => s.2.1) fixed + have oracle := congrArg (fun s => s.2.2.1) fixed + have answers := congrArg (fun s => s.2.2.2.1) fixed + have folds := congrArg (fun s => s.2.2.2.2.1) fixed + have points := congrArg (fun s => s.2.2.2.2.2) fixed + dsimp only [Root0FixedTarget.snapshot, initialLevel] at list boundary oracle answers folds points + have draw := get_set_ne q (.query (initialLevel p)) t x (by + intro same + rw [same] at later + exact lt_irrefl _ later) + unfold CollisionEvent Collision QueryBatchSoundness.polynomial BatchingRefinement.errorPolynomial + BatchingRefinement.oodError BatchingRefinement.queryError + rw [draw, list, boundary, oracle, answers, folds, points] + +theorem extraBad_set_future (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (r q : Coordinate (config p)) + (t : Tape (config p)) (x : Sample q) (later : position r < position q) : + extraBad p lanes root claims strategy r (set q t x) ↔ + extraBad p lanes root claims strategy r t := by + cases r with + | fold i j => + by_cases same : i = initialLevel p + · subst i + have before : levelStart (challenges (config p) t) 0 + j.val + 1 ≤ position q := by + rw [CausalPositions.position_fold _ _ t] at later + exact later + have guards := knowledgeEvents_set_future (Input p lanes root claims) strategy t + (initialLevel p) j q x before + simp only [extraBad, dite_true] + rw [guards.1, guards.2, PCSRoundByRoundCancellation.future_invariant p lanes root claims j q t x later] + · simp [extraBad, same] + | query i => + by_cases same : i = initialLevel p + · subst i + simp only [extraBad, true_and] + rw [collisionEvent_set_future p lanes root claims strategy t q x later, + lowSupportQuery_set_future p lanes root claims strategy t q x later] + · simp [extraBad, same] + | initial => simp only [extraBad] + | ood i j => simp only [extraBad] + | tail j => simp only [extraBad] + +/-- Every stored event is determined by the actual already completed causal +history, even for malformed strategies and arbitrary future challenge tapes. -/ +theorem roundBad_set_future (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (r q : Coordinate (config p)) + (t : Tape (config p)) (x : Sample q) (later : position r < position q) : + roundBad p lanes root claims strategy r (set q t x) ↔ + roundBad p lanes root claims strategy r t := by + unfold roundBad + rw [PCSRoundByRoundEnvelope.future_invariant p lanes root claims strategy r q t x later, + extraBad_set_future p lanes root claims strategy r q t x later] + +/-- A conservative uniform per-message envelope, derived only after the +conditional fibers have been proved. It is not the q56 extraction cutoff. -/ +def rbrError : ℚ := SupportedCandidateExtraction.radiusEnvelope + 1 / 2^78 + +theorem extraLoss_le (p : Profile) (q : Coordinate (config p)) : + extraLoss p q ≤ heavyQueryLoss p + 1 / 2^80 := by + have hnonnegative : (0 : ℚ) ≤ heavyQueryLoss p := by + unfold heavyQueryLoss + positivity + have cnonnegative : (0 : ℚ) ≤ (2^32 : ℚ) * blockLength (config p) / 2^192 := by positivity + have bnonnegative : (0 : ℚ) ≤ (2^32 : ℚ) * + ((oodCount (config p) 0 + (config p).queries[0]! : Nat) / 2^192) := by positivity + have budget := production_extra_ledger p + cases q with + | fold i j => + by_cases same : i = initialLevel p + · simp only [extraLoss, same, ite_true] + linarith + · simp only [extraLoss, same, ite_false] + positivity + | query i => + by_cases same : i = initialLevel p + · simp only [extraLoss, same, ite_true] + linarith + · simp only [extraLoss, same, ite_false] + positivity + | initial => simp only [extraLoss]; positivity + | ood i j => simp only [extraLoss]; positivity + | tail j => simp only [extraLoss]; positivity + +theorem epsilon_le_rbrError (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (cap : claims.size ≤ 2^64) (q : Coordinate (config p)) : + epsilon p lanes root claims q ≤ rbrError := by + have localBound := (CausalBadEvents.localError_le_groupedMaximum + (Input p lanes root claims) q).trans (production_grouped p claims.size cap) + have extra := extraLoss_le p q + have heavy := PCSRewindExtractor.production_heavyQueryLoss p + unfold epsilon rbrError + linarith + +#print axioms extraBad_fiber_bound +#print axioms roundBad_fiber_bound +#print axioms knowledgeBad_cover +#print axioms roundBad_set_future +#print axioms epsilon_le_rbrError + +end Whir.PCSRoundByRoundKnowledge diff --git a/verification/whir/Whir/PCSRoundByRoundKnowledgeQuery.lean b/verification/whir/Whir/PCSRoundByRoundKnowledgeQuery.lean new file mode 100644 index 000000000..ffb1d362a --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundKnowledgeQuery.lean @@ -0,0 +1,159 @@ +import Whir.PCSRoundByRoundSourceDecoder +import Whir.SupportedCandidateProtocolAccepted +import Whir.PCSRewindKnowledgeOriginalRecovery + +/-! The Root0 query loss is conditional on an arbitrary fixed incoming public +history. Separation fixes one target before querying; there is no candidate-list +factor in the heavy-query term. -/ +namespace Whir.PCSRoundByRoundKnowledge +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open ParameterBounds SupportedCandidateProtocol RewindBatchTarget +open PCSRewindExtractor (heavyAgreementCap heavyQueryLoss production_heavy_static) +open SupportedCandidateExtraction (blockLength) + +set_option maxRecDepth 100000 +set_option maxHeartbeats 1000000 +attribute [local irreducible] ParameterBounds.config + +/-- Native query indexing; the production initial-dimension theorem identifies +this with `PCSRewindExtractor.initialDepth` without changing the query law. -/ +abbrev initialDepth (p : Profile) := remaining (config p) 0 + (config p).rates[0]! + +noncomputable def TargetAt (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (target : Array E) : Prop := + Target (followingCandidates (Input p lanes root claims) strategy t 0) + (challenges (config p) t).levels[0]!.oodPoints[0]! + (proof (Input p lanes root claims) strategy t).levels[0]!.oods[0]!.value target ∧ + LevelBoundary.Separated (followingCandidates (Input p lanes root claims) strategy t 0) + (challenges (config p) t).levels[0]!.oodPoints[0]! + +noncomputable def scalarSupport (p : Profile) (root : BaseOracle) + (t : Tape (config p)) (target : Array E) := + LevelBoundary.agreeingColumns (remaining (config p) 0) (config p).rates[0]! target + (QueryBatchSoundness.oldWord (remaining (config p) 0) (config p).rates[0]! + (liftRoot root) true (challenges (config p) t).levels[0]!.folds) + +noncomputable def LowSupportQuery (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) : Prop := + ∃ target, TargetAt p lanes root claims strategy t target ∧ + (scalarSupport p root t target).card ≤ heavyAgreementCap p ∧ + SamplingProbability.allQueriesHit (initialDepth p) (config p).queries[0]! + (scalarSupport p root t target) (get (.query (initialLevel p)) t).1 + +theorem targetAt_set (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (draw : Sample (.query (initialLevel p))) (target : Array E) : + TargetAt p lanes root claims strategy (set (.query (initialLevel p)) t draw) target ↔ + TargetAt p lanes root claims strategy t target := by + have fixed := Root0FixedTarget.snapshot_set (Input p lanes root claims) strategy t + (initialLevel p) (.query (initialLevel p)) draw le_rfl + have list := congrArg (fun s => s.1) fixed + have answers := congrArg (fun s => s.2.2.2.1) fixed + have points := congrArg (fun s => s.2.2.2.2.2) fixed + dsimp only [Root0FixedTarget.snapshot, initialLevel] at list answers points + unfold TargetAt + rw [list, answers, points] + +theorem scalarSupport_set (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (draw : Sample (.query (initialLevel p))) (target : Array E) : + scalarSupport p root (set (.query (initialLevel p)) t draw) target = + scalarSupport p root t target := by + have fixed := Root0FixedTarget.snapshot_set (Input p lanes root claims) strategy t + (initialLevel p) (.query (initialLevel p)) draw le_rfl + have folds := congrArg (fun s => s.2.2.2.2.1) fixed + dsimp only [Root0FixedTarget.snapshot, initialLevel] at folds + unfold scalarSupport + rw [folds] + +open Classical in +theorem lowSupportQuery_fiber_bound (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) : + Soundness.uniformProb (Finset.univ.filter fun draw : Sample (.query (initialLevel p)) => + LowSupportQuery p lanes root claims strategy (set (.query (initialLevel p)) t draw)) ≤ + heavyQueryLoss p := by + by_cases existsTarget : ∃ target, TargetAt p lanes root claims strategy t target ∧ + (scalarSupport p root t target).card ≤ heavyAgreementCap p + · obtain ⟨target, matching, small⟩ := existsTarget + have included : (Finset.univ.filter fun draw : Sample (.query (initialLevel p)) => + LowSupportQuery p lanes root claims strategy (set (.query (initialLevel p)) t draw)) ⊆ + Finset.univ.filter (fun draw : Sample (.query (initialLevel p)) => + SamplingProbability.allQueriesHit (initialDepth p) (config p).queries[0]! + (scalarSupport p root t target) draw.1) := by + intro draw member + obtain ⟨other, hm, hs, hit⟩ := (Finset.mem_filter.mp member).2 + have otherMatch := (targetAt_set p lanes root claims strategy t draw other).mp hm + have same := target_unique _ _ _ matching.2 other target otherMatch.1 matching.1 + subst other + rw [scalarSupport_set p lanes root claims strategy t draw, get_set] at hit + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, hit⟩ + have positive : 0 < initialDepth p := by + simpa only [initialDepth, (InitialCandidates.production_initial_facts p).1] using + (production_heavy_static p).1 + have noWrap : initialDepth p ≤ 64 := by + simpa only [initialDepth, (InitialCandidates.production_initial_facts p).1] using + (InitialCandidates.production_initial_facts p).2.2.1 + have bound := SamplingProbability.actual_query_bound_rat (initialDepth p) + (config p).queries[0]! positive noWrap (scalarSupport p root t target) + have product : Soundness.uniformProb (Finset.univ.filter + (fun draw : Sample (.query (initialLevel p)) => + SamplingProbability.allQueriesHit (initialDepth p) (config p).queries[0]! + (scalarSupport p root t target) draw.1)) = + Soundness.uniformProb (Finset.univ.filter + (SamplingProbability.allQueriesHit (initialDepth p) (config p).queries[0]! + (scalarSupport p root t target))) := by + have realLaw := AuthenticatedResetProbability.product_left (B := E) + (SamplingProbability.allQueriesHit (initialDepth p) (config p).queries[0]! + (scalarSupport p root t target)) + rw [SamplingProbability.probability_eq_uniformProb, + SamplingProbability.probability_eq_uniformProb] at realLaw + exact (Rat.cast_inj (α := ℝ)).mp realLaw + have uniform : Soundness.uniformProb (Finset.univ.filter + (fun draw : Sample (.query (initialLevel p)) => + SamplingProbability.allQueriesHit (initialDepth p) (config p).queries[0]! + (scalarSupport p root t target) draw.1)) ≤ heavyQueryLoss p := by + rw [product] + apply bound.trans + unfold heavyQueryLoss + have dims : blockLength (config p) = 2 ^ initialDepth p := by + simp only [blockLength, initialDepth, (InitialCandidates.production_initial_facts p).1] + rw [dims] + gcongr + apply le_trans ?_ uniform + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (Nat.cast_le.mpr (Finset.card_le_card included)) (by positivity) + · have empty : (Finset.univ.filter fun draw : Sample (.query (initialLevel p)) => + LowSupportQuery p lanes root claims strategy (set (.query (initialLevel p)) t draw)) = ∅ := by + apply Finset.eq_empty_iff_forall_notMem.mpr + intro draw member + obtain ⟨target, matching, small, _⟩ := (Finset.mem_filter.mp member).2 + apply existsTarget + refine ⟨target, (targetAt_set p lanes root claims strategy t draw target).mp matching, ?_⟩ + simpa only [scalarSupport_set p lanes root claims strategy t draw target] using small + rw [empty] + simp only [Soundness.uniformProb, Finset.card_empty, Nat.cast_zero, zero_div] + unfold heavyQueryLoss + positivity + +theorem lowSupportQuery_set_future (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (q : Coordinate (config p)) (x : Sample q) + (later : position (.query (initialLevel p)) < position q) : + LowSupportQuery p lanes root claims strategy (set q t x) ↔ + LowSupportQuery p lanes root claims strategy t := by + have fixed := Root0FixedTarget.snapshot_set (Input p lanes root claims) strategy t + (initialLevel p) q x later.le + have list := congrArg (fun s => s.1) fixed + have answers := congrArg (fun s => s.2.2.2.1) fixed + have folds := congrArg (fun s => s.2.2.2.2.1) fixed + have points := congrArg (fun s => s.2.2.2.2.2) fixed + dsimp only [Root0FixedTarget.snapshot, initialLevel] at list answers folds points + have draw := get_set_ne q (.query (initialLevel p)) t x (by + intro same + rw [same] at later + exact (lt_irrefl _ later)) + unfold LowSupportQuery TargetAt scalarSupport + rw [list, answers, folds, points, draw] + +end Whir.PCSRoundByRoundKnowledge diff --git a/verification/whir/Whir/PCSRoundByRoundKnowledgeRecovery.lean b/verification/whir/Whir/PCSRoundByRoundKnowledgeRecovery.lean new file mode 100644 index 000000000..8d56b4d57 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundKnowledgeRecovery.lean @@ -0,0 +1,120 @@ +import Whir.PCSRoundByRoundKnowledgeQuery +import Whir.PCSRoundByRoundSourceDecoderCorrectness + +/-! Deterministic accepted-path bridge. The SAME OOD target, its backward-lifted +Root0 witness, every original slice/point, and the literal saved anchor are all +kept distinct from the probabilistic transition ledger. -/ +namespace Whir.PCSRoundByRoundKnowledge +open Concrete Protocol CausalGame CausalExecution CausalProbability ExecutionShapes +open ParameterBounds SupportedCandidateProtocol RewindBatchTarget +open PCSRewindExtractor (heavyAgreementCap production_heavy_static) +open SupportedCandidateExtraction (width blockLength) +open PCSRoundByRoundSource + +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +attribute [local irreducible] ParameterBounds.config + +/-- Safe acceptance either pays the real low-support query event or identifies +one strongly supported Root0 word explaining the original immutable statement. -/ +theorem accepted_safe_strong_original {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (publicPrefix : RingPCSGame.Prefix) (strategy : Strategy) + (t : Tape (config p)) + (accepted : experiment (OriginalClaimsChecker.input prepared root publicPrefix) strategy t = true) + (ringSafe : ¬ RingPCSGame.Escape (config p) lanes root family publicPrefix) + (safe : ¬ KnowledgeBad p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims strategy t) + (notLow : ¬ LowSupportQuery p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims strategy t) : + ∃ w : Witness (config p) lanes, StrongRootSupport p lanes root w ∧ + PCSRewindSource.ExplainsOriginal (config p) lanes root family points anchorPoint anchorValue w := by + classical + let claims := (OriginalClaimsChecker.input prepared root publicPrefix).claims + let input := Input p lanes root claims + let i := initialLevel p + have dims : remaining (config p) 0 = (config p).logN - (config p).folds[0]! := + (InitialCandidates.production_initial_facts p).1 + have acc : experiment input strategy t = true := accepted + have causal : ∀ q, ¬ CausalBadEvents.Bad input strategy q t := by + intro q bad + exact safe (Or.inl ⟨q, bad⟩) + have collision : ¬ CollisionEvent p lanes root claims strategy t := by + intro bad + exact safe (Or.inr (Or.inr (Or.inr bad))) + have outside := (collisionEvent_set p lanes root claims strategy t (get (.query i) t)).not.mp + (show CollisionEvent p lanes root claims strategy (set (.query i) t (get (.query i) t)) → False by + simpa only [set_get] using collision) + obtain ⟨target, matching, truth⟩ := Root0FixedTarget.accepted_reset_target_exists p lanes root claims + strategy t i (production_initial_next p) (get (.query i) t) + (by simpa only [set_get] using acc) (by simpa only [set_get] using causal) outside + have separated : LevelBoundary.Separated (followingCandidates input strategy t 0) + (challenges (config p) t).levels[0]!.oodPoints[0]! := by + by_contra absent + exact causal (.ood i (firstOOD p)) absent + have hit := RewindRadiusExtraction.accepted_reset_fixed_target p lanes root claims strategy t i + (production_initial_next p) (get (.query i) t) target matching separated + (by simpa only [set_get] using acc) (by simpa only [set_get] using causal) outside + have hit' : SamplingProbability.allQueriesHit (initialDepth p) (config p).queries[0]! + (scalarSupport p root t target) (get (.query i) t).1 := by + simpa only [scalarSupport, initialDepth, i, initialLevel, levelAt_zero, initial, + beq_self_eq_true, ↓reduceIte, Input] using hit + have above : heavyAgreementCap p < (scalarSupport p root t target).card := by + by_contra small + exact notLow ⟨target, ⟨matching, separated⟩, Nat.le_of_not_gt small, hit'⟩ + have valid : oracleValid (liftRoot root) (length (config p) 0) lanes = true := by + simpa only [i, initialLevel, levelAt_zero, initial, beq_self_eq_true, ↓reduceIte] using + AcceptedShapes.accepted_oracle p lanes root claims strategy t acc i + have laneBound := AcceptedShapes.accepted_lane_bound input strategy t acc + have prior := priorGood_of_not_bad p lanes root claims strategy t safe + have size : target.size = width (config p) := by + have size := CausalBoundary.followingCandidates_sizes input strategy t p rfl i + (by intro impossible; exact (impossible (production_initial_next p)).elim) target matching.1 + change target.size = 2 ^ remaining (config p) 0 at size + simpa only [width, dims] using size + let H := LevelBoundary.agreeingColumns ((config p).logN - (config p).folds[0]!) + (config p).rates[0]! target + (QueryBatchSoundness.oldWord ((config p).logN - (config p).folds[0]!) (config p).rates[0]! + (liftRoot root) true (challenges (config p) t).levels[0]!.folds) + have aboveH : heavyAgreementCap p < H.card := by + dsimp only [scalarSupport] at above + rw [dims] at above + exact above + obtain ⟨w, explains, rows⟩ := same_w_on_support p lanes root claims strategy t valid laneBound + (fun j => (prior.1 j).1) (fun j => (prior.1 j).2) prior.2.1 prior.2.2 target size truth + H + ((production_heavy_static p).2.2.trans (by omega)) (by + intro q member + exact (Finset.mem_filter.mp member).2) + have strong : StrongRootSupport p lanes root w := by + apply aboveH.trans_le + apply Finset.card_le_card + intro q member + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, rows q member⟩ + have checked := PCSRewindSource.input_checked_of_explains prepared root publicPrefix w ringSafe explains + have original := (OriginalClaimsChecker.check_iff prepared w).mp checked + exact ⟨w, strong, explains.1, original.1, original.2⟩ + +/-- The decoder is the implemented direct-index full-root Gao decoder. No +strategy, tape, post-root randomness, availability certificate, or abstract +recovery function is an extractor input or a premise of this endpoint. -/ +theorem accepted_safe_run {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (publicPrefix : RingPCSGame.Prefix) (strategy : Strategy) + (t : Tape (config p)) (familyCap : m ≤ 2^64) (pointCap : points.size ≤ 2^64) + (full : FullRoot (config p) lanes root) + (accepted : experiment (OriginalClaimsChecker.input prepared root publicPrefix) strategy t = true) + (ringSafe : ¬ RingPCSGame.Escape (config p) lanes root family publicPrefix) + (safe : ¬ KnowledgeBad p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims strategy t) + (notLow : ¬ LowSupportQuery p lanes root (OriginalClaimsChecker.input prepared root publicPrefix).claims strategy t) : + ∃ w : Witness (config p) lanes, + PCSRoundByRoundSource.run p lanes family points anchorPoint anchorValue root = some w ∧ + PCSRewindSource.ExplainsOriginal (config p) lanes root family points anchorPoint anchorValue w := by + obtain ⟨w, heavy, original⟩ := accepted_safe_strong_original p lanes family points anchorPoint anchorValue + prepared root publicPrefix strategy t accepted ringSafe safe notLow + exact ⟨w, PCSRoundByRoundSource.run_recovers_heavy p lanes family points anchorPoint anchorValue root + prepared familyCap pointCap full w heavy original.original original.anchor, original⟩ + +end Whir.PCSRoundByRoundKnowledge diff --git a/verification/whir/Whir/PCSRoundByRoundKnowledgeState.lean b/verification/whir/Whir/PCSRoundByRoundKnowledgeState.lean new file mode 100644 index 000000000..859dfc227 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundKnowledgeState.lean @@ -0,0 +1,66 @@ +import Whir.CausalPositions + +/-! Cumulative causal state on completed verifier messages. The step theorem +uses pointwise incoming-history fibers, not a marginal probability of an entire +tape. The concrete source ledger instantiates both hypotheses. -/ +namespace Whir.PCSRoundByRoundKnowledge +open Concrete Protocol CausalGame CausalProbability +open Classical + +noncomputable def state {c : Config} (bad : Coordinate c → Tape c → Prop) + (completed : Finset (Coordinate c)) (t : Tape c) : Bool := + if ∃ q ∈ completed, bad q t then true else false + +@[simp] theorem state_initial {c : Config} (bad : Coordinate c → Tape c → Prop) + (t : Tape c) : state bad ∅ t = false := by + classical + simp [state] + +theorem state_final {c : Config} (bad : Coordinate c → Tape c → Prop) + (t : Tape c) : state bad Finset.univ t = true ↔ ∃ q, bad q t := by + classical + simp [state] + +theorem state_next {c : Config} (bad : Coordinate c → Tape c → Prop) + (completed : Finset (Coordinate c)) (q : Coordinate c) (t : Tape c) : + state bad (insert q completed) t = true ↔ state bad completed t = true ∨ bad q t := by + classical + simp [state, or_comm] + +open Classical in +/-- After any fixed undoomed public history, an arbitrary continuation can only +make this update doomed through the current message's actual event. Future +coins and extraction failure are allowed in `failure`; they are not conditioned +on or substituted for the local fiber. -/ +theorem conditional_state_transition {c : Config} + (bad : Coordinate c → Tape c → Prop) (completed : Finset (Coordinate c)) + (q : Coordinate c) (t : Tape c) (failure : Sample q → Prop) (epsilon : ℚ) + (before : state bad completed t = false) + (fixed : ∀ r ∈ completed, ∀ x : Sample q, bad r (set q t x) ↔ bad r t) + (fiber : Soundness.uniformProb (Finset.univ.filter fun x : Sample q => + bad q (set q t x)) ≤ epsilon) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => + failure x ∧ state bad (insert q completed) (set q t x) = true) ≤ epsilon := by + have included : (Finset.univ.filter fun x : Sample q => + failure x ∧ state bad (insert q completed) (set q t x) = true) ⊆ + Finset.univ.filter fun x : Sample q => bad q (set q t x) := by + intro x member + have doomed := (state_next bad completed q (set q t x)).mp (Finset.mem_filter.mp member).2.2 + rcases doomed with past | now + · have pastEvent : ∃ r ∈ completed, bad r (set q t x) := by + simpa only [state, ite_eq_left_iff, Bool.false_eq_true, imp_false, not_not] using past + obtain ⟨r, member, event⟩ := pastEvent + have old : state bad completed t = true := by + simp only [state, ite_eq_left_iff, Bool.false_eq_true, imp_false, not_not] + exact ⟨r, member, (fixed r member x).mp event⟩ + rw [before] at old + contradiction + · exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, now⟩ + apply le_trans ?_ fiber + unfold Soundness.uniformProb + exact div_le_div_of_nonneg_right (Nat.cast_le.mpr (Finset.card_le_card included)) (by positivity) + +#print axioms state_initial +#print axioms conditional_state_transition + +end Whir.PCSRoundByRoundKnowledge diff --git a/verification/whir/Whir/PCSRoundByRoundPublicCertificate.lean b/verification/whir/Whir/PCSRoundByRoundPublicCertificate.lean new file mode 100644 index 000000000..04c2c251b --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundPublicCertificate.lean @@ -0,0 +1,48 @@ +import Whir.PCSRoundByRoundPublicState +import Whir.PCSRoundByRoundKnowledge + +/-! The literal public trace predicate agrees with the checked source state. Replay and zero filling occur only in this proof bridge, not in the extractor's inputs. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge ExecutionShapes +open Classical PublicTrace + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +theorem state_replay (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (done : Finset (Coordinate (config p))) : + state (roundBad p lanes root claims (indexedStrategy (replies (Input p lanes root claims) strategy t))) done t = + state (roundBad p lanes root claims strategy) done t := by + have same := proof_replay (Input p lanes root claims) strategy t + have event : (∃ q ∈ done, roundBad p lanes root claims + (indexedStrategy (replies (Input p lanes root claims) strategy t)) q t) ↔ + (∃ q ∈ done, roundBad p lanes root claims strategy q t) := by + apply exists_congr + intro q + exact and_congr_right fun _ => round_proof_congr p lanes root claims _ strategy t same q + unfold state + simp only [event] + +theorem snapshot_publicState_source {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (ring : RingPCSGame.Prefix) (t : Tape (config p)) (boundary : Coordinate (config p)) : + publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot ring t (replies (Input p lanes root (OriginalClaimsChecker.input prepared root ring).claims) (strategy ring) t) boundary) = + sourceState p lanes family points anchorPoint anchorValue prepared root strategy true (past boundary) ring t := by + unfold publicState sourceState + simp only [snapshot_ring, true_and] + split_ifs with bad + · rfl + · rw [snapshot_state_congr] + exact state_replay p lanes root (OriginalClaimsChecker.input prepared root ring).claims + (strategy ring) t (past boundary) + +#print axioms state_replay +#print axioms snapshot_publicState_source +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/Whir/PCSRoundByRoundPublicEndpoint.lean b/verification/whir/Whir/PCSRoundByRoundPublicEndpoint.lean new file mode 100644 index 000000000..dc1d4ecdd --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundPublicEndpoint.lean @@ -0,0 +1,77 @@ +import Whir.PCSRoundByRoundPublicCertificate +import Mathlib.Data.Finset.Max + +/-! Initial grouped challenge and final acceptance use the same literal public predicate, before the following prover response. No hidden continuation is an input of that predicate. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge ExecutionShapes +open Classical PublicTrace CausalPositions CausalPrefix + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +@[simp] theorem past_initial (c : Config) : past (.initial : Coordinate c) = {.initial} := by + ext q + simp only [past, Finset.mem_filter, Finset.mem_univ, true_and, position_initial, + Finset.mem_singleton] + constructor + · intro bound + exact position_injective c (by rw [position_initial]; omega) + · rintro rfl + simp + +theorem greatest_coordinate_exists (c : Config) : + ∃ q : Coordinate c, ∀ r : Coordinate c, position r ≤ position q := by + obtain ⟨q, _, largest⟩ := Finset.exists_max_image Finset.univ (@position c) + (show (Finset.univ : Finset (Coordinate c)).Nonempty from ⟨.initial, Finset.mem_univ _⟩) + exact ⟨q, fun r => largest r (Finset.mem_univ _)⟩ + +noncomputable def lastCoordinate (c : Config) : Coordinate c := + Classical.choose (greatest_coordinate_exists c) + +theorem lastCoordinate_max (c : Config) (r : Coordinate c) : + position r ≤ position (lastCoordinate c) := + Classical.choose_spec (greatest_coordinate_exists c) r + +@[simp] theorem past_lastCoordinate (c : Config) : past (lastCoordinate c) = Finset.univ := by + ext q + simp [past, lastCoordinate_max c q] + +section Source +variable {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + +theorem literal_initial_grouped_transition (familyCap : m ≤ 2^64) + (claimCap : points.size + 2 ≤ 2^64) (t : Tape (config p)) + (failure : RingPCSGame.Prefix × E → Prop) : + Soundness.uniformProb (Finset.univ.filter fun draw : RingPCSGame.Prefix × E => + failure draw ∧ publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot draw.1 (set .initial t draw.2) + (replies (Input p lanes root (OriginalClaimsChecker.input prepared root draw.1).claims) (strategy draw.1) + (set .initial t draw.2)) .initial) = true) ≤ rbrError := by + simp only [snapshot_publicState_source, past_initial] + exact (initial_grouped_transition p lanes family points anchorPoint anchorValue prepared root strategy + t failure).trans (initialLoss_le_rbrError (m := m) p points familyCap claimCap) + +theorem literal_accepted_extraction_failure_final (familyCap : m ≤ 2^64) + (claimCap : points.size + 2 ≤ 2^64) (ring : RingPCSGame.Prefix) (t : Tape (config p)) + (accepted : experiment (OriginalClaimsChecker.input prepared root ring) (strategy ring) t = true) + (failure : ¬ ∃ w, extract p lanes family points anchorPoint anchorValue root = some w ∧ + PCSRewindSource.ExplainsOriginal (config p) lanes root family points anchorPoint anchorValue w) : + publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot ring t (replies (Input p lanes root (OriginalClaimsChecker.input prepared root ring).claims) (strategy ring) t) + (lastCoordinate (config p))) = true := by + rw [snapshot_publicState_source, past_lastCoordinate] + exact accepted_extraction_failure_final_actual p lanes family points anchorPoint anchorValue prepared root + strategy familyCap claimCap ring t accepted failure +end Source + +#print axioms past_initial +#print axioms greatest_coordinate_exists +#print axioms literal_initial_grouped_transition +#print axioms literal_accepted_extraction_failure_final +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/Whir/PCSRoundByRoundPublicEvents.lean b/verification/whir/Whir/PCSRoundByRoundPublicEvents.lean new file mode 100644 index 000000000..17b3b269d --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundPublicEvents.lean @@ -0,0 +1,84 @@ +import Whir.PCSRoundByRoundPublicTrace +import Whir.PCSRoundByRoundKnowledgeLedger + +/-! Concrete RBR events are insensitive to a hidden strategy once its public replies are fixed, and to challenge coordinates after their own boundary. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge ExecutionShapes + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +theorem targetAt_proof_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Strategy) (t : Tape (config p)) + (same : proof (Input p lanes root claims) left t = proof (Input p lanes root claims) right t) + (target : Array E) : TargetAt p lanes root claims left t target ↔ + TargetAt p lanes root claims right t target := by + unfold TargetAt + rw [following_proof_congr (Input p lanes root claims) left right t same, same] + +theorem lowSupport_proof_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Strategy) (t : Tape (config p)) + (same : proof (Input p lanes root claims) left t = proof (Input p lanes root claims) right t) : + LowSupportQuery p lanes root claims left t ↔ LowSupportQuery p lanes root claims right t := by + unfold LowSupportQuery + apply exists_congr + intro target + rw [targetAt_proof_congr p lanes root claims left right t same] + +theorem collision_proof_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Strategy) (t : Tape (config p)) + (same : proof (Input p lanes root claims) left t = proof (Input p lanes root claims) right t) : + CollisionEvent p lanes root claims left t ↔ CollisionEvent p lanes root claims right t := by + unfold CollisionEvent + rw [level_proof_congr (Input p lanes root claims) left right t same, same, + boundary_proof_congr (Input p lanes root claims) left right t same, + following_proof_congr (Input p lanes root claims) left right t same] + +theorem extra_proof_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Strategy) (t : Tape (config p)) + (same : proof (Input p lanes root claims) left t = proof (Input p lanes root claims) right t) + (q : Coordinate (config p)) : extraBad p lanes root claims left q t ↔ + extraBad p lanes root claims right q t := by + cases q with + | fold i j => + unfold extraBad + dsimp only + split_ifs + · rw [rawMCA_proof_congr (Input p lanes root claims) left right t same, + claimEscape_proof_congr (Input p lanes root claims) left right t same] + · rfl + | query i => + unfold extraBad + rw [collision_proof_congr p lanes root claims left right t same, + lowSupport_proof_congr p lanes root claims left right t same] + | initial => rfl + | ood i j => rfl + | tail j => rfl + +theorem round_proof_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Strategy) (t : Tape (config p)) + (same : proof (Input p lanes root claims) left t = proof (Input p lanes root claims) right t) + (q : Coordinate (config p)) : roundBad p lanes root claims left q t ↔ + roundBad p lanes root claims right q t := by + unfold roundBad + rw [core_proof_congr (Input p lanes root claims) left right t same, + extra_proof_congr p lanes root claims left right t same] + +theorem round_prefix_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (q : Coordinate (config p)) + (t u : Tape (config p)) + (same : ∀ r, position r ≤ position q → get r t = get r u) : + roundBad p lanes root claims strategy q t ↔ roundBad p lanes root claims strategy q u := by + exact prefix_event_congr (roundBad p lanes root claims strategy q) q + (fun r tape draw later => roundBad_set_future p lanes root claims strategy q r tape draw later) + t u same + +#print axioms targetAt_proof_congr +#print axioms lowSupport_proof_congr +#print axioms collision_proof_congr +#print axioms extra_proof_congr +#print axioms round_proof_congr +#print axioms round_prefix_congr +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/Whir/PCSRoundByRoundPublicQuery.lean b/verification/whir/Whir/PCSRoundByRoundPublicQuery.lean new file mode 100644 index 000000000..6f6ef28fc --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundPublicQuery.lean @@ -0,0 +1,124 @@ +import Whir.PCSRoundByRoundTranscriptReplay +import Whir.PCSRoundByRoundKnowledgeLedger + +/-! The initial query's extra knowledge events inspect the already advertised OOD values, prior folded state and candidate list, but not the response to their own query/lambda draw. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalExecution CausalProbability CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge ExecutionShapes +open CausalPositions + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +theorem initial_query_history (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Array Reply) (t : Tape (config p)) + (same : ∀ n, n < position (.query (initialLevel p)) → left[n]! = right[n]!) : + CausalBoundary.boundary (Input p lanes root claims) (indexedStrategy left) t (initialLevel p) = + CausalBoundary.boundary (Input p lanes root claims) (indexedStrategy right) t (initialLevel p) ∧ + followingCandidates (Input p lanes root claims) (indexedStrategy left) t 0 = + followingCandidates (Input p lanes root claims) (indexedStrategy right) t 0 ∧ + (proof (Input p lanes root claims) (indexedStrategy left) t).levels[0]!.oods = + (proof (Input p lanes root claims) (indexedStrategy right) t).levels[0]!.oods := by + let input := Input p lanes root claims + let i := initialLevel p + have boundaryPast (n : Nat) (bound : n < levelStart (challenges (config p) t) 0 + (config p).folds[0]!) : + left[n]! = right[n]! := by + apply same n + rw [position_query (initialLevel p) t] + simp only + omega + have folded := CausalStrategy.foldAt_eq input left right t i (config p).folds[0]! + (by simp only [i]; exact le_rfl) boundaryPast + have following := CausalStrategy.followingCandidates_eq input left right t i boundaryPast + have oods := CausalStrategy.proof_oods_eq input left right t i same + refine ⟨?_, ?_, ?_⟩ + · simpa only [CausalBoundary.boundary, input, i] using folded + · simpa only [input, i, initialLevel] using following + · simpa only [input, i, initialLevel] using oods + +theorem targetAt_indexed_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Array Reply) (t : Tape (config p)) + (same : ∀ n, n < position (.query (initialLevel p)) → left[n]! = right[n]!) + (target : Array E) : TargetAt p lanes root claims (indexedStrategy left) t target ↔ + TargetAt p lanes root claims (indexedStrategy right) t target := by + have history := initial_query_history p lanes root claims left right t same + unfold TargetAt + rw [history.2.1, history.2.2] + +theorem lowSupport_indexed_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Array Reply) (t : Tape (config p)) + (same : ∀ n, n < position (.query (initialLevel p)) → left[n]! = right[n]!) : + LowSupportQuery p lanes root claims (indexedStrategy left) t ↔ + LowSupportQuery p lanes root claims (indexedStrategy right) t := by + unfold LowSupportQuery + apply exists_congr + intro target + rw [targetAt_indexed_congr p lanes root claims left right t same] + +theorem collision_indexed_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Array Reply) (t : Tape (config p)) + (same : ∀ n, n < position (.query (initialLevel p)) → left[n]! = right[n]!) : + CollisionEvent p lanes root claims (indexedStrategy left) t ↔ + CollisionEvent p lanes root claims (indexedStrategy right) t := by + have history := initial_query_history p lanes root claims left right t same + have oracle : (levelAt (Input p lanes root claims) (indexedStrategy left) t 0).oracle = + (levelAt (Input p lanes root claims) (indexedStrategy right) t 0).oracle := by + rw [CausalExecution.levelAt_zero, CausalExecution.levelAt_zero] + rfl + unfold CollisionEvent RewindBatchTarget.Collision + rw [oracle, history.1, history.2.1] + apply exists_congr + intro candidate + have poly := queryPolynomial_oods_congr (remaining (config p) 0) (config p).rates[0]! + (config p).queries[0]! 0 + (levelAt (Input p lanes root claims) (indexedStrategy right) t 0).oracle + (challenges (config p) t).levels[0]! + (proof (Input p lanes root claims) (indexedStrategy left) t).levels[0]! + (proof (Input p lanes root claims) (indexedStrategy right) t).levels[0]! + (CausalBoundary.boundary (Input p lanes root claims) (indexedStrategy right) t (initialLevel p)).state + (get (.query (initialLevel p)) t).1 candidate history.2.2 + rw [poly] + +theorem extra_indexed_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Array Reply) (q : Coordinate (config p)) (t : Tape (config p)) + (same : ∀ n, n < position q → left[n]! = right[n]!) : + extraBad p lanes root claims (indexedStrategy left) q t ↔ + extraBad p lanes root claims (indexedStrategy right) q t := by + cases q with + | fold i j => + unfold extraBad + dsimp only + split_ifs with first + · subst i + dsimp only + rw [rawMCA_indexed_congr (Input p lanes root claims) left right t (initialLevel p) j same, + claimEscape_indexed_congr (Input p lanes root claims) left right t (initialLevel p) j same] + · rfl + | query i => + by_cases first : i = initialLevel p + · subst i + unfold extraBad + rw [collision_indexed_congr p lanes root claims left right t same, + lowSupport_indexed_congr p lanes root claims left right t same] + · simp only [extraBad, first, false_and] + | initial => rfl + | ood i j => rfl + | tail j => rfl + +theorem round_indexed_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (left right : Array Reply) (q : Coordinate (config p)) (t : Tape (config p)) + (same : ∀ n, n < position q → left[n]! = right[n]!) : + roundBad p lanes root claims (indexedStrategy left) q t ↔ + roundBad p lanes root claims (indexedStrategy right) q t := by + unfold roundBad + rw [core_indexed_congr (Input p lanes root claims) left right q t same, + extra_indexed_congr p lanes root claims left right q t same] + +#print axioms initial_query_history +#print axioms targetAt_indexed_congr +#print axioms lowSupport_indexed_congr +#print axioms collision_indexed_congr +#print axioms extra_indexed_congr +#print axioms round_indexed_congr +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/Whir/PCSRoundByRoundPublicState.lean b/verification/whir/Whir/PCSRoundByRoundPublicState.lean new file mode 100644 index 000000000..381b5f71e --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundPublicState.lean @@ -0,0 +1,108 @@ +import Whir.PCSRoundByRoundPublicEvents +import Whir.PCSRoundByRoundPublicQuery +import Whir.PCSRoundByRoundKnowledgeState +import Whir.PCSRewindKnowledgeOriginalChance + +/-! The state predicate's inputs contain only the original public statement, the prover's Root0 oracle string and an observed strict public trace. Its zero-filled reconstruction does not supply hidden future verifier randomness. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalExecution CausalProbability CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge +open Classical PublicTrace + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +noncomputable def completed {c : Config} (trace : PublicTrace c) : Finset (Coordinate c) := + Finset.univ.filter fun q => (trace.samples q).isSome + +@[simp] theorem mem_completed {c : Config} (trace : PublicTrace c) (q : Coordinate c) : + q ∈ completed trace ↔ (trace.samples q).isSome = true := by + simp [completed] + +@[simp] theorem snapshot_completed {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (boundary q : Coordinate c) : + q ∈ completed (snapshot ring t answers boundary) ↔ position q ≤ position boundary := by + by_cases observed : position q ≤ position boundary + · simp [completed, snapshot, observed] + · simp [completed, snapshot, observed] + +theorem snapshot_past {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (boundary q : Coordinate c) (observed : position q ≤ position boundary) : + get q (tape (snapshot ring t answers boundary)) = get q t := by + rw [get_tape] + simp [snapshot, observed] + +theorem snapshot_round_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (ring : RingPCSGame.Prefix) (t : Tape (config p)) + (answers : Array Reply) (boundary q : Coordinate (config p)) + (observed : position q ≤ position boundary) : + roundBad p lanes root claims (indexedStrategy (snapshot ring t answers boundary).answers) q + (tape (snapshot ring t answers boundary)) ↔ + roundBad p lanes root claims (indexedStrategy answers) q t := by + have history : ∀ n, n < position q → + (snapshot ring t answers boundary).answers[n]! = answers[n]! := by + intro n bound + exact priorAnswers_get answers (position boundary) n (bound.trans_le observed) + have observedCoords : ∀ r, position r ≤ position q → + get r (tape (snapshot ring t answers boundary)) = get r t := by + intro r earlier + exact snapshot_past ring t answers boundary r (earlier.trans observed) + exact (round_prefix_congr p lanes root claims + (indexedStrategy (snapshot ring t answers boundary).answers) q + (tape (snapshot ring t answers boundary)) t observedCoords).trans + (round_indexed_congr p lanes root claims (snapshot ring t answers boundary).answers + answers q t history) + +noncomputable def past {c : Config} (boundary : Coordinate c) : Finset (Coordinate c) := + Finset.univ.filter fun q => position q ≤ position boundary + +theorem snapshot_state_congr (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (ring : RingPCSGame.Prefix) (t : Tape (config p)) + (answers : Array Reply) (boundary : Coordinate (config p)) : + state (roundBad p lanes root claims (indexedStrategy (snapshot ring t answers boundary).answers)) + (completed (snapshot ring t answers boundary)) (tape (snapshot ring t answers boundary)) = + state (roundBad p lanes root claims (indexedStrategy answers)) (past boundary) t := by + have event : (∃ q ∈ completed (snapshot ring t answers boundary), + roundBad p lanes root claims (indexedStrategy (snapshot ring t answers boundary).answers) q + (tape (snapshot ring t answers boundary))) ↔ + (∃ q ∈ past boundary, roundBad p lanes root claims (indexedStrategy answers) q t) := by + constructor + · rintro ⟨q, member, bad⟩ + have observed := (snapshot_completed ring t answers boundary q).mp member + exact ⟨q, by simpa only [past, Finset.mem_filter, Finset.mem_univ, true_and] using observed, + (snapshot_round_congr p lanes root claims ring t answers boundary q observed).mp bad⟩ + · rintro ⟨q, member, bad⟩ + have observed : position q ≤ position boundary := by + simpa only [past, Finset.mem_filter, Finset.mem_univ, true_and] using member + exact ⟨q, (snapshot_completed ring t answers boundary q).mpr observed, + (snapshot_round_congr p lanes root claims ring t answers boundary q observed).mpr bad⟩ + unfold state + simp only [event] + +noncomputable def publicState {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (trace : PublicTrace (config p)) : Bool := + match trace.ring with + | none => false + | some ring => + if RingPCSGame.Escape (config p) lanes root family ring then true else + state (roundBad p lanes root (OriginalClaimsChecker.input prepared root ring).claims + (indexedStrategy trace.answers)) (completed trace) (tape trace) + +@[simp] theorem publicState_initial {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) : + publicState p lanes family points anchorPoint anchorValue prepared root (PublicTrace.initial (config p)) = false := by + rfl + +#print axioms snapshot_completed +#print axioms snapshot_past +#print axioms publicState_initial +#print axioms snapshot_round_congr +#print axioms snapshot_state_congr +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/Whir/PCSRoundByRoundPublicTrace.lean b/verification/whir/Whir/PCSRoundByRoundPublicTrace.lean new file mode 100644 index 000000000..3d00d765b --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundPublicTrace.lean @@ -0,0 +1,83 @@ +import Whir.PCSRoundByRoundTranscriptReplay +import Whir.RingPCSGame + +/-! A public verifier-message boundary contains the observed ring prefix, the +observed challenge coordinates, and strictly prior prover replies. Future +coordinates are absent, not hidden fields of a stored tape. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalProbability CausalPositions + +set_option autoImplicit false + +structure PublicTrace (c : Config) where + ring : Option RingPCSGame.Prefix + samples : (q : Coordinate c) → Option (Sample q) + answers : Array Reply + +def PublicTrace.initial (c : Config) : PublicTrace c := + ⟨none, fun _ => none, #[]⟩ + +def PublicTrace.tape {c : Config} (trace : PublicTrace c) : Tape c := + (coordinates c).symm (fun q => (trace.samples q).getD 0) + +@[simp] theorem PublicTrace.get_tape {c : Config} (trace : PublicTrace c) + (q : Coordinate c) : get q trace.tape = (trace.samples q).getD 0 := by + change ((coordinates c) ((coordinates c).symm _)) q = _ + rw [Equiv.apply_symm_apply] + +def priorAnswers (answers : Array Reply) (length : Nat) : Array Reply := + Array.ofFn (fun n : Fin length => answers[n.val]!) + +@[simp] theorem priorAnswers_get (answers : Array Reply) (length n : Nat) + (bound : n < length) : (priorAnswers answers length)[n]! = answers[n]! := by + simp [priorAnswers, getElem!_pos, bound] + +def snapshot {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q : Coordinate c) : PublicTrace c := + ⟨some ring, (fun r => if position r ≤ position q then some (get r t) else none), + priorAnswers answers (position q)⟩ + +@[simp] theorem snapshot_ring {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q : Coordinate c) : (snapshot ring t answers q).ring = some ring := rfl + +theorem snapshot_observed {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q r : Coordinate c) (observed : position r ≤ position q) : + get r (snapshot ring t answers q).tape = get r t := by + simp [snapshot, observed] + +theorem snapshot_unobserved {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q r : Coordinate c) (future : position q < position r) : + (snapshot ring t answers q).samples r = none := by + simp [snapshot, Nat.not_le.mpr future] + +theorem snapshot_reply {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q : Coordinate c) (n : Nat) (prior : n < position q) : + (snapshot ring t answers q).answers[n]! = answers[n]! := + priorAnswers_get answers (position q) n prior + +theorem prefix_event_congr {c : Config} (event : Tape c → Prop) (q : Coordinate c) + (invariant : ∀ r t (x : Sample r), position q < position r → + (event (set r t x) ↔ event t)) + (t u : Tape c) (same : ∀ r, position r ≤ position q → get r t = get r u) : + event t ↔ event u := by + let predicate := fun f : (r : Coordinate c) → Sample r => event ((coordinates c).symm f) + have step : ∀ f r, ¬ position r ≤ position q → ∀ x, + predicate (Function.update f r x) ↔ predicate f := by + intro f r future x + have replaced : (coordinates c).symm (Function.update f r x) = + set r ((coordinates c).symm f) x := by + simp only [CausalProbability.set, Equiv.apply_symm_apply] + dsimp only [predicate] + rw [replaced] + exact invariant r _ x (Nat.lt_of_not_ge future) + have result := CausalPrefix.finite_pred_congr predicate (fun r => position r ≤ position q) + step (coordinates c t) (coordinates c u) same + simpa only [predicate, Equiv.symm_apply_apply] using result + +#print axioms PublicTrace.get_tape +#print axioms priorAnswers_get +#print axioms snapshot_observed +#print axioms snapshot_unobserved +#print axioms snapshot_reply +#print axioms prefix_event_congr +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/Whir/PCSRoundByRoundPublicTransition.lean b/verification/whir/Whir/PCSRoundByRoundPublicTransition.lean new file mode 100644 index 000000000..e4d899f94 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundPublicTransition.lean @@ -0,0 +1,72 @@ +import Whir.PCSRoundByRoundPublicEndpoint +import Whir.PCSBCSRounds + +/-! A noninitial message updates the literal public predicate on its exact uniform incoming-history fiber. Both trace snapshots stop before the following prover response. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge ExecutionShapes +open Classical PublicTrace CausalPositions CausalPrefix + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +def predecessor {c : Config} (q : Coordinate c) (positive : 0 < position q) : Coordinate c := + PCSBCSRounds.rounds c ⟨position q - 1, by + have bound : position q < PCSBCSRounds.k c := by + simpa only [PCSBCSRounds.depth_eq_k] using WHIRHistory.position_lt_depth q + omega⟩ + +theorem predecessor_position {c : Config} (q : Coordinate c) (positive : 0 < position q) : + position (predecessor q positive) = position q - 1 := by + let index : Fin (PCSBCSRounds.k c) := ⟨position q - 1, by + have bound : position q < PCSBCSRounds.k c := by + simpa only [PCSBCSRounds.depth_eq_k] using WHIRHistory.position_lt_depth q + omega⟩ + have inverse := congrArg Fin.val ((PCSBCSRounds.rounds c).left_inv index) + exact inverse + +theorem past_insert_predecessor {c : Config} (q : Coordinate c) (positive : 0 < position q) : + past q = insert q (past (predecessor q positive)) := by + ext r + simp only [past, Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_insert, + predecessor_position] + constructor + · intro bound + by_cases equal : position r = position q + · exact Or.inl (position_injective c equal) + · exact Or.inr (by omega) + · rintro (rfl | bound) <;> omega + +theorem literal_conditional_transition {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + (root : BaseOracle) (strategy : RingPCSGame.Prefix → Strategy) + (claimCap : points.size + 2 ≤ 2^64) (q : Coordinate (config p)) (positive : 0 < position q) + (ring : RingPCSGame.Prefix) (t : Tape (config p)) (failure : Sample q → Prop) + (before : publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot ring t (replies (Input p lanes root (OriginalClaimsChecker.input prepared root ring).claims) (strategy ring) t) + (predecessor q positive)) = false) : + Soundness.uniformProb (Finset.univ.filter fun x : Sample q => failure x ∧ + publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot ring (set q t x) + (replies (Input p lanes root (OriginalClaimsChecker.input prepared root ring).claims) (strategy ring) (set q t x)) q) = true) ≤ + rbrError := by + have incoming : sourceState p lanes family points anchorPoint anchorValue prepared root strategy + true (past (predecessor q positive)) ring t = false := by + rw [← snapshot_publicState_source] + exact before + have earlier : ∀ r ∈ past (predecessor q positive), position r < position q := by + intro r member + simp only [past, Finset.mem_filter, Finset.mem_univ, true_and] at member + rw [predecessor_position] at member + omega + have bound := source_conditional_transition_uniform p lanes family points anchorPoint anchorValue + prepared root strategy claimCap (past (predecessor q positive)) q ring t failure earlier incoming + simpa only [snapshot_publicState_source, past_insert_predecessor q positive] using bound + +#print axioms predecessor_position +#print axioms past_insert_predecessor +#print axioms literal_conditional_transition +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/Whir/PCSRoundByRoundTranscriptReplay.lean b/verification/whir/Whir/PCSRoundByRoundTranscriptReplay.lean new file mode 100644 index 000000000..a127356f8 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundTranscriptReplay.lean @@ -0,0 +1,192 @@ +import Whir.PCSRoundByRoundEnvelope +import Whir.CausalStrategy +import Whir.InitialKnowledgeSchedule + +/-! Public replies reproduce a causal execution without retaining the prover +strategy. Full-proof extensionality below is only a bridge to truncation; the +public state uses strictly prior reply slots and observed challenge coordinates. -/ +namespace Whir.PCSRoundByRoundTranscriptState +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalRefinement +open CausalStrategy CausalPositions + +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 +set_option autoImplicit false + +def replies (input : Public) (strategy : Strategy) (t : Tape input.config) : Array Reply := + (run strategy input [] (visibleBatches input.config t.1 (challenges input.config t))).toArray + +theorem replay_run (input : Public) (strategy : Strategy) (batches : List Batch) : + run (indexedStrategy (run strategy input [] batches).toArray) input [] batches = + run strategy input [] batches := by + apply List.ext_getElem! (by simp only [run_length]) + intro i + by_cases bound : i < batches.length + · rw [indexed_response _ input [] batches i bound] + simp only [List.length_nil, Nat.zero_add, List.getElem!_toArray] + · simp [getElem!_neg, run_length, bound] + +theorem proof_replay (input : Public) (strategy : Strategy) (t : Tape input.config) : + proof input (indexedStrategy (replies input strategy t)) t = proof input strategy t := by + unfold proof CausalTerminal.proof replies + rw [replay_run] + +theorem initial_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) : initial input left t = initial input right t := by + unfold initial + rw [same] + +theorem level_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (i : Nat) : + levelAt input left t i = levelAt input right t i := by + unfold levelAt + rw [same, initial_proof_congr input left right t same] + +theorem fold_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (i j : Nat) : + foldAt input left t i j = foldAt input right t i j := by + unfold foldAt + rw [same, level_proof_congr input left right t same] + +theorem candidates_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (i j : Nat) : + foldCandidates input left t i j = foldCandidates input right t i j := by + unfold foldCandidates + rw [level_proof_congr input left right t same] + +theorem following_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (i : Nat) : + followingCandidates input left t i = followingCandidates input right t i := by + unfold followingCandidates + rw [same] + +theorem boundary_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (i : Nat) : + CausalBoundary.boundary input left t i = CausalBoundary.boundary input right t i := by + exact fold_proof_congr input left right t same i _ + +theorem terminal_before_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) : + CausalTerminal.before input left t = CausalTerminal.before input right t := by + unfold CausalTerminal.before CausalTerminal.beforeChecked + have terminalSame : CausalTerminal.proof input left t = CausalTerminal.proof input right t := same + rw [terminalSame] + +theorem core_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (q : Coordinate input.config) : + PCSRoundByRoundEnvelope.core input left q t ↔ PCSRoundByRoundEnvelope.core input right q t := by + unfold PCSRoundByRoundEnvelope.core WHIRFiatShamir.Envelope + cases q with + | initial => simp only [CausalBadEvents.Bad, set_get] + | fold i j => + simp only [CausalBadEvents.Bad, set_get] + unfold CausalFolds.Event + rw [candidates_proof_congr input left right t same, + candidates_proof_congr input left right t same, + fold_proof_congr input left right t same, + fold_proof_congr input left right t same] + | ood i j => + simp only [CausalBadEvents.Bad, set_get] + unfold CausalBoundary.OodEvent + rw [following_proof_congr input left right t same] + | query i => + dsimp only + unfold WHIRFiatShamir.QueryEnvelope CausalBoundary.QueryPrior + dsimp only + simp only [same, level_proof_congr input left right t same, + boundary_proof_congr input left right t same, + following_proof_congr input left right t same] + | tail j => + simp only [CausalBadEvents.Bad, set_get] + unfold CausalTerminal.candidate CausalTerminal.pending + have terminalSame : CausalTerminal.proof input left t = CausalTerminal.proof input right t := same + rw [terminalSame, terminal_before_proof_congr input left right t same] + +theorem core_indexed_congr (input : Public) (left right : Array Reply) + (q : Coordinate input.config) (t : Tape input.config) + (same : ∀ n, n < position q → left[n]! = right[n]!) : + PCSRoundByRoundEnvelope.core input (indexedStrategy left) q t ↔ + PCSRoundByRoundEnvelope.core input (indexedStrategy right) q t := + Iff.of_eq (congrFun (envelope_indexed_eq input left right q t same) (get q t)) + +theorem rawMCA_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (i : Fin input.config.folds.size) + (j : Fin input.config.folds[i.val]!) : + InitialKnowledgeSchedule.RawMCA input left i j t ↔ + InitialKnowledgeSchedule.RawMCA input right i j t := by + unfold InitialKnowledgeSchedule.RawMCA InitialKnowledgeSchedule.paired + rw [level_proof_congr input left right t same] + +theorem claimEscape_proof_congr (input : Public) (left right : Strategy) (t : Tape input.config) + (same : proof input left t = proof input right t) (i : Fin input.config.folds.size) + (j : Fin input.config.folds[i.val]!) : + InitialKnowledgeSchedule.ClaimEscape input left i j t ↔ + InitialKnowledgeSchedule.ClaimEscape input right i j t := by + unfold InitialKnowledgeSchedule.ClaimEscape + rw [candidates_proof_congr input left right t same, + fold_proof_congr input left right t same] + +theorem queryPolynomial_oods_congr (n rate count i : Nat) (root : Oracle) + (cs : LevelChallenges) (left right : LevelProof) (s : VerifierState E) + (tape : LevelBoundary.QueryTape (n + rate) count) (f : Array E) + (same : left.oods = right.oods) : + QueryBatchSoundness.polynomial n rate count i root cs left s tape f = + QueryBatchSoundness.polynomial n rate count i root cs right s tape f := by + let qs := QueryBatchSoundness.queries (n + rate) count tape + let l : LevelProof := {left with rows := qs.map (fun q => root[q]!)} + let r : LevelProof := {right with rows := qs.map (fun q => root[q]!)} + have oods : BatchingRefinement.oodError f cs l = BatchingRefinement.oodError f cs r := by + funext j + simp only [BatchingRefinement.oodError, l, r, same] + have queries : BatchingRefinement.queryError f n cs l qs (i == 0) = + BatchingRefinement.queryError f n cs r qs (i == 0) := by + funext j + rfl + unfold QueryBatchSoundness.polynomial BatchingRefinement.errorPolynomial + dsimp only + rw [congrArg Array.size same] + exact congrArg₂ (fun ood query => BatchingRefinement.batchPolynomial right.oods.size qs.size + (BatchingRefinement.discrepancy f s) ood query) oods queries + +theorem rawMCA_indexed_congr (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) + (same : ∀ n, n < position (.fold i j) → left[n]! = right[n]!) : + InitialKnowledgeSchedule.RawMCA input (indexedStrategy left) i j t ↔ + InitialKnowledgeSchedule.RawMCA input (indexedStrategy right) i j t := by + have prior : ∀ n, n < levelStart (challenges input.config t) i.val → left[n]! = right[n]! := by + intro n bound + apply same n + rw [position_fold i j t] + omega + unfold InitialKnowledgeSchedule.RawMCA InitialKnowledgeSchedule.paired + rw [CausalStrategy.levelAt_eq input left right t i.val (Nat.le_of_lt i.isLt) prior] + +theorem claimEscape_indexed_congr (input : Public) (left right : Array Reply) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Fin input.config.folds[i.val]!) + (same : ∀ n, n < position (.fold i j) → left[n]! = right[n]!) : + InitialKnowledgeSchedule.ClaimEscape input (indexedStrategy left) i j t ↔ + InitialKnowledgeSchedule.ClaimEscape input (indexedStrategy right) i j t := by + have prior : ∀ n, n < levelStart (challenges input.config t) i.val → left[n]! = right[n]! := by + intro n bound + apply same n + rw [position_fold i j t] + omega + have foldPrior : ∀ n, n < levelStart (challenges input.config t) i.val + j.val → + left[n]! = right[n]! := by + intro n bound + apply same n + simpa only [position_fold i j t] using bound + unfold InitialKnowledgeSchedule.ClaimEscape + rw [CausalStrategy.foldCandidates_eq input left right t i j.val prior, + CausalStrategy.foldAt_eq input left right t i j.val (Nat.le_of_lt j.isLt) foldPrior] + +#print axioms replay_run +#print axioms proof_replay +#print axioms core_proof_congr +#print axioms core_indexed_congr +#print axioms rawMCA_proof_congr +#print axioms claimEscape_proof_congr +#print axioms queryPolynomial_oods_congr +#print axioms rawMCA_indexed_congr +#print axioms claimEscape_indexed_congr +end Whir.PCSRoundByRoundTranscriptState diff --git a/verification/whir/lakefile.toml b/verification/whir/lakefile.toml index 3abf6382d..297b5f6f5 100644 --- a/verification/whir/lakefile.toml +++ b/verification/whir/lakefile.toml @@ -50,3 +50,11 @@ root = "Whir.PublicCompressionCouplingSourceStreamSmoke" [[lean_exe]] name = "whirRoundByRoundDecoderSmoke" root = "Whir.PCSRoundByRoundSourceDecoderSmoke" + +[[lean_exe]] +name = "whirBookRoundsSmoke" +root = "Whir.PCSBCSRoundsSmoke" + +[[lean_exe]] +name = "whirMerkleLogExtractionSmoke" +root = "Whir.MerkleQueryLogExtractionSmoke" From b8fabbe8fa953bdb89c072cffe95a09cbbb9e8fc Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 23:17:12 +0100 Subject: [PATCH 14/28] Qualify frozen-table transport by its exact Merkle shape --- verification/whir/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 42b224588..6e46115a5 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -177,7 +177,7 @@ The completed characteristic-two additive source protocol has a coin-free straig The exact uniform round error is `(17/32)^56 + 1/2^78`. The grouped round count is `1 + sum_i(folds_i + oodCount_i + 1) + tailCount`, including the final full-E draw that has no following prover response. The checked PCS raw alphabets have minimum entropy exactly 192 bits, with the initial gamma, six maps and lambda forming one eight-E message and queries retaining their full E squeezes before positional projection. The source regrouping is causal and preserves acceptance and rejection in its modeled domain. The unchanged PCS profiles have `k <= 40` and maximal raw message length at most 5760 bits. These are protocol and resource statements, not a security level or a whole-system entropy conclusion. -Merkle-query-log reconstruction builds one preimage index, produces raw compact occupied rows in physical leaf order and freezes the table at first registration. Repeated registration cannot overwrite or re-extract it. Accepted pruned openings agree with that table or trigger the separately proved compression-game bad event. Missing or malformed leaves use explicit default rows and are not treated as authenticated data. The occupied-lane reversal belongs only to the first-fold consumer, not to the raw table supplied to the decoder. This provides a checked extraction component, not a Fiat-Shamir knowledge theorem for arbitrary BLAKE2s or a universal Rust refinement. +Merkle-query-log reconstruction builds one preimage index and produces raw compact occupied rows in physical leaf order. For the authentic captured prefix and the opening's exact height and occupied width, accepted pruned openings agree with the reconstructed table or trigger the separately proved compression-game bad event. Cache transport additionally requires that same shape and prefix provenance; the current digest-only registry does not establish safe cross-shape retrieval. Identical untagged bytes can be interpreted as a node or a leaf without a collision, so shape mismatch is not charged as cryptographic failure. Repeated registration preserves the first table without re-extraction. Missing or malformed leaves use explicit default rows and are not treated as authenticated data. The occupied-lane reversal belongs only to the first-fold consumer, not to the raw table supplied to the decoder. This provides a checked extraction component, not a Fiat-Shamir knowledge theorem for arbitrary BLAKE2s or a universal Rust refinement. The integrated completed closure passed `lake build --wfail +Whir:olean +Main:olean`, and `Audit.lean` checked **10402 exported Whir theorem declarations** with only the three permitted standard axioms. Actual compiled execution passed the multilevel accepted/rejected model, nontrivial full-root Gao extraction with a corrupted row, PCS grouped round and byte-cache behavior, and real-BLAKE2s Merkle-log extraction with honest, tampered, absent, malformed and lane-order cases. The inconsistent-output log fixture exercises collision handling without claiming a BLAKE2s collision. Unfinished restoration and source-duplex composition modules are not imported by this audited root. From 95829d14ffe6aed9b5796d6f9665c727fc4b05a4 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sat, 10 Oct 2026 23:33:06 +0100 Subject: [PATCH 15/28] Document and exercise verifier-fixed Merkle shape invariants --- verification/whir/README.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/verification/whir/README.md b/verification/whir/README.md index 6e46115a5..0b0c6b0db 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -181,6 +181,19 @@ Merkle-query-log reconstruction builds one preimage index and produces raw compa The integrated completed closure passed `lake build --wfail +Whir:olean +Main:olean`, and `Audit.lean` checked **10402 exported Whir theorem declarations** with only the three permitted standard axioms. Actual compiled execution passed the multilevel accepted/rejected model, nontrivial full-root Gao extraction with a corrupted row, PCS grouped round and byte-cache behavior, and real-BLAKE2s Merkle-log extraction with honest, tampered, absent, malformed and lane-order cases. The inconsistent-output log fixture exercises collision handling without claiming a BLAKE2s collision. Unfinished restoration and source-duplex composition modules are not imported by this audited root. +## Deployed leaf/node boundary and required invariant + +This source inspection is pinned to upstream `riscv-exploration` at `3caf0217f67d48d8b5f2e6c9a31cb476397590af`, not silently attributed to the historical proof-checkout Rust harness. + +- There is no leaf/node hash tag: [`hash_leaf` and `hash_pair`, `fiat_shamir/src/merkle.rs:41-53`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/fiat_shamir/src/merkle.rs#L41-L53) both use standard BLAKE2s. A 64-byte leaf image equal to two concatenated child digests has the same hash as their parent, with no collision. The zero-prefix plan at [`merkle.rs:105-130`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/fiat_shamir/src/merkle.rs#L105-L130) is an optimization of that same padded image, not domain separation. +- Native verification fixes the expected shape outside the proof's path. [`pcs/src/whir/verify.rs:304-330`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/pcs/src/whir/verify.rs#L304-L330) derives L0 depth from `log_n` and the configured fold/rate; [`pcs/src/verifier.rs:79-89`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/pcs/src/verifier.rs#L79-L89) passes `1 << depth` into authenticated opening. [`merkle.rs:309-324`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/fiat_shamir/src/merkle.rs#L309-L324) checks exact occupied row width; [`merkle.rs:346-385`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/fiat_shamir/src/merkle.rs#L346-L385) derives the fixed height, folds exactly that many levels and refuses missing or extra siblings and a different root. A node cannot replace a leaf by simply submitting a shorter path for this phase. +- Rows likewise fixes the height through the verifier-generated query vectors: [`rec/verifier/mod.rs:200-211`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/leanvm_core/src/rec/verifier/mod.rs#L200-L211) constructs queries of exactly the configured depth. [`rec/transcript.rs:233-288`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/leanvm_core/src/rec/transcript.rs#L233-L288) cuts or pads hints to the fixed sibling count, constrains the full padded image and hashes the fixed low levels; [`rec/verifier/mod.rs:253-282`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/leanvm_core/src/rec/verifier/mod.rs#L253-L282) hashes the remaining fixed top levels and constrains equality to the root. Hint normalization is not a proof-selected shorter tree and does not claim identical immediate error behavior to native verification. +- Current production leaf sizes provide another distinction: [`config/mod.rs:129-151`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/pcs/src/whir/config/mod.rs#L129-L151), [`296-302`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/pcs/src/whir/config/mod.rs#L296-L302) and [`432-443`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/pcs/src/whir/config/mod.rs#L432-L443) select initial fold six and subsequent fold four. With the image-width formulas at [`verify.rs:273-279`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/pcs/src/whir/verify.rs#L273-L279) and `304-330`, L0 images are 512 bytes and subsequent E images 384 bytes, not the 64-byte node input. Omitted lanes remain part of the zero-padded full image; they do not shorten its hash message. + +The required invariant is that **the verifier fixes each phase's tree height and image/occupied widths, never the proof's path length**. The native check or Rows root constraints must cover exactly that height. Digest equality alone is not binding across arbitrary shapes; generic caller-selected shapes can reinterpret the same untagged root. Cross-shape extraction caches must preserve shape identity rather than charging such reinterpretation as a collision. The inspected deployed paths do not mix shapes inside a phase, and this investigation does not establish a deployed same-shape leaf/node exploit. + +Fresh execution at this upstream pin passed an actual native BLAKE2s/opening executable: it confirmed identical untagged leaf/node hashes and valid interpretations under different caller-declared shapes, then rejected using either shortened or extended interpretation at the other fixed height, wrong row widths, out-of-range indices and non-power-of-two leaf counts. It also confirmed that zero-prefixed 64-byte images are not domain-separated. The existing release Rows regression [`a_node_opened_as_a_leaf_is_refused_at_the_shapes_depth`, `rec/transcript.rs:419-450`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/leanvm_core/src/rec/transcript.rs#L419-L450) passed under Rust 1.97: the same node-preimage interpretation satisfies a deliberately shorter configured tree but fails the original fixed-depth circuit's constraints. No production code or permanent test was changed by this investigation. + ## Historical source refresh validation The previously published native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean`. Its fresh `lake env lean -E warning Audit.lean` census reported **7488 exported theorem declarations**, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound`. That historical inspection included both native endpoint types, the then-external `PublicRandomCompressionDMV` coupling certificate and `ConcretePrimitiveGap`. It did not discharge the external coupling certificate, which the completed finite-game coupling above has now removed; the separate concrete primitive premise remains as stated. From 561209ff3e7bacf1da82474d99ab784a1e2c9f4d Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sun, 11 Oct 2026 00:35:31 +0100 Subject: [PATCH 16/28] docs(whir): state caller binding and padded leaf proof boundary --- verification/whir/README.md | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 0b0c6b0db..2c7666633 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -177,7 +177,7 @@ The completed characteristic-two additive source protocol has a coin-free straig The exact uniform round error is `(17/32)^56 + 1/2^78`. The grouped round count is `1 + sum_i(folds_i + oodCount_i + 1) + tailCount`, including the final full-E draw that has no following prover response. The checked PCS raw alphabets have minimum entropy exactly 192 bits, with the initial gamma, six maps and lambda forming one eight-E message and queries retaining their full E squeezes before positional projection. The source regrouping is causal and preserves acceptance and rejection in its modeled domain. The unchanged PCS profiles have `k <= 40` and maximal raw message length at most 5760 bits. These are protocol and resource statements, not a security level or a whole-system entropy conclusion. -Merkle-query-log reconstruction builds one preimage index and produces raw compact occupied rows in physical leaf order. For the authentic captured prefix and the opening's exact height and occupied width, accepted pruned openings agree with the reconstructed table or trigger the separately proved compression-game bad event. Cache transport additionally requires that same shape and prefix provenance; the current digest-only registry does not establish safe cross-shape retrieval. Identical untagged bytes can be interpreted as a node or a leaf without a collision, so shape mismatch is not charged as cryptographic failure. Repeated registration preserves the first table without re-extraction. Missing or malformed leaves use explicit default rows and are not treated as authenticated data. The occupied-lane reversal belongs only to the first-fold consumer, not to the raw table supplied to the decoder. This provides a checked extraction component, not a Fiat-Shamir knowledge theorem for arbitrary BLAKE2s or a universal Rust refinement. +Merkle-query-log reconstruction builds one preimage index and produces raw compact occupied rows in physical leaf order. The published `PCSBCSMerkleSourceRows.rawRoot0_eq_compactBaseOracle` and `pruned_opened_rows`, and the opened-table transport derived from them, cover the fully occupied case `leaf_words = occupied`. They do not yet cover production's partially occupied leaf images: [`pcs/src/whir/verify.rs:404`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/pcs/src/whir/verify.rs#L404) passes `(n_lanes, max)`, and [`pcs/src/verifier.rs:51-52,121-123`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/pcs/src/verifier.rs#L51-L123) authenticates the zero-prefixed full image before removing its prefix. Extending the compact-row transport to that actual image is proof work, not a production change. For the modeled fully occupied shape and authentic captured prefix, accepted pruned openings agree with the reconstructed table or trigger the separately proved compression-game bad event. Cache retrieval requires the same shape and captured-prefix provenance; digest equality alone does not justify cross-shape retrieval. Identical untagged bytes can be interpreted as a node or a leaf without a collision. Missing or malformed leaves use explicit default rows and are not treated as authenticated data. Occupied-lane reversal belongs to the first-fold consumer, not the raw decoder input. This is a checked extraction component, not a deployed Fiat-Shamir knowledge theorem or universal Rust refinement. The integrated completed closure passed `lake build --wfail +Whir:olean +Main:olean`, and `Audit.lean` checked **10402 exported Whir theorem declarations** with only the three permitted standard axioms. Actual compiled execution passed the multilevel accepted/rejected model, nontrivial full-root Gao extraction with a corrupted row, PCS grouped round and byte-cache behavior, and real-BLAKE2s Merkle-log extraction with honest, tampered, absent, malformed and lane-order cases. The inconsistent-output log fixture exercises collision handling without claiming a BLAKE2s collision. Unfinished restoration and source-duplex composition modules are not imported by this audited root. @@ -194,6 +194,16 @@ The required invariant is that **the verifier fixes each phase's tree height and Fresh execution at this upstream pin passed an actual native BLAKE2s/opening executable: it confirmed identical untagged leaf/node hashes and valid interpretations under different caller-declared shapes, then rejected using either shortened or extended interpretation at the other fixed height, wrong row widths, out-of-range indices and non-power-of-two leaf counts. It also confirmed that zero-prefixed 64-byte images are not domain-separated. The existing release Rows regression [`a_node_opened_as_a_leaf_is_refused_at_the_shapes_depth`, `rec/transcript.rs:419-450`](https://github.com/leanEthereum/leanVM/blob/3caf0217f67d48d8b5f2e6c9a31cb476397590af/crates/leanvm_core/src/rec/transcript.rs#L419-L450) passed under Rust 1.97: the same node-preimage interpretation satisfies a deliberately shorter configured tree but fails the original fixed-depth circuit's constraints. No production code or permanent test was changed by this investigation. +## Caller statement-binding precondition + +The original opening statement must be fixed before its batching challenge packet: every point, slice value, offset, selector and shape must come from already observed messages, the seeded public layout or strictly earlier verifier challenges. In the source-fiber formulation, changing only the current packet's random-table entry must leave that complete caller statement and its incoming public state unchanged. A commitment-record identity frame binds the record, not an otherwise unbound caller statement. The generic stack API and `leanvm_core::pcs` forwarding wrappers therefore retain this precondition; the anchor does not replace it. + +This caller audit is pinned to PR #600's held source `12eea88c41dd964d82d4eb15ce91bba17ef91339`. The native CPU leaf and constrained leaf Rows use the same reduction and opening sequence at [`cpu/reduce.rs:68-103`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/cpu/reduce.rs#L68-L103) and [`rec/verifier/riscv.rs:63-79`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/rec/verifier/riscv.rs#L63-L79). Bus evaluations are sent/read at `leaf/decompose.rs:522` and `leaf/mod.rs:469-471`; table evaluations and bit slices at `constraints/mod.rs:217-244`; Flock slices and matrix values at `flock/lincheck.rs:374-375,445-446`. Public output and program layout enter the seed at `cpu/program.rs:230,375,404-405,433-452`. Addresses are deterministic layout selections. Coordinates are earlier GKR, sumcheck, zerocheck or lincheck outputs, not point vectors reserialized immediately before the opening. + +Tree and aggregation proving open at [`rec/proof.rs:293-308`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/rec/proof.rs#L293-L308); native and Rows consume the shared core at `rec/proof.rs:217-245,329-363` and `rec/verifier/recursion.rs:105-125`. Every child statement limb is seeded by `rec/proof.rs:33-36` or the matching Rows seed. All 104 recursive slots are terminal table evaluations observed before opening; the single hash-witness ring uses the observed Flock slices. Fixed and program hint values outside the child transcript enter the separate reduction's bound list at `tree/design.rs:245,295,306` and are sent/read before its batching challenges at `tree/reduce/mod.rs:63-78`. Deferred claims must still be settled: native CPU at `cpu/deferred.rs:207-239`, final tree at `tree/mod.rs:620-648`, and constrained embeddings through the enclosing satisfied circuit. Host success from a partial core or Rows construction is not full verification. + +No production path in this audit exposed a late prover-selectable opening point or value. This is a source-provenance audit, not the missing random-oracle causality theorem: preserving the earlier challenge source keys, byte cursors, seeded layout and producer/native/Rows ordering remains an explicit composition obligation. The generic throughput benchmark and fixed honest stack/Rows fixtures are not adversarial statement-binding examples. No public API restriction or new statement frame is implemented in PR #600 by this audit. + ## Historical source refresh validation The previously published native-security dependency closure passed `lake build --wfail +Whir:olean +Main:olean`. Its fresh `lake env lean -E warning Audit.lean` census reported **7488 exported theorem declarations**, including generated declarations, with only `propext`, `Classical.choice` and `Quot.sound`. That historical inspection included both native endpoint types, the then-external `PublicRandomCompressionDMV` coupling certificate and `ConcretePrimitiveGap`. It did not discharge the external coupling certificate, which the completed finite-game coupling above has now removed; the separate concrete primitive premise remains as stated. From dacfa6a82f3fecdc77b81bb71e61408a4f2f13d3 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sun, 11 Oct 2026 04:42:59 +0100 Subject: [PATCH 17/28] proof: authenticate padded Merkle source images and reconstruct public PCS logs --- verification/whir/README.md | 14 +- verification/whir/Whir.lean | 18 + .../Whir/MerkleQueryLogExtractionSmoke.lean | 107 ++++-- .../whir/Whir/PCSBCSActualMerkleBound.lean | 35 ++ .../whir/Whir/PCSBCSCallerBinding.lean | 88 +++++ .../whir/Whir/PCSBCSChallengeOracle.lean | 201 ++++++++++ .../Whir/PCSBCSChallengeOracleAccounting.lean | 97 +++++ .../Whir/PCSBCSChallengeOracleCanonical.lean | 90 +++++ .../PCSBCSChallengeOracleEnteredErasure.lean | 62 +++ .../PCSBCSChallengeOracleEnteredGames.lean | 24 ++ ...PCSBCSChallengeOracleEnteredPartition.lean | 61 +++ .../Whir/PCSBCSChallengeOracleEntries.lean | 77 ++++ .../Whir/PCSBCSChallengeOracleErasure.lean | 135 +++++++ .../whir/Whir/PCSBCSChallengeOracleGames.lean | 104 ++++++ .../Whir/PCSBCSChallengeOraclePackets.lean | 247 ++++++++++++ .../PCSBCSChallengeOracleRestoration.lean | 91 +++++ .../Whir/PCSBCSChallengeOracleSource.lean | 161 ++++++++ .../whir/Whir/PCSBCSFirstRootDisclosure.lean | 110 ++++++ .../whir/Whir/PCSBCSFrozenOracleRows.lean | 82 ++++ .../whir/Whir/PCSBCSLiteralStatePath.lean | 50 +++ .../Whir/PCSBCSMerkleFullSourceTransport.lean | 65 ++++ .../whir/Whir/PCSBCSMerkleLeafImageCost.lean | 118 ++++++ .../whir/Whir/PCSBCSMerkleLeafImages.lean | 273 ++++++++++++++ .../whir/Whir/PCSBCSMerkleOpenedTable.lean | 66 +++- .../whir/Whir/PCSBCSMerkleQueryLog.lean | 14 +- .../whir/Whir/PCSBCSMerkleRootCache.lean | 98 ++++- .../whir/Whir/PCSBCSMerkleRootCacheCost.lean | 176 +++++++++ .../Whir/PCSBCSMerkleRootCacheTransport.lean | 56 +++ .../whir/Whir/PCSBCSMerkleSourceRows.lean | 66 ++-- .../whir/Whir/PCSBCSPublicLogExtractor.lean | 64 ++++ .../Whir/PCSBCSPublicLogExtractorSmoke.lean | 97 +++++ .../whir/Whir/PCSBCSPublicRootExtractor.lean | 38 ++ .../Whir/PCSBCSRestorationCertificate.lean | 109 ++++++ .../whir/Whir/PCSBCSRestorationHazard.lean | 126 +++++++ .../Whir/PCSBCSRestorationLiteralPath.lean | 71 ++++ .../whir/Whir/PCSBCSRestorationTrace.lean | 130 +++++++ .../whir/Whir/PCSBCSRoundsAdapter.lean | 158 ++++++++ .../Whir/PCSBCSSourceCoordinateDecoder.lean | 123 ++++++ ...SBCSSourceCoordinateDecoderProvenance.lean | 78 ++++ .../PCSBCSSourceCoordinateDecoderSmoke.lean | 88 +++++ .../PCSBCSSourceCoordinateDecoderSource.lean | 71 ++++ .../whir/Whir/PCSBCSSourcePacketTape.lean | 264 +++++++++++++ .../Whir/PCSBCSSourcePacketTapeSmoke.lean | 134 +++++++ .../Whir/PCSBCSSourcePrimitiveRootBudget.lean | 145 +++++++ .../whir/Whir/PCSBCSSourceReplyInversion.lean | 329 ++++++++++++++++ .../PCSBCSSourceReplyInversionIncoming.lean | 62 +++ .../Whir/PCSBCSSourceReplyInversionSmoke.lean | 147 ++++++++ .../whir/Whir/PCSBCSSourceRootCapture.lean | 129 +++++++ .../whir/Whir/PCSBCSSourceRootReferences.lean | 299 +++++++++++++++ .../PCSBCSSourceRootReferencesBudget.lean | 218 +++++++++++ .../Whir/PCSBCSSourceRootReferencesSmoke.lean | 116 ++++++ .../whir/Whir/PCSBCSVerifierPacketWalk.lean | 44 +++ .../whir/Whir/PCSStateRestoration.lean | 75 ++++ .../Whir/PCSStateRestorationAdaptive.lean | 353 ++++++++++++++++++ .../whir/Whir/PCSStateRestorationLatent.lean | 168 +++++++++ .../PCSStateRestorationLatentProbability.lean | 250 +++++++++++++ verification/whir/lakefile.toml | 8 + 57 files changed, 6583 insertions(+), 97 deletions(-) create mode 100644 verification/whir/Whir/PCSBCSActualMerkleBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerBinding.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracle.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleAccounting.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleCanonical.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleEnteredErasure.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleEnteredGames.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleEnteredPartition.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleEntries.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleErasure.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleGames.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOraclePackets.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleSource.lean create mode 100644 verification/whir/Whir/PCSBCSFirstRootDisclosure.lean create mode 100644 verification/whir/Whir/PCSBCSFrozenOracleRows.lean create mode 100644 verification/whir/Whir/PCSBCSLiteralStatePath.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleFullSourceTransport.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleLeafImageCost.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleLeafImages.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleRootCacheCost.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleRootCacheTransport.lean create mode 100644 verification/whir/Whir/PCSBCSPublicLogExtractor.lean create mode 100644 verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSPublicRootExtractor.lean create mode 100644 verification/whir/Whir/PCSBCSRestorationCertificate.lean create mode 100644 verification/whir/Whir/PCSBCSRestorationHazard.lean create mode 100644 verification/whir/Whir/PCSBCSRestorationLiteralPath.lean create mode 100644 verification/whir/Whir/PCSBCSRestorationTrace.lean create mode 100644 verification/whir/Whir/PCSBCSRoundsAdapter.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCoordinateDecoder.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCoordinateDecoderProvenance.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCoordinateDecoderSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCoordinateDecoderSource.lean create mode 100644 verification/whir/Whir/PCSBCSSourcePacketTape.lean create mode 100644 verification/whir/Whir/PCSBCSSourcePacketTapeSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean create mode 100644 verification/whir/Whir/PCSBCSSourceReplyInversion.lean create mode 100644 verification/whir/Whir/PCSBCSSourceReplyInversionIncoming.lean create mode 100644 verification/whir/Whir/PCSBCSSourceReplyInversionSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceRootCapture.lean create mode 100644 verification/whir/Whir/PCSBCSSourceRootReferences.lean create mode 100644 verification/whir/Whir/PCSBCSSourceRootReferencesBudget.lean create mode 100644 verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSVerifierPacketWalk.lean create mode 100644 verification/whir/Whir/PCSStateRestoration.lean create mode 100644 verification/whir/Whir/PCSStateRestorationAdaptive.lean create mode 100644 verification/whir/Whir/PCSStateRestorationLatent.lean create mode 100644 verification/whir/Whir/PCSStateRestorationLatentProbability.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index 2c7666633..06cdbffbe 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -10,7 +10,7 @@ Dependencies are pinned by `lean-toolchain`, `lakefile.toml`, `lake-manifest.jso cd verification/whir systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 lake update systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake build --wfail -systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake env lean Audit.lean +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake env lean -DwarningAsError=true Audit.lean python3 differential/run.py ``` @@ -19,11 +19,15 @@ The runner builds and executes `whirModel`, executes the production Rust harness The maintained compiled extraction and actual mode-stream regressions can be reproduced separately: ```sh -systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake build whirExtractionSmoke whirCountedExtractionSmoke whirActualSourceStreamSmoke whirRoundByRoundDecoderSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 env LEAN_NUM_THREADS=2 lake build --wfail whirExtractionSmoke whirCountedExtractionSmoke whirActualSourceStreamSmoke whirRoundByRoundDecoderSmoke whirBookRoundsSmoke whirMerkleLogExtractionSmoke pcsbcsSourceCoordinateDecoderSmoke pcsbcsPublicLogExtractorSmoke systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirExtractionSmoke systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirCountedExtractionSmoke systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirActualSourceStreamSmoke systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirRoundByRoundDecoderSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirBookRoundsSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/whirMerkleLogExtractionSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/pcsbcsSourceCoordinateDecoderSmoke +systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bin/pcsbcsPublicLogExtractorSmoke ``` ### Current source drift @@ -177,9 +181,11 @@ The completed characteristic-two additive source protocol has a coin-free straig The exact uniform round error is `(17/32)^56 + 1/2^78`. The grouped round count is `1 + sum_i(folds_i + oodCount_i + 1) + tailCount`, including the final full-E draw that has no following prover response. The checked PCS raw alphabets have minimum entropy exactly 192 bits, with the initial gamma, six maps and lambda forming one eight-E message and queries retaining their full E squeezes before positional projection. The source regrouping is causal and preserves acceptance and rejection in its modeled domain. The unchanged PCS profiles have `k <= 40` and maximal raw message length at most 5760 bits. These are protocol and resource statements, not a security level or a whole-system entropy conclusion. -Merkle-query-log reconstruction builds one preimage index and produces raw compact occupied rows in physical leaf order. The published `PCSBCSMerkleSourceRows.rawRoot0_eq_compactBaseOracle` and `pruned_opened_rows`, and the opened-table transport derived from them, cover the fully occupied case `leaf_words = occupied`. They do not yet cover production's partially occupied leaf images: [`pcs/src/whir/verify.rs:404`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/pcs/src/whir/verify.rs#L404) passes `(n_lanes, max)`, and [`pcs/src/verifier.rs:51-52,121-123`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/pcs/src/verifier.rs#L51-L123) authenticates the zero-prefixed full image before removing its prefix. Extending the compact-row transport to that actual image is proof work, not a production change. For the modeled fully occupied shape and authentic captured prefix, accepted pruned openings agree with the reconstructed table or trigger the separately proved compression-game bad event. Cache retrieval requires the same shape and captured-prefix provenance; digest equality alone does not justify cross-shape retrieval. Identical untagged bytes can be interpreted as a node or a leaf without a collision. Missing or malformed leaves use explicit default rows and are not treated as authenticated data. Occupied-lane reversal belongs to the first-fold consumer, not the raw decoder input. This is a checked extraction component, not a deployed Fiat-Shamir knowledge theorem or universal Rust refinement. +Merkle-query-log reconstruction builds one preimage index, authenticates the full zero-prefixed leaf image and only then removes `leaf_words - occupied` scalars to produce compact occupied rows in physical leaf order. The earlier `PCSBCSMerkleSourceRows.rawRoot0_eq_compactBaseOracle` and `pruned_opened_rows` covered only fully occupied leaves. The completed `PCSBCSMerkleLeafImages`, `PCSBCSMerkleFullSourceTransport` and four-field root-cache transport now cover the production distinction: [`pcs/src/whir/verify.rs:404`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/pcs/src/whir/verify.rs#L404) passes `(n_lanes, max)`, and [`pcs/src/verifier.rs:51-52,121-123`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/pcs/src/verifier.rs#L51-L123) hashes the padded image before compacting it. Missing images retain explicit unavailability; recovered nonzero padding retains availability but fails the padding check. Cache identity includes the digest, tree height, full image width and occupied width. Later records cannot replace a frozen prefix. Accepted opened rows agree with their frozen source rows outside the stated primitive opening-bad event; this is not an assumption that all committed images were already queried. -The integrated completed closure passed `lake build --wfail +Whir:olean +Main:olean`, and `Audit.lean` checked **10402 exported Whir theorem declarations** with only the three permitted standard axioms. Actual compiled execution passed the multilevel accepted/rejected model, nontrivial full-root Gao extraction with a corrupted row, PCS grouped round and byte-cache behavior, and real-BLAKE2s Merkle-log extraction with honest, tampered, absent, malformed and lane-order cases. The inconsistent-output log fixture exercises collision handling without claiming a BLAKE2s collision. Unfinished restoration and source-duplex composition modules are not imported by this audited root. +The integrated completed closure passed `lake build --wfail +Whir:olean +Main:olean`, and strict-warning `Audit.lean` checked **11010 exported Whir theorem declarations** with only the three permitted standard axioms. Six maintained compiled executables passed: the multilevel accepted/rejected model, nontrivial full-root Gao extraction with a corrupted row, PCS grouped round and byte-cache behavior, padded real-BLAKE2s Merkle-log transport and rejection, actual public coordinate recovery, and anchored public-log before-answer root capture, including a later point block queried first. The inconsistent-output log fixture exercises collision handling without claiming a BLAKE2s collision. The root imports completed literal restoration fibers, whole-current-independent root capture and source reply inversion, not a completed Fiat-Shamir knowledge endpoint. + +The executable public-log extractor selects the first recognized four-field Root0 address and uses only the ordinary compression records preceding that node's answer, then invokes the same original-statement Gao helper. Its output theorem checks one returned word against all 64 family slices, ordinary and strided points and the saved anchor. The scanner derives a conservative physical-query target cap `M = Q * (Q + 1)`, including adaptive anchor-source references. Its separate ideal-compression Merkle extraction term is exactly `(Q^3 + 3*Q^2 - 2*Q) / 2^256`; duplex coupling remains `min(1, (2*Q^2 - Q) / 2^256)`. These terms are not the unfinished Fiat-Shamir extraction-failure bound: identification of the actual source metadata and accepted state path, total extractor runtime, anchor composition and whole-system entropy remain separate obligations. No `Q^2 / 2^192` hash-chain term is transplanted from the book, because the actual duplex source keys omit prior verifier replies. ## Deployed leaf/node boundary and required invariant diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index 7ba7094af..7ab17e4aa 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -159,3 +159,21 @@ import Whir.PCSBCSRoundsByteHistory import Whir.PCSBCSMerkleRootCache import Whir.PCSBCSMerkleOpenedTable import Whir.MerkleQueryLogExtractionResourceContract +import Whir.PCSBCSMerkleRootCacheTransport +import Whir.PCSBCSMerkleRootCacheCost +import Whir.PCSBCSChallengeOracleEnteredGames +import Whir.PCSBCSChallengeOracleEnteredErasure +import Whir.PCSBCSChallengeOracleAccounting +import Whir.PCSBCSRestorationLiteralPath +import Whir.PCSBCSLiteralStatePath +import Whir.PCSBCSVerifierPacketWalk +import Whir.PCSBCSChallengeOracleRestoration +import Whir.PCSBCSSourcePacketTape +import Whir.PCSBCSSourceCoordinateDecoderSource +import Whir.PCSBCSSourceCoordinateDecoderProvenance +import Whir.PCSBCSSourceRootReferencesBudget +import Whir.PCSBCSFrozenOracleRows +import Whir.PCSBCSPublicLogExtractor +import Whir.PCSBCSActualMerkleBound +import Whir.PCSBCSSourceRootCapture +import Whir.PCSBCSSourceReplyInversionIncoming diff --git a/verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean b/verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean index 03c50a426..9dc4c7247 100644 --- a/verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean +++ b/verification/whir/Whir/MerkleQueryLogExtractionSmoke.lean @@ -1,11 +1,12 @@ import Whir.PCSBCSMerkleRootCache +import Whir.PCSBCSMerkleFullSourceTransport -/-! Native executable smoke: actual BLAKE2s compression records, including a -multiblock occupied row, repeated registration, tampering, absence, malformed -bytes, and an explicit inconsistent-output record set. No native_decide proof. -/ +/-! Actual BLAKE2s records with occupied UInt64.ofNat (n+1) let right : List K := (List.range 9).map fun n => UInt64.ofNat (n+21) - let lb := ByteCodec.wordsBytes left - let rb := ByteCodec.wordsBytes right + let fullLeft := leafImage 0 16 left + let fullRight := leafImage 0 16 right + let lb := ByteCodec.wordsBytes fullLeft + let rb := ByteCodec.wordsBytes fullRight let ld := hashBlake2s lb let rd := hashBlake2s rb let pb := List.ofFn (ByteCodec.pairBytes (ld,rd)) let root := hashBlake2s pb let honest := plan blake2sOracle lb ++ plan blake2sOracle rb ++ plan blake2sOracle pb - let table := rawRoot0 honest root 1 9 - require (table.toList.map Array.toList == [left,right]) "honest full Root0 rows differ" + let cells := sourceCells honest root 1 16 9 + let table := compactTable cells + require ((imageTable cells).toList.map Array.toList == [fullLeft,fullRight]) + "full authenticated images lost their leading padding" + require (table.toList.map Array.toList == [left,right]) "compact suffix rows differ" + require (cells.toList.all (fun cell => cell.available && cell.paddingValid)) + "honest padded leaves did not carry both status bits" require ((root0Consumer 9 16 table)[0]!.toList == left.reverse ++ List.replicate 7 0) "separate first-fold occupied-lane reversal/padding differs" + let fullProof : PrunedMerklePaths := ⟨[fullLeft,fullRight],[]⟩ + require ((PCSBCSMerkleFullSourceTransport.openSource hashBlake2s fullProof root + 2 [0,1] 16 9).isSome) "valid occupied (cell.available,cell.paddingValid))) == some (true,false)) + "invalid padding was conflated with missing data or authenticated padding" let missing := plan blake2sOracle rb ++ plan blake2sOracle pb let mt := fromPublic missing root 1 - require (mt.get [false] == none && mt.get [true] == some right) - "missing preimage was forged or available sibling was lost" - require ((rawRoot0 missing root 1 9).toList.map Array.toList == - [List.replicate 9 0,right]) "explicit absence default or full table order differs" - require ((rawRoot0 honest root 1 8).toList.map Array.toList == - [List.replicate 8 0,List.replicate 8 0]) "malformed width was not defaulted" - let registry := PCSBCSMerkleRootCache.register ∅ honest root ⟨1,9⟩ - let repeated := PCSBCSMerkleRootCache.register registry missing root ⟨0,8⟩ - require ((repeated[key root]?).map (fun frozen => frozen.raw.toList.map Array.toList) == - some [left,right]) "first root registration was recomputed or replaced" + require (mt.get [false] == none && mt.get [true] == some fullRight) + "missing full preimage was forged or available sibling was lost" + let missingCells := sourceCells missing root 1 16 9 + require ((compactTable missingCells).toList.map Array.toList == [List.replicate 9 0,right]) + "explicit book default or compact table order differs" + require (((missingCells[0]?).map (fun cell => (cell.available,cell.paddingValid))) == some (false,false)) + "unavailable zero default was authenticated" + let registry := PCSBCSMerkleRootCache.register ∅ honest root ⟨1,16,9⟩ + let repeated := PCSBCSMerkleRootCache.register registry missing root ⟨1,16,9⟩ + let physicalKey := PCSBCSMerkleRootCache.cacheKey root ⟨1,16,9⟩ + require ((repeated[physicalKey]?).map (fun frozen => frozen.raw.toList.map Array.toList) == + some [left,right]) "same-shape first registration was recomputed or replaced" + require ((repeated[physicalKey]?).map (fun frozen => frozen.queryPrefix.length) == + some honest.length) "same-shape announcement prefix changed" + let some pairWords := decodeWords pb | throw (IO.userError "pair did not decode as eight words") + require (pairWords.length == 8 && ByteCodec.wordsBytes pairWords == pb) + "identical-preimage reinterpretation changed the bytes" + let alternate := PCSBCSMerkleRootCache.register repeated honest root ⟨0,8,8⟩ + let alternateKey := PCSBCSMerkleRootCache.cacheKey root ⟨0,8,8⟩ + require ((alternate[alternateKey]?).map (fun frozen => frozen.raw.toList.map Array.toList) == + some [pairWords]) "same CV at another image shape reused the old table" + let alternateProof : PrunedMerklePaths := ⟨[pairWords],[]⟩ + require ((PCSBCSMerkleFullSourceTransport.openSource hashBlake2s alternateProof root + 1 [0] 8 8).isSome) "identical-preimage alternate shape was not actually admitted" + let narrow := PCSBCSMerkleRootCache.register alternate honest root ⟨1,16,8⟩ + let narrowKey := PCSBCSMerkleRootCache.cacheKey root ⟨1,16,8⟩ + require ((narrow[narrowKey]?).map (fun frozen => frozen.raw.toList.map Array.toList) == + some [left.drop 1,right.drop 1]) "another occupied width lost the literal suffix" + let wider := PCSBCSMerkleRootCache.register narrow honest root ⟨1,32,9⟩ + let widerKey := PCSBCSMerkleRootCache.cacheKey root ⟨1,32,9⟩ + require ((wider[widerKey]?).map (fun frozen => frozen.raw.toList.map Array.toList) == + some [List.replicate 9 0,List.replicate 9 0]) "image width was omitted from the address" + require ((wider[widerKey]?).map (fun frozen => frozen.cells.toList.all (fun c => !c.available)) == + some true) "wrong-width defaults were marked available" + require (wider.size == 4) "five announcements of one CV did not create four addressed entries" + require ((wider[physicalKey]?).map (fun frozen => frozen.raw.toList.map Array.toList) == + some [left,right]) "another image shape replaced the original table" let tampered : PublicLog := honest.map fun e => if e.1 = node DuplexCompression.parameterIV 0 pb true then (e.1,ld) else e - require ((fromPublic tampered root 1).get [false] == none) - "tampered final root answer was accepted" - require (decodeWords [0] == none && parsePair [0] == none) - "malformed leaf/pair bytes were accepted" + require ((fromPublic tampered root 1).get [false] == none) "tampered root answer was accepted" + require (decodeWords [0] == none && parsePair [0] == none) "malformed bytes were accepted" let collisionRecords : MerkleTransport.Commitments.Records := [(lb,ld),(rb,ld)] let indexed := build collisionRecords require (indexed[key ld]? == some lb) "first collision registration was not retained" - require ((register indexed rb ld)[key ld]? == some lb) "cached registration was overwritten" - require ((extract canonicalCodec indexed 0 ld).get [] == some left) - "collision case was not deterministic" - require ((fromPublic honest root 0).get [] != some left) - "untagged digest depth was silently erased" - IO.println "Merkle query-log extraction smoke PASS (honest/tampered/missing/malformed/collision/lane-order)" + require ((register indexed rb ld)[key ld]? == some lb) "collision registration was overwritten" + require ((extract canonicalCodec indexed 0 ld).get [] == some fullLeft) "collision case was not deterministic" + IO.println "Merkle query-log extraction smoke PASS (padded-source/opening/padding-rejection/absence/collision/lane-order/image-address)" end Whir.MerkleQueryLogExtractionSmoke diff --git a/verification/whir/Whir/PCSBCSActualMerkleBound.lean b/verification/whir/Whir/PCSBCSActualMerkleBound.lean new file mode 100644 index 000000000..607226576 --- /dev/null +++ b/verification/whir/Whir/PCSBCSActualMerkleBound.lean @@ -0,0 +1,35 @@ +import Whir.PCSBCSSourcePrimitiveRootBudget + +/-! Actual physical-query target admission, including adaptive anchor headers. +The target cap is derived from the public input scanner, not assumed or charged +through a construction ancestry ledger. The bound is an exact Q-expression. -/ +set_option autoImplicit false +namespace Whir.PCSBCSActualMerkleBound +open Concrete Protocol FiatShamirGame DuplexFraming DuplexPublicSimulator +open PCSBCSSourcePrimitiveRootBudget PCSBCSMerkleQueryLog + +variable (p : ParameterBounds.Profile) (Q : Nat) + (layout : PublicLog → Node → WHIRCallerClaims.CallerLayout) + (saved : PublicLog → Node → AnchoredHeaderCodec.Record) + (entry : PublicLog → Node → FramedHistory) + (answers : PublicLog → Node → FiatShamirGame.Coordinate → Digest32) + (headers : PublicLog → Node → AnchoredHeaderRoots.Public) + +theorem source_extraction_probability {T : Type} + (program : PublicCompressionProgram.Computation T Q) : + extractionProbability (targets p Q layout saved entry answers headers) program ≤ + PublicMerkleProbability.bound Q (Q*(Q+1)) := + multi_extraction_probability (targets p Q layout saved entry answers headers) Q (Q*(Q+1)) + (targets_cap p Q layout saved entry answers headers) + (targets_grow p Q layout saved entry answers headers) program + +theorem exact_merkle_loss (Q : Nat) : + PublicMerkleProbability.bound Q (Q*(Q+1)) = + ((Q : ℚ)^3 + 3*(Q : ℚ)^2 - 2*(Q : ℚ))/2^256 := by + unfold PublicMerkleProbability.bound + push_cast + ring + +#print axioms source_extraction_probability +#print axioms exact_merkle_loss +end Whir.PCSBCSActualMerkleBound diff --git a/verification/whir/Whir/PCSBCSCallerBinding.lean b/verification/whir/Whir/PCSBCSCallerBinding.lean new file mode 100644 index 000000000..7c79fa776 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerBinding.lean @@ -0,0 +1,88 @@ +import Whir.PCSBCSRestorationCertificate + +/-! The source application must fix the complete original caller input and incoming public trace independently of the queried packet's answer. Values can be absorbed/public and points can be earlier verifier coins; this law does not pretend every coordinate was serialized. Actual source reconstruction must prove the law, not assume original claims true. -/ +namespace Whir.PCSBCSCallerBinding +open Concrete Protocol CausalGame CausalProbability ParameterBounds +open PCSRoundByRoundKnowledge PCSBCSRestorationHazard +open PCSStateRestoration.Adaptive + +set_option autoImplicit false + +structure CallerInput (p : Profile) where + lanes : Nat + m : Nat + family : Fin m → RingPCSGame.FamilyClaim + points : Array RingPCSGame.PointClaim + anchorPoint : Array E + anchorValue : E + prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue + familyCap : m ≤ 2^64 + claimCap : points.size + 2 ≤ 2^64 + +structure CallerData (p : Profile) where + original : CallerInput p + observed : PublicData (config p) + +noncomputable def fixedCertificate (p : Profile) (input : CallerInput p) := + certificate p input.lanes input.family input.points input.anchorPoint input.anchorValue input.prepared + +noncomputable def callerCertificate (p : Profile) : + Certificate (Coordinate (config p)) PCSBCSRounds.Raw (CallerData p) where + before data q := (fixedCertificate p data.original).before data.observed q + after data q answer := (fixedCertificate p data.original).after data.observed q answer + +theorem caller_fiber (p : Profile) (data : CallerData p) (q : Coordinate (config p)) + (undoomed : (callerCertificate p).before data q = false) : + Soundness.uniformProb (Finset.univ.filter fun answer : PCSBCSRounds.Raw q => + (callerCertificate p).after data q answer = true) ≤ rbrError := by + classical + change Soundness.uniformProb (Finset.univ.filter fun answer : PCSBCSRounds.Raw q => + (fixedCertificate p data.original).after data.observed q answer = true) ≤ rbrError + change (fixedCertificate p data.original).before data.observed q = false at undoomed + by_cases initial : q = .initial + · subst q + exact initial_fiber p data.original.lanes data.original.family data.original.points + data.original.anchorPoint data.original.anchorValue data.original.prepared + data.original.familyCap data.original.claimCap data.observed + · exact noninitial_fiber p data.original.lanes data.original.family data.original.points + data.original.anchorPoint data.original.anchorValue data.original.prepared + data.original.claimCap data.observed q initial undoomed + +abbrev Table (p : Profile) (Key : Type) (coordinate : Key → Coordinate (config p)) := + (key : Key) → PCSBCSRounds.Raw (coordinate key) + +/-- This is the explicit source precondition, not a primitive soundness premise: +changing only the current packet answer cannot change the original caller input, +its frozen root or strictly incoming trace. Earlier latent coins may be used. -/ +def CallerBoundBeforeDraw (p : Profile) {Key : Type} [DecidableEq Key] + (coordinate : Key → Coordinate (config p)) + (snapshot : Key → Table p Key coordinate → CallerData p) : Prop := + ∀ key table answer, snapshot key (Function.update table key answer) = snapshot key table + +/-- The actual varying-table fiber reduces to the proved additive RBR fiber +only under the named caller-binding law. This theorem does not assert that the +public generic Rust stack API absorbs a supplied statement. -/ +theorem caller_source_fiber (p : Profile) {Key : Type} [DecidableEq Key] + (coordinate : Key → Coordinate (config p)) + (snapshot : Key → Table p Key coordinate → CallerData p) + (callerBinding : CallerBoundBeforeDraw p coordinate snapshot) + (key : Key) (table : Table p Key coordinate) + (undoomed : (callerCertificate p).before (snapshot key table) (coordinate key) = false) : + Soundness.uniformProb (Finset.univ.filter fun answer : PCSBCSRounds.Raw (coordinate key) => + (callerCertificate p).after (snapshot key (Function.update table key answer)) (coordinate key) answer = true) ≤ + rbrError := by + classical + have same : + (Finset.univ.filter fun answer : PCSBCSRounds.Raw (coordinate key) => + (callerCertificate p).after (snapshot key (Function.update table key answer)) (coordinate key) answer = true) = + (Finset.univ.filter fun answer : PCSBCSRounds.Raw (coordinate key) => + (callerCertificate p).after (snapshot key table) (coordinate key) answer = true) := by + congr 1 + funext answer + rw [callerBinding key table answer] + rw [same] + exact caller_fiber p (snapshot key table) (coordinate key) undoomed + +#print axioms caller_fiber +#print axioms caller_source_fiber +end Whir.PCSBCSCallerBinding diff --git a/verification/whir/Whir/PCSBCSChallengeOracle.lean b/verification/whir/Whir/PCSBCSChallengeOracle.lean new file mode 100644 index 000000000..c0951e0b8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracle.lean @@ -0,0 +1,201 @@ +import Whir.PCSBCSRoundsAdapter +import Whir.PCSBCSRoundsByteHistory +import Whir.RawOracleCoupling +import Whir.PublicCompressionCouplingActualCausalBound + +/-! Literal #552 challenge packets. A packet consists of all continuation blocks +of one normalized source history, not a hash of the preceding verifier answer. +The unused suffix of its last 256-bit block is retained. Programming is globally +memoized; a repeated query is not a new random experiment. -/ +set_option autoImplicit false +namespace Whir.PCSBCSChallengeOracle +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame TypedOracleCompiler +open scoped BigOperators + +private def concatenate (a b : Nat) : + ((Fin a → E) × (Fin b → E)) ≃ (Fin (a+b) → E) := + (Equiv.sumArrowEquivProdArrow (Fin a) (Fin b) E).symm.trans + (Equiv.arrowCongr finSumFinEquiv (Equiv.refl E)) + +/-- Componentwise, source-ordered representation; no cardinality-chosen bijection. -/ +def rawVector {c : Config} (q : CausalProbability.Coordinate c) : + Raw q ≃ (Fin (rawWidth q) → E) := by + cases q with + | initial => exact initialEight + | query i => exact ((Equiv.prodCongr (Equiv.refl _) (Equiv.funUnique (Fin 1) E).symm).trans + (concatenate (queryChunks c i.val) 1)) + | fold i j => exact (Equiv.funUnique (Fin 1) E).symm + | ood i j => exact Equiv.refl _ + | tail j => exact (Equiv.funUnique (Fin 1) E).symm + +def blocks (width : Nat) : Nat := (24*width+31)/32 + +def unused (width : Nat) : Nat := 32*blocks width-24*width + +theorem packet_length (width : Nat) : + 24*width + unused width = blocks width * 32 := by + have bound : 24*width ≤ 32*blocks width := by + unfold blocks + omega + unfold unused + omega + +def scalarBytesEquiv : E ≃ Scalar24 where + toFun := ByteCodec.encodeE + invFun := ByteCodec.decodeE + left_inv := ByteCodec.decodeE_encodeE + right_inv := ByteCodec.encodeE_decodeE + +/-- Flattening follows the byte cursor: block j, byte i is byte 32*j+i. -/ +def flatten (n size : Nat) : (Fin n → Fin size → Byte) ≃ (Fin (n*size) → Byte) := + (Equiv.curry (Fin n) (Fin size) Byte).symm.trans + (Equiv.arrowCongr finProdFinEquiv (Equiv.refl Byte)) + +def vectorBytes (width : Nat) : (Fin width → E) ≃ (Fin (width*24) → Byte) := + (Equiv.arrowCongr (Equiv.refl (Fin width)) scalarBytesEquiv).trans (flatten width 24) + +/-- All bytes are accounted for: full E vector and the unused output suffix. -/ +def packetEquiv (width : Nat) : + (Fin (blocks width) → Digest32) ≃ ((Fin width → E) × (Fin (unused width) → Byte)) := + (flatten (blocks width) 32).trans + ((Equiv.arrowCongr (finCongr (by have h := packet_length width; omega)) + (Equiv.refl Byte)).trans + ((Equiv.arrowCongr finSumFinEquiv.symm (Equiv.refl Byte)).trans + ((Equiv.sumArrowEquivProdArrow (Fin (width*24)) (Fin (unused width)) Byte).trans + (Equiv.prodCongr (vectorBytes width).symm (Equiv.refl _))))) + +def grouped {c : Config} (q : CausalProbability.Coordinate c) + (packet : Fin (blocks (rawWidth q)) → Digest32) : Raw q := + (rawVector q).symm ((packetEquiv (rawWidth q) packet).1) + +/-- The payload is the actual contiguous prefix of the concatenated output +blocks. The equivalence does not choose a representation by cardinality. -/ +theorem grouped_payload_bytes {c : Config} (q : CausalProbability.Coordinate c) + (packet : Fin (blocks (rawWidth q)) → Digest32) (j : Fin (rawWidth q*24)) : + vectorBytes (rawWidth q) (rawVector q (grouped q packet)) j = + packet ⟨j.val/32, by + have h := packet_length (rawWidth q) + have hj := j.isLt + omega⟩ ⟨j.val%32, Nat.mod_lt _ (by decide)⟩ := by + simp only [grouped, Equiv.apply_symm_apply] + simp [packetEquiv, flatten, vectorBytes, Equiv.arrowCongr, finProdFinEquiv, + Nat.mod_add_div] + rfl + +private theorem product_probability {A B : Type*} [Fintype A] [Fintype B] + (P : A → Prop) (R : B → Prop) : + SamplingProbability.probability (fun x : A × B => P x.1 ∧ R x.2) = + SamplingProbability.probability P * SamplingProbability.probability R := by + classical + let e : {x : A × B // P x.1 ∧ R x.2} ≃ {a : A // P a} × {b : B // R b} := + { toFun := fun x => (⟨x.val.1,x.property.1⟩,⟨x.val.2,x.property.2⟩) + invFun := fun x => ⟨(x.1.val,x.2.val),x.1.property,x.2.property⟩ + left_inv := fun _ => rfl + right_inv := fun _ => rfl } + unfold SamplingProbability.probability + simp only [← Nat.card_eq_fintype_card] + rw [Nat.card_congr e, Nat.card_prod, Nat.card_prod] + simp only [Nat.cast_mul, div_eq_mul_inv, mul_inv_rev] + ring + +/-- Uniform full-E message, independently of every predicate of the retained +suffix. In particular a 256-bit output is not silently counted as 256 E bits. -/ +theorem grouped_uniform_independent {c : Config} (q : CausalProbability.Coordinate c) + (P : Raw q → Prop) (S : (Fin (unused (rawWidth q)) → Byte) → Prop) : + SamplingProbability.probability (fun packet : Fin (blocks (rawWidth q)) → Digest32 => + P (grouped q packet) ∧ S (packetEquiv (rawWidth q) packet).2) = + SamplingProbability.probability P * SamplingProbability.probability S := by + unfold grouped + rw [SamplingProbability.probability_equiv (packetEquiv (rawWidth q)) + (fun x => P ((rawVector q).symm x.1) ∧ S x.2)] + rw [product_probability (fun v => P ((rawVector q).symm v)) S, + SamplingProbability.probability_equiv (rawVector q).symm P] + +theorem grouped_uniform {c : Config} (q : CausalProbability.Coordinate c) (P : Raw q → Prop) : + SamplingProbability.probability (fun packet : Fin (blocks (rawWidth q)) → Digest32 => + P (grouped q packet)) = SamplingProbability.probability P := by + have h := grouped_uniform_independent q P (fun _ => True) + have : Nonempty (Fin (unused (rawWidth q)) → Byte) := ⟨fun _ => ⟨0,by decide⟩⟩ + have ht : SamplingProbability.probability (fun _ : Fin (unused (rawWidth q)) → Byte => True) = 1 := by + classical + simp [SamplingProbability.probability] + simpa only [and_true, ht, mul_one] using h + +/-- Exact stratified query projection jointly with lambda, from complete +continuation blocks. Unused high query bits and final output bytes are retained. -/ +theorem grouped_query_projection {c : Config} (i : Fin c.folds.size) + (positive : 0 < remaining c i.val + c.rates[i.val]!) + (bounded : remaining c i.val + c.rates[i.val]! ≤ 64) + (P : Fin c.queries[i.val]! → Nat → Prop) (L : E → Prop) : + SamplingProbability.probability + (fun packet : Fin (blocks (rawWidth (.query i))) → Digest32 => + let x := grouped (.query i) packet + (∃ qs, deriveQueries (remaining c i.val + c.rates[i.val]!) c.queries[i.val]! + (Array.ofFn x.1) = some qs ∧ ∀ j : Fin c.queries[i.val]!, P j qs[j.val]!) ∧ L x.2) = + (∏ j, SamplingProbability.probability (fun raw : + Fin (2^(remaining c i.val + c.rates[i.val]!)) => + P j (SamplingProbability.concretePlace c.queries[i.val]! + (remaining c i.val + c.rates[i.val]!) j.val raw.val))) * + SamplingProbability.probability L := by + let event : Raw (.query i) → Prop := fun x => + (∃ qs, deriveQueries (remaining c i.val + c.rates[i.val]!) c.queries[i.val]! + (Array.ofFn x.1) = some qs ∧ ∀ j : Fin c.queries[i.val]!, P j qs[j.val]!) ∧ L x.2 + exact (grouped_uniform (.query i) event).trans + (query_lambda_joint_law _ _ positive bounded P L) + +/-- Literal finite RO keys can be restricted to any finite collection of +histories, including observer requests. No observer-class exclusion is used. -/ +noncomputable def restrictionEquiv {K I D : Type*} (key : I → K) + (injective : Function.Injective key) : + (K → D) ≃ ((I → D) × ({k : K // k ∉ Set.range key} → D)) := by + classical + exact (Equiv.piEquivPiSubtypeProd (fun k => k ∈ Set.range key) (fun _ => D)).trans + (Equiv.prodCongr (Equiv.arrowCongr (Equiv.ofInjective key injective).symm (Equiv.refl D)) + (Equiv.refl _)) + +theorem restriction_first {K I D : Type*} (key : I → K) + (injective : Function.Injective key) (table : K → D) : + (restrictionEquiv key injective table).1 = fun i => table (key i) := by + funext i + rfl + +open Classical in +/-- Freshness means absence of every requested continuation block from the +shared cache, not merely resetting the source byte cursor. Arbitrary events of +all other oracle entries factor from the complete grouped message. -/ +theorem fresh_group_independent {K : Type*} [Fintype K] {c : Config} + (q : CausalProbability.Coordinate c) (key : Fin (blocks (rawWidth q)) → K) + (injective : Function.Injective key) (cache : K → Option Digest32) + (fresh : ∀ i, cache (key i) = none) (P : Raw q → Prop) + (R : ({k : K // k ∉ Set.range key} → Digest32) → Prop) : + SamplingProbability.probability (fun table : K → Digest32 => + P (grouped q (fun i => RawOracleCoupling.overlay cache table (key i))) ∧ + R (restrictionEquiv key injective table).2) = + SamplingProbability.probability P * SamplingProbability.probability R := by + classical + have overlay (table : K → Digest32) : + (fun i => RawOracleCoupling.overlay cache table (key i)) = fun i => table (key i) := by + funext i; simp [RawOracleCoupling.overlay, fresh] + simp only [overlay] + change SamplingProbability.probability (fun table : K → Digest32 => + P (grouped q (restrictionEquiv key injective table).1) ∧ + R (restrictionEquiv key injective table).2) = _ + rw [SamplingProbability.probability_equiv (restrictionEquiv key injective) + (fun x => P (grouped q x.1) ∧ R x.2), + product_probability (fun packet => P (grouped q packet)) R, + grouped_uniform] + +/-- Programming and repeated-query behavior are the existing checked globally +memoized finite oracle semantics, for all adaptive continuations and payoffs. -/ +theorem programmable_table {K R : Type*} [Fintype K] [DecidableEq K] + {n : Nat} (p : Sampling K (fun _ => Digest32) R n) + (cache : K → Option Digest32) (payoff : R → ℚ) : + average (fun table => payoff (Sampling.eval (RawOracleCoupling.overlay cache table) p)) = + Sampling.expectation (fun result => payoff result.1) (RawOracleCoupling.memo p cache) := + RawOracleCoupling.table_eq_memo p cache payoff + +#print axioms grouped_uniform_independent +#print axioms fresh_group_independent +#print axioms programmable_table +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleAccounting.lean b/verification/whir/Whir/PCSBCSChallengeOracleAccounting.lean new file mode 100644 index 000000000..a7006edfb --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleAccounting.lean @@ -0,0 +1,97 @@ +import Whir.PCSBCSChallengeOracleSource + +/-! Exact request ledger. Direct calls of every purpose (including Merkle +verification) cost one; every continuation block charges its entire construction +path. Repetitions are charged, irrespective of global memoization. -/ +set_option autoImplicit false +namespace Whir.PCSBCSChallengeOracle +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame DuplexFraming +open scoped BigOperators + +def requestCost (queries : List Query) : Nat := (queries.map Query.cost).sum + +def requests {R : Type} : List Query → (List Digest32 → Program R) → Program R + | [], next => next [] + | q :: qs, next => .ask q (fun d => requests qs (fun ds => next (d :: ds))) + +/-- Exact prefix budget composes with any adaptive suffix, not merely an honest +verifier or a challenge-only observer. No Merkle-domain call is forgotten. -/ +theorem requests_counted {R : Type} (queries : List Query) (remaining : Nat) + (next : List Digest32 → Program R) (suffix : ∀ ds, Counts remaining (next ds)) : + Counts (requestCost queries + remaining) (requests queries next) := by + induction queries generalizing next with + | nil => simpa [requestCost, requests] using suffix [] + | cons q qs ih => + simp only [requests, Counts, requestCost, List.map_cons, List.sum_cons] + constructor + · omega + · intro d + have h := ih (fun ds => next (d :: ds)) (fun ds => suffix (d :: ds)) + simp only [requestCost] at h + convert h using 1 + omega + +theorem requests_real_cost {R : Type} (queries : List Query) + (oracle : PrimitiveOracle) (iv : Digest32) (next : List Digest32 → Program R) : + (runReal oracle iv (requests queries next)).primitiveCost = + requestCost queries + (runReal oracle iv + (next (queries.map (realAnswer oracle iv)))).primitiveCost := by + induction queries generalizing next with + | nil => simp [requests, requestCost] + | cons q qs ih => simp [requests, runReal, prepend, ih, requestCost, Nat.add_assoc] + +namespace SourcePacket +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + +def queries (s : SourcePacket p Q iv entry q) : List Query := + List.ofFn (fun b : Fin (blocks (rawWidth q)) => .construction (s.coordinate b) (s.valid b)) + +theorem request_number (s : SourcePacket p Q iv entry q) : + s.queries.length = (24*rawWidth q+31)/32 := by + simp [queries, blocks] + +theorem exact_path_cost (s : SourcePacket p Q iv entry q) : + requestCost s.queries = ∑ b : Fin (blocks (rawWidth q)), pathCost (s.coordinate b) := by + simp [requestCost, queries, Query.cost, List.sum_ofFn] + +/-- Caller/anchor and serialized prover/nonce work are included in EVERY +uncached root-to-output path. No block or repeated request is free. -/ +theorem exact_framed_cost (s : SourcePacket p Q iv entry q) : + requestCost s.queries = blocks (rawWidth q) * + (2 + (entry.frames.flatMap DuplexEncoding.framePlan).length + + ((WHIRHistoryKey.canonicalFrames (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + s.messages).flatMap DuplexEncoding.framePlan).length) := by + rw [s.exact_path_cost] + simp_rw [coordinate, WHIRCallerPrefix.pathCostFrom _ + (WHIRHistoryKey.stackWidth_positive p) entry + (WHIRHistoryKey.scheduled_normal _ _ s.nonempty s.admitted)] + simp + +/-- Eight E needs six 32-byte output blocks, not eight truncated RO calls. -/ +theorem initial_output_blocks : blocks 8 = 6 := by decide + +end SourcePacket + +/-- Aggregate mode cap for a completed list of packet requests and arbitrary +public calls. This identity includes every repeated request at its full cost. -/ +theorem aggregate_query_cost (packets : List (List Query)) (publicQueries : List Query) : + requestCost (packets.flatten ++ publicQueries) = + (packets.map requestCost).sum + requestCost publicQueries := by + have append (xs ys : List Query) : + requestCost (xs ++ ys) = requestCost xs + requestCost ys := by + simp [requestCost] + have flattened : requestCost packets.flatten = (packets.map requestCost).sum := by + induction packets with + | nil => simp [requestCost] + | cons packet packets ih => + simp only [List.flatten_cons,append,List.map_cons,List.sum_cons,ih] + rw [append,flattened] + +#print axioms requests_counted +#print axioms requests_real_cost +#print axioms SourcePacket.exact_path_cost +#print axioms SourcePacket.exact_framed_cost +#print axioms aggregate_query_cost +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleCanonical.lean b/verification/whir/Whir/PCSBCSChallengeOracleCanonical.lean new file mode 100644 index 000000000..25a1c787d --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleCanonical.lean @@ -0,0 +1,90 @@ +import Whir.PCSBCSChallengeOraclePackets + +/-! The canonical finite packet domain contains EVERY admitted source history +under the aggregate path cap, not an arbitrarily preselected family of observer +queries. Finiteness is derived from the proved literal key injection. All +nonpacket raw and simulator-seed inputs remain in the garbage summand. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame RawOracleCoupling + +abbrev CanonicalPacket (p : ParameterBounds.Profile) (Qcompression : Nat) + (iv : Digest32) (entry : FramedHistory) := + Sigma (fun q : CausalProbability.Coordinate (ParameterBounds.config p) => + SourcePacket p Qcompression iv entry q) + +namespace CanonicalPacket +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {entry : FramedHistory} + +def coord (packet : CanonicalPacket p Q iv entry) := packet.1 + +def messages (packet : CanonicalPacket p Q iv entry) := packet.2.messages + +theorem messages_injective : + Function.Injective (messages (p := p) (Q := Q) (iv := iv) (entry := entry)) := by + intro a b same + rcases a with ⟨q,s⟩ + rcases b with ⟨q',t⟩ + change s.messages = t.messages at same + have position_same : position q = position q' := by + rw [← s.position_eq, ← t.position_eq, same] + have coordinate_same : q = q' := by + have hs := schedule_get_position q + have ht := schedule_get_position q' + rw [position_same] at hs + exact Option.some.inj (hs.symm.trans ht) + subst q' + have records_same : s = t := by + cases s + cases t + cases same + rfl + cases records_same + rfl + +def firstBlock (packet : CanonicalPacket p Q iv entry) : Fin (blocks (rawWidth packet.coord)) := + ⟨0, by + have positive := (WHIRHistoryKey.production_sample_counts p packet.coord).2 + change 0 < rawWidth packet.coord at positive + unfold blocks + omega⟩ + +def firstKey (packet : CanonicalPacket p Q iv entry) : RawKey Q := packet.2.key packet.firstBlock + +theorem firstKey_injective : + Function.Injective (firstKey (p := p) (Q := Q) (iv := iv) (entry := entry)) := by + intro a b same + have facts := SourcePacket.distinct_history_keys a.2 b.2 a.firstBlock b.firstBlock same + exact messages_injective facts.1 + +/-- A checked finite domain of ALL source packets; no finite-enumeration +coverage assumption and no source entropy assumption are needed. -/ +noncomputable instance : Fintype (CanonicalPacket p Q iv entry) := by + classical + letI := rawKeyFintype Q + exact Fintype.ofInjective firstKey firstKey_injective + +noncomputable instance : DecidableEq (CanonicalPacket p Q iv entry) := Classical.decEq _ + +noncomputable def partition : + Partition (PublicCompressionCouplingMixed.Key Q) (CanonicalPacket p Q iv entry) + (fun a => Fin (blocks (rawWidth a.coord))) := + sourceFamilyPartition coord (fun a => a.2) messages_injective + +set_option maxHeartbeats 0 in +/-- Every admitted physical source output block is recognized as its full +canonical packet; remaining simulator or observer keys are not excluded. -/ +theorem recognize_block (packet : CanonicalPacket p Q iv entry) + (b : Fin (blocks (rawWidth packet.coord))) : + (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).recognize + (.inr (packet.2.key b)) = some ⟨packet,b⟩ := + (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).recognize_encode ⟨packet,b⟩ + +end CanonicalPacket + +#print axioms CanonicalPacket.messages_injective +#print axioms CanonicalPacket.firstKey_injective +#print axioms CanonicalPacket.recognize_block +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleEnteredErasure.lean b/verification/whir/Whir/PCSBCSChallengeOracleEnteredErasure.lean new file mode 100644 index 000000000..e24d01bf3 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleEnteredErasure.lean @@ -0,0 +1,62 @@ +import Whir.PCSBCSChallengeOracleEnteredPartition + +/-! All varying live prefixes share one virtual source table. Strict ancestors +retain the same public entry boundary and reside in OTHER packet fibers. Pure +metadata reconstruction does not request or disclose their latent answers. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle.EnteredPacket +open Concrete Protocol CausalGame CausalProbability PCSBCSRounds +open FiatShamirGame DuplexModeGame RawOracleCoupling +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} + +abbrev Earlier (current : EnteredPacket p Q iv boundary) := current.2.Earlier + +def predecessor (current : EnteredPacket p Q iv boundary) (earlier : current.Earlier) : + EnteredPacket p Q iv boundary := ⟨current.1,current.2.predecessor earlier⟩ + +theorem predecessor_ne_current (current : EnteredPacket p Q iv boundary) + (earlier : current.Earlier) : current.predecessor earlier ≠ current := by + intro same + have positions := congrArg (fun a : EnteredPacket p Q iv boundary => position a.2.coord) same + change position earlier.val = position current.2.coord at positions + have strict := earlier.property + omega + +abbrev OtherValues (current : EnteredPacket p Q iv boundary) := + (k : {k : (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Key // + k ≠ .inl current}) → + (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Answer (D := Digest32) k.val + +def prefixRawFromOther (current : EnteredPacket p Q iv boundary) + (other : current.OtherValues) (earlier : current.Earlier) : Raw earlier.val := + grouped earlier.val (other ⟨.inl (current.predecessor earlier),by + intro same + exact current.predecessor_ne_current earlier (Sum.inl.inj same)⟩) + +def metadataFromOther {M : Type*} (current : EnteredPacket p Q iv boundary) + (build : current.OtherValues → (∀ r : current.Earlier, Raw r.val) → M) + (other : current.OtherValues) : M := build other (current.prefixRawFromOther other) + +def metadataFromTable {M : Type*} (current : EnteredPacket p Q iv boundary) + (build : current.OtherValues → (∀ r : current.Earlier, Raw r.val) → M) + (table : (k : (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Key) → + (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Answer (D := Digest32) k) : M := + current.metadataFromOther build (fun key => table key.val) + +open Classical in +theorem metadata_update_current {M : Type*} (current : EnteredPacket p Q iv boundary) + (build : current.OtherValues → (∀ r : current.Earlier, Raw r.val) → M) + (table : (k : (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Key) → + (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Answer (D := Digest32) k) + (full : Fin (blocks (rawWidth current.2.coord)) → Digest32) : + current.metadataFromTable build (Function.update table (.inl current) full) = + current.metadataFromTable build table := by + unfold metadataFromTable + apply congrArg (current.metadataFromOther build) + funext key + simp [key.property] + +#print axioms predecessor_ne_current +#print axioms metadata_update_current +end Whir.PCSBCSChallengeOracle.EnteredPacket diff --git a/verification/whir/Whir/PCSBCSChallengeOracleEnteredGames.lean b/verification/whir/Whir/PCSBCSChallengeOracleEnteredGames.lean new file mode 100644 index 000000000..b5924c0d8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleEnteredGames.lean @@ -0,0 +1,24 @@ +import Whir.PCSBCSChallengeOracleEnteredPartition +import Whir.PCSBCSChallengeOracleGames + +/-! Whole-view transport covers all admitted data-valued live prefixes at the +public caller boundary, not just one prefix fixed before the adversary. The +bound is the proved 256-bit mode-coupling loss; it is not PCS knowledge or an +assumed hash-chain compilation theorem. -/ +set_option autoImplicit false +namespace Whir.PCSBCSChallengeOracle +open Concrete FiatShamirGame DuplexModeGame + +open Classical in +theorem entered_source_atomic_game_bound {AdvCoins R : Type} [Fintype AdvCoins] + (profile : ParameterBounds.Profile) (Qcompression : Nat) (iv : Digest32) + (boundary : Nat) (adversary : AdvCoins → Program R) + (counted : ∀ coins, Counts Qcompression (adversary coins)) (observe : View R → Bool) : + |realProbability iv adversary observe - + atomicIdealProbability + (EnteredPacket.partition (p := profile) (Q := Qcompression) (iv := iv) + (boundary := boundary)) iv adversary counted observe| ≤ duplexModeLoss Qcompression := + actual_source_atomic_game_bound _ iv adversary counted observe + +#print axioms entered_source_atomic_game_bound +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleEnteredPartition.lean b/verification/whir/Whir/PCSBCSChallengeOracleEnteredPartition.lean new file mode 100644 index 000000000..b9e1a102e --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleEnteredPartition.lean @@ -0,0 +1,61 @@ +import Whir.PCSBCSChallengeOracleEntries + +/-! Whole packets for every admitted live caller prefix at the public boundary. +The same physical source block belongs to at most one packet; all remaining +observer and simulator keys stay in the garbage summand. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle.EnteredPacket +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} + +abbrev Block (packet : EnteredPacket p Q iv boundary) := + Fin (blocks (rawWidth packet.2.coord)) + +def encode (block : Sigma (Block (p := p) (Q := Q) (iv := iv) (boundary := boundary))) : + PublicCompressionCouplingMixed.Key Q := .inr (block.1.2.2.key block.2) + +/-- Equal continuation keys force equal whole packets, even if their caller +prefix data was selected adaptively and differs between honest invocations. -/ +theorem encode_injective : Function.Injective + (encode (p := p) (Q := Q) (iv := iv) (boundary := boundary)) := by + intro a b same + rcases a with ⟨a,ai⟩ + rcases b with ⟨b,bi⟩ + have keys : a.2.2.key ai = b.2.2.key bi := Sum.inr.inj same + have coordinates := constructionKey_injective Q iv (a.2.2.valid ai) (b.2.2.valid bi) + (a.2.2.pathBound ai) (b.2.2.pathBound bi) keys + have history := congrArg FiatShamirGame.Coordinate.history coordinates + dsimp only [SourcePacket.coordinate,WHIRCallerPrefix.outputKeyFrom] at history + have firstCoordinates : a.2.2.coordinate a.2.firstBlock = b.2.2.coordinate b.2.firstBlock := by + change FiatShamirGame.Coordinate.mk _ (.output 0) = FiatShamirGame.Coordinate.mk _ (.output 0) + exact congrArg (fun h => FiatShamirGame.Coordinate.mk h (.output 0)) history + have castKey (x y : FiatShamirGame.Coordinate) (hx : pathCost x ≤ Q) (hy : pathCost y ≤ Q) + (equal : x = y) : constructionKey Q iv x hx = constructionKey Q iv y hy := by + cases equal + rfl + have firstKeys : a.firstKey = b.firstKey := + castKey _ _ (a.2.2.pathBound a.2.firstBlock) (b.2.2.pathBound b.2.firstBlock) firstCoordinates + have packetsSame : a = b := firstKey_injective firstKeys + cases packetsSame + have indexSame := (SourcePacket.distinct_history_keys a.2.2 a.2.2 ai bi keys).2 + have blocksSame : ai = bi := Fin.ext indexSame + cases blocksSame + rfl + +noncomputable instance : DecidableEq (EnteredPacket p Q iv boundary) := Classical.decEq _ + +noncomputable def partition : + Partition (PublicCompressionCouplingMixed.Key Q) (EnteredPacket p Q iv boundary) Block := + partitionOfInjection encode encode_injective + +theorem recognize_block (packet : EnteredPacket p Q iv boundary) (block : Block packet) : + (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).recognize + (.inr (packet.2.2.key block)) = some ⟨packet,block⟩ := + (partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).recognize_encode ⟨packet,block⟩ + +#print axioms encode_injective +#print axioms recognize_block +end Whir.PCSBCSChallengeOracle.EnteredPacket diff --git a/verification/whir/Whir/PCSBCSChallengeOracleEntries.lean b/verification/whir/Whir/PCSBCSChallengeOracleEntries.lean new file mode 100644 index 000000000..14febef7c --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleEntries.lean @@ -0,0 +1,77 @@ +import Whir.PCSBCSChallengeOracleErasure + +/-! All admitted caller prefixes at one public boundary count, rather than one +fixed data-valued entry. Source-key injectivity supplies finiteness. The actual +caller must derive its boundary count from its bound control shape; this module +does not assert a universal Rust parser or sum silently over other profiles. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling + +abbrev EnteredPacket (p : ParameterBounds.Profile) (Q : Nat) (iv : Digest32) + (boundary : Nat) := + Sigma (fun entry : {entry : FramedHistory // entry.frames.length = boundary} => + CanonicalPacket p Q iv entry.val) + +namespace EnteredPacket +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} + +def firstKey (packet : EnteredPacket p Q iv boundary) : RawKey Q := packet.2.firstKey + +/-- The literal raw key determines the live data-valued caller prefix when the +caller boundary count is fixed by the public control shape. -/ +theorem entry_eq_of_firstKey_eq (a b : EnteredPacket p Q iv boundary) + (same : a.firstKey = b.firstKey) : a.1.val = b.1.val := by + have coordinates := constructionKey_injective Q iv (a.2.2.valid a.2.firstBlock) + (b.2.2.valid b.2.firstBlock) (a.2.2.pathBound a.2.firstBlock) + (b.2.2.pathBound b.2.firstBlock) same + have history := congrArg FiatShamirGame.Coordinate.history coordinates + unfold SourcePacket.coordinate at history + rw [WHIRCallerPrefix.outputKeyFrom_history _ (WHIRHistoryKey.stackWidth_positive p) a.1.val + (WHIRHistoryKey.scheduled_normal _ _ a.2.2.nonempty a.2.2.admitted), + WHIRCallerPrefix.outputKeyFrom_history _ (WHIRHistoryKey.stackWidth_positive p) b.1.val + (WHIRHistoryKey.scheduled_normal _ _ b.2.2.nonempty b.2.2.admitted)] at history + have domains := congrArg FramedHistory.domain history + have statements := congrArg FramedHistory.statement history + have frames := congrArg FramedHistory.frames history + have prefixes := congrArg (List.take boundary) frames + have takePrefix (xs ys : List Frame) (length : xs.length = boundary) : + (xs ++ ys).take boundary = xs := by + have count := congrArg (fun n => (xs ++ ys).take n) length + exact count.symm.trans List.take_left + change List.take boundary (a.1.val.frames ++ WHIRHistoryKey.canonicalFrames + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) a.2.messages) = + List.take boundary (b.1.val.frames ++ WHIRHistoryKey.canonicalFrames + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) b.2.messages) at prefixes + rw [takePrefix _ _ a.1.property,takePrefix _ _ b.1.property] at prefixes + have records : FramedHistory.mk a.1.val.domain a.1.val.statement a.1.val.frames = + FramedHistory.mk b.1.val.domain b.1.val.statement b.1.val.frames := by + rw [domains,statements,prefixes] + exact records + +/-- Caller prefix data may be chosen adaptively; it is not a single reserved +prefix. Different admitted entries cannot share the same first raw source key. -/ +theorem firstKey_injective : + Function.Injective (firstKey (p := p) (Q := Q) (iv := iv) (boundary := boundary)) := by + intro a b same + have entrySame : a.1 = b.1 := Subtype.ext (entry_eq_of_firstKey_eq a b same) + cases a with + | mk ae ap => + cases b with + | mk be bp => + cases entrySame + have packetSame : ap = bp := CanonicalPacket.firstKey_injective same + cases packetSame + rfl + +noncomputable instance : Fintype (EnteredPacket p Q iv boundary) := by + classical + letI := rawKeyFintype Q + exact Fintype.ofInjective firstKey firstKey_injective + +end EnteredPacket +#print axioms EnteredPacket.entry_eq_of_firstKey_eq +#print axioms EnteredPacket.firstKey_injective +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleErasure.lean b/verification/whir/Whir/PCSBCSChallengeOracleErasure.lean new file mode 100644 index 000000000..3d5edc778 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleErasure.lean @@ -0,0 +1,135 @@ +import Whir.PCSBCSChallengeOracleCanonical + +/-! Strict source ancestors and erased-key ghost metadata. Predecessor packets +are constructed from the literal Pending-history suffix, with admission and path +bounds proved. Reading the OTHER virtual-table fibers reconstructs their Raw +values without consulting the selected packet. These are denotational ghost +functions, not an executable recovery oracle or ancestor-warming operation. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling + +namespace CanonicalPacket +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {entry : FramedHistory} + +abbrev Earlier (current : CanonicalPacket p Q iv entry) := + {q : CausalProbability.Coordinate (ParameterBounds.config p) // position q < position current.coord} + +def prefixMessages (current : CanonicalPacket p Q iv entry) (r : current.Earlier) : List Pending := + current.messages.drop (position current.coord-position r.val) + +theorem messages_length (current : CanonicalPacket p Q iv entry) : + current.messages.length = position current.coord+1 := by + have positive := List.length_pos_iff.mpr current.2.nonempty + change 0 < current.messages.length at positive + have slot := current.2.position_eq + change current.messages.length-1 = position current.coord at slot + omega + +theorem prefixMessages_length (current : CanonicalPacket p Q iv entry) (r : current.Earlier) : + (current.prefixMessages r).length = position r.val+1 := by + simp only [prefixMessages, List.length_drop, current.messages_length] + have earlier := r.property + omega + +theorem prefixMessages_nonempty (current : CanonicalPacket p Q iv entry) (r : current.Earlier) : + current.prefixMessages r ≠ [] := by + apply List.length_pos_iff.mp + rw [current.prefixMessages_length] + omega + +/-- Every strict chronological ancestor is itself an admitted canonical packet +within the SAME aggregate path cap, not an assumed reconstruction certificate. -/ +def predecessor (current : CanonicalPacket p Q iv entry) (r : current.Earlier) : + CanonicalPacket p Q iv entry := + ⟨r.val, + { messages := current.prefixMessages r + nonempty := current.prefixMessages_nonempty r + admitted := scheduledAdmissible_drop _ current.messages _ current.2.admitted + entryValid := current.2.entryValid + position_eq := by rw [current.prefixMessages_length]; omega + pathBound := by + intro block + have bound := WHIRCallerPrefix.pathCostFrom_drop (ParameterBounds.config p) + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + (WHIRHistoryKey.stackWidth_positive p) entry current.messages + (position current.coord-position r.val) block.val current.firstBlock.val + current.2.nonempty (current.prefixMessages_nonempty r) current.2.admitted + exact bound.trans (current.2.pathBound current.firstBlock) }⟩ + +theorem predecessor_ne_current (current : CanonicalPacket p Q iv entry) (r : current.Earlier) : + current.predecessor r ≠ current := by + intro same + have slots := congrArg (fun a : CanonicalPacket p Q iv entry => position a.coord) same + change position r.val = position current.coord at slots + have earlier := r.property + omega + +/-- Exact distinctness of EVERY ancestor continuation key from EVERY selected +continuation key, rather than only distinctness of abstract coordinate labels. -/ +theorem predecessor_block_key_ne (current : CanonicalPacket p Q iv entry) (r : current.Earlier) + (past : Fin (blocks (rawWidth r.val))) (now : Fin (blocks (rawWidth current.coord))) : + (current.predecessor r).2.key past ≠ current.2.key now := by + intro same + have histories := SourcePacket.distinct_history_keys + (current.predecessor r).2 current.2 past now same + have packetsSame : current.predecessor r = current := messages_injective histories.1 + exact current.predecessor_ne_current r packetsSame + +abbrev OtherValues (current : CanonicalPacket p Q iv entry) := + (k : {k : (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Key // k ≠ .inl current}) → + (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Answer (D := Digest32) k.val + +/-- Pure ghost reconstruction from erased-table fibers. No allocation, oracle +request or source-visible read is inserted in the Atomic.program interpreter. -/ +def prefixRawFromOther (current : CanonicalPacket p Q iv entry) (other : current.OtherValues) + (r : current.Earlier) : Raw r.val := + grouped r.val (other ⟨.inl (current.predecessor r), by + intro same + exact current.predecessor_ne_current r (Sum.inl.inj same)⟩) + +theorem prefixRaw_reconstructed (current : CanonicalPacket p Q iv entry) + (table : (k : (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Key) → + (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Answer (D := Digest32) k) + (r : current.Earlier) : + current.prefixRawFromOther (fun k => table k.val) r = + grouped r.val (table (.inl (current.predecessor r))) := rfl + +/-- The caller supplies its checked strict-prefix builder (e.g. incomingTrace). +All prover frames and the immutable statement/root are fixed in `current`; +additional public/Merkle ghost metadata can be computed from `other` as well. -/ +def metadataFromOther {M : Type*} (current : CanonicalPacket p Q iv entry) + (build : current.OtherValues → (∀ r : current.Earlier, Raw r.val) → M) + (other : current.OtherValues) : M := build other (current.prefixRawFromOther other) + +def metadataFromTable {M : Type*} (current : CanonicalPacket p Q iv entry) + (build : current.OtherValues → (∀ r : current.Earlier, Raw r.val) → M) + (table : (k : (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Key) → + (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Answer (D := Digest32) k) : M := + current.metadataFromOther build (fun k => table k.val) + +open Classical in +/-- Current-fiber erasure invariance of reconstructed metadata, even if the +builder inspects arbitrary other-table public/Merkle data. This theorem changes +only the virtual table's selected full packet, never prover input or raw keys. -/ +theorem metadata_update_current {M : Type*} (current : CanonicalPacket p Q iv entry) + (build : current.OtherValues → (∀ r : current.Earlier, Raw r.val) → M) + (table : (k : (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Key) → + (partition (p := p) (Q := Q) (iv := iv) (entry := entry)).Answer (D := Digest32) k) + (full : Fin (blocks (rawWidth current.coord)) → Digest32) : + current.metadataFromTable build (Function.update table (.inl current) full) = + current.metadataFromTable build table := by + unfold metadataFromTable + apply congrArg (current.metadataFromOther build) + funext k + simp [k.property] + +end CanonicalPacket + +#print axioms CanonicalPacket.predecessor +#print axioms CanonicalPacket.predecessor_block_key_ne +#print axioms CanonicalPacket.prefixRaw_reconstructed +#print axioms CanonicalPacket.metadata_update_current +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleGames.lean b/verification/whir/Whir/PCSBCSChallengeOracleGames.lean new file mode 100644 index 000000000..f2792a3f2 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleGames.lean @@ -0,0 +1,104 @@ +import Whir.PCSBCSChallengeOraclePackets +import Whir.PCSBCSChallengeOracleCanonical + +/-! Whole-public-view transport to the first-disclosure challenge experiment. +This is the actual #552 history-RO adapter. It does not assert book hash-chain +compiler equality, a concrete hash assumption, or whole-system lambda security. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle +open Concrete FiatShamirGame DuplexModeGame TypedOracleCompiler RawOracleCoupling + +private theorem average_product {X Y : Type} [Fintype X] [Fintype Y] (f : X × Y → ℚ) : + average f = average (fun x => average (fun y => f (x,y))) := by + classical + simp only [average,Fintype.sum_prod_type,Finset.sum_div,Fintype.card_prod,Nat.cast_mul,div_div] + simp only [mul_comm] + +open Classical in +noncomputable def atomicIdealProbability {Packet : Type} [Fintype Packet] [DecidableEq Packet] + {Block : Packet → Type} [∀ p, Fintype (Block p)] {Q : Nat} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + {AdvCoins R : Type} [Fintype AdvCoins] (iv : Digest32) + (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) + (D : View R → Bool) : ℚ := + letI : DecidableEq (PublicCompressionCouplingMixed.Key Q) := Classical.decEq _ + average (fun a => Sampling.expectation (fun result => if D result.1 then (1:ℚ) else 0) + (RawOracleCoupling.memo + (Atomic.program part (PublicCompressionCouplingMixed.compile Q iv [] (adversary a) + Q (by rfl) (counted a))) (fun _ => none))) + +open Classical in +/-- Equality for EVERY whole-view observer, including all public Merkle and +chosen-CV observations. A uniform full packet is allocated at its first +physical or simulator query; later projections do not introduce fresh coins. -/ +theorem atomic_ideal_probability_eq {Packet : Type} [Fintype Packet] [DecidableEq Packet] + {Block : Packet → Type} [∀ p, Fintype (Block p)] {Q : Nat} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + {AdvCoins R : Type} [Fintype AdvCoins] (iv : Digest32) + (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) + (D : View R → Bool) : + letI := DuplexPublicSimulator.seedFintype + atomicIdealProbability part iv adversary counted D = + idealProbability (DuplexPublicSimulator.simulator Q) iv adversary counted D := by + let : DecidableEq (PublicCompressionCouplingMixed.Key Q) := Classical.decEq _ + let := DuplexPublicSimulator.seedFintype + let := rawOracleFintype Q + let := PublicCompressionCouplingMixed.mixedKeyFintype Q + unfold atomicIdealProbability + have marginal (a : AdvCoins) := actual_ideal_eq_atomic_packets part iv + (adversary a) (counted a) (fun view => if D view then (1:ℚ) else 0) + simp_rw [← marginal] + rw [average_comm] + rw [← average_product + (fun coins : (PublicCompressionCouplingMixed.Key Q → Digest32) × AdvCoins => + if D (runIdeal (DuplexPublicSimulator.simulator Q) (fun k => coins.1 (.inr k)) + iv ⟨(fun n => coins.1 (.inl n)),[]⟩ (adversary coins.2) Q (by rfl) (counted coins.2)).view + then (1:ℚ) else 0)] + let e : (PublicCompressionCouplingMixed.Key Q → Digest32) × AdvCoins ≃ + (RawKey Q → Digest32) × DuplexPublicSimulator.Seed × AdvCoins := + (Equiv.prodCongr ((PublicCompressionCouplingMixed.tableEquiv Q).trans + (Equiv.prodComm DuplexPublicSimulator.Seed (RawKey Q → Digest32))) (Equiv.refl AdvCoins)).trans + (Equiv.prodAssoc (RawKey Q → Digest32) DuplexPublicSimulator.Seed AdvCoins) + have equality := RawOracleCoupling.average_equiv e + (fun coins : (RawKey Q → Digest32) × DuplexPublicSimulator.Seed × AdvCoins => + if D (runIdeal (DuplexPublicSimulator.simulator Q) coins.1 iv + ((DuplexPublicSimulator.simulator Q).initial coins.2.1) (adversary coins.2.2) + Q (by rfl) (counted coins.2.2)).view then (1:ℚ) else 0) + unfold idealProbability + rw [distinguish_average (inferInstance : Fintype + ((RawKey Q → Digest32) × DuplexPublicSimulator.Seed × AdvCoins))] + exact equality + +open Classical in +/-- Exact aggregate-Q source-to-atomic challenge game bound. Only the proven +256-bit mode loss is used here. A separate 192-bit hash-chain collision term is +NOT silently added, since no book hash-chain/source correspondence is asserted. -/ +theorem actual_source_atomic_game_bound {Packet : Type} [Fintype Packet] [DecidableEq Packet] + {Block : Packet → Type} [∀ p, Fintype (Block p)] {Q : Nat} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + {AdvCoins R : Type} [Fintype AdvCoins] (iv : Digest32) + (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) + (D : View R → Bool) : + |realProbability iv adversary D - atomicIdealProbability part iv adversary counted D| ≤ + duplexModeLoss Q := by + let := DuplexPublicSimulator.seedFintype + rw [atomic_ideal_probability_eq] + exact PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss Q iv adversary counted D + +open Classical in +/-- The complete, literal source domain instantiates the game theorem without +an arbitrary packet-family completeness or equal-distribution premise. -/ +theorem canonical_source_atomic_game_bound {AdvCoins R : Type} [Fintype AdvCoins] + (profile : ParameterBounds.Profile) (Qcompression : Nat) (iv : Digest32) + (entry : FramedHistory) (adversary : AdvCoins → Program R) + (counted : ∀ a, Counts Qcompression (adversary a)) (D : View R → Bool) : + |realProbability iv adversary D - + atomicIdealProbability + (CanonicalPacket.partition (p := profile) (Q := Qcompression) (iv := iv) (entry := entry)) + iv adversary counted D| ≤ duplexModeLoss Qcompression := + actual_source_atomic_game_bound _ iv adversary counted D + +#print axioms atomic_ideal_probability_eq +#print axioms actual_source_atomic_game_bound +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOraclePackets.lean b/verification/whir/Whir/PCSBCSChallengeOraclePackets.lean new file mode 100644 index 000000000..e8a7da588 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOraclePackets.lean @@ -0,0 +1,247 @@ +import Whir.PCSBCSChallengeOracleSource + +/-! Atomic virtual-packet sampling on FIRST physical disclosure. All later +projections are cache hits, even after partial disclosure, abort or restoration. +Off-image observer and simulator RO requests remain ordinary memoized requests. +No ancestor warming multiplies the aggregate physical query cap. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle +open Concrete FiatShamirGame TypedOracleCompiler RawOracleCoupling + +/-- Finite restriction of the literal key encoder. No raw keys are dropped: +keys not recognized as packet blocks occupy the garbage summand. -/ +noncomputable def partitionOfInjection {Raw Packet : Type} {Block : Packet → Type} + (encode : Sigma Block → Raw) (injective : Function.Injective encode) : + Partition Raw Packet Block := by + classical + exact + { encode := encode + recognize := fun raw => if h : ∃ b, encode b = raw then some (Classical.choose h) else none + recognize_encode := by + intro b + have hasPreimage : ∃ b', encode b' = encode b := ⟨b,rfl⟩ + rw [dite_eq_left hasPreimage] + apply congrArg some + exact injective (Classical.choose_spec (show ∃ b', encode b' = encode b from ⟨b,rfl⟩)) + encode_recognize := by + intro raw b same + split at same + · rename_i h + have eq := Option.some.inj same + rw [← eq] + exact Classical.choose_spec h + · contradiction } + +namespace Atomic +variable {Raw Packet : Type} {Block : Packet → Type} + (part : Partition Raw Packet Block) + +/-- Sampling the complete virtual packet is PRIVATE; the continuation receives +only the one requested 256-bit physical block, including its otherwise unused +bytes. A replay never re-enters this draw in the memoized interpreter. -/ +def request (raw : Raw) : Sampling part.Key (part.Answer (D := Digest32)) Digest32 1 := + match h : part.recognize raw with + | some b => .draw (.inl b.1) (fun full => .ret (full b.2)) + | none => .draw (.inr ⟨raw,h⟩) (fun answer => .ret answer) + +theorem eval_request (table : (k : part.Key) → part.Answer (D := Digest32) k) (raw : Raw) : + Sampling.eval table (request part raw) = part.join table raw := by + unfold request Partition.join + split + · rename_i b hit + simp only [Sampling.eval] + split + · rename_i b' hit' + have same := Option.some.inj (hit.symm.trans hit') + cases same + rfl + · rename_i missed + have impossible := hit.symm.trans missed + cases impossible + · rename_i missed + simp only [Sampling.eval] + split + · rename_i b hit + have impossible := missed.symm.trans hit + cases impossible + · rfl + +def program {R : Type} {n : Nat} : Sampling Raw (fun _ => Digest32) R n → + Sampling part.Key (part.Answer (D := Digest32)) R n + | .ret r => .ret r + | .draw raw next => Sampling.pad (by omega) + (Sampling.bind (request part raw) (fun answer => program (next answer))) + +theorem eval_program {R : Type} {n : Nat} + (table : (k : part.Key) → part.Answer (D := Digest32) k) + (p : Sampling Raw (fun _ => Digest32) R n) : + Sampling.eval table (program part p) = Sampling.eval (part.join table) p := by + induction p with + | ret r => rfl + | draw raw next ih => simp [program, eval_request, Sampling.eval, ih] + +open Classical in +/-- Exact game mapping for every adaptive program and payoff. The same outer +cache memoizes whole packets and arbitrary off-image observer requests. -/ +theorem table_eq_atomic_packets [Fintype Raw] [Fintype Packet] + [∀ p, Fintype (Block p)] [DecidableEq Packet] + {R : Type} {n : Nat} (p : Sampling Raw (fun _ => Digest32) R n) (payoff : R → ℚ) : + average (fun table : Raw → Digest32 => payoff (Sampling.eval table p)) = + Sampling.expectation (fun result => payoff result.1) + (RawOracleCoupling.memo (program part p) (fun _ => none)) := by + classical + rw [← RawOracleCoupling.empty_table_eq_memo] + simp only [eval_program] + have h := RawOracleCoupling.average_equiv part.tableEquiv + (fun table => payoff (Sampling.eval (part.join table) p)) + simpa only [Partition.tableEquiv, Equiv.coe_fn_mk, Partition.join_split] using h + +/-- Actual number of new virtual packets is at most the aggregate physical RO +request cap n. Sampling an entire packet does not charge a per-round n again. -/ +theorem allocation_cap [DecidableEq Packet] [DecidableEq Raw] + {R : Type} {n : Nat} (p : Sampling Raw (fun _ => Digest32) R n) + {trace : List (Sigma (part.Answer (D := Digest32)))} {result : R × _} + (run : Sampling.Runs (RawOracleCoupling.memo (program part p) (fun _ => none)) trace result) : + trace.length ≤ n := run.length_le + +end Atomic + +/-- A finite family of actual source packets gives the literal injective encoder +required above. Distinct packet identifiers must name distinct prover histories; +this is an identity-of-keys condition, not an entropy or small-loss assumption. -/ +theorem source_family_encode_injective {P : Type} {p : ParameterBounds.Profile} + {Q : Nat} {iv : Digest32} {entry : FramedHistory} + (coord : P → CausalProbability.Coordinate (ParameterBounds.config p)) + (packets : ∀ a, SourcePacket p Q iv entry (coord a)) + (unique : Function.Injective (fun a => (packets a).messages)) : + Function.Injective (fun b : Sigma (fun a => Fin (blocks (PCSBCSRounds.rawWidth (coord a)))) => + (packets b.1).key b.2) := by + intro a b same + have facts := SourcePacket.distinct_history_keys (packets a.1) (packets b.1) a.2 b.2 same + have identity := unique facts.1 + cases a with + | mk a i => + cases b with + | mk b j => + dsimp only at identity + subst b + exact congrArg (Sigma.mk a) (Fin.ext facts.2) + +noncomputable def sourceFamilyPartition {P : Type} {p : ParameterBounds.Profile} + {Q : Nat} {iv : Digest32} {entry : FramedHistory} + (coord : P → CausalProbability.Coordinate (ParameterBounds.config p)) + (packets : ∀ a, SourcePacket p Q iv entry (coord a)) + (unique : Function.Injective (fun a => (packets a).messages)) : + Partition (PublicCompressionCouplingMixed.Key Q) P + (fun a => Fin (blocks (PCSBCSRounds.rawWidth (coord a)))) := + partitionOfInjection + (fun b => .inr ((packets b.1).key b.2)) + (fun _ _ same => source_family_encode_injective coord packets unique (Sum.inr.inj same)) + +open Classical in +/-- Conditional first-disclosure kernel, with the ENTIRE past represented by +an arbitrary fixed shared cache. All continuation branches (including early +abort) receive projections only after the full packet has been allocated. -/ +theorem first_disclosure_kernel {Packet : Type} [DecidableEq Packet] + {Raw : Type} [DecidableEq Raw] {Block : Packet → Type} + [∀ p, Fintype (Block p)] (part : Partition Raw Packet Block) + {R : Type} {n : Nat} (packet : Packet) + (cache : TypedFiatShamirGame.Cache part.Key (part.Answer (D := Digest32))) + (fresh : cache (.inl packet) = none) + (next : (Block packet → Digest32) → Sampling part.Key (part.Answer (D := Digest32)) R n) + (payoff : R × TypedFiatShamirGame.Cache part.Key (part.Answer (D := Digest32)) → ℚ) : + Sampling.expectation payoff (RawOracleCoupling.memo (.draw (.inl packet) next) cache) = + average (fun full : Block packet → Digest32 => + Sampling.expectation payoff (RawOracleCoupling.memo (next full) + (TypedFiatShamirGame.put cache (.inl packet) full))) := by + classical + simp only [RawOracleCoupling.memo, fresh, Sampling.expectation] + +private theorem average_fintype {A : Type} (old new : Fintype A) (f : A → ℚ) : + @average A old f = @average A new f := by + cases Subsingleton.elim old new + rfl + +open Classical in +private theorem average_indicator_cast {A : Type} [Fintype A] (P : A → Prop) : + ((average (fun a : A => if P a then (1:ℚ) else 0)) : ℝ) = + SamplingProbability.probability P := by + simp [average, SamplingProbability.probability, Finset.sum_boole, Fintype.card_subtype] + +open Classical in +/-- Exact conditional uniform Raw distribution on the first disclosure of an +atomic source packet. A partially disclosed packet is already a cache hit and +is therefore ineligible for this theorem. The fixed cache may encode any past +public/primitive/Merkle observations and any earlier restored computations. -/ +theorem first_disclosure_grouped_uniform {Packet : Type} [DecidableEq Packet] + {RawKey : Type} [DecidableEq RawKey] {c : Protocol.Config} + (coord : Packet → CausalProbability.Coordinate c) + (part : Partition RawKey Packet (fun a => Fin (blocks (PCSBCSRounds.rawWidth (coord a))))) + (packet : Packet) + (cache : TypedFiatShamirGame.Cache part.Key (part.Answer (D := Digest32))) + (fresh : cache (.inl packet) = none) (P : PCSBCSRounds.Raw (coord packet) → Prop) : + ((Sampling.expectation + (fun result : PCSBCSRounds.Raw (coord packet) × + TypedFiatShamirGame.Cache part.Key (part.Answer (D := Digest32)) => + if P result.1 then (1:ℚ) else 0) + (RawOracleCoupling.memo + (.draw (.inl packet) (fun full => .ret (n := 0) (grouped (coord packet) full))) cache)) : ℝ) = + SamplingProbability.probability P := by + simp only [RawOracleCoupling.memo, fresh, Sampling.expectation] + rw [average_fintype _ (inferInstance : Fintype (Fin + (blocks (PCSBCSRounds.rawWidth (coord packet))) → Digest32)) + (fun full => if P (grouped (coord packet) full) then (1:ℚ) else 0)] + rw [average_indicator_cast, grouped_uniform] + +open Classical in +/-- Pointwise lowering of the actual pinned ideal simulator and all its public +requests to the atomic challenge experiment. The finite mixed table contains +both independent simulator fallback seed answers and literal source RO answers. +The existing compiler charges at most Q draws under the SAME Counts Q cap. -/ +theorem actual_ideal_eq_atomic_packets {Packet : Type} [Fintype Packet] [DecidableEq Packet] + {Block : Packet → Type} [∀ p, Fintype (Block p)] {Q : Nat} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + {R : Type} (iv : Digest32) (p : DuplexModeGame.Program R) + (counted : DuplexModeGame.Counts Q p) (payoff : DuplexModeGame.View R → ℚ) : + letI : DecidableEq (PublicCompressionCouplingMixed.Key Q) := Classical.decEq _ + letI := PublicCompressionCouplingMixed.mixedKeyFintype Q + average (fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + payoff (DuplexModeGame.runIdeal (DuplexPublicSimulator.simulator Q) + (fun k => table (.inr k)) iv + ⟨(fun n => table (.inl n)),[]⟩ p Q (by rfl) counted).view) = + Sampling.expectation (fun result => payoff result.1) + (RawOracleCoupling.memo + (Atomic.program part (PublicCompressionCouplingMixed.compile Q iv [] p Q (by rfl) counted)) + (fun _ => none)) := by + classical + let : DecidableEq (PublicCompressionCouplingMixed.Key Q) := Classical.decEq _ + let := PublicCompressionCouplingMixed.mixedKeyFintype Q + have pointwise (table : PublicCompressionCouplingMixed.Key Q → Digest32) := + PublicCompressionCouplingMixed.compile_actual Q (fun n => table (.inl n)) + (fun k => table (.inr k)) iv [] p Q (by rfl) counted + have oracle_identity (table : PublicCompressionCouplingMixed.Key Q → Digest32) : + PublicCompressionCouplingMixed.oracle (fun n => table (.inl n)) (fun k => table (.inr k)) = + table := by funext k; cases k <;> rfl + simp only [oracle_identity] at pointwise + simp_rw [← pointwise] + exact Atomic.table_eq_atomic_packets part _ payoff + +open Classical in +theorem actual_ideal_allocation_cap {Packet : Type} [DecidableEq Packet] + {Block : Packet → Type} {Q : Nat} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + {R : Type} (iv : Digest32) (p : DuplexModeGame.Program R) + (counted : DuplexModeGame.Counts Q p) {trace result} + (execution : Sampling.Runs + (RawOracleCoupling.memo + (Atomic.program part (PublicCompressionCouplingMixed.compile Q iv [] p Q (by rfl) counted)) + (fun _ => none)) trace result) : trace.length ≤ Q := execution.length_le + +#print axioms first_disclosure_grouped_uniform +#print axioms actual_ideal_eq_atomic_packets +#print axioms actual_ideal_allocation_cap +#print axioms Atomic.table_eq_atomic_packets +#print axioms Atomic.allocation_cap +#print axioms source_family_encode_injective +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean b/verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean new file mode 100644 index 000000000..8efef16c5 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean @@ -0,0 +1,91 @@ +import Whir.PCSBCSChallengeOracleEnteredErasure +import Whir.PCSBCSCallerBinding +import Whir.PCSStateRestorationLatent + +/-! Concrete additive-RBR transition fibers for the literal duplex's whole +source packets, including every data-valued live caller entry at the public +boundary. Ghost reconstruction reads only other packet fibers and strict +predecessors; arbitrary off-image observer requests remain in the same game. +A source parser must still justify the metadata builder and accepted path. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSChallengeOracle.Restoration +open Concrete Protocol CausalGame CausalProbability PCSBCSRounds +open FiatShamirGame RawOracleCoupling +open PCSBCSChallengeOracle PCSBCSCallerBinding PCSBCSRestorationHazard +attribute [local irreducible] PCSBCSCallerBinding.callerCertificate + PCSBCSCallerBinding.fixedCertificate EnteredPacket.metadataFromOther + +variable (p : ParameterBounds.Profile) (Q : Nat) (iv : Digest32) (boundary : Nat) + +abbrev Key := (EnteredPacket.partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Key +abbrev Answer := (EnteredPacket.partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Answer + (D := Digest32) + +noncomputable local instance (key : Key p Q iv boundary) : Fintype (Answer p Q iv boundary key) := + match key with + | .inl _ => inferInstance + | .inr _ => inferInstance + +abbrev Builder := (current : EnteredPacket p Q iv boundary) → + current.OtherValues → (∀ earlier : current.Earlier, Raw earlier.val) → CallerData p + +open Classical in +noncomputable def model (build : Builder p Q iv boundary) : + PCSStateRestoration.Latent.NodeModel (Key p Q iv boundary) (Answer p Q iv boundary) + (Option (CallerData p)) where + reconstruct key other := match key with + | .inl current => some (current.metadataFromOther (build current) other) + | .inr _ => none + before data key := match key, data with + | .inl current, some caller => (callerCertificate p).before caller current.2.coord + | _, _ => false + after data key answer := match key with + | .inl current => match data with + | some caller => (callerCertificate p).after caller current.2.coord (grouped current.2.coord answer) + | none => false + | .inr _ => false + +/-- Whole output blocks induce exactly the checked RBR alphabet. The incoming +state is fixed before every bit of the selected packet, including unused bits. -/ +theorem whole_packet_fiber (caller : CallerData p) (current : EnteredPacket p Q iv boundary) + (undoomed : (callerCertificate p).before caller current.2.coord = false) : + Soundness.uniformProb (Finset.univ.filter fun full : + Fin (blocks (rawWidth current.2.coord)) → Digest32 => + (callerCertificate p).after caller current.2.coord (grouped current.2.coord full) = true) ≤ + PCSRoundByRoundKnowledge.rbrError := by + classical + have law := grouped_uniform current.2.coord (fun answer => + (callerCertificate p).after caller current.2.coord answer = true) + rw [SamplingProbability.probability_eq_uniformProb, + SamplingProbability.probability_eq_uniformProb] at law + have exactLaw := (Rat.cast_inj (α := ℝ)).mp law + exact exactLaw.trans_le (caller_fiber p caller current.2.coord undoomed) + +/-- Derived from the actual grouped alphabet and additive RBR fiber, not an +assumed primitive or final failure-probability bound. -/ +theorem conditional_hazard (build : Builder p Q iv boundary) : + PCSStateRestoration.Latent.ConditionalHazard (model p Q iv boundary build) + PCSRoundByRoundKnowledge.rbrError := by + classical + intro key other undoomed + cases key with + | inl current => + change (callerCertificate p).before + (current.metadataFromOther (build current) other) current.2.coord = false at undoomed + have bound := whole_packet_fiber p Q iv boundary + (current.metadataFromOther (build current) other) current undoomed + unfold Soundness.uniformProb at bound ⊢ + simp only [model,Fintype.card_eq_nat_card] at bound ⊢ + convert bound using 1 + congr 2 + | inr garbage => + simp only [model,Bool.false_eq_true,Finset.filter_false,Soundness.uniformProb, + Finset.card_empty,Nat.cast_zero,zero_div] + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + +#print axioms whole_packet_fiber +#print axioms conditional_hazard +end Whir.PCSBCSChallengeOracle.Restoration diff --git a/verification/whir/Whir/PCSBCSChallengeOracleSource.lean b/verification/whir/Whir/PCSBCSChallengeOracleSource.lean new file mode 100644 index 000000000..9814f3ed8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleSource.lean @@ -0,0 +1,161 @@ +import Whir.PCSBCSChallengeOracle +import Whir.WHIRCallerOutputs + +/-! Actual #552/source12ee modeled source-history adapter, not the book's +challenge hash chain or a historical Rust-byte identity. Literal prior +caller/anchor frames and the current Pending prover string select every +continuation block. Merkle and arbitrary chosen-CV requests remain in the public +compression Program and the aggregate Counts ledger. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame TypedOracleCompiler DuplexRefinement DuplexFraming + +/-- The explicit source/model interface fixes the actual live entry and admitted +prover strings. It does not assume random source bytes or a hash-chain compiler. -/ +structure SourcePacket (p : ParameterBounds.Profile) (Q : Nat) + (iv : Digest32) (entry : FramedHistory) (q : CausalProbability.Coordinate (ParameterBounds.config p)) where + messages : List Pending + nonempty : messages ≠ [] + admitted : scheduledAdmissible (ParameterBounds.config p) messages = true + entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f + position_eq : messages.length-1 = position q + pathBound : ∀ block : Fin (blocks (rawWidth q)), pathCost + (WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + entry messages block.val) ≤ Q + +namespace SourcePacket +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + +theorem width_eq (s : SourcePacket p Q iv entry q) : + WHIRHistoryKey.stackWidth (ParameterBounds.config p) (s.messages.length-1) = 24*rawWidth q := by + unfold WHIRHistoryKey.stackWidth + rw [s.position_eq, schedule_get_position] + rfl + +def coordinate (s : SourcePacket p Q iv entry q) (block : Fin (blocks (rawWidth q))) : + FiatShamirGame.Coordinate := WHIRCallerPrefix.outputKeyFrom + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) entry s.messages block.val + +theorem valid (s : SourcePacket p Q iv entry q) (block : Fin (blocks (rawWidth q))) : + DuplexEncoding.Admissible (s.coordinate block) := by + apply WHIRCallerPrefix.production_stackOutputKeyFrom_admissible p entry s.entryValid + s.messages block.val s.nonempty s.admitted + simpa only [s.width_eq, blocks] using block.isLt + +def key (s : SourcePacket p Q iv entry q) (block : Fin (blocks (rawWidth q))) : RawKey Q := + constructionKey Q iv (s.coordinate block) (s.pathBound block) + +theorem key_injective (s : SourcePacket p Q iv entry q) : Function.Injective s.key := by + intro a b same + have coordinates := constructionKey_injective Q iv (s.valid a) (s.valid b) + (s.pathBound a) (s.pathBound b) same + have terminal := congrArg FiatShamirGame.Coordinate.terminal coordinates + exact Fin.ext (Terminal.output.inj terminal) + +/-- This is the challenge model itself: a finite programmable raw RO keyed by +the literal #552 message/template encoding. No compressed challenge-chain state +replaces the source history. -/ +def sample (s : SourcePacket p Q iv entry q) (ro : RawKey Q → Digest32) : Raw q := + grouped q (fun b => ro (s.key b)) + +/-- Operative physical byte mapping, including scalar slices that cross output +blocks. Represents and the successful guarded squeeze are the existing actual +source-machine preconditions; no fresh-entropy or hash-chain premise is used. -/ +theorem physical_packet_bytes (s : SourcePacket p Q iv entry q) + (compress : Compression) (before after : State) (bytes : List Byte) + (represents : Represents compress iv + (WHIRCallerPrefix.beforeModelFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + entry s.messages) before) + (squeezed : squeeze compress before (rawWidth q*24) = .ok (after,bytes)) : + bytes = List.ofFn (vectorBytes (rawWidth q) (rawVector q + (grouped q (fun b => evalCoordinate compress iv (s.coordinate b))))) := by + rw [WHIRCallerPrefix.squeeze_frame_bytes_from compress iv _ + (WHIRHistoryKey.stackWidth_positive p) entry + (WHIRHistoryKey.scheduled_normal _ _ s.nonempty s.admitted) before after + represents _ bytes squeezed, WHIRCallerOutputs.stream_ofFn] + apply congrArg List.ofFn + funext i + rw [grouped_payload_bytes] + simp only [Nat.zero_add, evalCoordinate, coordinate, WHIRCallerPrefix.outputKeyFrom, evalTerminal] + +open Classical in +/-- Full-E conditional law includes initial eight-E, query vector and lambda, +and every individual fold/OOD/tail coordinate, by the dependent Raw alphabet. -/ +theorem fresh_uniform_independent (s : SourcePacket p Q iv entry q) + (cache : RawKey Q → Option Digest32) (fresh : ∀ b, cache (s.key b) = none) + (P : Raw q → Prop) (observer : ({k : RawKey Q // k ∉ Set.range s.key} → Digest32) → Prop) : + letI : DecidableEq (RawKey Q) := Classical.decEq _ + letI := rawKeyFintype Q + SamplingProbability.probability (fun ro : RawKey Q → Digest32 => + P (s.sample (RawOracleCoupling.overlay cache ro)) ∧ + observer (restrictionEquiv s.key s.key_injective ro).2) = + SamplingProbability.probability P * SamplingProbability.probability observer := by + let : DecidableEq (RawKey Q) := Classical.decEq _ + let := rawKeyFintype Q + exact @fresh_group_independent (RawKey Q) (rawKeyFintype Q) (ParameterBounds.config p) + q s.key s.key_injective cache fresh P observer + +/-- Literal histories, including the current message and continuation index, +are injective across all admitted source-round packets at the same entry. -/ +theorem distinct_history_keys {q' : CausalProbability.Coordinate (ParameterBounds.config p)} + (s : SourcePacket p Q iv entry q) (t : SourcePacket p Q iv entry q') + (a : Fin (blocks (rawWidth q))) (b : Fin (blocks (rawWidth q'))) + (same : s.key a = t.key b) : s.messages = t.messages ∧ a.val = b.val := by + have coordinates := constructionKey_injective Q iv (s.valid a) (t.valid b) + (s.pathBound a) (t.pathBound b) same + exact WHIRCallerPrefix.outputKeyFrom_injective _ _ + (WHIRHistoryKey.stackWidth_positive p) (WHIRHistoryKey.stackWidth_positive p) entry + (WHIRHistoryKey.scheduled_normal _ _ s.nonempty s.admitted) + (WHIRHistoryKey.scheduled_normal _ _ t.nonempty t.admitted) _ _ coordinates + +/-- One block is exactly the ideal construction answer, while all public +primitive (including Merkle-domain) requests still use the simulator. -/ +theorem ideal_block (s : SourcePacket p Q iv entry q) + {Seed State R : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (state : State) (b : Fin (blocks (rawWidth q))) + (next : Digest32 → Program R) + (counted : Counts Q (.ask (.construction (s.coordinate b) (s.valid b)) next)) : + (runIdeal sim ro iv state (.ask (.construction (s.coordinate b) (s.valid b)) next) + Q (by rfl) counted).view.observations.head? = + some ⟨.construction (s.coordinate b) (s.valid b), ro (s.key b)⟩ := by + rfl + +end SourcePacket + +/-- All observers of any decoded challenge/protocol/public-primitive view are +covered. Counts charges uncached construction paths, repeats, nonce terminals, +continuation blocks, and direct Merkle calls in one Q; it is not just a count of +PCS coordinates. This transports to the actual literal-history RO, not to BCS. -/ +theorem literal_source_mode_bound {AdvCoins R V : Type} [Fintype AdvCoins] + (Q : Nat) (iv : Digest32) (adversary : AdvCoins → Program R) + (counted : ∀ a, Counts Q (adversary a)) (decode : View R → V) (D : V → Bool) : + letI := DuplexPublicSimulator.seedFintype + |realProbability iv adversary (fun view => D (decode view)) - + idealProbability (DuplexPublicSimulator.simulator Q) iv adversary counted + (fun view => D (decode view))| ≤ duplexModeLoss Q := + PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss Q iv adversary counted _ + +open Classical in +/-- The event mapping is the proved actual joint causal bad event, not an +assumed RO-equivalence certificate. Arbitrary decoded views coincide outside it. -/ +theorem literal_source_good_view {R V : Type} (Q : Nat) (iv : Digest32) + (p : Program R) (counted : Counts Q p) {trace} + {pair : PublicCompressionCouplingActualJoint.JointResult Q R} + (execution : Sampling.Runs (PublicCompressionCouplingActualJoint.actualJoint Q iv p counted) trace pair) + (table : PublicCompressionCouplingMixed.Key Q → Digest32) + (quiet : PublicCompressionCouplingMixed.causalBad Q iv p counted + (RawOracleCoupling.overlay pair.2.2 table) = false) + (decode : View R → V) : decode pair.1.1.view = decode pair.2.1.1 := by + exact congrArg decode (PublicCompressionCouplingSourceStream.actual_joint_good_view + Q iv p counted execution table quiet) + +#print axioms SourcePacket.physical_packet_bytes +#print axioms SourcePacket.fresh_uniform_independent +#print axioms SourcePacket.distinct_history_keys +#print axioms SourcePacket.ideal_block +#print axioms literal_source_mode_bound +#print axioms literal_source_good_view +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSFirstRootDisclosure.lean b/verification/whir/Whir/PCSBCSFirstRootDisclosure.lean new file mode 100644 index 000000000..344e82656 --- /dev/null +++ b/verification/whir/Whir/PCSBCSFirstRootDisclosure.lean @@ -0,0 +1,110 @@ +import Whir.PCSStateRestorationLatentProbability + +/-! Root-table capture occurs at the first source-key mention of its complete +shape address, before that packet answer is disclosed. Capturing at a later +commitment announcement would not justify causality against prefix prequeries. +This finder is a ghost of the unchanged operational request sequence. -/ +namespace Whir.PCSBCSFirstRootDisclosure +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent +set_option autoImplicit false + +universe u v w z +variable {Key : Type u} {Answer : Key → Type v} {Root : Type w} {R : Type z} + +section +variable [DecidableEq Key] [DecidableEq Root] + +/-- Addresses include every semantic tree/image/occupied shape field. One +source key can mention several roots; the literal parser must derive them. -/ +def firstMention (address : Key → List Root) (root : Root) : {n : Nat} → + Sampling Key Answer R n → Table Key Answer → Option (List (Sigma Answer)) + | _, .ret _, _ => none + | _, .draw key next, table => + if root ∈ address key then some [] else + (firstMention address root (next (table key)) table).map + (fun before => ⟨key,table key⟩ :: before) + +/-- The complete public prefix used to capture a referenced root is independent +of the current packet's entire answer, including undisclosed continuation bits. +No assumption about query chronology, novelty or warmed ancestors is made. -/ +theorem first_mention_answer_independent (address : Key → List Root) + (target : Key) (root : Root) (mentioned : root ∈ address target) + {n : Nat} (source : Sampling Key Answer R n) (table : Table Key Answer) + (answer : Answer target) : + firstMention address root source (Function.update table target answer) = + firstMention address root source table := by + induction source with + | ret result => rfl + | draw key next ih => + by_cases sameRoot : root ∈ address key + · simp only [firstMention,sameRoot,↓reduceIte] + · have different : key ≠ target := by + intro same + subst key + exact sameRoot mentioned + simp only [firstMention,sameRoot,↓reduceIte,Function.update_of_ne different,ih] + +/-- Any deterministic public-log extraction from that prefix inherits the same +current-answer erasure law. Its implementation must still be identified with +the actual public compression log, not a full hidden virtual-table dump. -/ +theorem captured_metadata_answer_independent {Metadata : Type*} + (address : Key → List Root) (target : Key) (root : Root) + (mentioned : root ∈ address target) {n : Nat} + (source : Sampling Key Answer R n) (capture : Option (List (Sigma Answer)) → Metadata) + (table : Table Key Answer) (answer : Answer target) : + capture (firstMention address root source (Function.update table target answer)) = + capture (firstMention address root source table) := by + rw [first_mention_answer_independent address target root mentioned source table answer] + +omit [DecidableEq Key] in +/-- Every actually requested referencing key has an earlier first capture. +This uses the adaptive operational trace, not a proposed verifier schedule. -/ +theorem first_mention_exists (address : Key → List Root) (target : Key) (root : Root) + (mentioned : root ∈ address target) {n : Nat} + (source : Sampling Key Answer R n) (table : Table Key Answer) + (visited : target ∈ ((Sampling.execute table source).2.map Sigma.fst)) : + ∃ before, firstMention address root source table = some before := by + induction source with + | ret result => simp only [Sampling.execute,List.map_nil,List.not_mem_nil] at visited + | draw key next ih => + by_cases hit : root ∈ address key + · exact ⟨[],by simp only [firstMention,hit,↓reduceIte]⟩ + · have different : key ≠ target := by + intro same + subst key + exact hit mentioned + simp only [Sampling.execute,List.map_cons,List.mem_cons] at visited + obtain ⟨before,found⟩ := ih (table key) (visited.resolve_left (Ne.symm different)) + exact ⟨⟨key,table key⟩::before,by simp only + [firstMention,hit,↓reduceIte,found,Option.map_some]⟩ + + +omit [DecidableEq Key] in +/-- The finder stores only the actual earlier query prefix, at most the +declared operational query count, even with repeated or off-image requests. -/ +theorem first_mention_length (address : Key → List Root) (root : Root) {n : Nat} + (source : Sampling Key Answer R n) (table : Table Key Answer) + (before : List (Sigma Answer)) (found : firstMention address root source table = some before) : + before.length ≤ n := by + induction source generalizing before with + | ret result => cases found + | draw key next ih => + by_cases hit : root ∈ address key + · simp only [firstMention,hit,↓reduceIte,Option.some.injEq] at found + subst before + exact Nat.zero_le _ + · simp only [firstMention,hit,↓reduceIte] at found + cases earlier : firstMention address root (next (table key)) table with + | none => simp only [earlier,Option.map_none] at found; contradiction + | some prior => + simp only [earlier,Option.map_some,Option.some.injEq] at found + subst before + exact Nat.succ_le_succ (ih (table key) prior earlier) + +end + +#print axioms first_mention_answer_independent +#print axioms captured_metadata_answer_independent +#print axioms first_mention_exists +#print axioms first_mention_length +end Whir.PCSBCSFirstRootDisclosure diff --git a/verification/whir/Whir/PCSBCSFrozenOracleRows.lean b/verification/whir/Whir/PCSBCSFrozenOracleRows.lean new file mode 100644 index 000000000..783a4376d --- /dev/null +++ b/verification/whir/Whir/PCSBCSFrozenOracleRows.lean @@ -0,0 +1,82 @@ +import Whir.PCSBCSMerkleRootCache +import Whir.CausalGame +import Whir.WHIRCallerGeometry + +/-! The semantic oracle is the frozen suffix in its original wire lane order. +Initial base rows use the existing liftRoot. Extension rows decode consecutive +three-word E images without serializing and reparsing a temporary byte array. -/ +set_option autoImplicit false +namespace Whir.PCSBCSFrozenOracleRows +open Concrete Protocol CausalGame + +/-- Malformed extension images reject rather than dropping their last limbs. -/ +def extensionRow (words : Array K) : Option (Array E) := + if words.size % 3 = 0 then + some (Array.ofFn fun i : Fin (words.size / 3) => + ⟨words[3*i.val]!,words[3*i.val+1]!,words[3*i.val+2]!⟩) + else none + +def extensionOracle (raw : Array (Array K)) : Option Oracle := + raw.mapM extensionRow + +/-- The source phase determines the representation; the proof does not choose +whether the same bytes are read as base or extension elements. -/ +def frozenOracle (phase : Nat) (frozen : PCSBCSMerkleRootCache.Frozen) : Option Oracle := + if phase = 0 then some (liftRoot frozen.raw) else extensionOracle frozen.raw + +/-- A query reply contains ONLY rows in derived-query order, not the full tree. +Checked lookup rejects out-of-range positions in the same traversal. -/ +def queryRows (oracle : Oracle) (queries : Array Nat) : Option Oracle := + queries.mapM (fun q => oracle[q]?) + +theorem queryRows_spec (oracle rows : Oracle) (queries : Array Nat) + (selected : queryRows oracle queries = some rows) : + rows.size = queries.size ∧ + ∀ i : Fin queries.size, rows[i.val]! = oracle[queries[i]]! := by + unfold queryRows at selected + rw [Array.mapM_eq_mapM_toList] at selected + cases traversed : queries.toList.mapM (fun q => oracle[q]?) with + | none => simp [traversed] at selected + | some ys => + simp only [traversed,Functor.map,Option.map,Option.some.injEq] at selected + subst rows + have related := WHIRCallerGeometry.option_mapM_rel (fun q => oracle[q]?) + queries.toList ys traversed + have length : ys.length = queries.size := by simpa using related.length_eq.symm + constructor + · simpa + · intro i + have outputBound : i.val < ys.length := by simp [length,i.isLt] + have matched : oracle[queries[i]]? = some ys[i.val] := by + simpa using related.get (i := i.val) (by simp [i.isLt]) outputBound + obtain ⟨inside,same⟩ := Array.getElem?_eq_some_iff.mp matched + rw [getElem!_pos oracle (queries[i]) inside] + simpa [getElem!_pos,outputBound] using same.symm + +theorem extensionRow_size (words : Array K) (row : Array E) + (decoded : extensionRow words = some row) : + words.size % 3 = 0 ∧ row.size = words.size / 3 := by + unfold extensionRow at decoded + split at decoded + next valid => + have same := Option.some.inj decoded + subst row + exact ⟨valid,by simp⟩ + next => contradiction + +theorem extensionRow_limb (words : Array K) (row : Array E) + (decoded : extensionRow words = some row) (i : Fin row.size) : + row[i].c0 = words[3*i.val]! ∧ row[i].c1 = words[3*i.val+1]! ∧ + row[i].c2 = words[3*i.val+2]! := by + unfold extensionRow at decoded + split at decoded + next valid => + cases Option.some.inj decoded + simp + next => contradiction + +#print axioms extensionRow_size +#print axioms extensionRow_limb +end Whir.PCSBCSFrozenOracleRows + +#print axioms Whir.PCSBCSFrozenOracleRows.queryRows_spec diff --git a/verification/whir/Whir/PCSBCSLiteralStatePath.lean b/verification/whir/Whir/PCSBCSLiteralStatePath.lean new file mode 100644 index 000000000..0e5810ddb --- /dev/null +++ b/verification/whir/Whir/PCSBCSLiteralStatePath.lean @@ -0,0 +1,50 @@ +import Whir.PCSBCSVerifierPacketWalk + +/-! Local before/after identities suffice to construct the latent restoration +path from the verifier's recorded requests. This is a path-construction lemma, +not a substitute for proving the literal source identities. -/ +set_option autoImplicit false +namespace Whir.PCSBCSLiteralStatePath +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent + +universe u v w +variable {Key : Type u} {Answer : Key → Type v} {Public : Type w} + +/-- All neighbouring round states agree, and the two endpoints are literal. +Every key is an actual verifier lookup, not an auxiliary oracle query. -/ +theorem of_round_links (model : NodeModel Key Answer Public) (table : Table Key Answer) + (exposed : List (Sigma Answer)) (keys : List Key) (first last : Bool) + (recorded : ∀ key ∈ keys, (⟨key,table key⟩ : Sigma Answer) ∈ exposed) + (links : ∀ i (hi : i + 1 < keys.length), + after model (keys[i]'(by omega)) table = before model (keys[i+1]'hi) table) + (initial : ∀ key, keys.head? = some key → before model key table = first) + (terminal : ∀ key, keys.getLast? = some key → after model key table = last) + (empty : keys = [] → first = last) : StatePath model table exposed first last := by + induction keys generalizing first with + | nil => simpa only [empty rfl] using (StatePath.nil (model := model) (table := table) (exposed := exposed) last) + | cons key rest ih => + rw [← initial key rfl] + apply StatePath.step key (recorded key (by simp)) + apply ih (first := after model key table) + · intro other member + exact recorded other (List.mem_cons_of_mem key member) + · intro i hi + have bound : (i+1)+1 < (key::rest).length := by + simpa only [List.length_cons] using Nat.succ_lt_succ hi + simpa only [List.getElem_cons_succ] using links (i+1) bound + · intro next head + cases rest with + | nil => cases head + | cons next' tail => + cases head + simpa using (links 0 (by simp)) |>.symm + · intro other final + cases rest with + | nil => cases final + | cons next tail => exact terminal other (by simpa using final) + · intro isEmpty + subst rest + exact terminal key rfl + +#print axioms of_round_links +end Whir.PCSBCSLiteralStatePath diff --git a/verification/whir/Whir/PCSBCSMerkleFullSourceTransport.lean b/verification/whir/Whir/PCSBCSMerkleFullSourceTransport.lean new file mode 100644 index 000000000..0d709fcf1 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleFullSourceTransport.lean @@ -0,0 +1,65 @@ +import Whir.PCSBCSMerkleLeafImages + +/-! Acceptance-side source boundary: read full leafWords images, check their +leading zeros, drain leafWords-occupied, then use the existing compact octopus +transport which reconstitutes the identical full hashed image. This models +successful output semantics, not the order/trace of rejected Rust executions. -/ +namespace Whir.PCSBCSMerkleFullSourceTransport +open Concrete FiatShamirGame MerkleTransport MerkleBinding PCSBCSMerkleLeafImages + +private theorem zeroPrefix_image (n : Nat) (row : List K) + (checked : zeroPrefix n row = true) : row = List.replicate n 0 ++ row.drop n := by + induction n generalizing row with + | zero => simp + | succ n ih => + cases row with + | nil => simp [zeroPrefix] at checked + | cons x xs => + simp only [zeroPrefix,Bool.and_eq_true,beq_iff_eq] at checked + obtain ⟨rfl,tail⟩ := checked + simpa only [List.replicate_succ,List.cons_append,List.drop_succ_cons] using + congrArg (List.cons (0 : K)) (ih xs tail) + +def compactLeaf (leafWords occupied : Nat) (image : List K) : Option (List K) := + if occupied ≤ leafWords ∧ image.length = leafWords ∧ zeroPrefix (leafWords-occupied) image = true + then some (image.drop (leafWords-occupied)) else none + +theorem compactLeaf_spec (leafWords occupied : Nat) (image compact : List K) + (accepted : compactLeaf leafWords occupied image = some compact) : + occupied ≤ leafWords ∧ compact.length = occupied ∧ + image = leafImage 0 leafWords compact := by + unfold compactLeaf at accepted + split at accepted + next guard => + cases Option.some.inj accepted + obtain ⟨fits,width,padding⟩ := guard + have suffix : (image.drop (leafWords-occupied)).length = occupied := by + simp only [List.length_drop,width] + omega + refine ⟨fits,suffix,?_⟩ + simpa only [leafImage,suffix] using zeroPrefix_image (leafWords-occupied) image padding + next => contradiction + +def compactProof (proof : PrunedMerklePaths) (leafWords occupied : Nat) : Option PrunedMerklePaths := do + let rows ← collect (compactLeaf leafWords occupied) proof.leafData + pure ⟨rows,proof.siblingHashes⟩ + +def openSource (hash : Primitive) (proof : PrunedMerklePaths) (root : Digest32) + (numLeaves : Nat) (queries : List Nat) (leafWords occupied : Nat) : Option (List RawPath) := do + let compact ← compactProof proof leafWords occupied + compact.open hash root numLeaves queries occupied leafWords + +theorem openSource_refines (hash : Primitive) (proof : PrunedMerklePaths) (root : Digest32) + (numLeaves : Nat) (queries : List Nat) (leafWords occupied : Nat) (output : List RawPath) + (accepted : openSource hash proof root numLeaves queries leafWords occupied = some output) : + ∃ compact, compactProof proof leafWords occupied = some compact ∧ + compact.open hash root numLeaves queries occupied leafWords = some output := by + simpa only [openSource,Option.bind_eq_bind,Option.bind_eq_some_iff] using accepted + +/-- Invalid padding cannot be accepted, even when its full bytes hash to root. -/ +theorem compactLeaf_reject_padding (leafWords occupied : Nat) (image : List K) + (invalid : zeroPrefix (leafWords-occupied) image ≠ true) : + compactLeaf leafWords occupied image = none := by + simp [compactLeaf,invalid] + +end Whir.PCSBCSMerkleFullSourceTransport diff --git a/verification/whir/Whir/PCSBCSMerkleLeafImageCost.lean b/verification/whir/Whir/PCSBCSMerkleLeafImageCost.lean new file mode 100644 index 000000000..0178788af --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleLeafImageCost.lean @@ -0,0 +1,118 @@ +import Whir.PCSBCSMerkleLeafImages +import Whir.MerkleQueryLogExtractionResourceContract + +/-! Instrumented fused image/suffix extraction, with the same shared default +cell as production. No counter is executed by the production cache. -/ +namespace Whir.PCSBCSMerkleLeafImages +open Concrete FiatShamirGame PublicMerkleLog MerkleQueryLogExtraction PCSBCSMerkleQueryLog + +def countedCells (codec : Codec) (index : Index) (leafWords occupied : Nat) (default : ImageCell) : + Nat → Digest32 → Array ImageCell → Array ImageCell × Nat + | 0, root, out => (extractCells codec index leafWords occupied default 0 root out,1) + | h+1, root, out => match index[key root]? with + | none => (fillCells default (2^(h+1)) out,1) + | some bytes => match codec.pair bytes with + | none => (fillCells default (2^(h+1)) out,1) + | some (l,r) => + let left := countedCells codec index leafWords occupied default h l out + let right := countedCells codec index leafWords occupied default h r left.1 + (right.1,1+left.2+right.2) + +theorem countedCells_value (codec : Codec) (index : Index) (leafWords occupied : Nat) + (default : ImageCell) (height : Nat) (root : Digest32) (out : Array ImageCell) : + (countedCells codec index leafWords occupied default height root out).1 = + extractCells codec index leafWords occupied default height root out := by + induction height generalizing root out with + | zero => rfl + | succ h ih => + cases hi : index[key root]? with + | none => simp [countedCells,extractCells,hi] + | some bytes => + cases hp : codec.pair bytes with + | none => simp [countedCells,extractCells,hi,hp] + | some pair => rcases pair with ⟨l,r⟩; simp only [countedCells,extractCells,hi,hp,ih] + +theorem countedCells_visits (codec : Codec) (index : Index) (leafWords occupied : Nat) + (default : ImageCell) (height : Nat) (root : Digest32) (out : Array ImageCell) : + (countedCells codec index leafWords occupied default height root out).2 = + (countedExtract codec index height root).2 := by + induction height generalizing root out with + | zero => rfl + | succ h ih => + cases hi : index[key root]? with + | none => simp [countedCells,countedExtract,hi] + | some bytes => + cases hp : codec.pair bytes with + | none => simp [countedCells,countedExtract,hi,hp] + | some pair => rcases pair with ⟨l,r⟩; simp only [countedCells,countedExtract,hi,hp,ih] + +theorem source_visit_budget (log : PublicLog) (root : Digest32) (height leafWords occupied : Nat) : + (countedCells canonicalCodec (build (records log)) leafWords occupied + (defaultCell leafWords occupied) height root #[]).2 < 2*(2^height) := by + rw [countedCells_visits] + exact fixed_depth_visit_budget _ _ _ _ _ rfl + +theorem compact_word_slots (log : PublicLog) (root : Digest32) + (height leafWords occupied : Nat) (fits : occupied ≤ leafWords) : + ((compactTable (sourceCells log root height leafWords occupied)).toList.map Array.size).sum ≤ + 2^height*occupied := by + have shape := compactTable_shape log root height leafWords occupied fits + have bound := List.sum_le_length_nsmul + ((compactTable (sourceCells log root height leafWords occupied)).toList.map Array.size) occupied (by + intro size member + obtain ⟨row,inside,rfl⟩ := List.mem_map.mp member + exact le_of_eq (shape.2 row inside)) + simpa only [List.length_map,Array.length_toList,shape.1,smul_eq_mul] using bound + +theorem image_word_slots (log : PublicLog) (root : Digest32) + (height leafWords occupied : Nat) : + ((imageTable (sourceCells log root height leafWords occupied)).toList.map Array.size).sum ≤ + 2^height*leafWords := by + rw [imageTable_eq_full] + exact rawRoot0_word_slots log root height leafWords + +/-- Actual byte volume supplied to leaf/pair codecs at visited preimages. +This is a data-operation metric, not a machine-instruction claim. -/ +def inputByteVolume (codec : Codec) (index : Index) : Nat → Digest32 → Nat + | 0, root => match index[key root]? with + | none => 0 + | some bytes => bytes.length + | h+1, root => match index[key root]? with + | none => 0 + | some bytes => match codec.pair bytes with + | none => bytes.length + | some (l,r) => bytes.length + inputByteVolume codec index h l + inputByteVolume codec index h r + +theorem inputByteVolume_bound (codec : Codec) (index : Index) (height : Nat) + (root : Digest32) (B : Nat) + (cap : ∀ d bytes, index[key d]? = some bytes → bytes.length ≤ B) : + inputByteVolume codec index height root ≤ (countedExtract codec index height root).2*B := by + induction height generalizing root with + | zero => + cases hit : index[key root]? with + | none => simp [inputByteVolume,hit,countedExtract] + | some bytes => simpa [inputByteVolume,hit,countedExtract] using cap root bytes hit + | succ h ih => + cases hit : index[key root]? with + | none => simp [inputByteVolume,hit,countedExtract] + | some bytes => + have size := cap root bytes hit + cases parsed : codec.pair bytes with + | none => simpa [inputByteVolume,countedExtract,hit,parsed] using size + | some pair => + rcases pair with ⟨l,r⟩ + have left := ih l + have right := ih r + simp only [inputByteVolume,countedExtract,hit,parsed] + nlinarith + +theorem public_input_byte_volume (log : PublicLog) (root : Digest32) (height Q N : Nat) + (queryCap : log.length ≤ Q) (rowCap : 2^height ≤ N) : + inputByteVolume canonicalCodec (build (records log)) height root ≤ 2*N*(64*(Q+2)) := by + have bytes := inputByteVolume_bound canonicalCodec (build (records log)) height root + (64*(log.length+2)) (public_selected_bytes log) + have visits := fixed_depth_visit_budget canonicalCodec (build (records log)) height root (2^height) rfl + have count : (countedExtract canonicalCodec (build (records log)) height root).2 ≤ 2*N := by omega + exact bytes.trans (Nat.mul_le_mul count (by omega)) + +end Whir.PCSBCSMerkleLeafImages diff --git a/verification/whir/Whir/PCSBCSMerkleLeafImages.lean b/verification/whir/Whir/PCSBCSMerkleLeafImages.lean new file mode 100644 index 000000000..188887d68 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleLeafImages.lean @@ -0,0 +1,273 @@ +import Whir.PCSBCSMerkleQueryLog + +/-! Full hashed images and compact source suffixes are different objects. +Missing/malformed images have explicit unavailable status, even though the +book default keeps both numerical tables rectangular. Invalid zero padding +is a local source rejection, never a cryptographic collision. -/ +namespace Whir.PCSBCSMerkleLeafImages +open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments +open MerkleBinding +open MerkleQueryLogExtraction PCSBCSMerkleQueryLog PublicMerkleLog + +/-- Allocation-free leading-zero check. -/ +def zeroPrefix : Nat → List K → Bool + | 0, _ => true + | _+1, [] => false + | n+1, x::xs => (x == 0) && zeroPrefix n xs + +theorem zeroPrefix_replicate (n : Nat) (row : List K) : + zeroPrefix n (List.replicate n 0 ++ row) = true := by + induction n with + | zero => rfl + | succ n ih => simp [zeroPrefix,List.replicate_succ,ih] + +structure ImageCell where + image : Array K + compact : Array K + available : Bool + paddingValid : Bool + +/-- Numerical defaults are not marked available or padding-authenticated. -/ +def defaultCell (leafWords occupied : Nat) : ImageCell := + ⟨Array.replicate leafWords 0,Array.replicate (leafWords-(leafWords-occupied)) 0,false,false⟩ + +def leafCell (leafWords occupied : Nat) (row : List K) + (default : ImageCell := defaultCell leafWords occupied) : ImageCell := + if row.length = leafWords then + ⟨row.toArray,(row.drop (leafWords-occupied)).toArray,true, + decide (occupied ≤ leafWords) && zeroPrefix (leafWords-occupied) row⟩ + else default + +theorem leafCell_image (leafWords occupied : Nat) (row : List K) : + (leafCell leafWords occupied row).image = MerkleQueryLogExtraction.normalize leafWords row := by + simp only [leafCell,MerkleQueryLogExtraction.normalize] + split <;> rfl + +theorem leafCell_compact (leafWords occupied : Nat) (row : List K) : + (leafCell leafWords occupied row).compact = + ((leafCell leafWords occupied row).image.toList.drop (leafWords-occupied)).toArray := by + simp only [leafCell] + split + next => simp + next => simp [defaultCell,List.drop_replicate] + +theorem leafCell_admitted (leafWords occupied : Nat) (row : List K) + (width : row.length = occupied) (fits : occupied ≤ leafWords) : + (leafCell leafWords occupied (leafImage 0 leafWords row)).available = true ∧ + (leafCell leafWords occupied (leafImage 0 leafWords row)).paddingValid = true ∧ + (leafCell leafWords occupied (leafImage 0 leafWords row)).compact = row.toArray := by + have full := leafImage_length (0 : K) leafWords row (width ▸ fits) + simp only [leafCell,full,↓reduceIte] + simp [leafImage,width,fits,zeroPrefix_replicate] + +def fillCells (default : ImageCell) : Nat → Array ImageCell → Array ImageCell + | 0, out => out + | n+1, out => fillCells default n (out.push default) + +theorem fillCells_list (default : ImageCell) (n : Nat) (out : Array ImageCell) : + (fillCells default n out).toList = out.toList ++ List.replicate n default := by + induction n generalizing out with + | zero => simp [fillCells] + | succ n ih => simp only [fillCells,ih,Array.toList_push,List.append_assoc, + List.replicate_succ,List.singleton_append] + +def cellsSpec (leafWords occupied : Nat) : Nat → Tree → List ImageCell + | 0, .leaf row => [leafCell leafWords occupied row] + | h+1, .branch l r => cellsSpec leafWords occupied h l ++ cellsSpec leafWords occupied h r + | h, _ => List.replicate (2^h) (defaultCell leafWords occupied) + +def emitCells (leafWords occupied : Nat) : Nat → Tree → Array ImageCell → Array ImageCell + | 0, .leaf row, out => out.push (leafCell leafWords occupied row) + | h+1, .branch l r, out => emitCells leafWords occupied h r (emitCells leafWords occupied h l out) + | h, _, out => fillCells (defaultCell leafWords occupied) (2^h) out + +/-- One preindex and one fused hash-tree descent. No per-row log/path scans. -/ +def extractCells (codec : Codec) (index : Index) (leafWords occupied : Nat) (default : ImageCell) : + Nat → Digest32 → Array ImageCell → Array ImageCell + | 0, root, out => match index[key root]? with + | none => out.push default + | some bytes => match codec.leaf bytes with + | none => out.push default + | some row => out.push (leafCell leafWords occupied row default) + | h+1, root, out => match index[key root]? with + | none => fillCells default (2^(h+1)) out + | some bytes => match codec.pair bytes with + | none => fillCells default (2^(h+1)) out + | some (l,r) => extractCells codec index leafWords occupied default h r + (extractCells codec index leafWords occupied default h l out) + +theorem extractCells_eq_emit (codec : Codec) (index : Index) (leafWords occupied height : Nat) + (root : Digest32) (out : Array ImageCell) : + extractCells codec index leafWords occupied (defaultCell leafWords occupied) height root out = + emitCells leafWords occupied height (extract codec index height root) out := by + induction height generalizing root out with + | zero => + cases hi : index[key root]? with + | none => simp [extractCells,extract,hi,emitCells,fillCells] + | some bytes => cases hl : codec.leaf bytes <;> + simp [extractCells,extract,hi,hl,emitCells,fillCells] + | succ h ih => + cases hi : index[key root]? with + | none => simp [extractCells,extract,hi,emitCells] + | some bytes => + cases hp : codec.pair bytes with + | none => simp [extractCells,extract,hi,hp,emitCells] + | some pair => rcases pair with ⟨l,r⟩; simp only [extractCells,extract,hi,hp,emitCells,ih] + +theorem emitCells_spec (leafWords occupied height : Nat) (tree : Tree) (out : Array ImageCell) : + (emitCells leafWords occupied height tree out).toList = + out.toList ++ cellsSpec leafWords occupied height tree := by + induction height generalizing tree out with + | zero => cases tree <;> simp [emitCells,cellsSpec,fillCells_list] + | succ h ih => cases tree <;> simp only [emitCells,cellsSpec,fillCells_list,ih,List.append_assoc] + +theorem cellsSpec_length (leafWords occupied height : Nat) (tree : Tree) : + (cellsSpec leafWords occupied height tree).length = 2^height := by + induction height generalizing tree with + | zero => cases tree <;> simp [cellsSpec] + | succ h ih => cases tree <;> simp [cellsSpec,ih,pow_succ,Nat.mul_two] + +def sourceCells (log : PublicLog) (root : Digest32) (height leafWords occupied : Nat) : Array ImageCell := + extractCells canonicalCodec (build (records log)) leafWords occupied + (defaultCell leafWords occupied) height root #[] + +def imageTable (cells : Array ImageCell) : Array (Array K) := cells.map ImageCell.image +def compactTable (cells : Array ImageCell) : Array (Array K) := cells.map ImageCell.compact + +theorem sourceCells_spec (log : PublicLog) (root : Digest32) (height leafWords occupied : Nat) : + (sourceCells log root height leafWords occupied).toList = + cellsSpec leafWords occupied height (fromPublic log root height) := by + simp only [sourceCells,extractCells_eq_emit,emitCells_spec,List.nil_append,fromPublic] + +theorem sourceCells_size (log : PublicLog) (root : Digest32) (height leafWords occupied : Nat) : + (sourceCells log root height leafWords occupied).size = 2^height := by + have h := congrArg List.length (sourceCells_spec log root height leafWords occupied) + simpa only [Array.length_toList,cellsSpec_length] using h + +theorem cellsSpec_images (leafWords occupied height : Nat) (tree : Tree) : + (cellsSpec leafWords occupied height tree).map ImageCell.image = rowsSpec leafWords height tree := by + induction height generalizing tree with + | zero => + cases tree with + | absent => simp [cellsSpec,rowsSpec,defaultCell] + | branch l r => simp [cellsSpec,rowsSpec,defaultCell] + | leaf row => simp only [cellsSpec,rowsSpec,List.map_cons,List.map_nil,leafCell_image] + | succ h ih => cases tree <;> simp [cellsSpec,rowsSpec,defaultCell,ih] + +theorem imageTable_eq_full (log : PublicLog) (root : Digest32) (height leafWords occupied : Nat) : + imageTable (sourceCells log root height leafWords occupied) = rawRoot0 log root height leafWords := by + apply Array.toList_inj.mp + simp only [imageTable,Array.toList_map,sourceCells_spec,cellsSpec_images, + rawRoot0_eq_fullRows,fullRows_spec] + +theorem cell_compact_drop (leafWords occupied height : Nat) (tree : Tree) : + ∀ cell ∈ cellsSpec leafWords occupied height tree, + cell.compact = (cell.image.toList.drop (leafWords-occupied)).toArray := by + induction height generalizing tree with + | zero => + cases tree with + | absent => simp [cellsSpec,defaultCell,List.drop_replicate] + | branch l r => simp [cellsSpec,defaultCell,List.drop_replicate] + | leaf row => + intro cell member + simp only [cellsSpec,List.mem_singleton] at member + subst cell + exact leafCell_compact leafWords occupied row + | succ h ih => + cases tree with + | absent => simp [cellsSpec,defaultCell,List.drop_replicate] + | leaf row => simp [cellsSpec,defaultCell,List.drop_replicate] + | branch l r => + intro cell member + rcases List.mem_append.mp member with hl | hr + · exact ih l cell hl + · exact ih r cell hr + +theorem compactTable_eq_drop (log : PublicLog) (root : Digest32) (height leafWords occupied : Nat) : + compactTable (sourceCells log root height leafWords occupied) = + (rawRoot0 log root height leafWords).map + (fun image => (image.toList.drop (leafWords-occupied)).toArray) := by + rw [← imageTable_eq_full log root height leafWords occupied] + apply Array.toList_inj.mp + simp only [compactTable,imageTable,Array.toList_map,List.map_map,sourceCells_spec] + apply List.map_congr_left + intro cell member + exact cell_compact_drop leafWords occupied height (fromPublic log root height) cell member + +theorem compactTable_shape (log : PublicLog) (root : Digest32) + (height leafWords occupied : Nat) (fits : occupied ≤ leafWords) : + (compactTable (sourceCells log root height leafWords occupied)).size = 2^height ∧ + ∀ row ∈ (compactTable (sourceCells log root height leafWords occupied)).toList, + row.size = occupied := by + rw [compactTable_eq_drop] + have shape := rawRoot0_shape log root height leafWords + refine ⟨by simpa using shape.1,?_⟩ + intro row member + simp only [Array.toList_map,List.mem_map] at member + obtain ⟨image,inside,rfl⟩ := member + have width := shape.2 image inside + simp only [List.size_toArray,List.length_drop,Array.length_toList,width] + omega + +private theorem address_top (index h : Nat) (below : List Bool) : + addressAbove index (h+1) below = right (index/2^h) :: addressAbove index h below := by + induction h generalizing index below with + | zero => simp [addressAbove] + | succ h ih => rw [addressAbove,ih]; simp only [Nat.div_div_eq_div_mul,pow_succ,Nat.mul_comm]; rfl + +private theorem address_mod (index h : Nat) (below : List Bool) : + addressAbove (index%2^h) h below = addressAbove index h below := by + induction h generalizing index below with + | zero => rfl + | succ h ih => + rw [addressAbove,addressAbove] + have parity : right (index%2^(h+1)) = right index := by + simp only [right,MerkleLevels.right,pow_succ,Nat.mul_comm (2^h) 2,Nat.mod_mul_right_mod] + rw [parity,pow_succ,Nat.mod_mul_left_div_self,ih] + +def cellAt (leafWords occupied : Nat) (tree : Tree) (address : List Bool) : ImageCell := + match tree.get address with + | none => defaultCell leafWords occupied + | some row => leafCell leafWords occupied row + +theorem cellsSpec_get (leafWords occupied height : Nat) (tree : Tree) (index : Nat) + (inside : index < 2^height) : + (cellsSpec leafWords occupied height tree)[index]? = + some (cellAt leafWords occupied tree (addressAbove index height [])) := by + induction height generalizing tree index with + | zero => + have eq : index = 0 := by simpa using inside + subst index + cases tree <;> simp [cellsSpec,cellAt,Tree.get,addressAbove] + | succ h ih => + have full : index < 2^h*2 := by simpa [pow_succ] using inside + rw [address_top] + cases tree with + | absent => simp [cellsSpec,cellAt,Tree.get,inside] + | leaf row => simp [cellsSpec,cellAt,Tree.get,inside] + | branch l r => + by_cases lower : index < 2^h + · have hd : index/2^h = 0 := Nat.div_eq_of_lt lower + simp only [cellsSpec,cellAt,Tree.get,hd,right,MerkleLevels.right,Nat.reduceMod,Nat.reduceBEq] + rw [List.getElem?_append_left (by simpa [cellsSpec_length] using lower)] + exact ih l index lower + · have upper : index-2^h < 2^h := by omega + have hd : index/2^h = 1 := Nat.div_eq_of_lt_le (by simpa using Nat.le_of_not_gt lower) + (by simpa [Nat.mul_comm] using full) + have hm : index%2^h = index-2^h := by + rw [Nat.mod_eq_sub_mod (Nat.le_of_not_gt lower),Nat.mod_eq_of_lt upper] + have ha : addressAbove index h [] = addressAbove (index-2^h) h [] := by + rw [← hm]; exact (address_mod index h []).symm + simp only [cellsSpec,cellAt,Tree.get,hd,right,MerkleLevels.right,Nat.reduceMod,Nat.reduceBEq,↓reduceIte] + rw [List.getElem?_append_right (by simpa [cellsSpec_length] using Nat.le_of_not_gt lower)] + rw [cellsSpec_length,ha] + exact ih r (index-2^h) upper + +theorem sourceCells_get (log : PublicLog) (root : Digest32) (height leafWords occupied index : Nat) + (inside : index < 2^height) : + (sourceCells log root height leafWords occupied)[index]? = + some (cellAt leafWords occupied (fromPublic log root height) (addressAbove index height [])) := by + rw [← Array.getElem?_toList,sourceCells_spec] + exact cellsSpec_get leafWords occupied height _ index inside + +end Whir.PCSBCSMerkleLeafImages diff --git a/verification/whir/Whir/PCSBCSMerkleOpenedTable.lean b/verification/whir/Whir/PCSBCSMerkleOpenedTable.lean index 1bd7a0e88..1dba4f17c 100644 --- a/verification/whir/Whir/PCSBCSMerkleOpenedTable.lean +++ b/verification/whir/Whir/PCSBCSMerkleOpenedTable.lean @@ -1,43 +1,81 @@ import Whir.PCSBCSMerkleSourceRows -/-! Actual accepted Root0 transport rows agree with the executable full table, -in query occurrence order including duplicate queries. No ideal oracle is -passed to the runtime decoder; the table consists solely of frozen log data. -/ +/-! Full images remain in the Merkle relation. Compact suffix authentication is +established only for accepted source openings with their zero-prefix image; +absence defaults and arbitrary committed padding are not authenticated. -/ namespace Whir.PCSBCSMerkleSourceRows open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments +open MerkleBinding open MerkleQueryLogExtraction PCSBCSMerkleQueryLog PublicMerkleLog PublicMerkleBinding +open PCSBCSMerkleLeafImages theorem pruned_opened_table (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) (auth : AuthenticLog C log) (root : Digest32) (proof : PrunedMerklePaths) - (numLeaves occupied : Nat) (queries : List Nat) (output : List RawPath) - (accepted : proof.open (hash C) root numLeaves queries occupied occupied = some output) + (numLeaves leafWords occupied : Nat) (queries : List Nat) (output : List RawPath) + (accepted : proof.open (hash C) root numLeaves queries occupied leafWords = some output) (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : - List.Forall₂ (fun q p => (rawRoot0 log root numLeaves.log2 occupied)[q]! = p.leafData.toArray) + List.Forall₂ (fun q p => (rawRoot0 log root numLeaves.log2 leafWords)[q]! = p.leafData.toArray) queries output ∨ OpenPrimitiveBad C log root output := by - have refined := open_refines (hash C) proof root numLeaves queries occupied occupied output accepted - have conditions := ((open_spec (hash C) proof root numLeaves queries occupied occupied output).mp accepted).1 - rcases pruned_opened_rows C log auth root proof numLeaves occupied queries output accepted bounds with good | bad + have refined := open_refines (hash C) proof root numLeaves queries occupied leafWords output accepted + have conditions := ((open_spec (hash C) proof root numLeaves queries occupied leafWords output).mp accepted).1 + rcases pruned_opened_rows C log auth root proof numLeaves leafWords occupied queries output accepted bounds with good | bad · left apply List.forall₂_of_length_eq_of_get refined.length_eq intro i hi ho obtain ⟨stored,hs,hw,hindex,hdata,hlen,hdepth,hroot⟩ := refined.get hi ho have hq := conditions.range (queries.get ⟨i,hi⟩) (List.get_mem _ _) - have inside : queries.get ⟨i,hi⟩ < 2^numLeaves.log2 := by - simpa only [conditions.power] using hq + have inside : queries.get ⟨i,hi⟩ < 2^numLeaves.log2 := by simpa only [conditions.power] using hq have tree := good (output.get ⟨i,ho⟩) (List.get_mem _ _) rw [hindex] at tree - have table := fullRows_get occupied numLeaves.log2 (fromPublic log root numLeaves.log2) + have table := fullRows_get leafWords numLeaves.log2 (fromPublic log root numLeaves.log2) (queries.get ⟨i,hi⟩) inside simp only [Tree.row,tree,Option.getD_some,MerkleQueryLogExtraction.normalize,hlen,↓reduceIte] at table have bound : queries.get ⟨i,hi⟩ < - (fullRows occupied numLeaves.log2 (fromPublic log root numLeaves.log2)).size := by + (fullRows leafWords numLeaves.log2 (fromPublic log root numLeaves.log2)).size := by simpa only [fullRows_size] using inside rw [Array.getElem?_eq_getElem bound] at table have result := Option.some.inj table rw [rawRoot0_eq_fullRows] simpa only [getElem!_pos - (fullRows occupied numLeaves.log2 (fromPublic log root numLeaves.log2)) + (fullRows leafWords numLeaves.log2 (fromPublic log root numLeaves.log2)) (queries.get ⟨i,hi⟩) bound] using result · exact Or.inr bad +/-- Both status bits are proved, independently of numerical zero defaults. -/ +theorem pruned_opened_compact (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (root : Digest32) (proof : PrunedMerklePaths) + (numLeaves leafWords occupied : Nat) (queries : List Nat) (output : List RawPath) + (accepted : proof.open (hash C) root numLeaves queries occupied leafWords = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : + List.Forall₂ (fun q p => + (compactTable (sourceCells log root numLeaves.log2 leafWords occupied))[q]! = + (p.leafData.drop (leafWords-occupied)).toArray ∧ + ((sourceCells log root numLeaves.log2 leafWords occupied)[q]?).map + (fun cell => (cell.available,cell.paddingValid)) = some (true,true)) queries output ∨ + OpenPrimitiveBad C log root output := by + have refined := open_refines (hash C) proof root numLeaves queries occupied leafWords output accepted + have conditions := ((open_spec (hash C) proof root numLeaves queries occupied leafWords output).mp accepted).1 + rcases pruned_opened_rows C log auth root proof numLeaves leafWords occupied queries output accepted bounds with good | bad + · left + apply List.forall₂_of_length_eq_of_get refined.length_eq + intro i hi ho + obtain ⟨stored,hs,hw,hindex,hdata,hlen,hdepth,hroot⟩ := refined.get hi ho + have hq := conditions.range (queries.get ⟨i,hi⟩) (List.get_mem _ _) + have inside : queries.get ⟨i,hi⟩ < 2^numLeaves.log2 := by simpa only [conditions.power] using hq + have tree := good (output.get ⟨i,ho⟩) (List.get_mem _ _) + rw [hindex] at tree + have cell := sourceCells_get log root numLeaves.log2 leafWords occupied (queries.get ⟨i,hi⟩) inside + simp only [cellAt,tree] at cell + have admitted := leafCell_admitted leafWords occupied stored hw conditions.fits + have drop : ((output.get ⟨i,ho⟩).leafData.drop (leafWords-occupied)).toArray = stored.toArray := by + rw [hdata] + simp [leafImage,hw] + rw [hdata] at cell + refine ⟨?_,?_⟩ + · rw [drop] + simp only [compactTable,getElem!_def,Array.getElem?_map,cell,Option.map_some,admitted.2.2] + · rw [cell] + simp only [Option.map_some,admitted.1,admitted.2.1] + · exact Or.inr bad + end Whir.PCSBCSMerkleSourceRows diff --git a/verification/whir/Whir/PCSBCSMerkleQueryLog.lean b/verification/whir/Whir/PCSBCSMerkleQueryLog.lean index b7356f1c7..17acb1503 100644 --- a/verification/whir/Whir/PCSBCSMerkleQueryLog.lean +++ b/verification/whir/Whir/PCSBCSMerkleQueryLog.lean @@ -118,15 +118,15 @@ noncomputable def extractionProbability {T : Type} (roots : RootPolicy) {Q : Nat exact average (fun C : PrimitiveOracle => if FrozenExtractionBad C roots (toLog (Sampling.execute C p).2) then 1 else 0) -/-- Q is the actual full shared compression-call budget, not the number of -whole hashes. Q+1 is the independently checked root-announcement cap. The -root policy retains announced roots across causal public-call boundaries. -/ -theorem multi_extraction_probability {T : Type} (roots : RootPolicy) (Q : Nat) - (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ Q+1) +/-- Q counts actual shared compression calls. M is the independently checked +target-admission cap; it must not be inferred from distinct commitment CVs or +from a whole-construction cost when the source made primitive requests. -/ +theorem multi_extraction_probability {T : Type} (roots : RootPolicy) (Q M : Nat) + (rootCap : ∀ log, log.length ≤ Q → (roots log).card ≤ M) (grow : RootsGrow roots) (p : Computation T Q) : - extractionProbability roots p ≤ bound Q (Q+1) := by + extractionProbability roots p ≤ bound Q M := by classical - apply le_trans _ (opening_probability_bound roots Q (Q+1) rootCap grow p) + apply le_trans _ (opening_probability_bound roots Q M rootCap grow p) apply average_mono intro C by_cases bad : FrozenExtractionBad C roots (toLog (Sampling.execute C p).2) diff --git a/verification/whir/Whir/PCSBCSMerkleRootCache.lean b/verification/whir/Whir/PCSBCSMerkleRootCache.lean index 912e7616a..c87a14d69 100644 --- a/verification/whir/Whir/PCSBCSMerkleRootCache.lean +++ b/verification/whir/Whir/PCSBCSMerkleRootCache.lean @@ -1,65 +1,131 @@ import Whir.PCSBCSMerkleQueryLog +import Whir.PCSBCSMerkleLeafImages /-! At the commitment/oracle-message boundary, first registration freezes the CURRENT public-query prefix and its full extracted table. This API is called by -the causal caller, not with a final transcript log. Repeat announcements/clones -retain the literal same prefix and table; later fresh queries do not fill absent -rows retroactively. Agreement with later openings is charged by OpenPrimitiveBad. -/ +the causal caller, not with a final transcript log. The address includes the CV, +height, full leaf-image width and occupied width: identical untagged preimages +at different shapes are not collisions. Same-address clones retain the literal +prefix and table; later +queries do not fill absent rows retroactively. Opening transport additionally +requires derived registry provenance and authentic captured-prefix evidence. -/ namespace Whir.PCSBCSMerkleRootCache open Concrete FiatShamirGame PublicMerkleLog MerkleQueryLogExtraction PCSBCSMerkleQueryLog +open PCSBCSMerkleLeafImages structure Shape where height : Nat + leafWords : Nat occupied : Nat structure Frozen where shape : Shape queryPrefix : PublicLog + cells : Array ImageCell raw : Array (Array K) -abbrev Registry := Std.ExtHashMap Key Frozen +abbrev CacheKey := Key × Nat × Nat × Nat + +def cacheKey (root : Digest32) (shape : Shape) : CacheKey := + (key root, shape.height, shape.leafWords, shape.occupied) + +theorem cacheKey_injective {root other : Digest32} {shape requested : Shape} + (same : cacheKey root shape = cacheKey other requested) : + root = other ∧ shape = requested := by + have digest := congrArg Prod.fst same + have height := congrArg (fun address : CacheKey => address.2.1) same + have imageWidth := congrArg (fun address : CacheKey => address.2.2.1) same + have occupied := congrArg (fun address : CacheKey => address.2.2.2) same + refine ⟨key_injective digest, ?_⟩ + cases shape + cases requested + dsimp only [cacheKey] at height imageWidth occupied + cases height + cases imageWidth + cases occupied + rfl + +abbrev Registry := Std.ExtHashMap CacheKey Frozen /-- `queryPrefix` is already public at the announcement. It is retained by reference, not recopied; extraction never consults later answers. -/ def freeze (queryPrefix : PublicLog) (root : Digest32) (shape : Shape) : Frozen := - ⟨shape,queryPrefix,rawRoot0 queryPrefix root shape.height shape.occupied⟩ + let cells := sourceCells queryPrefix root shape.height shape.leafWords shape.occupied + ⟨shape,queryPrefix,cells,compactTable cells⟩ theorem freeze_prefix (queryPrefix : PublicLog) (root : Digest32) (shape : Shape) : (freeze queryPrefix root shape).queryPrefix = queryPrefix := rfl -/-- Runtime branches BEFORE invoking extraction; existing roots do no work. -/ +/-- Runtime branches BEFORE invoking extraction. Only the identical +CV/height/leafWords/occupied address reuses an earlier extraction. -/ def register (registry : Registry) (log : PublicLog) (root : Digest32) (shape : Shape) : Registry := - match registry[key root]? with + let address := cacheKey root shape + match registry[address]? with | some _ => registry - | none => registry.insert (key root) (freeze log root shape) + | none => registry.insert address (freeze log root shape) theorem register_existing (registry : Registry) (log : PublicLog) (root : Digest32) - (shape : Shape) (frozen : Frozen) (known : registry[key root]? = some frozen) : + (shape : Shape) (frozen : Frozen) (known : registry[cacheKey root shape]? = some frozen) : register registry log root shape = registry := by simp [register,known] theorem register_preserves (registry : Registry) (log : PublicLog) (root other : Digest32) - (shape : Shape) (frozen : Frozen) (known : registry[key root]? = some frozen) : - (register registry log other shape)[key root]? = some frozen := by + (shape requested : Shape) (frozen : Frozen) + (known : registry[cacheKey root shape]? = some frozen) : + (register registry log other requested)[cacheKey root shape]? = some frozen := by unfold register + dsimp only split next => exact known next miss => rw [Std.ExtHashMap.getElem?_insert] split next eq => - have hk : key other = key root := by simpa using eq + have hk : cacheKey other requested = cacheKey root shape := by simpa using eq rw [hk,known] at miss contradiction next => exact known theorem register_first (registry : Registry) (log : PublicLog) (root : Digest32) - (shape : Shape) (absent : registry[key root]? = none) : - (register registry log root shape)[key root]? = some (freeze log root shape) := by + (shape : Shape) (absent : registry[cacheKey root shape]? = none) : + (register registry log root shape)[cacheKey root shape]? = some (freeze log root shape) := by simp [register,absent] -theorem freeze_shape (log : PublicLog) (root : Digest32) (shape : Shape) : +/-- Derived provenance, not an assumption that preimages are available. -/ +def WellFormed (registry : Registry) : Prop := + ∀ root shape frozen, registry[cacheKey root shape]? = some frozen → + frozen = freeze frozen.queryPrefix root shape + +theorem empty_wellFormed : WellFormed (∅ : Registry) := by + simp [WellFormed] + +theorem register_wellFormed (registry : Registry) (log : PublicLog) (root : Digest32) + (shape : Shape) (valid : WellFormed registry) : + WellFormed (register registry log root shape) := by + unfold register + dsimp only + split + next => exact valid + next miss => + intro other requested frozen known + rw [Std.ExtHashMap.getElem?_insert] at known + split at known + next eq => + have same : cacheKey root shape = cacheKey other requested := by simpa using eq + obtain ⟨rfl,rfl⟩ := cacheKey_injective same + have value := Option.some.inj known + rw [← value] + rfl + next => exact valid other requested frozen known + +theorem lookup_shape (registry : Registry) (valid : WellFormed registry) + (root : Digest32) (shape : Shape) (frozen : Frozen) + (known : registry[cacheKey root shape]? = some frozen) : frozen.shape = shape := by + exact congrArg Frozen.shape (valid root shape frozen known) + +theorem freeze_shape (log : PublicLog) (root : Digest32) (shape : Shape) + (fits : shape.occupied ≤ shape.leafWords) : (freeze log root shape).raw.size = 2^shape.height ∧ ∀ row ∈ (freeze log root shape).raw.toList, row.size = shape.occupied := by - exact rawRoot0_shape log root shape.height shape.occupied + exact compactTable_shape log root shape.height shape.leafWords shape.occupied fits end Whir.PCSBCSMerkleRootCache diff --git a/verification/whir/Whir/PCSBCSMerkleRootCacheCost.lean b/verification/whir/Whir/PCSBCSMerkleRootCacheCost.lean new file mode 100644 index 000000000..29ac93e18 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleRootCacheCost.lean @@ -0,0 +1,176 @@ +import Whir.PCSBCSMerkleRootCache +import Whir.PCSBCSMerkleLeafImageCost + +/-! Resources are charged to actual announcements, not unique CVs. A fresh +(CV,height,leafWords,occupied) address creates one captured image/suffix table; +identical addresses only perform the registry lookup. Metrics are proof-side, +not extra scans executed by register. Storage counts both full images and raw +suffix arrays, status cells and captured-prefix records. Container-internal +instructions, shared capacities and Rust allocators are not refined here. -/ +namespace Whir.PCSBCSMerkleRootCache +open Concrete FiatShamirGame PublicMerkleLog MerkleQueryLogExtraction PCSBCSMerkleQueryLog +open PCSBCSMerkleLeafImages + +structure Announcement where + queryPrefix : PublicLog + root : Digest32 + shape : Shape + +def registerAll (registry : Registry) : List Announcement → Registry + | [] => registry + | a::rest => registerAll (register registry a.queryPrefix a.root a.shape) rest + +theorem register_size_le (registry : Registry) (log : PublicLog) (root : Digest32) + (shape : Shape) : (register registry log root shape).size ≤ registry.size+1 := by + unfold register + dsimp only + split + next => omega + next => exact Std.ExtHashMap.size_insert_le + +theorem registerAll_size_le (registry : Registry) (announcements : List Announcement) : + (registerAll registry announcements).size ≤ registry.size+announcements.length := by + induction announcements generalizing registry with + | nil => simp [registerAll] + | cons a rest ih => + have later := ih (register registry a.queryPrefix a.root a.shape) + have first := register_size_le registry a.queryPrefix a.root a.shape + simp only [registerAll,List.length_cons] + omega + +theorem registerAll_wellFormed (registry : Registry) (announcements : List Announcement) + (valid : WellFormed registry) : WellFormed (registerAll registry announcements) := by + induction announcements generalizing registry with + | nil => exact valid + | cons a rest ih => + exact ih _ (register_wellFormed registry a.queryPrefix a.root a.shape valid) + +def sumCharges (charge : Registry → Announcement → Nat) (registry : Registry) : + List Announcement → Nat + | [] => 0 + | a::rest => charge registry a + + sumCharges charge (register registry a.queryPrefix a.root a.shape) rest + +theorem sumCharges_bound (charge : Registry → Announcement → Nat) + (registry : Registry) (announcements : List Announcement) (budget : Nat) + (cap : ∀ r a, a ∈ announcements → charge r a ≤ budget) : + sumCharges charge registry announcements ≤ announcements.length*budget := by + induction announcements generalizing registry with + | nil => simp [sumCharges] + | cons a rest ih => + have first := cap registry a (List.mem_cons_self) + have later := ih (register registry a.queryPrefix a.root a.shape) + (fun r b member => cap r b (List.mem_cons_of_mem a member)) + simp only [sumCharges,List.length_cons] + nlinarith + +def extractionCharge (registry : Registry) (a : Announcement) : Nat := + match registry[cacheKey a.root a.shape]? with + | some _ => 0 + | none => 1 + +def imageSlots (a : Announcement) : Nat := + ((imageTable (sourceCells a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied)).toList.map Array.size).sum + +def compactSlots (a : Announcement) : Nat := + ((compactTable (sourceCells a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied)).toList.map Array.size).sum + +/-- Actual replay operations, map invocations, fused node visits and codec-input +byte volume; cell/raw-array pushes, materialized slots and a full-image-word +upper charge for zero-prefix traversal. These are data-operation metrics. -/ +def operationCharge (registry : Registry) (a : Announcement) : Nat := + match registry[cacheKey a.root a.shape]? with + | some _ => 1 + | none => 2 + (PublicCost.recordsFrom a.queryPrefix a.queryPrefix).2 + + (countedBuild (records a.queryPrefix)).2 + + (countedCells canonicalCodec (build (records a.queryPrefix)) a.shape.leafWords a.shape.occupied + (defaultCell a.shape.leafWords a.shape.occupied) a.shape.height a.root #[]).2 + + inputByteVolume canonicalCodec (build (records a.queryPrefix)) a.shape.height a.root + + 2*(sourceCells a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied).size + + 2*imageSlots a + compactSlots a + +def wordCharge (registry : Registry) (a : Announcement) : Nat := + match registry[cacheKey a.root a.shape]? with + | some _ => 0 + | none => imageSlots a + compactSlots a + +def cellCharge (registry : Registry) (a : Announcement) : Nat := + match registry[cacheKey a.root a.shape]? with + | some _ => 0 + | none => (sourceCells a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied).size + +def prefixCharge (registry : Registry) (a : Announcement) : Nat := + match registry[cacheKey a.root a.shape]? with + | some _ => 0 + | none => a.queryPrefix.length + +def operationBudget (Q N leafWords occupied : Nat) : Nat := + 2+Q*(20000*(Q+2)*(Q+2)+1)+Q+4*N+2*N*(64*(Q+2))+2*N*leafWords+N*occupied + +theorem cached_charges (registry : Registry) (a : Announcement) (frozen : Frozen) + (known : registry[cacheKey a.root a.shape]? = some frozen) : + operationCharge registry a = 1 ∧ extractionCharge registry a = 0 ∧ + wordCharge registry a = 0 ∧ cellCharge registry a = 0 ∧ prefixCharge registry a = 0 := by + simp [operationCharge,extractionCharge,wordCharge,cellCharge,prefixCharge,known] + +theorem announcement_charges (registry : Registry) (a : Announcement) (Q N leafWords occupied : Nat) + (queryCap : a.queryPrefix.length ≤ Q) (rowCap : 2^a.shape.height ≤ N) + (leafCap : a.shape.leafWords ≤ leafWords) (widthCap : a.shape.occupied ≤ occupied) + (fits : a.shape.occupied ≤ a.shape.leafWords) : + operationCharge registry a ≤ operationBudget Q N leafWords occupied ∧ + extractionCharge registry a ≤ 1 ∧ wordCharge registry a ≤ N*(leafWords+occupied) ∧ + cellCharge registry a ≤ N ∧ prefixCharge registry a ≤ Q := by + have resources := actual_resource_contract a.queryPrefix a.root a.shape.height + a.shape.leafWords Q (2^a.shape.height) queryCap rfl + obtain ⟨saturation,inserts,_index,_payload,_visits,_rows,_words⟩ := resources + have visits := source_visit_budget a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied + have bytes := public_input_byte_volume a.queryPrefix a.root a.shape.height Q N queryCap rowCap + have cells := sourceCells_size a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied + have images := image_word_slots a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied + have suffix := compact_word_slots a.queryPrefix a.root a.shape.height a.shape.leafWords a.shape.occupied fits + have imageCap : imageSlots a ≤ N*leafWords := images.trans (Nat.mul_le_mul rowCap leafCap) + have suffixCap : compactSlots a ≤ N*occupied := suffix.trans (Nat.mul_le_mul rowCap widthCap) + unfold operationCharge extractionCharge wordCharge cellCharge prefixCharge + cases registry[cacheKey a.root a.shape]? with + | some frozen => simp only []; unfold operationBudget; omega + | none => + simp only [] + refine ⟨?_,by omega,?_,by omega,queryCap⟩ + · unfold operationBudget + rw [cells] + nlinarith + · nlinarith [imageCap,suffixCap] + +/-- Every configuration announcement is counted, even if all CVs coincide. -/ +theorem registration_resources (registry : Registry) (announcements : List Announcement) + (Q N leafWords occupied : Nat) + (caps : ∀ a ∈ announcements, a.queryPrefix.length ≤ Q ∧ + 2^a.shape.height ≤ N ∧ a.shape.leafWords ≤ leafWords ∧ + a.shape.occupied ≤ occupied ∧ a.shape.occupied ≤ a.shape.leafWords) : + (registerAll registry announcements).size ≤ registry.size+announcements.length ∧ + sumCharges operationCharge registry announcements ≤ + announcements.length*operationBudget Q N leafWords occupied ∧ + sumCharges extractionCharge registry announcements ≤ announcements.length ∧ + sumCharges wordCharge registry announcements ≤ announcements.length*(N*(leafWords+occupied)) ∧ + sumCharges cellCharge registry announcements ≤ announcements.length*N ∧ + sumCharges prefixCharge registry announcements ≤ announcements.length*Q := by + have charged : ∀ r a, a ∈ announcements → + operationCharge r a ≤ operationBudget Q N leafWords occupied ∧ + extractionCharge r a ≤ 1 ∧ wordCharge r a ≤ N*(leafWords+occupied) ∧ + cellCharge r a ≤ N ∧ prefixCharge r a ≤ Q := by + intro r a member + obtain ⟨queryCap,rowCap,leafCap,widthCap,fits⟩ := caps a member + exact announcement_charges r a Q N leafWords occupied queryCap rowCap leafCap widthCap fits + refine ⟨registerAll_size_le registry announcements, + sumCharges_bound operationCharge registry announcements _ + (fun r a member => (charged r a member).1),?_, + sumCharges_bound wordCharge registry announcements _ + (fun r a member => (charged r a member).2.2.1), + sumCharges_bound cellCharge registry announcements _ + (fun r a member => (charged r a member).2.2.2.1), + sumCharges_bound prefixCharge registry announcements _ + (fun r a member => (charged r a member).2.2.2.2)⟩ + simpa only [Nat.mul_one] using sumCharges_bound extractionCharge registry announcements 1 + (fun r a member => (charged r a member).2.1) + +end Whir.PCSBCSMerkleRootCache diff --git a/verification/whir/Whir/PCSBCSMerkleRootCacheTransport.lean b/verification/whir/Whir/PCSBCSMerkleRootCacheTransport.lean new file mode 100644 index 000000000..8091567dd --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleRootCacheTransport.lean @@ -0,0 +1,56 @@ +import Whir.PCSBCSMerkleRootCache +import Whir.PCSBCSMerkleOpenedTable +import Whir.PCSBCSMerkleFullSourceTransport + +/-! Cache transport retains full images and literal compact suffixes separately. +Lookup supplies height, full image width and occupied width. Availability and +zero-prefix authentication are concluded only from accepted source openings. -/ +namespace Whir.PCSBCSMerkleRootCache +open Concrete FiatShamirGame PublicMerkleLog PublicMerkleBinding MerkleTransport +open MerkleQueryLogExtraction PCSBCSMerkleQueryLog PCSBCSMerkleLeafImages + +theorem cached_opened_table (C : DuplexModeGame.PrimitiveOracle) (registry : Registry) + (valid : WellFormed registry) (root : Digest32) (frozen : Frozen) + (proof : PrunedMerklePaths) (numLeaves leafWords occupied : Nat) + (queries : List Nat) (output : List RawPath) + (known : registry[cacheKey root ⟨numLeaves.log2,leafWords,occupied⟩]? = some frozen) + (auth : AuthenticLog C frozen.queryPrefix) + (accepted : proof.open (hash C) root numLeaves queries occupied leafWords = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : + List.Forall₂ (fun q p => frozen.raw[q]! = + (p.leafData.drop (leafWords-occupied)).toArray ∧ + (frozen.cells[q]?).map (fun cell => (cell.available,cell.paddingValid)) = some (true,true)) + queries output ∨ OpenPrimitiveBad C frozen.queryPrefix root output := by + have provenance := valid root ⟨numLeaves.log2,leafWords,occupied⟩ frozen known + have rows : frozen.raw = compactTable + (sourceCells frozen.queryPrefix root numLeaves.log2 leafWords occupied) := + congrArg Frozen.raw provenance + have cells : frozen.cells = sourceCells frozen.queryPrefix root numLeaves.log2 leafWords occupied := + congrArg Frozen.cells provenance + rcases PCSBCSMerkleSourceRows.pruned_opened_compact C frozen.queryPrefix auth root + proof numLeaves leafWords occupied queries output accepted bounds with good | bad + · left + simpa only [rows,cells] using good + · exact Or.inr bad + +/-- Successful full-wire source semantics includes the checked zero prefix +before compacting; invalid padding is a local rejection, not a bad hash event. -/ +theorem cached_opened_source (C : DuplexModeGame.PrimitiveOracle) (registry : Registry) + (valid : WellFormed registry) (root : Digest32) (frozen : Frozen) + (fullProof : PrunedMerklePaths) (numLeaves leafWords occupied : Nat) + (queries : List Nat) (output : List RawPath) + (known : registry[cacheKey root ⟨numLeaves.log2,leafWords,occupied⟩]? = some frozen) + (auth : AuthenticLog C frozen.queryPrefix) + (accepted : PCSBCSMerkleFullSourceTransport.openSource (hash C) fullProof root + numLeaves queries leafWords occupied = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : + List.Forall₂ (fun q p => frozen.raw[q]! = + (p.leafData.drop (leafWords-occupied)).toArray ∧ + (frozen.cells[q]?).map (fun cell => (cell.available,cell.paddingValid)) = some (true,true)) + queries output ∨ OpenPrimitiveBad C frozen.queryPrefix root output := by + obtain ⟨compact,_decoded,opened⟩ := PCSBCSMerkleFullSourceTransport.openSource_refines + (hash C) fullProof root numLeaves queries leafWords occupied output accepted + exact cached_opened_table C registry valid root frozen compact numLeaves leafWords occupied + queries output known auth opened bounds + +end Whir.PCSBCSMerkleRootCache diff --git a/verification/whir/Whir/PCSBCSMerkleSourceRows.lean b/verification/whir/Whir/PCSBCSMerkleSourceRows.lean index bdd89ed89..5e3638925 100644 --- a/verification/whir/Whir/PCSBCSMerkleSourceRows.lean +++ b/verification/whir/Whir/PCSBCSMerkleSourceRows.lean @@ -1,40 +1,52 @@ import Whir.PCSBCSMerkleQueryLog +import Whir.PCSBCSMerkleLeafImages import Whir.MerkleQueryLogExtractionRowsAgreement import Whir.WHIRPhysicalRows import Whir.SupportedCandidateExtraction -/-! PR600 source-width boundary: authenticated initial leaves contain occupied -lanes, not the generic model's leading zero-prefix encoding to the max fold -width. The source decoder consumes literal raw compact rows and internally uses -lanes-1-l. The verifier first fold reverses once and pads separately. These two -orders are never conflated. The Lean codecs are checked; Rust codec/asm/source -refinement remains an explicit external interface, not a security axiom here. -/ +/-! PR600 12ee source-width boundary: the authenticated image has leafWords +words, including a checked leading zero prefix; occupied words are obtained by +draining leafWords-occupied. The rectangular compact oracle retains literal +suffixes even for invalid padding, independently of availability/padding status. +Only accepted-query transport authenticates these suffixes. Decoder lane access +reverses internally; verifier coefficient/fold order remains separate. Checked +Lean codecs do not claim a complete Rust scalar/assembly refinement. -/ namespace Whir.PCSBCSMerkleSourceRows open Concrete FiatShamirGame MerkleTransport MerkleTransport.Commitments open MerkleQueryLogExtraction PCSBCSMerkleQueryLog PublicMerkleLog PublicMerkleBinding +open PCSBCSMerkleLeafImages -/-- Exact agreement with `compactBaseOracle` at ACTUAL leafWords=occupied. -No claim is made for the legacy padded leafWords=max-fold-width convention. -/ -theorem rawRoot0_eq_compactBaseOracle (C : DuplexModeGame.PrimitiveOracle) +/-- Full image agreement needs no honest-padding or availability assumption. -/ +theorem imageRoot0_eq_baseOracle (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) - (root : Digest32) (height occupied : Nat) : - rawRoot0 log root height occupied = - WHIRPhysicalRows.compactBaseOracle (hash C) - ⟨recordDomain (records log),[]⟩ root height (2^height) occupied occupied := by - have full := fullRows_eq_empty_snapshot canonicalCodec (hash C) (records log) + (root : Digest32) (height leafWords occupied : Nat) : + imageTable (sourceCells log root height leafWords occupied) = + baseOracle (hash C) ⟨recordDomain (records log),[]⟩ root height (2^height) leafWords := by + rw [imageTable_eq_full,rawRoot0_eq_fullRows] + exact fullRows_eq_empty_snapshot canonicalCodec (hash C) (records log) (records_authentic C log auth) (fun bad => clean (reconstructed_collision C log auth bad)) - root height occupied - simpa only [rawRoot0_eq_fullRows,fromPublic,WHIRPhysicalRows.compactBaseOracle, - WHIRPhysicalRows.compactBaseRow,Nat.sub_self,List.drop_zero,baseOracle] using full + root height leafWords + +/-- This is the literal suffix oracle, not a claim that every prefix is valid +or that default rows are authenticated. No all-valid-root premise is imposed. -/ +theorem compactRoot0_eq_compactBaseOracle (C : DuplexModeGame.PrimitiveOracle) + (log : PublicLog) (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) + (root : Digest32) (height leafWords occupied : Nat) : + compactTable (sourceCells log root height leafWords occupied) = + WHIRPhysicalRows.compactBaseOracle (hash C) + ⟨recordDomain (records log),[]⟩ root height (2^height) leafWords occupied := by + rw [compactTable_eq_drop,← imageTable_eq_full log root height leafWords occupied, + imageRoot0_eq_baseOracle C log auth clean] + simp [baseOracle,WHIRPhysicalRows.compactBaseOracle,WHIRPhysicalRows.compactBaseRow, + Array.map_ofFn,Function.comp_def] -/-- The compiled extractor prepares the exact raw FullRoot shape, independently -of availability. Shape-default rows do NOT authenticate absent leaves. -/ -theorem prepared_source_shape (log : PublicLog) (root : Digest32) (height occupied rows : Nat) - (count : rows = 2^height) : - (rawRoot0 log root height occupied).size = rows ∧ - ∀ row ∈ (rawRoot0 log root height occupied).toList, row.size = occupied := by +theorem prepared_source_shape (log : PublicLog) (root : Digest32) + (height leafWords occupied rows : Nat) (fits : occupied ≤ leafWords) (count : rows = 2^height) : + (compactTable (sourceCells log root height leafWords occupied)).size = rows ∧ + ∀ row ∈ (compactTable (sourceCells log root height leafWords occupied)).toList, + row.size = occupied := by subst rows - exact rawRoot0_shape log root height occupied + exact compactTable_shape log root height leafWords occupied fits /-- A coefficient-ascending view agrees with the decoder's intrinsic raw-row lane access. This theorem does not reverse the oracle supplied to the decoder. -/ @@ -55,13 +67,13 @@ theorem coefficient_lane (raw : Array (Array K)) (occupied index lane : Nat) The only failure branch is the existing observed compression game event. -/ theorem pruned_opened_rows (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) (auth : AuthenticLog C log) (root : Digest32) (proof : PrunedMerklePaths) - (numLeaves occupied : Nat) (queries : List Nat) (output : List RawPath) - (accepted : proof.open (hash C) root numLeaves queries occupied occupied = some output) + (numLeaves leafWords occupied : Nat) (queries : List Nat) (output : List RawPath) + (accepted : proof.open (hash C) root numLeaves queries occupied leafWords = some output) (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (hashing (hash C)), bytes.length < 2^64) : (∀ p ∈ output, (fromPublic log root numLeaves.log2).get (addressAbove p.leafIndex numLeaves.log2 []) = some p.leafData) ∨ OpenPrimitiveBad C log root output := by - have refined := open_refines (hash C) proof root numLeaves queries occupied occupied output accepted + have refined := open_refines (hash C) proof root numLeaves queries occupied leafWords output accepted apply opened_rows C log auth root numLeaves.log2 output · intro p hp obtain ⟨q,hq,row,hr,hw,hi,hd,hl,hdepth,hroot⟩ := forall₂_mem_right refined hp diff --git a/verification/whir/Whir/PCSBCSPublicLogExtractor.lean b/verification/whir/Whir/PCSBCSPublicLogExtractor.lean new file mode 100644 index 000000000..caabd29e2 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicLogExtractor.lean @@ -0,0 +1,64 @@ +import Whir.PCSBCSSourcePrimitiveRootBudget +import Whir.PCSBCSPublicRootExtractor + +/-! The executable public-log extractor scans the actual chronological inputs, +selects the first matching CV/height/full-image/occupied address, and runs the +real full-root Gao decoder once. It does not extract unrelated root tables. +Source acceptance and the finite-game failure bound remain separate obligations. -/ +set_option autoImplicit false +namespace Whir.PCSBCSPublicLogExtractor +open Concrete Protocol FiatShamirGame DuplexFraming DuplexPublicSimulator +open PCSBCSMerkleRootCache PCSBCSSourceRootReferences + +variable (p : ParameterBounds.Profile) (Q : Nat) + (layout : PublicLog → Node → WHIRCallerClaims.CallerLayout) + (savedAt : PublicLog → Node → AnchoredHeaderCodec.Record) + (entry : PublicLog → Node → FramedHistory) + (answers : PublicLog → Node → FiatShamirGame.Coordinate → Digest32) + (headers : PublicLog → Node → AnchoredHeaderRoots.Public) + (target : AnchoredHeaderCodec.Record) + +def selectPrefix : PublicLog → Option PublicLog + | [] => none + | (input,_) :: queryPrefix => + match selectPrefix queryPrefix with + | some captured => some captured + | none => + if (PCSBCSSourcePrimitiveRootBudget.references p Q layout savedAt entry answers headers + queryPrefix input).any (fun ref => decide + (cacheKey ref.root ref.shape = cacheKey target.root (initialShape target.shape))) then + some queryPrefix + else none + +/-- Later primitive queries cannot replace the already captured prefix or +supply new preimages to the initial word extraction. -/ +theorem selectPrefix_preserves (log captured : PublicLog) (input : Node) (digest : Digest32) + (known : selectPrefix p Q layout savedAt entry answers headers target log = some captured) : + selectPrefix p Q layout savedAt entry answers headers target ((input,digest)::log) = + some captured := by + simp only [selectPrefix,known] + +def extract {m : Nat} (lanes : Nat) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (anchorPoint : Array E) (anchorValue : E) + (log : PublicLog) : Option (CausalGame.Witness (ParameterBounds.config p) lanes) := do + let captured ← selectPrefix p Q layout savedAt entry answers headers target log + PCSBCSPublicRootExtractor.extract p lanes family points anchorPoint anchorValue captured target + +/-- Every actual returned word explains every original claim and the anchor. +No collision assumption or final success-probability premise is used here. -/ +theorem output_explains {m : Nat} (lanes : Nat) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (anchorPoint : Array E) (anchorValue : E) + (log : PublicLog) (w : CausalGame.Witness (ParameterBounds.config p) lanes) + (returned : extract p Q layout savedAt entry answers headers target lanes family points + anchorPoint anchorValue log = some w) : + ∃ captured, selectPrefix p Q layout savedAt entry answers headers target log = some captured ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) lanes + (freeze captured target.root (initialShape target.shape)).raw + family points anchorPoint anchorValue w := by + obtain ⟨captured,selected,decoded⟩ := Option.bind_eq_some_iff.mp returned + exact ⟨captured,selected,PCSBCSPublicRootExtractor.output_explains p lanes family points + anchorPoint anchorValue captured target w decoded⟩ + +#print axioms selectPrefix_preserves +#print axioms output_explains +end Whir.PCSBCSPublicLogExtractor diff --git a/verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean b/verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean new file mode 100644 index 000000000..c15eafdf8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean @@ -0,0 +1,97 @@ +import Whir.PCSBCSPublicLogExtractor + +/-! Actual BLAKE2s source-key recovery and first-image capture. The incomplete +prefix is a local missing-record fixture, not an ideal-oracle probability test. -/ +namespace Whir.PCSBCSPublicLogExtractorSmoke +open Whir Concrete Protocol FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicMerkleLog AnchoredHeaderCodec + +private def digest (n : Nat) : Digest32 := + fun i => ⟨(n / 256^i.val)%256,Nat.mod_lt _ (by decide)⟩ + +private def publicPath (cv : Digest32) (log : PublicLog) : + List DuplexEncoding.Instruction → Option (PublicLog × Node) + | [] => none + | [(block,tweak)] => some (log,⟨cv,block,tweak,true⟩) + | (block,tweak)::next::rest => + let input : Node := ⟨cv,block,tweak,true⟩ + let stored := Array.ofFn (blake2sOracle input) + let answer : Digest32 := fun i => stored[i.val]'(by simp [stored]) + publicPath answer (Whir.DuplexPublicSimulator.observe log input answer) (next::rest) + +private def require (condition : Bool) (message : String) : IO Unit := + unless condition do throw (IO.userError message) + +private def p : ParameterBounds.Profile := (⟨0,by decide⟩,⟨0,by decide⟩) +private def layout : WHIRCallerClaims.CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 15,.committed (2^15) 0],⟨0,6,7⟩,1⟩ + +def smoke : IO Unit := do + let words : List (List K) := [[0,3],[0,5],[0,7],[0,11]] + let bytes := words.map ByteCodec.wordsBytes + let leaves := bytes.map hashBlake2s + let leftBytes := List.ofFn (ByteCodec.pairBytes (leaves[0]!,leaves[1]!)) + let rightBytes := List.ofFn (ByteCodec.pairBytes (leaves[2]!,leaves[3]!)) + let rootBytes := List.ofFn (ByteCodec.pairBytes (hashBlake2s leftBytes,hashBlake2s rightBytes)) + let root := hashBlake2s rootBytes + let leafLogs := bytes.map (plan blake2sOracle) + let incomplete := (leafLogs.drop 1).flatten ++ plan blake2sOracle leftBytes ++ + plan blake2sOracle rightBytes ++ plan blake2sOracle rootBytes + let shape : Shape := ⟨2,1,1,1⟩ + let domain := digest 7 + let statement := digest 9 + let iv := PCSBCSSourceCoordinateDecoder.seedIV + let history : FramedHistory := ⟨domain,statement, + [.absorb 0 (WHIRHistory.scalarBytes (headerScalars shape root))]⟩ + let key : FiatShamirGame.Coordinate := ⟨history,.output 0⟩ + let some (queryPrefix,input) := publicPath iv incomplete (DuplexEncoding.plan key) + | throw (IO.userError "empty anchored public source path") + let target : Record := ⟨shape,root,⟨digest 41,fun _ => none,0,true,0,0⟩,[0,0],0⟩ + require (decide target.Valid) "invalid local immutable target" + let layouts := fun (_ : PublicLog) (_ : Node) => layout + let records := fun (_ : PublicLog) (_ : Node) => target + let entries := fun (_ : PublicLog) (_ : Node) => (⟨domain,statement,[]⟩ : FramedHistory) + let answers := fun (_ : PublicLog) (_ : Node) (_ : FiatShamirGame.Coordinate) => digest 0 + let headers := fun (_ : PublicLog) (_ : Node) => + (⟨iv,domain,fun s => if s = statement then some shape else none⟩ : AnchoredHeaderRoots.Public) + let refs := PCSBCSSourcePrimitiveRootBudget.references p 64 layouts records entries answers + headers queryPrefix input + let childKey := {key with terminal := .output 1} + let some (childPrefix,childInput) := publicPath iv incomplete (DuplexEncoding.plan childKey) + | throw (IO.userError "empty child-block source path") + let childLog := Whir.DuplexPublicSimulator.observe childPrefix childInput (blake2sOracle childInput) + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers + headers target childLog) == some childPrefix) + "later point block did not capture the root before its own first disclosure" + require (refs.length == 1 && refs.all (fun r => decide + (r = ⟨root,PCSBCSSourceRootReferences.initialShape shape⟩))) + "actual commitment key did not select its complete-image address" + let received := Whir.DuplexPublicSimulator.observe queryPrefix input (blake2sOracle input) + let some captured := PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers + headers target received | throw (IO.userError "public anchor root was not captured") + require (decide (captured = queryPrefix)) "capture included its challenge answer" + let first := Whir.PCSBCSMerkleRootCache.freeze captured root (PCSBCSSourceRootReferences.initialShape shape) + require (((first.cells[0]?).map (fun cell => cell.available)) == some false && + ((first.cells[1]?).map (fun cell => cell.available)) == some true) + "missing prefix image was authenticated or an available sibling was lost" + let later := plan blake2sOracle bytes[0]! ++ received + let changed := Whir.DuplexPublicSimulator.observe queryPrefix input (digest 123) + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers + headers target later) == some captured) + "later image queries replaced the first captured prefix" + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers + headers target changed) == some captured) + "current whole answer changed the captured metadata" + let some stable := PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers + headers target later | throw (IO.userError "later log lost an existing capture") + require (((((Whir.PCSBCSMerkleRootCache.freeze stable root (PCSBCSSourceRootReferences.initialShape shape)).cells[0]?).map + (fun cell => cell.available))) == some false) + "future leaf preimage entered the straight-line extraction table" + let foreign := { target with root := digest 42 } + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers + headers foreign received).isNone) "unmentioned target root was invented" + IO.println "public-log extractor smoke PASS (real BLAKE2s, anchored address, before-answer capture, unavailable status, future/current independence)" + +end Whir.PCSBCSPublicLogExtractorSmoke + +def main : IO Unit := Whir.PCSBCSPublicLogExtractorSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSPublicRootExtractor.lean b/verification/whir/Whir/PCSBCSPublicRootExtractor.lean new file mode 100644 index 000000000..7a529c98f --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicRootExtractor.lean @@ -0,0 +1,38 @@ +import Whir.PCSBCSMerkleRootCache +import Whir.PCSBCSSourceRootReferences +import Whir.PCSRoundByRoundSourceDecoderCorrectness + +/-! The executable straight-line word extractor reads one frozen public prefix. +It hashes no invented oracle reply, rewinds no prover, and authenticates no +unavailable default. Failure probability requires the source restoration and +Merkle target-hit composition; output correctness does not assume those bounds. -/ +set_option autoImplicit false +namespace Whir.PCSBCSPublicRootExtractor +open Concrete Protocol CausalGame +open PCSBCSMerkleRootCache PCSBCSSourceRootReferences + +/-- Full image hashing and compact suffix extraction are performed by the +production-shaped cache constructor before the lane-wise Gao decoder. -/ +def extract {m : Nat} (p : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (queryPrefix : PublicMerkleLog.PublicLog) (saved : AnchoredHeaderCodec.Record) := + let frozen := freeze queryPrefix saved.root (initialShape saved.shape) + PCSRoundByRoundSource.run p lanes family points anchorPoint anchorValue frozen.raw + +/-- One actual returned word explains ALL original ordinary/strided/anchor +claims, not only their randomized batched linear combination. -/ +theorem output_explains {m : Nat} (p : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (queryPrefix : PublicMerkleLog.PublicLog) (saved : AnchoredHeaderCodec.Record) + (w : CausalGame.Witness (ParameterBounds.config p) lanes) + (returned : extract p lanes family points anchorPoint anchorValue queryPrefix saved = some w) : + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) lanes + (freeze queryPrefix saved.root (initialShape saved.shape)).raw + family points anchorPoint anchorValue w := + PCSRoundByRoundSource.run_output_explains p lanes family points anchorPoint anchorValue + (freeze queryPrefix saved.root (initialShape saved.shape)).raw w returned + +#print axioms output_explains +end Whir.PCSBCSPublicRootExtractor diff --git a/verification/whir/Whir/PCSBCSRestorationCertificate.lean b/verification/whir/Whir/PCSBCSRestorationCertificate.lean new file mode 100644 index 000000000..a77ba0833 --- /dev/null +++ b/verification/whir/Whir/PCSBCSRestorationCertificate.lean @@ -0,0 +1,109 @@ +import Whir.PCSBCSRestorationHazard + +/-! The complete uniform-fiber certificate covers the unchanged grouped initial draw and every later source coordinate. It retains the original family, ordinary/strided points and anchor. -/ +namespace Whir.PCSBCSRestorationHazard +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge +open PCSRoundByRoundTranscriptState PCSStateRestoration.Adaptive +open Classical + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +instance raw_nonempty {c : Config} (q : Coordinate c) : Nonempty (PCSBCSRounds.Raw q) := by + cases q <;> unfold PCSBCSRounds.Raw WHIRHistory.StackSample Sample <;> infer_instance + +section Source +variable {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + +theorem snapshot_indexed_answers (root : BaseOracle) (ring : RingPCSGame.Prefix) + (t : Tape (config p)) (answers : Array Reply) (q : Coordinate (config p)) : + publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot ring t + (replies (ExecutionShapes.Input p lanes root (OriginalClaimsChecker.input prepared root ring).claims) + (indexedStrategy answers) t) q) = + publicState p lanes family points anchorPoint anchorValue prepared root (snapshot ring t answers q) := by + rw [snapshot_publicState_source p lanes family points anchorPoint anchorValue prepared root + (fun _ => indexedStrategy answers) ring t q] + unfold publicState sourceState + simp only [snapshot_ring, true_and] + split_ifs + · rfl + · rw [snapshot_state_congr] + +theorem initial_fiber (familyCap : m ≤ 2^64) (claimCap : points.size + 2 ≤ 2^64) + (data : PublicData (config p)) : + Soundness.uniformProb (Finset.univ.filter fun draw : PCSBCSRounds.Raw (.initial : Coordinate (config p)) => + (certificate p lanes family points anchorPoint anchorValue prepared).after data .initial draw = true) ≤ + rbrError := by + let strategy : RingPCSGame.Prefix → Strategy := fun _ => indexedStrategy data.trace.answers + have source := literal_initial_grouped_transition p lanes family points anchorPoint anchorValue prepared + data.root strategy familyCap claimCap data.trace.tape (fun _ => True) + have event (draw : RingPCSGame.Prefix × E) : + publicState p lanes family points anchorPoint anchorValue prepared data.root + (snapshot draw.1 (set .initial data.trace.tape draw.2) + (replies (ExecutionShapes.Input p lanes data.root + (OriginalClaimsChecker.input prepared data.root draw.1).claims) (strategy draw.1) + (set .initial data.trace.tape draw.2)) .initial) = + (certificate p lanes family points anchorPoint anchorValue prepared).after data .initial draw := by + exact snapshot_indexed_answers p lanes family points anchorPoint anchorValue prepared data.root draw.1 + (set .initial data.trace.tape draw.2) data.trace.answers .initial + simpa only [true_and, event] using source + +theorem noninitial_fiber (claimCap : points.size + 2 ≤ 2^64) (data : PublicData (config p)) + (q : Coordinate (config p)) (different : q ≠ .initial) + (undoomed : (certificate p lanes family points anchorPoint anchorValue prepared).before data q = false) : + Soundness.uniformProb (Finset.univ.filter fun answer : PCSBCSRounds.Raw q => + (certificate p lanes family points anchorPoint anchorValue prepared).after data q answer = true) ≤ rbrError := by + have positive := noninitial_positive q different + have incoming : laterBefore p lanes family points anchorPoint anchorValue prepared data q positive = false := by + simpa only [certificate, before, dite_eq_right different] using undoomed + have bound := later_fiber p lanes family points anchorPoint anchorValue prepared claimCap data q positive incoming + cases q with + | initial => exact False.elim (different rfl) + | fold i j => + simp only [certificate, after] + convert bound using 1; congr 1 + | ood i j => + simp only [certificate, after] + convert bound using 1; congr 1 + | query i => + simp only [certificate, after] + convert bound using 1; congr 1 + | tail j => + simp only [certificate, after] + convert bound using 1; congr 1 + +theorem source_conditionalHazard (familyCap : m ≤ 2^64) (claimCap : points.size + 2 ≤ 2^64) : + ConditionalHazard (certificate p lanes family points anchorPoint anchorValue prepared) rbrError := by + apply conditionalHazard_of_uniform + intro data q incoming + by_cases initial : q = .initial + · subst q + exact initial_fiber p lanes family points anchorPoint anchorValue prepared familyCap claimCap data + · exact noninitial_fiber p lanes family points anchorPoint anchorValue prepared claimCap data q initial incoming + +noncomputable def keyedCertificate {Key : Type*} (round : Key → Coordinate (config p)) : + Certificate Key (fun key => PCSBCSRounds.Raw (round key)) (PublicData (config p)) := + ⟨fun data key => (certificate p lanes family points anchorPoint anchorValue prepared).before data (round key), + fun data key answer => (certificate p lanes family points anchorPoint anchorValue prepared).after data + (round key) answer⟩ + +theorem keyed_conditionalHazard {Key : Type*} [DecidableEq Key] + (round : Key → Coordinate (config p)) (familyCap : m ≤ 2^64) (claimCap : points.size + 2 ≤ 2^64) : + ConditionalHazard (keyedCertificate p lanes family points anchorPoint anchorValue prepared round) rbrError := by + intro data key incoming + exact source_conditionalHazard p lanes family points anchorPoint anchorValue prepared + familyCap claimCap data (round key) incoming +end Source + +#print axioms snapshot_indexed_answers +#print axioms initial_fiber +#print axioms noninitial_fiber +#print axioms source_conditionalHazard +#print axioms keyed_conditionalHazard +end Whir.PCSBCSRestorationHazard diff --git a/verification/whir/Whir/PCSBCSRestorationHazard.lean b/verification/whir/Whir/PCSBCSRestorationHazard.lean new file mode 100644 index 000000000..48965ee61 --- /dev/null +++ b/verification/whir/Whir/PCSBCSRestorationHazard.lean @@ -0,0 +1,126 @@ +import Whir.PCSRoundByRoundPublicTransition +import Whir.PCSStateRestorationAdaptive + +/-! The restoration hazard is instantiated with the actual additive source RBR predicate, not an assumed soundness probability. Metadata contains only a frozen raw root and an observed public trace. -/ +namespace Whir.PCSBCSRestorationHazard +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge +open PCSRoundByRoundTranscriptState PCSStateRestoration.Adaptive +open Classical + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +structure PublicData (c : Config) where + root : BaseOracle + trace : PublicTrace c + +theorem noninitial_positive {c : Config} (q : Coordinate c) (different : q ≠ .initial) : + 0 < position q := by + by_contra absent + apply different + exact CausalPrefix.position_injective c (by rw [CausalPositions.position_initial]; omega) + +section Source +variable {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + +noncomputable def laterBefore (data : PublicData (config p)) (q : Coordinate (config p)) + (positive : 0 < position q) : Bool := + match data.trace.ring with + | none => false + | some ring => publicState p lanes family points anchorPoint anchorValue prepared data.root + (snapshot ring data.trace.tape data.trace.answers (predecessor q positive)) + +noncomputable def laterAfter (data : PublicData (config p)) (q : Coordinate (config p)) + (answer : Sample q) : Bool := + match data.trace.ring with + | none => false + | some ring => publicState p lanes family points anchorPoint anchorValue prepared data.root + (snapshot ring (set q data.trace.tape answer) data.trace.answers q) + +noncomputable def before (data : PublicData (config p)) (q : Coordinate (config p)) : Bool := + if initial : q = .initial then false else + laterBefore p lanes family points anchorPoint anchorValue prepared data q (noninitial_positive q initial) + +noncomputable def after (data : PublicData (config p)) (q : Coordinate (config p)) : + PCSBCSRounds.Raw q → Bool := + match q with + | .initial => fun draw => publicState p lanes family points anchorPoint anchorValue prepared data.root + (snapshot draw.1 (set .initial data.trace.tape draw.2) data.trace.answers .initial) + | .fold i j => laterAfter p lanes family points anchorPoint anchorValue prepared data (.fold i j) + | .ood i j => laterAfter p lanes family points anchorPoint anchorValue prepared data (.ood i j) + | .query i => laterAfter p lanes family points anchorPoint anchorValue prepared data (.query i) + | .tail j => laterAfter p lanes family points anchorPoint anchorValue prepared data (.tail j) + +noncomputable def certificate : Certificate (Coordinate (config p)) PCSBCSRounds.Raw (PublicData (config p)) := + ⟨before p lanes family points anchorPoint anchorValue prepared, + after p lanes family points anchorPoint anchorValue prepared⟩ + +theorem later_fiber (claimCap : points.size + 2 ≤ 2^64) (data : PublicData (config p)) + (q : Coordinate (config p)) (positive : 0 < position q) + (undoomed : laterBefore p lanes family points anchorPoint anchorValue prepared data q positive = false) : + Soundness.uniformProb (Finset.univ.filter fun answer : Sample q => + laterAfter p lanes family points anchorPoint anchorValue prepared data q answer = true) ≤ rbrError := by + cases ringEq : data.trace.ring with + | none => + simp only [laterAfter, ringEq, Bool.false_eq_true, Finset.filter_false, Soundness.uniformProb, + Finset.card_empty, Nat.cast_zero, zero_div] + unfold rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + | some ring => + let strategy : RingPCSGame.Prefix → Strategy := fun _ => indexedStrategy data.trace.answers + have beforeEq : publicState p lanes family points anchorPoint anchorValue prepared data.root + (snapshot ring data.trace.tape + (replies (ExecutionShapes.Input p lanes data.root + (OriginalClaimsChecker.input prepared data.root ring).claims) (strategy ring) data.trace.tape) + (predecessor q positive)) = false := by + rw [snapshot_publicState_source] + have direct : state (roundBad p lanes data.root (OriginalClaimsChecker.input prepared data.root ring).claims + (indexedStrategy data.trace.answers)) (past (predecessor q positive)) data.trace.tape = false := by + have congruence := snapshot_state_congr p lanes data.root + (OriginalClaimsChecker.input prepared data.root ring).claims ring data.trace.tape data.trace.answers + (predecessor q positive) + -- Ring escape and the source state are retained by the same literal predicate. + unfold laterBefore at undoomed + rw [ringEq] at undoomed + unfold publicState at undoomed + simp only [snapshot_ring] at undoomed + split_ifs at undoomed with escaped + rw [congruence] at undoomed + exact undoomed + unfold sourceState + dsimp only [strategy] + have ringSafe : ¬ RingPCSGame.Escape (config p) lanes data.root family ring := by + intro escaped + unfold laterBefore at undoomed + simp only [ringEq, publicState, snapshot_ring, escaped, ↓reduceIte] at undoomed + contradiction + simp only [ringSafe, and_false, ↓reduceIte] + exact direct + have source := literal_conditional_transition p lanes family points anchorPoint anchorValue prepared + data.root strategy claimCap q positive ring data.trace.tape (fun _ => True) beforeEq + have event (answer : Sample q) : + publicState p lanes family points anchorPoint anchorValue prepared data.root + (snapshot ring (set q data.trace.tape answer) + (replies (ExecutionShapes.Input p lanes data.root + (OriginalClaimsChecker.input prepared data.root ring).claims) (strategy ring) + (set q data.trace.tape answer)) q) = + laterAfter p lanes family points anchorPoint anchorValue prepared data q answer := by + rw [snapshot_publicState_source] + unfold laterAfter + rw [ringEq] + unfold publicState sourceState + simp only [snapshot_ring, true_and] + split_ifs + · rfl + · rw [snapshot_state_congr] + simpa only [true_and, event] using source + +end Source +#print axioms noninitial_positive +#print axioms later_fiber +end Whir.PCSBCSRestorationHazard diff --git a/verification/whir/Whir/PCSBCSRestorationLiteralPath.lean b/verification/whir/Whir/PCSBCSRestorationLiteralPath.lean new file mode 100644 index 000000000..9c265ffca --- /dev/null +++ b/verification/whir/Whir/PCSBCSRestorationLiteralPath.lean @@ -0,0 +1,71 @@ +import Whir.PCSBCSRestorationTrace +import Whir.PCSBCSCallerBinding + +/-! Literal before/after identities used to link a source verifier's observed +packets to the additive RBR predicate. They do not assume a failure-probability +bound or silently identify a byte parser with the verifier. -/ +set_option autoImplicit false +namespace Whir.PCSBCSRestorationHazard +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds PCSRoundByRoundKnowledge PCSRoundByRoundTranscriptState +open PCSBCSCallerBinding + +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +def literalRaw {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (q : Coordinate c) : PCSBCSRounds.Raw q := + match q with + | .initial => (ring,get .initial t) + | .fold i j => get (.fold i j) t + | .ood i j => get (.ood i j) t + | .query i => get (.query i) t + | .tail j => get (.tail j) t + +def literalCallerData (p : Profile) (original : CallerInput p) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (config p)) (answers : Array Reply) + (q : Coordinate (config p)) : CallerData p := + ⟨original,incomingData p root ring t answers q⟩ + +noncomputable def literalState (p : Profile) (original : CallerInput p) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (config p)) (answers : Array Reply) + (q : Coordinate (config p)) : Bool := + publicState p original.lanes original.family original.points original.anchorPoint + original.anchorValue original.prepared root (snapshot ring t answers q) + +attribute [local irreducible] ParameterBounds.config + +theorem literal_after (p : Profile) (original : CallerInput p) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (config p)) (answers : Array Reply) + (q : Coordinate (config p)) : + (callerCertificate p).after (literalCallerData p original root ring t answers q) + q (literalRaw ring t q) = literalState p original root ring t answers q := by + unfold callerCertificate fixedCertificate literalCallerData literalState + cases q with + | initial => + exact incoming_after_initial p original.lanes original.family original.points + original.anchorPoint original.anchorValue original.prepared root ring t answers + | fold i j => + exact incoming_after_later p original.lanes original.family original.points + original.anchorPoint original.anchorValue original.prepared root ring t answers (.fold i j) (by intro h; cases h) + | ood i j => + exact incoming_after_later p original.lanes original.family original.points + original.anchorPoint original.anchorValue original.prepared root ring t answers (.ood i j) (by intro h; cases h) + | query i => + exact incoming_after_later p original.lanes original.family original.points + original.anchorPoint original.anchorValue original.prepared root ring t answers (.query i) (by intro h; cases h) + | tail j => + exact incoming_after_later p original.lanes original.family original.points + original.anchorPoint original.anchorValue original.prepared root ring t answers (.tail j) (by intro h; cases h) + +theorem literal_before (p : Profile) (original : CallerInput p) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (config p)) (answers : Array Reply) + (q : Coordinate (config p)) (different : q ≠ .initial) : + (callerCertificate p).before (literalCallerData p original root ring t answers q) q = + literalState p original root ring t answers (predecessor q (noninitial_positive q different)) := + incoming_before p original.lanes original.family original.points original.anchorPoint + original.anchorValue original.prepared root ring t answers q different + +#print axioms literal_after +#print axioms literal_before +end Whir.PCSBCSRestorationHazard diff --git a/verification/whir/Whir/PCSBCSRestorationTrace.lean b/verification/whir/Whir/PCSBCSRestorationTrace.lean new file mode 100644 index 000000000..314e61e76 --- /dev/null +++ b/verification/whir/Whir/PCSBCSRestorationTrace.lean @@ -0,0 +1,130 @@ +import Whir.PCSBCSRestorationCertificate +import Whir.PCSBCSRoundsAdapter + +/-! Source path metadata captures only prior public draws and the already supplied prover response. Agreement below discards every hidden future coordinate. -/ +namespace Whir.PCSBCSRestorationHazard +open Concrete Protocol CausalGame CausalProbability CausalExecution CausalStrategy +open ParameterBounds SupportedCandidateProtocol PCSRoundByRoundKnowledge +open PCSRoundByRoundTranscriptState PCSStateRestoration.Adaptive +open Classical PublicTrace + +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 10000 + +def incomingTrace {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q : Coordinate c) : PublicTrace c := + ⟨if q = .initial then none else some ring, + (fun r => if position r < position q then some (get r t) else none), + priorAnswers answers (position q)⟩ + +theorem incoming_get {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q r : Coordinate c) (observed : position r < position q) : + get r (incomingTrace ring t answers q).tape = get r t := by + simp [incomingTrace, observed] + +theorem incoming_after_get {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q r : Coordinate c) (observed : position r ≤ position q) : + get r (set q (incomingTrace ring t answers q).tape (get q t)) = get r t := by + by_cases same : r = q + · subst r + exact get_set q _ _ + · rw [get_set_ne q r _ _ same] + apply incoming_get + have unequal : position r ≠ position q := fun eq => same (CausalPrefix.position_injective c eq) + omega + +theorem past_state_prefix (p : Profile) (lanes : Nat) (root : BaseOracle) (claims : Array Claim) + (left right : Array Reply) (t u : Tape (config p)) (q : Coordinate (config p)) + (samples : ∀ r, position r ≤ position q → get r t = get r u) + (answers : ∀ n, n < position q → left[n]! = right[n]!) : + state (roundBad p lanes root claims (indexedStrategy left)) (past q) t = + state (roundBad p lanes root claims (indexedStrategy right)) (past q) u := by + have event : (∃ r ∈ past q, roundBad p lanes root claims (indexedStrategy left) r t) ↔ + (∃ r ∈ past q, roundBad p lanes root claims (indexedStrategy right) r u) := by + apply exists_congr + intro r + apply and_congr_right + intro member + have observed : position r ≤ position q := by + simpa only [past, Finset.mem_filter, Finset.mem_univ, true_and] using member + exact (round_prefix_congr p lanes root claims (indexedStrategy left) r t u + (fun s earlier => samples s (earlier.trans observed))).trans + (round_indexed_congr p lanes root claims left right r u + (fun n prior => answers n (prior.trans_le observed))) + unfold state + simp only [event] + +section Source +variable {m : Nat} (p : Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) + (prepared : OriginalClaimsChecker.Prepared (config p) lanes m family points anchorPoint anchorValue) + +theorem public_snapshot_prefix (root : BaseOracle) (ring : RingPCSGame.Prefix) + (left right : Array Reply) (t u : Tape (config p)) (q : Coordinate (config p)) + (samples : ∀ r, position r ≤ position q → get r t = get r u) + (answers : ∀ n, n < position q → left[n]! = right[n]!) : + publicState p lanes family points anchorPoint anchorValue prepared root (snapshot ring t left q) = + publicState p lanes family points anchorPoint anchorValue prepared root (snapshot ring u right q) := by + unfold publicState + simp only [snapshot_ring] + split_ifs + · rfl + · rw [snapshot_state_congr, snapshot_state_congr] + exact past_state_prefix p lanes root (OriginalClaimsChecker.input prepared root ring).claims + left right t u q samples answers + +def incomingData (root : BaseOracle) (ring : RingPCSGame.Prefix) (t : Tape (config p)) + (answers : Array Reply) (q : Coordinate (config p)) : PublicData (config p) := + ⟨root, incomingTrace ring t answers q⟩ + +theorem incoming_before (root : BaseOracle) (ring : RingPCSGame.Prefix) (t : Tape (config p)) + (answers : Array Reply) (q : Coordinate (config p)) (different : q ≠ .initial) : + (certificate p lanes family points anchorPoint anchorValue prepared).before + (incomingData p root ring t answers q) q = + publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot ring t answers (predecessor q (noninitial_positive q different))) := by + unfold certificate before laterBefore incomingData + simp only [dite_eq_right different, incomingTrace, ite_eq_right different] + apply public_snapshot_prefix p lanes family points anchorPoint anchorValue prepared + · intro r observed + apply incoming_get ring t answers q r + rw [predecessor_position] at observed + have positive := noninitial_positive q different + omega + · intro n prior + apply priorAnswers_get + rw [predecessor_position] at prior + omega + +theorem incoming_after_initial (root : BaseOracle) (ring : RingPCSGame.Prefix) + (t : Tape (config p)) (answers : Array Reply) : + (certificate p lanes family points anchorPoint anchorValue prepared).after + (incomingData p root ring t answers .initial) .initial (ring,get .initial t) = + publicState p lanes family points anchorPoint anchorValue prepared root + (snapshot ring t answers .initial) := by + unfold certificate after incomingData + apply public_snapshot_prefix p lanes family points anchorPoint anchorValue prepared + · exact fun r observed => incoming_after_get ring t answers .initial r observed + · exact fun n prior => priorAnswers_get answers (position (.initial : Coordinate (config p))) n prior + +theorem incoming_after_later (root : BaseOracle) (ring : RingPCSGame.Prefix) (t : Tape (config p)) + (answers : Array Reply) (q : Coordinate (config p)) (different : q ≠ .initial) : + laterAfter p lanes family points anchorPoint anchorValue prepared + (incomingData p root ring t answers q) q (get q t) = + publicState p lanes family points anchorPoint anchorValue prepared root (snapshot ring t answers q) := by + unfold laterAfter incomingData + simp only [incomingTrace, ite_eq_right different] + apply public_snapshot_prefix p lanes family points anchorPoint anchorValue prepared + · exact fun r observed => incoming_after_get ring t answers q r observed + · exact fun n prior => priorAnswers_get answers (position q) n prior + +end Source +#print axioms incoming_after_get +#print axioms past_state_prefix +#print axioms public_snapshot_prefix +#print axioms incoming_before +#print axioms incoming_after_later +#print axioms incoming_after_initial +end Whir.PCSBCSRestorationHazard diff --git a/verification/whir/Whir/PCSBCSRoundsAdapter.lean b/verification/whir/Whir/PCSBCSRoundsAdapter.lean new file mode 100644 index 000000000..ff13d5d7d --- /dev/null +++ b/verification/whir/Whir/PCSBCSRoundsAdapter.lean @@ -0,0 +1,158 @@ +import Whir.PCSBCSRounds +import Whir.AnchoredPhysicalAnchor +import Whir.AnchoredSourceFreshCaller + +/-! Operative regrouping of the actual PCS coin tape and native anchored opening +verifier. The original record is a fixed prior input. Neither its original anchor +sample nor commitment is a new verifier round here. Original commit-time IOP and +whole-system Flock/bus/GKR caller randomness are deliberately outside this module. +Canonical full histories and their byte cursor are preserved; this does not +identify them with the book's hash-chain compiler or invoke its theorem. -/ +namespace Whir.PCSBCSRounds +open Concrete Protocol CausalGame CausalProbability WHIRHistory + +abbrev BookTape (c : Config) := ∀ q : Coordinate c, Raw q +abbrev SourceTape (c : Config) := (E × (Fin 6 → E)) × Tape c + +/-- Lossless regrouping of source chronological draws. First eight scalars are +one dependent verifier message; the other coordinates are untouched. -/ +def tapeAdapter (c : Config) : SourceTape c ≃ BookTape c where + toFun t q := match q with + | .initial => (t.1,t.2.1) + | .fold i j => get (.fold i j) t.2 + | .ood i j => get (.ood i j) t.2 + | .query i => get (.query i) t.2 + | .tail j => get (.tail j) t.2 + invFun f := ((f .initial).1, (coordinates c).symm (fun q => match q with + | .initial => (f .initial).2 + | .fold i j => f (.fold i j) + | .ood i j => f (.ood i j) + | .query i => f (.query i) + | .tail j => f (.tail j))) + left_inv t := rfl + right_inv f := by funext q; cases q <;> rfl + +noncomputable instance (c : Config) : Fintype (BookTape c) := by + unfold BookTape + infer_instance + +private def concatenate (a b : Nat) : + ((Fin a → E) × (Fin b → E)) ≃ (Fin (a+b) → E) := + (Equiv.sumArrowEquivProdArrow (Fin a) (Fin b) E).symm.trans + (Equiv.arrowCongr finSumFinEquiv (Equiv.refl E)) + +/-- Literal eight-coordinate alphabet, without padding or a stretched seed. -/ +def initialEight {c : Config} : Raw (c := c) .initial ≃ (Fin 8 → E) := + (Equiv.prodCongr + ((Equiv.prodCongr (Equiv.funUnique (Fin 1) E).symm (Equiv.refl (Fin 6 → E))).trans + (concatenate 1 6)) + (Equiv.funUnique (Fin 1) E).symm).trans (concatenate 7 1) + +/-- The complete joint uniform law is preserved, not merely its raw cardinality. -/ +theorem tape_uniform (c : Config) (event : BookTape c → Prop) : + SamplingProbability.probability (fun t : SourceTape c => event (tapeAdapter c t)) = + SamplingProbability.probability event := + SamplingProbability.probability_equiv (tapeAdapter c) event + +/-- The actual causal strategy is called only at completed grouped messages. +The ring prefix may affect every reply, but no future WHIR coin is disclosed. -/ +def bookReplies (c : Config) (inputFor : (E × (Fin 6 → E)) → Public) + (strategy : (E × (Fin 6 → E)) → Strategy) (t : BookTape c) : List Reply := + let source := (tapeAdapter c).symm t + run (strategy source.1) (inputFor source.1) [] + (visibleBatches c source.2.1 (challenges c source.2)) + +theorem causal_replies_preserved (c : Config) (inputFor : (E × (Fin 6 → E)) → Public) + (strategy : (E × (Fin 6 → E)) → Strategy) (t : SourceTape c) : + bookReplies c inputFor strategy (tapeAdapter c t) = + run (strategy t.1) (inputFor t.1) [] (visibleBatches c t.2.1 (challenges c t.2)) := by + simp only [bookReplies, Equiv.symm_apply_apply] + +/-- Native acceptance including tag/length failures. Replies here are the +actual source-shaped messages, retaining authenticated rows as side data. -/ +def sourceOpening {m : Nat} (c : Config) (record : AnchoredHeaderCodec.Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (t : SourceTape c) (replies : Array Reply) : Except String Unit := do + let proof ← CausalGame.opening c (challenges c t.2) replies + AnchoredPhysicalAnchor.sourceVerify record family points t.1 t.2.1 c + (challenges c t.2) proof + +def bookOpening {m : Nat} (c : Config) (record : AnchoredHeaderCodec.Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (t : BookTape c) (replies : Array Reply) : Except String Unit := + sourceOpening c record family points ((tapeAdapter c).symm t) replies + +/-- Equality of the entire Except result: accepting and rejecting branches are +both preserved. No algebraic validity, grinding success, or honest proof premise. -/ +theorem same_acceptance_and_rejection {m : Nat} (c : Config) + (record : AnchoredHeaderCodec.Record) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (t : SourceTape c) (replies : Array Reply) : + bookOpening c record family points (tapeAdapter c t) replies = + sourceOpening c record family points t replies := by + simp only [bookOpening, Equiv.symm_apply_apply] + +/-- A model/source precondition is literal equality of the prior record and +parsed/authenticated causal messages at the audited PCS entry, not a statement +that all Rust versions refine this model. The adapter then transports the native +result for arbitrary rejecting messages as well. -/ +theorem source_model_transport {m : Nat} (c : Config) + (saved received : AnchoredHeaderCodec.Record) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (t : SourceTape c) + (sourceReplies modeledReplies : Array Reply) + (recordFixed : received = saved) (parsed : sourceReplies = modeledReplies) : + bookOpening c saved family points (tapeAdapter c t) modeledReplies = + sourceOpening c received family points t sourceReplies := by + subst received + subst sourceReplies + exact same_acceptance_and_rejection c saved family points t modeledReplies + +/-- Byte-history adapter at a live caller continuation; source normalized entry +frames are retained instead of resetting to a freshly seeded PCS statement. -/ +theorem byte_history_message_roundtrip (p : ParameterBounds.Profile) + (entry : FiatShamirGame.FramedHistory) (messages : List Pending) + (normal : WHIRHistoryKey.Normal messages) (block : Nat) : + WHIRHistoryKey.parseSteps + ((WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + entry messages block).history.frames.drop entry.frames.length) = + some messages.dropLast.reverse := + WHIRCallerPrefix.parse_outputKeyFrom _ (WHIRHistoryKey.stackWidth_positive p) + entry normal block + +/-- Every serialized prover string, including a nonce, is recovered exactly. +This is a prover-message codec, not disclosure of the verifier coin tape to an +extractor (the book's extractor input contains IOP strings only). -/ +theorem prover_message_roundtrip (message : Pending) : + decodePending message.scalars.length (encodePending message) = some message := + pending_roundtrip message + +/-- The original fresh-opening parser retains the actual prior original record; +verifier coins embedded in transformed claims do not become a new commit IOP. -/ +theorem fresh_record_fixed (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FiatShamirGame.FramedHistory) + (answers : FiatShamirGame.Coordinate → FiatShamirGame.Digest32) + (claims : AnchoredSourceCaller.Claims) + (parsed : AnchoredSourceFreshCaller.decode layout saved entry answers = some claims) : + claims.record = saved ∧ claims.caller.root = saved.root := + AnchoredSourceFreshCaller.decode_retained layout saved entry answers claims parsed + +/-- Fresh entry binds the entire original record before gamma/maps/lambda. +This actual nonempty prover frame resets the modeled output cursor; an +initial group may not silently inherit the caller's cached output tail. -/ +theorem initial_record_binding_nonempty (saved : AnchoredHeaderCodec.Record) : + scalarBytes (AnchoredHeaderCodec.openingScalars saved) ≠ [] := by + intro empty + have size := congrArg List.length empty + rw [scalarBytes_length, AnchoredHeaderCodec.openingScalars_length, + List.length_nil] at size + omega + +theorem initial_record_binding_cursor_zero (m : DuplexRefinement.Model) + (saved : AnchoredHeaderCodec.Record) : + (DuplexRefinement.modelAbsorb m + (scalarBytes (AnchoredHeaderCodec.openingScalars saved))).consumed = 0 := by + simp [DuplexRefinement.modelAbsorb, initial_record_binding_nonempty saved] + +#print axioms tape_uniform +#print axioms same_acceptance_and_rejection +#print axioms byte_history_message_roundtrip +end Whir.PCSBCSRounds diff --git a/verification/whir/Whir/PCSBCSSourceCoordinateDecoder.lean b/verification/whir/Whir/PCSBCSSourceCoordinateDecoder.lean new file mode 100644 index 000000000..9697521b4 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCoordinateDecoder.lean @@ -0,0 +1,123 @@ +import Whir.DuplexPublicSimulator + +/-! Executable inverse of the literal duplex message/template key. The byte +parser only proposes a coordinate: the final comparison checks every message +byte, seed CV, tweak and final flag, including unequal list lengths. This is a +modeled source codec, not a theorem equating arbitrary Rust executions to Lean. -/ +namespace Whir.PCSBCSSourceCoordinateDecoder +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator + +/-- The source's `PARAM_IV`, not the domain digest passed to `Duplex::new`. -/ +def seedIV : Digest32 := DuplexCompression.parameterIV + +/-- Recover a candidate using the existing frame decoder, then validate the +entire raw key. `zip` in `extractedPlan` is never trusted to validate shape. -/ +def decodeExtracted (iv : Digest32) (key : Extracted) : Option Coordinate := + match DuplexEncoding.decode (extractedPlan key) with + | none => none + | some q => + if key.message = (modeKey iv q).message ∧ key.template = (modeKey iv q).template + then some q else none + +def decode {Q : Nat} (iv : Digest32) (key : RawKey Q) : Option Coordinate := + decodeExtracted iv (expandKey key) + +theorem extractedPlan_modeKey (iv : Digest32) (q : Coordinate) : + extractedPlan (modeKey iv q) = DuplexEncoding.plan q := by + have step : ∀ p : List DuplexEncoding.Instruction, + ((p.map (fun i => (if DuplexEncoding.readRole i.2 = 1 then some iv else none, i.1))).zip + (p.map (fun i => (i.2,true)))).map (fun p => (p.1.2,p.2.1)) = p := by + intro p + induction p with + | nil => rfl + | cons i p ih => simp [ih] + unfold modeKey keyFromPlan extractedPlan + rw [step, List.reverse_reverse] + +theorem decodeExtracted_modeKey (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : decodeExtracted iv (modeKey iv q) = some q := by + simp [decodeExtracted, extractedPlan_modeKey, DuplexEncoding.decode_plan q valid] + +theorem decodeExtracted_iff (iv : Digest32) (key : Extracted) (q : Coordinate) : + decodeExtracted iv key = some q ↔ DuplexEncoding.Admissible q ∧ key = modeKey iv q := by + constructor + · intro h + unfold decodeExtracted at h + cases parsed : DuplexEncoding.decode (extractedPlan key) with + | none => simp [parsed] at h + | some candidate => + simp only [parsed] at h + split at h + · have equal := Option.some.inj h + subst candidate + have fields : key.message = (modeKey iv q).message ∧ + key.template = (modeKey iv q).template := by assumption + exact ⟨(DuplexEncoding.decode_sound parsed).1, + by cases key; exact congrArg₂ Extracted.mk fields.1 fields.2⟩ + · cases h + · rintro ⟨valid, rfl⟩ + exact decodeExtracted_modeKey iv q valid + +theorem decode_iff {Q : Nat} (iv : Digest32) (key : RawKey Q) (q : Coordinate) : + decode iv key = some q ↔ DuplexEncoding.Admissible q ∧ expandKey key = modeKey iv q := + decodeExtracted_iff iv (expandKey key) q + +/-- Exact left inverse, uniformly over all data-valued domains, statements, +caller frames, nonce values and all three terminal constructors. -/ +theorem decode_constructionKey (Q : Nat) (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (bound : pathCost q ≤ Q) : + decode iv (constructionKey Q iv q bound) = some q := by + simp only [decode, expand_constructionKey] + exact decodeExtracted_modeKey iv q valid + +theorem decode_pathBound {Q : Nat} {iv : Digest32} {key : RawKey Q} {q : Coordinate} + (decoded : decode iv key = some q) : pathCost q ≤ Q := by + have same := (decode_iff iv key q).mp decoded |>.2 + have lengths := congrArg (fun e : Extracted => e.message.length) same + simp only [expandKey, expandShort, List.length_ofFn, (modeKey_lengths iv q).1] at lengths + have bound := key.1.1.isLt + omega + +/-- Public compression-chain recovery, with no reconstruction oracle. -/ +def recover (Q : Nat) (iv : Digest32) (log : PublicLog) (input : Node) : Option Coordinate := + (privateKey Q log input).bind (decode iv) + +theorem recover_of_modeKey {Q : Nat} {iv : Digest32} {log : PublicLog} {input : Node} + {key : RawKey Q} {q : Coordinate} (found : privateKey Q log input = some key) + (valid : DuplexEncoding.Admissible q) (same : expandKey key = modeKey iv q) : + recover Q iv log input = some q := by + simp only [recover, found, Option.bind_some] + exact (decode_iff iv key q).mpr ⟨valid,same⟩ + +/-- Source shape is supplied by the actual recognized coordinate tree; key +recovery itself remains the existing executable public-log algorithm. -/ +theorem recover_of_coordinateTree {Q : Nat} {iv : Digest32} {log : PublicLog} {input : Node} + (c : Compression) (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (fresh : lookup log input = none) + (recognizedTree : recognized log input = some (coordinateTree c iv q)) + (budget : log.length+1 ≤ Q) : recover Q iv log input = some q := by + obtain ⟨key,found,extracted⟩ := privateKey_of_recognized fresh recognizedTree budget + have same : expandKey key = modeKey iv q := + Option.some.inj (extracted.symm.trans (coordinateTree_key c iv q valid)) + exact recover_of_modeKey found valid same + +theorem recover_sound {Q : Nat} {iv : Digest32} {log : PublicLog} {input : Node} {q : Coordinate} + (recovered : recover Q iv log input = some q) : + ∃ key ns, privateKey Q log input = some key ∧ recognized log input = some ns ∧ + Complete ns ∧ extract ns = some (modeKey iv q) ∧ DuplexEncoding.Admissible q ∧ + pathCost q ≤ Q := by + unfold recover at recovered + cases found : privateKey Q log input with + | none => simp [found] at recovered + | some key => + simp only [found, Option.bind_some] at recovered + obtain ⟨ns,tree,complete,extracted⟩ := privateKey_sound found + obtain ⟨valid,same⟩ := (decode_iff iv key q).mp recovered + exact ⟨key,ns,rfl,tree,complete,by simpa only [same] using extracted,valid, + decode_pathBound recovered⟩ + +#print axioms decode_constructionKey +#print axioms decode_iff +#print axioms recover_of_coordinateTree +#print axioms recover_sound +end Whir.PCSBCSSourceCoordinateDecoder diff --git a/verification/whir/Whir/PCSBCSSourceCoordinateDecoderProvenance.lean b/verification/whir/Whir/PCSBCSSourceCoordinateDecoderProvenance.lean new file mode 100644 index 000000000..6f32a5ef5 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCoordinateDecoderProvenance.lean @@ -0,0 +1,78 @@ +import Whir.PCSBCSSourceCoordinateDecoderSource +import Whir.PublicCompressionCouplingTerminalSupport + +/-! Decoding actual private raw queries preserves their existing public-terminal +or inspected-construction provenance. Non-source supermode keys may be rejected; +no reconstruction oracle or byte/frame equivalence premise is introduced. -/ +namespace Whir.PCSBCSSourceCoordinateDecoder +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionCouplingRecognition PublicCompressionCouplingMixed RawOracleCoupling +open TypedOracleCompiler (Sampling) + +-- Use the public simulator's executable dictionary at its memo endpoint. +local instance : DecidableEq Node := DuplexPublicSimulator.instDecidableEqNode + +/-- Actual public recovery has both a literal coordinate and public compression +input/output provenance, not merely a coordinate supplied by a caller. -/ +theorem recover_public_provenance {Q : Nat} {iv : Digest32} {log : PublicLog} + {input : Node} {q : Coordinate} (recovered : recover Q iv log input = some q) : + ∃ rest, Complete (input::rest) ∧ PublicBody log input.cv rest ∧ + extract (input::rest) = some (modeKey iv q) ∧ DuplexEncoding.Admissible q := by + obtain ⟨key,ns,found,recognized,complete,extracted,valid,_⟩ := recover_sound recovered + obtain ⟨rest,rfl,body⟩ := recognized_publicBody recognized + exact ⟨rest,complete,body,extracted,valid⟩ + +/-- In the real causal compiler, successful decoding either retains an actual +public terminal witness or identifies the literal inspected construction. -/ +theorem causalCompile_decoded_origin {R : Type} (Q : Nat) (seedTable : Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (log : PublicLog) (p : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) + (auth : NonterminalAuthentic seedTable log) {key : RawKey Q} {answer : Digest32} + {q : Coordinate} (decoded : decode iv key = some q) + (member : (⟨.inr key,answer⟩ : Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seedTable ro) (causalCompile Q iv log p remaining cap counted)).2) : + (∃ input rest, Complete (input::rest) ∧ Tree (compressionOf seedTable) input.cv rest ∧ + extract (input::rest) = some (modeKey iv q) ∧ + PublicBody (finalLog log (Sampling.eval (oracle seedTable ro) + (compile Q iv log p remaining cap counted)).observations) input.cv rest) ∨ + (∃ construction ∈ (Sampling.eval (oracle seedTable ro) + (causalCompile Q iv log p remaining cap counted)).2, construction.coordinate = q) := by + have same := (decode_iff iv key q).mp decoded |>.2 + rcases causalCompile_raw_origin Q seedTable ro iv log p remaining cap counted auth member with + publicOrigin | construction + · obtain ⟨input,rest,complete,tree,extracted,body⟩ := publicOrigin + exact Or.inl ⟨input,rest,complete,tree,by simpa only [same] using extracted,body⟩ + · obtain ⟨construction,inspected,bound,equal⟩ := construction + have leftInverse := decode_constructionKey Q iv construction.coordinate construction.valid bound + rw [← equal, decoded] at leftInverse + exact Or.inr ⟨construction,inspected,Option.some.inj leftInverse.symm⟩ + +open Classical in +/-- The actual hidden-guess-complement support theorem, now with an executable +coordinate inverse. The source boundary is successful canonical decoding (or +`decode_of_sourceShape`), not a universal claim about arbitrary raw keys. -/ +theorem actual_decoded_terminal_support {R : Type} (Q : Nat) (iv : Digest32) (p : Program R) + (counted : Counts Q p) (seedTable : Seed) (ro : RawKey Q → Digest32) + (quiet : hiddenGuess Q iv p counted (oracle seedTable ro)=false) + {key : RawKey Q} {answer : Digest32} {q : Coordinate} + (decoded : decode iv key = some q) + (stored : (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 (.inr key)=some answer) : + ∃ input rest, Complete (input::rest) ∧ Tree (compressionOf seedTable) input.cv rest ∧ + extract (input::rest) = some (modeKey iv q) ∧ + (∀ n ∈ rest, (Sampling.eval (oracle seedTable ro) + (memo (causalCompile Q iv [] p Q (by rfl) counted) (fun _ => none))).2 + (.inl n)=some (seedTable n)) ∧ + (input.cv ∈ publicCVTargets (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations → + PublicBody (finalLog [] (Sampling.eval (oracle seedTable ro) + (compile Q iv [] p Q (by rfl) counted)).observations) input.cv rest) := by + obtain ⟨input,rest,complete,tree,extracted,cached,publicBody⟩ := + actual_terminal_support Q iv p counted seedTable ro quiet stored + have same := (decode_iff iv key q).mp decoded |>.2 + exact ⟨input,rest,complete,tree,by simpa only [same] using extracted,cached,publicBody⟩ + +#print axioms recover_public_provenance +#print axioms causalCompile_decoded_origin +#print axioms actual_decoded_terminal_support +end Whir.PCSBCSSourceCoordinateDecoder diff --git a/verification/whir/Whir/PCSBCSSourceCoordinateDecoderSmoke.lean b/verification/whir/Whir/PCSBCSSourceCoordinateDecoderSmoke.lean new file mode 100644 index 000000000..000192c06 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCoordinateDecoderSmoke.lean @@ -0,0 +1,88 @@ +import Whir.PCSBCSSourceCoordinateDecoder + +namespace Whir.PCSBCSSourceCoordinateDecoderSmoke +open Whir FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PCSBCSSourceCoordinateDecoder + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +private def bytes (n salt : Nat) : List Byte := + (List.range n).map fun i => ⟨(i*17+salt)%256, Nat.mod_lt _ (by decide)⟩ + +private def digest (salt : Nat) : Digest32 := fun i => + ⟨(i.val*13+salt)%256, Nat.mod_lt _ (by decide)⟩ + +/-- Store compression replies as data before taking the next step. The log +contains real primitive inputs/replies only, never semantic recovery hints. -/ +private def publicPath (cv : Digest32) (log : PublicLog) : + List DuplexEncoding.Instruction → Option (PublicLog × Node) + | [] => none + | [(block,tweak)] => some (log,⟨cv,block,tweak,true⟩) + | (block,tweak) :: next :: rest => + let node : Node := ⟨cv,block,tweak,true⟩ + let stored := Array.ofFn (blake2sOracle node) + let answer : Digest32 := fun i => stored[i.val]'(by simp [stored]) + publicPath answer (observe log node answer) (next::rest) + +private def key? (e : Extracted) : Option (RawKey 32) := + if hm : e.message.length ≤ 32 then + if ht : e.template.length ≤ 32 then some (restrictKey 32 e hm ht) else none + else none + +private def rejects (e : Extracted) : Bool := + match key? e with + | none => false + | some key => (decode seedIV key).isNone + +private def check (label : String) (passed : Bool) : IO Unit := do + unless passed do throw (IO.userError (label ++ ": FAILED")) + IO.println (label ++ ": ok") + +private def coordinate (salt : Nat) (terminal : Terminal) : Coordinate := + ⟨⟨digest salt,digest (salt+11), + [.absorb 7 (bytes 65 salt), .nonce 35 3 (fun i => ⟨(i.val+salt)%256, Nat.mod_lt _ (by decide)⟩), + .absorb 0 (bytes 3 (salt+1))]⟩,terminal⟩ + +private def exercise (salt : Nat) (terminal : Terminal) : IO Unit := do + let q := coordinate salt terminal + let some (log,input) := publicPath seedIV [] (DuplexEncoding.plan q) + | throw (IO.userError "empty public compression path") + check "real-BLAKE2s public log coordinate recovery" (decide (recover 32 seedIV log input = some q)) + let some key := privateKey 32 log input + | throw (IO.userError "missing public-log raw key") + let e := expandKey key + check "all coordinate data retained" (decide (decode seedIV key = some q)) + check "foreign seed IV rejected" ((decode (digest 199) key).isNone) + let foreignTemplate := { e with template := e.template.map fun (_,last) => (UInt64.ofNat (10*2^56),last) } + check "foreign template rejected" (rejects foreignTemplate) + let badCounter := { e with template := e.template.modify 0 fun (t,last) => (t+1,last) } + check "noncanonical counter rejected" (rejects badCounter) + let badFlag := { e with template := e.template.modify 0 fun (t,_) => (t,false) } + check "compression final flag rejected" (rejects badFlag) + let badSeed := { e with message := e.message.map fun (cv,b) => + (cv.map (fun _ => digest 177),b) } + check "foreign seed CV payload rejected" (rejects badSeed) + check "truncated message rejected" (rejects { e with message := e.message.dropLast }) + check "truncated template rejected" (rejects { e with template := e.template.dropLast }) + check "truncated complete key rejected" (rejects + { message := e.message.dropLast, template := e.template.dropLast }) + check "truncated public compression log rejected" ((recover 32 seedIV log.dropLast input).isNone) + check "foreign public terminal flag rejected" ((recover 32 seedIV log { input with last := false }).isNone) + check "foreign public terminal counter rejected" ((recover 32 seedIV log { input with tweak := input.tweak+1 }).isNone) + IO.println ("actual terminal digest: " ++ DuplexCompression.hex (List.ofFn (blake2sOracle input))) + +end Whir.PCSBCSSourceCoordinateDecoderSmoke + +def main : IO Unit := do + Whir.PCSBCSSourceCoordinateDecoderSmoke.exercise 19 (.output 3) + Whir.PCSBCSSourceCoordinateDecoderSmoke.exercise 71 (.commitment 35) + Whir.PCSBCSSourceCoordinateDecoderSmoke.exercise 121 (.powBase 47 5) diff --git a/verification/whir/Whir/PCSBCSSourceCoordinateDecoderSource.lean b/verification/whir/Whir/PCSBCSSourceCoordinateDecoderSource.lean new file mode 100644 index 000000000..fedf3ad62 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCoordinateDecoderSource.lean @@ -0,0 +1,71 @@ +import Whir.PCSBCSSourceCoordinateDecoder +import Whir.PCSBCSChallengeOracleSource + +/-! The source boundary is explicit: admitted normalized frames and terminals, +a fixed PARAM_IV, a live caller entry and the source machine's `Represents` +and successful guarded squeeze. No universal Lean/Rust equality is asserted. -/ +namespace Whir.PCSBCSSourceCoordinateDecoder +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator + +/-- Canonical source syntax is additional to supermode completeness. A foreign +chosen-CV compression tree is not silently declared a duplex source history. -/ +def SourceShape (iv : Digest32) (ns : List Node) (q : Coordinate) : Prop := + Complete ns ∧ Anchored iv ns ∧ DuplexEncoding.Admissible q ∧ rawPlan ns = DuplexEncoding.plan q + +theorem decode_of_sourceShape {Q : Nat} {iv : Digest32} {ns : List Node} + {key : RawKey Q} {q : Coordinate} (shape : SourceShape iv ns q) + (extracted : extract ns = some (expandKey key)) : decode iv key = some q := by + obtain ⟨complete,anchored,valid,plan⟩ := shape + have canonical := extract_anchored iv ns complete anchored + rw [plan] at canonical + have same : expandKey key = modeKey iv q := Option.some.inj (extracted.symm.trans canonical) + exact (decode_iff iv key q).mpr ⟨valid,same⟩ + +theorem coordinateTree_sourceShape (c : Compression) (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : SourceShape iv (coordinateTree c iv q) q := + ⟨coordinateTree_complete c iv q valid.1, coordinateTree_anchored c iv q valid, + valid, coordinateTree_plan c iv q⟩ + +/-- Completeness from ordinary functional collision-free public records. The +source-shape premise is syntactic; public links are independently witnessed by +actual compression records, not by a history reconstruction oracle. -/ +theorem recover_from_publicBody {Q : Nat} {iv : Digest32} {log : PublicLog} + {input : Node} {rest : List Node} {q : Coordinate} + (functional : Functional log) (clean : ¬OutputCollision log) + (fresh : lookup log input = none) (terminal : isTerminal input) + (body : PublicBody log input.cv rest) (shape : SourceShape iv (input::rest) q) + (budget : log.length+1 ≤ Q) : recover Q iv log input = some q := by + have tree := recognized_complete functional clean terminal body + obtain ⟨key,found,extracted⟩ := privateKey_of_recognized fresh tree budget + simp only [recover,found,Option.bind_some] + exact decode_of_sourceShape shape extracted + +/-- Entry is a variable, including its data-valued domain, statement and frames; +this is not a decoder specialized to one caller prefix. -/ +theorem decode_sourcePacket {p : ParameterBounds.Profile} {Q : Nat} + {entry : FramedHistory} + {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : PCSBCSChallengeOracle.SourcePacket p Q seedIV entry q) + (block : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth q))) : + decode seedIV (packet.key block) = some (packet.coordinate block) := + decode_constructionKey Q seedIV (packet.coordinate block) (packet.valid block) (packet.pathBound block) + +/-- Source packet recovery from an actual public log, for every admitted entry. +The recognized tree and public-log budget are genuine endpoint conditions. -/ +theorem recover_sourcePacket {p : ParameterBounds.Profile} {Q : Nat} + {entry : FramedHistory} + {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : PCSBCSChallengeOracle.SourcePacket p Q seedIV entry q) + (block : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth q))) + (c : Compression) (log : PublicLog) (input : Node) + (fresh : lookup log input = none) + (tree : recognized log input = some (coordinateTree c seedIV (packet.coordinate block))) + (budget : log.length+1 ≤ Q) : + recover Q seedIV log input = some (packet.coordinate block) := + recover_of_coordinateTree c (packet.coordinate block) (packet.valid block) fresh tree budget + +#print axioms decode_of_sourceShape +#print axioms recover_from_publicBody +#print axioms decode_sourcePacket +#print axioms recover_sourcePacket +end Whir.PCSBCSSourceCoordinateDecoder diff --git a/verification/whir/Whir/PCSBCSSourcePacketTape.lean b/verification/whir/Whir/PCSBCSSourcePacketTape.lean new file mode 100644 index 000000000..01de5580d --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourcePacketTape.lean @@ -0,0 +1,264 @@ +import Whir.PCSBCSChallengeOracleEnteredErasure +import Whir.WHIRFiatShamir + +/-! Pure strict-prefix reconstruction from OTHER full source-packet fibers. +No oracle operation or ancestor-warming draw occurs here. The source metadata +assumptions are exactly SourcePacket's admitted Pending list, entry validity, +position equality, and aggregate path bound. A table is one shared, memoized +whole-packet table, not a recovery oracle. Caller snapshots, reply inversion, +frozen root accessors and acceptance are deliberately supplied by callers. +These lemmas do not assert a Fiat-Shamir endpoint. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourcePacketTape +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open PCSBCSChallengeOracle FiatShamirGame DuplexModeGame + +/-- Initial Raw is ring-prefix × initial E; all other alphabets are Sample. -/ +def project {c : Config} (q : Coordinate c) : Raw q → Sample q := + match q with + | .initial => Prod.snd + | .fold _ _ => id + | .ood _ _ => id + | .query _ => id + | .tail _ => id + +abbrev RawPrefix {c : Config} (q : Coordinate c) := + (r : Coordinate c) → position r < position q → Raw r + +/-- Named inert suffix: never sampled and never an incoming predicate input. -/ +def inertSample {c : Config} (q : Coordinate c) : Sample q := 0 + +def inertRing : RingPCSGame.Prefix := (0, fun _ => 0) + +/-- Executable realization of the existing strict-prefix tape convention. -/ +def tapeOfPrefix {c : Config} {q : Coordinate c} (past : WHIRFiatShamir.Prefix q) : Tape c := + (coordinates c).symm (fun r => if h : position r < position q then past r h else inertSample r) + +def projectedPrefix {c : Config} {q : Coordinate c} (past : RawPrefix q) : + WHIRFiatShamir.Prefix q := fun r h => project r (past r h) + +def ringOfPrefix {c : Config} {q : Coordinate c} (past : RawPrefix q) : RingPCSGame.Prefix := + if h : position (.initial : Coordinate c) < position q then (past .initial h).1 else inertRing + +/-- Unlike the inert totalized ring, this is safe to expose to a public predicate. -/ +def disclosedRing {c : Config} {q : Coordinate c} (past : RawPrefix q) : + Option RingPCSGame.Prefix := + if h : position (.initial : Coordinate c) < position q then some (past .initial h).1 else none + +theorem tapeOfPrefix_eq {c : Config} {q : Coordinate c} (past : WHIRFiatShamir.Prefix q) : + tapeOfPrefix past = past.tape := rfl + +theorem get_tapeOfPrefix {c : Config} {q r : Coordinate c} + (past : WHIRFiatShamir.Prefix q) (h : position r < position q) : + get r (tapeOfPrefix past) = past r h := by + change (coordinates c ((coordinates c).symm _)) r = _ + simp only [Equiv.apply_symm_apply, dite_eq_left h] + +theorem get_inert {c : Config} {q r : Coordinate c} + (past : WHIRFiatShamir.Prefix q) (h : ¬ position r < position q) : + get r (tapeOfPrefix past) = inertSample r := by + change (coordinates c ((coordinates c).symm _)) r = _ + simp only [Equiv.apply_symm_apply, dite_eq_right h] + +/-- Incoming predicates receive only RawPrefix, not the total tape or its +inert ring. This interface also lets the caller attach Array Reply and its +checked snapshot through a fixed closure, without exposing future values. -/ +def incoming {c : Config} {q : Coordinate c} (P : RawPrefix q → Prop) + (past : RawPrefix q) : Prop := P past + +/-- Any choice of inert suffix gives exactly the same incoming prefix. -/ +theorem incoming_ignores_suffix {c : Config} {q : Coordinate c} + (past : RawPrefix q) (suffix : ∀ r : Coordinate c, Sample r) + (P : WHIRFiatShamir.Prefix q → Prop) : + P (WHIRFiatShamir.Prefix.ofTape q + ((coordinates c).symm (fun r => if h : position r < position q + then project r (past r h) else suffix r))) ↔ P (projectedPrefix past) := by + have same : WHIRFiatShamir.Prefix.ofTape q + ((coordinates c).symm (fun r => if h : position r < position q + then project r (past r h) else suffix r)) = projectedPrefix past := by + funext r h + change (coordinates c ((coordinates c).symm _)) r = _ + simp only [Equiv.apply_symm_apply, dite_eq_left h, projectedPrefix] + rw [same] + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} + +abbrev Table := + (k : (EnteredPacket.partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Key) → + (EnteredPacket.partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Answer + (D := Digest32) k + +def rawPrefix (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) : + RawPrefix current.2.coord := fun r h => current.prefixRawFromOther other ⟨r,h⟩ + +def strictPrefix (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) : + WHIRFiatShamir.Prefix current.2.coord := projectedPrefix (rawPrefix current other) + +def tape (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) : + Tape (ParameterBounds.config p) := tapeOfPrefix (strictPrefix current other) + +def ringPrefix (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) : + RingPCSGame.Prefix := ringOfPrefix (rawPrefix current other) + +theorem rawPrefix_table (current : EnteredPacket p Q iv boundary) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) (r : current.Earlier) : + rawPrefix current (fun k => table k.val) r.val r.property = + grouped r.val (table (.inl (current.predecessor r))) := rfl + +/-- Every earlier coordinate reads its actual global-table predecessor packet. -/ +theorem get_table (current : EnteredPacket p Q iv boundary) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) (r : current.Earlier) : + get r.val (tape current (fun k => table k.val)) = + project r.val (grouped r.val (table (.inl (current.predecessor r)))) := + get_tapeOfPrefix _ r.property + +/-- The byte law is the existing contiguous grouped payload law, including +cross-block scalar slices; no cardinality-selected representation is used. -/ +theorem rawPrefix_bytes (current : EnteredPacket p Q iv boundary) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) (r : current.Earlier) + (j : Fin (rawWidth r.val * 24)) : + vectorBytes (rawWidth r.val) (rawVector r.val + (rawPrefix current (fun k => table k.val) r.val r.property)) j = + table (.inl (current.predecessor r)) ⟨j.val / 32, by + change j.val / 32 < blocks (rawWidth r.val) + have bound := packet_length (rawWidth r.val) + have hj := j.isLt + omega⟩ ⟨j.val % 32, Nat.mod_lt _ (by decide)⟩ := + grouped_payload_bytes r.val _ j + +open Classical in +/-- All reconstruction products, including any fixed caller combination, +ignore a replacement of the WHOLE selected packet (unused bytes included). -/ +theorem reconstruction_update_current {M : Type*} (current : EnteredPacket p Q iv boundary) + (build : RawPrefix current.2.coord → M) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (full : Fin (blocks (rawWidth current.2.coord)) → Digest32) : + build (rawPrefix current (fun k => Function.update table (.inl current) full k.val)) = + build (rawPrefix current (fun k => table k.val)) := by + exact current.metadata_update_current (fun _ past => build (fun r h => past ⟨r,h⟩)) table full + +/-- Nested literal Pending suffixes give the same admitted source packet. +Both packets retain the identical live entry and the same aggregate cap. -/ +theorem predecessor_comp (current : EnteredPacket p Q iv boundary) (r : current.Earlier) + (s : (current.predecessor r).Earlier) : + (current.predecessor r).predecessor s = + current.predecessor ⟨s.val, by + have hs := s.property + change position s.val < position r.val at hs + exact hs.trans r.property⟩ := by + apply Sigma.ext (by rfl) + apply heq_of_eq + apply CanonicalPacket.messages_injective + change (current.2.messages.drop (position current.2.coord - position r.val)).drop + (position r.val - position s.val) = + current.2.messages.drop (position current.2.coord - position s.val) + rw [List.drop_drop] + congr 1 + have hr := r.property + have hs := s.property + change position s.val < position r.val at hs + omega + +/-- The same global table links strict prefixes of adjacent (or any nested) +packets without chronology assumptions about the order of table queries. -/ +theorem prefix_consistent (current : EnteredPacket p Q iv boundary) (r : current.Earlier) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (s : (current.predecessor r).Earlier) : + rawPrefix (current.predecessor r) (fun k => table k.val) s.val s.property = + rawPrefix current (fun k => table k.val) s.val (by + have hs := s.property + change position s.val < position r.val at hs + exact hs.trans r.property) := by + have hs := s.property + change position s.val < position r.val at hs + let readAt : {a : EnteredPacket p Q iv boundary // a.2.coord = s.val} → Raw s.val := + fun a => a.property ▸ grouped a.val.2.coord (table (.inl a.val)) + exact congrArg readAt + (Subtype.ext (predecessor_comp current r s) : + (⟨(current.predecessor r).predecessor s,rfl⟩ : + {a : EnteredPacket p Q iv boundary // a.2.coord = s.val}) = + ⟨current.predecessor ⟨s.val,hs.trans r.property⟩,rfl⟩) + +/-- Source-history compatibility is explicit: a neighbouring packet in one +accepted history must be this literal predecessor, not just share a position. +Acceptance itself is not needed for this stronger functional equality. -/ +theorem history_prefix_consistent (current previous : EnteredPacket p Q iv boundary) + (r : current.Earlier) (history : previous = current.predecessor r) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (s : previous.Earlier) : + ∃ _h : position s.val < position current.2.coord, + get s.val (tape previous (fun k => table k.val)) = + get s.val (tape current (fun k => table k.val)) := by + subst previous + have hs := s.property + change position s.val < position r.val at hs + refine ⟨hs.trans r.property, ?_⟩ + unfold tape + rw [get_tapeOfPrefix _ s.property, get_tapeOfPrefix _ (hs.trans r.property)] + exact congrArg (project s.val) (prefix_consistent current r table s) + +theorem ring_table (current : EnteredPacket p Q iv boundary) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (h : position (.initial : Coordinate (ParameterBounds.config p)) < position current.2.coord) : + ringPrefix current (fun k => table k.val) = + (grouped .initial (table (.inl (current.predecessor ⟨.initial,h⟩)))).1 := by + simp only [ringPrefix, ringOfPrefix, dite_eq_left h] + rfl + +open Classical in +theorem tape_update_current (current : EnteredPacket p Q iv boundary) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (full : Fin (blocks (rawWidth current.2.coord)) → Digest32) : + tape current (fun k => Function.update table (.inl current) full k.val) = + tape current (fun k => table k.val) := + reconstruction_update_current current (fun past => tapeOfPrefix (projectedPrefix past)) table full + +open Classical in +theorem ring_update_current (current : EnteredPacket p Q iv boundary) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (full : Fin (blocks (rawWidth current.2.coord)) → Digest32) : + ringPrefix current (fun k => Function.update table (.inl current) full k.val) = + ringPrefix current (fun k => table k.val) := + reconstruction_update_current current ringOfPrefix table full + +/-- Adjacent literal-history packets are linked by exactly one already assigned +Raw answer, not by resampling/warming a missing ancestor. -/ +theorem adjacent_tape_step (current : EnteredPacket p Q iv boundary) (r : current.Earlier) + (adjacent : position current.2.coord = position r.val + 1) + (table : Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) : + tape current (fun k => table k.val) = + set r.val (tape (current.predecessor r) (fun k => table k.val)) + (project r.val (grouped r.val (table (.inl (current.predecessor r))))) := by + apply (coordinates (ParameterBounds.config p)).injective + funext s + change get s _ = get s _ + by_cases same : s = r.val + · subst s + rw [get_set] + exact get_table current table r + · rw [get_set_ne _ _ _ _ same] + by_cases earlier : position s < position r.val + · have consistent := prefix_consistent current r table ⟨s,earlier⟩ + unfold tape + rw [get_tapeOfPrefix (strictPrefix current (fun k => table k.val)) (earlier.trans r.property), + get_tapeOfPrefix (strictPrefix (current.predecessor r) (fun k => table k.val)) earlier] + exact congrArg (project s) consistent.symm + · have distinct : position s ≠ position r.val := + fun h => same (CausalPrefix.position_injective _ h) + have future : ¬ position s < position current.2.coord := by omega + unfold tape + rw [get_inert (strictPrefix current (fun k => table k.val)) future, + get_inert (strictPrefix (current.predecessor r) (fun k => table k.val)) earlier] + +#print axioms ring_table +#print axioms tape_update_current +#print axioms ring_update_current +#print axioms adjacent_tape_step +#print axioms get_table +#print axioms rawPrefix_bytes +#print axioms reconstruction_update_current +#print axioms predecessor_comp +#print axioms prefix_consistent +#print axioms history_prefix_consistent +#print axioms incoming_ignores_suffix +end Whir.PCSBCSSourcePacketTape diff --git a/verification/whir/Whir/PCSBCSSourcePacketTapeSmoke.lean b/verification/whir/Whir/PCSBCSSourcePacketTapeSmoke.lean new file mode 100644 index 000000000..b8de45c27 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourcePacketTapeSmoke.lean @@ -0,0 +1,134 @@ +import Whir.PCSBCSSourcePacketTape + +/-! Executable TOY functional fixture, not a production profile measurement or +an FS endpoint. Packets have a fixed literal toy Pending-history identifier; +the full block table is assigned before queries. Reading a child does not read +or disclose its parents. The actual grouped byte law and prefix/tape functions +are exercised, while source admission/caller/root provenance remain the explicit +SourcePacket obligations in the proof module (not asserted by this toy). -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourcePacketTapeSmoke +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame PCSBCSChallengeOracle PCSBCSSourcePacketTape + +def toy : Config := ⟨3, #[1,1], #[2,2], #[16,8], #[0,1]⟩ +def scalar (n : Nat) : E := ⟨UInt64.ofNat n,UInt64.ofNat (n+100),UInt64.ofNat (n+200)⟩ + +/-- A reverse-chronological history identifier, distinct for every packet. -/ +def messages (q : Coordinate toy) : List Nat := (List.range (position q + 1)).reverse + +def raw (q : Coordinate toy) : Raw q := + (rawVector q).symm (fun j => scalar (1000 * (position q + 1) + j.val)) + +/-- Includes every full 32-byte block, with nonzero unused bytes. -/ +def full (q : Coordinate toy) : Fin (blocks (rawWidth q)) → Digest32 := + (packetEquiv (rawWidth q)).symm (rawVector q (raw q), fun i => + ⟨(197+i.val)%256, Nat.mod_lt _ (by decide)⟩) + +abbrev FullTable := (q : Coordinate toy) → Fin (blocks (rawWidth q)) → Digest32 + +def assigned : FullTable := full + +/-- Only the currently selected whole fiber changes, including all unused bytes. -/ +def changed (current : Coordinate toy) : FullTable := + Function.update assigned current (fun block byte => + ⟨(block.val * 37 + byte.val + 211)%256, Nat.mod_lt _ (by decide)⟩) + +def past (current : Coordinate toy) (table : FullTable) : RawPrefix current := + fun q _ => grouped q (table q) + +def restored (current : Coordinate toy) (table : FullTable) : Tape toy := + tapeOfPrefix (projectedPrefix (past current table)) + +def payload (table : FullTable) (q : Coordinate toy) : List Byte := + (List.ofFn (fun b : Fin (blocks (rawWidth q)) => List.ofFn (table q b))).flatten + +structure Disclosure where + coord : Coordinate toy + history : List Nat + bytes : List Byte + +/-- Operational read loop. Each requested full packet is disclosed in exactly +that order, with repeats preserved. No query is inserted for an ancestor. -/ +def query (table : FullTable) (order : List (Coordinate toy)) : List Disclosure := + order.map (fun q => ⟨q,messages q,payload table q⟩) + +/-- This functional query property holds for every order, not just the smoke's +child-before-parent ordering. -/ +theorem query_at (table : FullTable) (order : List (Coordinate toy)) (n : Fin order.length) : + (query table order)[n.val]'(by simp [query]) = + ⟨order[n.val],messages order[n.val],payload table order[n.val]⟩ := by + simp [query] + +/-- Universal current-whole-packet independence of the toy strict raw prefix. -/ +theorem past_update (current : Coordinate toy) : past current (changed current) = + past current assigned := by + funext q h + have different : q ≠ current := by + intro same + subst q + exact Nat.lt_irrefl _ h + simp [past, changed, Function.update_of_ne different] + +/-- Earlier disclosure contains exactly the bytes used by the reconstruction. -/ +theorem earlier_bytes (current q : Coordinate toy) (h : position q < position current) + (j : Fin (rawWidth q * 24)) : + vectorBytes (rawWidth q) (rawVector q (past current assigned q h)) j = + assigned q ⟨j.val/32, by + have bound := packet_length (rawWidth q) + have hj := j.isLt + omega⟩ ⟨j.val%32, Nat.mod_lt _ (by decide)⟩ := + grouped_payload_bytes q _ j + +def check (b : Bool) (message : String) : IO Unit := + unless b do throw (IO.userError message) + +def smoke : IO Unit := do + let order := schedule toy + let current : Coordinate toy := .tail ⟨0,by decide⟩ + let strict := order.filter (fun q => position q < position current) + let childFirst := current :: strict.reverse ++ [current,.initial] + let disclosures := query assigned childFirst + check (disclosures.length == childFirst.length) "ancestor-warming query inserted" + check (disclosures.head?.map (fun d => d.coord) == some current) "child was not queried first" + check (disclosures.all (fun d => d.history == messages d.coord && + d.bytes == payload assigned d.coord)) "disclosed packet differed from assigned global table" + for d in disclosures do + if h : position d.coord < position current then + let reconstructed := stackSampleScalars d.coord (past current assigned d.coord h) + check (scalarBytes reconstructed == d.bytes.take (rawWidth d.coord * 24)) + "earlier disclosure payload differs from reconstructed strict prefix" + let before := restored current assigned + let after := restored current (changed current) + for q in order do + check (sampleScalars q (get q before) == sampleScalars q (get q after)) + "whole current replacement changed reconstructed tape" + if h : position q < position current then + check (sampleScalars q (get q before) == sampleScalars q (project q (raw q))) + "strict earlier tape value differs from predecessor packet projection" + check (stackSampleScalars q (past current assigned q h) == stackSampleScalars q (raw q)) + "strict earlier Raw value differs from earlier disclosed packet" + else + check (sampleScalars q (get q before) == sampleScalars q (inertSample q)) + "future/current coordinate was not inert" + check (stackSampleScalars current (grouped current (assigned current)) != + stackSampleScalars current (grouped current ((changed current) current))) + "full current packet replacement was vacuous" + check (payload assigned current != payload (changed current) current) + "full current bytes were not replaced" + let ringBefore := ringOfPrefix (past current assigned) + let ringAfter := ringOfPrefix (past current (changed current)) + check (ringBefore.1 == ringAfter.1 && List.ofFn ringBefore.2 == List.ofFn ringAfter.2) + "whole current replacement changed reconstructed ring prefix" + let parentFirst := query assigned order + for d in parentFirst do + check ((disclosures.find? (fun item => item.coord == d.coord)).map (fun item => item.bytes) == + some d.bytes) "query order changed a memoized disclosure" + IO.println s!"TOY packet tape PASS: {order.length} coordinates; child-before-parent with repeats, no warming, full current block replacement, strict disclosed byte/Raw/projected tape match, inert suffix, ring prefix, order independence" + +#print axioms query_at +#print axioms past_update +#print axioms earlier_bytes +end Whir.PCSBCSSourcePacketTapeSmoke + +def main : IO Unit := Whir.PCSBCSSourcePacketTapeSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean b/verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean new file mode 100644 index 000000000..d436f1140 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean @@ -0,0 +1,145 @@ +import Whir.PCSBCSSourceRootReferencesBudget +import Whir.PCSBCSSourceCoordinateDecoderSource +import Whir.AnchoredHeaderRoots + +/-! A public terminal costs one compression query, not its complete ancestry. +This actual-log scanner includes anchored commitment headers and opening roles, +using the conservative Q*(Q+1) target cap. Shared ancestry is not re-charged. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourcePrimitiveRootBudget +open Concrete Protocol FiatShamirGame DuplexPublicSimulator DuplexFraming +open PCSBCSMerkleRootCache PCSBCSSourceRootReferences + +variable (p : ParameterBounds.Profile) (Q : Nat) + (layout : PublicLog → Node → WHIRCallerClaims.CallerLayout) + (saved : PublicLog → Node → AnchoredHeaderCodec.Record) + (entry : PublicLog → Node → FramedHistory) + (answers : PublicLog → Node → FiatShamirGame.Coordinate → Digest32) + (headers : PublicLog → Node → AnchoredHeaderRoots.Public) + +/-- Commitment-point output blocks register the verifier-selected full image +shape before their reply. The context CV is never treated as a tree root. -/ +def anchorReferences (queryPrefix : PublicLog) (input : Node) + (key : FiatShamirGame.Coordinate) : List Reference := + match key.terminal with + | .output _ => + match AnchoredHeaderRoots.fromHistory (headers queryPrefix input) key.history with + | none => [] + | some header => [⟨header.root,initialShape header.shape⟩] + | _ => [] + +theorem anchorReferences_length (queryPrefix : PublicLog) (input : Node) + (key : FiatShamirGame.Coordinate) : + (anchorReferences headers queryPrefix input key).length ≤ 1 := by + unfold anchorReferences + cases key.terminal <;> try simp + split <;> simp + +/-- Ordinary public inputs and their strictly earlier log, with one source-key +inversion, no history oracle and no future records. Every shape is retained. -/ +def references (queryPrefix : PublicLog) (input : Node) : List Reference := + ((PCSBCSSourceCoordinateDecoder.recover Q PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input).map + (fun key => anchorReferences headers queryPrefix input key ++ + (parseReferences p (layout queryPrefix input) (saved queryPrefix input) + (entry queryPrefix input) (answers queryPrefix input) key).getD [])).getD [] + +theorem references_le (queryPrefix : PublicLog) (input : Node) : + (references p Q layout saved entry answers headers queryPrefix input).length ≤ Q+1 := by + unfold references + cases recovered : PCSBCSSourceCoordinateDecoder.recover Q + PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input with + | none => simp + | some key => + simp only [Option.map_some,Option.getD_some,List.length_append] + have anchor := anchorReferences_length headers queryPrefix input key + have opening : ((parseReferences p (layout queryPrefix input) (saved queryPrefix input) + (entry queryPrefix input) (answers queryPrefix input) key).getD []).length ≤ Q := by + cases parsed : parseReferences p (layout queryPrefix input) (saved queryPrefix input) + (entry queryPrefix input) (answers queryPrefix input) key with + | none => simp + | some refs => + simp only [Option.getD_some] + obtain ⟨_,_,_,_,_,_,_,cost⟩ := PCSBCSSourceCoordinateDecoder.recover_sound recovered + exact (parsed_reference_bound p (layout queryPrefix input) (saved queryPrefix input) + (entry queryPrefix input) (answers queryPrefix input) key refs parsed).trans cost + omega + +/-- Newest records are stored first. The accumulator avoids repeatedly copying +older announcements and captures each exact prefix at its primitive request. -/ +def scanAux : PublicLog → List Announcement → List Announcement + | [], acc => acc + | (input,_) :: queryPrefix, acc => + scanAux queryPrefix (announcements queryPrefix + (references p Q layout saved entry answers headers queryPrefix input) ++ acc) + +def scan (log : PublicLog) : List Announcement := + scanAux p Q layout saved entry answers headers log [] + +theorem scanAux_append (log : PublicLog) (left right : List Announcement) : + scanAux p Q layout saved entry answers headers log (left ++ right) = + scanAux p Q layout saved entry answers headers log left ++ right := by + induction log generalizing left with + | nil => rfl + | cons record queryPrefix ih => + rcases record with ⟨input,digest⟩ + simp only [scanAux,← List.append_assoc,ih] + +theorem scan_cons (input : Node) (digest : Digest32) (queryPrefix : PublicLog) : + scan p Q layout saved entry answers headers ((input,digest)::queryPrefix) = + scan p Q layout saved entry answers headers queryPrefix ++ + announcements queryPrefix (references p Q layout saved entry answers headers queryPrefix input) := by + simpa only [scan,scanAux,List.nil_append,List.append_nil] using + scanAux_append p Q layout saved entry answers headers queryPrefix [] + (announcements queryPrefix (references p Q layout saved entry answers headers queryPrefix input)) + +theorem scan_length (log : PublicLog) : + (scan p Q layout saved entry answers headers log).length ≤ log.length*(Q+1) := by + induction log with + | nil => simp [scan,scanAux] + | cons record queryPrefix ih => + rcases record with ⟨input,digest⟩ + have bound := references_le p Q layout saved entry answers headers queryPrefix input + simp only [scan_cons,List.length_append,announcements,List.length_map,List.length_cons] + rw [Nat.succ_mul] + omega + +/-- Shared physical queries bound the actual public log. No Q+1 target cap or +one-opening-root-per-terminal premise is used. Adaptive anchors are included. -/ +theorem register_scan (registry : Registry) (log : PublicLog) (budget : log.length ≤ Q) : + (registerAll registry (scan p Q layout saved entry answers headers log)).size ≤ + registry.size + Q*(Q+1) := by + have entries := registerAll_size_le registry (scan p Q layout saved entry answers headers log) + have count := scan_length p Q layout saved entry answers headers log + have cost : log.length*(Q+1) ≤ Q*(Q+1) := Nat.mul_le_mul_right (Q+1) budget + omega + +/-- Digest targets come from classified shape references, not a registry that +conflates equal digests at different verifier-fixed shapes. -/ +def targets (log : PublicLog) : Finset Digest32 := + ((scan p Q layout saved entry answers headers log).map (fun a => a.root)).toFinset + +theorem targets_grow : PublicMerkleProbability.RootsGrow + (targets p Q layout saved entry answers headers) := by + intro history record root member + simp only [targets,List.mem_toFinset,List.mem_map] at member ⊢ + obtain ⟨announcement,inOld,same⟩ := member + rcases record with ⟨input,digest⟩ + rw [scan_cons] + exact ⟨announcement,List.mem_append_left _ inOld,same⟩ + +theorem targets_cap (log : PublicLog) (budget : log.length ≤ Q) : + (targets p Q layout saved entry answers headers log).card ≤ Q*(Q+1) := by + have finite := List.toFinset_card_le + ((scan p Q layout saved entry answers headers log).map (fun a => a.root)) + have count := scan_length p Q layout saved entry answers headers log + have cost : log.length*(Q+1) ≤ Q*(Q+1) := Nat.mul_le_mul_right (Q+1) budget + simp only [List.length_map] at finite + exact finite.trans (count.trans cost) + +#print axioms anchorReferences_length +#print axioms references_le +#print axioms scan_length +#print axioms register_scan +#print axioms targets_grow +#print axioms targets_cap +end Whir.PCSBCSSourcePrimitiveRootBudget diff --git a/verification/whir/Whir/PCSBCSSourceReplyInversion.lean b/verification/whir/Whir/PCSBCSSourceReplyInversion.lean new file mode 100644 index 000000000..d114bc953 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceReplyInversion.lean @@ -0,0 +1,329 @@ +import Whir.PCSBCSChallengeOracleSource + +/-! Executable inverse of the actual WHIR scalar projection. Authentication is +not inferred from scalars: the parent supplies frozen, coordinate-indexed rows +and root-table access. This adapter neither assumes honest commitments nor +creates rows. A nonce is retained as rejection metadata, never a challenge. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceReplyInversion +open Concrete Protocol CausalGame CausalProbability WHIRHistory FiatShamirGame +open PCSBCSChallengeOracle + +/-- Literal source stage and phase; foreign phases reject before parsing. -/ +inductive Stage where + | initial + | fold (phase round : Nat) + | ood (phase index : Nat) + | query (phase : Nat) + | tail (round : Nat) + deriving DecidableEq, Repr + +def stage {c : Config} : CausalProbability.Coordinate c → Stage + | .initial => .initial + | .fold i j => .fold i.val j.val + | .ood i j => .ood i.val j.val + | .query i => .query i.val + | .tail j => .tail j.val + +/-- Explicit external frozen data, not a recovery oracle. At a query, `rows q` +is the COMPACT array in query-list order: frozenOracle[derivedQueries[j]], +using the Raw of that strictly earlier query packet from the reconstructed +prefix tape. It is NOT the full root oracle. By contrast `next q digest` is +the FULL next Oracle from the authenticated frozen root registry. +The parent must bind both accesses to that prior public boundary; neither may +depend on the current packet's Raw or its subsequent reply. No relation between +a digest and an honest oracle is assumed. -/ +structure FrozenOracles (c : Config) where + rows : CausalProbability.Coordinate c → Oracle + next : CausalProbability.Coordinate c → Digest32 → Oracle + +structure Inverted where + reply : Reply + nonce : Option (Nat × E) + +def inverse {c : Config} (frozen : FrozenOracles c) + (q : CausalProbability.Coordinate c) (source : Stage) (m : Pending) : Option Inverted := + if source = stage q then + (decodeReplyScalars q (frozen.next q) (frozen.rows q) m.scalars).map + (fun r => ⟨r,m.nonce⟩) + else none + +/-- Reuse the exact canonical scalar-to-digest codec used by WHIR's reply +parser. Only a final nonterminal fold announces a root, at scalar offset two. -/ +def announcedRoot {c : Config} (q : CausalProbability.Coordinate c) (m : Pending) : + Option Digest32 := + match q with + | .fold i j => + if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size then + match m.scalars with + | [_,_,a,b] => ByteCodec.scalarsToHash (a,b) + | _ => none + else none + | _ => none + +theorem announcedRoot_roundtrip (c : Config) (i : Fin c.folds.size) + (j : Fin c.folds[i.val]!) (last : j.val+1 = c.folds[i.val]!) + (later : i.val+1 < c.folds.size) (a b : E) (root : Digest32) + (nonce : Option (Nat × E)) : + announcedRoot (.fold i j) ⟨[a,b] ++ rootScalars root,nonce⟩ = some root := by + simp [announcedRoot,last,later,rootScalars,ByteCodec.scalarsToHash_hashToScalars] + +/-- Exact quotient: coefficients/claims are retained; query rows are erased; +fold next-oracles are erased; middle-fold residuals and nonterminal-boundary +residuals are erased; terminal-boundary residuals are retained. The digest is +explicit side input, fixed on both sides. Malformed tags remain rejected. -/ +def ScalarEquivalent {c : Config} (q : CausalProbability.Coordinate c) + (digest : Digest32) (a b : Reply) : Prop := + replyScalars q digest a = replyScalars q digest b + +theorem quotient_congr {c : Config} (q : CausalProbability.Coordinate c) + (digest : Digest32) (frozen : FrozenOracles c) (a b : Reply) + (same : ScalarEquivalent q digest a b) : + canonicalReply q digest (frozen.next q) (frozen.rows q) a = + canonicalReply q digest (frozen.next q) (frozen.rows q) b := by + rw [← replyScalars_roundtrip, ← replyScalars_roundtrip] + exact congrArg (fun xs => xs.bind (decodeReplyScalars q (frozen.next q) (frozen.rows q))) same + +/-- On the explicitly frozen-compatible domain, the scalar quotient is exactly +semantic equality. Normalization, not an assumption of honest commitments, +removes the unbound fields before this equivalence is asserted. -/ +theorem normalized_quotient_eq {c : Config} (q : CausalProbability.Coordinate c) + (digest : Digest32) (frozen : FrozenOracles c) (a b : Reply) + (left : canonicalReply q digest (frozen.next q) (frozen.rows q) a = some a) + (right : canonicalReply q digest (frozen.next q) (frozen.rows q) b = some b) : + ScalarEquivalent q digest a b ↔ a = b := by + constructor + · intro same + have h := quotient_congr q digest frozen a b same + rw [left, right] at h + exact Option.some.inj h + · intro same + subst b + rfl + +/-- Roundtrip is canonical equality, not equality of erased semantic fields. +Wrong terminal residual lengths reject rather than being padded or truncated. -/ +theorem scalar_roundtrip {c : Config} (frozen : FrozenOracles c) + (q : CausalProbability.Coordinate c) (digest : Digest32) (r : Reply) + (nonce : Option (Nat × E)) : + (replyScalars q digest r).bind (fun xs => inverse frozen q (stage q) ⟨xs,nonce⟩) = + (canonicalReply q digest (frozen.next q) (frozen.rows q) r).map + (fun reply => (⟨reply,nonce⟩ : Inverted)) := by + simpa [inverse] using congrArg + (Option.map (fun reply => (⟨reply,nonce⟩ : Inverted))) + (replyScalars_roundtrip q digest (frozen.next q) (frozen.rows q) r) + +theorem inverse_wrong_stage {c : Config} (frozen : FrozenOracles c) + (q : CausalProbability.Coordinate c) (source : Stage) (m : Pending) + (wrong : source ≠ stage q) : inverse frozen q source m = none := by + simp [inverse, wrong] + +theorem inverse_nonce {c : Config} (frozen : FrozenOracles c) + (q : CausalProbability.Coordinate c) (source : Stage) (m : Pending) (r : Inverted) + (parsed : inverse frozen q source m = some r) : r.nonce = m.nonce := by + unfold inverse at parsed + split at parsed + · cases h : decodeReplyScalars q (frozen.next q) (frozen.rows q) m.scalars with + | none => simp [h] at parsed + | some reply => simp only [h, Option.map_some, Option.some.injEq] at parsed; cases parsed; rfl + · contradiction + +/-- Source admission alone is syntax admission, not a claim of authenticated +rows or honest evaluation. Given the exact scalar projection, inversion equals +precisely its canonical semantic reply. -/ +theorem source_admitted_inverse {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {current : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry current) + (frozen : FrozenOracles (ParameterBounds.config p)) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) + (n : Nat) (m : Pending) (digest : Digest32) (r : Reply) + (_earlier : n < position current) + (_coordinate : (schedule (ParameterBounds.config p))[n]? = some q) + (_message : packet.messages.reverse[n+1]? = some m) + (scalars : replyScalars q digest r = some m.scalars) : + inverse frozen q (stage q) m = + (canonicalReply q digest (frozen.next q) (frozen.rows q) r).map + (fun reply => (⟨reply,m.nonce⟩ : Inverted)) := by + have h := scalar_roundtrip frozen q digest r m.nonce + rw [scalars, Option.bind_some] at h + exact h + +/-- Chronological message n+1 is the response to coordinate n. Index zero is +the empty initial Pending. Out-of-range reads reject; there is no fallback to +initial, and no lookup of a reply at the current or a future coordinate. -/ +def inverseAt {c : Config} (frozen : FrozenOracles c) (messages : List Pending) + (n : Nat) : Option Inverted := do + let q ← (schedule c)[n]? + let m ← messages.reverse[n+1]? + inverse frozen q (stage q) m + +/-- Correctness at the actual chronological source index. Stage and phase are +selected by the admitted public schedule, not by untrusted scalar contents. -/ +theorem inverseAt_source {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {current : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry current) + (frozen : FrozenOracles (ParameterBounds.config p)) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) + (n : Nat) (m : Pending) (digest : Digest32) (r : Reply) + (earlier : n < position current) + (coordinate : (schedule (ParameterBounds.config p))[n]? = some q) + (message : packet.messages.reverse[n+1]? = some m) + (scalars : replyScalars q digest r = some m.scalars) : + inverseAt frozen packet.messages n = + (canonicalReply q digest (frozen.next q) (frozen.rows q) r).map + (fun reply => (⟨reply,m.nonce⟩ : Inverted)) := by + simp only [inverseAt, coordinate, message] + exact source_admitted_inverse packet frozen q n m digest r earlier coordinate message scalars + +/-- Full semantic equality requires the frozen-field compatibility hypothesis +explicitly. Without it only canonical equality in the scalar quotient holds. -/ +theorem inverseAt_source_exact {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {current : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry current) + (frozen : FrozenOracles (ParameterBounds.config p)) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) + (n : Nat) (m : Pending) (digest : Digest32) (r : Reply) + (earlier : n < position current) + (coordinate : (schedule (ParameterBounds.config p))[n]? = some q) + (message : packet.messages.reverse[n+1]? = some m) + (scalars : replyScalars q digest r = some m.scalars) + (frozenCompatible : canonicalReply q digest (frozen.next q) (frozen.rows q) r = some r) : + inverseAt frozen packet.messages n = some ⟨r,m.nonce⟩ := by + rw [inverseAt_source packet frozen q n m digest r earlier coordinate message scalars, + frozenCompatible] + rfl + +/-- Build only the requested strict prefix. Reverse chronological storage and +the public schedule are computed once, outside the recursive array builder. -/ +def prefixReplies {c : Config} (frozen : FrozenOracles c) (messages : List Pending) + (count : Nat) : Option (Array Reply) := + let chronological := messages.reverse + let qs := schedule c + let rec loop : Nat → Option (Array Reply) + | 0 => some #[] + | n+1 => do + let prior ← loop n + let r ← (do + let q ← qs[n]? + let m ← chronological[n+1]? + inverse frozen q (stage q) m) + pure (prior.push r.reply) + loop count + +theorem prefixReplies_succ {c : Config} (frozen : FrozenOracles c) + (messages : List Pending) (n : Nat) : + prefixReplies frozen messages (n+1) = (do + let prior ← prefixReplies frozen messages n + let r ← inverseAt frozen messages n + pure (prior.push r.reply)) := rfl + +def replies {c : Config} (frozen : FrozenOracles c) (messages : List Pending) : + Option (Array Reply) := + if messages ≠ [] ∧ scheduledAdmissible c messages = true then + prefixReplies frozen messages (messages.length-1) + else none + +theorem prefixReplies_size {c : Config} (frozen : FrozenOracles c) + (messages : List Pending) (n : Nat) (answers : Array Reply) + (parsed : prefixReplies frozen messages n = some answers) : answers.size = n := by + induction n generalizing answers with + | zero => simp only [prefixReplies] at parsed; cases parsed; rfl + | succ n ih => + rw [prefixReplies_succ] at parsed + cases hp : prefixReplies frozen messages n with + | none => simp [hp] at parsed + | some prior => + cases hr : inverseAt frozen messages n with + | none => simp [hp,hr] at parsed + | some r => + simp only [hp,hr] at parsed + cases parsed + simp [ih prior hp] + +/-- The array index used by `incomingData` is exactly the source response +position, never the position of the Pending that carries that response. -/ +theorem prefixReplies_index {c : Config} (frozen : FrozenOracles c) + (messages : List Pending) (count : Nat) (answers : Array Reply) + (parsed : prefixReplies frozen messages count = some answers) + (n : Nat) (earlier : n < count) : + (inverseAt frozen messages n).map Inverted.reply = answers[n]? := by + induction count generalizing answers with + | zero => omega + | succ count ih => + rw [prefixReplies_succ] at parsed + cases hp : prefixReplies frozen messages count with + | none => simp [hp] at parsed + | some prior => + cases hr : inverseAt frozen messages count with + | none => simp [hp,hr] at parsed + | some r => + simp only [hp,hr] at parsed + cases parsed + have size := prefixReplies_size frozen messages count prior hp + by_cases last : n = count + · subst n + rw [hr] + change some r.reply = (prior.push r.reply)[count]? + rw [← size] + simp + · have before : n < count := by omega + rw [ih prior hp before] + simp [Array.getElem?_push, size, Nat.ne_of_lt before] + +/-- A strong no-late-read property: successful prefix reconstruction is +unchanged by ANY changes outside the inverse results at strict earlier indexes. -/ +theorem prefixReplies_congr {c : Config} (f g : FrozenOracles c) + (left right : List Pending) (count : Nat) + (same : ∀ n, n < count → inverseAt f left n = inverseAt g right n) : + prefixReplies f left count = prefixReplies g right count := by + induction count with + | zero => rfl + | succ count ih => + simp only [prefixReplies_succ, ih (fun n hn => same n (by omega)), same count (by omega)] + +theorem packet_replies {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry q) (frozen : FrozenOracles (ParameterBounds.config p)) : + replies frozen packet.messages = prefixReplies frozen packet.messages (position q) := by + unfold replies + rw [ite_eq_left ⟨packet.nonempty,packet.admitted⟩, packet.position_eq] + +theorem packet_reply_index {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry q) (frozen : FrozenOracles (ParameterBounds.config p)) + (answers : Array Reply) (parsed : replies frozen packet.messages = some answers) + (n : Nat) (earlier : n < position q) : + (inverseAt frozen packet.messages n).map Inverted.reply = answers[n]? := by + rw [packet_replies] at parsed + exact prefixReplies_index frozen packet.messages (position q) answers parsed n earlier + +/-- Even the underlying coordinate-indexed parser cannot find a current or +future response inside a SourcePacket. This is independent of scalar values +and of the supplied oracle accessor. -/ +theorem packet_inverse_not_future {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry q) (frozen : FrozenOracles (ParameterBounds.config p)) + (n : Nat) (future : position q ≤ n) : + inverseAt frozen packet.messages n = none := by + have missing : packet.messages.reverse[n+1]? = none := by + apply List.getElem?_eq_none + rw [List.length_reverse] + have pos := packet.position_eq + omega + simp only [inverseAt, missing] + cases (schedule (ParameterBounds.config p))[n]? <;> rfl + +#print axioms announcedRoot_roundtrip +#print axioms normalized_quotient_eq +#print axioms inverse_nonce +#print axioms inverseAt_source +#print axioms inverseAt_source_exact +#print axioms prefixReplies_size +#print axioms packet_inverse_not_future +#print axioms prefixReplies_index +#print axioms prefixReplies_congr +#print axioms packet_reply_index +#print axioms quotient_congr +#print axioms scalar_roundtrip +#print axioms source_admitted_inverse +end Whir.PCSBCSSourceReplyInversion diff --git a/verification/whir/Whir/PCSBCSSourceReplyInversionIncoming.lean b/verification/whir/Whir/PCSBCSSourceReplyInversionIncoming.lean new file mode 100644 index 000000000..df6ce4f5b --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceReplyInversionIncoming.lean @@ -0,0 +1,62 @@ +import Whir.PCSBCSSourceReplyInversion +import Whir.PCSBCSRestorationTrace + +/-! Strict source-message prefixes supply precisely the reply indexes read by +incomingData. Challenges and the frozen oracle accessor remain parent inputs; +this is not a Fiat-Shamir endpoint or an authentication theorem. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceReplyInversion +open Concrete Protocol CausalGame CausalProbability WHIRHistory FiatShamirGame +open PCSBCSChallengeOracle PCSRoundByRoundTranscriptState + +/-- No padding with default replies is needed: source packet position is the +exact length of the successfully decoded semantic response array. -/ +theorem packet_reply_size {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry q) (frozen : FrozenOracles (ParameterBounds.config p)) + (answers : Array Reply) (parsed : replies frozen packet.messages = some answers) : + answers.size = position q := by + rw [packet_replies] at parsed + exact prefixReplies_size frozen packet.messages (position q) answers parsed + +theorem packet_reply_not_future {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry q) (frozen : FrozenOracles (ParameterBounds.config p)) + (answers : Array Reply) (parsed : replies frozen packet.messages = some answers) + (n : Nat) (future : position q ≤ n) : answers[n]? = none := by + apply Array.getElem?_eq_none + rw [packet_reply_size packet frozen answers parsed] + exact future + +/-- Array positions in the incoming public trace are the same positions as the +source parser. In particular message n+1 gives semantic answer n. -/ +theorem incoming_reply_index {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry q) (frozen : FrozenOracles (ParameterBounds.config p)) + (answers : Array Reply) (parsed : replies frozen packet.messages = some answers) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) + (n : Nat) (earlier : n < position q) : + ((PCSBCSRestorationHazard.incomingTrace ring t answers q).answers)[n]! = + ((inverseAt frozen packet.messages n).map Inverted.reply).getD default := by + rw [packet_reply_index packet frozen answers parsed n earlier] + change (priorAnswers answers (position q))[n]! = answers[n]?.getD default + rw [priorAnswers_get answers (position q) n earlier] + rw [getElem!_def] + cases answers[n]? <;> rfl + +theorem incomingData_reply_index {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {q : CausalProbability.Coordinate (ParameterBounds.config p)} + (packet : SourcePacket p Q iv entry q) (frozen : FrozenOracles (ParameterBounds.config p)) + (answers : Array Reply) (parsed : replies frozen packet.messages = some answers) + (root : BaseOracle) (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) + (n : Nat) (earlier : n < position q) : + ((PCSBCSRestorationHazard.incomingData p root ring t answers q).trace.answers)[n]! = + ((inverseAt frozen packet.messages n).map Inverted.reply).getD default := + incoming_reply_index packet frozen answers parsed ring t n earlier + +#print axioms packet_reply_not_future +#print axioms incomingData_reply_index + +#print axioms packet_reply_size +#print axioms incoming_reply_index +end Whir.PCSBCSSourceReplyInversion diff --git a/verification/whir/Whir/PCSBCSSourceReplyInversionSmoke.lean b/verification/whir/Whir/PCSBCSSourceReplyInversionSmoke.lean new file mode 100644 index 000000000..adb49d0b4 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceReplyInversionSmoke.lean @@ -0,0 +1,147 @@ +import Whir.PCSBCSSourceReplyInversion + +/-! Executable toy-shape smoke, not a production-profile measurement or a +Merkle/Fiat-Shamir endpoint test. Frozen rows below are explicit supplied data. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceReplyInversionSmoke +open Concrete Protocol CausalGame CausalProbability WHIRHistory +open PCSBCSSourceReplyInversion + +def toy : Config := ⟨5, #[2,1], #[2,2], #[16,8], #[0,1]⟩ +def e (n : Nat) : E := ⟨UInt64.ofNat n,UInt64.ofNat (n+100),UInt64.ofNat (n+200)⟩ +def digest : FiatShamirGame.Digest32 := fun i => ⟨i.val,by omega⟩ +def rows : Oracle := #[#[e 901,e 902],#[e 903,e 904]] +def nextRows : Oracle := #[#[e 801],#[e 802],#[e 803]] +def frozen : FrozenOracles toy := ⟨fun _ => rows,fun _ _ => nextRows⟩ +def m : Message E := ⟨e 11,e 12⟩ +def first : Coordinate toy := .initial +def middle : Coordinate toy := .fold ⟨0,by decide⟩ ⟨0,by decide⟩ +def boundary : Coordinate toy := .fold ⟨0,by decide⟩ ⟨1,by decide⟩ +def finalFold : Coordinate toy := .fold ⟨1,by decide⟩ ⟨0,by decide⟩ +def ood : Coordinate toy := .ood ⟨0,by decide⟩ ⟨0,by decide⟩ +def query : Coordinate toy := .query ⟨0,by decide⟩ +def tail : Coordinate toy := .tail ⟨0,by decide⟩ + +def check (ok : Bool) (label : String) : IO Unit := + unless ok do throw (IO.userError label) + +def get (q : Coordinate toy) (scalars : List E) + (nonce : Option (Nat × E) := none) : IO Inverted := + match inverse frozen q (stage q) ⟨scalars,nonce⟩ with + | some r => pure r + | none => throw (IO.userError s!"valid inverse rejected at {repr (stage q)}") + +/-- Public-shaped source messages at every boundary of the toy schedule. -/ +def fields (q : Coordinate toy) : List E := + match q with + | .fold i j => messageScalars m ++ + if j.val+1 = toy.folds[i.val]! then + if i.val+1 < toy.folds.size then rootScalars digest + else (List.range (2 ^ remaining toy i.val)).map e + else [] + | .ood _ _ => e 21 :: messageScalars m + | _ => messageScalars m + +def sourcePrefix (count : Nat) : List Pending := + ((List.range (count+1)).map fun n => + let q := ((schedule toy)[n]?).getD .initial + let previous := ((schedule toy)[n-1]?).getD .initial + (⟨if n = 0 then [] else fields previous, + match q with | .query _ => some (0,E.zero) | _ => none⟩ : Pending)).reverse + +def smoke : IO Unit := do + let initial ← get first (messageScalars m) + match initial.reply with + | .initial msg => check (messageScalars msg == messageScalars m) "initial coefficients" + | _ => throw (IO.userError "initial tag") + let mid ← get middle (messageScalars m) + match mid.reply with + | .fold msg next residual => + check (messageScalars msg == messageScalars m && next.isNone && residual.isEmpty) + "middle fold normalization" + | _ => throw (IO.userError "middle fold tag") + let bound ← get boundary (messageScalars m ++ rootScalars digest) + match bound.reply with + | .fold msg next residual => + check (messageScalars msg == messageScalars m && next == some nextRows && residual.isEmpty) + "nonterminal root must use supplied frozen next oracle" + | _ => throw (IO.userError "nonterminal fold tag") + check (((announcedRoot boundary ⟨messageScalars m ++ rootScalars digest,none⟩).map + (fun d => List.ofFn d)) == some (List.ofFn digest)) "exact root digest" + let residual := (List.range (2 ^ remaining toy 1)).map e + let final ← get finalFold (messageScalars m ++ residual) + match final.reply with + | .fold msg next tailValues => + check (messageScalars msg == messageScalars m && next.isNone && tailValues.toList == residual) + "terminal residual must be exact, ordered and unpadded" + | _ => throw (IO.userError "terminal fold tag") + let claim ← get ood (e 21 :: messageScalars m) + match claim.reply with + | .ood value => + check (value.value == e 21 && messageScalars value.intro == messageScalars m) + "OOD value precedes coefficients" + | _ => throw (IO.userError "OOD tag") + let answer ← get query (messageScalars m) (some (5,e 77)) + match answer.reply with + | .query actual intro => + check (actual == rows && messageScalars intro == messageScalars m) + "query must preserve supplied frozen rows" + | _ => throw (IO.userError "query tag") + check (answer.nonce == some (5,e 77)) "nonce metadata changed" + let tailAnswer ← get tail (messageScalars m) + match tailAnswer.reply with + | .tail msg => check (messageScalars msg == messageScalars m) "tail coefficients" + | _ => throw (IO.userError "tail tag") + for q in [first,middle,ood,query,tail] do + check ((inverse frozen q (stage q) ⟨[],none⟩).isNone) "empty fields accepted" + check ((inverse frozen q (stage q) ⟨[e 1],none⟩).isNone) "short fields accepted" + let long := (List.range (replyScalarCount q + 1)).map e + check ((inverse frozen q (stage q) ⟨long,none⟩).isNone) "extra fields accepted" + for fields in [messageScalars m, messageScalars m ++ [e 31], + messageScalars m ++ rootScalars digest ++ [e 32]] do + check ((inverse frozen boundary (stage boundary) ⟨fields,none⟩).isNone) + "malformed nonterminal boundary length accepted" + let noncanonical : List E := [⟨0,0,1⟩,⟨0,0,0⟩] + check ((inverse frozen boundary (stage boundary) ⟨messageScalars m ++ noncanonical,none⟩).isNone) + "noncanonical root spare limbs accepted" + for fields in [messageScalars m ++ residual.dropLast, messageScalars m ++ residual ++ [e 33]] do + check ((inverse frozen finalFold (stage finalFold) ⟨fields,none⟩).isNone) + "wrong terminal residual length accepted" + check ((inverse frozen boundary (.fold 1 1) + ⟨messageScalars m ++ rootScalars digest,none⟩).isNone) "foreign source phase accepted" + check ((inverse frozen query (.ood 0 0) ⟨messageScalars m,none⟩).isNone) + "foreign source stage accepted" + let messages : List Pending := [⟨messageScalars m,none⟩,⟨[],none⟩] + check (scheduledAdmissible toy messages) "toy initial source prefix not admitted" + match replies frozen messages with + | none => throw (IO.userError "admitted initial reply prefix rejected") + | some answers => check (answers.size == 1) "source response off-by-one" + check ((inverseAt frozen messages 1).isNone) "late/current reply read" + check ((inverseAt frozen messages 100).isNone) "future reply read" + check ((replies frozen []).isNone) "empty source packet accepted" + check ((replies frozen [⟨[e 1],none⟩]).isNone) "malformed initial Pending accepted" + for count in List.range (depth toy) do + let source := sourcePrefix count + check (scheduledAdmissible toy source) s!"source admission failed at {count}" + match replies frozen source with + | none => throw (IO.userError s!"full source prefix rejected at {count}") + | some answers => + check (answers.size == count) "strict source-prefix array length" + for n in List.range count do + let q := ((schedule toy)[n]?).getD .initial + check ((answers[n]?).bind (replyScalars q digest) == some (fields q)) + s!"source scalar re-projection at {count}/{n}" + check ((inverseAt frozen source count).isNone) "current response present in source prefix" + check ((inverseAt frozen source (count+1)).isNone) "future response present in source prefix" + match ((schedule toy)[count]?).getD .initial with + | .query _ => + let noNonce := source.map fun p => {p with nonce := none} + check ((replies frozen noNonce).isNone) "missing query rejection nonce accepted" + let hard := source.map fun p => {p with nonce := p.nonce.map fun (_,x) => (64,x)} + check ((replies frozen hard).isNone) "over-limit source nonce accepted" + | _ => pure () + IO.println "source reply inverse PASS: initial/middle-fold/OOD/query/tail, frozen rows, exact nonterminal root and terminal residual, nonce metadata, malformed lengths/root/stage/phase, strict prefix indexes" + +end Whir.PCSBCSSourceReplyInversionSmoke + +def main : IO Unit := Whir.PCSBCSSourceReplyInversionSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceRootCapture.lean b/verification/whir/Whir/PCSBCSSourceRootCapture.lean new file mode 100644 index 000000000..4cd3b1c03 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceRootCapture.lean @@ -0,0 +1,129 @@ +import Whir.PCSBCSFirstRootDisclosure +import Whir.PCSBCSChallengeOracleEnteredErasure +import Whir.PCSBCSMerkleRootCache +import Whir.PCSBCSSourceRootReferences + +/-! In the grouped mixed game, root images are reconstructed from actual +ordinary primitive records preceding the first shape-address mention. Source +packet answers are not invented Merkle preimages. Identifying this prefix with +the physical compression trace is a separate coupling/refinement obligation. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceRootCapture +open Concrete Protocol CausalGame CausalProbability PCSBCSRounds +open FiatShamirGame TypedOracleCompiler TypedFiatShamirGame +open PCSBCSChallengeOracle PCSBCSMerkleRootCache PCSBCSSourceRootReferences +open Classical PCSStateRestoration.Latent + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} + +abbrev Key := (EnteredPacket.partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Key +abbrev Answer := (EnteredPacket.partition (p := p) (Q := Q) (iv := iv) (boundary := boundary)).Answer + (D := Digest32) +local notation "Keys" => Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => Answer (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Only the primitive-query summand contains public compression records. +Other construction queries cannot supply a made-up hash preimage. -/ +def ordinaryRecord (event : Sigma (Answer (p := p) (Q := Q) (iv := iv) (boundary := boundary))) : + DuplexPublicSimulator.PublicLog := + match event with + | ⟨.inl _,_⟩ => [] + | ⟨.inr other,answer⟩ => + match other.val with + | .inl input => [(input,answer)] + | .inr _ => [] + +def ordinaryPrefix (events : List (Sigma + (Answer (p := p) (Q := Q) (iv := iv) (boundary := boundary)))) : + DuplexPublicSimulator.PublicLog := + events.foldl (fun log event => ordinaryRecord event ++ log) [] + +/-- A missing first mention returns no captured root, not an authenticated +zero table. Genuine absent leaf images retain the cache's explicit status. -/ +noncomputable def capture {R : Type} {n : Nat} + (address : Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) → List Reference) + (ref : Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : Option Frozen := + (PCSBCSFirstRootDisclosure.firstMention address ref program table).map fun events => + freeze (ordinaryPrefix events) ref.root ref.shape + +/-- This reconstructs the complete image and compact suffix from a prefix of +actual records, while erasing the whole current packet before metadata lookup. -/ +theorem capture_answer_independent {R : Type} {n : Nat} + (address : Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) → List Reference) + (current : EnteredPacket p Q iv boundary) (ref : Reference) + (mentioned : ref ∈ address (.inl current)) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (full : Fin (blocks (rawWidth current.2.coord)) → Digest32) : + capture address ref program (Function.update table (.inl current) full) = + capture address ref program table := by + unfold capture + rw [PCSBCSFirstRootDisclosure.first_mention_answer_independent address + (.inl current) ref mentioned program table full] + +/-- A ghost completion only: the selected packet is never read before its +address mention. The following theorem removes the inert completion exactly. -/ +noncomputable def otherTable (current : EnteredPacket p Q iv boundary) + (other : current.OtherValues) : Table Keys Answers := + fun key => if same : key = .inl current then by + subst key + exact fun _ _ => 0 + else other ⟨key,same⟩ + +noncomputable def captureOther {R : Type} {n : Nat} + (address : Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) → List Reference) + (current : EnteredPacket p Q iv boundary) (ref : Reference) + (program : Sampling Keys Answers R n) (other : current.OtherValues) : Option Frozen := + capture address ref program (otherTable current other) + +theorem captureOther_table {R : Type} {n : Nat} + (address : Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) → List Reference) + (current : EnteredPacket p Q iv boundary) (ref : Reference) + (mentioned : ref ∈ address (.inl current)) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : + captureOther address current ref program (fun key => table key.val) = + capture address ref program table := by + have same : otherTable current (fun key => table key.val) = + Function.update table (.inl current) (fun _ _ => 0) := by + funext key + by_cases equal : key = .inl current + · subst key + simp [otherTable] + · simp [otherTable,equal] + unfold captureOther + rw [same] + exact capture_answer_independent address current ref mentioned program table (fun _ _ => 0) + + +/-- An actually queried shape reference has a genuine earlier capture. +Nothing asserts that this capture already contains every leaf preimage. -/ +theorem capture_exists {R : Type} {n : Nat} + (address : Keys → List Reference) (ref : Reference) + (key : Keys) (mentioned : ref ∈ address key) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (visited : key ∈ ((Sampling.execute table program).2.map Sigma.fst)) : + ∃ frozen, capture address ref program table = some frozen := by + obtain ⟨events,found⟩ := PCSBCSFirstRootDisclosure.first_mention_exists + address key ref mentioned program table visited + exact ⟨freeze (ordinaryPrefix events) ref.root ref.shape,by + simp only [capture,found,Option.map_some]⟩ + +/-- Source accessors receive the actual indexed prefix, not an arbitrary +digest-to-oracle map or a promise that a Merkle root is honestly generated. -/ +theorem capture_provenance {R : Type} {n : Nat} + (address : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (frozen : Frozen) (captured : capture address ref program table = some frozen) : + ∃ events, PCSBCSFirstRootDisclosure.firstMention address ref program table = some events ∧ + frozen = freeze (ordinaryPrefix events) ref.root ref.shape ∧ events.length ≤ n := by + unfold capture at captured + obtain ⟨events,found,equal⟩ := Option.map_eq_some_iff.mp captured + exact ⟨events,found,equal.symm, + PCSBCSFirstRootDisclosure.first_mention_length address ref program table events found⟩ + +#print axioms capture_exists +#print axioms capture_provenance + +#print axioms capture_answer_independent +#print axioms captureOther_table +end Whir.PCSBCSSourceRootCapture diff --git a/verification/whir/Whir/PCSBCSSourceRootReferences.lean b/verification/whir/Whir/PCSBCSSourceRootReferences.lean new file mode 100644 index 000000000..c5950c9d1 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceRootReferences.lean @@ -0,0 +1,299 @@ +import Whir.PCSBCSChallengeOracleSource +import Whir.AnchoredSourceFreshCaller +import Whir.PCSBCSMerkleRootCacheCost + +/-! Literal PR600 roles at 12eea88c41dd964d82d4eb15ce91bba17ef91339: +commit.rs:124-175,229-253 and verify.rs:395-437. This is a source schedule +hand-port, not universal Rust refinement and not a digest search. Admission is +syntax and immutable-record binding, not Merkle acceptance, honest padding, +or truth of any evaluation. No current packet is read by the registry. -/ +namespace Whir.PCSBCSSourceRootReferences +open Concrete Protocol CausalGame CausalProbability FiatShamirGame WHIRHistory WHIRHistoryKey +open AnchoredHeaderCodec PCSBCSMerkleRootCache + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq FiatShamirGame.Coordinate := by + intro a b + cases a + cases b + simp only [FiatShamirGame.Coordinate.mk.injEq] + infer_instance + +local instance : DecidableEq PCSBCSMerkleRootCache.Shape := by + intro a b + cases a + cases b + simp only [PCSBCSMerkleRootCache.Shape.mk.injEq] + infer_instance + +structure Reference where + root : Digest32 + shape : PCSBCSMerkleRootCache.Shape + deriving DecidableEq + +/-- The production initial leaf is the full lane cube, not just its live suffix. -/ +def initialShape (s : AnchoredHeaderCodec.Shape) : PCSBCSMerkleRootCache.Shape := + ⟨s.logN-s.logBatch+s.logRate, 2^s.logBatch, s.lanes⟩ + +/-- Phase i+1 is announced after folding phase i, but uses the NEXT fold and +rate for its own row geometry. Extension elements occupy three base words. -/ +def phaseShape (c : Config) (phase : Nat) : PCSBCSMerkleRootCache.Shape := + ⟨remaining c phase + c.rates[phase]!, 3*2^c.folds[phase]!, 3*2^c.folds[phase]!⟩ + +def profileShape (p : ParameterBounds.Profile) (s : AnchoredHeaderCodec.Shape) : Prop := + s.logN = (ParameterBounds.config p).logN ∧ + s.logBatch = (ParameterBounds.config p).folds[0]! ∧ + s.logRate = (ParameterBounds.config p).rates[0]! +instance (p : ParameterBounds.Profile) (s : AnchoredHeaderCodec.Shape) : + Decidable (profileShape p s) := inferInstanceAs (Decidable (_ ∧ _ ∧ _)) + +/-- Offset 3 is the root role; offset 5 is context CV and NEVER a tree root. +The entire original record frame must match, not merely its marker or digest. -/ +def parseInitial (saved : Record) (frame : List E) (offset : Nat) : Option Reference := + if saved.Valid ∧ frame = openingScalars saved ∧ offset = 3 then + some ⟨saved.root, initialShape saved.shape⟩ else none + +theorem parseInitial_roundtrip (saved : Record) (valid : saved.Valid) : + parseInitial saved (openingScalars saved) 3 = + some ⟨saved.root,initialShape saved.shape⟩ := by simp [parseInitial,valid] + +theorem parseInitial_admitted (saved : Record) (frame : List E) (offset : Nat) + (ref : Reference) (parsed : parseInitial saved frame offset = some ref) : + saved.Valid ∧ frame = openingScalars saved ∧ offset = 3 ∧ + ref = ⟨saved.root,initialShape saved.shape⟩ := by + unfold parseInitial at parsed + split at parsed + next guard => exact ⟨guard.1,guard.2.1,guard.2.2,(Option.some.inj parsed).symm⟩ + next => contradiction + +/-- Reuse the deployed scalar-pair codec directly, as decodeReplyScalars does. +No temporary 48-byte re-encoding and scalar re-decoding is executed. -/ +def parseRootScalars : List E → Option Digest32 + | [a,b] => ByteCodec.scalarsToHash (a,b) + | _ => none + +theorem parseRootScalars_byte_codec (a b : E) : + parseRootScalars [a,b] = WHIRHistory.parseRoot (scalarBytes [a,b]) := by + have decoded := parseExact_roundtrip [a,b] + simp only [List.length_cons,List.length_nil] at decoded + simp [parseRootScalars,WHIRHistory.parseRoot,decoded] + +theorem parseRootScalars_roundtrip (root : Digest32) : + parseRootScalars (rootScalars root) = some root := by + simp [parseRootScalars,rootScalars,ByteCodec.scalarsToHash_hashToScalars] + +/-- The root immediately follows the two quadratic coefficients of a final +nonterminal fold. Foreign phases, middle folds and arbitrary scalar offsets +reject even if their values happen to encode a digest. -/ +def parsePhase (c : Config) (q : CausalProbability.Coordinate c) + (m : Pending) (phase offset : Nat) : Option Reference := + match q with + | .fold i j => + if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size ∧ + phase = i.val+1 ∧ offset = 2 ∧ m.scalars.length = 4 then do + let root ← parseRootScalars (m.scalars.drop 2) + pure ⟨root,phaseShape c phase⟩ + else none + | _ => none + +theorem parsePhase_roundtrip (c : Config) (i : Fin c.folds.size) + (j : Fin c.folds[i.val]!) (last : j.val+1 = c.folds[i.val]!) + (later : i.val+1 < c.folds.size) (a b : E) (root : Digest32) + (nonce : Option (Nat × E)) : + parsePhase c (.fold i j) ⟨[a,b] ++ rootScalars root,nonce⟩ (i.val+1) 2 = + some ⟨root,phaseShape c (i.val+1)⟩ := by + have size : (rootScalars root).length = 2 := rfl + have decoded : parseRootScalars (rootScalars root) = some root := + parseRootScalars_roundtrip root + simp [parsePhase,last,later,size,decoded] + +theorem parsePhase_admitted (c : Config) (q : CausalProbability.Coordinate c) + (m : Pending) (phase offset : Nat) (ref : Reference) + (parsed : parsePhase c q m phase offset = some ref) : + offset = 2 ∧ phase < c.folds.size ∧ m.scalars.length = 4 ∧ + ref.shape = phaseShape c phase := by + cases q <;> try (change none = some ref at parsed; contradiction) + case fold i j => + dsimp only [parsePhase] at parsed + by_cases guard : j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size ∧ + phase = i.val+1 ∧ offset = 2 ∧ m.scalars.length = 4 + · rw [ite_eq_left guard] at parsed + obtain ⟨last,later,index,role,size⟩ := guard + cases root : parseRootScalars (m.scalars.drop 2) with + | none => + simp only [root] at parsed + dsimp only [Bind.bind,Option.bind] at parsed + contradiction + | some digest => + simp only [root] at parsed + dsimp only [Bind.bind,Option.bind,Pure.pure] at parsed + have equal := Option.some.inj parsed + subst ref + exact ⟨role,index.symm ▸ later,size,rfl⟩ + · rw [ite_eq_right guard] at parsed + contradiction + +/-- Chronological Pending position n contains the reply to schedule[n-1]. -/ +def phaseAt (c : Config) (n : Nat) (m : Pending) : Option Reference := + if n = 0 then none else + let q := ((schedule c)[n-1]?).getD .initial + match q with + | .fold i _ => parsePhase c q m (i.val+1) 2 + | _ => none + +def phaseReferences (c : Config) (messages : List Pending) : List Reference := + messages.reverse.zipIdx.filterMap (fun (m,n) => phaseAt c n m) + +/-- Source next_root rejects noncanonical halves. An invalid root at a checked +role is a failed parse, not permission to silently omit that reference. -/ +def phaseRolesAdmitted (c : Config) (messages : List Pending) : Bool := + messages.reverse.zipIdx.all fun (m,n) => + if n = 0 then true else + let q := ((schedule c)[n-1]?).getD .initial + match q with + | .fold i j => + if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size then + (parsePhase c q m (i.val+1) 2).isSome + else true + | _ => true + +/-- Parse ALL prior steps, restore the unabsorbed initial Pending, then require +literal whole-key equality. Wrong seed, prefix, previous-width, nonce frame, +scalar role or continuation block cannot be admitted by a suffix search. -/ +def parsePendingKey (p : ParameterBounds.Profile) (entry : FramedHistory) + (key : FiatShamirGame.Coordinate) : Option (List Pending) := do + let chronological ← parseSteps (key.history.frames.drop entry.frames.length) + let messages := chronological.reverse ++ [initialPending] + let block ← match key.terminal with | .output b => some b | _ => none + if scheduledAdmissible (ParameterBounds.config p) messages = true ∧ + key = WHIRCallerPrefix.outputKeyFrom (stackWidth (ParameterBounds.config p)) + entry messages block then some messages else none + +theorem parsePendingKey_roundtrip (p : ParameterBounds.Profile) (entry : FramedHistory) + (messages : List Pending) (nonempty : messages ≠ []) + (admitted : scheduledAdmissible (ParameterBounds.config p) messages = true) + (block : Nat) : + parsePendingKey p entry (WHIRCallerPrefix.outputKeyFrom + (stackWidth (ParameterBounds.config p)) entry messages block) = some messages := by + have normal := scheduled_normal _ _ nonempty admitted + have parsed := WHIRCallerPrefix.parse_outputKeyFrom _ (stackWidth_positive p) + entry normal block + simp only [parsePendingKey,parsed] + dsimp only [Bind.bind,Option.bind,WHIRCallerPrefix.outputKeyFrom] + rw [List.reverse_reverse] + rw [normal.restore] + simp [admitted] + +theorem parsePendingKey_admitted (p : ParameterBounds.Profile) (entry : FramedHistory) + (key : FiatShamirGame.Coordinate) (messages : List Pending) + (parsed : parsePendingKey p entry key = some messages) : + messages ≠ [] ∧ scheduledAdmissible (ParameterBounds.config p) messages = true ∧ + ∃ block, key = WHIRCallerPrefix.outputKeyFrom (stackWidth (ParameterBounds.config p)) + entry messages block := by + unfold parsePendingKey at parsed + cases steps : parseSteps (key.history.frames.drop entry.frames.length) with + | none => simp [steps] at parsed + | some chronological => + simp only [steps] at parsed + dsimp only [Bind.bind,Option.bind] at parsed + cases terminal : key.terminal with + | commitment _ => simp [terminal] at parsed + | powBase _ _ => simp [terminal] at parsed + | output block => + simp only [terminal] at parsed + split at parsed + next guard => + have same := Option.some.inj parsed + subst messages + exact ⟨by simp,guard.1,block,guard.2⟩ + next => contradiction + +/-- Initial identity admission is the existing public caller parser. This +checks the saved binding frame at its control-shape position; its context CV, +point and value are not additional root references. -/ +def parseReferences (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (saved : Record) (entry : FramedHistory) (answers : FiatShamirGame.Coordinate → Digest32) + (key : FiatShamirGame.Coordinate) : Option (List Reference) := do + if saved.Valid ∧ profileShape p saved.shape then pure () else none + let _ ← AnchoredSourceFreshCaller.decode layout saved entry answers + let messages ← parsePendingKey p entry key + if phaseRolesAdmitted (ParameterBounds.config p) messages then + pure (⟨saved.root,initialShape saved.shape⟩ :: + phaseReferences (ParameterBounds.config p) messages) + else none + +theorem parseReferences_admitted (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : FiatShamirGame.Coordinate → Digest32) (key : FiatShamirGame.Coordinate) + (refs : List Reference) (parsed : parseReferences p layout saved entry answers key = some refs) : + saved.Valid ∧ profileShape p saved.shape ∧ + ∃ claims messages, + AnchoredSourceFreshCaller.decode layout saved entry answers = some claims ∧ + parsePendingKey p entry key = some messages ∧ + phaseRolesAdmitted (ParameterBounds.config p) messages = true ∧ + refs = ⟨saved.root,initialShape saved.shape⟩ :: + phaseReferences (ParameterBounds.config p) messages := by + unfold parseReferences at parsed + split at parsed + next guard => + dsimp only [Bind.bind,Option.bind,Pure.pure] at parsed + cases caller : AnchoredSourceFreshCaller.decode layout saved entry answers with + | none => simp [caller] at parsed + | some claims => + simp only [caller] at parsed + cases pending : parsePendingKey p entry key with + | none => simp [pending] at parsed + | some messages => + simp only [pending] at parsed + split at parsed + next roles => + exact ⟨guard.1,guard.2,claims,messages,rfl,rfl,roles, + (Option.some.inj parsed).symm⟩ + next => contradiction + next => simp at parsed + +theorem initialShape_admitted (saved : Record) (valid : saved.Valid) : + (initialShape saved.shape).occupied ≤ (initialShape saved.shape).leafWords := + valid.1.2.2.2.2.2 + +theorem phaseShape_admitted (c : Config) (phase : Nat) : + (phaseShape c phase).occupied = (phaseShape c phase).leafWords := rfl + +/-- Every listed phase reference comes from its scheduled Pending position, +and carries the full three-limb extension leaf rather than an occupied-only +or CV-only address. No assumption about committed padding is used. -/ +theorem phaseReference_admitted (c : Config) (messages : List Pending) + (ref : Reference) (member : ref ∈ phaseReferences c messages) : + ref.shape.occupied = ref.shape.leafWords := by + obtain ⟨⟨m,n⟩,_,decoded⟩ := List.mem_filterMap.mp member + change phaseAt c n m = some ref at decoded + by_cases initial : n = 0 + · simp [phaseAt,initial] at decoded + · simp only [phaseAt,initial,↓reduceIte] at decoded + cases coordinate : ((schedule c)[n-1]?).getD .initial with + | fold i j => + simp only [coordinate] at decoded + have shape := (parsePhase_admitted c (.fold i j) m (i.val+1) 2 ref decoded).2.2.2 + rw [shape] + rfl + | initial => simp [coordinate] at decoded + | ood i j => simp [coordinate] at decoded + | query i => simp [coordinate] at decoded + | tail i => simp [coordinate] at decoded + +#print axioms parseInitial_roundtrip +#print axioms parseInitial_admitted +#print axioms parseRootScalars_byte_codec +#print axioms parseRootScalars_roundtrip +#print axioms parsePhase_roundtrip +#print axioms parsePhase_admitted +#print axioms parsePendingKey_roundtrip +#print axioms parsePendingKey_admitted +#print axioms parseReferences_admitted +#print axioms initialShape_admitted +#print axioms phaseShape_admitted +#print axioms phaseReference_admitted +end Whir.PCSBCSSourceRootReferences diff --git a/verification/whir/Whir/PCSBCSSourceRootReferencesBudget.lean b/verification/whir/Whir/PCSBCSSourceRootReferencesBudget.lean new file mode 100644 index 000000000..d973bc8f8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceRootReferencesBudget.lean @@ -0,0 +1,218 @@ +import Whir.PCSBCSSourceRootReferences + +/-! Target/reference accounting is deliberately independent of authentication. +Every root in a child prefix is charged, including equal CVs at different shape +addresses. Complete construction paths, not one root per query, pay the bill. -/ +namespace Whir.PCSBCSSourceRootReferences +open Concrete Protocol FiatShamirGame WHIRHistory WHIRHistoryKey +open DuplexModeGame DuplexFraming PCSBCSMerkleRootCache + +private theorem chunks_positive (first : Bool) (previous : Nat) (pending bytes : List Byte) + (nonempty : pending ≠ [] ∨ bytes ≠ []) : + 0 < (DuplexEncoding.chunks first previous pending bytes).length := by + induction bytes generalizing first previous pending with + | nil => + have hp : pending ≠ [] := by simpa using nonempty + simp [DuplexEncoding.chunks,hp] + | cons b bs ih => + simp only [DuplexEncoding.chunks] + split + · simp + · exact ih _ _ _ (Or.inl (by simp)) + +private theorem canonical_cost (width : Nat → Nat) (messages : List Pending) + (normal : Normal messages) : + messages.dropLast.length ≤ + ((canonicalFrames width messages).flatMap DuplexEncoding.framePlan).length := by + induction normal with + | initial => simp [initialPending,canonicalFrames,annotated,encodeSteps] + | @cons ps prior m nonempty ih => + have scalarNonempty : scalarBytes m.scalars ≠ [] := + fun h => nonempty ((scalarBytes_empty _).mp h) + have positive := chunks_positive true (width (ps.length-1)) [] + (scalarBytes m.scalars) (Or.inr scalarNonempty) + have hp := prior.nonempty + simp only [canonicalFrames,annotated,hp,↓reduceIte,List.reverse_cons, + encodeSteps,List.flatMap_append,List.flatMap_cons,List.flatMap_nil, + List.append_nil,List.length_append] at ih ⊢ + simp only [stepFrames,List.flatMap_append,List.flatMap_cons,List.flatMap_nil, + DuplexEncoding.framePlan,List.length_append,List.append_nil] at ih ⊢ + rw [List.dropLast_cons_of_ne_nil hp,List.length_cons] + omega + +theorem reference_count (c : Config) (messages : List Pending) (normal : Normal messages) : + (phaseReferences c messages).length ≤ messages.dropLast.length := by + have restore := normal.restore + have hr : messages.reverse = initialPending :: messages.dropLast.reverse := by + calc + messages.reverse = (messages.dropLast ++ [initialPending]).reverse := + congrArg List.reverse restore.symm + _ = initialPending :: messages.dropLast.reverse := by simp + simp only [phaseReferences,hr,List.zipIdx_cons,List.filterMap_cons,phaseAt, + ↓reduceIte] + have bound := List.length_filterMap_le + (fun (m,n) => phaseAt c n m) + (List.zipIdx messages.dropLast.reverse 1) + simpa [phaseAt] using bound + +theorem complete_path_reference_bound (p : ParameterBounds.Profile) (entry : FramedHistory) + (messages : List Pending) (nonempty : messages ≠ []) + (admitted : scheduledAdmissible (ParameterBounds.config p) messages = true) + (block : Nat) : + 1 + (phaseReferences (ParameterBounds.config p) messages).length ≤ + pathCost (WHIRCallerPrefix.outputKeyFrom (stackWidth (ParameterBounds.config p)) + entry messages block) := by + have normal := scheduled_normal _ _ nonempty admitted + have refs := reference_count (ParameterBounds.config p) messages normal + have cost := canonical_cost (stackWidth (ParameterBounds.config p)) messages normal + unfold pathCost DuplexEncoding.plan + rw [WHIRCallerPrefix.outputKeyFrom_history _ (stackWidth_positive p) entry normal] + simp only [List.flatMap_append,List.length_cons,List.length_append,List.length_nil] + omega + +/-- Each successful parser result is charged without a CV-based deduplication. -/ +def requestReferences (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (answers : FiatShamirGame.Coordinate → Digest32) : Query → List Reference + | .construction key _ => (parseReferences p layout saved entry answers key).getD [] + | .primitive _ _ => [] + +theorem parsed_reference_bound (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (answers : FiatShamirGame.Coordinate → Digest32) + (key : FiatShamirGame.Coordinate) (refs : List Reference) + (parsed : parseReferences p layout saved entry answers key = some refs) : + refs.length ≤ pathCost key := by + obtain ⟨_,_,claims,messages,_,pending,_,rfl⟩ := + parseReferences_admitted p layout saved entry answers key refs parsed + obtain ⟨nonempty,admitted,block,same⟩ := + parsePendingKey_admitted p entry key messages pending + rw [same] + simpa only [List.length_cons,Nat.add_comm] using + complete_path_reference_bound p entry messages nonempty admitted block + +theorem request_reference_bound (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (answers : FiatShamirGame.Coordinate → Digest32) + (request : Query) : + (requestReferences p layout saved entry answers request).length ≤ request.cost := by + cases request with + | primitive purpose node => simp [requestReferences,Query.cost] + | construction key valid => + cases parsed : parseReferences p layout saved entry answers key with + | none => simp [requestReferences,Query.cost,parsed] + | some refs => + simpa [requestReferences,Query.cost,parsed] using + parsed_reference_bound p layout saved entry answers key refs parsed + +/-- A response-following prefix of the actual Program: no accepted-verifier or +source-truth premise. Rejected continuations and primitive queries also charge. -/ +inductive RequestPrefix {R : Type} : Program R → List Query → Prop where + | nil (program : Program R) : RequestPrefix program [] + | ask (q : Query) (next : Digest32 → Program R) (answer : Digest32) + (rest : List Query) (tail : RequestPrefix (next answer) rest) : + RequestPrefix (.ask q next) (q :: rest) + +theorem counts_prefix_cost {R : Type} (Q : Nat) (program : Program R) + (requests : List Query) (counted : Counts Q program) + (tracePrefix : RequestPrefix program requests) : (requests.map Query.cost).sum ≤ Q := by + induction tracePrefix generalizing Q with + | nil => simp + | ask q next answer rest tail ih => + have first := counted.1 + have later := ih (Q-q.cost) (counted.2 answer) + simp only [List.map_cons,List.sum_cons] + omega + +def announcements (log : PublicMerkleLog.PublicLog) (refs : List Reference) : List Announcement := + refs.map (fun ref => ⟨log,ref.root,ref.shape⟩) + +/-- CONSTRUCTION-request ledger only. Counts charges each complete construction +path; primitive terminals do not register here. All child-prefix references are +counted, and only identical shape addresses reuse the existing registry. +Public primitive first-reference/frame charging is a separate integration. -/ +theorem aggregate_resource_bound {R : Type} (Q : Nat) (program : Program R) + (requests : List Query) (counted : Counts Q program) + (tracePrefix : RequestPrefix program requests) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (answers : FiatShamirGame.Coordinate → Digest32) + (registry : Registry) (log : PublicMerkleLog.PublicLog) : + (registerAll registry (announcements log (requests.flatMap + (requestReferences p layout saved entry answers)))).size ≤ registry.size + Q := by + have cost := counts_prefix_cost Q program requests counted tracePrefix + have refs : (requests.flatMap (requestReferences p layout saved entry answers)).length ≤ + (requests.map Query.cost).sum := by + clear counted tracePrefix cost + induction requests with + | nil => simp + | cons request rest ih => + have first := request_reference_bound p layout saved entry answers request + simp only [List.flatMap_cons,List.length_append,List.map_cons,List.sum_cons] + omega + have bound := registerAll_size_le registry + (announcements log (requests.flatMap (requestReferences p layout saved entry answers))) + simp only [announcements,List.length_map] at bound + unfold announcements + omega + +/-- Public recognizer integration: selected keys may be arbitrary child-prefix +prequeries. The endpoint explicitly requires their complete path charges; it +does not mistake a terminal primitive call for the cost of its ancestry. -/ +theorem first_mention_path_budget (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (answers : FiatShamirGame.Coordinate → Digest32) + (keys : List FiatShamirGame.Coordinate) (Q : Nat) + (charged : (keys.map pathCost).sum ≤ Q) (registry : Registry) + (log : PublicMerkleLog.PublicLog) : + (registerAll registry (announcements log (keys.flatMap (fun key => + (parseReferences p layout saved entry answers key).getD [])))).size ≤ + registry.size+Q := by + have refs : (keys.flatMap (fun key => + (parseReferences p layout saved entry answers key).getD [])).length ≤ + (keys.map pathCost).sum := by + clear charged + induction keys with + | nil => simp + | cons key rest ih => + have first : ((parseReferences p layout saved entry answers key).getD []).length ≤ + pathCost key := by + cases parsed : parseReferences p layout saved entry answers key with + | none => simp + | some refs => exact parsed_reference_bound p layout saved entry answers key refs parsed + simp only [List.flatMap_cons,List.length_append,List.map_cons,List.sum_cons] + omega + have bound := registerAll_size_le registry (announcements log + (keys.flatMap (fun key => (parseReferences p layout saved entry answers key).getD []))) + simp only [announcements,List.length_map] at bound + unfold announcements + omega + +/-- The final proof root costs at most one extra address; if already registered, +register returns the same table. It is NOT one extra root per query. -/ +theorem final_root_resource_bound (registry : Registry) (refs : List Announcement) + (Q : Nat) (cap : (registerAll registry refs).size ≤ registry.size+Q) + (log : PublicMerkleLog.PublicLog) (finalRoot : Digest32) + (shape : PCSBCSMerkleRootCache.Shape) : + (register (registerAll registry refs) log finalRoot shape).size ≤ registry.size+Q+1 := by + have bound := register_size_le (registerAll registry refs) log finalRoot shape + omega + +theorem final_root_captured_bound (registry : Registry) (refs : List Announcement) + (Q : Nat) (cap : (registerAll registry refs).size ≤ registry.size+Q) + (log : PublicMerkleLog.PublicLog) (finalRoot : Digest32) + (shape : PCSBCSMerkleRootCache.Shape) (frozen : Frozen) + (captured : (registerAll registry refs)[cacheKey finalRoot shape]? = some frozen) : + (register (registerAll registry refs) log finalRoot shape).size ≤ registry.size+Q := by + rw [register_existing _ _ _ _ frozen captured] + exact cap + +#print axioms reference_count +#print axioms complete_path_reference_bound +#print axioms parsed_reference_bound +#print axioms counts_prefix_cost +#print axioms aggregate_resource_bound +#print axioms first_mention_path_budget +#print axioms final_root_resource_bound +#print axioms final_root_captured_bound +end Whir.PCSBCSSourceRootReferences diff --git a/verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean b/verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean new file mode 100644 index 000000000..41643b5de --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean @@ -0,0 +1,116 @@ +import Whir.PCSBCSSourceRootReferencesBudget + +namespace Whir.PCSBCSSourceRootReferencesSmoke +open Whir Concrete Protocol FiatShamirGame WHIRHistory WHIRHistoryKey +open AnchoredHeaderCodec WHIRCallerClaims PCSBCSSourceRootReferences +open DuplexModeGame DuplexFraming PCSBCSMerkleRootCache + +private def digest (n : Nat) : Digest32 := + fun i => ⟨(n / 256^i.val) % 256,Nat.mod_lt _ (by decide)⟩ +private def p : ParameterBounds.Profile := (⟨1,by decide⟩,⟨0,by decide⟩) +private def c : Config := ParameterBounds.config p +private def layout : CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 15,.committed (2^15) 0],⟨0,6,7⟩,1⟩ +private def zeroToken : WHIRCallerShape.EventShape → CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) +private def compression : DuplexRefinement.Compression := compressionOf blake2sOracle +private def iv : Digest32 := DuplexCompression.parameterIV + +private def pendingAt (n : Nat) : Pending := + let previous := ((schedule c)[n-1]?).getD .initial + let q := ((schedule c)[n]?).getD .initial + let scalars := if n = 0 then [] else + match previous with + | .fold i j => + if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size then + [0,0] ++ rootScalars (digest 17) + else List.replicate (replyScalarCount previous) 0 + | _ => List.replicate (replyScalarCount previous) 0 + ⟨scalars,match q with | .query _ => some (0,0) | _ => none⟩ +private def messages : List Pending := (List.range (depth c)).map pendingAt |>.reverse + +private def require (label : String) (test : Bool) : IO Unit := do + unless test do throw (IO.userError s!"root-reference smoke failed: {label}") + IO.println s!"root-reference smoke: {label}" +private def describe (ref : Reference) : String := + s!"cv[0]={ref.root ⟨0,by decide⟩};height={ref.shape.height};image={ref.shape.leafWords};occupied={ref.shape.occupied}" +private def printParse (label : String) (result : Option Reference) : IO Unit := + IO.println s!"{label}: {result.map describe}" + +def smoke : IO Unit := do + let original := DuplexRefinement.seed compression iv (digest 7) (digest 9) + let shape := AnchoredSourceCaller.shape layout + let afterHeader := DuplexRefinement.absorb compression original + (scalarBytes (headerScalars shape (digest 17))) + let point ← match DuplexRefinement.sampleVec compression afterHeader shape.logN with + | .ok (_,point) => pure point + | .error _ => throw (IO.userError "original commitment anchor draw failed") + let saved : Record := ⟨shape,digest 17,capture original,point,0⟩ + require "valid immutable original record" (decide saved.Valid) + require "public PCS profile matches control shape" (decide (profileShape p saved.shape)) + require "production initial leaf retains padding and occupied suffix" + (decide (saved.shape.lanes < (initialShape saved.shape).leafWords)) + let payload := ((WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout)).map zeroToken + let tokens := payload ++ (openingScalars saved).map CallerToken.sent + let entry := tokenHistory (digest 11) (digest 13) tokens + let answers := DuplexRefinement.evalCoordinate compression iv + require "fresh caller identity admitted" (AnchoredSourceFreshCaller.decode layout saved entry answers).isSome + printParse "initial exact role3" (parseInitial saved (openingScalars saved) 3) + printParse "initial rejected context-CV role5" (parseInitial saved (openingScalars saved) 5) + require "wrong initial role rejected" (parseInitial saved (openingScalars saved) 5).isNone + let foreign := {saved with value := saved.value+1} + printParse "foreign immutable frame" (parseInitial saved (openingScalars foreign) 3) + printParse "malformed immutable frame" (parseInitial saved ((openingScalars saved).drop 1) 3) + require "foreign record rejected" (parseInitial saved (openingScalars foreign) 3).isNone + require "malformed record rejected" (parseInitial saved ((openingScalars saved).drop 1) 3).isNone + let arbitrary : Pending := ⟨rootScalars (digest 17),none⟩ + printParse "digest halves at non-root coordinate" (parsePhase c .initial arbitrary 1 0) + require "no magic digest search across arbitrary scalar roles" + (parsePhase c .initial arbitrary 1 0).isNone + require "scheduled child-prefix admitted" (scheduledAdmissible c messages) + let key := WHIRCallerPrefix.outputKeyFrom (stackWidth c) entry messages 0 + require "exact Pending parser roundtrip" (decide (parsePendingKey p entry key = some messages)) + let refs ← match parseReferences p layout saved entry answers key with + | some refs => pure refs + | none => throw (IO.userError "whole child key root parser rejected") + IO.println s!"child-prefix exact parser: {refs.map describe}" + require "multiple prior phase roots in ONE child key" (decide (2 ≤ (phaseReferences c messages).length)) + require "all references have repeated equal CV" (refs.all (fun ref => decide (ref.root = digest 17))) + let announcements := PCSBCSSourceRootReferences.announcements [] refs + let registry := registerAll ({} : Registry) announcements + IO.println s!"ledger: source-key first-mention=1 references={refs.length} unique-shape-addresses={registry.size} complete-path-charge={pathCost key}" + require "same CV is not registry deduplication key" (decide (2 ≤ registry.size)) + require "all references fit charged complete path" (decide (refs.length ≤ pathCost key)) + let repeated := registerAll registry announcements + require "repeat exact addresses do not allocate" (decide (repeated.size = registry.size)) + let badKey := {key with history := {key.history with domain := digest 99}} + require "foreign source seed rejected" (parsePendingKey p entry badKey).isNone + require "foreign record binding rejected by whole parser" + (parseReferences p layout foreign entry answers key).isNone + for (m,n) in messages.reverse.zipIdx do + if n > 0 then + let q := ((schedule c)[n-1]?).getD .initial + match q with + | .fold i j => + if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size then + printParse "phase exact scalar2" (parsePhase c q m (i.val+1) 2) + printParse "phase rejected scalar0" (parsePhase c q m (i.val+1) 0) + printParse "phase rejected foreign index" (parsePhase c q m (i.val+2) 2) + require "wrong phase offset rejected" (parsePhase c q m (i.val+1) 0).isNone + require "wrong phase index rejected" (parsePhase c q m (i.val+2) 2).isNone + let malformed : Pending := ⟨[0,0,⟨0,0,1⟩,0],m.nonce⟩ + printParse "phase rejected noncanonical root halves" + (parsePhase c q malformed (i.val+1) 2) + require "noncanonical root halves rejected" + (parsePhase c q malformed (i.val+1) 2).isNone + | _ => pure () + let physical := DuplexRefinement.evalCoordinate compression iv key + IO.println s!"actual deployed compression output first byte={physical ⟨0,by decide⟩}" + let final := register registry [] (digest 17) (initialShape saved.shape) + require "final proof root already captured costs zero addresses" (decide (final.size = registry.size)) + +end Whir.PCSBCSSourceRootReferencesSmoke + +def main : IO Unit := Whir.PCSBCSSourceRootReferencesSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSVerifierPacketWalk.lean b/verification/whir/Whir/PCSBCSVerifierPacketWalk.lean new file mode 100644 index 000000000..138aeef4c --- /dev/null +++ b/verification/whir/Whir/PCSBCSVerifierPacketWalk.lean @@ -0,0 +1,44 @@ +import Whir.PCSStateRestorationLatent + +/-! The verifier suffix requests its actual source packets in protocol order. +Prior adversarial requests, repetitions and child-prefix prequeries remain in +the ordinary operational trace; no ancestor-warming program is introduced. -/ +set_option autoImplicit false +namespace Whir.PCSBCSVerifierPacketWalk +open TypedOracleCompiler TypedFiatShamirGame +open PCSStateRestoration.Latent + +universe u v +variable {Key : Type u} {Answer : Key → Type v} + +def request : (keys : List Key) → Sampling Key Answer Unit keys.length + | [] => .ret () + | key :: rest => .draw key (fun _ => request rest) + +/-- This is the exact operational transcript, including repeated requests. -/ +theorem execute_request (keys : List Key) (table : Table Key Answer) : + (Sampling.execute table (request keys)).2 = keys.map (fun key => ⟨key,table key⟩) := by + induction keys with + | nil => rfl + | cons key rest ih => simp only [request,Sampling.execute,List.map_cons,ih] + +/-- Every verifier lookup is recorded after an arbitrary adaptive adversary +prefix. The proof does not reorder the prefix or require ancestor disclosure. -/ +theorem verifier_lookup_recorded {R : Type} {Q : Nat} + (adversary : Sampling Key Answer R Q) (keys : R → List Key) (k : Nat) + (length : ∀ result, (keys result).length = k) + (table : Table Key Answer) (key : Key) + (member : key ∈ keys (Sampling.execute table adversary).1) : + (⟨key,table key⟩ : Sigma Answer) ∈ + (Sampling.execute table (Sampling.bind adversary (fun result => + (Sampling.pad (by simpa only [length] using Nat.le_refl k) (request (keys result)) : + Sampling Key Answer Unit k)))).2 := by + rw [Sampling.execute_bind] + apply List.mem_append_right + simp only [Sampling.execute_pad,execute_request] + apply List.mem_map.mpr + exact ⟨key,by simpa only [Sampling.execute_value] using member,rfl⟩ + +#print axioms execute_request +#print axioms verifier_lookup_recorded +end Whir.PCSBCSVerifierPacketWalk diff --git a/verification/whir/Whir/PCSStateRestoration.lean b/verification/whir/Whir/PCSStateRestoration.lean new file mode 100644 index 000000000..2ed3bc7bf --- /dev/null +++ b/verification/whir/Whir/PCSStateRestoration.lean @@ -0,0 +1,75 @@ +import Whir.RawOracleCoupling + +/-! Reusable finite memo-interpreter facts for PCS state restoration. +The adaptive first-registration game is in PCSStateRestorationAdaptive. -/ +namespace Whir.PCSStateRestoration +open TypedOracleCompiler TypedFiatShamirGame +open FiatShamirGame (average) + +set_option autoImplicit false + +universe u v w +variable {Key : Type u} {Answer : Key → Type v} {R : Type w} [DecidableEq Key] + +/-- Padding a request cap does not create an additional fresh draw, even after +memoization. This is an exact expectation identity for every payoff. -/ +theorem memo_expectation_pad [∀ key, Fintype (Answer key)] [∀ key, Nonempty (Answer key)] + {n m : Nat} (h : n ≤ m) (source : Sampling Key Answer R n) + (cache : Cache Key Answer) (payoff : R × Cache Key Answer → ℚ) : + Sampling.expectation payoff (RawOracleCoupling.memo (Sampling.pad h source) cache) = + Sampling.expectation payoff (RawOracleCoupling.memo source cache) := by + induction source generalizing m cache with + | ret r => simp only [Sampling.pad,RawOracleCoupling.memo,Sampling.expectation] + | draw key next ih => + cases m with + | zero => omega + | succ m => + cases hit : cache key with + | some answer => + simp only [Sampling.pad,RawOracleCoupling.memo,hit,Sampling.expectation_pad] + exact ih answer _ cache + | none => + simp only [Sampling.pad,RawOracleCoupling.memo,hit,Sampling.expectation] + apply congrArg average + funext answer + exact ih answer _ (put cache key answer) + +/-- Every allocated key is distinct and absent from the initial cache. Existing +fixed-prefix answers and repeated requests are not fresh exposures. -/ +theorem memo_runs_distinct {n : Nat} (source : Sampling Key Answer R n) + (cache : Cache Key Answer) (trace : List (Sigma Answer)) (result : R × Cache Key Answer) + (run : Sampling.Runs (RawOracleCoupling.memo source cache) trace result) : + (∀ entry ∈ trace, cache entry.1 = none) ∧ (trace.map Sigma.fst).Nodup := by + induction source generalizing cache trace result with + | ret value => + cases run + exact ⟨by simp, by simp⟩ + | draw key next ih => + cases hit : cache key with + | some answer => + simp only [RawOracleCoupling.memo,hit,Sampling.runs_pad] at run + exact ih answer cache trace result run + | none => + simp only [RawOracleCoupling.memo,hit] at run + cases run with + | @draw _ _ _ tail _ answer rest => + obtain ⟨fresh,distinct⟩ := ih answer (put cache key answer) _ _ rest + have different : ∀ (entry : Sigma Answer), entry ∈ tail → entry.1 ≠ key := by + intro entry member same + have absent := fresh entry member + rw [same,put_self] at absent + contradiction + constructor + · intro entry member + rcases List.mem_cons.mp member with equal | member + · subst entry; exact hit + · simpa only [put_other _ _ _ _ (different entry member)] using fresh entry member + · rw [List.map_cons,List.nodup_cons] + refine ⟨?_,distinct⟩ + intro member + obtain ⟨entry,entryMember,equal⟩ := List.mem_map.mp member + exact different entry entryMember equal + +#print axioms memo_expectation_pad +#print axioms memo_runs_distinct +end Whir.PCSStateRestoration diff --git a/verification/whir/Whir/PCSStateRestorationAdaptive.lean b/verification/whir/Whir/PCSStateRestorationAdaptive.lean new file mode 100644 index 000000000..062b5abf6 --- /dev/null +++ b/verification/whir/Whir/PCSStateRestorationAdaptive.lean @@ -0,0 +1,353 @@ +import Whir.PCSStateRestoration + +/-! Adaptive first-registration metadata for the restoration theorem. Immutable +root tables and public prefixes are captured before the first requested draw; +they need not be encoded literally in the raw RO key. Reusing a raw key reuses +that capture. An actual-source adapter must justify this replay outside its +explicit Merkle/framing bad events; this file does not assert that justification. -/ +namespace Whir.PCSStateRestoration.Adaptive +open TypedOracleCompiler TypedFiatShamirGame +open FiatShamirGame (average average_mono average_const average_add) + +set_option autoImplicit false +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +universe u v w +variable {Key : Type u} {Answer : Key → Type v} {Public : Type w} + +structure Certificate (Key : Type u) (Answer : Key → Type v) (Public : Type w) where + before : Public → Key → Bool + after : Public → (key : Key) → Answer key → Bool + +abbrev Entry (Key : Type u) (Answer : Key → Type v) (Public : Type w) := Public × Sigma Answer +abbrev History (Key : Type u) (Answer : Key → Type v) (Public : Type w) := List (Entry Key Answer Public) + +structure View (Key : Type u) (Answer : Key → Type v) (Public : Type w) where + history : History Key Answer Public + registry : Key → Option Public + +def initial : View Key Answer Public := ⟨[],fun _ => none⟩ + +structure Policy (Key : Type u) (Answer : Key → Type v) (Public : Type w) where + choose : Nat → History Key Answer Public → Option Key + prepare : Nat → History Key Answer Public → Key → Public + +/-- This function consults completed registration metadata, never the pending +answer or a reference oracle. Registration is fixed before the queried draw. -/ +def snapshot (policy : Policy Key Answer Public) (cursor : Nat) + (view : View Key Answer Public) (key : Key) : Public := + match view.registry key with + | some publicData => publicData + | none => policy.prepare cursor view.history key + +def Transition (cert : Certificate Key Answer Public) (publicData : Public) + (key : Key) (answer : Answer key) : Prop := + cert.before publicData key = false ∧ cert.after publicData key answer = true + +def Dirty (cert : Certificate Key Answer Public) (history : History Key Answer Public) : Prop := + ∃ entry ∈ history, Transition cert entry.1 entry.2.1 entry.2.2 + +def Doomed (cert : Certificate Key Answer Public) (history : History Key Answer Public) : Prop := + ∃ entry ∈ history, cert.after entry.1 entry.2.1 entry.2.2 = true + +section Execution +variable [DecidableEq Key] + +/-- Existing metadata survives exactly; only a previously absent entry is +inserted. Logging repeats preserves the complete adversarial past view. -/ +def advanceCaptured (view : View Key Answer Public) (key : Key) + (publicData : Public) (answer : Answer key) : View Key Answer Public := + ⟨(publicData,⟨key,answer⟩) :: view.history, + if view.registry key = none then Function.update view.registry key (some publicData) + else view.registry⟩ + +def advance (policy : Policy Key Answer Public) (cursor : Nat) + (view : View Key Answer Public) (key : Key) (answer : Answer key) : View Key Answer Public := + advanceCaptured view key (snapshot policy cursor view key) answer + +theorem registry_never_overwrites (policy : Policy Key Answer Public) (cursor : Nat) + (view : View Key Answer Public) (key wanted : Key) (answer : Answer key) (publicData : Public) + (registered : view.registry wanted = some publicData) : + (advance policy cursor view key answer).registry wanted = some publicData := by + by_cases same : wanted = key + · subst wanted + simp [advance,advanceCaptured,registered] + · by_cases missing : view.registry key = none + · simp [advance,advanceCaptured,missing,Function.update_of_ne same,registered] + · simp [advance,advanceCaptured,missing,registered] + +theorem registry_records_snapshot (policy : Policy Key Answer Public) (cursor : Nat) + (view : View Key Answer Public) (key : Key) (answer : Answer key) : + (advance policy cursor view key answer).registry key = some (snapshot policy cursor view key) := by + cases registered : view.registry key with + | none => simp [advance,advanceCaptured,registered] + | some publicData => simp [advance,advanceCaptured,snapshot,registered] + +omit [DecidableEq Key] in +theorem replay_snapshot (policy : Policy Key Answer Public) (cursor : Nat) + (view : View Key Answer Public) (key : Key) (publicData : Public) + (registered : view.registry key = some publicData) : + snapshot policy cursor view key = publicData := by simp [snapshot,registered] + +/-- Precise actual-source replay adapter condition. If a raw key aliases a new +logical context, its pending literal certificate must agree with the first +capture. Merkle/framing exclusions may establish this; they are not assumed +away or converted to fresh randomness by the finite-game theorem. -/ +def ReplayCompatible (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (cursor : Nat) (view : View Key Answer Public) (key : Key) : Prop := + ∀ publicData, view.registry key = some publicData → + cert.before publicData key = cert.before (policy.prepare cursor view.history key) key ∧ + ∀ answer : Answer key, cert.after publicData key answer = + cert.after (policy.prepare cursor view.history key) key answer + +omit [DecidableEq Key] in +theorem replay_certificate_agrees (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (cursor : Nat) (view : View Key Answer Public) (key : Key) + (compatible : ReplayCompatible cert policy cursor view key) : + cert.before (snapshot policy cursor view key) key = + cert.before (policy.prepare cursor view.history key) key ∧ + ∀ answer : Answer key, cert.after (snapshot policy cursor view key) key answer = + cert.after (policy.prepare cursor view.history key) key answer := by + cases registered : view.registry key with + | none => simp [snapshot,registered] + | some publicData => + simpa only [snapshot,registered] using compatible publicData registered + +def program (policy : Policy Key Answer Public) : (n : Nat) → Nat → View Key Answer Public → + Sampling Key Answer (View Key Answer Public) n + | 0, _, view => .ret view + | n+1, cursor, view => + match policy.choose cursor view.history with + | none => Sampling.pad (Nat.le_succ n) (program policy n (cursor+1) view) + | some key => + let publicData := snapshot policy cursor view key + .draw key (fun answer => + program policy n (cursor+1) (advanceCaptured view key publicData answer)) + +/-- Exact structural condition needed for restoring a nonzero public state: +it inherits a completed state-one record. It has no probabilistic hypothesis. -/ +def Causal (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) : + (n : Nat) → Nat → View Key Answer Public → Prop + | 0, _, _ => True + | n+1, cursor, view => + match policy.choose cursor view.history with + | none => Causal cert policy n (cursor+1) view + | some key => (cert.before (snapshot policy cursor view key) key = true → Doomed cert view.history) ∧ + ∀ answer, Causal cert policy n (cursor+1) (advance policy cursor view key answer) + +private theorem dirty_advance (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (cursor : Nat) (view : View Key Answer Public) (key : Key) (answer : Answer key) : + Dirty cert (advance policy cursor view key answer).history ↔ + Transition cert (snapshot policy cursor view key) key answer ∨ Dirty cert view.history := by + simp [advance,advanceCaptured,Dirty] + +private theorem coherent_advance (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (cursor : Nat) (view : View Key Answer Public) (key : Key) (answer : Answer key) + (initialCoherent : Doomed cert view.history → Dirty cert view.history) + (restore : cert.before (snapshot policy cursor view key) key = true → Doomed cert view.history) : + Doomed cert (advance policy cursor view key answer).history → + Dirty cert (advance policy cursor view key answer).history := by + intro doomed + obtain ⟨entry,member,after⟩ := doomed + rcases List.mem_cons.mp member with equal | member + · subst entry + cases before : cert.before (snapshot policy cursor view key) key with + | false => exact (dirty_advance cert policy cursor view key answer).mpr (Or.inl ⟨before,after⟩) + | true => + exact (dirty_advance cert policy cursor view key answer).mpr (Or.inr (initialCoherent (restore before))) + · exact (dirty_advance cert policy cursor view key answer).mpr (Or.inr (initialCoherent ⟨entry,member,after⟩)) + +theorem execution_has_transition (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (n cursor : Nat) (view : View Key Answer Public) (causal : Causal cert policy n cursor view) + (initialCoherent : Doomed cert view.history → Dirty cert view.history) + (table : (key : Key) → Answer key) : + Doomed cert (Sampling.eval table (program policy n cursor view)).history → + Dirty cert (Sampling.eval table (program policy n cursor view)).history := by + induction n generalizing cursor view with + | zero => exact initialCoherent + | succ n ih => + cases chosen : policy.choose cursor view.history with + | none => + simp only [program,chosen,Sampling.eval_pad] + exact ih _ _ (by simpa only [Causal,chosen] using causal) initialCoherent + | some key => + have localCausal : (cert.before (snapshot policy cursor view key) key = true → Doomed cert view.history) ∧ + ∀ answer, Causal cert policy n (cursor+1) (advance policy cursor view key answer) := by + simpa only [Causal,chosen] using causal + simp only [program,chosen,Sampling.eval] + exact ih _ _ (localCausal.2 _) (coherent_advance cert policy cursor view key _ initialCoherent localCausal.1) + +end Execution + +section Probability +variable [DecidableEq Key] [∀ key, Fintype (Answer key)] [∀ key, Nonempty (Answer key)] + +def ConditionalHazard (cert : Certificate Key Answer Public) (epsilon : ℚ) : Prop := + ∀ publicData key, cert.before publicData key = false → + average (fun answer : Answer key => if cert.after publicData key answer = true then (1 : ℚ) else 0) ≤ epsilon + +/-- Operational cache/metadata invariant. It will be derived from the empty +view and cache, not supplied as a security assumption on the final experiment. -/ +def Recorded (view : View Key Answer Public) (cache : Cache Key Answer) : Prop := + ∀ key answer, cache key = some answer → ∃ publicData, + view.registry key = some publicData ∧ (publicData,⟨key,answer⟩) ∈ view.history + +omit [∀ key, Fintype (Answer key)] [∀ key, Nonempty (Answer key)] in +private theorem recorded_advance (policy : Policy Key Answer Public) (cursor : Nat) + (view : View Key Answer Public) (cache : Cache Key Answer) (recorded : Recorded view cache) + (key : Key) (answer : Answer key) : + Recorded (advance policy cursor view key answer) (put cache key answer) := by + intro wanted value present + by_cases same : wanted = key + · subst wanted + simp only [put_self,Option.some.injEq] at present + subst value + exact ⟨snapshot policy cursor view key,registry_records_snapshot policy cursor view key answer,List.mem_cons_self⟩ + · obtain ⟨publicData,registered,member⟩ := recorded wanted value (by simpa [put_other,same] using present) + exact ⟨publicData,registry_never_overwrites policy cursor view key wanted answer publicData registered, + List.mem_cons_of_mem _ member⟩ + + +/-- Actual adaptive memoized probability bound with first-capture metadata. +Retries can use the full past; only a distinct fresh raw-key exposure is charged. -/ +theorem memo_transition_bound (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard cert epsilon) + (n cursor : Nat) (view : View Key Answer Public) (cache : Cache Key Answer) + (recorded : Recorded view cache) (clean : ¬ Dirty cert view.history) : + Sampling.expectation (fun result => if Dirty cert result.1.history then (1 : ℚ) else 0) + (RawOracleCoupling.memo (program policy n cursor view) cache) ≤ (n : ℚ)*epsilon := by + classical + induction n generalizing cursor view cache with + | zero => simp [program,RawOracleCoupling.memo,Sampling.expectation,clean] + | succ n ih => + have increase : (n : ℚ)*epsilon ≤ ((n+1 : Nat) : ℚ)*epsilon := + mul_le_mul_of_nonneg_right (by exact_mod_cast Nat.le_succ n) nonnegative + cases chosen : policy.choose cursor view.history with + | none => + simp only [program,chosen,memo_expectation_pad] + exact (ih _ _ _ recorded clean).trans increase + | some key => + cases hit : cache key with + | some answer => + obtain ⟨publicData,registered,member⟩ := recorded key answer hit + have repeated : ¬ Transition cert (snapshot policy cursor view key) key answer := by + rw [replay_snapshot policy cursor view key publicData registered] + exact fun transition => clean ⟨_,member,transition⟩ + have continued : ¬ Dirty cert (advance policy cursor view key answer).history := by + rw [dirty_advance]; exact not_or.mpr ⟨repeated,clean⟩ + have oldRecorded : Recorded (advance policy cursor view key answer) cache := by + intro wanted value present + obtain ⟨publicData,registered,member⟩ := recorded wanted value present + exact ⟨publicData,registry_never_overwrites policy cursor view key wanted answer publicData registered, + List.mem_cons_of_mem _ member⟩ + simp only [program,chosen,RawOracleCoupling.memo,hit,Sampling.expectation_pad] + exact (ih _ _ _ oldRecorded continued).trans increase + | none => + simp only [program,chosen,RawOracleCoupling.memo,hit,Sampling.expectation] + have fibers (answer : Answer key) : + Sampling.expectation (fun result => if Dirty cert result.1.history then (1 : ℚ) else 0) + (RawOracleCoupling.memo (program policy n (cursor+1) (advance policy cursor view key answer)) + (put cache key answer)) ≤ + (if Transition cert (snapshot policy cursor view key) key answer then 1 else 0) + (n : ℚ)*epsilon := by + by_cases bad : Transition cert (snapshot policy cursor view key) key answer + · have one := Sampling.expectation_le_one + (fun result : View Key Answer Public × Cache Key Answer => if Dirty cert result.1.history then (1 : ℚ) else 0) + (fun result => by split <;> norm_num) + (RawOracleCoupling.memo (program policy n (cursor+1) (advance policy cursor view key answer)) + (put cache key answer)) + simpa only [bad,↓reduceIte] using one.trans + (le_add_of_nonneg_right (mul_nonneg (Nat.cast_nonneg n) nonnegative)) + · have continued : ¬ Dirty cert (advance policy cursor view key answer).history := by + rw [dirty_advance]; exact not_or.mpr ⟨bad,clean⟩ + simpa only [bad,↓reduceIte,zero_add] using + ih _ _ _ (recorded_advance policy cursor view cache recorded key answer) continued + have localBound : average (fun answer : Answer key => + if Transition cert (snapshot policy cursor view key) key answer then (1 : ℚ) else 0) ≤ epsilon := by + cases before : cert.before (snapshot policy cursor view key) key with + | false => simpa only [Transition,before,true_and] using hazard (snapshot policy cursor view key) key before + | true => simpa [Transition,before,average_const] using nonnegative + calc + _ ≤ average (fun answer : Answer key => + (if Transition cert (snapshot policy cursor view key) key answer then (1 : ℚ) else 0) + (n : ℚ)*epsilon) := average_mono fibers + _ ≤ epsilon + (n : ℚ)*epsilon := by + rw [average_add,average_const]; exact add_le_add localBound le_rfl + _ = ((n+1 : Nat) : ℚ)*epsilon := by push_cast; ring + +omit [DecidableEq Key] [∀ key, Nonempty (Answer key)] in +theorem conditionalHazard_of_uniform (cert : Certificate Key Answer Public) (epsilon : ℚ) + (fibers : ∀ publicData key, cert.before publicData key = false → + Soundness.uniformProb (Finset.univ.filter fun answer : Answer key => + cert.after publicData key answer = true) ≤ epsilon) : ConditionalHazard cert epsilon := by + classical + intro publicData key before + simpa only [average,Soundness.uniformProb,Finset.card_filter,Nat.cast_sum, + Nat.cast_ite,Nat.cast_one,Nat.cast_zero] using fibers publicData key before + +/-- Conditional game after an explicitly represented fixed public prefix. +Existing answers and first-registration metadata are not charged again. -/ +theorem fixed_prefix_failure_probability [Fintype Key] + (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard cert epsilon) + (n cursor : Nat) (view : View Key Answer Public) (cache : Cache Key Answer) + (recorded : Recorded view cache) (clean : ¬ Dirty cert view.history) + (initialCoherent : Doomed cert view.history → Dirty cert view.history) + (causal : Causal cert policy n cursor view) (failure : View Key Answer Public → Prop) + (endpoint : ∀ table : (key : Key) → Answer key, + failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)) → + Doomed cert (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)).history) : + Soundness.uniformProb (Finset.univ.filter fun table : (key : Key) → Answer key => + failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view))) ≤ + (n : ℚ)*epsilon := by + classical + have bound := memo_transition_bound cert policy epsilon nonnegative hazard n cursor view cache recorded clean + have coupling := RawOracleCoupling.table_eq_memo (program policy n cursor view) cache + (fun view => if Dirty cert view.history then (1 : ℚ) else 0) + have tableBound := coupling.trans_le bound + have covered : average (fun table : (key : Key) → Answer key => + if failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)) + then (1 : ℚ) else 0) ≤ (n : ℚ)*epsilon := by + apply le_trans _ tableBound + apply average_mono + intro table + by_cases bad : failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)) + · have transition := execution_has_transition cert policy n cursor view causal initialCoherent + (RawOracleCoupling.overlay cache table) (endpoint table bad) + simp [bad,transition] + · simp only [bad,↓reduceIte]; split <;> norm_num + simpa only [average,Soundness.uniformProb,Finset.card_filter,Nat.cast_sum, + Nat.cast_ite,Nat.cast_one,Nat.cast_zero] using covered + +/-- Empty-view PCS game with exactly the requested Q+k dependence. First-capture +metadata invariants are proved internally from the empty cache. The pointwise +endpoint cover, structural causality, and local fiber are the adapter interfaces. -/ +theorem accepted_failure_probability [Fintype Key] + (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard cert epsilon) + (Q k : Nat) (causal : Causal cert policy (Q+k) 0 initial) + (failure : View Key Answer Public → Prop) + (endpoint : ∀ table : (key : Key) → Answer key, + failure (Sampling.eval table (program policy (Q+k) 0 initial)) → + Doomed cert (Sampling.eval table (program policy (Q+k) 0 initial)).history) : + Soundness.uniformProb (Finset.univ.filter fun table : (key : Key) → Answer key => + failure (Sampling.eval table (program policy (Q+k) 0 initial))) ≤ + ((Q+k : Nat) : ℚ)*epsilon := by + exact fixed_prefix_failure_probability cert policy epsilon nonnegative hazard (Q+k) 0 initial + (fun _ => none) (by intro key answer hit; cases hit) (by simp [initial,Dirty]) + (by simp [initial,Doomed]) causal failure endpoint + +end Probability + +/-- The final verifier receives the entire adversarial history but gets only k +additional challenge slots, sharing the adversary's global registry and cache. -/ +def phases (Q : Nat) (adversary verifier : Policy Key Answer Public) : Policy Key Answer Public where + choose cursor history := if cursor < Q then adversary.choose cursor history + else verifier.choose (cursor-Q) history + prepare cursor history key := if cursor < Q then adversary.prepare cursor history key + else verifier.prepare (cursor-Q) history key + +#print axioms registry_never_overwrites +#print axioms execution_has_transition +#print axioms memo_transition_bound +#print axioms accepted_failure_probability +#print axioms fixed_prefix_failure_probability +end Whir.PCSStateRestoration.Adaptive diff --git a/verification/whir/Whir/PCSStateRestorationLatent.lean b/verification/whir/Whir/PCSStateRestorationLatent.lean new file mode 100644 index 000000000..505a1d01a --- /dev/null +++ b/verification/whir/Whir/PCSStateRestorationLatent.lean @@ -0,0 +1,168 @@ +import Whir.PCSStateRestorationLatentProbability + +/-! Latent-context state restoration. The reconstruction is a pure function of +all table coordinates except the queried one, not an operational certificate +oracle. It releases no ancestor answer, adds no query, and changes no program. +Actual-source adapters must implement that reconstruction and prove its literal +state correspondence; these obligations are not asserted by this module. -/ +namespace Whir.PCSStateRestoration.Latent +open TypedOracleCompiler TypedFiatShamirGame +open FiatShamirGame (average) + +set_option autoImplicit false +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +universe u v w z +variable {Key : Type u} {Answer : Key → Type v} {Public : Type w} + +/-- A literal full-table source reconstruction factors through the erased key +only if replacing that answer leaves it unchanged. This is a causality law, +not a final bad-probability premise. -/ +def ErasureIndependent [DecidableEq Key] (sourceSnapshot : Key → Table Key Answer → Public) : Prop := + ∀ key table answer, sourceSnapshot key (Function.update table key answer) = sourceSnapshot key table + +section Reconstruction +variable [DecidableEq Key] + +def fill (key : Key) (rest : Erased Answer key) (answer : Answer key) : Table Key Answer := + (Equiv.piSplitAt key Answer).symm (answer,rest) + +@[simp] theorem fill_erase (key : Key) (table : Table Key Answer) (answer : Answer key) : + fill key (erase key table) answer = Function.update table key answer := by + funext other + by_cases same : other = key + · subst other; simp [fill,Equiv.piSplitAt] + · simp [fill,erase,Equiv.piSplitAt,same] + +/-- Construct an erased-key reconstruction from an actual full-table function. +The fixed reference answer is mathematical coordinate filling, not a simulated +RO reply or an additional query. Its choice is immaterial under independence. -/ +def erasedReconstruction (sourceSnapshot : Key → Table Key Answer → Public) + (reference : (key : Key) → Answer key) (key : Key) (rest : Erased Answer key) : Public := + sourceSnapshot key (fill key rest (reference key)) + +theorem erased_reconstruction_eq_source (sourceSnapshot : Key → Table Key Answer → Public) + (reference : (key : Key) → Answer key) (independent : ErasureIndependent sourceSnapshot) + (key : Key) (table : Table Key Answer) : + erasedReconstruction sourceSnapshot reference key (erase key table) = sourceSnapshot key table := by + rw [erasedReconstruction,fill_erase] + exact independent key table (reference key) + +end Reconstruction + +/-- Pure latent public-node computation plus literal before/after state maps. +`reconstruct` has no access to the current answer by its domain, and is never +called by the operational Sampling computation. -/ +structure NodeModel (Key : Type u) (Answer : Key → Type v) (Public : Type w) where + reconstruct : (key : Key) → Erased Answer key → Public + before : Public → Key → Bool + after : Public → (key : Key) → Answer key → Bool + +def publicNode (model : NodeModel Key Answer Public) (key : Key) (table : Table Key Answer) : Public := + model.reconstruct key (erase key table) + +def before (model : NodeModel Key Answer Public) (key : Key) (table : Table Key Answer) : Bool := + model.before (publicNode model key table) key + +def after (model : NodeModel Key Answer Public) (key : Key) (table : Table Key Answer) : Bool := + model.after (publicNode model key table) key (table key) + +def Transition (model : NodeModel Key Answer Public) (key : Key) (table : Table Key Answer) : Prop := + before model key table = false ∧ after model key table = true + +/-- Source-round path through actual exposed key/value pairs. Its order can be +unrelated to query order, and its reconstructed ancestor draws can be latent at +the time of a child-prefix query. The path still links literal state values. -/ +inductive StatePath (model : NodeModel Key Answer Public) (table : Table Key Answer) + (exposed : List (Sigma Answer)) : Bool → Bool → Prop where + | nil (state : Bool) : StatePath model table exposed state state + | step (key : Key) {final : Bool} (recorded : (⟨key,table key⟩ : Sigma Answer) ∈ exposed) + (rest : StatePath model table exposed (after model key table) final) : + StatePath model table exposed (before model key table) final + +theorem path_has_transition (model : NodeModel Key Answer Public) (table : Table Key Answer) + (exposed : List (Sigma Answer)) (start finish : Bool) : + StatePath model table exposed start finish → start = false → finish = true → + ∃ entry ∈ exposed, Transition model entry.1 table := by + intro path + induction path with + | nil state => + intro initialState finalState + have impossible : false = true := initialState.symm.trans finalState + cases impossible + | step key member rest ih => + intro initialState finalState + cases returned : after model key table with + | false => exact ih returned finalState + | true => exact ⟨⟨key,table key⟩,member,initialState,returned⟩ + +section Probability +variable [DecidableEq Key] [Fintype Key] +variable [∀ key, Fintype (Answer key)] [∀ key, Nonempty (Answer key)] + +/-- Exact conditional uniform hazard for every erased complete table. The +reconstructed ancestors are fixed, even if they have not been disclosed. -/ +def ConditionalHazard (model : NodeModel Key Answer Public) (epsilon : ℚ) : Prop := + ∀ key rest, model.before (model.reconstruct key rest) key = false → + Soundness.uniformProb (Finset.univ.filter fun answer : Answer key => + model.after (model.reconstruct key rest) key answer = true) ≤ epsilon + +omit [Fintype Key] [∀ key, Nonempty (Answer key)] in +theorem latent_fiber_bound (model : NodeModel Key Answer Public) (epsilon : ℚ) + (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard model epsilon) : + FiberBound (Transition model) epsilon := by + classical + intro key table + have fixed (answer : Answer key) : publicNode model key (Function.update table key answer) = publicNode model key table := by + simp [publicNode] + simp only [Transition,before,after,fixed,Function.update_self] + cases state : model.before (publicNode model key table) key with + | false => + simpa only [publicNode,average,Soundness.uniformProb,Finset.card_filter,Nat.cast_sum, + Nat.cast_ite,Nat.cast_one,Nat.cast_zero,true_and] using hazard key (erase key table) state + | true => simpa [average] using nonnegative + +/-- Accepted extraction-failure paths from initial zero imply an observed +transition. No chronological causality restriction is imposed on queries. -/ +theorem accepted_path_failure_probability {R : Type z} (model : NodeModel Key Answer Public) + (Q k : Nat) (source : Sampling Key Answer R (Q+k)) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard model epsilon) + (failure : Table Key Answer → Prop) + (acceptedPath : ∀ table, failure table → StatePath model table (Sampling.execute table source).2 false true) : + Soundness.uniformProb (Finset.univ.filter failure) ≤ ((Q+k : Nat) : ℚ)*epsilon := by + apply covered_failure_probability (Transition model) epsilon nonnegative + (latent_fiber_bound model epsilon nonnegative hazard) source failure + intro table failed + exact path_has_transition model table _ false true (acceptedPath table failed) rfl rfl + +/-- Q adversarial requests followed by k verifier lookups. The continuations, +all keys and repetitions are retained, with no ancestor-warming transformation. -/ +theorem adversary_verifier_failure_probability {R S : Type z} (model : NodeModel Key Answer Public) + (Q k : Nat) (adversary : Sampling Key Answer R Q) (verifier : R → Sampling Key Answer S k) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard model epsilon) + (failure : Table Key Answer → Prop) + (acceptedPath : ∀ table, failure table → + StatePath model table (Sampling.execute table (Sampling.bind adversary verifier)).2 false true) : + Soundness.uniformProb (Finset.univ.filter failure) ≤ (Q : ℚ)*epsilon + (k : ℚ)*epsilon := by + have bound := accepted_path_failure_probability model Q k (Sampling.bind adversary verifier) + epsilon nonnegative hazard failure acceptedPath + simpa only [Nat.cast_add,add_mul] using bound + +end Probability + +/-- Actual operation accounting: repeats stay in the request trace, while the +memo interpreter allocates distinct fresh keys and excludes the fixed prefix. -/ +theorem exposure_accounting [DecidableEq Key] {R : Type z} {n : Nat} + (source : Sampling Key Answer R n) (cache : Cache Key Answer) + (trace : List (Sigma Answer)) (result : R × Cache Key Answer) + (run : Sampling.Runs (RawOracleCoupling.memo source cache) trace result) : + trace.length ≤ n ∧ (trace.map Sigma.fst).Nodup ∧ ∀ entry ∈ trace, cache entry.1 = none := by + obtain ⟨fresh,distinct⟩ := PCSStateRestoration.memo_runs_distinct source cache trace result run + exact ⟨run.length_le,distinct,fresh⟩ + +#print axioms erased_reconstruction_eq_source +#print axioms path_has_transition +#print axioms latent_fiber_bound +#print axioms accepted_path_failure_probability +#print axioms adversary_verifier_failure_probability +end Whir.PCSStateRestoration.Latent diff --git a/verification/whir/Whir/PCSStateRestorationLatentProbability.lean b/verification/whir/Whir/PCSStateRestorationLatentProbability.lean new file mode 100644 index 000000000..fd0501e54 --- /dev/null +++ b/verification/whir/Whir/PCSStateRestorationLatentProbability.lean @@ -0,0 +1,250 @@ +import Whir.PCSStateRestoration + +/-! Finite first-disclosure union bound with events depending on latent table +coordinates. No ancestor is warmed and no adversarial query is restricted. -/ +namespace Whir.PCSStateRestoration.Latent +open TypedOracleCompiler TypedFiatShamirGame +open FiatShamirGame (average average_mono average_const average_add) + +set_option autoImplicit false + +universe u v w +variable {Key : Type u} {Answer : Key → Type v} {R : Type w} + +abbrev Table (Key : Type u) (Answer : Key → Type v) := (key : Key) → Answer key +abbrev Erased (Answer : Key → Type v) (key : Key) := (other : {other : Key // other ≠ key}) → Answer other.val + +def erase (key : Key) (table : Table Key Answer) : Erased Answer key := fun other => table other.val + +section Execution +variable [DecidableEq Key] + +@[simp] theorem erase_update (key : Key) (table : Table Key Answer) (answer : Answer key) : + erase key (Function.update table key answer) = erase key table := by + funext other + simp [erase,Function.update_of_ne other.property] + +/-- The actual complete public view before the first request of a selected key. +`none` means that the computation never requests that key. -/ +def firstDisclosure (target : Key) : {n : Nat} → Sampling Key Answer R n → Table Key Answer → + Option (List (Sigma Answer)) + | _, .ret _, _ => none + | _, .draw key next, table => + if key = target then some [] else + (firstDisclosure target (next (table key)) table).map (fun past => ⟨key,table key⟩ :: past) + +/-- First-query selection and its entire preceding view are independent of +that key's answer. This is proved from the actual adaptive Sampling execution, +not a freshness premise on the adversary or an observer restriction. -/ +theorem first_disclosure_answer_independent {n : Nat} (target : Key) + (source : Sampling Key Answer R n) (table : Table Key Answer) (answer : Answer target) : + firstDisclosure target source (Function.update table target answer) = firstDisclosure target source table := by + induction source with + | ret result => rfl + | draw key next ih => + by_cases same : key = target + · simp [firstDisclosure,same] + · simp only [firstDisclosure,same,↓reduceIte,Function.update_of_ne same,ih] + +/-- The selected first-disclosure prefix really precedes a request in the +ordinary operational trace. Subsequent requests remain in that trace. -/ +theorem first_disclosure_execution {n : Nat} (target : Key) (source : Sampling Key Answer R n) + (table : Table Key Answer) (past : List (Sigma Answer)) + (selected : firstDisclosure target source table = some past) : + ∃ suffix, (Sampling.execute table source).2 = past ++ (⟨target,table target⟩ :: suffix) ∧ + ∀ entry ∈ past, entry.1 ≠ target := by + induction source generalizing past with + | ret result => simp [firstDisclosure] at selected + | draw key next ih => + by_cases same : key = target + · subst key + simp only [firstDisclosure,↓reduceIte,Option.some.injEq] at selected + subst past + exact ⟨(Sampling.execute table (next (table target))).2,rfl,by simp⟩ + · simp only [firstDisclosure,same,↓reduceIte] at selected + cases found : firstDisclosure target (next (table key)) table with + | none => simp [found] at selected + | some before => + simp only [found,Option.map_some,Option.some.injEq] at selected + subst past + obtain ⟨suffix,trace,absent⟩ := ih (table key) before found + refine ⟨suffix,?_,?_⟩ + · simp only [Sampling.execute,List.cons_append,trace] + · intro entry member + rcases List.mem_cons.mp member with equal | member + · subst entry; exact same + · exact absent entry member + +/-- Conversely every operational request is selected by the first-disclosure +finder. Together with `first_disclosure_execution`, this rules out a merely +plausible recognizer that ignores some actually requested keys. -/ +theorem first_disclosure_complete {n : Nat} (target : Key) (source : Sampling Key Answer R n) + (table : Table Key Answer) + (observed : ∃ entry ∈ (Sampling.execute table source).2, entry.1 = target) : + ∃ past, firstDisclosure target source table = some past := by + induction source with + | ret result => simp [Sampling.execute] at observed + | draw key next ih => + by_cases same : key = target + · exact ⟨[],by simp [firstDisclosure,same]⟩ + · obtain ⟨entry,member,equal⟩ := observed + rcases List.mem_cons.mp member with first | member + · subst entry; exact False.elim (same equal) + · obtain ⟨past,selected⟩ := ih (table key) ⟨entry,member,equal⟩ + exact ⟨⟨key,table key⟩ :: past,by simp [firstDisclosure,same,selected]⟩ + +/-- Whether the actual computation ever requests a key is answer-independent, +not just the syntactic recognizer's result. Repeated and later requests remain +unrestricted after that first exposure. -/ +theorem queried_key_answer_independent {n : Nat} (target : Key) + (source : Sampling Key Answer R n) (table : Table Key Answer) (answer : Answer target) : + (∃ entry ∈ (Sampling.execute (Function.update table target answer) source).2, entry.1 = target) ↔ + ∃ entry ∈ (Sampling.execute table source).2, entry.1 = target := by + have transfer (old new : Table Key Answer) + (same : firstDisclosure target source old = firstDisclosure target source new) + (observed : ∃ entry ∈ (Sampling.execute old source).2, entry.1 = target) : + ∃ entry ∈ (Sampling.execute new source).2, entry.1 = target := by + obtain ⟨past,selected⟩ := first_disclosure_complete target source old observed + obtain ⟨suffix,trace,_⟩ := first_disclosure_execution target source new past (same ▸ selected) + exact ⟨⟨target,new target⟩,by rw [trace]; simp,rfl⟩ + have same := first_disclosure_answer_independent target source table answer + exact ⟨transfer _ _ same,transfer _ _ same.symm⟩ + +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +/-- One charge per distinct first exposure. Events may depend on all other +latent coordinates of the same table, including ancestors queried later. -/ +noncomputable def count (bad : Key → Table Key Answer → Prop) : {n : Nat} → + Sampling Key Answer R n → Cache Key Answer → Table Key Answer → Nat + | _, .ret _, _, _ => 0 + | _, .draw key next, cache, table => + match cache key with + | some _ => count bad (next (table key)) cache table + | none => (if bad key table then 1 else 0) + + count bad (next (table key)) (put cache key (table key)) table + +def ObservedBad (bad : Key → Table Key Answer → Prop) {n : Nat} + (source : Sampling Key Answer R n) (table : Table Key Answer) : Prop := + ∃ entry ∈ (Sampling.execute table source).2, bad entry.1 table + +/-- Pointwise coverage by a first exposure, including arbitrary repeats. -/ +theorem observed_bad_count_positive (bad : Key → Table Key Answer → Prop) {n : Nat} + (source : Sampling Key Answer R n) (cache : Cache Key Answer) (table : Table Key Answer) + (safe : ∀ key answer, cache key = some answer → ¬ bad key table) + (observed : ObservedBad bad source table) : 0 < count bad source cache table := by + induction source generalizing cache with + | ret result => simp [ObservedBad,Sampling.execute] at observed + | draw key next ih => + cases hit : cache key with + | some answer => + obtain ⟨entry,member,event⟩ := observed + rcases List.mem_cons.mp member with equal | member + · subst entry; exact False.elim (safe key answer hit event) + · simp only [count,hit] + exact ih (table key) cache safe ⟨entry,member,event⟩ + | none => + by_cases badNow : bad key table + · simp only [count,hit,badNow,↓reduceIte] + omega + · obtain ⟨entry,member,event⟩ := observed + rcases List.mem_cons.mp member with equal | member + · subst entry; exact False.elim (badNow event) + · have nextSafe : ∀ wanted value, put cache key (table key) wanted = some value → ¬ bad wanted table := by + intro wanted value present + by_cases same : wanted = key + · subst wanted; exact badNow + · exact safe wanted value (by simpa [put_other,same] using present) + simpa only [count,hit,badNow,↓reduceIte,zero_add] using + ih (table key) (put cache key (table key)) nextSafe ⟨entry,member,event⟩ + +end Execution + +section Probability +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P +variable [DecidableEq Key] [Fintype Key] +variable [∀ key, Fintype (Answer key)] [∀ key, Nonempty (Answer key)] + +/-- Uniform fiber condition with the complete remaining table fixed. Later +coins are not averaged away or replaced by independent placeholder events. -/ +def FiberBound (bad : Key → Table Key Answer → Prop) (epsilon : ℚ) : Prop := + ∀ key table, average (fun answer : Answer key => + if bad key (Function.update table key answer) then (1 : ℚ) else 0) ≤ epsilon + +/-- Exact adaptive finite-table first-disclosure bound. The induction uses the +causal Sampling continuations and exact selected-coordinate disintegration; +the latent event itself need not be measurable from the disclosed history. -/ +theorem adaptive_first_disclosure_bound (bad : Key → Table Key Answer → Prop) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (fiber : FiberBound bad epsilon) + {n : Nat} (source : Sampling Key Answer R n) (cache : Cache Key Answer) : + average (fun table : Table Key Answer => + (count bad source cache (RawOracleCoupling.overlay cache table) : ℚ)) ≤ (n : ℚ)*epsilon := by + induction source generalizing cache with + | ret result => + simp only [count,Nat.cast_zero,average_const] + exact mul_nonneg (Nat.cast_nonneg _) nonnegative + | @draw n key next ih => + cases hit : cache key with + | some answer => + have answered (table : Table Key Answer) : RawOracleCoupling.overlay cache table key = answer := by + simp [RawOracleCoupling.overlay,hit] + simp only [count,hit] + simp_rw [answered] + exact (ih answer cache).trans + (mul_le_mul_of_nonneg_right (by exact_mod_cast Nat.le_succ n) nonnegative) + | none => + rw [RawOracleCoupling.overlay_average cache key hit + (fun table => (count bad (.draw key next) cache table : ℚ))] + have answered (answer : Answer key) (table : Table Key Answer) : + RawOracleCoupling.overlay (put cache key answer) table key = answer := by + simp [RawOracleCoupling.overlay] + simp only [count,hit,Nat.cast_add,Nat.cast_ite,Nat.cast_one,Nat.cast_zero] + simp_rw [answered,average_add] + have localBound : average (fun answer : Answer key => average (fun table : Table Key Answer => + if bad key (RawOracleCoupling.overlay (put cache key answer) table) then (1 : ℚ) else 0)) ≤ epsilon := by + rw [RawOracleCoupling.average_comm] + have perRest (table : Table Key Answer) : average (fun answer : Answer key => + if bad key (RawOracleCoupling.overlay (put cache key answer) table) then (1 : ℚ) else 0) ≤ epsilon := by + simpa only [RawOracleCoupling.overlay_put] using fiber key (RawOracleCoupling.overlay cache table) + exact (average_mono perRest).trans (le_of_eq (average_const epsilon)) + have continued : average (fun answer : Answer key => average (fun table : Table Key Answer => + (count bad (next answer) (put cache key answer) + (RawOracleCoupling.overlay (put cache key answer) table) : ℚ))) ≤ (n : ℚ)*epsilon := by + exact (average_mono (fun answer => ih answer (put cache key answer))).trans (le_of_eq (average_const _)) + calc + _ ≤ epsilon + (n : ℚ)*epsilon := add_le_add localBound continued + _ = ((n : ℚ)+1)*epsilon := by ring + +/-- Generic failure coverage; the endpoint is pointwise, not a probability or +soundness assumption. The bound charges requests rather than the key universe. -/ +theorem covered_failure_probability (bad : Key → Table Key Answer → Prop) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (fiber : FiberBound bad epsilon) + {n : Nat} (source : Sampling Key Answer R n) (failure : Table Key Answer → Prop) + (cover : ∀ table, failure table → ObservedBad bad source table) : + Soundness.uniformProb (Finset.univ.filter failure) ≤ (n : ℚ)*epsilon := by + classical + have bounded := adaptive_first_disclosure_bound bad epsilon nonnegative fiber source (fun _ => none) + simp only [RawOracleCoupling.overlay_empty] at bounded + have covered : average (fun table : Table Key Answer => if failure table then (1 : ℚ) else 0) ≤ + (n : ℚ)*epsilon := by + apply le_trans _ bounded + apply average_mono + intro table + by_cases failed : failure table + · have positive := observed_bad_count_positive bad source (fun _ => none) table + (by intro key answer hit; cases hit) (cover table failed) + simp only [failed,↓reduceIte] + exact_mod_cast positive + · simp only [failed,↓reduceIte] + positivity + simpa only [average,Soundness.uniformProb,Finset.card_filter,Nat.cast_sum, + Nat.cast_ite,Nat.cast_one,Nat.cast_zero] using covered + +end Probability + +#print axioms first_disclosure_answer_independent +#print axioms first_disclosure_execution +#print axioms first_disclosure_complete +#print axioms queried_key_answer_independent +#print axioms adaptive_first_disclosure_bound +#print axioms covered_failure_probability +end Whir.PCSStateRestoration.Latent diff --git a/verification/whir/lakefile.toml b/verification/whir/lakefile.toml index 297b5f6f5..b1967b6d5 100644 --- a/verification/whir/lakefile.toml +++ b/verification/whir/lakefile.toml @@ -58,3 +58,11 @@ root = "Whir.PCSBCSRoundsSmoke" [[lean_exe]] name = "whirMerkleLogExtractionSmoke" root = "Whir.MerkleQueryLogExtractionSmoke" + +[[lean_exe]] +name = "pcsbcsSourceCoordinateDecoderSmoke" +root = "Whir.PCSBCSSourceCoordinateDecoderSmoke" + +[[lean_exe]] +name = "pcsbcsPublicLogExtractorSmoke" +root = "Whir.PCSBCSPublicLogExtractorSmoke" From e5d7cf5949aae4825dc999ecb3cf7b9a88cee776 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sun, 11 Oct 2026 15:25:55 +0100 Subject: [PATCH 18/28] docs(whir): pin transcript claims before session rewrite --- verification/whir/README.md | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 06cdbffbe..98049da24 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -1,6 +1,6 @@ # Executable WHIR model, binding and interactive extraction -This isolated Lean project models leanVM's binary-field interleaved WHIR variant, originally pinned to [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217) and integrated normally with upstream [`10266a181437019400bc93d8dfbb373301ba8aa5`](https://github.com/leanEthereum/leanVM/tree/10266a181437019400bc93d8dfbb373301ba8aa5). It contains the executable concrete prover/verifier, checked field/encoder mathematics, adaptive interactive list binding, immutable-anchor selection mathematics, an actual original-statement interactive reset extractor, and a proved adaptive ideal-compression duplex coupling. The duplex model matches #552 at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`; the live Rust harness remains historical. Fresh Rust differential checks are separate implementation evidence. These results do not establish Fiat-Shamir knowledge soundness, universal current-source correspondence or unconditional concrete BLAKE2s security. +This isolated Lean project models leanVM's binary-field interleaved WHIR variant, originally pinned to [`edafd396120f453de6f75013f231bfda2049f217`](https://github.com/leanEthereum/leanVM/tree/edafd396120f453de6f75013f231bfda2049f217) and integrated normally with upstream [`10266a181437019400bc93d8dfbb373301ba8aa5`](https://github.com/leanEthereum/leanVM/tree/10266a181437019400bc93d8dfbb373301ba8aa5). It contains the executable concrete prover/verifier, checked field/encoder mathematics, adaptive interactive list binding, immutable-anchor selection mathematics, an actual original-statement interactive reset extractor, and a proved adaptive ideal-compression duplex coupling. The duplex model matches the pre-#607 transcript at #552's `f11f84f585680cf10f676bb4d9ae1a67e26547ca`, not the newly deployed session and raw-byte transcript. The live Rust harness remains historical. Fresh Rust differential checks are separate implementation evidence. These results do not establish Fiat-Shamir knowledge soundness, universal current-source correspondence or unconditional concrete BLAKE2s security. ## Reproduce @@ -34,12 +34,14 @@ systemd-run --user --scope -q -p MemoryMax=16G -p MemorySwapMax=0 .lake/build/bi The live differential harness executes relative dependencies from the proof checkout's historical Rust source pin `10266a181437019400bc93d8dfbb373301ba8aa5`, not the latest upstream tree. At that pin, relevant paths are `pcs/src/{ntt,stack_open,whir}/mod.rs` and `whir/{config,sumcheck}/mod.rs`. [#559 at `a956c82ac711b2f4dbb3793ef2679fa47f3d6435`](https://github.com/leanEthereum/leanVM/commit/a956c82ac711b2f4dbb3793ef2679fa47f3d6435) changed deeper commitments to retained message/NTT/Merkle data with queried rows regenerated and replayed in original order. [#550 at `f52bd991c8623894e7b03a2e50bede6c248ea1ad`](https://github.com/leanEthereum/leanVM/commit/f52bd991c8623894e7b03a2e50bede6c248ea1ad) changed optimized NTT/induced-weight execution; these kernels remain differentially checked, not universally refined. [#537 at `b735ce59975e51414b3290fce50e7a7ea10600b2`](https://github.com/leanEthereum/leanVM/commit/b735ce59975e51414b3290fce50e7a7ea10600b2) removed the Python verifier and its integrations. The Python runner here is orchestration, not a replacement verifier. -[#552 is now merged at upstream `f11f84f585680cf10f676bb4d9ae1a67e26547ca`](https://github.com/leanEthereum/leanVM/commit/f11f84f585680cf10f676bb4d9ae1a67e26547ca). Its deployed framed byte duplex is the mode modeled by `DuplexRefinement` and `DuplexFraming`, pinned to [`ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). Inspection of the other Fiat Shamir files and native, recursive, CPU, tree and reduction callsites confirms that mode correspondence: native duplex, arithmetic adapter and recursive transcript blobs are identical; Merkle documentation and the removed Python raw-stream header do not change transcript transitions. This is a source audit, not universal compiler correspondence. The proof checkout's live differential harness remains integrated with the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source, whose old CV transcript must not be described as current upstream deployment. +[#552 merged at upstream `f11f84f585680cf10f676bb4d9ae1a67e26547ca`](https://github.com/leanEthereum/leanVM/commit/f11f84f585680cf10f676bb4d9ae1a67e26547ca). Its historical framed byte duplex is the mode modeled by `DuplexRefinement` and `DuplexFraming`, pinned to [`ff6a275304a3b577118b066ddcff83bfafa5998d`](https://github.com/leanEthereum/leanVM/commit/ff6a275304a3b577118b066ddcff83bfafa5998d). Inspection of the other Fiat Shamir files and native, recursive, CPU, tree and reduction callsites confirmed correspondence at that merge: native duplex, arithmetic adapter and recursive transcript blobs were identical; Merkle documentation and the removed Python raw-stream header did not change transcript transitions. This historical source audit does not cover #607 and is not universal compiler correspondence. The proof checkout's live differential harness remains integrated with `10266a181437019400bc93d8dfbb373301ba8aa5`, whose old CV transcript must not be described as current upstream deployment. At the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source pin, `stack_open/mod.rs::check_statement` checks point-claim range ends, not offset alignment or strided-slot bounds. The harness reports actual acceptance of three independently incorrect malformed selector claims as **KNOWN GAP**, outside valid-shape Lean comparisons. [#599 at `5735b019`](https://github.com/leanEthereum/leanVM/commit/5735b019) has since replaced that public stack implementation with typed `pcs/src/stack.rs`, including aligned full-block containment and strided-slot validation. Its WHIR kernels are crate-internal, the test-only public dense-weight entry point is gone, NTT code is unified in `ntt.rs`, and query induction uses `whir::query::{Normalizers,QueryBatch}`. The mathematical native correspondence still requires `SuccinctPointWeight.Shape`; the historical harness does not establish correspondence for every statement accepted or rejected by this new source. No production Rust changes are made by this proof update. [#555 at `9255db3ea2a604898c8af4677f4707d5f671f83a`](https://github.com/leanEthereum/leanVM/commit/9255db3ea2a604898c8af4677f4707d5f671f83a) subsequently changes `fiat_shamir/src/merkle.rs` to batched verifier hashing and the production scalar BLAKE2s implementation under `primitives/src/hash`. The preceding Fiat Shamir file and callsite equality audit is pinned to the #552 merge, not a claim that these newer files are identical. The mathematical duplex transition model and BLAKE2s specification are distinct from universal refinement of the new optimized Rust backend. Its x86 scalar compression now reaches inline assembly, which the pinned Aeneas backend does not currently translate; a checked assembly semantics/ABI bridge is an additional explicit source-correspondence obligation, not an opaque implementation assumed equivalent. +[#607 at `d3c7f9d9`](https://github.com/leanEthereum/leanVM/commit/d3c7f9d9) subsequently replaces the transcript interfaces, session initialization and codecs. The new [`duplex.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/fiat_shamir/src/duplex.rs) seeds from a 32-byte session IV, and [`codec.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/fiat_shamir/src/codec.rs) encodes digests as their raw bytes. [`pcs/src/verifier.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/pcs/src/verifier.rs) reads and absorbs a root as 32 bytes rather than the earlier two 24-byte field elements. These are framing and wire changes, not merely API renames. The existing mode, native and anchor adapters remain pinned to the earlier source; a new session-IV and raw-byte framing adapter is required before their endpoints can apply to the deployed transcript. The ongoing native, Rows and session audit is separate from the checked historical model. + ## Protocol to code to theorem map @@ -159,9 +161,9 @@ The proved mathematical boundary includes concrete K/E field laws, the Lean addi - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. -- **Deployment/security target:** the public mode theorem models the #552 byte duplex deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not cover the new anchor frames or establish deterministic BLAKE2s security. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. +- **Deployment/security target:** the public mode theorem models the pre-#607 #552 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not currently apply to the #607 session-IV and raw-byte transcript, cover the new anchor frames or establish deterministic BLAKE2s security. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. -Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the #552 byte-duplex framing and the proved adaptive ideal-compression coupling. Additional anchor inputs, their cursor-based sampling, updated source-event refinement and Fiat-Shamir knowledge extraction remain separate composition obligations. +Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the historical #552 byte-duplex framing and the proved adaptive ideal-compression coupling. The #607 session-IV seed and raw-byte root absorption, additional anchor inputs, their cursor-based sampling, updated source-event refinement and Fiat-Shamir knowledge extraction remain separate composition obligations. Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte decoding error taxonomy or underflow behavior as production `TranscriptError`. The historical Rust smoke separately uses the actual stack opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte for byte theorem for all deployed callers is claimed. From 1cd6027592001b8cafec30d576b85fca0c3e403b Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Sun, 11 Oct 2026 15:35:19 +0100 Subject: [PATCH 19/28] docs(whir): record session transcript correspondence boundary --- verification/whir/README.md | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 98049da24..06fe04a15 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -40,7 +40,9 @@ At the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source pin, `stack_ [#555 at `9255db3ea2a604898c8af4677f4707d5f671f83a`](https://github.com/leanEthereum/leanVM/commit/9255db3ea2a604898c8af4677f4707d5f671f83a) subsequently changes `fiat_shamir/src/merkle.rs` to batched verifier hashing and the production scalar BLAKE2s implementation under `primitives/src/hash`. The preceding Fiat Shamir file and callsite equality audit is pinned to the #552 merge, not a claim that these newer files are identical. The mathematical duplex transition model and BLAKE2s specification are distinct from universal refinement of the new optimized Rust backend. Its x86 scalar compression now reaches inline assembly, which the pinned Aeneas backend does not currently translate; a checked assembly semantics/ABI bridge is an additional explicit source-correspondence obligation, not an opaque implementation assumed equivalent. -[#607 at `d3c7f9d9`](https://github.com/leanEthereum/leanVM/commit/d3c7f9d9) subsequently replaces the transcript interfaces, session initialization and codecs. The new [`duplex.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/fiat_shamir/src/duplex.rs) seeds from a 32-byte session IV, and [`codec.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/fiat_shamir/src/codec.rs) encodes digests as their raw bytes. [`pcs/src/verifier.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/pcs/src/verifier.rs) reads and absorbs a root as 32 bytes rather than the earlier two 24-byte field elements. These are framing and wire changes, not merely API renames. The existing mode, native and anchor adapters remain pinned to the earlier source; a new session-IV and raw-byte framing adapter is required before their endpoints can apply to the deployed transcript. The ongoing native, Rows and session audit is separate from the checked historical model. +[#607 at `d3c7f9d9`](https://github.com/leanEthereum/leanVM/commit/d3c7f9d9) subsequently replaces the transcript interfaces, session initialization and codecs. Inspection confirms the reachable role, counter and buffered absorb/squeeze core remains the same, but the surrounding source and wire do not. [`session.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/fiat_shamir/src/session.rs) derives a session identifier through the shared duplex; [`duplex.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/fiat_shamir/src/duplex.rs) then seeds from that identifier and zeros, with the public instance absorbed afterward. [`codec.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/fiat_shamir/src/codec.rs) and [`pcs/src/verifier.rs`](https://github.com/leanEthereum/leanVM/blob/d3c7f9d9/crates/pcs/src/verifier.rs) encode and absorb a root as 32 raw bytes rather than two 24-byte field elements. Positive proof of work now consumes a 32-byte challenge and absorbs an eight-byte nonce; zero work performs no step. Final recursion digests consume squeeze bytes rather than a nonmutating commitment node, and the proof wire separates byte messages from length-framed hints. Native and Rows agree on the new session, root and proof-of-work byte encodings by source inspection, not by a new executable or kernel correspondence check. Rows authenticates recorded opening witnesses but does not constrain exact hint-wire parsing or EOF. The historical mode, native, caller and anchor adapters therefore require new session, mixed-message, proof-of-work, digest, transport and budget refinements before their endpoints apply to this deployment. + +The new duplex documentation's `Q^2/2^257` and protocol prose's `choose(Q,2)/2^256` are not the checked whole-view coupling coefficient `min(1,(2Q^2-Q)/2^256)`. Neither smaller expression follows from that theorem. They require a separate correctly instantiated argument; this discrepancy is a proof-claim boundary, not a demonstrated attack or a lower bound on the rewritten protocol. Individual field challenge encoding remains a bijection onto `2^192` elements, but the changed proof-of-work and zero-work schedule still needs a new grouped source-allocation proof. ## Protocol to code to theorem map @@ -108,7 +110,7 @@ The proof constructs concrete initial-batching, fold-restoration, OOD/query-rest `WHIRROM.rom_list_binding_numeric` bounds actual standalone false acceptance by `min 1 (B * (K + 1) * 2^-79)`. `StackWHIRROM.rom_list_binding_numeric` gives `min 1 (B * (K + 1) * (2^-79 + ringCharge cap))` for original stacked family/point claims. Both prove their concrete replay parsing, strict-prefix event correspondence and terminal trace cover; neither asks the caller to assume accepted false openings are covered by bad events. Immutable statement catalogs and root oracles are explicit inputs, not mutable values chosen after a challenge. -`DuplexRefinement`, `DuplexFraming` and the `WHIRNativeSecurity` public compression chain model the framed byte duplex deployed at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. The capped conditional `2^-42` endpoint concerns that mode and the modeled unanchored native WHIR experiment under the resource and source-model premises below. The actual ideal-compression mode coupling is now proved, not a supplied DMV assumption. It is not a concrete BLAKE2s security bound or a theorem covering every deployed caller. Separate pinned anchored physical and cursor-byte refinements do not yet compose into the deployed anchored Fiat-Shamir endpoint; generic repeated-scalar vector sampling also does not establish whole-request exhaustion/error equivalence. +`DuplexRefinement`, `DuplexFraming` and the `WHIRNativeSecurity` public compression chain model the historical pre-#607 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. The capped conditional `2^-42` endpoint concerns that mode and the modeled unanchored native WHIR experiment under the resource and source-model premises below; it does not currently apply to the rewritten #607 deployment. The actual ideal-compression mode coupling is proved, not a supplied DMV assumption. It is not a concrete BLAKE2s security bound or a theorem covering every deployed caller. Separate pinned anchored physical and cursor-byte refinements do not yet compose into an anchored Fiat-Shamir endpoint; generic repeated-scalar vector sampling also does not establish whole-request exhaustion/error equivalence. `DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove framing inverses, message/template injection, canonical WHIR history encoding and structural mode conditions. `DuplexCompression` implements BLAKE2s compression. The separate actual source-stream coupling supplies the stochastic whole-view bound; structural framing alone is not used as its proof. @@ -222,7 +224,7 @@ Historical-pin release Rust `rec::verifier::tests::the_smallest_opening_holds_in Fresh compiled-model execution exposed a startup bug that interpreter/proof checks had not detected: even `whirModel query 8 0` was killed under the required memory scope before emitting a record. Generated `FieldCardinality` C initializers eagerly called `List.finRange` for the `2^64` base-field enumeration and constructed extension-field Cartesian products. The proof-only `FieldModel.instFintypeK` and `instFintypeE`, plus their dependent mathematical challenge-table instances, are now explicitly noncomputable. `FieldTower` supplies canonical computable superclass dictionaries directly from the already-proved `instCommRingE`, so executable ring kernels do not synthesize operations through the noncomputable field-inverse structure. No second set of arithmetic operations or laws is introduced. This removes unnecessary executable initialization without changing the finite carriers, cardinality theorems or mathematical security statements. The rebuilt compiled empty-query command emitted `queries=` successfully under the same scope. The maintained differential runner exercises the actual compiled executable, not an interpreter-only replacement. -After the correction, fresh `python3 differential/run.py` passed **71 live record groups** and production query batches `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)` at the historical proof-checkout source pin. The compiled Lean multilevel opening accepted and rejected its maintained malformed/tampered cases without stderr diagnostics. That pinned Rust opening accepted mixed point/strided/ring claims and rejected damaged streams/scalars/authentication and source enforced shape errors. It separately reported `accepted_incorrect_claim` for plain offset, strided offset and high strided slot, explicitly outside valid shape refinement. Its diagnostic label `deployed_keyed_step,max_pending:2,squeeze_tag:2` referred to that pin's historical CV compression transcript, not the #552 state machine now deployed upstream. The Lean opening replay uses supplied ideal challenges, not deployed BLAKE2s challenges. +After the correction, fresh `python3 differential/run.py` passed **71 live record groups** and production query batches `(1,9)`, `(5,47)`, `(7,29)`, `(17,31)`, `(63,8)`, `(8,0)` at the historical proof-checkout source pin. The compiled Lean multilevel opening accepted and rejected its maintained malformed/tampered cases without stderr diagnostics. That pinned Rust opening accepted mixed point/strided/ring claims and rejected damaged streams/scalars/authentication and source enforced shape errors. It separately reported `accepted_incorrect_claim` for plain offset, strided offset and high strided slot, explicitly outside valid shape refinement. Its diagnostic label `deployed_keyed_step,max_pending:2,squeeze_tag:2` referred to that pin's historical CV compression transcript, not the later #552 or #607 byte transcripts. The Lean opening replay uses supplied ideal challenges, not deployed BLAKE2s challenges. ## Earlier scoped validation From 0c7a9e931746db9429f1276a2d737d3c2dd1fdd9 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 05:01:29 +0100 Subject: [PATCH 20/28] proof: close public PCS extraction and current transcript adapters --- verification/whir/README.md | 65 +- verification/whir/Whir.lean | 66 + .../whir/Whir/AnchoredByteStreamSampler.lean | 98 ++ .../AnchoredFiatShamirSecurityBudget.lean | 152 ++ .../Whir/AnchoredIdealPhysicalAcceptance.lean | 410 +++++ .../Whir/AnchoredMixedAttackerPrefix.lean | 792 +++++++++ .../AnchoredMixedAttackerPrefixObserver.lean | 84 + .../AnchoredMixedAttackerPrefixSource.lean | 397 +++++ .../AnchoredMixedIdealSourceAcceptance.lean | 143 ++ .../whir/Whir/AnchoredPhysicalAfter.lean | 84 + .../whir/Whir/AnchoredPhysicalExecution.lean | 125 ++ .../AnchoredPhysicalKnowledgeAcceptance.lean | 212 +++ .../Whir/AnchoredPhysicalPreparation.lean | 337 ++++ .../AnchoredPrimitivePhysicalSnapshots.lean | 65 + .../whir/Whir/AnchoredSourceGroups.lean | 134 ++ .../whir/Whir/AnchoredSourcePacket.lean | 193 +++ .../whir/Whir/AuthenticatedResetSmoke.lean | 60 + verification/whir/Whir/ByteCodec.lean | 36 +- .../whir/Whir/ConcreteRowExtraction.lean | 70 +- .../whir/Whir/DeployedTranscript.lean | 290 ++++ .../whir/Whir/DeployedTranscriptCoupling.lean | 136 ++ .../Whir/DeployedTranscriptEntryAlias.lean | 92 + .../whir/Whir/DeployedTranscriptGame.lean | 243 +++ .../whir/Whir/DeployedTranscriptSource.lean | 125 ++ verification/whir/Whir/DuplexRefinement.lean | 24 + .../whir/Whir/ErasureInterpolation.lean | 107 ++ .../whir/Whir/FrobeniusExtraction.lean | 72 + .../Whir/InitialKnowledgeScheduleActual.lean | 87 + .../whir/Whir/InterleavedListExtraction.lean | 271 +++ .../whir/Whir/PCSBCSActualMerkleBound.lean | 16 +- .../PCSBCSAdaptiveSourceCallerSnapshot.lean | 127 ++ ...BCSAdaptiveSourceKnowledgeProbability.lean | 192 +++ .../Whir/PCSBCSAtomicAllocationTrace.lean | 79 + verification/whir/Whir/PCSBCSAtomicTrace.lean | 70 + .../PCSBCSCallerBusTablePolynomialBound.lean | 1121 +++++++++++++ ...BCSCallerBusTablePolynomialBoundSmoke.lean | 102 ++ .../Whir/PCSBCSCallerCPUPolynomialBound.lean | 1069 ++++++++++++ .../PCSBCSCallerCPUPolynomialBoundSmoke.lean | 85 + .../Whir/PCSBCSCallerCompletionCausality.lean | 413 +++++ .../PCSBCSCallerFlockPolynomialBound.lean | 420 +++++ ...PCSBCSCallerFlockPolynomialBoundSmoke.lean | 100 ++ .../Whir/PCSBCSCallerGKRPolynomialBound.lean | 163 ++ .../whir/Whir/PCSBCSCallerParserCost.lean | 958 +++++++++++ .../PCSBCSCallerParserPolynomialBound.lean | 291 ++++ .../whir/Whir/PCSBCSCallerPayloadCost.lean | 1481 +++++++++++++++++ .../Whir/PCSBCSCallerPayloadCostSmoke.lean | 194 +++ .../PCSBCSCallerPayloadPolynomialBound.lean | 437 +++++ .../PCSBCSCallerSchedulePolynomialBound.lean | 432 +++++ ...BCSCallerSchedulePolynomialBoundSmoke.lean | 144 ++ .../PCSBCSCallerSourcePolynomialBound.lean | 565 +++++++ .../PCSBCSCapturedIdealNativeAcceptance.lean | 197 +++ .../Whir/PCSBCSCapturedNativePhaseQuery.lean | 540 ++++++ .../Whir/PCSBCSCapturedNativeReplyBridge.lean | 482 ++++++ .../PCSBCSCapturedNativeReplyBridgeSmoke.lean | 182 ++ .../Whir/PCSBCSCapturedSourceAcceptance.lean | 276 +++ .../Whir/PCSBCSCapturedSourceExecutable.lean | 97 ++ .../PCSBCSCapturedSourceExecutableSmoke.lean | 185 ++ .../Whir/PCSBCSCapturedSourceProbability.lean | 120 ++ .../Whir/PCSBCSCapturedSourceStatePath.lean | 442 +++++ .../Whir/PCSBCSCapturedSourceTransport.lean | 238 +++ .../whir/Whir/PCSBCSChallengeOracleChain.lean | 139 ++ .../Whir/PCSBCSChallengeOracleDomains.lean | 52 + .../PCSBCSChallengeOracleRestoration.lean | 25 +- .../Whir/PCSBCSConstructionReplayTrace.lean | 197 +++ .../whir/Whir/PCSBCSCoordinateCodecCost.lean | 475 ++++++ .../PCSBCSExecutedCoordinateRecovery.lean | 136 ++ .../Whir/PCSBCSIdealConstructionAnswers.lean | 44 + .../whir/Whir/PCSBCSMerkleSeedProjection.lean | 340 ++++ .../Whir/PCSBCSMerkleSeedProjectionSmoke.lean | 81 + .../Whir/PCSBCSMerkleTableAuthenticity.lean | 46 + .../Whir/PCSBCSMixedConstructionTrace.lean | 109 ++ .../whir/Whir/PCSBCSMixedOrdinaryMerkle.lean | 215 +++ .../whir/Whir/PCSBCSNativeCallerOriginal.lean | 207 +++ .../whir/Whir/PCSBCSNativeCapturedLogs.lean | 133 ++ .../Whir/PCSBCSNativeCapturedOracles.lean | 159 ++ .../PCSBCSNativeCapturedReplyTransport.lean | 962 +++++++++++ .../whir/Whir/PCSBCSNativeCapturedRows.lean | 87 + .../whir/Whir/PCSBCSNativeCapturedTape.lean | 579 +++++++ .../whir/Whir/PCSBCSNativeCompleteAlarm.lean | 105 ++ .../Whir/PCSBCSNativeIdealCallerOriginal.lean | 103 ++ .../whir/Whir/PCSBCSNativeOracleReplay.lean | 172 ++ .../whir/Whir/PCSBCSNativePacketBridge.lean | 316 ++++ .../whir/Whir/PCSBCSNativePacketCodec.lean | 168 ++ .../Whir/PCSBCSNativePacketCodecSmoke.lean | 112 ++ .../whir/Whir/PCSBCSNativePacketVisit.lean | 212 +++ .../whir/Whir/PCSBCSNativePhysicalFreeze.lean | 590 +++++++ .../Whir/PCSBCSNativePhysicalMerkleBad.lean | 431 +++++ .../whir/Whir/PCSBCSNativePublicCapture.lean | 622 +++++++ .../whir/Whir/PCSBCSNativeRootRoles.lean | 574 +++++++ .../whir/Whir/PCSBCSNativeSourceFailure.lean | 91 + .../whir/Whir/PCSBCSNativeSourceOriginal.lean | 151 ++ .../whir/Whir/PCSBCSNativeSourceTables.lean | 54 + .../PCSBCSObservedPrimitiveExtension.lean | 113 ++ .../whir/Whir/PCSBCSPublicCallerAnswers.lean | 92 + .../Whir/PCSBCSPublicCallerAnswersCost.lean | 56 + .../Whir/PCSBCSPublicCallerAnswersSmoke.lean | 60 + .../Whir/PCSBCSPublicCallerCompletion.lean | 327 ++++ .../whir/Whir/PCSBCSPublicExtractor.lean | 528 ++++++ .../Whir/PCSBCSPublicExtractorAnchor.lean | 175 ++ .../whir/Whir/PCSBCSPublicExtractorCost.lean | 1054 ++++++++++++ .../whir/Whir/PCSBCSPublicExtractorSmoke.lean | 99 ++ .../whir/Whir/PCSBCSPublicLogExtractor.lean | 34 +- .../Whir/PCSBCSPublicLogExtractorCost.lean | 1141 +++++++++++++ .../PCSBCSPublicLogExtractorCostSmoke.lean | 172 ++ .../Whir/PCSBCSPublicLogExtractorSmoke.lean | 53 +- .../whir/Whir/PCSBCSPublicLogParserCost.lean | 901 ++++++++++ .../Whir/PCSBCSPublicPrimitiveOpening.lean | 342 ++++ .../Whir/PCSBCSRecoveredSourceVolume.lean | 60 + .../whir/Whir/PCSBCSRestorationErasure.lean | 42 + .../whir/Whir/PCSBCSSourceCallerAnswers.lean | 210 +++ .../whir/Whir/PCSBCSSourceCallerOriginal.lean | 106 ++ .../Whir/PCSBCSSourceCallerOriginalCost.lean | 155 ++ .../Whir/PCSBCSSourceCallerOriginalSmoke.lean | 129 ++ .../whir/Whir/PCSBCSSourceCallerSnapshot.lean | 201 +++ .../whir/Whir/PCSBCSSourceFrozenAccessor.lean | 303 ++++ .../Whir/PCSBCSSourceFrozenAccessorSmoke.lean | 161 ++ .../PCSBCSSourceFrozenAccessorStructural.lean | 404 +++++ ...CSSourceFrozenAccessorStructuralSmoke.lean | 104 ++ .../whir/Whir/PCSBCSSourceFrozenReplies.lean | 151 ++ .../Whir/PCSBCSSourceFrozenRepliesSmoke.lean | 40 + .../PCSBCSSourceKnowledgeComposition.lean | 107 ++ .../whir/Whir/PCSBCSSourceKnowledgeGame.lean | 145 ++ .../Whir/PCSBCSSourcePrimitiveRootBudget.lean | 188 ++- .../whir/Whir/PCSBCSSourcePublicMetadata.lean | 125 ++ .../Whir/PCSBCSSourcePublicMetadataSmoke.lean | 83 + .../Whir/PCSBCSSourceReferenceParserCost.lean | 296 ++++ .../PCSBCSSourceReferencePolynomialBound.lean | 495 ++++++ .../PCSBCSSourceReferencePolynomialSmoke.lean | 48 + .../whir/Whir/PCSBCSSourceRootAdmission.lean | 587 +++++++ .../Whir/PCSBCSSourceSavedRecordDecoder.lean | 307 ++++ .../PCSBCSSourceSavedRecordDecoderCost.lean | 536 ++++++ ...SBCSSourceSavedRecordDecoderCostSmoke.lean | 122 ++ .../PCSBCSSourceSavedRecordDecoderSmoke.lean | 63 + .../PCSBCSSourceSavedRecordProvenance.lean | 319 ++++ .../PCSBCSWholeNativeCaptureTransport.lean | 924 ++++++++++ .../Whir/PCSBCSWholeNativePacketCoverage.lean | 556 +++++++ .../whir/Whir/PCSBCSWholeSourceObserver.lean | 420 +++++ verification/whir/Whir/PCSListExtraction.lean | 69 + .../Whir/PCSRewindExtractorGSFixtures.lean | 24 + .../whir/Whir/PCSRewindKnowledgeAnchor.lean | 140 ++ .../whir/Whir/PCSRewindKnowledgeBound.lean | 178 ++ .../whir/Whir/PCSRoundByRoundChronology.lean | 58 + .../Whir/PCSRoundByRoundKnowledgeAnchor.lean | 58 + .../Whir/PCSRoundByRoundSourceDecoder.lean | 65 +- ...SRoundByRoundSourceDecoderCorrectness.lean | 2 +- .../whir/Whir/PCSStateRestorationCost.lean | 61 + .../PCSStateRestorationLatentExample.lean | 113 ++ .../whir/Whir/PCSStateRestorationPath.lean | 103 ++ .../PublicCompressionCouplingLateLinks.lean | 78 + .../Whir/PublicCompressionCouplingLog.lean | 115 ++ .../whir/Whir/PublicCompressionProgram.lean | 22 + verification/whir/Whir/PublicMerkleLog.lean | 24 + .../whir/Whir/PublicMerkleProgram.lean | 68 +- .../whir/Whir/ReedSolomonExtraction.lean | 162 +- .../whir/Whir/ShoupTraceExtraction.lean | 117 ++ .../Whir/SpongefishCurrentAdapterSmoke.lean | 152 ++ .../Whir/SpongefishCurrentAnchorHeader.lean | 347 ++++ .../SpongefishCurrentCommitmentReceive.lean | 129 ++ .../Whir/SpongefishCurrentModeQueries.lean | 188 +++ .../SpongefishCurrentPhysicalRootCapture.lean | 541 ++++++ ...ongefishCurrentPrimitiveEventCompiler.lean | 620 +++++++ .../SpongefishCurrentRecordCodecSmoke.lean | 37 + .../Whir/SpongefishCurrentRecordDecoder.lean | 247 +++ .../SpongefishCurrentRecordModeCapture.lean | 130 ++ ...SpongefishCurrentRecordOpeningQueries.lean | 40 + .../whir/Whir/SpongefishOrdinarySession.lean | 141 ++ .../whir/Whir/SpongefishPCSRoundFrames.lean | 931 +++++++++++ .../whir/Whir/SpongefishPowAdapter.lean | 104 ++ .../Whir/SpongefishRecordBindingParser.lean | 197 +++ .../whir/Whir/SpongefishSessionAdapter.lean | 366 ++++ .../whir/Whir/TraceBasisExtraction.lean | 144 ++ verification/whir/Whir/TraceExtraction.lean | 138 ++ .../whir/Whir/TriangularExtraction.lean | 4 +- .../whir/Whir/WHIRPhysicalSoundness.lean | 2 +- verification/whir/lakefile.toml | 52 + 175 files changed, 42172 insertions(+), 204 deletions(-) create mode 100644 verification/whir/Whir/AnchoredByteStreamSampler.lean create mode 100644 verification/whir/Whir/AnchoredFiatShamirSecurityBudget.lean create mode 100644 verification/whir/Whir/AnchoredIdealPhysicalAcceptance.lean create mode 100644 verification/whir/Whir/AnchoredMixedAttackerPrefix.lean create mode 100644 verification/whir/Whir/AnchoredMixedAttackerPrefixObserver.lean create mode 100644 verification/whir/Whir/AnchoredMixedAttackerPrefixSource.lean create mode 100644 verification/whir/Whir/AnchoredMixedIdealSourceAcceptance.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalAfter.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalExecution.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalKnowledgeAcceptance.lean create mode 100644 verification/whir/Whir/AnchoredPhysicalPreparation.lean create mode 100644 verification/whir/Whir/AnchoredPrimitivePhysicalSnapshots.lean create mode 100644 verification/whir/Whir/AnchoredSourceGroups.lean create mode 100644 verification/whir/Whir/AnchoredSourcePacket.lean create mode 100644 verification/whir/Whir/AuthenticatedResetSmoke.lean create mode 100644 verification/whir/Whir/DeployedTranscript.lean create mode 100644 verification/whir/Whir/DeployedTranscriptCoupling.lean create mode 100644 verification/whir/Whir/DeployedTranscriptEntryAlias.lean create mode 100644 verification/whir/Whir/DeployedTranscriptGame.lean create mode 100644 verification/whir/Whir/DeployedTranscriptSource.lean create mode 100644 verification/whir/Whir/ErasureInterpolation.lean create mode 100644 verification/whir/Whir/FrobeniusExtraction.lean create mode 100644 verification/whir/Whir/InitialKnowledgeScheduleActual.lean create mode 100644 verification/whir/Whir/InterleavedListExtraction.lean create mode 100644 verification/whir/Whir/PCSBCSAdaptiveSourceCallerSnapshot.lean create mode 100644 verification/whir/Whir/PCSBCSAdaptiveSourceKnowledgeProbability.lean create mode 100644 verification/whir/Whir/PCSBCSAtomicAllocationTrace.lean create mode 100644 verification/whir/Whir/PCSBCSAtomicTrace.lean create mode 100644 verification/whir/Whir/PCSBCSCallerBusTablePolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerBusTablePolynomialBoundSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSCallerCPUPolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerCPUPolynomialBoundSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSCallerCompletionCausality.lean create mode 100644 verification/whir/Whir/PCSBCSCallerFlockPolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerFlockPolynomialBoundSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSCallerGKRPolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerParserCost.lean create mode 100644 verification/whir/Whir/PCSBCSCallerParserPolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerPayloadCost.lean create mode 100644 verification/whir/Whir/PCSBCSCallerPayloadCostSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSCallerPayloadPolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerSchedulePolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCallerSchedulePolynomialBoundSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSCallerSourcePolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedIdealNativeAcceptance.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedNativePhaseQuery.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedNativeReplyBridge.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedNativeReplyBridgeSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedSourceAcceptance.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedSourceExecutable.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedSourceExecutableSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedSourceProbability.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedSourceStatePath.lean create mode 100644 verification/whir/Whir/PCSBCSCapturedSourceTransport.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleChain.lean create mode 100644 verification/whir/Whir/PCSBCSChallengeOracleDomains.lean create mode 100644 verification/whir/Whir/PCSBCSConstructionReplayTrace.lean create mode 100644 verification/whir/Whir/PCSBCSCoordinateCodecCost.lean create mode 100644 verification/whir/Whir/PCSBCSExecutedCoordinateRecovery.lean create mode 100644 verification/whir/Whir/PCSBCSIdealConstructionAnswers.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleSeedProjection.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleSeedProjectionSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSMerkleTableAuthenticity.lean create mode 100644 verification/whir/Whir/PCSBCSMixedConstructionTrace.lean create mode 100644 verification/whir/Whir/PCSBCSMixedOrdinaryMerkle.lean create mode 100644 verification/whir/Whir/PCSBCSNativeCallerOriginal.lean create mode 100644 verification/whir/Whir/PCSBCSNativeCapturedLogs.lean create mode 100644 verification/whir/Whir/PCSBCSNativeCapturedOracles.lean create mode 100644 verification/whir/Whir/PCSBCSNativeCapturedReplyTransport.lean create mode 100644 verification/whir/Whir/PCSBCSNativeCapturedRows.lean create mode 100644 verification/whir/Whir/PCSBCSNativeCapturedTape.lean create mode 100644 verification/whir/Whir/PCSBCSNativeCompleteAlarm.lean create mode 100644 verification/whir/Whir/PCSBCSNativeIdealCallerOriginal.lean create mode 100644 verification/whir/Whir/PCSBCSNativeOracleReplay.lean create mode 100644 verification/whir/Whir/PCSBCSNativePacketBridge.lean create mode 100644 verification/whir/Whir/PCSBCSNativePacketCodec.lean create mode 100644 verification/whir/Whir/PCSBCSNativePacketCodecSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSNativePacketVisit.lean create mode 100644 verification/whir/Whir/PCSBCSNativePhysicalFreeze.lean create mode 100644 verification/whir/Whir/PCSBCSNativePhysicalMerkleBad.lean create mode 100644 verification/whir/Whir/PCSBCSNativePublicCapture.lean create mode 100644 verification/whir/Whir/PCSBCSNativeRootRoles.lean create mode 100644 verification/whir/Whir/PCSBCSNativeSourceFailure.lean create mode 100644 verification/whir/Whir/PCSBCSNativeSourceOriginal.lean create mode 100644 verification/whir/Whir/PCSBCSNativeSourceTables.lean create mode 100644 verification/whir/Whir/PCSBCSObservedPrimitiveExtension.lean create mode 100644 verification/whir/Whir/PCSBCSPublicCallerAnswers.lean create mode 100644 verification/whir/Whir/PCSBCSPublicCallerAnswersCost.lean create mode 100644 verification/whir/Whir/PCSBCSPublicCallerAnswersSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSPublicCallerCompletion.lean create mode 100644 verification/whir/Whir/PCSBCSPublicExtractor.lean create mode 100644 verification/whir/Whir/PCSBCSPublicExtractorAnchor.lean create mode 100644 verification/whir/Whir/PCSBCSPublicExtractorCost.lean create mode 100644 verification/whir/Whir/PCSBCSPublicExtractorSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSPublicLogExtractorCost.lean create mode 100644 verification/whir/Whir/PCSBCSPublicLogExtractorCostSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSPublicLogParserCost.lean create mode 100644 verification/whir/Whir/PCSBCSPublicPrimitiveOpening.lean create mode 100644 verification/whir/Whir/PCSBCSRecoveredSourceVolume.lean create mode 100644 verification/whir/Whir/PCSBCSRestorationErasure.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCallerAnswers.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCallerOriginal.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCallerOriginalCost.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCallerOriginalSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceCallerSnapshot.lean create mode 100644 verification/whir/Whir/PCSBCSSourceFrozenAccessor.lean create mode 100644 verification/whir/Whir/PCSBCSSourceFrozenAccessorSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceFrozenAccessorStructural.lean create mode 100644 verification/whir/Whir/PCSBCSSourceFrozenAccessorStructuralSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceFrozenReplies.lean create mode 100644 verification/whir/Whir/PCSBCSSourceFrozenRepliesSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceKnowledgeComposition.lean create mode 100644 verification/whir/Whir/PCSBCSSourceKnowledgeGame.lean create mode 100644 verification/whir/Whir/PCSBCSSourcePublicMetadata.lean create mode 100644 verification/whir/Whir/PCSBCSSourcePublicMetadataSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceReferenceParserCost.lean create mode 100644 verification/whir/Whir/PCSBCSSourceReferencePolynomialBound.lean create mode 100644 verification/whir/Whir/PCSBCSSourceReferencePolynomialSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceRootAdmission.lean create mode 100644 verification/whir/Whir/PCSBCSSourceSavedRecordDecoder.lean create mode 100644 verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCost.lean create mode 100644 verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCostSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceSavedRecordDecoderSmoke.lean create mode 100644 verification/whir/Whir/PCSBCSSourceSavedRecordProvenance.lean create mode 100644 verification/whir/Whir/PCSBCSWholeNativeCaptureTransport.lean create mode 100644 verification/whir/Whir/PCSBCSWholeNativePacketCoverage.lean create mode 100644 verification/whir/Whir/PCSBCSWholeSourceObserver.lean create mode 100644 verification/whir/Whir/PCSListExtraction.lean create mode 100644 verification/whir/Whir/PCSRewindExtractorGSFixtures.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeAnchor.lean create mode 100644 verification/whir/Whir/PCSRewindKnowledgeBound.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundChronology.lean create mode 100644 verification/whir/Whir/PCSRoundByRoundKnowledgeAnchor.lean create mode 100644 verification/whir/Whir/PCSStateRestorationCost.lean create mode 100644 verification/whir/Whir/PCSStateRestorationLatentExample.lean create mode 100644 verification/whir/Whir/PCSStateRestorationPath.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingLateLinks.lean create mode 100644 verification/whir/Whir/PublicCompressionCouplingLog.lean create mode 100644 verification/whir/Whir/ShoupTraceExtraction.lean create mode 100644 verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean create mode 100644 verification/whir/Whir/SpongefishCurrentAnchorHeader.lean create mode 100644 verification/whir/Whir/SpongefishCurrentCommitmentReceive.lean create mode 100644 verification/whir/Whir/SpongefishCurrentModeQueries.lean create mode 100644 verification/whir/Whir/SpongefishCurrentPhysicalRootCapture.lean create mode 100644 verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRecordCodecSmoke.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRecordDecoder.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRecordModeCapture.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRecordOpeningQueries.lean create mode 100644 verification/whir/Whir/SpongefishOrdinarySession.lean create mode 100644 verification/whir/Whir/SpongefishPCSRoundFrames.lean create mode 100644 verification/whir/Whir/SpongefishPowAdapter.lean create mode 100644 verification/whir/Whir/SpongefishRecordBindingParser.lean create mode 100644 verification/whir/Whir/SpongefishSessionAdapter.lean create mode 100644 verification/whir/Whir/TraceBasisExtraction.lean create mode 100644 verification/whir/Whir/TraceExtraction.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index 06fe04a15..3ac08e886 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -44,6 +44,8 @@ At the historical `10266a181437019400bc93d8dfbb373301ba8aa5` source pin, `stack_ The new duplex documentation's `Q^2/2^257` and protocol prose's `choose(Q,2)/2^256` are not the checked whole-view coupling coefficient `min(1,(2Q^2-Q)/2^256)`. Neither smaller expression follows from that theorem. They require a separate correctly instantiated argument; this discrepancy is a proof-claim boundary, not a demonstrated attack or a lower bound on the rewritten protocol. Individual field challenge encoding remains a bijection onto `2^192` elements, but the changed proof-of-work and zero-work schedule still needs a new grouped source-allocation proof. +An isolated release executable linked the actual upstream `fiat_shamir` and `primitives` crates at `d3c7f9d9a6ad4f7b88f917284076b34430502ae2`, using Rust 1.97 and a fresh storage-backed target. It passed the duplex known answer, session and public-instance binding, raw-root proof serialization, positive and zero-work replay, exact proof roundtrip, short-message poisoning, malformed hint framing and failed-work rejection. Encoding the same root through the historical two-field representation produced a different challenge. This is exercised native API evidence for the wire drift, not a Rows execution, universal source equivalence or a security proof. + ## Protocol to code to theorem map @@ -114,6 +116,38 @@ The proof constructs concrete initial-batching, fold-restoration, OOD/query-rest `DuplexRefinement` implements that pinned source's buffered stream, held final block, absorb/squeeze roles, full chaining value, vector sampling, cloning, nonce/grinding and limits. `DuplexEncoding`, `DuplexFraming` and `WHIRHistoryKey` prove framing inverses, message/template injection, canonical WHIR history encoding and structural mode conditions. `DuplexCompression` implements BLAKE2s compression. The separate actual source-stream coupling supplies the stochastic whole-view bound; structural framing alone is not used as its proof. +`SpongefishSessionAdapter` separately checks the new session-IV initialization, arbitrary-tag session derivation, canonical first instance absorption, raw 32-byte root transport and normalized immutable opening frame at #600's `75d4562b`. The commitment prefix is exactly `3E + raw32 = 104` bytes before the full extension-field anchor draws; its advertised value follows those draws, giving 128 transport bytes. Ordinary session derivation costs `2 + ceil(tagBytes/64)` primitive nodes and the new session initialization adds one, as a checked hand-port plan count, not a compiler execution-count theorem. A pinned actual Rust session/duplex/codec/prover/verifier and native BLAKE2s fixture matched 15 Lean output records, including boundary-length tags, commitment draws, opening bytes and the final 32-byte draw. The private PCS frame operation sequences were mirrored in that fixture, not invoked as extracted Rust helpers. `SpongefishPowAdapter` additionally proves that the deployed leading-zero test equals the exact 64-bit threshold test, including zero difficulty, and checks the raw32 challenge followed by the absorbed LE u64 nonce. A separate actual Rust prover/verifier and Lean BLAKE2s run matched 12 records: nine 64-byte trial inputs and digests from three challenge patterns and nonce values 0, 1 and `u64::MAX`, plus three sessions at difficulties 0, 1 and 5, with identical selected nonces, wire bytes and subsequent challenges. Rust also rejected false-work nonces and retained the poisoned error at EOF; these error observations are not a formal poisoned-state refinement. Nonce search, hints, complete poison/EOF behavior, the caller schedule and the deployed source observer/reduction remain separate obligations. The historical security endpoints are not silently retargeted by these byte adapters. + +`SpongefishPCSRoundFrames` adds the current absorb-only byte grammar, canonical E24/raw32/UInt64 codecs, successful read and guarded-squeeze cursor bridges, native/Rows metadata framing and all-round normalized replay. Its source inspection is pinned by twelve checked file hashes at `75d4562b`. Every nonempty PCS verifier group has at least 192 bits in the exact finite byte-codec law; positive PoW draws raw32 and has 256, while the nonce is prover-supplied and zero PoW has no event. Query positions use the fixed-count stratified projection of all three limbs of full E draws, with the query/lambda joint pushforward and prior-message prefix preserved, not an assumed uniform position or iid query law. Thus this PCS grouping does not collapse its minimum to the projected index domain. These are source-inspected successful-replay and finite pushforward results, not uniformity of fixed BLAKE2s or a whole-current native acceptance theorem. The dynamic session ID must still be selected from the observed, charged ordinary derivation path in the full registry/source compiler. Malformed and poisoned reads, hint parsing, EOF, Rows free-wire constraints, and the whole-system round minimum remain outside this adapter. + +`SpongefishOrdinarySession.derivation_plan_evaluates` proves the session derivation plan equal to the actual hand-ported byte evaluator for every compression function and tag. `deriveProgram_real` executes that entire plan as observed ordinary queries, and `afterDerive_real` passes the computed ID to the adaptive continuation, never a stipulated domain digest. Its exact ordinary observation count is `2 + ceil(tagBytes/64)`; the global mode loss uses this plus the complete continuation budget. This closes the free-domain-selection gap for that adaptive composition interface, not the remaining transport of the current native acceptance and public extraction observer into it. + +`SpongefishCurrentModeQueries.squeezed_byte` identifies every successful current draw byte with its actual absorb-only output coordinate, including retained byte offsets and the complete prior prover history. Its source squeeze guard derives the bounded mode address, and `all_round_frame_domain` preserves admissible frames through the normalized read/draw/hint replay from the initial session; no algebraic acceptance or hidden-CV premise supplies that geometry. This closes the deterministic current-byte to mode-coordinate interface. The current native event compiler, complete physical Merkle capture and original-statement observer still need their full transport into the historical probability chain. + +`SpongefishRecordBindingParser.verify_source` characterizes current opening-record acceptance by the exact literal opening prefix, including the raw 32-byte root and CV, normalized pending packs, point and value. Each scalar is read individually in the native order; `verify_reject` covers every stream without that prefix. `verify_transport` preserves the remaining transport, source read counts and actual event prefix. `verify_bridge` preserves the mode representation and derives the resulting frame geometry, and `verify_draw_byte` gives the actual bounded output coordinate for every subsequent draw byte. These are checked hand-port parser and cursor theorems, not a compiler correspondence, failed-read poison/error theorem or Rows constraint proof. + +A compiled real-BLAKE2s `spongefishCurrentAdapterSmoke` run executed the observed ordinary session derivation, accepted the canonical raw-root opening record with its exact byte/read cursor, rejected a foreign root and a truncated record, and matched every byte of a draw crossing the output-block boundary with the corresponding absorb-only mode coordinate. This exercises the current hand-port interfaces, not actual Rust verifier acceptance, malformed-read poisoning or a whole current Fiat-Shamir knowledge theorem. + +`SpongefishCurrentRecordDecoder` reconstructs an unknown saved record from literal current bytes at the fixed public shape. Its universal encoder inverse recovers the raw root and CV, every live pending byte, first flag, counters, point, value and remaining transport. The canonical source law rejects nonnormalized metadata and unused pending bytes rather than discarding them. An executed codec regression covered every pending length from zero through the full buffer, both first flags, exact suffix preservation, truncation and malformed high fields or byte padding. These are public-byte recovery results; they do not yet supply the current whole-native first-root capture, original-caller or acceptance adapter. + +The current decoder also recognizes saved records at the end of a public absorb-frame body with arbitrary preceding bytes. `suffixCandidates_recovery` proves that the actual canonical record is included, `suffixCandidates_source` proves that every result reencodes to an actual suffix, and `suffixCandidates_length` bounds the result by four. This recognizer returns the bounded candidate list; it does not assume suffix uniqueness or silently select an unproved first match. The executable codec regression exercises recovery across the full pending-buffer range with a nonempty prefix. + +`SpongefishCurrentRecordModeCapture` connects that candidate recognizer to the actual successful individual-read cursor. `verify_run` derives the pending byte suffix from the record check, and `verified_record_coordinate` recovers the record from the resulting closed absorb history. `verified_raw_record` also reconstructs the literal bounded raw mode key before inspecting record bytes; `rawRecords_sound` checks its full IV and template, and `rawRecords_length` bounds the references by four. The explicit shape, pending-buffer, point-width, frame-domain and construction-work hypotheses are source geometry, not an assumed witness or extractor success. The complete current native observer and physical Merkle first-capture transport are still open. + +`SpongefishCurrentRecordOpeningQueries.verified_squeezed_byte` joins the actual successful record read to the subsequent byte returned at the recovered whole raw mode key. `SpongefishCurrentAnchorHeader` handles the earlier commitment-receive header separately: three scalar constants followed by the raw 32-byte root, before the anchor vector is sampled or its value is read. Its fixed 104-byte suffix identifies a unique root at the public shape, and `readHeader_anchor_byte` ties every actual point byte to that root-bearing mode key. These are source-order hand-port interfaces, not a current whole-native first-root or compiler correspondence. + +`SpongefishCurrentCommitmentReceive.receive_anchor_source` then composes that header with the actual full-vector squeeze, canonical point decoding and subsequent prover-value read. Every successful returned record retains the sampled point and the actual preheader context; its root-bearing coordinate is identified before the point reply, without a stipulated saved record, root, point or value. Prior mode representation, frame geometry and aggregate construction-work bounds remain explicit. This closes the deterministic commitment-receive operation in the hand-port, not native rejection/poison behavior or the remaining current physical Merkle and whole-observer composition. + +`SpongefishCurrentPhysicalRootCapture` recognizes only literal current bounded output keys with the checked raw-header suffix, computes the earliest mentioning event and freezes the strict preceding ordinary log. An earlier adversarial mention is reused; its reply and every later continuation are excluded from replacement of the captured table. Actual mixed source execution supplies both that prefix and its authentic ordinary records. The derived physical shape is height `logN-logBatch+logRate`, full image width `2^logBatch` and occupied width `lanes`. `opened_getter_or_bad` connects the actual successful fixed-height Merkle opening computation to full zero-prefixed image hashing and compact occupied rows, or the existing primitive collision/fresh-target event. The current native opening compiler and original-statement observer still require their complete composition. + +`SpongefishCurrentPrimitiveEventCompiler` separately compiles current byte reads, guarded draws and decoded hints into actual observed primitive queries. Its real execution agrees with the entire reached cursor and the hand-port replay's success or rejection, including work before a later failure. Zero draws and cursor-exhausted draws issue no finalization query; insufficient typed transport is rejected before absorption. `replayProgram_trace` identifies every literal compression node and answer in source order, while `replayProgram_exact_count` and the linear byte-work budget charge every occurrence. This compiler does not invoke a hidden compression function or assume mode representation or acceptance. It is not yet a mode-replacement, whole-native branching, raw hint/poison, Rows or Aeneas correspondence. + +`AnchoredMixedAttackerPrefix` preserves the unchanged mixed source lowering and its entire public view while freezing the literal strict-prefix Merkle table before the first anchor reply. Repeated grouped queries reuse the first prepared root and point. The exact ambiguity bound is `n/2^124` for the aggregate mixed draw cap, or `remaining/2^124` under the source `Counts` work bound; allocations, lookup requests and full construction-path work are not equated. The wrapper uses the historical pre-#607 header grammar. + +`AnchoredMixedAttackerPrefixSource.initial_source_prefixes` derives the cache and first-root invariants at every actual source prefix. Cache-hit observations can be omitted from the draw log without preserving its literal order; outside ordinary output collisions, their membership set suffices to preserve digest-selected preimages. `AnchoredMixedAttackerPrefixObserver.source_prefixes_of_alarm` derives precisely that guard from the SAME complete physical Merkle alarm already paid by the source observer. No second collision loss, clean-cache assumption, externally supplied frozen-root equality or extra lowering is introduced. + +`PCSBCSPublicExtractorAnchor` proves that appending arbitrary public continuations cannot replace an already captured first-root prefix. Under the explicit clean immutable anchor condition, successful extractions from that prefix return the same word, even when later original claim sets change. `extractAt_equals_selected` identifies the actual returned word with every retained candidate satisfying that anchor. This deterministic public-extractor result does not silently turn the historical source endpoint into a current deployed Fiat-Shamir knowledge theorem. + `DuplexModeGame` defines finite real public-compression and ideal raw-random-oracle/simulator games for adaptive direct and construction queries, including auxiliary and verifier work. `PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss` proves the unrestricted whole-view inequality for the actual `DuplexPublicSimulator.simulator Q` under one aggregate `Counts Q` cap. `DuplexPublicSimulator.modeSecurity` supplies its proved `PublicCompressionModeBound`; native endpoints no longer ask for an external fixed-simulator security certificate. The corrected loss is `min(1,(2*choose(Q,2)+Q^2)/2^256) = min(1,(2Q^2-Q)/2^256)`. The earlier birthday-only coefficient was insufficient for the whole-view coupling and has been corrected. Sharp birthday subevent estimates remain separate from the full loss. Actual residual-table disintegration and adaptive stream alignment prove the coupling, including repeated queries, late recognition, final cache completion and unrestricted observers. `ConcretePrimitiveGap` is retained as a precisely named **full-public-view replacement premise**, not a standard computational hash-security assumption. `knownAnswerAdversary` makes one direct primitive query, and `knownAnswerDistinguisher` compares its answer with a local evaluation of public BLAKE2s. `knownAnswer_concreteProbability` is exactly `1`; `knownAnswer_realProbability` is exactly `2^-256`. The kernel-checked `concretePrimitiveGap_knownAnswer_lower_bound` therefore proves `primitiveLoss >= 1 - 2^-256` whenever `Q >= 1` and `Allowed` includes this pair. Ordinary efficient classes include this elementary observer. Efficiency, collision resistance or a stronger implementation audit cannot justify a small full-view loss. This counterexample applies to the public primitive experiment used for proposed #552 and does not refute the separate random-compression DMV claim. @@ -189,7 +223,28 @@ Merkle-query-log reconstruction builds one preimage index, authenticates the ful The integrated completed closure passed `lake build --wfail +Whir:olean +Main:olean`, and strict-warning `Audit.lean` checked **11010 exported Whir theorem declarations** with only the three permitted standard axioms. Six maintained compiled executables passed: the multilevel accepted/rejected model, nontrivial full-root Gao extraction with a corrupted row, PCS grouped round and byte-cache behavior, padded real-BLAKE2s Merkle-log transport and rejection, actual public coordinate recovery, and anchored public-log before-answer root capture, including a later point block queried first. The inconsistent-output log fixture exercises collision handling without claiming a BLAKE2s collision. The root imports completed literal restoration fibers, whole-current-independent root capture and source reply inversion, not a completed Fiat-Shamir knowledge endpoint. -The executable public-log extractor selects the first recognized four-field Root0 address and uses only the ordinary compression records preceding that node's answer, then invokes the same original-statement Gao helper. Its output theorem checks one returned word against all 64 family slices, ordinary and strided points and the saved anchor. The scanner derives a conservative physical-query target cap `M = Q * (Q + 1)`, including adaptive anchor-source references. Its separate ideal-compression Merkle extraction term is exactly `(Q^3 + 3*Q^2 - 2*Q) / 2^256`; duplex coupling remains `min(1, (2*Q^2 - Q) / 2^256)`. These terms are not the unfinished Fiat-Shamir extraction-failure bound: identification of the actual source metadata and accepted state path, total extractor runtime, anchor composition and whole-system entropy remain separate obligations. No `Q^2 / 2^192` hash-chain term is transplanted from the book, because the actual duplex source keys omit prior verifier replies. +The executable public-log extractor selects the first recognized four-field Root0 address and uses only the ordinary compression records preceding that node's answer, then invokes the same original-statement Gao helper. Its output theorem checks one returned word against all 64 family slices, ordinary and strided points and the saved anchor. The scanner derives a conservative physical-query target cap `M = Q * (Q + 1)`, including adaptive anchor-source references. The source composition now charges the actual complete primitive-trace alarm, covering global output collisions as well as frozen-opening failures, with exactly `(Q^3 + 3*Q^2 - 2*Q) / 2^256`; duplex coupling remains `min(1, (2*Q^2 - Q) / 2^256)`. Excluding only an extracted-row mismatch does not establish that every primitive opening event is quiet, and no such converse is used. These terms are not the unfinished Fiat-Shamir extraction-failure bound: identification of the whole adversarial-prefix source metadata and accepted state path, total extractor runtime, anchor composition and whole-system entropy remain separate obligations. No `Q^2 / 2^192` hash-chain term is transplanted from the book, because the actual duplex source keys omit prior verifier replies. + +`PCSBCSAtomicTrace.memo_recorded` proves literal dependent key/value membership in the actual memo interpreter's allocation trace on every operational branch, including cached replay and early abort. Starting from the empty cache, `cached_answer_allocated` recovers the complete packet answer, not just exposed scalar bytes. An isolated executable passed with two real BLAKE2s digests: disclosing the first block and later replaying the same packet's previously hidden second block preserved the full answer and its single recorded allocation. This is trace provenance, not yet the native acceptance, root-capture and Fiat-Shamir failure refinement. + +`AnchoredMixedIdealSourceAcceptance` now derives erased source execution, request preparation and same-tape protocol/experiment acceptance from the actual historical mixed compiler's successful native-source result. It does not require independently sampled construction replies to equal deterministic compression outputs. Ordinary Merkle consistency comes from the checked simulator seed projection; `AnchoredPrimitivePhysicalSnapshots` likewise preserves the actual tracked registry under primitive-only consistency. A real BLAKE2s smoke retained the same first-root snapshot across a construction reply deliberately different from deterministic evaluation and a repeated primitive request. The physical snapshot invariant, retained registration, causal preparedness and executed Merkle bad-event exclusions remain explicit; their identification with PCS first-root capture is not yet the finished Fiat-Shamir knowledge theorem. + +`PCSBCSNativeIdealCallerOriginal.fresh_original` now constructs the original stacked statement from the actual successful historical ideal native continuation and its literal raw-table caller observations. It derives the saved root, ring seed and every caller answer rather than asking for an accepted original-statement certificate or identifying the native packet bound with the source budget. `PCSBCSObservedPrimitiveExtension.ideal_snapshot` derives the complete tracked physical invariant even for nonordinary primitive queries: its executable table preserves all observed primitive answers and uses the actual fallback seed only on unobserved inputs. A real BLAKE2s executable exercised a complete nonordinary private-node query whose answer differs from deterministic compression, one raw lookup followed by cached replay, genuine seed evaluation on an unobserved input and an unchanged first-root prefix. The physical log deduplicates repeated inputs; the observed simulator log retains them, so only answer provenance, not literal list equality, was checked. This observed extension is not uniform and is not itself a Merkle security argument. Identification with the earlier source allocation's captured oracle, queried-row transport and the final source failure refinement remain separate obligations. + +`PCSBCSNativePacketVisit.mixed_success_recorded` now removes the presumed complete-allocation cache: actual successful historical mixed native verification derives an observed first-block query for every scheduled packet, its exact source-cap admission and the complete dependent answer in the literal grouped compiler trace. The cap is derived from that execution, not assumed to dominate the earlier native admission parameter. `PCSBCSAtomicAllocationTrace.execute_program` preserves chronological raw-query provenance through the actual atomic compiler, and `PCSBCSMixedConstructionTrace.ideal_packet_recorded` preserves it across primitive simulator interleavings. An isolated actual atomic-compiler executable passed with genuine two-block BLAKE2s answers, retaining the hidden suffix after partial disclosure. `PCSBCSCapturedIdealNativeAcceptance.mixed_success_captured_rows` separately derives actual first-mention capture and accepted native queried-row equality or the existing captured-prefix Merkle bad event. Its selected shape-address membership, phase codec crosswalk and nonterminal next-root transport remain explicit; neither whole earlier/later oracle equality nor the finished Fiat-Shamir failure refinement is claimed. + +`PCSBCSCapturedSourceTransport.address` now parses literal caller-entry bytes and pending-role bytes only. The clean cutover removes its old caller layout, saved-record and hidden-answer parameters and their address-erasure lemmas. `PCSBCSNativePublicCapture.sourceRoot_same_view` proves identical captured source rows for arbitrary whole-program typed tables with the same actual public view outside the stated capture-log collision; it needs no hidden-answer or address-equality premise. Genuine original-claim decoding still requires observation coverage for the caller's actual prior outputs. An executed byte-parser smoke covered all 56 supported profiles, exact partially occupied initial shapes and truncated saved-frame rejection without any caller-answer getter. + +The historical whole native source joins now preserve the arbitrary attacker prefix: `PCSBCSNativePhysicalFreeze` derives the actual first-root physical boundary and complete ordinary-log saturation, and `PCSBCSSourceRootAdmission` derives scanner admission from the real first mention and the same complete-trace alarm. `PCSBCSWholeNativePacketCoverage` derives every full-width packet, caller-output preparation and root first mention from actual whole-program success. `PCSBCSWholeNativeCaptureTransport` then derives the literal original statement, canonical replay, same-tape causal experiment and every reply transport; its real endpoint assumes only the counted source execution, supported original family cap, successful actual verifier and exclusion of that same complete-trace alarm, rather than supplied capture, row or hidden-caller certificates. `PCSBCSPublicPrimitiveOpening` checks finite-plan oracle locality and reconstructs accepted-opening primitive bad events from public observations for arbitrary mixed tables. `PCSBCSWholeSourceObserver` completes the public failure reduction without an observer-refinement or hidden-oracle-locality premise. `PCSBCSPublicExtractor` implements that observer's actual extractor using computational raw-key recognition, strict first-mention capture, observed caller decoding, padded Merkle row recovery and the original-claim Gao/base-word decoder, with no strategy, verifier tape or candidate enumeration. + +Its checked `random_compression_failure_probability` bounds acceptance with no output by `B*((17/32)^56+1/2^78) + min(1,(2B^2-B)/2^256) + (B^3+3B^2-2B)/2^256`. Here `B` bounds the complete attacker-plus-verifier ordinary calls and construction paths, including rejected executions, not just verifier query count. The endpoint is PCS-only in the historical ideal-compression experiment. Its structural class fixes the public profile, caller layout and entry boundary across all source results, not only favorable accepted traces; it also requires the native mode IV and supported original-family cap. Every returned word explains the literal original statement. The complete public-view extractor now compiles, but its production-profile executable run did not complete within the bounded smoke invocation. Adapting the whole historical source model to #607 remains an integration obligation. These checked historical results do not establish current deployed Fiat-Shamir knowledge or deterministic BLAKE2s security. + +`PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. + +The final warning-denied library and compiled-model closure passed, and `Audit.lean` checked **14607 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. The compiled current real-BLAKE2s adapter exercised observed session derivation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The current record codec exercised all 65 pending-buffer lengths with both first flags. Eight maintained model, reset/counting, source-stream, PCS grouping and real-BLAKE2s Merkle/public-log scenarios passed. + +The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. + ## Deployed leaf/node boundary and required invariant @@ -208,7 +263,7 @@ Fresh execution at this upstream pin passed an actual native BLAKE2s/opening exe The original opening statement must be fixed before its batching challenge packet: every point, slice value, offset, selector and shape must come from already observed messages, the seeded public layout or strictly earlier verifier challenges. In the source-fiber formulation, changing only the current packet's random-table entry must leave that complete caller statement and its incoming public state unchanged. A commitment-record identity frame binds the record, not an otherwise unbound caller statement. The generic stack API and `leanvm_core::pcs` forwarding wrappers therefore retain this precondition; the anchor does not replace it. -This caller audit is pinned to PR #600's held source `12eea88c41dd964d82d4eb15ce91bba17ef91339`. The native CPU leaf and constrained leaf Rows use the same reduction and opening sequence at [`cpu/reduce.rs:68-103`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/cpu/reduce.rs#L68-L103) and [`rec/verifier/riscv.rs:63-79`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/rec/verifier/riscv.rs#L63-L79). Bus evaluations are sent/read at `leaf/decompose.rs:522` and `leaf/mod.rs:469-471`; table evaluations and bit slices at `constraints/mod.rs:217-244`; Flock slices and matrix values at `flock/lincheck.rs:374-375,445-446`. Public output and program layout enter the seed at `cpu/program.rs:230,375,404-405,433-452`. Addresses are deterministic layout selections. Coordinates are earlier GKR, sumcheck, zerocheck or lincheck outputs, not point vectors reserialized immediately before the opening. +This caller audit is pinned to PR #600's historical source `12eea88c41dd964d82d4eb15ce91bba17ef91339`. The native CPU leaf and constrained leaf Rows use the same reduction and opening sequence at [`cpu/reduce.rs:68-103`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/cpu/reduce.rs#L68-L103) and [`rec/verifier/riscv.rs:63-79`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/rec/verifier/riscv.rs#L63-L79). Bus evaluations are sent/read at `leaf/decompose.rs:522` and `leaf/mod.rs:469-471`; table evaluations and bit slices at `constraints/mod.rs:217-244`; Flock slices and matrix values at `flock/lincheck.rs:374-375,445-446`. Public output and program layout enter the seed at `cpu/program.rs:230,375,404-405,433-452`. Addresses are deterministic layout selections. Coordinates are earlier GKR, sumcheck, zerocheck or lincheck outputs, not point vectors reserialized immediately before the opening. Tree and aggregation proving open at [`rec/proof.rs:293-308`](https://github.com/leanEthereum/leanVM/blob/12eea88c41dd964d82d4eb15ce91bba17ef91339/crates/leanvm_core/src/rec/proof.rs#L293-L308); native and Rows consume the shared core at `rec/proof.rs:217-245,329-363` and `rec/verifier/recursion.rs:105-125`. Every child statement limb is seeded by `rec/proof.rs:33-36` or the matching Rows seed. All 104 recursive slots are terminal table evaluations observed before opening; the single hash-witness ring uses the observed Flock slices. Fixed and program hint values outside the child transcript enter the separate reduction's bound list at `tree/design.rs:245,295,306` and are sent/read before its batching challenges at `tree/reduce/mod.rs:63-78`. Deferred claims must still be settled: native CPU at `cpu/deferred.rs:207-239`, final tree at `tree/mod.rs:620-648`, and constrained embeddings through the enclosing satisfied circuit. Host success from a partial core or Rows construction is not full verification. @@ -264,4 +319,8 @@ Compiled source-extractor checks exercise nontrivial K coefficients, all origina `PCSRoundByRoundSource.run` separately decodes the full Root0 message by direct indexed Gao/base-word processing, checks the actual common support and all original claims, and receives no strategy or verifier coins. Its output, SAME-word heavy-support recovery and counted degree-seven cost are kernel checked. The compiled generic-helper smoke exercises corrupted roots and malformed original statements. This decoder contract alone is not a completed RBR or Fiat-Shamir theorem. -The authorized production anchor cutover is developed in [PR #600](https://github.com/leanEthereum/leanVM/pull/600) on a separate upstream-based branch, not silently substituted for this proof-only draft's historical source pin. Its normal integration of #599 is separate from the proof checkout and the Aeneas extraction work. Source refactors and finite smoke checks do not establish Rust-to-Lean equivalence. The historical malformed-selector observation, the new source-correspondence obligations and the unproved full concrete compression replacement remain explicit limitations. +The counted Gao interpolant skips basis construction and inversion whenever a received coefficient is zero, for arbitrary mixed inputs rather than a special all-zero decoder. `ReedSolomonExtraction.countedInterpolationTerm_value` and `countedInterpolant_value` prove the same mathematical interpolant; support and decoder-cost proofs retain their source connection. The resource count includes each coefficient test, and the closed interpolation budget includes the corresponding linear term. A real-field row smoke with mixed zero and nonzero evaluations recovered the linear base word `[0,1]` through the actual counted row decoder. + +The actual Root0 decoder now shares the public domain's nodal polynomial across occupied lanes. `PCSActualSourceRootDecoder.decodeRoot_value` preserves the previous row-decoder output for every input, and `decodeRoot_cost` charges its construction once while retaining the existing polynomial bound. Canonical counted multiplication uses the shorter operand on the left of its asymmetric convolution; its mathematical product and counted bounds are proved unchanged. Both changes are general, not input-specific fallback algorithms. + +The authorized production anchor cutover is developed in [PR #600](https://github.com/leanEthereum/leanVM/pull/600) on a separate upstream-based branch, not silently substituted for this proof-only draft's historical source pin. Its published normal upstream merge is `75d4562bde1efe296b4e32d2a195fdfc232b3ead`, incorporating the #607 transcript and #608 claim-width guards from `d3c7f9d9a6ad4f7b88f917284076b34430502ae2`. Native and Rows opening frames now bind raw 32-byte roots, the original chaining value and normalized byte-buffer context under the session-IV and new codec API; the wire versions are LVMP17, LVMT15, rv64im15 and tree12. Its separate public CPU and first/node tree prove/serialize/decode/verify smoke passed, including legacy, foreign-statement, changed-output and truncation rejection. These observations do not establish universal Rust-to-Lean equivalence or discharge the historical duplex model's new session-IV, raw-root and changed PoW/final-digest correspondence obligations. The historical malformed-selector observation, current source-correspondence obligations and unproved full concrete compression replacement remain explicit limitations. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index 7ab17e4aa..c7e36ff6b 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -177,3 +177,69 @@ import Whir.PCSBCSPublicLogExtractor import Whir.PCSBCSActualMerkleBound import Whir.PCSBCSSourceRootCapture import Whir.PCSBCSSourceReplyInversionIncoming +import Whir.PCSBCSCallerSourcePolynomialBound +import Whir.PCSBCSCallerSchedulePolynomialBound +import Whir.PCSBCSPublicLogExtractorCost +import Whir.PCSBCSSourceFrozenAccessorStructural +import Whir.PCSBCSCapturedSourceExecutable +import Whir.PCSBCSSourceKnowledgeComposition +import Whir.PCSBCSMerkleTableAuthenticity +import Whir.PCSBCSPublicCallerAnswersCost +import Whir.PCSBCSSourceSavedRecordDecoderCost +import Whir.PCSBCSConstructionReplayTrace +import Whir.PCSBCSPublicCallerCompletion +import Whir.PCSBCSSourcePublicMetadata +import Whir.PCSBCSCallerCompletionCausality +import Whir.PCSBCSExecutedCoordinateRecovery +import Whir.AnchoredPhysicalExecution +import Whir.AnchoredPhysicalKnowledgeAcceptance +import Whir.AnchoredPhysicalPreparation +import Whir.PCSBCSNativeCallerOriginal +import Whir.PCSBCSNativePacketCodec +import Whir.PCSBCSAtomicTrace +import Whir.AnchoredMixedIdealSourceAcceptance +import Whir.AnchoredPrimitivePhysicalSnapshots +import Whir.PCSBCSNativeIdealCallerOriginal +import Whir.PCSBCSObservedPrimitiveExtension +import Whir.PCSBCSCapturedIdealNativeAcceptance +import Whir.PCSBCSNativePacketVisit +import Whir.SpongefishSessionAdapter +import Whir.PCSBCSNativeRootRoles +import Whir.PCSBCSCapturedNativePhaseQuery +import Whir.PCSBCSNativeOracleReplay +import Whir.PCSBCSNativeCapturedRows +import Whir.PCSBCSNativeCapturedOracles +import Whir.PCSBCSNativeSourceOriginal +import Whir.PCSBCSNativeCapturedTape +import Whir.PCSBCSNativeCapturedReplyTransport +import Whir.PCSBCSNativeCapturedLogs +import Whir.PCSBCSNativeSourceTables +import Whir.PCSBCSNativeSourceFailure +import Whir.PCSBCSNativePublicCapture +import Whir.PCSBCSNativePhysicalMerkleBad +import Whir.AnchoredPhysicalAfter +import Whir.PCSBCSNativePhysicalFreeze +import Whir.PCSBCSSourceRootAdmission +import Whir.PCSBCSNativeCompleteAlarm +import Whir.PCSBCSWholeNativePacketCoverage +import Whir.PCSBCSWholeNativeCaptureTransport +import Whir.PCSBCSPublicPrimitiveOpening +import Whir.SpongefishPowAdapter +import Whir.PCSBCSWholeSourceObserver +import Whir.PCSBCSPublicExtractor +import Whir.SpongefishPCSRoundFrames +import Whir.PCSBCSPublicExtractorCost +import Whir.SpongefishOrdinarySession +import Whir.SpongefishCurrentModeQueries +import Whir.SpongefishRecordBindingParser +import Whir.SpongefishCurrentRecordDecoder +import Whir.SpongefishCurrentRecordModeCapture +import Whir.SpongefishCurrentRecordOpeningQueries +import Whir.SpongefishCurrentAnchorHeader +import Whir.PCSBCSPublicExtractorAnchor +import Whir.AnchoredMixedAttackerPrefix +import Whir.AnchoredMixedAttackerPrefixSource +import Whir.AnchoredMixedAttackerPrefixObserver +import Whir.SpongefishCurrentCommitmentReceive +import Whir.SpongefishCurrentPhysicalRootCapture +import Whir.SpongefishCurrentPrimitiveEventCompiler diff --git a/verification/whir/Whir/AnchoredByteStreamSampler.lean b/verification/whir/Whir/AnchoredByteStreamSampler.lean new file mode 100644 index 000000000..fa9cf0400 --- /dev/null +++ b/verification/whir/Whir/AnchoredByteStreamSampler.lean @@ -0,0 +1,98 @@ +import Whir.AnchoredFiatShamirSecurityCodec + +/-! Bridge from the hand-ported deployed squeeze loop to the finite byte-vector +codec. Mandatory nonempty commitment absorption resets the cursor; there is no +injectable cached-output assumption. -/ +namespace Whir.AnchoredByteStreamSampler +open Concrete FiatShamirGame DuplexRefinement AnchoredFiatShamirSecurityCodec +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 + +@[simp] theorem stream_length (c : Compression) (cv : Digest32) (offset n : Nat) : + (stream c cv offset n).length = n := by + induction n generalizing offset with + | zero => rfl + | succ n ih => simp [stream, ih] + +theorem stream_getElem (c : Compression) (cv : Digest32) (offset n j : Nat) + (bound : j < n) : + (stream c cv offset n)[j]'(by simpa using bound) = + outputBlock c cv ((offset+j)/32) ⟨(offset+j)%32, Nat.mod_lt _ (by decide)⟩ := by + induction n generalizing offset j with + | zero => omega + | succ n ih => + cases j with + | zero => simp [stream] + | succ j => + simp only [stream, List.getElem_cons_succ] + simpa only [Nat.add_assoc, Nat.add_comm 1 j] using ih (offset+1) j (by omega) + +theorem squeezeLoop_getElem (c : Compression) (s : State) (n j : Nat) + (cache : CacheValid c s) (bound : j < n) : + (squeezeLoop c n s).2[j]'(by simpa using bound) = + outputBlock c s.cv ((s.consumed+j)/32) + ⟨(s.consumed+j)%32, Nat.mod_lt _ (by decide)⟩ := by + have h := congrArg (fun bs : List Byte => bs[j]?) (squeezeLoop_stream c s n cache) + have left : j < (squeezeLoop c n s).2.length := by simpa using bound + have right : j < (stream c s.cv s.consumed n).length := by simpa using bound + rw [List.getElem?_eq_getElem left, List.getElem?_eq_getElem right] at h + exact (Option.some.inj h).trans (stream_getElem c s.cv s.consumed n j bound) + +def actualBlocks (c : Compression) (s : State) (dimension : Nat) : Blocks dimension := + fun i => outputBlock c (finish c s).cv i.val + +/-- Direct equality to the actual deployed 24-byte decoder, including every +block straddling and the exact final cursor. The initial cache is irrelevant +because the mandatory absorb has reset that cursor to zero. -/ +theorem sampleVec_actual (c : Compression) (s : State) (dimension : Nat) + (cursor : s.consumed = 0) (positive : 0 < dimension) + (limit : 24*dimension ≤ maxCursor) : + sampleVec c s dimension = + .ok ((squeezeLoop c (24*dimension) (finish c s)).1, + List.ofFn (point dimension (actualBlocks c s dimension))) := by + have cache : CacheValid c (finish c s) := by + intro nonzero + simp [cursor] at nonzero + have squeezed : squeeze c s (24*dimension) = + .ok (squeezeLoop c (24*dimension) (finish c s)) := by + simp [squeeze, cursor, limit, Nat.ne_of_gt (by omega : 0 < 24*dimension)] + unfold sampleVec + split + next e he => rw [he] at squeezed; cases squeezed + next t bs hs => + have eq := Except.ok.inj (hs.symm.trans squeezed) + have ht := congrArg Prod.fst eq + have hb := congrArg Prod.snd eq + dsimp only at ht hb + subst t + subst bs + apply congrArg Except.ok + apply Prod.ext + · rfl + · apply congrArg List.ofFn + funext j + rw [point_bytes] + apply congrArg ByteCodec.decodeE + funext i + have h := squeezeLoop_getElem c (finish c s) (24*dimension) (24*j.val+i.val) + cache (by have := j.isLt; have := i.isLt; omega) + simpa only [finish_consumed, cursor, Nat.zero_add, actualBlocks] using h + +theorem mandatory_absorb_cursor (c : Compression) (s : State) (header : List Byte) + (nonempty : header ≠ []) : (absorb c s header).consumed = 0 := + absorb_nonempty_cursor c s header nonempty + +theorem sampleVec_cursor (c : Compression) (s : State) (dimension : Nat) + (cursor : s.consumed = 0) : + (squeezeLoop c (24*dimension) (finish c s)).1.consumed = 24*dimension := by + simp [cursor] + +theorem anchor_dimension_limit (dimension : Nat) (small : dimension ≤ 28) : + 24*dimension ≤ maxCursor := by + norm_num [maxCursor] + omega + +end Whir.AnchoredByteStreamSampler + +#print axioms Whir.AnchoredByteStreamSampler.sampleVec_actual +#print axioms Whir.AnchoredByteStreamSampler.mandatory_absorb_cursor diff --git a/verification/whir/Whir/AnchoredFiatShamirSecurityBudget.lean b/verification/whir/Whir/AnchoredFiatShamirSecurityBudget.lean new file mode 100644 index 000000000..c00ac39b8 --- /dev/null +++ b/verification/whir/Whir/AnchoredFiatShamirSecurityBudget.lean @@ -0,0 +1,152 @@ +import Whir.AnchoredFiatShamirSecurityROM +import Whir.AnchoredByteStreamPrepared + +/-! Security ledger for the proved byte-stream ROM anchor plus independent +causal opening experiment. No unconditional native BLAKE2s bound is asserted; +the deployed verifier body and the primitive-to-ROM gap are separate obligations. -/ +namespace Whir.AnchoredFiatShamirSecurityBudget +open Concrete Protocol CausalGame ParameterBounds CommitmentAnchor +open AnchoredFiatShamirSecurity AnchoredFiatShamirSecurityROM FiatShamirGame +open RawOracleCoupling.Concrete TypedOracleCompiler +open DuplexFraming DuplexModeGame +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +/-- Actual derived composition: adaptive immutable-anchor ambiguity plus the +anchor-inclusive causal opening term, not a prospective native allocation cap. -/ +def romLedger (attempts : Nat) : ℚ := (attempts : ℚ)/2^124 + (1 : ℚ)/2^73 + +theorem byte_stream_security_ledger {p : Profile} {Key : Type} + [Fintype Key] [DecidableEq Key] (policy : Policy p Key) (n : Nat) + (select : TableSelector policy n) (advertised : BlockOracle p Key → E) + (opening : BlockOracle p Key → Array Claim) (strategy : BlockOracle p Key → Strategy) + (opening_cap : ∀ table, (opening table).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + (TableFailure policy n select advertised opening strategy)) ≤ romLedger n := + block_table_unique_opening_probability policy n select advertised opening strategy opening_cap + +/-- Resource charges use ceil(24*logN/32) distinct output blocks per attempt. +The numerical statement is attached to the actual proved experiment. -/ +theorem byte_stream_security_numeric {p : Profile} {Key : Type} + [Fintype Key] [DecidableEq Key] (policy : Policy p Key) (n Q : Nat) + (blockBudget : n * AnchoredFiatShamirSecurityCodec.blockCount (config p).logN ≤ Q) + (compression : Q ≤ 2^60) + (select : TableSelector policy n) (advertised : BlockOracle p Key → E) + (opening : BlockOracle p Key → Array Claim) (strategy : BlockOracle p Key → Strategy) + (opening_cap : ∀ table, (opening table).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + (TableFailure policy n select advertised opening strategy)) ≤ (1 : ℚ)/2^63 := by + exact (block_table_unique_opening_numeric policy n Q blockBudget compression select advertised + opening strategy opening_cap).trans (by norm_num) + +abbrev RawSelector {p : Profile} {Q : Nat} {iv : Digest32} {accept : FramedHistory → Bool} + {R : Type} {n : Nat} (policy : AnchoredByteStreamPrepared.Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) := + (table : RawKey Q → Digest32) → Option {e : Entry p (AnchoredByteStreamPrepared.PointPacket p Q iv accept) // + e ∈ (AnchoredByteStreamPrepared.execution policy source table).1.2} + +noncomputable def RawFailure {p : Profile} {Q : Nat} {iv : Digest32} + {accept : FramedHistory → Bool} {R : Type} {n : Nat} + (policy : AnchoredByteStreamPrepared.Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) + (select : RawSelector policy source) (advertised : (RawKey Q → Digest32) → E) + (opening : (RawKey Q → Digest32) → Array Claim) + (strategy : (RawKey Q → Digest32) → Strategy) + (sample : (RawKey Q → Digest32) × Tape (config p)) : Prop := + match select sample.1 with + | none => False + | some e => openingFailure p (chosenCommitment e.val (advertised sample.1)) + (opening sample.1) (strategy sample.1) sample.2 + +/-- Actual adaptive raw-byte source grouping and immutable selection, followed +by the proved independent causal opening experiment. Every public raw oracle +answer may be inspected by the final selector, with no observer restriction. -/ +theorem raw_security_ledger {p : Profile} {Q : Nat} {iv : Digest32} + {accept : FramedHistory → Bool} {R : Type} {n : Nat} + (policy : AnchoredByteStreamPrepared.Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) + (select : RawSelector policy source) (advertised : (RawKey Q → Digest32) → E) + (opening : (RawKey Q → Digest32) → Array Claim) + (strategy : (RawKey Q → Digest32) → Strategy) + (opening_cap : ∀ table, (opening table).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + (RawFailure policy source select advertised opening strategy)) ≤ romLedger n := by + classical + apply RingMapBatching.conditional_error + (fun table : RawKey Q → Digest32 => + Dirty (AnchoredByteStreamPrepared.execution policy source table).1.2) + _ _ _ (by positivity) + (AnchoredByteStreamPrepared.prepared_raw_table_ambiguity policy source) + intro table clean + cases chosen : select table with + | none => simp [RawFailure, chosen, Soundness.uniformProb] + | some e => + have sep : ¬ Ambiguous p e.val.commitment.lanes e.val.commitment.root + e.val.commitment.point := fun bad => clean ⟨e.val,e.property,bad⟩ + simpa only [RawFailure, chosen] using + (unique_opening_probability p (chosenCommitment e.val (advertised table)) + sep (opening table) (strategy table)).trans + (production_interactive p _ (opening_cap table)) + +private theorem profile_blocks : ∀ p : Profile, + 1 ≤ AnchoredFiatShamirSecurityCodec.blockCount (config p).logN := by + decide +kernel + +theorem raw_security_numeric {p : Profile} {Q : Nat} {iv : Digest32} + {accept : FramedHistory → Bool} {R : Type} {n : Nat} + (policy : AnchoredByteStreamPrepared.Policy p Q iv accept) + (source : Sampling (RawKey Q) (fun _ => Digest32) R n) + (blockBudget : n * AnchoredFiatShamirSecurityCodec.blockCount (config p).logN ≤ Q) + (compression : Q ≤ 2^60) + (select : RawSelector policy source) (advertised : (RawKey Q → Digest32) → E) + (opening : (RawKey Q → Digest32) → Array Claim) + (strategy : (RawKey Q → Digest32) → Strategy) + (opening_cap : ∀ table, (opening table).size+1 ≤ 2^64) : + Soundness.uniformProb (Finset.univ.filter + (RawFailure policy source select advertised opening strategy)) ≤ (1 : ℚ)/2^63 := by + have attempts : n ≤ 2^60 := calc + n = n*1 := by simp + _ ≤ n*AnchoredFiatShamirSecurityCodec.blockCount (config p).logN := + Nat.mul_le_mul_left n (profile_blocks p) + _ ≤ Q := blockBudget + _ ≤ 2^60 := compression + apply (raw_security_ledger policy source select advertised opening strategy opening_cap).trans + unfold romLedger + have h : (n : ℚ) ≤ 2^60 := by exact_mod_cast attempts + have anchor := div_le_div_of_nonneg_right h (by positivity : (0 : ℚ) ≤ 2^124) + calc + _ ≤ (2^60 : ℚ)/2^124 + (1 : ℚ)/2^73 := add_le_add anchor le_rfl + _ ≤ _ := by norm_num + + +/-- Chronology and counting alone still permit a root chosen after an answer. +The physical source integration must use its header decoder and frozen registry, +not infer pre-point preparation from the unrefined Source datatype. -/ +def lateRoot {cap : Nat} (query : DuplexModeGame.Query) : + WHIRSourceChronology.Source cap Unit := + .ask query (fun answer => .commit answer (.done ())) + +theorem lateRoot_before {cap : Nat} (query : DuplexModeGame.Query) : + WHIRSourceChronology.recover (lateRoot (cap := cap) query) [] = + ⟨[],some query,none⟩ := rfl + +theorem lateRoot_after {cap : Nat} (query : DuplexModeGame.Query) (answer : Digest32) : + (WHIRSourceChronology.recover (lateRoot (cap := cap) query) [⟨query,answer⟩]).events = + [.answer query answer,.commit answer] := rfl + +theorem lateRoot_counted {cap : Nat} (query : DuplexModeGame.Query) : + WHIRSourceChronology.Counts query.cost (lateRoot (cap := cap) query) := by + simp [lateRoot, WHIRSourceChronology.Counts] + +/- The byte codec and fresh raw history grouping concern actual 552 output +bytes. The opening term above is an independent causal opening tape, not the +native byte-stream body. Body challenge transport, accepted native arithmetic +and the BLAKE2s primitive gap are not proved by this ledger. Physical frame +absorption and all extra compression nodes must be charged by that composition. -/ + +end Whir.AnchoredFiatShamirSecurityBudget + +#print axioms Whir.AnchoredFiatShamirSecurityBudget.byte_stream_security_ledger +#print axioms Whir.AnchoredFiatShamirSecurityBudget.byte_stream_security_numeric +#print axioms Whir.AnchoredFiatShamirSecurityBudget.lateRoot_counted +#print axioms Whir.AnchoredFiatShamirSecurityBudget.raw_security_ledger +#print axioms Whir.AnchoredFiatShamirSecurityBudget.raw_security_numeric diff --git a/verification/whir/Whir/AnchoredIdealPhysicalAcceptance.lean b/verification/whir/Whir/AnchoredIdealPhysicalAcceptance.lean new file mode 100644 index 000000000..9aca982a2 --- /dev/null +++ b/verification/whir/Whir/AnchoredIdealPhysicalAcceptance.lean @@ -0,0 +1,410 @@ +import Whir.AnchoredPhysicalPreparation +import Whir.PCSBCSMixedOrdinaryMerkle + +/-! Acceptance for the historical pre-#607 native anchored source verifier. +Construction answers remain the actual, arbitrary RO packet values. Only the +ordinary verification primitives used by retained Merkle openers must agree +with the seed oracle. This is not a completed PCS/Fiat--Shamir endpoint: the +physical registry, its preparedness, and its first-frozen capture still need +the independent PCS first-capture crosswalk. -/ +namespace Whir.AnchoredIdealPhysicalAcceptance +open Concrete Protocol FiatShamirGame DuplexModeGame DuplexFraming +open MerkleTransport MerkleTransport.Commitments +open MerkleBinding +open WHIRPhysicalVerifier WHIRPhysicalReplay WHIRPhysicalOpeningRuns WHIRPhysicalSoundness +open PublicMerkleProgram WHIRSourceChronology AnchoredPhysicalDriver +open AnchoredPhysicalKnowledgeAcceptance (original input replies_nonempty sourceVerify_erased) +open PrunedMerkleProgram +set_option maxHeartbeats 800000 + +/-- No requirement on construction requests, or on nonordinary primitives. -/ +def PrimitiveConsistent (C : PrimitiveOracle) (observations : List Observation) : Prop := + ∀ o ∈ observations, ∀ n, o.query = .primitive .verification n → tag n = 0 → o.answer = C n + +/-- A syntactic all-reply byte bound, including rejecting continuations. -/ +private def HashBounded {R : Type} : HashProgram R → Prop + | .done _ => True + | .hash bytes next => bytes.length < 2^56 ∧ ∀ d, HashBounded (next d) + +private theorem bounded_bind {R S : Type} (p : HashProgram R) (next : R → HashProgram S) + (before : HashBounded p) (after : ∀ r, HashBounded (next r)) : + HashBounded (p.bind next) := by + induction p with + | done r => exact after r + | hash bytes next ih => exact ⟨before.1,fun d => ih d (before.2 d)⟩ + +private theorem bounded_map {R S : Type} (p : HashProgram R) (f : R → S) + (bound : HashBounded p) : HashBounded (p.map f) := + bounded_bind p _ bound (fun _ => trivial) + +private theorem leafHashes_bounded (rowWords leafWords : Nat) (rows : List (List K)) + (fits : rowWords ≤ leafWords) (bound : 8 * leafWords < 2^56) : + HashBounded (leafHashes rowWords leafWords rows) := by + induction rows with + | nil => trivial + | cons row rows ih => + unfold leafHashes + split + · rename_i width + refine ⟨?_,fun digest => bounded_map _ _ ih⟩ + rw [PrunedMerkleProgram.wordsBytes_length, + leafImage_length 0 leafWords row (width ▸ fits)] + omega + · trivial + +private theorem emit_bounded (i : Nat) (left right : Digest32) (tail : HashProgram LevelResult) + (bound : HashBounded tail) : HashBounded (emit i left right tail) := by + refine ⟨?_,fun _ => bounded_map _ _ bound⟩ + simp only [pairBytes,List.length_ofFn] + decide + +private theorem foldLevel_bounded (nodes : MerkleLevels.Level Digest32) (supplied : List Digest32) : + HashBounded (foldLevel nodes supplied) := by + induction nodes using (measure List.length).wf.induction generalizing supplied with + | _ nodes ih => + cases nodes with + | nil => simp [foldLevel,HashBounded] + | cons x nodes => + rcases x with ⟨i,d⟩ + rw [foldLevel.eq_def] + dsimp only + split + · cases nodes with + | nil => + cases supplied with + | nil => trivial + | cons s ss => exact emit_bounded i d s _ (ih [] (by change 0<1; omega) ss) + | cons y tail => + rcases y with ⟨j,e⟩ + dsimp only + split + · exact emit_bounded i d e _ + (ih tail (by change tail.length < tail.length+1+1; omega) supplied) + · cases supplied with + | nil => trivial + | cons s ss => + exact emit_bounded i d s _ + (ih ((j,e)::tail) (by change tail.length+1 < tail.length+1+1; omega) ss) + · cases supplied with + | nil => trivial + | cons s ss => + exact emit_bounded i s d _ + (ih nodes (by change nodes.length < nodes.length+1; omega) ss) + +private theorem levels_bounded (n : Nat) (nodes : MerkleLevels.Level Digest32) + (supplied : List Digest32) : HashBounded (levels n nodes supplied) := by + induction n generalizing nodes supplied with + | zero => trivial + | succ n ih => + apply bounded_bind _ _ (foldLevel_bounded nodes supplied) + intro result + cases result with + | none => trivial + | some triple => + rcases triple with ⟨parents,known,rest⟩ + exact bounded_map _ _ (ih parents rest) + +private theorem plan_bounded (proof : PrunedMerklePaths) (root : Digest32) (numLeaves : Nat) + (queries : List Nat) (rowWords leafWords : Nat) (bound : 8 * leafWords < 2^56) : + HashBounded (plan proof root numLeaves queries rowWords leafWords) := by + unfold plan + split + · trivial + · split + · trivial + · rename_i guards + apply bounded_bind _ _ (leafHashes_bounded rowWords leafWords proof.leafData (by omega) bound) + intro hashes + cases hashes with + | none => trivial + | some hashes => + dsimp only + by_cases range : ∃ q ∈ queries, numLeaves ≤ q + · simp only [range,↓reduceIte] + trivial + · simp only [range,↓reduceIte] + exact bounded_map _ _ (levels_bounded _ _ _) + +private theorem lower_ordinary {R : Type} (program : HashProgram R) (bound : HashBounded program) + (observations : List Observation) (result : R) + (run : Runs program.lower observations result) : + ∀ o ∈ observations, ∃ n, o.query = .primitive .verification n ∧ tag n = 0 := by + induction program generalizing observations result with + | done r => cases run; simp + | hash bytes next ih => + obtain ⟨before,digest,after,equal,hashed,continued⟩ := (Runs.bind_iff _ _).mp run + intro o member + rw [equal] at member + rcases List.mem_append.mp member with member | member + · exact PCSBCSMixedOrdinaryMerkle.hash_trace_tag_zero hashed bound.1 o member + · exact ih digest (bound.2 digest) after result continued o member + +/-- Actual opener syntax emits only ordinary verification primitives. The +statement includes unsuccessful executions and does not evaluate challenges. -/ +theorem openQuery_ordinary (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) (lanes : Nat) + (proof : PrunedMerklePaths) (root : Digest32) (sample : CausalProbability.Sample (.query i)) + (observations : List Observation) (result : Option Opened) + (run : Runs (openQuery p i lanes proof root sample) observations result) : + ∀ o ∈ observations, ∃ n, o.query = .primitive .verification n ∧ tag n = 0 := by + obtain ⟨before,paths,after,equal,opened,finished⟩ := (Runs.bind_iff _ _).mp run + cases finished + simp only [List.append_nil] at equal + subst observations + exact lower_ordinary _ (plan_bounded proof root _ _ _ _ (production_leaf_byte_tag_zero p i)) _ _ opened + +/-- Only the retained opener's primitive subtrace is transferred to the seed; +the caller and source challenge observations are left untouched. -/ +theorem observed_real {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array PrunedMerklePaths} + {observations : List Observation} {opening : QueryOpening p} + (observed : ObservedOpening lanes proofs observations opening) (C : PrimitiveOracle) (iv : Digest32) + (answers : PrimitiveConsistent C observations) : + ∃ proof, proofs[opening.level.val]? = some proof ∧ + (runReal C iv (openQuery p opening.level lanes proof opening.root opening.sample)).view.result = some opening.result ∧ + ∀ o ∈ (runReal C iv (openQuery p opening.level lanes proof opening.root opening.sample)).view.observations, + o ∈ observations := by + obtain ⟨proof,trace,index,run,subset⟩ := observed + have actual := run.real_result_trace C iv (by + intro o member + obtain ⟨n,query,ordinary⟩ := openQuery_ordinary p opening.level lanes proof opening.root opening.sample + trace _ run o member + rw [query] + exact answers o (subset o member) n query ordinary) + exact ⟨proof,index,actual.1,fun o member => subset o (actual.2 ▸ member)⟩ + +theorem observed_binding {p : ParameterBounds.Profile} {lanes : Nat} + {proofs : Array PrunedMerklePaths} {observations : List Observation} {opening : QueryOpening p} + (observed : ObservedOpening lanes proofs observations opening) (C : PrimitiveOracle) (iv : Digest32) + (answers : PrimitiveConsistent C observations) + (oldLog : PublicMerkleLog.PublicLog) (authentic : PublicMerkleLog.AuthenticLog C oldLog) + (retained : Records) + (history : ∀ e ∈ retained, ∃ earlier : PublicMerkleLog.PublicLog, + (∀ q ∈ earlier, q ∈ oldLog) ∧ e ∈ PublicMerkleLog.records earlier) + (saturated : ∀ bytes d, (bytes,d) ∈ PublicMerkleLog.records oldLog → ∃ first, (bytes,first) ∈ retained) + (snapshot : Snapshot) (table : snapshot.table = recordDomain retained) : + opening.result.rows = atQueries + (frozenQueryOracle (PublicMerkleLog.hash C) snapshot opening.root p opening.level.val lanes) + (queryIndices p opening.level opening.sample) ∨ + PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths := by + obtain ⟨proof,_,accepted,_⟩ := observed_real observed C iv answers + exact openQuery_retained C iv oldLog authentic retained history saturated snapshot table + p opening.level lanes proof opening.root opening.sample opening.result accepted + +private theorem opening_unerase (c : Config) (ch : Challenges) + (replies : Array CausalGame.Reply) (erased : Opening) + (accepted : CausalGame.opening c ch (replies.map WHIRPhysicalErasure.eraseReply) = .ok erased) : + ∃ proof, CausalGame.opening c ch replies = .ok proof ∧ WHIRPhysicalErasure.eraseOracles proof = erased := by + rw [WHIRPhysicalErasure.opening_erase] at accepted + cases parsed : CausalGame.opening c ch replies with + | error message => simp [parsed,Except.map] at accepted + | ok proof => + simp [parsed,Except.map] at accepted + exact ⟨proof,rfl,accepted⟩ + +/-- Registry lookup and readiness concern the actual retained physical trace. +They are not semantic state paths or a PCS capture-identity certificate. -/ +theorem execution_boundRows {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (C : PrimitiveOracle) (iv : Digest32) (packet : RawWHIRKeys.Packet ctx Q) + (record : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (a : Accepted ctx Q cap packet record) (observations : List Observation) + (answers : PrimitiveConsistent C observations) + (observed : ∀ opening ∈ a.wire.openings, ObservedOpening a.request.lanes proofs observations opening) + (trace : Trace ctx stack Q packet.val.profile a.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile a.request.root) a.wire a.history) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, lookup a.request.root state.registry = some snap) + (prepared : CausalBindingState.Prepared state packet.val.profile ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + WHIRPhysicalRoots.BoundRows (original a state).root (CausalBindingState.roots state packet.val.profile) a.wire := by + intro opening member + have chain := completion_chain ctx Q packet + obtain ⟨snapshot,known⟩ := trace_opening_registered packet a.request.root chain trace state + initial prepared opening member + obtain ⟨retained,oldLog,_,frozen,authentic,history,saturated,table⟩ := + invariant.retained opening.root snapshot known + rcases observed_binding (observed opening member) C iv answers oldLog authentic + retained history saturated snapshot table with bound | bad + · rw [frozenQueryOracle_state C state invariant packet.val.profile opening.root snapshot known + opening.level.val a.request.lanes a.request.lane_bound] at bound + by_cases base : opening.level.val = 0 + · have rootEq := trace_base_opening_root packet a.request.root chain trace opening member base + simpa only [base,ite_true,rootEq,original,CausalBindingState.bindClaims] using bound + · simpa only [ite_eq_right base] using bound + · exact False.elim (quiet opening member oldLog frozen bad) + +/-- Literal native acceptance restores protocol verification and experiment +success on the very same tape, with arbitrary actual construction replies. +The base is the physical first-frozen capture, not an identified PCS capture. -/ +theorem verifySource_experiment (cap : Nat) (boundary : Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (record : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (a : Accepted ctx Q cap packet record) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + observations (some a)) + (C : PrimitiveOracle) (iv : Digest32) + (answers : PrimitiveConsistent C observations) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, lookup record.root state.registry = some snap) + (prepared : CausalBindingState.Prepared state packet.val.profile ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + ∃ (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + replay.original = original a state ∧ a.wire.initial = some replay.initial ∧ + a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof ∧ + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (original a state).root) + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).weight + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).value proof = .ok () ∧ + CausalGame.experiment (input a state replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨caller,rootEq,lanesEq,trace,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap boundary model ctx stack Q packet record proofs observations a run + have trace' : Trace ctx stack Q packet.val.profile a.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile a.request.root) a.wire a.history := by + simpa only [rootEq,lanesEq] using trace + have bound := execution_boundRows C iv packet record proofs a observations answers + (by simpa only [lanesEq] using observed) trace' state invariant (by simpa only [rootEq] using initial) prepared quiet + let catalog : StackWHIRReplay.Catalog packet.val.profile cap := fun _ => some (original a state) + have found : catalog packet.val.statement = some (original a state) := rfl + have chain := completion_chain ctx Q packet + have complete := trace_completed a.request.root chain trace' + obtain ⟨head,past,sample,erased,history,decoded,originalEq,initialSeed,statement,tape,replies⟩ := + Completed.decodeStack packet a.wire a.history catalog (original a state) found complete (replies_nonempty a) + have tail : (localHistory ctx stack Q packet.val.profile a.history).tail = past := by rw [history]; rfl + have full := decoded + change WHIRPhysicalHistory.decodeStack packet.val.profile cap catalog WHIRPhysicalErasure.zeroRoots + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ = some erased at full + rw [WHIRPhysicalErasure.decodeStack_zero packet.val.profile cap catalog (CausalBindingState.roots state packet.val.profile) + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩] at full + obtain ⟨replay,physical,erasedEq⟩ := Option.map_eq_some_iff.mp full + subst erased + change replay.original = original a state at originalEq + change a.wire.initial = some replay.initial at initialSeed + change (StackWHIRReplay.finish ⟨packet.val.statement,packet.val.messages,past⟩ replay sample).whir.tape = a.wire.tape at tape + change replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies at replies + have agreement := WHIRPhysicalRoots.trace_stackRowsAgree packet a.request.root catalog (original a state) + (CausalBindingState.roots state packet.val.profile) found chain trace' bound + rw [tail] at agreement + have ideal := WHIRPhysicalHistory.decodeStack_success packet.val.profile cap catalog + (CausalBindingState.roots state packet.val.profile) (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,past⟩ replay agreement physical + have lambda := StackWHIRReplay.decode_initial_lambda catalog (CausalBindingState.roots state packet.val.profile) + ⟨packet.val.statement,packet.val.messages,past⟩ replay ideal sample + rw [tape] at lambda + change a.wire.tape.1 = replay.initial.2 at lambda + obtain ⟨seed,nativeProof,seedFound,parsed,native⟩ := a.acceptance + have sameSeed : seed = replay.initial := Option.some.inj (seedFound.symm.trans initialSeed) + subst seed + rw [← replies] at parsed + obtain ⟨proof,parsedFull,erasedProof⟩ := opening_unerase _ _ replay.whir.replies nativeProof parsed + have nativeFull : AnchoredPhysicalAnchor.sourceVerify record a.request.claims.family a.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) proof = .ok () := by + rw [← sourceVerify_erased,erasedProof] + exact native + have rootsShape := decodeStack_rootShapes packet.val.profile cap state catalog + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ replay physical a.wire.tape proof parsedFull + have authenticated := trace_authenticatedRows packet a.request.root (original a state).root + (CausalBindingState.roots state packet.val.profile) chain trace' bound catalog replay + (by rw [tail]; exact physical) proof parsedFull + obtain ⟨before,after,_,_,_,callerParsed⟩ := caller + obtain ⟨_,same,_,_,_,_,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_success + cap boundary model ctx stack Q packet record proofs observations a run + have shapes := request_anchored_shapes boundary cap packet.val.profile model record a.configuration same + (RawWHIRKeys.entry ctx packet.val) (WHIRPhysicalCaller.latestAnswers before) a.request callerParsed + replay.initial.1 replay.initial.2 + have nativeShapes := request_nativeShapes boundary cap packet.val.profile model record a.configuration same + (RawWHIRKeys.entry ctx packet.val) (WHIRPhysicalCaller.latestAnswers before) a.request callerParsed + have verified := AnchorPrefixRefinement.sourceVerify_refines record a.request.claims.family a.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) _ proof + (CausalGame.liftRoot (original a state).root) a.configuration.1 a.configuration.2.1 a.configuration.2.2.1 + nativeShapes.1 (fun i => nativeShapes.2 _ (by simp)) shapes.2 + (by simpa only [original,CausalBindingState.bindClaims,lanesEq] using + capture_base_shape state packet.val.profile a.request.root a.request.lanes a.request.lane_bound) + rootsShape authenticated nativeFull + have verifiedTape : Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (original a state).root) + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).weight + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).value proof = .ok () := by + rw [lambda] + exact verified + refine ⟨replay,proof,originalEq,initialSeed,lambda,replies,parsedFull,verifiedTape,?_⟩ + apply experiment_indexed_accepts (input a state replay.initial.1) a.wire.tape replay.whir.replies proof parsedFull + · exact shapes.1 + · exact verifiedTape + +/-- Preparation is derived from the exact executed native parser. Remaining +physical boundaries are `invariant`, `initial`, `registered`, and `quiet`; +identifying this physical first capture with PCS first capture is not assumed +or concluded. Neither protocol acceptance nor experiment success is a premise. -/ +theorem verifySource_prepared_experiment (cap : Nat) (boundary : Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (record : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (observations : List Observation) + (a : Accepted ctx Q cap packet record) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + observations (some a)) + (C : PrimitiveOracle) (iv : Digest32) (answers : PrimitiveConsistent C observations) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, lookup record.root state.registry = some snap) + (registered : CausalBindingState.Prepared state packet.val.profile ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + ∃ prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.count a.request.claims.family a.request.claims.points record.point.toArray record.value, + ∃ (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + OriginalClaimsChecker.prepare (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.family a.request.claims.points record.point.toArray record.value = some prepared ∧ + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) ∧ + replay.original = original a state ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof ∧ + (let claims := (OriginalClaimsChecker.input prepared (original a state).root replay.initial.1).claims + let claim := CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) claims a.wire.tape.1 + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (original a state).root) claim.weight claim.value proof = .ok ()) ∧ + CausalGame.experiment (OriginalClaimsChecker.input prepared (original a state).root replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨prepared,preparedEq,inputEq⟩ := AnchoredPhysicalPreparation.verifySource_preparation + cap boundary model ctx stack Q packet record proofs observations a run + obtain ⟨replay,proof,originalEq,seed,lambda,erased,parsed,verified,experiment⟩ := + verifySource_experiment cap boundary model ctx stack Q packet record + proofs observations a run C iv answers state invariant initial registered quiet + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution cap boundary model ctx stack Q + packet record proofs observations a run + have complete := trace_completed record.root (completion_chain ctx Q packet) trace + have claimsEq := congrArg CausalGame.Public.claims (inputEq state replay.initial.1) + refine ⟨prepared,replay,proof,preparedEq,AnchoredPhysicalPreparation.accepted_completed_depth a complete, + originalEq,seed,lambda,erased,parsed,?_,?_⟩ + · simpa only [claimsEq] using verified + · have experimentEq := congrArg (fun claims => + CausalGame.experiment + (CausalGame.Public.mk (ParameterBounds.config packet.val.profile) record.shape.lanes + (original a state).root claims) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape) claimsEq + exact experimentEq.trans experiment + +#print axioms openQuery_ordinary +#print axioms observed_real +#print axioms observed_binding +#print axioms execution_boundRows +#print axioms verifySource_experiment +#print axioms verifySource_prepared_experiment + +end Whir.AnchoredIdealPhysicalAcceptance diff --git a/verification/whir/Whir/AnchoredMixedAttackerPrefix.lean b/verification/whir/Whir/AnchoredMixedAttackerPrefix.lean new file mode 100644 index 000000000..ba0723d6a --- /dev/null +++ b/verification/whir/Whir/AnchoredMixedAttackerPrefix.lean @@ -0,0 +1,792 @@ +import Whir.AnchoredSourceGroups +import Whir.PublicCompressionCouplingMixed +import Whir.PCSBCSMerkleRootCache +import Whir.PCSBCSMixedOrdinaryMerkle + +/-! Mixed attacker-prefix grouping. The ordinary summand exposes its full +compression reply, including repeated requests. The construction summand is +literal bounded raw input. At first contact with any point block, preparation +uses only the strict completed mixed history; it freezes the decoded header's +public ordinary Merkle prefix before the whole-run answer is allocated. + +The final specialization of the existing public-simulator lowering preserves +its entire View. Its public ordinary log contains completed fallback draws. +AnchoredMixedAttackerPrefixSource proves that omitted cache hits preserve the +frozen root table when the SAME actual ordinary trace's OutputCollision alarm +is quiet. No native body/knowledge or current-607 correspondence is asserted. -/ +namespace Whir.AnchoredMixedAttackerPrefix +open Concrete FiatShamirGame DuplexModeGame ParameterBounds TypedOracleCompiler +open RawOracleCoupling AnchoredByteStreamCausal AnchoredByteStreamGroups + +abbrev Key := PublicCompressionCouplingMixed.Key +abbrev History (Q : Nat) := List (Key Q × Digest32) + +noncomputable def recognize (Q dimension : Nat) (iv : Digest32) + (accept : FramedHistory → Bool) : Key Q → + Option (Sigma (fun _ : Packet Q dimension iv accept => + Fin (AnchoredFiatShamirSecurityCodec.blockCount dimension))) + | .inl _ => none + | .inr raw => AnchoredByteStreamCausal.recognize Q dimension iv accept raw + +noncomputable def partition (Q dimension : Nat) (iv : Digest32) + (accept : FramedHistory → Bool) : Partition (Key Q) + (Packet Q dimension iv accept) + (fun _ => Fin (AnchoredFiatShamirSecurityCodec.blockCount dimension)) where + encode := fun c => .inr (AnchoredByteStreamCausal.encode Q dimension iv accept c) + recognize := recognize Q dimension iv accept + recognize_encode := fun c => AnchoredByteStreamCausal.recognize_encode Q dimension iv accept c + encode_recognize := by + intro raw c found + cases raw with + | inl input => simp [recognize] at found + | inr raw => + exact congrArg Sum.inr + (AnchoredByteStreamCausal.encode_recognize Q dimension iv accept raw c found) + +/-- Newest-first, actual completed ordinary replies only. In particular no raw +construction answer can masquerade as a compression preimage. -/ +def ordinaryPrefix (past : History Q) : PublicMerkleLog.PublicLog := + past.filterMap fun (key,answer) => match key with + | .inl input => if DuplexFraming.tag input = 0 then some (input,answer) else none + | .inr _ => none + +@[simp] theorem ordinaryPrefix_raw (raw : RawKey Q) (answer : Digest32) (past : History Q) : + ordinaryPrefix ((.inr raw,answer)::past) = ordinaryPrefix past := rfl + +@[simp] theorem ordinaryPrefix_ordinary (input : DuplexFraming.Node) (answer : Digest32) + (past : History Q) (ordinary : DuplexFraming.tag input = 0) : + ordinaryPrefix ((.inl input,answer)::past) = (input,answer)::ordinaryPrefix past := by + simp [ordinaryPrefix,ordinary] + +namespace Grouped +open Concrete Protocol CausalGame ParameterBounds CommitmentAnchor FiatShamirGame +open TypedOracleCompiler RawOracleCoupling RawOracleCoupling.Concrete +open AnchoredFiatShamirSecurityCodec AnchoredByteStreamGroups +open DuplexFraming DuplexModeGame + +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 + +variable {p : Profile} {Q : Nat} {iv : Digest32} {accept : FramedHistory → Bool} + +abbrev PointPacket (p : Profile) (Q : Nat) (iv : Digest32) (accept : FramedHistory → Bool) := + Packet Q (config p).logN iv accept +abbrev Records := AnchoredFiatShamirSecurity.Cache p (PointPacket p Q iv accept) +abbrev Group := (partition Q (config p).logN iv accept).Key +abbrev Reply := (partition Q (config p).logN iv accept).Answer (D := Digest32) +abbrev GroupCache := TypedFiatShamirGame.Cache (Group (p := p) (Q := Q) (iv := iv) (accept := accept)) + (Reply (p := p) (Q := Q) (iv := iv) (accept := accept)) + +structure Policy (p : Profile) (Q : Nat) (iv : Digest32) (accept : FramedHistory → Bool) where + prepare : History Q → PointPacket p Q iv accept → AnchoredFiatShamirSecurity.PreAnchor p + advertise : History Q → PointPacket p Q iv accept → Joint (config p).logN → E + +noncomputable def step (policy : Policy p Q iv accept) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (packet : PointPacket p Q iv accept) (blocks : Blocks (config p).logN) := + AnchoredFiatShamirSecurity.advance + { choose := fun _ => packet + prepare := fun _ _ => policy.prepare past packet + advertise := fun _ _ answer => policy.advertise past packet answer } + records (vectorParts (config p).logN blocks) + +theorem repeated_original (policy : Policy p Q iv accept) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (packet : PointPacket p Q iv accept) (e : AnchoredFiatShamirSecurity.Entry p _) + (hit : AnchoredFiatShamirSecurity.lookup records packet = some e) + (blocks : Blocks (config p).logN) : step policy past records packet blocks = e :: records := by + exact AnchoredFiatShamirSecurity.repeated_key _ records e hit _ + +noncomputable def compile (policy : Policy p Q iv accept) {R : Type} : {n : Nat} → + Sampling (Key Q) (fun _ => Digest32) R n → History Q → + Records (p := p) (Q := Q) (iv := iv) (accept := accept) → + Sampling (Group (p := p) (Q := Q) (iv := iv) (accept := accept)) + (Reply (p := p) (Q := Q) (iv := iv) (accept := accept)) + (R × Records (p := p) (Q := Q) (iv := iv) (accept := accept)) n + | _, .ret result, _, records => .ret (result,records) + | _, .draw raw next, past, records => + match h : recognize Q (config p).logN iv accept raw with + | some c => .draw (.inl c.1) (fun blocks => + compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + | none => .draw (.inr ⟨raw,h⟩) (fun answer => + compile policy (next answer) ((raw,answer)::past) records) + +private def Seen (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (cache : GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept)) : Prop := + ∀ packet blocks, cache (.inl packet) = some blocks → + ∃ e, AnchoredFiatShamirSecurity.lookup records packet = some e + +private theorem step_clean (policy : Policy p Q iv accept) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (clean : ¬ AnchoredFiatShamirSecurity.Dirty records) (packet : PointPacket p Q iv accept) + (blocks : Blocks (config p).logN) + (separated : ¬ Ambiguous p (policy.prepare past packet).lanes + (policy.prepare past packet).root (point (config p).logN blocks)) : + ¬ AnchoredFiatShamirSecurity.Dirty (step policy past records packet blocks) := by + classical + unfold step AnchoredFiatShamirSecurity.advance + dsimp only + cases hit : AnchoredFiatShamirSecurity.lookup records packet with + | none => + simp only [AnchoredFiatShamirSecurity.Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨separated,clean⟩ + | some e => + have member : e ∈ records := List.mem_of_find?_eq_some hit + simp only [AnchoredFiatShamirSecurity.Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨fun bad => clean ⟨e,member,bad⟩,clean⟩ + +private theorem step_seen (policy : Policy p Q iv accept) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (cache : GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept)) (seen : Seen records cache) + (packet : PointPacket p Q iv accept) (blocks : Blocks (config p).logN) : + Seen (step policy past records packet blocks) (TypedFiatShamirGame.put cache (.inl packet) blocks) := by + classical + intro wanted value present + unfold step AnchoredFiatShamirSecurity.advance + dsimp only + cases hit : AnchoredFiatShamirSecurity.lookup records packet with + | none => + by_cases same : wanted = packet + · subst wanted + refine ⟨⟨packet, + ⟨(policy.prepare past packet).lanes,(policy.prepare past packet).root, + (vectorParts (config p).logN blocks).1, + policy.advertise past packet (vectorParts (config p).logN blocks), + (policy.prepare past packet).occupied⟩, + (vectorParts (config p).logN blocks).2⟩,?_⟩ + simp [AnchoredFiatShamirSecurity.lookup] + · have old : cache (.inl wanted) = some value := by + simpa [TypedFiatShamirGame.put, same] using present + obtain ⟨e,found⟩ := seen wanted value old + exact ⟨e,by simpa [AnchoredFiatShamirSecurity.lookup, Ne.symm same] using found⟩ + | some e => + by_cases same : wanted = packet + · subst wanted + refine ⟨e,?_⟩ + have keyeq : e.key = packet := by + have member := List.find?_some hit + simpa using member + simp [AnchoredFiatShamirSecurity.lookup, keyeq] + · have old : cache (.inl wanted) = some value := by + simpa [TypedFiatShamirGame.put, same] using present + obtain ⟨other,found⟩ := seen wanted value old + have keyeq : e.key = packet := by + have member := List.find?_some hit + simpa using member + exact ⟨other,by simpa [AnchoredFiatShamirSecurity.lookup, keyeq, Ne.symm same] using found⟩ + +private theorem ambiguity_average (pre : AnchoredFiatShamirSecurity.PreAnchor p) : + average (fun blocks : Blocks (config p).logN => + if Ambiguous p pre.lanes pre.root (point (config p).logN blocks) then (1 : ℚ) else 0) ≤ + (1 : ℚ)/2^124 := by + rw [vector_point_average (config p).logN + (fun pt => if Ambiguous p pre.lanes pre.root pt then (1 : ℚ) else 0)] + have h := ambiguity_probability_numeric p pre.lanes pre.root pre.occupied.2 + simpa only [average, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using h + +private theorem memo_bound (policy : Policy p Q iv accept) {R : Type} {n : Nat} + (source : Sampling (Key Q) (fun _ => Digest32) R n) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (cache : GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept)) + (seen : Seen records cache) (clean : ¬ AnchoredFiatShamirSecurity.Dirty records) : + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (compile policy source past records) cache) ≤ (n : ℚ)/2^124 := by + classical + induction source generalizing past records cache with + | ret result => + simp only [compile, RawOracleCoupling.memo, Sampling.expectation, clean, ↓reduceIte] + positivity + | @draw n raw next ih => + unfold compile + split + · rename_i c recognized + cases cached : cache (.inl c.1) with + | some blocks => + obtain ⟨e,hit⟩ := seen c.1 blocks cached + have repeated := repeated_original policy past records c.1 e hit blocks + have nextClean : ¬ AnchoredFiatShamirSecurity.Dirty (step policy past records c.1 blocks) := by + rw [repeated] + have member : e ∈ records := List.mem_of_find?_eq_some hit + simp only [AnchoredFiatShamirSecurity.Dirty, List.mem_cons, exists_eq_or_imp] + exact not_or.mpr ⟨fun bad => clean ⟨e,member,bad⟩,clean⟩ + have nextSeen : Seen (step policy past records c.1 blocks) cache := by + have s := step_seen policy past records cache seen c.1 blocks + have putSame : TypedFiatShamirGame.put cache (.inl c.1) blocks = cache := by + funext k + by_cases same : k = .inl c.1 + · subst k; simp [cached] + · simp [TypedFiatShamirGame.put_other _ _ _ _ same] + simpa [putSame] using s + simp only [RawOracleCoupling.memo, cached, Sampling.expectation_pad] + exact (ih (blocks c.2) _ _ _ nextSeen nextClean).trans + (div_le_div_of_nonneg_right (by exact_mod_cast Nat.le_succ n) (by positivity)) + | none => + simp only [RawOracleCoupling.memo, cached, Sampling.expectation] + have fiber (blocks : Blocks (config p).logN) : + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks)) ≤ + (if Ambiguous p (policy.prepare past c.1).lanes (policy.prepare past c.1).root + (point (config p).logN blocks) then 1 else 0) + (n : ℚ)/2^124 := by + by_cases bad : Ambiguous p (policy.prepare past c.1).lanes (policy.prepare past c.1).root + (point (config p).logN blocks) + · have one := Sampling.expectation_le_one + (fun result : (R × Records (p := p) (Q := Q) (iv := iv) (accept := accept)) × + GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept) => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (fun result => by split <;> norm_num) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks)) + simpa [bad] using one.trans (le_add_of_nonneg_right (by positivity : 0 ≤ (n : ℚ)/2^124)) + · simpa [bad] using ih (blocks c.2) _ _ _ + (step_seen policy past records cache seen c.1 blocks) + (step_clean policy past records clean c.1 blocks bad) + have averaged := average_mono fiber + have badBound := ambiguity_average (policy.prepare past c.1) + have bound : + average (fun blocks : Blocks (config p).logN => + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks))) ≤ + (1 : ℚ)/2^124 + (n : ℚ)/2^124 := averaged.trans (by + rw [average_add, average_const] + exact add_le_add badBound le_rfl) + have arithmetic : (1 : ℚ)/2^124 + (n : ℚ)/2^124 = + ((n+1 : Nat) : ℚ)/2^124 := by push_cast; ring + refine le_trans (le_of_eq ?_) (bound.trans_eq arithmetic) + refine @RawOracleCoupling.average_equiv + (Reply (p := p) (Q := Q) (iv := iv) (accept := accept) (.inl c.1)) + (Blocks (config p).logN) ?_ ?_ (Equiv.refl (Blocks (config p).logN)) + (fun blocks : Blocks (config p).logN => + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo + (compile policy (next (blocks c.2)) ((raw,blocks c.2)::past) + (step policy past records c.1 blocks)) + (TypedFiatShamirGame.put cache (.inl c.1) blocks))) + · rename_i unrecognized + have updatedSeen (answer : Digest32) : + Seen records (TypedFiatShamirGame.put cache (.inr ⟨raw,unrecognized⟩) answer) := by + intro packet blocks present + apply seen packet blocks + simpa [TypedFiatShamirGame.put] using present + cases cached : cache (.inr ⟨raw,unrecognized⟩) with + | some answer => + simp only [RawOracleCoupling.memo, cached, Sampling.expectation_pad] + exact (ih answer _ _ _ seen clean).trans + (div_le_div_of_nonneg_right (by exact_mod_cast Nat.le_succ n) (by positivity)) + | none => + simp only [RawOracleCoupling.memo, cached, Sampling.expectation] + apply (average_mono (fun answer => ih answer _ _ _ (updatedSeen answer) clean)).trans + rw [average_const] + exact div_le_div_of_nonneg_right (by exact_mod_cast Nat.le_succ n) (by positivity) + +/-- Genuine adaptive source-key preparation. Roots depend on the completed raw +history, including every fourth word actually queried. First contact may be ANY +point block; the whole run is memoized and repeats preserve the same point. +No fresh-source-key assumption occurs in this theorem. -/ +theorem causal_prepared_ambiguity {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (Key Q) (fun _ => Digest32) R n) : + Sampling.expectation (fun result => + if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)) ≤ (n : ℚ)/2^124 := + memo_bound policy source [] [] (fun _ => none) + (by intro packet blocks present; contradiction) + (by simp [AnchoredFiatShamirSecurity.Dirty]) + +theorem profile_blocks : ∀ p : Profile, 0 < blockCount (config p).logN := by + decide +kernel + +noncomputable def execution (policy : Policy p Q iv accept) {R : Type} {n : Nat} + (source : Sampling (Key Q) (fun _ => Digest32) R n) (table : Key Q → Digest32) := + Sampling.eval ((partition Q (config p).logN iv accept).split table) + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)) + +private theorem compile_result {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (Key Q) (fun _ => Digest32) R n) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (table : Key Q → Digest32) : + (Sampling.eval ((partition Q (config p).logN iv accept).split table) + (compile policy source past records)).1 = Sampling.eval table source := by + induction source generalizing past records with + | ret result => rfl + | draw raw next ih => + unfold compile + split + · rename_i c recognized + simp only [Sampling.eval, Partition.split, ih] + change Sampling.eval table + (next (table ((partition Q (config p).logN iv accept).encode c))) = _ + rw [(partition Q (config p).logN iv accept).encode_recognize raw c recognized] + · simp only [Sampling.eval, Partition.split, ih] + +/-- The compiler changes no raw reply or continuation. Its extra state consists +only of the immutable prepared records and the memoized complete point runs. -/ +theorem execution_result {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (Key Q) (fun _ => Digest32) R n) (table : Key Q → Digest32) : + (execution policy source table).1.1 = Sampling.eval table source := by + unfold execution + rw [RawOracleCoupling.memo_eval_first, RawOracleCoupling.overlay_empty] + rw [compile_result] + +/-- Joint coupling includes the actual source result, immutable records and +private grouped cache. No part of any public raw answer is erased. -/ +theorem prepared_full_distribution {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (Key Q) (fun _ => Digest32) R n) + (payoff : (R × Records (p := p) (Q := Q) (iv := iv) (accept := accept)) × + GroupCache (p := p) (Q := Q) (iv := iv) (accept := accept) → ℚ) : + average (fun table : Key Q → Digest32 => payoff (execution policy source table)) = + Sampling.expectation payoff + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)) := by + classical + let _ := packetFintype Q (config p).logN iv accept (profile_blocks p) + have h := RawOracleCoupling.average_equiv + ((partition Q (config p).logN iv accept).tableEquiv (D := Digest32)) + (fun table => payoff (Sampling.eval table + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)))) + rw [show average (fun table : Key Q → Digest32 => payoff (execution policy source table)) = + average (fun table => payoff (Sampling.eval table + (RawOracleCoupling.memo (compile policy source [] []) (fun _ => none)))) from h] + exact RawOracleCoupling.table_eq_memo_full _ (fun _ => none) payoff + +theorem prepared_raw_table_ambiguity {R : Type} {n : Nat} (policy : Policy p Q iv accept) + (source : Sampling (Key Q) (fun _ => Digest32) R n) : + Soundness.uniformProb (Finset.univ.filter fun table : Key Q → Digest32 => + AnchoredFiatShamirSecurity.Dirty (execution policy source table).1.2) ≤ (n : ℚ)/2^124 := by + classical + have h := prepared_full_distribution policy source + (fun result => if AnchoredFiatShamirSecurity.Dirty result.1.2 then (1 : ℚ) else 0) + have bound := causal_prepared_ambiguity policy source + rw [← h] at bound + simpa only [average, Soundness.uniformProb, Finset.card_filter, Nat.cast_sum, + Nat.cast_ite, Nat.cast_one, Nat.cast_zero] using bound + +/-- Count actual construction-summand requests; ordinary draws cost no raw +request here, and repetitions still cost one request. -/ +def rawRequests (table : Key Q → Digest32) : {n : Nat} → + Sampling (Key Q) (fun _ => Digest32) R n → Nat + | _, .ret _ => 0 + | _, .draw key next => + (match key with | .inl _ => 0 | .inr _ => 1) + + rawRequests table (next (table key)) + +theorem rawRequests_le (table : Key Q → Digest32) + (source : Sampling (Key Q) (fun _ => Digest32) R n) : + rawRequests table source ≤ n := by + induction source with + | ret => simp [rawRequests] + | draw key next ih => + have bound := ih (table key) + cases key <;> simp only [rawRequests] <;> omega + +theorem step_length (policy : Policy p Q iv accept) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (packet : PointPacket p Q iv accept) (blocks : Blocks (config p).logN) : + (step policy past records packet blocks).length = records.length+1 := by + unfold step AnchoredFiatShamirSecurity.advance + dsimp only + split <;> rfl + +theorem compile_records_length (policy : Policy p Q iv accept) + (source : Sampling (Key Q) (fun _ => Digest32) R n) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (table : Key Q → Digest32) : + (Sampling.eval ((partition Q (config p).logN iv accept).split table) + (compile policy source past records)).2.length ≤ + records.length + rawRequests table source := by + induction source generalizing past records with + | ret result => simp [compile,Sampling.eval,rawRequests] + | draw raw next ih => + unfold compile + split + · rename_i c recognized + have same := (partition Q (config p).logN iv accept).encode_recognize raw c recognized + simp only [Sampling.eval,Partition.split] + have bound := ih (table ((partition Q (config p).logN iv accept).encode c)) + ((raw,table ((partition Q (config p).logN iv accept).encode c))::past) + (step policy past records c.1 + (fun i => table ((partition Q (config p).logN iv accept).encode ⟨c.1,i⟩))) + rw [same,step_length] at bound + cases raw with + | inl input => simp [recognize] at recognized + | inr raw => simpa only [same,rawRequests,Nat.add_assoc] using bound + · rename_i unrecognized + simp only [Sampling.eval,Partition.split] + have bound := ih (table raw) ((raw,table raw)::past) records + cases raw <;> simp only [rawRequests] <;> omega + +/-- One allocation per distinct packet, whereas the records list includes +repeated observations of the original immutable entry. -/ +noncomputable def allocations + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) : Nat := by + classical + exact (records.map (fun e => e.key)).toFinset.card + +theorem allocation_budget (policy : Policy p Q iv accept) + (source : Sampling (Key Q) (fun _ => Digest32) R n) (table : Key Q → Digest32) : + allocations (execution policy source table).1.2 ≤ rawRequests table source ∧ + rawRequests table source ≤ n := by + classical + refine ⟨?_,rawRequests_le table source⟩ + unfold execution + rw [RawOracleCoupling.memo_eval_first,RawOracleCoupling.overlay_empty] + have lengthBound := compile_records_length policy source [] [] table + simp only [List.length_nil,zero_add] at lengthBound + exact ((List.toFinset_card_le _).trans_eq (List.length_map ..)).trans lengthBound + +theorem repeated_allocation (policy : Policy p Q iv accept) (past : History Q) + (records : Records (p := p) (Q := Q) (iv := iv) (accept := accept)) + (packet : PointPacket p Q iv accept) (e : AnchoredFiatShamirSecurity.Entry p _) + (hit : AnchoredFiatShamirSecurity.lookup records packet = some e) + (blocks : Blocks (config p).logN) : + allocations (step policy past records packet blocks) = allocations records := by + classical + rw [repeated_original policy past records packet e hit blocks] + have member : e.key ∈ (records.map (fun e => e.key)).toFinset := + List.mem_toFinset.mpr (List.mem_map.mpr ⟨e,List.mem_of_find?_eq_some hit,rfl⟩) + simp only [allocations,List.map_cons,List.toFinset_cons] + rw [Finset.insert_eq_of_mem member] + + +end Grouped + +open AnchoredHeaderRoots AnchoredFiatShamirSecurityCodec + +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +/-- Full leaf-image width is distinct from occupied lanes. -/ +def rootShape (header : Header) : PCSBCSMerkleRootCache.Shape := + ⟨header.shape.logN-header.shape.logBatch+header.shape.logRate, + 2^header.shape.logBatch,header.shape.lanes⟩ + +structure PrefixState where + log : PublicMerkleLog.PublicLog := [] + roots : PCSBCSMerkleRootCache.Registry := ∅ + +/-- Recording an ordinary answer is the only operation that extends the +ordinary log. Raw requests merely freeze a decoded root/shape address. -/ +noncomputable def completed (registry : Public) (state : PrefixState) + (key : Key Q) (answer : Digest32) : PrefixState := + match key with + | .inl input => + if DuplexFraming.tag input = 0 then {state with log := (input,answer)::state.log} + else state + | .inr raw => + match rawHeader registry raw with + | none => state + | some header => {state with roots := + PCSBCSMerkleRootCache.register state.roots state.log header.root (rootShape header)} + +/-- Tail-first traversal replays the newest-first public history in chronology. +At a raw event, `completed` does not inspect that event's answer. -/ +noncomputable def replay (registry : Public) : History Q → PrefixState + | [] => {} + | (key,answer)::past => completed registry (replay registry past) key answer + +theorem replay_log (registry : Public) (past : History Q) : + (replay registry past).log = ordinaryPrefix past := by + induction past with + | nil => rfl + | cons item past ih => + rcases item with ⟨key,answer⟩ + cases key with + | inl input => + simp only [replay,completed,ordinaryPrefix,List.filterMap_cons] + split <;> simp_all [ordinaryPrefix] + | inr raw => + simp only [replay,completed,ordinaryPrefix,List.filterMap_cons] + cases rawHeader registry raw <;> exact ih + +theorem completed_preserves (registry : Public) (state : PrefixState) + (key : Key Q) (answer : Digest32) (header : Header) + (frozen : PCSBCSMerkleRootCache.Frozen) + (known : state.roots[PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = + some frozen) : + (completed registry state key answer).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = some frozen := by + cases key with + | inl input => simp only [completed]; split <;> exact known + | inr raw => + simp only [completed] + cases rawHeader registry raw with + | none => exact known + | some other => exact PCSBCSMerkleRootCache.register_preserves _ _ _ _ _ _ _ known + +theorem replay_wellFormed (registry : Public) (past : History Q) : + PCSBCSMerkleRootCache.WellFormed (replay registry past).roots := by + induction past with + | nil => exact PCSBCSMerkleRootCache.empty_wellFormed + | cons item past ih => + rcases item with ⟨key,answer⟩ + cases key with + | inl input => simp only [replay,completed]; split <;> exact ih + | inr raw => + simp only [replay,completed] + cases rawHeader registry raw with + | none => exact ih + | some header => exact PCSBCSMerkleRootCache.register_wellFormed _ _ _ _ ih + +/-- The current reply is absent: registration takes the earlier replay log and +the literal header only. No compression oracle is an argument. -/ +noncomputable def beforeHeader (registry : Public) (past : History Q) (header : Header) : + PCSBCSMerkleRootCache.Registry := + PCSBCSMerkleRootCache.register (replay registry past).roots (replay registry past).log + header.root (rootShape header) + +noncomputable def frozenHeader (registry : Public) (past : History Q) (header : Header) : + PCSBCSMerkleRootCache.Frozen := + (beforeHeader registry past header)[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]?.getD + (PCSBCSMerkleRootCache.freeze (ordinaryPrefix past) header.root (rootShape header)) + +theorem frozenHeader_known (registry : Public) (past : History Q) (header : Header) : + (beforeHeader registry past header)[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = + some (frozenHeader registry past header) := by + unfold beforeHeader frozenHeader + cases known : (replay registry past).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? with + | none => simp [beforeHeader,PCSBCSMerkleRootCache.register,known] + | some frozen => simp [beforeHeader,PCSBCSMerkleRootCache.register,known] + +theorem frozenHeader_provenance (registry : Public) (past : History Q) (header : Header) : + frozenHeader registry past header = + PCSBCSMerkleRootCache.freeze (frozenHeader registry past header).queryPrefix + header.root (rootShape header) := by + have valid := PCSBCSMerkleRootCache.register_wellFormed (replay registry past).roots + (replay registry past).log header.root (rootShape header) (replay_wellFormed registry past) + exact valid header.root (rootShape header) _ (frozenHeader_known registry past header) + +theorem frozenHeader_geometry (registry : Public) (past : History Q) + (header : Header) (valid : header.shape.Valid) : + (frozenHeader registry past header).raw.size = + 2^(header.shape.logN-header.shape.logBatch+header.shape.logRate) ∧ + ∀ row ∈ (frozenHeader registry past header).raw.toList, row.size = header.shape.lanes := by + rw [frozenHeader_provenance] + exact PCSBCSMerkleRootCache.freeze_shape _ _ _ valid.2.2.2.2.2 + +theorem frozenHeader_first (registry : Public) (past : History Q) (header : Header) + (absent : (replay registry past).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = none) : + frozenHeader registry past header = + PCSBCSMerkleRootCache.freeze (ordinaryPrefix past) header.root (rootShape header) := by + simp [frozenHeader,beforeHeader,PCSBCSMerkleRootCache.register,absent,replay_log] + +theorem frozenHeader_repeated (registry : Public) (past : History Q) (header : Header) + (frozen : PCSBCSMerkleRootCache.Frozen) + (known : (replay registry past).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = some frozen) : + frozenHeader registry past header = frozen := by + simp [frozenHeader,beforeHeader,PCSBCSMerkleRootCache.register,known] + +/-- A raw header is registered before its own reply and retained at every +later completed event, regardless of ordinary replies or raw block indices. -/ +theorem first_raw_freezes (registry : Public) (past : History Q) + (raw : RawKey Q) (header : Header) (parsed : rawHeader registry raw = some header) + (answer : Digest32) (later : History Q) : + (replay registry (later ++ ((.inr raw,answer)::past))).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = + some (frozenHeader registry past header) := by + have first : (replay registry ((.inr raw,answer)::past)).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = + some (frozenHeader registry past header) := by + simpa only [replay,completed,parsed,beforeHeader] using frozenHeader_known registry past header + induction later with + | nil => exact first + | cons item later ih => + exact completed_preserves registry _ item.1 item.2 header _ ih + +abbrev Packet (registry : Public) (p : Profile) (Q : Nat) := + AnchoredSourceGroups.Packet registry p Q + +theorem recognized_raw_header (registry : Public) (p : Profile) (raw : RawKey Q) + (c : Sigma (fun _ : Packet registry p Q => Fin (blockCount (config p).logN))) + (recognized : recognize Q (config p).logN registry.iv + (AnchoredSourceGroups.accept registry p) (.inr raw) = some c) : + rawHeader registry raw = some (AnchoredSourceGroups.header registry p Q c.1) := by + have same := AnchoredByteStreamCausal.encode_recognize Q (config p).logN registry.iv + (AnchoredSourceGroups.accept registry p) raw c recognized + rw [← same] + exact AnchoredSourceGroups.packet_key_header registry p Q c.1 c.2 + +/-- All geometry/admission obligations here are decoded from the packet. +No before-point certificate, final-root policy, or source chronology is a premise. -/ +theorem packet_guards (registry : Public) (p : Profile) (packet : Packet registry p Q) : + let h := AnchoredSourceGroups.header registry p Q packet + registry.shapes h.statement = some h.shape ∧ h.shape.Valid ∧ + h.shape.logN = (config p).logN ∧ h.shape.logBatch = (config p).folds[0]! ∧ + (∀ i : Fin (blockCount (config p).logN), + DuplexEncoding.Admissible (AnchoredByteStreamGroups.coordinate packet.val i)) ∧ + (∀ i : Fin (blockCount (config p).logN), + DuplexFraming.pathCost (AnchoredByteStreamGroups.coordinate packet.val i) ≤ Q) := by + have decoded := fromHistory_valid registry packet.val.history + (AnchoredSourceGroups.header registry p Q packet) + (AnchoredSourceGroups.header_parsed registry p Q packet) + have geometry := (AnchoredSourceGroups.packet_header registry p Q packet).choose_spec.2 + dsimp only + exact ⟨decoded.2.1 ▸ decoded.2.2.1,decoded.2.2.2,geometry.1,geometry.2, + packet.val.admissible,packet.val.bounded⟩ + +/-- The root is exactly the compact table of the immutable public prefix. +Absent images use the existing freeze representation, not a fabricated oracle. -/ +noncomputable def prepare (registry : Public) (p : Profile) (Q : Nat) + (past : History Q) (packet : Packet registry p Q) : + AnchoredFiatShamirSecurity.PreAnchor p := + let h := AnchoredSourceGroups.header registry p Q packet + let valid := (fromHistory_valid registry packet.val.history h + (AnchoredSourceGroups.header_parsed registry p Q packet)).2.2.2 + let bound : h.shape.lanes ≤ 2^(config p).folds[0]! := by + rw [← AnchoredSourceGroups.header_batch registry p Q packet] + exact valid.2.2.2.2.2 + ⟨h.shape.lanes,(frozenHeader registry past h).raw,⟨valid.2.2.2.2.1,bound⟩⟩ + +/-- The prepared table is literal frozen extraction, not an externally chosen +oracle or a root reconstructed from the point answer. -/ +theorem prepare_literal (registry : Public) (p : Profile) (Q : Nat) + (past : History Q) (packet : Packet registry p Q) : + (prepare registry p Q past packet).root = + (frozenHeader registry past (AnchoredSourceGroups.header registry p Q packet)).raw ∧ + (prepare registry p Q past packet).lanes = + (AnchoredSourceGroups.header registry p Q packet).shape.lanes := ⟨rfl,rfl⟩ + +noncomputable def policy (registry : Public) (p : Profile) (Q : Nat) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) : + Grouped.Policy p Q registry.iv (AnchoredSourceGroups.accept registry p) := + ⟨prepare registry p Q,advertise⟩ + +noncomputable def execution (registry : Public) (p : Profile) (Q : Nat) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) + (source : Sampling (Key Q) (fun _ => Digest32) R n) (table : Key Q → Digest32) := + Grouped.execution (policy registry p Q advertise) source table + +/-- Genuine mixed adaptive ambiguity, including repeated keys and arbitrary +ordinary replies. `n` is the aggregate mixed-draw cap, not n*point-block-count. -/ +theorem mixed_ambiguity (registry : Public) (p : Profile) (Q : Nat) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) + (source : Sampling (Key Q) (fun _ => Digest32) R n) : + Soundness.uniformProb (Finset.univ.filter fun table : Key Q → Digest32 => + AnchoredFiatShamirSecurity.Dirty (execution registry p Q advertise source table).1.2) ≤ + (n : ℚ)/2^124 := + Grouped.prepared_raw_table_ambiguity (policy registry p Q advertise) source + +theorem mixed_execution_result (registry : Public) (p : Profile) (Q : Nat) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) + (source : Sampling (Key Q) (fun _ => Digest32) R n) (table : Key Q → Digest32) : + (execution registry p Q advertise source table).1.1 = Sampling.eval table source := + Grouped.execution_result (policy registry p Q advertise) source table + +/-- The existing whole source lowering is preserved as an entire public View, +not merely an opening tape or a restricted observer projection. -/ +theorem source_observations_exact (registry : Public) (p : Profile) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey Q → Digest32) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) : + (execution registry p Q advertise + (PublicCompressionCouplingMixed.compile Q registry.iv [] program remaining cap counted) + (PublicCompressionCouplingMixed.oracle seed ro)).1.1 = + (runIdeal (DuplexPublicSimulator.simulator Q) ro registry.iv ⟨seed,[]⟩ + program remaining cap counted).view := by + rw [mixed_execution_result,PublicCompressionCouplingMixed.compile_actual] + +/-- Counts charges each complete construction path as well as each ordinary +query. Ideal raw lookup counts are not substituted for that aggregate work. -/ +theorem source_aggregate_ambiguity (registry : Public) (p : Profile) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) : + Soundness.uniformProb (Finset.univ.filter fun table : Key Q → Digest32 => + AnchoredFiatShamirSecurity.Dirty (execution registry p Q advertise + (PublicCompressionCouplingMixed.compile Q registry.iv [] program remaining cap counted) + table).1.2) ≤ (remaining : ℚ)/2^124 := + mixed_ambiguity registry p Q advertise _ + +def primitiveRequests (observations : List Observation) : Nat := + (observations.map fun o => match o.query with + | .primitive _ _ => 1 | .construction _ _ => 0).sum + +def constructionRequests (observations : List Observation) : Nat := + (observations.map fun o => match o.query with + | .primitive _ _ => 0 | .construction _ _ => 1).sum + +def constructionWork (observations : List Observation) : Nat := + (observations.map fun o => match o.query with + | .primitive _ _ => 0 + | .construction coordinate _ => DuplexFraming.pathCost coordinate).sum + +theorem work_decomposition (observations : List Observation) : + primitiveRequests observations + constructionWork observations = + (observations.map (fun o => o.query.cost)).sum := by + induction observations with + | nil => rfl + | cons observation observations ih => + cases query : observation.query <;> + simp_all [primitiveRequests,constructionWork,Query.cost] <;> omega + +theorem constructionRequests_le_work (observations : List Observation) : + constructionRequests observations ≤ constructionWork observations := by + induction observations with + | nil => rfl + | cons observation observations ih => + cases query : observation.query with + | primitive purpose input => + simpa [constructionRequests,constructionWork,query] using ih + | construction coordinate valid => + have positive := DuplexRawProgram.pathCost_pos coordinate + simp only [constructionRequests,constructionWork,List.map_cons,List.sum_cons,query] at * + omega + +theorem source_work_budget (registry : Public) (p : Profile) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey Q → Digest32) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) : + let observations := (execution registry p Q advertise + (PublicCompressionCouplingMixed.compile Q registry.iv [] program remaining cap counted) + (PublicCompressionCouplingMixed.oracle seed ro)).1.1.observations + constructionRequests observations ≤ constructionWork observations ∧ + primitiveRequests observations + constructionWork observations ≤ remaining := by + dsimp only + rw [source_observations_exact] + refine ⟨constructionRequests_le_work _,?_⟩ + rw [work_decomposition] + exact PublicCompressionCouplingMixed.runIdeal_viewCost Q seed ro registry.iv [] + program remaining cap counted + +/-- The three budgets are not equated: allocations ≤ completed raw draw +requests ≤ aggregate cap. Source path work is accounted separately above. -/ +theorem mixed_allocation_budget (registry : Public) (p : Profile) (Q : Nat) + (advertise : History Q → Packet registry p Q → Joint (config p).logN → E) + (source : Sampling (Key Q) (fun _ => Digest32) R n) (table : Key Q → Digest32) : + Grouped.allocations (execution registry p Q advertise source table).1.2 ≤ + Grouped.rawRequests table source ∧ Grouped.rawRequests table source ≤ n := + Grouped.allocation_budget (policy registry p Q advertise) source table + +#print axioms Grouped.repeated_original +#print axioms Grouped.repeated_allocation +#print axioms first_raw_freezes +#print axioms packet_guards +#print axioms frozenHeader_provenance +#print axioms frozenHeader_geometry +#print axioms prepare_literal +#print axioms mixed_ambiguity +#print axioms mixed_execution_result +#print axioms Grouped.prepared_full_distribution +#print axioms source_observations_exact +#print axioms source_aggregate_ambiguity +#print axioms source_work_budget +#print axioms mixed_allocation_budget + +end Whir.AnchoredMixedAttackerPrefix diff --git a/verification/whir/Whir/AnchoredMixedAttackerPrefixObserver.lean b/verification/whir/Whir/AnchoredMixedAttackerPrefixObserver.lean new file mode 100644 index 000000000..b54dc2c52 --- /dev/null +++ b/verification/whir/Whir/AnchoredMixedAttackerPrefixObserver.lean @@ -0,0 +1,84 @@ +import Whir.AnchoredMixedAttackerPrefixSource +import Whir.PCSBCSNativePhysicalMerkleBad + +/-! Historical pre-#607 anchored source prefixes use the SAME complete physical +Merkle alarm as the public source observer. This join derives the ordinary +collision guard, rather than charging a second event or assuming clean caches. +It does not claim a current Rust-to-Lean or #607 transcript correspondence. -/ +set_option autoImplicit false +namespace Whir.AnchoredMixedAttackerPrefixObserver +open Concrete FiatShamirGame DuplexModeGame TypedOracleCompiler +open PublicCompressionProgram PublicMerkleLog +open AnchoredHeaderRoots AnchoredMixedAttackerPrefix AnchoredMixedAttackerPrefixSource + +/-- Every literal ordinary observation, including cache hits, belongs to the +actual complete primitive trace under the real construction table. -/ +theorem ordinary_subset {Q : Nat} {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) : + let view := Sampling.eval + (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable Q C)) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted) + ∀ record ∈ PCSBCSMerkleSeedProjection.ordinaryObservations view.observations, + record ∈ primitiveLog C iv program remaining counted := by + intro view record member + obtain ⟨observation,present,parsed⟩ := List.mem_filterMap.mp member + rcases observation with ⟨query,answer⟩ + cases query with + | construction coordinate valid => simp at parsed + | primitive purpose input => + by_cases ordinary : DuplexFraming.tag input = 0 + · simp only [ordinary,↓reduceIte,Option.some.injEq] at parsed + subst record + have actual : view = (runReal C iv program).view := by + dsimp only [view] + rw [PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C iv _ ⟨rfl,by simp⟩ _ _ cap _ + rw [actual] at present + have included := PCSBCSConstructionReplayTrace.observation_trace_membership + C iv program remaining counted _ present + have authentic := PCSBCSConstructionReplayTrace.observation_answer C iv program _ present + change answer = C input at authentic + apply included (input,answer) + exact List.mem_singleton.mpr (Prod.ext rfl authentic) + · simp [ordinary] at parsed + +/-- The anchored cache guard is already paid by the complete physical alarm. -/ +theorem ordinary_quiet_of_alarm {Q : Nat} {R : Type} (C : PrimitiveOracle) + (iv : Digest32) (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) (roots : PublicMerkleProbability.RootPolicy) + (quiet : PublicMerkleProbability.traceAlarm roots [] + (primitiveLog C iv program remaining counted) = false) : + ¬ OutputCollision (PCSBCSMerkleSeedProjection.ordinaryObservations + (Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable Q C)) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)).observations) := by + intro bad + have collision := PublicMerkleProbability.collision_mono + (ordinary_subset C iv program remaining cap counted) bad + have clean := PublicMerkleProbability.traceAlarm_clean C roots [] _ + (by intro n d h; cases h) (primitiveLog_authentic C iv program remaining counted) + (by rintro ⟨a,b,d,h,_⟩; cases h) quiet + apply clean + apply PublicMerkleProbability.collision_mono _ collision + exact fun _ member => List.mem_append_left _ (List.mem_reverse.mpr member) + +/-- All attacker and verifier source prefixes, not just the final prefix, have +actual frozen root tables outside that SAME complete physical event. -/ +theorem source_prefixes_of_alarm {Q : Nat} {R : Type} (registry : Public) + (C : PrimitiveOracle) (program : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining program) + (roots : PublicMerkleProbability.RootPolicy) + (quiet : PublicMerkleProbability.traceAlarm roots [] + (primitiveLog C registry.iv program remaining counted) = false) : + let full := PCSBCSMerkleSeedProjection.ordinaryObservations + (Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable Q C)) + (PublicCompressionCouplingMixed.compile Q registry.iv [] program remaining cap counted)).observations + SourcePrefixes registry C (WHIRRealSimulator.rawTable Q C) full [] [] + program remaining cap counted := by + exact initial_source_prefixes registry C (WHIRRealSimulator.rawTable Q C) program remaining + cap counted (ordinary_quiet_of_alarm C registry.iv program remaining cap counted roots quiet) + +#print axioms ordinary_subset +#print axioms ordinary_quiet_of_alarm +#print axioms source_prefixes_of_alarm +end Whir.AnchoredMixedAttackerPrefixObserver diff --git a/verification/whir/Whir/AnchoredMixedAttackerPrefixSource.lean b/verification/whir/Whir/AnchoredMixedAttackerPrefixSource.lean new file mode 100644 index 000000000..c6b8b4750 --- /dev/null +++ b/verification/whir/Whir/AnchoredMixedAttackerPrefixSource.lean @@ -0,0 +1,397 @@ +import Whir.AnchoredMixedAttackerPrefix + +/-! Quiet source join for the unchanged PublicCompressionCouplingMixed.compile. +Cache-hit ordinary observations need not be draws. Their omission preserves +set membership, not literal log order. Outside OutputCollision in the SAME +complete actual ordinary trace, digest-selected preimages and freeze.raw are +extensional in this membership set. All cache/prefix invariants below are +derived from the actual simulator lowering; no frozenRootEq is a premise. +Construction answers never supply ordinary compression records. -/ +namespace Whir.AnchoredMixedAttackerPrefixSource +open Concrete FiatShamirGame DuplexModeGame TypedOracleCompiler +open AnchoredMixedAttackerPrefix AnchoredHeaderRoots +open PublicMerkleLog MerkleTransport.Commitments MerkleQueryLogExtraction + +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +/-- Literal zero-role compression records only; no construction output key +is admitted merely because it appears in a public observation. -/ +def ordinaryLog (log : DuplexPublicSimulator.PublicLog) : PublicMerkleLog.PublicLog := + log.filter (fun e => DuplexFraming.tag e.1 = 0) + +theorem ordinaryLog_authentic (seed : PrimitiveOracle) (log : DuplexPublicSimulator.PublicLog) + (auth : PCSBCSMerkleSeedProjection.OrdinaryAuthentic seed log) : + AuthenticLog seed (ordinaryLog log) := by + intro n d member + obtain ⟨present,ordinary⟩ := List.mem_filter.mp member + exact auth n d present (by simpa using ordinary) + +theorem quiet_mono (left right : PublicLog) (included : ∀ e ∈ left, e ∈ right) + (quiet : ¬ OutputCollision right) : ¬ OutputCollision left := by + rintro ⟨a,b,d,ha,hb,different⟩ + exact quiet ⟨a,b,d,included _ ha,included _ hb,different⟩ + +/-- This internal extensionality lemma makes its collision guard explicit. +The public source theorem below derives both authenticity and membership. -/ +theorem quiet_index (seed : PrimitiveOracle) (left right : PublicLog) + (leftAuth : AuthenticLog seed left) (rightAuth : AuthenticLog seed right) + (same : ∀ e, e ∈ left ↔ e ∈ right) (quiet : ¬ OutputCollision right) (d : Digest32) : + (build (records left))[key d]? = (build (records right))[key d]? := by + have leftQuiet := quiet_mono left right (fun e member => (same e).mp member) quiet + have lr := PublicMerkleBinding.records_persist seed left right leftAuth rightAuth + (fun e member => (same e).mp member) quiet + have rl := PublicMerkleBinding.records_persist seed right left rightAuth leftAuth + (fun e member => (same e).mpr member) leftQuiet + have leftUnique := fun bad => leftQuiet (PublicMerkleBinding.reconstructed_collision seed left leftAuth bad) + have rightUnique := fun bad => quiet (PublicMerkleBinding.reconstructed_collision seed right rightAuth bad) + cases l : (build (records left))[key d]? with + | some bytes => + have member := lr _ (build_mem l) + exact (selected_unique (PublicMerkleLog.hash seed) (records right) + (records_authentic seed right rightAuth) rightUnique member).symm + | none => + cases r : (build (records right))[key d]? with + | none => rfl + | some bytes => + have member := rl _ (build_mem r) + have found := selected_unique (PublicMerkleLog.hash seed) (records left) + (records_authentic seed left leftAuth) leftUnique member + rw [l] at found + contradiction + +theorem extract_lookup_ext (codec : Codec) (left right : Index) + (same : ∀ d, left[key d]? = right[key d]?) (height : Nat) (root : Digest32) : + extract codec left height root = extract codec right height root := by + induction height generalizing root with + | zero => simp only [extract,same] + | succ height ih => simp only [extract,same,ih] + +theorem quiet_freeze_raw (seed : PrimitiveOracle) (left right : PublicLog) + (leftAuth : AuthenticLog seed left) (rightAuth : AuthenticLog seed right) + (same : ∀ e, e ∈ left ↔ e ∈ right) (quiet : ¬ OutputCollision right) + (root : Digest32) (shape : PCSBCSMerkleRootCache.Shape) : + (PCSBCSMerkleRootCache.freeze left root shape).raw = + (PCSBCSMerkleRootCache.freeze right root shape).raw := by + have tree := extract_lookup_ext canonicalCodec (build (records left)) (build (records right)) + (quiet_index seed left right leftAuth rightAuth same quiet) shape.height root + have cells : PCSBCSMerkleLeafImages.sourceCells left root shape.height shape.leafWords shape.occupied = + PCSBCSMerkleLeafImages.sourceCells right root shape.height shape.leafWords shape.occupied := by + simp only [PCSBCSMerkleLeafImages.sourceCells,PCSBCSMerkleLeafImages.extractCells_eq_emit] + rw [tree] + change PCSBCSMerkleLeafImages.compactTable + (PCSBCSMerkleLeafImages.sourceCells left root shape.height shape.leafWords shape.occupied) = + PCSBCSMerkleLeafImages.compactTable + (PCSBCSMerkleLeafImages.sourceCells right root shape.height shape.leafWords shape.occupied) + rw [cells] + +structure PrefixInvariant (seed : PrimitiveOracle) + (log : DuplexPublicSimulator.PublicLog) (past : AnchoredMixedAttackerPrefix.History Q) : Prop where + ordinary : PCSBCSMerkleSeedProjection.OrdinaryAuthentic seed log + authentic : AuthenticLog seed (ordinaryPrefix past) + members : ∀ e, e ∈ ordinaryPrefix past ↔ e ∈ ordinaryLog log + +theorem ordinary_lookup_consistent (seed : PrimitiveOracle) + (log : DuplexPublicSimulator.PublicLog) (past : AnchoredMixedAttackerPrefix.History Q) + (invariant : PrefixInvariant seed log past) (input : DuplexFraming.Node) + (ordinary : DuplexFraming.tag input = 0) : + PublicMerkleLog.lookup (ordinaryPrefix past) input = DuplexPublicSimulator.lookup log input := by + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => + have present := DuplexPublicSimulator.lookup_mem hit + have member := (invariant.members (input,answer)).mpr + (List.mem_filter.mpr ⟨present,by simpa using ordinary⟩) + have correct := invariant.ordinary input answer present ordinary + simpa [correct] using PublicMerkleLog.lookup_authentic_member seed _ invariant.authentic member + | none => + cases old : PublicMerkleLog.lookup (ordinaryPrefix past) input with + | none => rfl + | some answer => + have present := (List.mem_filter.mp + ((invariant.members _).mp (PublicMerkleLog.lookup_mem old))).1 + obtain ⟨answer,found⟩ := DuplexPublicSimulator.lookup_exists present + rw [hit] at found + contradiction + +def traceHistory (past : AnchoredMixedAttackerPrefix.History Q) + (events : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key Q => Digest32))) := + events.foldl (fun prior e => (e.1,e.2)::prior) past + +theorem traceHistory_append (past : AnchoredMixedAttackerPrefix.History Q) + (left right : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key Q => Digest32))) : + traceHistory past (left++right) = traceHistory (traceHistory past left) right := by + simp only [traceHistory,List.foldl_append] + +theorem traceHistory_cons (past : AnchoredMixedAttackerPrefix.History Q) + (event : Sigma (fun _ : PublicCompressionCouplingMixed.Key Q => Digest32)) (events) : + traceHistory past (event::events) = traceHistory ((event.1,event.2)::past) events := rfl + +theorem execute_map_trace (table : PublicCompressionCouplingMixed.Key Q → Digest32) + (f : R → S) (source : PublicCompressionCouplingMixed.Computation Q R n) : + (Sampling.execute table (PublicCompressionCouplingMixed.Computation.map f source)).2 = + (Sampling.execute table source).2 := by + induction source with + | ret result => rfl + | draw key next ih => simp only [PublicCompressionCouplingMixed.Computation.map,Sampling.execute,ih] + +/-- Operational reference only: these are exactly the already completed draws +of primitiveCalls. Neither the attacker nor preparation receives the seed. -/ +def primitiveHistory (Q : Nat) (seed : DuplexPublicSimulator.Seed) (ro : RawKey Q → Digest32) + (log : DuplexPublicSimulator.PublicLog) (past : AnchoredMixedAttackerPrefix.History Q) + (input : DuplexFraming.Node) : AnchoredMixedAttackerPrefix.History Q := + match DuplexPublicSimulator.lookup log input with + | some _ => past + | none => match DuplexPublicSimulator.privateKey Q log input with + | some raw => (.inr raw,ro raw)::past + | none => (.inl input,seed input)::past + +theorem primitiveHistory_actual (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) + (past : AnchoredMixedAttackerPrefix.History Q) (input : DuplexFraming.Node) : + primitiveHistory Q seed ro log past input = traceHistory past + (Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input)).2 := by + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => simp [primitiveHistory,PublicCompressionCouplingMixed.primitiveCalls,hit, + Sampling.execute,traceHistory] + | none => + cases key : DuplexPublicSimulator.privateKey Q log input <;> + simp [primitiveHistory,PublicCompressionCouplingMixed.primitiveCalls,hit,key, + Sampling.execute,traceHistory,PublicCompressionCouplingMixed.oracle] + +theorem primitive_log (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) + (input : DuplexFraming.Node) : + let reply := Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) + reply.1 = DuplexPublicSimulator.observe log input reply.2 := by + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => simp [PublicCompressionCouplingMixed.primitiveCalls,hit,Sampling.eval] + | none => + cases key : DuplexPublicSimulator.privateKey Q log input <;> + simp [PublicCompressionCouplingMixed.primitiveCalls,hit,key,Sampling.eval] + +/-- Exact accumulated raw/primitive draw history of the unchanged lowering. +This reference evaluator is not an attacker or preparation argument. -/ +def finishHistory (Q : Nat) (iv : Digest32) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) + (past : AnchoredMixedAttackerPrefix.History Q) : + (program : Program R) → (remaining : Nat) → remaining ≤ Q → Counts remaining program → + AnchoredMixedAttackerPrefix.History Q + | .done _, _, _, _ => past + | .ask (.primitive _ input) next, remaining, cap, counted => + let reply := Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) + finishHistory Q iv seed ro reply.1 (primitiveHistory Q seed ro log past input) + (next reply.2) (remaining-1) (by omega) (counted.2 _) + | .ask (.construction coordinate _) next, remaining, cap, counted => + let raw := constructionKey Q iv coordinate (counted.1.trans cap) + finishHistory Q iv seed ro log ((.inr raw,ro raw)::past) + (next (ro raw)) (remaining-DuplexFraming.pathCost coordinate) (by omega) (counted.2 _) + +theorem finishHistory_actual (Q : Nat) (iv : Digest32) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) + (past : AnchoredMixedAttackerPrefix.History Q) (program : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + finishHistory Q iv seed ro log past program remaining cap counted = + traceHistory past (Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q iv log program remaining cap counted)).2 := by + induction program generalizing log past remaining with + | done => rfl + | ask query next ih => + cases query with + | primitive purpose input => + simp only [finishHistory,PublicCompressionCouplingMixed.compile,Sampling.execute_pad, + Sampling.execute_bind,execute_map_trace,traceHistory_append] + rw [← primitiveHistory_actual] + exact ih _ _ _ _ _ _ + | construction coordinate valid => + simp only [finishHistory,PublicCompressionCouplingMixed.compile,Sampling.execute_pad, + Sampling.execute,execute_map_trace,PublicCompressionCouplingMixed.oracle,traceHistory_cons] + exact ih _ _ _ _ _ _ + +theorem initial_invariant (seed : PrimitiveOracle) : + PrefixInvariant seed [] ([] : AnchoredMixedAttackerPrefix.History Q) := by + constructor <;> simp [PCSBCSMerkleSeedProjection.OrdinaryAuthentic,AuthenticLog, + ordinaryPrefix,ordinaryLog] + +theorem primitive_invariant (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) + (past : AnchoredMixedAttackerPrefix.History Q) (input : DuplexFraming.Node) + (invariant : PrefixInvariant seed log past) : + PrefixInvariant seed + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input)).1 + (primitiveHistory Q seed ro log past input) := by + refine ⟨(PCSBCSMerkleSeedProjection.primitiveCalls_preserves Q seed ro log invariant.ordinary input).1,?_,?_⟩ + · cases hit : DuplexPublicSimulator.lookup log input with + | some answer => simpa [primitiveHistory,hit] using invariant.authentic + | none => + cases key : DuplexPublicSimulator.privateKey Q log input with + | some raw => simpa [primitiveHistory,hit,key] using invariant.authentic + | none => + intro n d member + simp only [primitiveHistory,hit,key,ordinaryPrefix,List.filterMap_cons] at member + by_cases ordinary : DuplexFraming.tag input = 0 + · simp only [ordinary,↓reduceIte,List.mem_cons,Prod.mk.injEq] at member + rcases member with ⟨rfl,rfl⟩ | prior + · rfl + · exact invariant.authentic n d prior + · simp only [ordinary,↓reduceIte] at member + exact invariant.authentic n d member + · intro e + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => + have present := DuplexPublicSimulator.lookup_mem hit + by_cases ordinary : DuplexFraming.tag input = 0 + · have old : (input,answer) ∈ ordinaryPrefix past := + (invariant.members _).mpr (List.mem_filter.mpr ⟨present,by simpa using ordinary⟩) + have members : e ∈ ordinaryPrefix past ↔ e ∈ log ∧ DuplexFraming.tag e.1 = 0 := by + simpa [ordinaryLog] using invariant.members e + simp [primitiveHistory,hit,PublicCompressionCouplingMixed.primitiveCalls,Sampling.eval, + ordinaryLog,DuplexPublicSimulator.observe,ordinary] + exact ⟨fun member => Or.inr (members.mp member), + fun member => member.elim (fun same => by simpa [same] using old) members.mpr⟩ + · simpa [primitiveHistory,hit,PublicCompressionCouplingMixed.primitiveCalls,Sampling.eval, + ordinaryLog,DuplexPublicSimulator.observe,ordinary] using invariant.members e + | none => + by_cases ordinary : DuplexFraming.tag input = 0 + · have key := PCSBCSMixedOrdinaryMerkle.ordinary_privateKey_none Q log input ordinary + simpa [primitiveHistory,hit,key,PublicCompressionCouplingMixed.primitiveCalls,Sampling.eval, + PublicCompressionCouplingMixed.oracle,ordinaryPrefix,ordinaryLog, + DuplexPublicSimulator.observe,ordinary] using or_congr Iff.rfl (invariant.members e) + · cases key : DuplexPublicSimulator.privateKey Q log input <;> + simpa [primitiveHistory,hit,key,PublicCompressionCouplingMixed.primitiveCalls,Sampling.eval, + PublicCompressionCouplingMixed.oracle,ordinaryPrefix,ordinaryLog, + DuplexPublicSimulator.observe,ordinary] using invariant.members e + +theorem raw_invariant (seed : PrimitiveOracle) (log : DuplexPublicSimulator.PublicLog) + (past : AnchoredMixedAttackerPrefix.History Q) (raw : RawKey Q) (answer : Digest32) + (invariant : PrefixInvariant seed log past) : + PrefixInvariant seed log ((.inr raw,answer)::past) := by + exact ⟨invariant.ordinary,by simpa using invariant.authentic, + fun e => by simpa using invariant.members e⟩ + +/-- At first registration, the quiet full ordinary observation log and the +strict completed-draw log produce identical root tables. Authenticity and +set matching are fields of the DERIVED cache invariant, not caller promises. -/ +theorem first_freeze_full_log (registry : Public) (seed : PrimitiveOracle) + (log : DuplexPublicSimulator.PublicLog) (past : AnchoredMixedAttackerPrefix.History Q) + (invariant : PrefixInvariant seed log past) (full : PublicLog) + (included : ∀ e ∈ ordinaryLog log, e ∈ full) (quiet : ¬ OutputCollision full) + (header : Header) (absent : (replay registry past).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = none) : + (frozenHeader registry past header).raw = + (PCSBCSMerkleRootCache.freeze (ordinaryLog log) header.root (rootShape header)).raw := by + rw [frozenHeader_first registry past header absent] + exact quiet_freeze_raw seed _ _ invariant.authentic (ordinaryLog_authentic seed log invariant.ordinary) + invariant.members (quiet_mono _ full included quiet) _ _ + +/-- This is an operational prequery invariant for the ACTUAL source lowering. +At constructions the raw key is the literal constructionKey, and preparation +is checked before recurring on the answer; no before-point certificate occurs +among the hypotheses of initial_source_prefixes below. -/ +def SourcePrefixes (registry : Public) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (full : PublicLog) + (log : DuplexPublicSimulator.PublicLog) (past : AnchoredMixedAttackerPrefix.History Q) : + (program : Program R) → (remaining : Nat) → remaining ≤ Q → Counts remaining program → Prop + | .done _, _, _, _ => PrefixInvariant seed log past + | .ask (.primitive _ input) next, remaining, cap, counted => + PrefixInvariant seed log past ∧ + (∀ header, (replay registry past).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = none → + (frozenHeader registry past header).raw = + (PCSBCSMerkleRootCache.freeze (ordinaryLog log) header.root (rootShape header)).raw) ∧ + let reply := Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) + SourcePrefixes registry seed ro full reply.1 (primitiveHistory Q seed ro log past input) + (next reply.2) (remaining-1) (by omega) (counted.2 _) + | .ask (.construction coordinate _) next, remaining, cap, counted => + PrefixInvariant seed log past ∧ + (∀ header, (replay registry past).roots[ + PCSBCSMerkleRootCache.cacheKey header.root (rootShape header)]? = none → + (frozenHeader registry past header).raw = + (PCSBCSMerkleRootCache.freeze (ordinaryLog log) header.root (rootShape header)).raw) ∧ + let raw := constructionKey Q registry.iv coordinate (counted.1.trans cap) + SourcePrefixes registry seed ro full log ((.inr raw,ro raw)::past) + (next (ro raw)) (remaining-DuplexFraming.pathCost coordinate) (by omega) (counted.2 _) + +theorem ordinaryObservations_tail (observation : Observation) (seen : List Observation) : + ∀ e ∈ PCSBCSMerkleSeedProjection.ordinaryObservations seen, + e ∈ PCSBCSMerkleSeedProjection.ordinaryObservations (observation::seen) := by + intro e member + obtain ⟨o,present,parsed⟩ := List.mem_filterMap.mp member + exact List.mem_filterMap.mpr ⟨o,List.mem_cons_of_mem _ present,parsed⟩ + +theorem source_prefixes (registry : Public) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (full : PublicLog) + (log : DuplexPublicSimulator.PublicLog) (past : AnchoredMixedAttackerPrefix.History Q) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) (invariant : PrefixInvariant seed log past) + (included : ∀ e ∈ ordinaryLog log, e ∈ full) + (future : ∀ e ∈ PCSBCSMerkleSeedProjection.ordinaryObservations + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q registry.iv log program remaining cap counted)).observations, + e ∈ full) (quiet : ¬ OutputCollision full) : + SourcePrefixes registry seed ro full log past program remaining cap counted := by + induction program generalizing log past remaining with + | done => exact invariant + | ask query next ih => + have freeze := fun header absent => + first_freeze_full_log registry seed log past invariant full included quiet header absent + cases query with + | primitive purpose input => + refine ⟨invariant,freeze,?_⟩ + let reply := Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) + have after := primitive_invariant Q seed ro log past input invariant + simp only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe] at future + apply ih reply.2 reply.1 (primitiveHistory Q seed ro log past input) + (remaining-1) (by omega) (counted.2 _) after + · intro e member + obtain ⟨present,ordinary⟩ := List.mem_filter.mp member + rw [primitive_log Q seed ro log input] at present + rcases List.mem_cons.mp present with same | prior + · subst e + apply future + have ordinaryTag : DuplexFraming.tag input = 0 := by simpa using ordinary + simp [PCSBCSMerkleSeedProjection.ordinaryObservations,ordinaryTag] + · exact included e (List.mem_filter.mpr ⟨prior,ordinary⟩) + · intro e member + exact future e (ordinaryObservations_tail _ _ e member) + | construction coordinate valid => + refine ⟨invariant,freeze,?_⟩ + simp only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval, + PublicCompressionCouplingMixed.oracle,PublicCompressionCouplingMixed.Computation.eval_map, + DuplexRawProgram.observe] at future + apply ih _ log _ _ _ _ (raw_invariant seed log past _ _ invariant) included + intro e member + exact future e (ordinaryObservations_tail _ _ e member) + +/-- SAME complete source trace, with no extra source/header policy hypothesis. +The only guard is the existing paid ordinary output-collision alarm being quiet. +Every first root table equals extraction from its actual earlier full ordinary +observation prefix, including cache hits, BEFORE its current point reply. -/ +theorem initial_source_prefixes (registry : Public) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (program : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining program) : + let full := PCSBCSMerkleSeedProjection.ordinaryObservations + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q registry.iv [] program remaining cap counted)).observations + ¬ OutputCollision full → + SourcePrefixes registry seed ro full [] [] program remaining cap counted := by + intro full quiet + exact source_prefixes registry seed ro full [] [] program remaining cap counted + (initial_invariant seed) (by simp [ordinaryLog]) (fun _ member => member) quiet + +#print axioms quiet_index +#print axioms quiet_freeze_raw +#print axioms primitiveHistory_actual +#print axioms primitive_invariant +#print axioms ordinary_lookup_consistent +#print axioms finishHistory_actual +#print axioms first_freeze_full_log +#print axioms source_prefixes +#print axioms initial_source_prefixes + +end Whir.AnchoredMixedAttackerPrefixSource diff --git a/verification/whir/Whir/AnchoredMixedIdealSourceAcceptance.lean b/verification/whir/Whir/AnchoredMixedIdealSourceAcceptance.lean new file mode 100644 index 000000000..dd1197de9 --- /dev/null +++ b/verification/whir/Whir/AnchoredMixedIdealSourceAcceptance.lean @@ -0,0 +1,143 @@ +import Whir.AnchoredIdealPhysicalAcceptance + +/-! Actual mixed execution of the historical pre-#607 native source driver. +Source erasure and ordinary primitive consistency are derived from execution; +neither is an endpoint premise. Independent raw construction answers are left +untouched. The physical first-frozen registry invariant and preparedness are +explicit remaining causal hypotheses, not an identified PCS capture. -/ +set_option autoImplicit false +namespace Whir.AnchoredMixedIdealSourceAcceptance +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open WHIRSourceChronology AnchoredPhysicalDriver PublicMerkleProgram WHIRPhysicalVerifier +open AnchoredPhysicalKnowledgeAcceptance (original) +open MerkleTransport + +section Driver +variable (cap : Nat) (boundary : Boundary) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (record : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (iv : Digest32) + (B : Nat) (limit : sourceBudget ctx Q packet ≤ B) + +/-- The literal actual mixed compiler, at the driver's proved source budget. +B is the shared primitive/RO cap, not the historical packet ancestry cap Q. -/ +def mixedView (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) : + View (WHIRSourceChronology.Result cap (Option (Accepted ctx Q cap packet record))) := + Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] + (WHIRSourceChronology.compile + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + (sourceBudget ctx Q packet) limit + ((WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap boundary model ctx stack Q packet record proofs))) + +/-- Both operational joins come from the actual execution. In particular, the +source event trace equals the observed trace even for rejecting continuations. -/ +theorem mixedView_runs (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) : + let view := mixedView cap boundary model ctx stack Q packet record proofs iv B limit seed ro + Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + view.observations view.result.value ∧ + WHIRSourceChronology.observations view.result.events = view.observations ∧ + AnchoredIdealPhysicalAcceptance.PrimitiveConsistent seed view.observations := by + dsimp only + let program := WHIRSourceChronology.compile + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs) + have counted : DuplexModeGame.Counts (sourceBudget ctx Q packet) program := + (WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap boundary model ctx stack Q packet record proofs) + have compiledRun : Runs program + (mixedView cap boundary model ctx stack Q packet record proofs iv B limit seed ro).observations + (mixedView cap boundary model ctx stack Q packet record proofs iv B limit seed ro).result := by + simp only [mixedView,PublicCompressionCouplingMixed.compile_actual] + exact runIdeal_runs (DuplexPublicSimulator.simulator B) ro iv ⟨seed,[]⟩ program + (sourceBudget ctx Q packet) limit counted + obtain ⟨erased,observed⟩ := WHIRPhysicalCaller.compile_run + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs) _ _ compiledRun + refine ⟨erased,observed,?_⟩ + have authentic := PCSBCSMixedOrdinaryMerkle.runIdeal_initial_answers B seed ro iv program + (sourceBudget ctx Q packet) limit counted + simpa only [AnchoredIdealPhysicalAcceptance.PrimitiveConsistent,mixedView, + PublicCompressionCouplingMixed.compile_actual,DuplexPublicSimulator.simulator,program] using authentic + +/-- An actual successful mixed source run gives the native ideal acceptance +adapter its erased Runs and primitive-only answer facts. The only acceptance +premise is the actual driver's returned value, not native verification. -/ +theorem mixed_success_prepared_experiment (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (a : Accepted ctx Q cap packet record) + (accepted : (mixedView cap boundary model ctx stack Q packet record proofs iv B limit seed ro).result.value = some a) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant seed state) + (initial : ∃ snap, MerkleTransport.Commitments.lookup record.root state.registry = some snap) + (registered : CausalBindingState.Prepared state packet.val.profile + ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad seed oldLog opening.root opening.result.paths) : + ∃ prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.count a.request.claims.family a.request.claims.points record.point.toArray record.value, + ∃ (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + OriginalClaimsChecker.prepare (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.family a.request.claims.points record.point.toArray record.value = some prepared ∧ + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) ∧ + replay.original = original a state ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof ∧ + (let claims := (OriginalClaimsChecker.input prepared (original a state).root replay.initial.1).claims + let claim := CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) claims a.wire.tape.1 + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (original a state).root) claim.weight claim.value proof = .ok ()) ∧ + CausalGame.experiment (OriginalClaimsChecker.input prepared (original a state).root replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨run,_,answers⟩ := mixedView_runs cap boundary model ctx stack Q packet record proofs iv B limit seed ro + rw [accepted] at run + exact AnchoredIdealPhysicalAcceptance.verifySource_prepared_experiment + cap boundary model ctx stack Q packet record proofs + (mixedView cap boundary model ctx stack Q packet record proofs iv B limit seed ro).observations + a run seed iv answers state invariant initial registered quiet + +/-- The same join stated on actual runIdeal, rather than only its exactly equal +mixed lowering. All construction replies still come from the independent RO. -/ +theorem runIdeal_success_prepared_experiment (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (a : Accepted ctx Q cap packet record) + (accepted : (runIdeal (DuplexPublicSimulator.simulator B) ro iv + ((DuplexPublicSimulator.simulator B).initial seed) + (WHIRSourceChronology.compile + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + (sourceBudget ctx Q packet) limit + ((WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap boundary model ctx stack Q packet record proofs))).view.result.value = some a) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant seed state) + (initial : ∃ snap, MerkleTransport.Commitments.lookup record.root state.registry = some snap) + (registered : CausalBindingState.Prepared state packet.val.profile + ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad seed oldLog opening.root opening.result.paths) : + ∃ prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.count a.request.claims.family a.request.claims.points record.point.toArray record.value, + ∃ (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + OriginalClaimsChecker.prepare (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.family a.request.claims.points record.point.toArray record.value = some prepared ∧ + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) ∧ + replay.original = original a state ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof ∧ + (let claims := (OriginalClaimsChecker.input prepared (original a state).root replay.initial.1).claims + let claim := CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) claims a.wire.tape.1 + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (original a state).root) claim.weight claim.value proof = .ok ()) ∧ + CausalGame.experiment (OriginalClaimsChecker.input prepared (original a state).root replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + apply mixed_success_prepared_experiment cap boundary model ctx stack Q packet record proofs iv B limit + seed ro a _ state invariant initial registered quiet + simpa only [mixedView,PublicCompressionCouplingMixed.compile_actual,DuplexPublicSimulator.simulator] using accepted + +end Driver +#print axioms mixedView_runs +#print axioms mixed_success_prepared_experiment +#print axioms runIdeal_success_prepared_experiment +end Whir.AnchoredMixedIdealSourceAcceptance diff --git a/verification/whir/Whir/AnchoredPhysicalAfter.lean b/verification/whir/Whir/AnchoredPhysicalAfter.lean new file mode 100644 index 000000000..de2bbbede --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalAfter.lean @@ -0,0 +1,84 @@ +import Whir.AnchoredPhysicalExecution +import Whir.WHIRPhysicalDriver + +/-! The arbitrary attacker may make ordinary/constructed prequeries and then +choose transport, a retained anchor record and Merkle paths. Only the trusted +anchored verifier can produce acceptance. The whole source keeps those earlier +queries; verifier-only captures do not substitute for its first-address logs. -/ +set_option autoImplicit false +namespace Whir.AnchoredPhysicalAfter +open Concrete FiatShamirGame DuplexModeGame WHIRSourceChronology WHIRPhysicalVerifier +open MerkleTransport MerkleTransport.Commitments PublicMerkleProgram +open WHIRPhysicalDriver +open WHIRSourceBackfill (AllResults) + +structure Input (ctx : RawWHIRKeys.Context) (Q : Nat) where + packet : RawWHIRKeys.Packet ctx Q + record : AnchoredHeaderCodec.Record + proofs : Array PrunedMerklePaths + +structure Accepted (ctx : RawWHIRKeys.Context) (Q cap : Nat) where + input : Input ctx Q + native : AnchoredPhysicalDriver.Accepted ctx Q cap input.packet input.record + +def verifier (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (input : Input registry.context Q) : + Source cap (Option (Accepted registry.context Q cap)) := + (AnchoredPhysicalDriver.verifySource cap .fresh (registry.packetModel Q input.packet) + registry.context rfl Q input.packet input.record input.proofs).map + (Option.map (fun native => ⟨input,native⟩)) + +def verifyAfter (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) : Source cap (Option (Accepted registry.context Q cap)) := + attacker.bind (verifier cap registry Q) + +theorem verifier_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (input : Input registry.context Q) : + Counts (sourceBudget registry.context Q input.packet) (verifier cap registry Q input) := by + apply (Source.map_counted _ _ _).mpr + exact AnchoredPhysicalDriver.verifySource_counted cap .fresh (registry.packetModel Q input.packet) + registry.context rfl Q input.packet input.record input.proofs + +theorem verifyAfter_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) (a b : Nat) (before : Counts a attacker) + (budget : AllResults (fun input => sourceBudget registry.context Q input.packet ≤ b) (erase attacker)) : + Counts (a+b) (verifyAfter cap registry Q attacker) := by + apply (erase_counted _ _).mp + rw [verifyAfter,Source.erase_bind] + apply WHIRSourceBackfill.bind_counted_reachable _ _ _ a b + ((erase_counted _ _).mpr before) budget + intro input bounded + exact (erase_counted _ _).mpr (Source.counts_mono (verifier_counted cap registry Q input) bounded) + +theorem native_segment (cap : Nat) (registry : ProductionRegistry) (Q : Nat) + (attacker : Source cap (Input registry.context Q)) (observations : List Observation) + (accepted : Accepted registry.context Q cap) + (run : Runs (erase (verifyAfter cap registry Q attacker)) observations (some accepted)) : + ∃ (input : Input registry.context Q) (before after : List Observation) + (native : AnchoredPhysicalDriver.Accepted registry.context Q cap input.packet input.record), + observations = before ++ after ∧ Runs (erase attacker) before input ∧ + Runs (erase (AnchoredPhysicalDriver.verifySource cap .fresh (registry.packetModel Q input.packet) + registry.context rfl Q input.packet input.record input.proofs)) after (some native) ∧ + accepted = ⟨input,native⟩ := by + obtain ⟨before,input,after,trace,first,last⟩ := + (Source.erased_bind_runs attacker _ observations (some accepted)).mp run + obtain ⟨result,nativeRun,mapped⟩ := (Source.erased_map_runs _ _ after (some accepted)).mp last + obtain ⟨native,returned,equal⟩ := Option.map_eq_some_iff.mp mapped + rw [returned] at nativeRun + exact ⟨input,before,after,native,trace,first,nativeRun,equal.symm⟩ + +theorem real_result (C : PrimitiveOracle) (iv : Digest32) (cap : Nat) + (registry : ProductionRegistry) (Q : Nat) (attacker : Source cap (Input registry.context Q)) : + (runReal C iv (compile (verifyAfter cap registry Q attacker))).view.result = + let chosen := (runReal C iv (compile attacker)).view.result + let native := (runReal C iv (compile (AnchoredPhysicalDriver.verifySource cap .fresh + (registry.packetModel Q chosen.value.packet) registry.context rfl Q + chosen.value.packet chosen.value.record chosen.value.proofs))).view.result + ⟨native.value.map (fun accepted => ⟨chosen.value,accepted⟩),chosen.events ++ native.events⟩ := by + rw [verifyAfter,Source.real_bind] + simp only [verifier,Source.real_map] + +end Whir.AnchoredPhysicalAfter +#print axioms Whir.AnchoredPhysicalAfter.verifier_counted +#print axioms Whir.AnchoredPhysicalAfter.verifyAfter_counted +#print axioms Whir.AnchoredPhysicalAfter.native_segment +#print axioms Whir.AnchoredPhysicalAfter.real_result diff --git a/verification/whir/Whir/AnchoredPhysicalExecution.lean b/verification/whir/Whir/AnchoredPhysicalExecution.lean new file mode 100644 index 000000000..398b8ed42 --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalExecution.lean @@ -0,0 +1,125 @@ +import Whir.AnchoredPhysicalDriver +import Whir.WHIRPhysicalSoundness + +/-! Operational inversion of the anchored receiver. The caller model, boundary, +answers and packet/opening executions below are pinned by the executed program, +not selected from the result's existential `origin` field. -/ +namespace Whir.AnchoredPhysicalExecution +open Concrete Protocol FiatShamirGame PublicMerkleProgram WHIRSourceChronology DuplexModeGame +open WHIRPhysicalVerifier WHIRPhysicalReplay WHIRPhysicalOpeningRuns +open WHIRPhysicalCaller AnchoredPhysicalDriver +open RawOracleCoupling.Concrete +open MerkleTransport MerkleTransport.Commitments + + theorem finish_success (ctx : RawWHIRKeys.Context) (Q cap : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (record : AnchoredHeaderCodec.Record) + (configured : configuration packet.val.profile record) + (request : CausalBindingState.ClaimRequest cap packet.val.profile) + (state : WireState packet.val.profile) (history : List (Sigma (GroupAnswer ctx Q))) + (origin : ∃ boundary : Boundary, ∃ model : WHIRCallerSupport.ProductionLayout, + ∃ answers : Coordinate → Option Digest32, + record.shape = AnchoredSourceCaller.shape model.layout ∧ + AnchoredPhysicalDriver.request boundary cap packet.val.profile model.layout record + (RawWHIRKeys.entry ctx packet.val) answers = some request) + (a : Accepted ctx Q cap packet record) + (success : AnchoredPhysicalDriver.finish ctx Q cap packet record configured request state history origin = some a) : + a.request = request ∧ a.wire = state ∧ a.history = history := by + unfold AnchoredPhysicalDriver.finish at success + split at success + · cases success + · dsimp only at success + split at success + · cases success + · split at success + · cases success + · cases Option.some.inj success + exact ⟨rfl,rfl,rfl⟩ + + theorem verifySource_success (cap : Nat) (boundary : Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (record : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (a : Accepted ctx Q cap packet record) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + observations (some a)) : + ∃ (configured : configuration packet.val.profile record) + (same : record.shape = AnchoredSourceCaller.shape model.layout) (before after : List Observation) + (request : CausalBindingState.ClaimRequest cap packet.val.profile), + observations = before ++ after ∧ + before.length = (WHIRModeFinal.callerPositions ctx Q packet).length ∧ + before.map Observation.query = (WHIRModeFinal.callerPositions ctx Q packet).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property)) ∧ + ∃ parsed : AnchoredPhysicalDriver.request boundary cap packet.val.profile model.layout record + (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) = some request, + Runs (erase (readPhysicalPackets (cap := cap) ctx stack Q packet.val.profile record.shape.lanes proofs none + (completion ctx Q packet) (completion_profiles ctx Q packet) + (initialWireState packet.val.profile record.root) + (fun state history => .done (AnchoredPhysicalDriver.finish ctx Q cap packet record configured request state history + ⟨boundary,model,latestAnswers before,same,parsed⟩)))) after (some a) := by + unfold AnchoredPhysicalDriver.verifySource at run + split at run + · rename_i configured + split at run + · simp only [erase] at run + cases run + · rename_i same + simp only [erase] at run + obtain ⟨before,after,traceEq,count,queries,continued⟩ := readCallerInputs_run ctx Q packet + (WHIRModeFinal.callerPositions ctx Q packet) (fun _ => none) _ observations (some a) run + split at continued + · cases continued + · rename_i request parsed + exact ⟨configured,not_ne_iff.mp same,before,after,request,traceEq,count,queries,parsed,continued⟩ + · simp only [erase] at run + cases run + +private theorem runs_done_eq {R : Type} {left right : R} {trace : List Observation} + (run : Runs (.done left) trace right) : left = right := by + cases run + rfl + +/-- Actual success exposes the actual caller-prefix equation as well as the +complete packet trace and every retained Merkle opener subrun. -/ + theorem verifySource_execution (cap : Nat) (boundary : Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (record : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (a : Accepted ctx Q cap packet record) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + observations (some a)) : + (∃ before after, observations = before ++ after ∧ + before.length = (WHIRModeFinal.callerPositions ctx Q packet).length ∧ + before.map Observation.query = (WHIRModeFinal.callerPositions ctx Q packet).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property)) ∧ + AnchoredPhysicalDriver.request boundary cap packet.val.profile model.layout record + (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) = some a.request) ∧ + a.request.root = record.root ∧ a.request.lanes = record.shape.lanes ∧ + Trace ctx stack Q packet.val.profile record.shape.lanes proofs (completion ctx Q packet) + (initialWireState packet.val.profile record.root) a.wire a.history ∧ + (∀ opening ∈ a.wire.openings, ObservedOpening record.shape.lanes proofs observations opening) := by + obtain ⟨configured,same,before,after,request,traceEq,count,queries,parsed,physical⟩ := + verifySource_success cap boundary model ctx stack Q packet record proofs observations a run + obtain ⟨final,history,suffix,trace,last⟩ := readPhysicalPackets_trace ctx stack Q packet.val.profile + record.shape.lanes proofs _ _ _ _ after a physical + obtain ⟨requestEq,wireEq,historyEq⟩ := finish_success ctx Q cap packet record configured request final history + _ a (runs_done_eq last) + obtain ⟨_,_,_,root,lanes⟩ := request_origin boundary cap packet.val.profile model.layout record + (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) request parsed + refine ⟨⟨before,after,traceEq,count,queries,by simpa only [requestEq] using parsed⟩, + (congrArg (fun r => r.root) requestEq).trans root,requestEq ▸ lanes,?_,?_⟩ + · simpa only [← wireEq,← historyEq] using trace + · obtain ⟨state,log,remaining,last,_,opened⟩ := readPhysicalCompletion_openings ctx stack Q packet + record.shape.lanes proofs record.root _ after a physical + obtain ⟨_,wireEq',_⟩ := finish_success ctx Q cap packet record configured request state log + _ a (runs_done_eq last) + intro opening member + rw [wireEq'] at member + apply (opened opening member).mono + intro event present + rw [traceEq] + exact List.mem_append_right _ present + +#print axioms finish_success +#print axioms verifySource_success +#print axioms verifySource_execution +end Whir.AnchoredPhysicalExecution diff --git a/verification/whir/Whir/AnchoredPhysicalKnowledgeAcceptance.lean b/verification/whir/Whir/AnchoredPhysicalKnowledgeAcceptance.lean new file mode 100644 index 000000000..bd9b50f0b --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalKnowledgeAcceptance.lean @@ -0,0 +1,212 @@ +import Whir.AnchoredPhysicalExecution +import Whir.AnchorPrefixRefinementCaller +import Whir.WHIRNativeErasure + +/-! Deterministic acceptance at the physical observer's first-frozen capture. +The input is constructed from the executed request and immutable anchor. This +is deliberately not a PCS cross-sampler capture-identity theorem. Snapshot +registration and quietness refer to the actual retained opener executions. -/ +namespace Whir.AnchoredPhysicalKnowledgeAcceptance +open Concrete Protocol FiatShamirGame DuplexModeGame +open MerkleTransport MerkleTransport.Commitments +open WHIRPhysicalVerifier WHIRPhysicalReplay WHIRPhysicalOpeningRuns WHIRPhysicalSoundness +open PublicMerkleProgram WHIRSourceChronology AnchoredPhysicalDriver +set_option maxHeartbeats 800000 + + theorem sourceVerify_erased {m : Nat} (record : AnchoredHeaderCodec.Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) (c : Config) (ch : Challenges) (proof : Opening) : + AnchoredPhysicalAnchor.sourceVerify record family points seed lambda c ch + (WHIRPhysicalErasure.eraseOracles proof) = + AnchoredPhysicalAnchor.sourceVerify record family points seed lambda c ch proof := + WHIRNativeErasure.nativeVerify_erased c ch record.shape.lanes + (AnchoredPhysicalAnchor.initialClaim record family points seed lambda) + (AnchoredPhysicalAnchor.callerAt record family points seed lambda) proof + +private theorem opening_unerase (c : Config) (ch : Challenges) + (replies : Array CausalGame.Reply) (erased : Opening) + (accepted : CausalGame.opening c ch (replies.map WHIRPhysicalErasure.eraseReply) = .ok erased) : + ∃ proof, CausalGame.opening c ch replies = .ok proof ∧ WHIRPhysicalErasure.eraseOracles proof = erased := by + rw [WHIRPhysicalErasure.opening_erase] at accepted + cases parsed : CausalGame.opening c ch replies with + | error message => simp [parsed,Except.map] at accepted + | ok proof => + simp [parsed,Except.map] at accepted + exact ⟨proof,rfl,accepted⟩ + +noncomputable def original {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : AnchoredHeaderCodec.Record} + (a : Accepted ctx Q cap packet record) (state : CausalBindingState.State cap) : + WHIRFiatShamir.StackInitial packet.val.profile cap := + CausalBindingState.bindClaims + (CausalBindingState.capture state packet.val.profile a.request.root a.request.lanes a.request.lane_bound) + a.request.claims + +noncomputable def input {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : AnchoredHeaderCodec.Record} + (a : Accepted ctx Q cap packet record) (state : CausalBindingState.State cap) + (seed : RingPCSGame.Prefix) : CausalGame.Public where + config := ParameterBounds.config packet.val.profile + lanes := record.shape.lanes + root := (original a state).root + claims := AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) record + a.request.claims.family a.request.claims.points seed + + theorem replies_nonempty {ctx : RawWHIRKeys.Context} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : AnchoredHeaderCodec.Record} + (a : Accepted ctx Q cap packet record) : a.wire.replies ≠ #[] := by + intro empty + obtain ⟨_,_,_,parsed,_⟩ := a.acceptance + rw [empty] at parsed + simp [CausalGame.opening,CausalGame.visibleBatches,CausalGame.checkReplies] at parsed + +/-- The bound rows are a conclusion of actual opener execution, authentic +retained snapshots, and absence of the executed Merkle bad events. -/ + theorem execution_boundRows {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (C : PrimitiveOracle) (iv : Digest32) (packet : RawWHIRKeys.Packet ctx Q) + (record : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (a : Accepted ctx Q cap packet record) (observations : List Observation) + (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (observed : ∀ opening ∈ a.wire.openings, ObservedOpening a.request.lanes proofs observations opening) + (trace : Trace ctx stack Q packet.val.profile a.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile a.request.root) a.wire a.history) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, lookup a.request.root state.registry = some snap) + (prepared : CausalBindingState.Prepared state packet.val.profile ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + WHIRPhysicalRoots.BoundRows (original a state).root (CausalBindingState.roots state packet.val.profile) a.wire := by + intro opening member + have chain := completion_chain ctx Q packet + obtain ⟨snapshot,known⟩ := trace_opening_registered packet a.request.root chain trace state + initial prepared opening member + obtain ⟨retained,oldLog,_,frozen,authentic,history,saturated,table⟩ := + invariant.retained opening.root snapshot known + rcases observed_binding (observed opening member) C iv answers oldLog authentic + retained history saturated snapshot table with bound | bad + · rw [frozenQueryOracle_state C state invariant packet.val.profile opening.root snapshot known + opening.level.val a.request.lanes a.request.lane_bound] at bound + by_cases base : opening.level.val = 0 + · have rootEq := trace_base_opening_root packet a.request.root chain trace opening member base + simpa only [base,ite_true,rootEq,original,CausalBindingState.bindClaims] using bound + · simpa only [ite_eq_right base] using bound + · exact False.elim (quiet opening member oldLog frozen bad) + +/-- Erased physical acceptance is restored to protocol and experiment success +on the same actual tape, at the physical first-frozen captured base. There are +no accepted-experiment, semantic-equivalence, root-shape or authenticated-row +premises. The catalog used in the proof is a local constant decoding scaffold. -/ + theorem verifySource_experiment (cap : Nat) (boundary : Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (record : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (a : Accepted ctx Q cap packet record) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + observations (some a)) + (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, lookup record.root state.registry = some snap) + (prepared : CausalBindingState.Prepared state packet.val.profile ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + ∃ (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + replay.original = original a state ∧ a.wire.initial = some replay.initial ∧ + a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof ∧ + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (original a state).root) + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).weight + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).value proof = .ok () ∧ + CausalGame.experiment (input a state replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨caller,rootEq,lanesEq,trace,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap boundary model ctx stack Q packet record proofs observations a run + have trace' : Trace ctx stack Q packet.val.profile a.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile a.request.root) a.wire a.history := by + simpa only [rootEq,lanesEq] using trace + have bound := execution_boundRows C iv packet record proofs a observations answers + (by simpa only [lanesEq] using observed) trace' state invariant (by simpa only [rootEq] using initial) prepared quiet + let catalog : StackWHIRReplay.Catalog packet.val.profile cap := fun _ => some (original a state) + have found : catalog packet.val.statement = some (original a state) := rfl + have chain := completion_chain ctx Q packet + have complete := trace_completed a.request.root chain trace' + obtain ⟨head,past,sample,erased,history,decoded,originalEq,initialSeed,statement,tape,replies⟩ := + Completed.decodeStack packet a.wire a.history catalog (original a state) found complete (replies_nonempty a) + have tail : (localHistory ctx stack Q packet.val.profile a.history).tail = past := by rw [history]; rfl + have full := decoded + change WHIRPhysicalHistory.decodeStack packet.val.profile cap catalog WHIRPhysicalErasure.zeroRoots + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ = some erased at full + rw [WHIRPhysicalErasure.decodeStack_zero packet.val.profile cap catalog (CausalBindingState.roots state packet.val.profile) + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩] at full + obtain ⟨replay,physical,erasedEq⟩ := Option.map_eq_some_iff.mp full + subst erased + change replay.original = original a state at originalEq + change a.wire.initial = some replay.initial at initialSeed + change (StackWHIRReplay.finish ⟨packet.val.statement,packet.val.messages,past⟩ replay sample).whir.tape = a.wire.tape at tape + change replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies at replies + have agreement := WHIRPhysicalRoots.trace_stackRowsAgree packet a.request.root catalog (original a state) + (CausalBindingState.roots state packet.val.profile) found chain trace' bound + rw [tail] at agreement + have ideal := WHIRPhysicalHistory.decodeStack_success packet.val.profile cap catalog + (CausalBindingState.roots state packet.val.profile) (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,past⟩ replay agreement physical + have lambda := StackWHIRReplay.decode_initial_lambda catalog (CausalBindingState.roots state packet.val.profile) + ⟨packet.val.statement,packet.val.messages,past⟩ replay ideal sample + rw [tape] at lambda + change a.wire.tape.1 = replay.initial.2 at lambda + obtain ⟨seed,nativeProof,seedFound,parsed,native⟩ := a.acceptance + have sameSeed : seed = replay.initial := Option.some.inj (seedFound.symm.trans initialSeed) + subst seed + rw [← replies] at parsed + obtain ⟨proof,parsedFull,erasedProof⟩ := opening_unerase _ _ replay.whir.replies nativeProof parsed + have nativeFull : AnchoredPhysicalAnchor.sourceVerify record a.request.claims.family a.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) proof = .ok () := by + rw [← sourceVerify_erased,erasedProof] + exact native + have rootsShape := decodeStack_rootShapes packet.val.profile cap state catalog + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ replay physical a.wire.tape proof parsedFull + have authenticated := trace_authenticatedRows packet a.request.root (original a state).root + (CausalBindingState.roots state packet.val.profile) chain trace' bound catalog replay + (by rw [tail]; exact physical) proof parsedFull + obtain ⟨before,after,_,_,_,callerParsed⟩ := caller + obtain ⟨_,same,_,_,_,_,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_success + cap boundary model ctx stack Q packet record proofs observations a run + have shapes := request_anchored_shapes boundary cap packet.val.profile model record a.configuration same + (RawWHIRKeys.entry ctx packet.val) (WHIRPhysicalCaller.latestAnswers before) a.request callerParsed + replay.initial.1 replay.initial.2 + have nativeShapes := request_nativeShapes boundary cap packet.val.profile model record a.configuration same + (RawWHIRKeys.entry ctx packet.val) (WHIRPhysicalCaller.latestAnswers before) a.request callerParsed + have verified := AnchorPrefixRefinement.sourceVerify_refines record a.request.claims.family a.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) _ proof + (CausalGame.liftRoot (original a state).root) a.configuration.1 a.configuration.2.1 a.configuration.2.2.1 + nativeShapes.1 (fun i => nativeShapes.2 _ (by simp)) shapes.2 + (by simpa only [original,CausalBindingState.bindClaims,lanesEq] using + capture_base_shape state packet.val.profile a.request.root a.request.lanes a.request.lane_bound) + rootsShape authenticated nativeFull + have verifiedTape : Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (original a state).root) + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).weight + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a state replay.initial.1).claims a.wire.tape.1).value proof = .ok () := by + rw [lambda] + exact verified + refine ⟨replay,proof,originalEq,initialSeed,lambda,replies,parsedFull,verifiedTape,?_⟩ + apply experiment_indexed_accepts (input a state replay.initial.1) a.wire.tape replay.whir.replies proof parsedFull + · exact shapes.1 + · exact verifiedTape + +#print axioms sourceVerify_erased +#print axioms execution_boundRows +#print axioms verifySource_experiment +end Whir.AnchoredPhysicalKnowledgeAcceptance diff --git a/verification/whir/Whir/AnchoredPhysicalPreparation.lean b/verification/whir/Whir/AnchoredPhysicalPreparation.lean new file mode 100644 index 000000000..9331d628c --- /dev/null +++ b/verification/whir/Whir/AnchoredPhysicalPreparation.lean @@ -0,0 +1,337 @@ +import Whir.AnchoredPhysicalKnowledgeAcceptance +import Whir.CountedCandidateCheckOriginalCorrectness + +/-! Original-claim preparation is computed from the exact executed anchored +request. No separately chosen public caller or semantic matching certificate is +used. PCS public metadata/capture matching remains a separate boundary. -/ +namespace Whir.AnchoredPhysicalPreparation +open Concrete Protocol FiatShamirGame DuplexModeGame +open WHIRCallerClaims WHIRCallerSupport AnchoredPhysicalDriver +open WHIRPhysicalVerifier WHIRPhysicalReplay WHIRSourceChronology PublicMerkleProgram +open MerkleTransport +set_option maxHeartbeats 800000 + +private def extentOf (bound : Nat) : RingPCSGame.PointClaim → Prop + | .point offset point _ => offset + 2^point.size ≤ bound + | .strided offset _ stride point _ => offset + 2^(stride+point.size) ≤ bound + +private theorem point_extent (sources : Array Source) (ps : Array Placement) + (built : placementsOf sources = some ps) (column : ColumnClaim) (placement : Placement) + (atColumn : ps[column.column]? = some placement) + (fits : columnFits sources column.column column.point.length = true) + (claim : RingPCSGame.PointClaim) (placed : placeClaim placement column = some claim) : + extentOf (placedWords sources) claim := by + have hp := placementsOf_get sources ps built column.column placement atColumn + by_cases sliced : sources[column.column]? = some .sliced + · simp [WHIRCallerSupport.placement,sliced] at hp + subst placement + simp [placeClaim] at placed + · have dimension : ∃ rows, columnDimension sources column.column = some rows ∧ column.point.length ≤ rows := by + unfold columnFits at fits + simp only [Bool.and_eq_true] at fits + cases hs : sources[column.column]? with + | none => simp [columnDimension,hs] at fits + | some source => + cases source with + | sliced => exact False.elim (sliced hs) + | committed d => + cases hd : columnDimension sources column.column with + | none => simp [hd] at fits + | some rows => exact ⟨rows,rfl,by simpa [hd] using fits.2⟩ + | port packed slot stride => + cases hd : columnDimension sources column.column with + | none => simp [hd] at fits + | some rows => exact ⟨rows,rfl,by simpa [hd] using fits.2⟩ + obtain ⟨rows,hd,length⟩ := dimension + have extent := placement_extent sources column.column rows placement hp hd + cases placement with + | committed offset dimension => + simp only [placeClaim,Option.some.injEq] at placed + subst claim + change rows ≤ dimension ∧ offset + 2^dimension ≤ placedWords sources at extent + have power : 2^column.point.length ≤ 2^dimension := + Nat.pow_le_pow_right (by decide) (length.trans extent.1) + simp only [extentOf,List.size_toArray] + omega + | port offset slot stride => + simp only [placeClaim,Option.some.injEq] at placed + subst claim + change offset + 2^(stride+rows) ≤ placedWords sources at extent + have power : 2^(stride+column.point.length) ≤ 2^(stride+rows) := + Nat.pow_le_pow_right (by decide) (Nat.add_le_add_left length stride) + simp only [extentOf,List.size_toArray] + omega + | sliced => simp [placeClaim] at placed + +private theorem decoded_guards (p : ParameterBounds.Profile) (model : ProductionLayout) + (record : AnchoredHeaderCodec.Record) (configured : configuration p record) + (same : record.shape = AnchoredSourceCaller.shape model.layout) + (decoded : AnchoredSourceCaller.Claims) + (geometry : WHIRCallerGeometry.ClaimsValid + (fun i d => columnFits model.sources i d = true) + (fun o d => ringFits model.sources o d = true) (callerPlacements model.layout) decoded.caller) : + OriginalClaimsChecker.Guards (ParameterBounds.config p) record.shape.lanes + (fun i : Fin decoded.caller.families.length => decoded.caller.families[i]) + decoded.caller.points record.point.toArray := by + have metadata := opening_metadata model p record configured same + have laneBound : record.shape.lanes ≤ 2^(ParameterBounds.config p).folds[0]! := by + rw [← configured.2.2.1] + exact configured.1.1.2.2.2.2.2 + have shapes := geometry_nativeShapes model p record.shape.lanes metadata laneBound decoded.caller geometry + have support := geometry_support model decoded.caller geometry + have occupied := openingMatches_occupied model.layout p record.shape.lanes metadata + have valid := configured.1 + refine ⟨?_,?_,?_,laneBound,?_,?_,?_⟩ + · rw [← configured.2.2.1,← configured.2.1] + exact Nat.le_of_lt valid.1.1 + · rw [← configured.2.1] + exact Nat.le_of_lt valid.1.2.1 + · exact lt_of_lt_of_le (by decide : 0 < 1) valid.1.2.2.2.2.1 + · simpa only [List.size_toArray] using valid.2.2.trans configured.2.1 + · intro j + have native := shapes.1 j + exact ⟨native.1,native.2.1,(support.1 _ (by simp)).trans occupied⟩ + · intro i + have native := shapes.2 decoded.caller.points[i] (by simp) + obtain ⟨column,placement,atColumn,placed,fits⟩ := geometry.2 decoded.caller.points[i] (by simp) + have extent := point_extent model.sources (callerPlacements model.layout) model.constructed + column placement atColumn fits _ placed + rw [← callerWords_placementsOf model.sources model.layout model.constructed] at extent + cases claimEq : decoded.caller.points[i] with + | point offset point value => + rw [claimEq] at native extent + obtain ⟨dimension,aligned,range⟩ := (SuccinctPointWeight.Shape.point_iff _ _ _ _).mp native + change offset + 2^point.size ≤ callerWords model.layout at extent + exact ⟨dimension,aligned,extent.trans occupied⟩ + | strided offset slot stride point value => + rw [claimEq] at native extent + obtain ⟨dimension,aligned,range,slotBound⟩ := (SuccinctPointWeight.Shape.strided_iff _ _ _ _ _ _).mp native + change offset + 2^(stride+point.size) ≤ callerWords model.layout at extent + exact ⟨dimension,slotBound,aligned,extent.trans occupied⟩ + +/-- Exact parser success, not `Accepted.origin`, supplies preparation guards. -/ + theorem request_guards (boundary : Boundary) (cap : Nat) (p : ParameterBounds.Profile) + (model : ProductionLayout) (record : AnchoredHeaderCodec.Record) + (configured : configuration p record) (same : record.shape = AnchoredSourceCaller.shape model.layout) + (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (result : CausalBindingState.ClaimRequest cap p) + (accepted : AnchoredPhysicalDriver.request boundary cap p model.layout record entry answers = some result) : + OriginalClaimsChecker.Guards (ParameterBounds.config p) record.shape.lanes + result.claims.family result.claims.points record.point.toArray := by + unfold AnchoredPhysicalDriver.request at accepted + split at accepted + next present => + cases parsed : AnchoredPhysicalDriver.decodeCaller boundary model.layout record entry + (fun q => (answers q).getD DuplexRefinement.zeroDigest) with + | none => simp [parsed] at accepted + | some decoded => + simp only [parsed,bind,Option.bind] at accepted + split at accepted + next mismatch => contradiction + next matched => + split at accepted + next lanes => + split at accepted + next families => + split at accepted + next points => + cases Option.some.inj accepted + exact decoded_guards p model record configured same decoded + (decodeCaller_geometry boundary model record entry _ decoded parsed) + next => contradiction + next => contradiction + next => contradiction + next => contradiction + +/-- Preparation and its exact public-input equality follow from actual receiver +execution. This statement works for both receiver boundaries, without equating +the original and fresh decoders. -/ + theorem verifySource_preparation (cap : Nat) (boundary : Boundary) + (model : ProductionLayout) (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (record : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (observations : List Observation) + (a : Accepted ctx Q cap packet record) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + observations (some a)) : + ∃ prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.count a.request.claims.family a.request.claims.points record.point.toArray record.value, + OriginalClaimsChecker.prepare (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.family a.request.claims.points record.point.toArray record.value = some prepared ∧ + ∀ (state : CausalBindingState.State cap) (seed : RingPCSGame.Prefix), + OriginalClaimsChecker.input prepared (AnchoredPhysicalKnowledgeAcceptance.original a state).root seed = + AnchoredPhysicalKnowledgeAcceptance.input a state seed := by + obtain ⟨configured,same,before,after,request,_,_,_,parsed,_⟩ := + AnchoredPhysicalExecution.verifySource_success cap boundary model ctx stack Q packet record proofs observations a run + obtain ⟨⟨before',after',_,_,_,actual⟩,_,_,_,_⟩ := + AnchoredPhysicalExecution.verifySource_execution cap boundary model ctx stack Q packet record proofs observations a run + have guards := request_guards boundary cap packet.val.profile model record configured same + (RawWHIRKeys.entry ctx packet.val) (WHIRPhysicalCaller.latestAnswers before') a.request actual + cases hp : OriginalClaimsChecker.prepare (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.family a.request.claims.points record.point.toArray record.value with + | none => simp [OriginalClaimsChecker.prepare,dite_eq_left guards] at hp + | some cached => + refine ⟨cached,rfl,?_⟩ + intro state seed + exact congrArg (fun claims => CausalGame.Public.mk (ParameterBounds.config packet.val.profile) + record.shape.lanes (AnchoredPhysicalKnowledgeAcceptance.original a state).root claims) + (OriginalClaimsChecker.input_claims cached (AnchoredPhysicalKnowledgeAcceptance.original a state).root seed) + +/-- Successful anchored opening parsing forces completion of the actual packet +schedule, including its possible hidden terminal sample. -/ +theorem accepted_completed_depth {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {record : AnchoredHeaderCodec.Record} + (a : Accepted ctx Q cap packet record) (complete : Completed stack packet a.wire a.history) : + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) := by + obtain ⟨_,_,_,_,_,_,_,_,_,_,size,_,_⟩ := complete + obtain ⟨_,proof,_,parsed,_⟩ := a.acceptance + have count := CausalRefinement.checkReplies_length _ _ + ((CausalRefinement.opening_ok_iff _ _ _ _).mp parsed).1 + have stream := congrArg List.length + (CausalProbability.visibleCoordinates_map (ParameterBounds.config packet.val.profile) a.wire.tape) + simp only [List.length_map] at stream + have length : a.wire.replies.size = + (CausalProbability.visibleCoordinates (ParameterBounds.config packet.val.profile)).length := by + calc + a.wire.replies.size = (CausalGame.visibleBatches (ParameterBounds.config packet.val.profile) + E.zero (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape)).length := count + _ = (CausalGame.visibleBatches (ParameterBounds.config packet.val.profile) + a.wire.tape.1 (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape)).length := by + simp only [CausalGame.visibleBatches,List.length_append,List.length_singleton] + _ = _ := stream.symm + have max := RawWHIRKeys.packet_depth ctx Q packet + have hidden : (WHIRHistory.hiddenTail (ParameterBounds.config packet.val.profile)).length ≤ 1 := by + unfold WHIRHistory.hiddenTail + split <;> simp + simp only [WHIRHistory.depth,WHIRHistory.schedule,List.length_append] at max ⊢ + omega + +/-- End-to-end deterministic endpoint on the actual request's prepared original +claims, the restored replies, and the same physical tape. The remaining public +PCS capture/metadata identity is not smuggled in as a matching certificate. -/ +theorem verifySource_prepared_experiment (cap : Nat) (boundary : Boundary) + (model : ProductionLayout) (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (record : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (observations : List Observation) + (a : Accepted ctx Q cap packet record) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs)) + observations (some a)) + (C : PrimitiveOracle) (iv : Digest32) + (answers : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, Commitments.lookup record.root state.registry = some snap) + (registered : CausalBindingState.Prepared state packet.val.profile ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + ∃ prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.count a.request.claims.family a.request.claims.points record.point.toArray record.value, + ∃ (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + OriginalClaimsChecker.prepare (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.family a.request.claims.points record.point.toArray record.value = some prepared ∧ + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) ∧ + replay.original = AnchoredPhysicalKnowledgeAcceptance.original a state ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof ∧ + (let claims := (OriginalClaimsChecker.input prepared + (AnchoredPhysicalKnowledgeAcceptance.original a state).root replay.initial.1).claims + let claim := CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) claims a.wire.tape.1 + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (AnchoredPhysicalKnowledgeAcceptance.original a state).root) + claim.weight claim.value proof = .ok ()) ∧ + CausalGame.experiment + (OriginalClaimsChecker.input prepared (AnchoredPhysicalKnowledgeAcceptance.original a state).root replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨prepared,preparedEq,inputEq⟩ := verifySource_preparation cap boundary model ctx stack Q packet record + proofs observations a run + obtain ⟨replay,proof,originalEq,seed,lambda,erased,parsed,verified,experiment⟩ := + AnchoredPhysicalKnowledgeAcceptance.verifySource_experiment cap boundary model ctx stack Q packet record + proofs observations a run C iv answers state invariant initial registered quiet + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution cap boundary model ctx stack Q + packet record proofs observations a run + have complete := trace_completed record.root (completion_chain ctx Q packet) trace + have claimsEq := congrArg CausalGame.Public.claims (inputEq state replay.initial.1) + have preparedVerified : + let claims := (OriginalClaimsChecker.input prepared + (AnchoredPhysicalKnowledgeAcceptance.original a state).root replay.initial.1).claims + let claim := CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) claims a.wire.tape.1 + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (AnchoredPhysicalKnowledgeAcceptance.original a state).root) + claim.weight claim.value proof = .ok () := by + simpa only [claimsEq] using verified + refine ⟨prepared,replay,proof,preparedEq,accepted_completed_depth a complete,originalEq,seed,lambda,erased,parsed,preparedVerified,?_⟩ + have experimentEq := congrArg (fun claims => + CausalGame.experiment + (CausalGame.Public.mk (ParameterBounds.config packet.val.profile) record.shape.lanes + (AnchoredPhysicalKnowledgeAcceptance.original a state).root claims) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape) claimsEq + exact experimentEq.trans experiment + +private theorem real_answers {R : Type} (C : PrimitiveOracle) (iv : Digest32) (program : Program R) : + ∀ o ∈ (runReal C iv program).view.observations, o.answer = realAnswer C iv o.query := by + induction program with + | done value => simp [runReal] + | ask query next ih => + intro o member + rcases List.mem_cons.mp member with same | rest + · subst o + rfl + · exact ih (realAnswer C iv query) o rest + +/-- Actual compiled real receiver success. Answer consistency is now derived +from execution itself. The observer snapshot registration/capture interface is +the only remaining outer boundary; no PCS public-capture identity is claimed. -/ +theorem real_verifySource_prepared_experiment (cap : Nat) (boundary : Boundary) + (model : ProductionLayout) (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) (record : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (C : PrimitiveOracle) (iv : Digest32) + (a : Accepted ctx Q cap packet record) + (success : (runReal C iv (compile + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs))).view.result.value = some a) + (state : CausalBindingState.State cap) (invariant : WHIRPhysicalSnapshots.Invariant C state) + (initial : ∃ snap, Commitments.lookup record.root state.registry = some snap) + (registered : CausalBindingState.Prepared state packet.val.profile ⟨packet.val.statement,packet.val.messages,[]⟩) + (quiet : ∀ opening ∈ a.wire.openings, ∀ oldLog, state.frozenLog opening.root = some oldLog → + ¬ PublicMerkleBinding.OpenPrimitiveBad C oldLog opening.root opening.result.paths) : + ∃ prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.count a.request.claims.family a.request.claims.points record.point.toArray record.value, + ∃ (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + OriginalClaimsChecker.prepare (ParameterBounds.config packet.val.profile) record.shape.lanes + a.request.claims.family a.request.claims.points record.point.toArray record.value = some prepared ∧ + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) ∧ + replay.original = AnchoredPhysicalKnowledgeAcceptance.original a state ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof ∧ + (let claims := (OriginalClaimsChecker.input prepared + (AnchoredPhysicalKnowledgeAcceptance.original a state).root replay.initial.1).claims + let claim := CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) claims a.wire.tape.1 + Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) record.shape.lanes + (CausalGame.liftRoot (AnchoredPhysicalKnowledgeAcceptance.original a state).root) + claim.weight claim.value proof = .ok ()) ∧ + CausalGame.experiment + (OriginalClaimsChecker.input prepared (AnchoredPhysicalKnowledgeAcceptance.original a state).root replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + let source := AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet record proofs + have run := WHIRPhysicalCaller.real_source_runs C iv source + change (runReal C iv (compile source)).view.result.value = some a at success + rw [success] at run + have answers : ∀ o ∈ observations (runReal C iv (compile source)).view.result.events, + o.answer = realAnswer C iv o.query := by + rw [real_source_trace] + exact real_answers C iv (compile source) + exact verifySource_prepared_experiment cap boundary model ctx stack Q packet record proofs + _ a run C iv answers state invariant initial registered quiet + +#print axioms real_verifySource_prepared_experiment + +#print axioms accepted_completed_depth +#print axioms verifySource_prepared_experiment + +#print axioms request_guards +#print axioms verifySource_preparation +end Whir.AnchoredPhysicalPreparation diff --git a/verification/whir/Whir/AnchoredPrimitivePhysicalSnapshots.lean b/verification/whir/Whir/AnchoredPrimitivePhysicalSnapshots.lean new file mode 100644 index 000000000..be5106f36 --- /dev/null +++ b/verification/whir/Whir/AnchoredPrimitivePhysicalSnapshots.lean @@ -0,0 +1,65 @@ +import Whir.WHIRPhysicalSnapshots + +/-! The tracked physical registry only observes primitive replies and root +announcements. Construction challenges do not update it, so its invariant does +not require independently sampled ideal challenges to equal a deterministic +compression evaluation. This does not yet identify PCS first-root captures. -/ +set_option autoImplicit false +namespace Whir.AnchoredPrimitivePhysicalSnapshots +open FiatShamirGame DuplexModeGame WHIRSourceChronology WHIRSourceObserver +open WHIRPhysicalSnapshots CausalBindingState + +variable {cap : Nat} + +def PrimitiveEvent (C : PrimitiveOracle) : Event cap → Prop + | .answer (.primitive _ node) answer => answer = C node + | _ => True + +theorem step_invariant (C : PrimitiveOracle) + (state next : CausalBindingState.State cap) (event : Event cap) + (old : Invariant C state) (correct : PrimitiveEvent C event) + (stepped : step state event = .ok next) : Invariant C next := by + cases event with + | answer query value => + cases query with + | primitive purpose node => + change value = C node at correct + subst value + cases stepped + exact observePublic_invariant C state node old + | construction coordinate valid => cases stepped; exact old + | commit root => cases stepped; exact registerRoot_invariant C state root old + | claims profile entry request => + unfold step at stepped + cases known : MerkleTransport.Commitments.lookup request.root state.registry <;> + simp only [known] at stepped + · cases stepped + · cases stepped; exact old + +/-- Actual tracked execution, including bookkeeping errors, preserves frozen +snapshot authentication when its primitive replies are consistent. -/ +theorem replayTracked_invariant (C : PrimitiveOracle) + (state : CausalBindingState.State cap) (events : List (Event cap)) + (old : Invariant C state) (correct : ∀ e ∈ events, PrimitiveEvent C e) : + Invariant C (replayTracked state events) := by + induction events generalizing state with + | nil => exact old + | cons event rest ih => + unfold replayTracked + cases progress : step state event with + | error root => + exact ih _ (error_invariant C state (state.sourceError.or (some root)) old) + (fun e member => correct e (List.mem_cons_of_mem _ member)) + | ok next => + exact ih next (step_invariant C state next event old (correct event (by simp)) progress) + (fun e member => correct e (List.mem_cons_of_mem _ member)) + +theorem replayTracked_empty_invariant (C : PrimitiveOracle) + (events : List (Event cap)) (correct : ∀ e ∈ events, PrimitiveEvent C e) : + Invariant C (replayTracked (empty cap) events) := + replayTracked_invariant C _ events (empty_invariant C cap) correct + +#print axioms step_invariant +#print axioms replayTracked_invariant +#print axioms replayTracked_empty_invariant +end Whir.AnchoredPrimitivePhysicalSnapshots diff --git a/verification/whir/Whir/AnchoredSourceGroups.lean b/verification/whir/Whir/AnchoredSourceGroups.lean new file mode 100644 index 000000000..4c97c4092 --- /dev/null +++ b/verification/whir/Whir/AnchoredSourceGroups.lean @@ -0,0 +1,134 @@ +import Whir.AnchoredSourceRegistry +import Whir.AnchoredByteStreamPrepared +import Whir.WHIRSourceRawCache + +/-! Actual raw-byte grouping is selected by the source header decoder. Preparation reuses the existing partial native-source replay and immutable first Merkle registry. It receives only completed raw history before the current group answer, including when the adversary first requests a nonzero point block. The simulator seed and total source resource certificate remain the explicit mode-game inputs. -/ +namespace Whir.AnchoredSourceGroups +open Concrete FiatShamirGame DuplexModeGame ParameterBounds +open AnchoredHeaderRoots AnchoredByteStreamGroups +open WHIRSourceChronology + +def accept (registry : Public) (p : Profile) (history : FramedHistory) : Bool := + (fromHistory registry history).any (fun header => + decide (header.shape.logN = (config p).logN ∧ header.shape.logBatch = (config p).folds[0]!)) + +abbrev Packet (registry : Public) (p : Profile) (Q : Nat) := + AnchoredByteStreamPrepared.PointPacket p Q registry.iv (accept registry p) + +theorem packet_header (registry : Public) (p : Profile) (Q : Nat) (packet : Packet registry p Q) : + ∃ header, fromHistory registry packet.val.history = some header ∧ + header.shape.logN = (config p).logN ∧ header.shape.logBatch = (config p).folds[0]! := by + have valid := packet.property + cases parsed : fromHistory registry packet.val.history with + | none => simp [accept,parsed] at valid + | some header => + have geometry : header.shape.logN = (config p).logN ∧ header.shape.logBatch = (config p).folds[0]! := by + simpa [accept,parsed] using valid + exact ⟨header,rfl,geometry⟩ + +noncomputable def header (registry : Public) (p : Profile) (Q : Nat) (packet : Packet registry p Q) : Header := + (packet_header registry p Q packet).choose + +theorem header_parsed (registry : Public) (p : Profile) (Q : Nat) (packet : Packet registry p Q) : + fromHistory registry packet.val.history = some (header registry p Q packet) := + (packet_header registry p Q packet).choose_spec.1 + +theorem header_batch (registry : Public) (p : Profile) (Q : Nat) (packet : Packet registry p Q) : + (header registry p Q packet).shape.logBatch = (config p).folds[0]! := + (packet_header registry p Q packet).choose_spec.2.2 + +def rawState (cap Q : Nat) (past : ByteHistory Q) : CausalBindingState.State cap := + { rawAnswers := fun n => if equal : n = Q then equal.symm ▸ past else [] } + +/-- The same source event replay used by the historical physical chain, now fed all counted original-CV/metadata/frame inputs from the new source. No asserted record table or future raw answer is accepted. -/ +def updatePrefix (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) (past : ByteHistory Q) + (state : AnchoredSourceRegistry.State cap) : AnchoredSourceRegistry.State cap := + {state with binding := (WHIRSourceObserver.privateReplay Q registry.iv + (WHIRSourceRawCache.cache Q (rawState cap Q past)) seed source counted state.binding)} + +/-- Replay chronological requests, updating source observations only from replies already completed at each prefix. Every header is frozen before adding that request's answer. -/ +def replayPast (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) : + ByteHistory Q → ByteHistory Q → AnchoredSourceRegistry.State cap → AnchoredSourceRegistry.State cap + | [],past,state => updatePrefix registry Q seed source counted past state + | (key,answer)::rest,past,state => + let state := updatePrefix registry Q seed source counted past state + let state := AnchoredSourceRegistry.beforeRaw registry state key + replayPast registry Q seed source counted rest ((key,answer)::past) state + +theorem replayPast_preserves (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (remaining past : ByteHistory Q) (state : AnchoredSourceRegistry.State cap) + (header : Header) (frozen : AnchoredSourceRegistry.Frozen) (known : state.headers header = some frozen) : + (replayPast registry Q seed source counted remaining past state).headers header = some frozen := by + induction remaining generalizing past state with + | nil => exact known + | cons item remaining ih => + exact ih _ _ (AnchoredSourceRegistry.beforeRaw_preserves registry + (updatePrefix registry Q seed source counted past state) item.1 header frozen known) + +theorem replayPast_extends (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (remaining past : ByteHistory Q) (state : AnchoredSourceRegistry.State cap) : + CausalBindingState.Extends state.binding + (replayPast registry Q seed source counted remaining past state).binding := by + induction remaining generalizing past state with + | nil => exact WHIRSourceObserver.privateReplay_extends Q registry.iv _ seed source counted state.binding + | cons item remaining ih => + exact (WHIRSourceObserver.privateReplay_extends Q registry.iv _ seed source counted state.binding).trans + ((AnchoredSourceRegistry.beforeRaw_binding_extends registry + (updatePrefix registry Q seed source counted past state) item.1).trans (ih _ _)) + +/-- Once a query has recognized the original root and shape, every later completed-query/source replay keeps that same frozen capture. The answer of this first query is appended only after registration. -/ +theorem chronological_first_query_freezes (registry : Public) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (key : RawKey Q) (answer : Digest32) (rest past : ByteHistory Q) + (state : AnchoredSourceRegistry.State cap) (header : Header) + (parsed : rawHeader registry key = some header) : + ∃ frozen, + (AnchoredSourceRegistry.beforeRaw registry (updatePrefix registry Q seed source counted past state) key).headers header = + some frozen ∧ + (replayPast registry Q seed source counted ((key,answer)::rest) past state).headers header = some frozen := by + obtain ⟨frozen,known⟩ := AnchoredSourceRegistry.beforeRaw_known registry + (updatePrefix registry Q seed source counted past state) key header parsed + exact ⟨frozen,known,replayPast_preserves registry Q seed source counted rest ((key,answer)::past) _ header frozen known⟩ + +noncomputable def preparedState (registry : Public) (p : Profile) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) (past : ByteHistory Q) + (packet : Packet registry p Q) : AnchoredSourceRegistry.State cap := + AnchoredSourceRegistry.register + (replayPast registry Q seed source counted past.reverse [] {}) (header registry p Q packet) + +/-- This root and occupied shape are fixed before the fresh whole-run answer. The source's finite first-record hash is used, not a future primitive oracle lookup. -/ +noncomputable def prepare (registry : Public) (p : Profile) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) (past : ByteHistory Q) + (packet : Packet registry p Q) : AnchoredFiatShamirSecurity.PreAnchor p := + let h := header registry p Q packet + let valid := (fromHistory_valid registry packet.val.history h (header_parsed registry p Q packet)).2.2.2 + let occupied : 0 < h.shape.lanes ∧ h.shape.lanes ≤ 2^(config p).folds[0]! := + ⟨valid.2.2.2.2.1,by rw [← header_batch registry p Q packet]; exact valid.2.2.2.2.2⟩ + let state := preparedState registry p Q seed source counted past packet + ⟨h.shape.lanes,(CausalBindingState.capture state.binding p h.root h.shape.lanes occupied.2).base,occupied⟩ + +noncomputable def policy (registry : Public) (p : Profile) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) + (advertise : ByteHistory Q → Packet registry p Q → AnchoredFiatShamirSecurityCodec.Joint (config p).logN → E) : + AnchoredByteStreamPrepared.Policy p Q registry.iv (accept registry p) := + ⟨prepare registry p Q seed source counted,advertise⟩ + +theorem prepare_list_bound (registry : Public) (p : Profile) (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (source : Source cap R) (counted : WHIRSourceChronology.Counts Q source) (past : ByteHistory Q) + (packet : Packet registry p Q) : + (InitialCandidates.witnesses (config p) (prepare registry p Q seed source counted past packet).lanes + (prepare registry p Q seed source counted past packet).root).card ≤ 2^32 := + InitialCandidates.production_witnesses_card p _ _ + +/-- Every requested block of this packet has exactly the same source header. Root preparation therefore works at the adversary's earliest queried block, not only when block zero is requested first. -/ +theorem packet_key_header (registry : Public) (p : Profile) (Q : Nat) (packet : Packet registry p Q) + (i : Fin (AnchoredFiatShamirSecurityCodec.blockCount (config p).logN)) : + rawHeader registry (key packet.val i) = some (header registry p Q packet) := by + rw [rawHeader,key_decodes] + exact header_parsed registry p Q packet + +end Whir.AnchoredSourceGroups diff --git a/verification/whir/Whir/AnchoredSourcePacket.lean b/verification/whir/Whir/AnchoredSourcePacket.lean new file mode 100644 index 000000000..16d82f945 --- /dev/null +++ b/verification/whir/Whir/AnchoredSourcePacket.lean @@ -0,0 +1,193 @@ +import Whir.AnchoredPhysicalDriver + +/-! Pinned 32c anchored source packets retain RawWHIRKeys' exact bounded path reconstruction and shared cache. Original and fresh caller boundaries have distinct exact frame counts. The entire original-CV/metadata/pending/point/value frame remains part of entryFrames and hence every physical path cost and backfill input. -/ +namespace Whir.AnchoredSourcePacket +open Concrete FiatShamirGame WHIRSourceChronology AnchoredHeaderCodec +open WHIRPhysicalDriver +open MerkleTransport MerkleTransport.Commitments + +/-- Fresh CPU source prelude is announcements plus clock; recursion captures immediately after its native transcript seed. Full pending blocks are retained until the next byte. -/ +def originalPending : WHIRCallerClaims.CallerLayout → Nat + | .recursion _ => 0 + | .cpu layout => ((24*(layout.tables.length+2)-1)%64)+1 + +def context (registry : ProductionRegistry) : RawWHIRKeys.Context := + { registry.context with + entryLength := fun statement => ((WHIRCallerRegistry.selection registry.publicRegistry statement).map + (fun selected => AnchoredSourceCaller.entryLength selected.1 (originalPending selected.1))).getD 0 + callerOutputCap := registry.callerOutputCap + (24*28+31)/32 } + +/-- A later session transports the new payload and immutable frame only. Original point output blocks are not replayed or resampled here. -/ +def freshContext (registry : ProductionRegistry) (record : Record) : RawWHIRKeys.Context := + {registry.context with entryLength := fun statement => + ((WHIRCallerRegistry.selection registry.publicRegistry statement).map + (fun selected => AnchoredSourceFreshCaller.entryLength selected.1 record)).getD 0} + +def headerPublic (registry : ProductionRegistry) : AnchoredHeaderRoots.Public where + iv := registry.iv + domain := registry.domain + shapes := fun statement => ((WHIRCallerRegistry.selection registry.publicRegistry statement).map + (fun selected => AnchoredSourceCaller.shape selected.1)) + +/-- The same immutable production registry selects the model. No packet carries a supplied layout, shape proof, root decoder or native acceptance evidence. -/ +def packetModel (registry : ProductionRegistry) (ctx : RawWHIRKeys.Context) + (catalogue : ctx.catalog = registry.context.catalog) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) : + WHIRCallerSupport.ProductionLayout := + match found : registry.models packet.val.statement with + | some model => model + | none => False.elim (by + have catalog := packet.property.1 + rw [catalogue] at catalog + change (WHIRCallerRegistry.selection registry.publicRegistry packet.val.statement).map Prod.snd = + some packet.val.profile at catalog + cases selected : WHIRCallerRegistry.selection registry.publicRegistry packet.val.statement with + | none => simp [selected] at catalog + | some pair => + have registered := (WHIRCallerRegistry.selection_spec registry.publicRegistry packet.val.statement + pair.1 pair.2 selected).1 + simp [ProductionRegistry.publicRegistry,found] at registered) + +structure Input (registry : ProductionRegistry) (Q : Nat) where + packet : RawWHIRKeys.Packet (context registry) Q + proofs : Array PrunedMerklePaths + +structure Accepted (registry : ProductionRegistry) (Q cap : Nat) (record : Record) where + packet : RawWHIRKeys.Packet (context registry) Q + native : AnchoredPhysicalDriver.Accepted (context registry) Q cap packet record + +def verifier (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (input : Input registry Q) : Source cap (Option (Accepted registry Q cap record)) := + (AnchoredPhysicalDriver.verifySource cap .original (packetModel registry (context registry) rfl Q input.packet) (context registry) rfl Q + input.packet record input.proofs).map (Option.map (fun native => ⟨input.packet,native⟩)) + +/-- Actual public opening endpoint: the attacker supplies only bytes and Merkle proofs. The native continuation enforces the complete caller/record parse before opening challenges, and computes acceptance itself. -/ +def verifyAfter (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (attacker : Source cap (Input registry Q)) : Source cap (Option (Accepted registry Q cap record)) := + attacker.bind (verifier cap registry Q record) + +structure Completed (registry : ProductionRegistry) (Q cap : Nat) where + record : Record + accepted : Accepted registry Q cap record + +/-- Original commitment is executed once. Its immutable result, rather than a caller-injected commitment record, is reused by the later attacker and verifier. The advertised value may depend on the original point. -/ +def receiveAndVerify (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (shape : Shape) + (original : DuplexRefinement.State) (header : List E) (advertised : List E → E) + (attacker : Record → Source cap (Input registry Q)) : Source cap (Option (Completed registry Q cap)) := + (AnchoredPhysicalTranscript.receiveSource shape original header advertised).bind fun result => + match result with + | .error _ => .done none + | .ok (_,record) => (verifyAfter cap registry Q record (attacker record)).map + (Option.map (fun accepted => ⟨record,accepted⟩)) + +theorem verifier_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (input : Input registry Q) : + Counts (WHIRPhysicalVerifier.sourceBudget (context registry) Q input.packet) + (verifier cap registry Q record input) := by + apply (Source.map_counted _ _ _).mpr + exact AnchoredPhysicalDriver.verifySource_counted cap .original (packetModel registry (context registry) rfl Q input.packet) + (context registry) rfl Q input.packet record input.proofs + +/-- Every returned packet must satisfy the verifier resource bound on every reachable attacker branch. Neither rejected paths nor original-context backfill calls are discarded from the budget. -/ +theorem verifyAfter_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (attacker : Source cap (Input registry Q)) (a b : Nat) (before : Counts a attacker) + (budget : WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget (context registry) Q input.packet ≤ b) (erase attacker)) : + Counts (a+b) (verifyAfter cap registry Q record attacker) := by + apply (erase_counted _ _).mp + rw [verifyAfter,Source.erase_bind] + apply WHIRSourceBackfill.bind_counted_reachable _ _ _ a b ((erase_counted _ _).mpr before) budget + intro input bounded + exact (erase_counted _ _).mpr (Source.counts_mono (verifier_counted cap registry Q record input) bounded) + +theorem receiveAndVerify_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (shape : Shape) + (original : DuplexRefinement.State) (header : List E) (advertised : List E → E) + (attacker : Record → Source cap (Input registry Q)) (a b : Nat) + (before : ∀ record, Counts a (attacker record)) + (budget : ∀ record, WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget (context registry) Q input.packet ≤ b) (erase (attacker record))) : + Counts (AnchoredPhysicalTranscript.receiveBudget shape+(a+b)) + (receiveAndVerify cap registry Q shape original header advertised attacker) := by + apply Source.bind_counted _ _ (AnchoredPhysicalTranscript.receiveBudget shape) (a+b) + (AnchoredPhysicalTranscript.receiveSource_counted shape original header advertised) + intro result + cases result with + | error error => trivial + | ok result => + apply (Source.map_counted _ _ _).mpr + exact verifyAfter_counted cap registry Q result.2 (attacker result.2) a b (before result.2) (budget result.2) + +structure FreshInput (registry : ProductionRegistry) (Q : Nat) (record : Record) where + packet : RawWHIRKeys.Packet (freshContext registry record) Q + proofs : Array PrunedMerklePaths + +structure FreshAccepted (registry : ProductionRegistry) (Q cap : Nat) (record : Record) where + packet : RawWHIRKeys.Packet (freshContext registry record) Q + native : AnchoredPhysicalDriver.Accepted (freshContext registry record) Q cap packet record + +/-- The saved record comes from the original receiver. A fresh attacker supplies only its new packet and paths, never a replacement record or acceptance payload. -/ +def verifierFresh (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (input : FreshInput registry Q record) : Source cap (Option (FreshAccepted registry Q cap record)) := + (AnchoredPhysicalDriver.verifySource cap .fresh + (packetModel registry (freshContext registry record) rfl Q input.packet) + (freshContext registry record) rfl Q input.packet record input.proofs).map + (Option.map (fun native => ⟨input.packet,native⟩)) + +def verifyFreshAfter (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (attacker : Source cap (FreshInput registry Q record)) : Source cap (Option (FreshAccepted registry Q cap record)) := + attacker.bind (verifierFresh cap registry Q record) + +theorem verifierFresh_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (input : FreshInput registry Q record) : + Counts (WHIRPhysicalVerifier.sourceBudget (freshContext registry record) Q input.packet) + (verifierFresh cap registry Q record input) := by + apply (Source.map_counted _ _ _).mpr + exact AnchoredPhysicalDriver.verifySource_counted cap .fresh + (packetModel registry (freshContext registry record) rfl Q input.packet) + (freshContext registry record) rfl Q input.packet record input.proofs + +theorem verifyFreshAfter_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (record : Record) + (attacker : Source cap (FreshInput registry Q record)) (a b : Nat) (before : Counts a attacker) + (budget : WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget (freshContext registry record) Q input.packet ≤ b) (erase attacker)) : + Counts (a+b) (verifyFreshAfter cap registry Q record attacker) := by + apply (erase_counted _ _).mp + rw [verifyFreshAfter,Source.erase_bind] + apply WHIRSourceBackfill.bind_counted_reachable _ _ _ a b ((erase_counted _ _).mpr before) budget + intro input bounded + exact (erase_counted _ _).mpr (Source.counts_mono (verifierFresh_counted cap registry Q record input) bounded) + +structure FreshCompleted (registry : ProductionRegistry) (Q cap : Nat) where + record : Record + accepted : FreshAccepted registry Q cap record + +/-- Source-owned original receiver followed by a genuinely fresh caller/session continuation. The retained record is the only link between their transcripts. -/ +def receiveAndFreshVerify (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (shape : Shape) + (original : DuplexRefinement.State) (header : List E) (advertised : List E → E) + (attacker : (record : Record) → Source cap (FreshInput registry Q record)) : + Source cap (Option (FreshCompleted registry Q cap)) := + (AnchoredPhysicalTranscript.receiveSource shape original header advertised).bind fun result => + match result with + | .error _ => .done none + | .ok (_,record) => (verifyFreshAfter cap registry Q record (attacker record)).map + (Option.map (fun accepted => ⟨record,accepted⟩)) + +theorem receiveAndFreshVerify_counted (cap : Nat) (registry : ProductionRegistry) (Q : Nat) (shape : Shape) + (original : DuplexRefinement.State) (header : List E) (advertised : List E → E) + (attacker : (record : Record) → Source cap (FreshInput registry Q record)) (a b : Nat) + (before : ∀ record, Counts a (attacker record)) + (budget : ∀ record, WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget (freshContext registry record) Q input.packet ≤ b) + (erase (attacker record))) : + Counts (AnchoredPhysicalTranscript.receiveBudget shape+(a+b)) + (receiveAndFreshVerify cap registry Q shape original header advertised attacker) := by + apply Source.bind_counted _ _ (AnchoredPhysicalTranscript.receiveBudget shape) (a+b) + (AnchoredPhysicalTranscript.receiveSource_counted shape original header advertised) + intro result + cases result with + | error error => trivial + | ok result => + apply (Source.map_counted _ _ _).mpr + exact verifyFreshAfter_counted cap registry Q result.2 (attacker result.2) a b (before result.2) (budget result.2) + +end Whir.AnchoredSourcePacket + diff --git a/verification/whir/Whir/AuthenticatedResetSmoke.lean b/verification/whir/Whir/AuthenticatedResetSmoke.lean new file mode 100644 index 000000000..7387c1414 --- /dev/null +++ b/verification/whir/Whir/AuthenticatedResetSmoke.lean @@ -0,0 +1,60 @@ +import Whir.AuthenticatedResetCollector + +/-! Compiled, actual-verifier fixtures: a zero honest prover, a partially +accepting withholding prover, and malformed query tags. No probability space +or field-element enumeration is evaluated by these executable tests. -/ +namespace Whir.AuthenticatedResetSmoke +open Concrete Protocol CausalGame KnowledgeExtraction AuthenticatedResetSupport + +def config : Config := ⟨3, #[1, 1], #[1, 1], #[2, 2], #[0, 0]⟩ +def input : Public := ⟨config, 1, tab 8 (fun _ => #[0]), #[]⟩ +def message : Message E := ⟨0, 0⟩ + +def honest : Strategy := fun _ _ batch => + match batch with + | .initial _ => .initial message + | .fold level _ _ => .fold message + (if level = 0 then some (tab 4 fun _ => #[0, 0]) else none) + (if level = 1 then #[0, 0] else #[]) + | .ood _ _ _ => .ood ⟨0, message⟩ + | .query level _ _ => .query (tab 2 fun _ => if level = 0 then #[0] else #[0, 0]) message + | .tail _ _ => .tail message + +def withholding : Strategy := fun statement past batch => + match batch with + | .query 0 squeezes _ => + if squeezes[0]!.c0 == 1 then .query #[] message else honest statement past batch + | _ => honest statement past batch + +def malformed : Strategy := fun statement past batch => + match batch with + | .query _ _ _ => .tail message + | _ => honest statement past batch + +def tape (x : K) : Tape config := + (0, (fun i => (fun _ => 0, (fun _ _ => 0), + (fun _ => if i.val = 0 then E.ofK x else 0), 0)), fun _ => 0) + +def check : IO Unit := do + let level : Fin config.folds.size := ⟨0, by decide⟩ + let tapes := [tape 0, tape 1] + let honestProver : CommittedProver := ⟨input, honest⟩ + let withholdingProver : CommittedProver := ⟨input, withholding⟩ + let malformedProver : CommittedProver := ⟨input, malformed⟩ + let h := collectedRecords honestProver level 3 tapes + let w := collectedRecords withholdingProver level 3 tapes + let m := collectedRecords malformedProver level 3 tapes + let result := runRewind input withholding 5 (collectionFuel input tapes) + (collectAcceptedProgram input level 3 tapes (fun _ => none)) + if experiment input honest (tape 0) != true || experiment input honest (tape 1) != true then + throw (IO.userError "honest verifier trial rejected") + if experiment input withholding (tape 0) != true || experiment input withholding (tape 1) != false then + throw (IO.userError "withholding acceptance gate failed") + if experiment input malformed (tape 0) != false then + throw (IO.userError "malformed tag accepted") + if h.length != 4 || w.length != 2 || m.length != 0 || result.responseCalls != 30 then + throw (IO.userError "collected data/replay count mismatch") + IO.println s!"actual verifier: honest 2/2, withholding 1/2, malformed 0/2; records {h.length}/{w.length}/{m.length}; response/replay calls {result.responseCalls}" +end Whir.AuthenticatedResetSmoke + +def main : IO Unit := Whir.AuthenticatedResetSmoke.check diff --git a/verification/whir/Whir/ByteCodec.lean b/verification/whir/Whir/ByteCodec.lean index 02a884e83..06d9ed34c 100644 --- a/verification/whir/Whir/ByteCodec.lean +++ b/verification/whir/Whir/ByteCodec.lean @@ -9,10 +9,23 @@ Fiat–Shamir security claim for either transcript version. -/ namespace Whir.ByteCodec open Concrete FiatShamirGame -def encodeNat : (n : Nat) → Nat → (Fin n → Byte) - | 0, _, i => Fin.elim0 i - | n + 1, x, i => Fin.cases ⟨x % 256, Nat.mod_lt _ (by decide)⟩ - (encodeNat n (x / 256)) i +/-- Select a little-endian digit directly. Recursive `Fin.cases` indexing makes +compiled callers repeatedly traverse predecessor functions. -/ +def encodeNat (n x : Nat) : Fin n → Byte := + fun i => ⟨(x / 256^i.val)%256,Nat.mod_lt _ (by decide)⟩ + +theorem encodeNat_zero (n x : Nat) : + encodeNat (n+1) x 0 = ⟨x%256,Nat.mod_lt _ (by decide)⟩ := by + apply Fin.ext + simp [encodeNat] + +theorem encodeNat_succ (n x : Nat) (i : Fin n) : + encodeNat (n+1) x i.succ = encodeNat n (x/256) i := by + apply Fin.ext + simp only [encodeNat,Fin.val_succ] + rw [Nat.div_div_eq_div_mul,pow_succ] + congr 2 + omega def decodeNat : (n : Nat) → (Fin n → Byte) → Nat | 0, _ => 0 @@ -35,7 +48,7 @@ theorem decodeNat_encodeNat (n x : Nat) (h : x < 256 ^ n) : have hd : x / 256 < 256 ^ n := by apply (Nat.div_lt_iff_lt_mul (by decide)).mpr simpa [pow_succ] using h - simp only [decodeNat, encodeNat, Fin.cases_zero, Fin.cases_succ] + simp only [decodeNat,encodeNat_zero,encodeNat_succ] rw [ih _ hd] exact Nat.mod_add_div x 256 @@ -48,7 +61,8 @@ theorem encodeNat_decodeNat (n : Nat) (b : Fin n → Byte) : refine Fin.cases ?_ (fun j => ?_) i · apply Fin.ext simp [encodeNat, decodeNat, Nat.add_mod, Nat.mod_eq_of_lt (b 0).isLt] - · simp only [encodeNat, decodeNat, Fin.cases_succ] + · rw [encodeNat_succ] + simp only [decodeNat] rw [Nat.add_mul_div_left _ _ (by decide)] rw [Nat.div_eq_of_lt (b 0).isLt, Nat.zero_add] exact congrFun (ih (fun i => b i.succ)) j @@ -56,15 +70,7 @@ theorem encodeNat_decodeNat (n : Nat) (b : Fin n → Byte) : /-- Byte `i` is exactly the base-256 little-endian digit, not merely an arbitrary injective representation of the machine word. -/ theorem encodeNat_byte (n x : Nat) (i : Fin n) : - (encodeNat n x i).val = (x / 256 ^ i.val) % 256 := by - induction n generalizing x with - | zero => exact Fin.elim0 i - | succ n ih => - refine Fin.cases ?_ (fun j => ?_) i - · simp [encodeNat] - · simp only [encodeNat, Fin.cases_succ, Fin.val_succ] - rw [ih] - simp [Nat.div_div_eq_div_mul, pow_succ, Nat.mul_comm] + (encodeNat n x i).val = (x / 256 ^ i.val) % 256 := rfl def encodeK (x : K) : Fin 8 → Byte := encodeNat 8 x.toNat def decodeK (b : Fin 8 → Byte) : K := UInt64.ofNat (decodeNat 8 b) diff --git a/verification/whir/Whir/ConcreteRowExtraction.lean b/verification/whir/Whir/ConcreteRowExtraction.lean index 730ced57f..25b855089 100644 --- a/verification/whir/Whir/ConcreteRowExtraction.lean +++ b/verification/whir/Whir/ConcreteRowExtraction.lean @@ -281,19 +281,79 @@ uses no extension-field arithmetic. The field counter includes Gao's nodal product, Lagrange interpolation, fueled Euclidean loop with actual degree drop, final remainder/division, original novel-basis preparation, coefficient peeling and the guarded projection. -/ -def countedExtractRow (n rate : Nat) (noWrap : n + rate ≤ 64) - (received : Vector E (domain (n + rate) noWrap).n) : Option (Array K) × Nat := - let decoded := ReedSolomonExtraction.countedDecode 382 (2 ^ n) (domain (n + rate) noWrap) received +def countedExtractRowPrepared (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) + (nodal : CPolynomial E × Nat) : Option (Array K) × Nat := + let decoded := ReedSolomonExtraction.countedDecodePrepared 382 (2 ^ n) + (domain (n + rate) noWrap) received nodal match decoded.1 with | none => (none, decoded.2) | some p => let projected := countedBaseWords n p (projected.1, decoded.2 + projected.2) +def countedExtractRow (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : Option (Array K) × Nat := + countedExtractRowPrepared n rate noWrap received + (ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)) + +theorem countedExtractRow_eq (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : + countedExtractRow n rate noWrap received = + let decoded := ReedSolomonExtraction.countedDecode 382 (2 ^ n) + (domain (n + rate) noWrap) received + match decoded.1 with + | none => (none,decoded.2) + | some p => let projected := countedBaseWords n p + (projected.1,decoded.2+projected.2) := rfl + +theorem countedExtractRowPrepared_value_cost_independent (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) (nodal : CPolynomial E) (cost : Nat) : + (countedExtractRowPrepared n rate noWrap received (nodal,cost)).1 = + (countedExtractRowPrepared n rate noWrap received (nodal,0)).1 := by + unfold countedExtractRowPrepared + dsimp only + rw [ReedSolomonExtraction.countedDecodePrepared_value_cost_independent] + split <;> simp_all + +theorem countedExtractRowPrepared_cost (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) (nodal : CPolynomial E) (cost : Nat) : + (countedExtractRowPrepared n rate noWrap received (nodal,cost)).2 = + cost + (countedExtractRowPrepared n rate noWrap received (nodal,0)).2 := by + unfold countedExtractRowPrepared + dsimp only + rw [ReedSolomonExtraction.countedDecodePrepared_value_cost_independent, + ReedSolomonExtraction.countedDecodePrepared_cost] + split <;> simp_all [Nat.add_assoc] + +theorem countedExtractRow_shared_value (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : + (countedExtractRowPrepared n rate noWrap received + ((ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)).1,0)).1 = + (countedExtractRow n rate noWrap received).1 := by + simpa only [countedExtractRow,Prod.mk.eta] using + (countedExtractRowPrepared_value_cost_independent n rate noWrap received + (ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)).1 + (ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)).2).symm + +theorem countedExtractRow_shared_cost (n rate : Nat) (noWrap : n + rate ≤ 64) + (received : Vector E (domain (n + rate) noWrap).n) : + (countedExtractRow n rate noWrap received).2 = + (ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)).2 + + (countedExtractRowPrepared n rate noWrap received + ((ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)).1,0)).2 := by + simpa only [countedExtractRow,Prod.mk.eta] using + countedExtractRowPrepared_cost n rate noWrap received + (ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)).1 + (ReedSolomonExtraction.countedNodal (domain (n + rate) noWrap)).2 + +#print axioms countedExtractRow_shared_value +#print axioms countedExtractRow_shared_cost + theorem countedExtractRow_value (n rate : Nat) (noWrap : n + rate ≤ 64) (received : Vector E (domain (n + rate) noWrap).n) : (countedExtractRow n rate noWrap received).1 = extractRow n rate noWrap received := by - simp only [countedExtractRow, ReedSolomonExtraction.countedDecode_value, extractRow, decode] + simp only [countedExtractRow_eq, ReedSolomonExtraction.countedDecode_value, extractRow, decode] split <;> simp_all [countedBaseWords_value] /-- Explicit polynomial field-arithmetic budget. `N=2^(n+rate)`, `k=2^n`; @@ -310,7 +370,7 @@ theorem countedExtractRow_cost (n rate : Nat) (noWrap : n + rate ≤ 64) have decoderCost := ReedSolomonExtraction.countedDecode_cost 382 (2 ^ n) (domain (n + rate) noWrap) received rw [domain_size] at decoderCost - unfold countedExtractRow + rw [countedExtractRow_eq] cases output : (ReedSolomonExtraction.countedDecode 382 (2 ^ n) (domain (n + rate) noWrap) received).1 with | none => diff --git a/verification/whir/Whir/DeployedTranscript.lean b/verification/whir/Whir/DeployedTranscript.lean new file mode 100644 index 000000000..43ed4f3e3 --- /dev/null +++ b/verification/whir/Whir/DeployedTranscript.lean @@ -0,0 +1,290 @@ +import Whir.PublicCompressionProgram + +/-! HISTORICAL byte-level hand-port of the pre-#552 tagged-scalar transcript +observed in `crates/fiat_shamir/src/lib.rs` before the #552 merge. This is NOT +the current merged #552 framed-byte duplex. The primitive is shared with +ordinary hashing and exposes its full chosen-CV interface. These historical +source equations assert neither Rust compiler equivalence nor security. -/ +namespace Whir.DeployedTranscript +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram TypedOracleCompiler + +/-- Exactly the source's three reachable pending-buffer shapes. -/ +inductive Pending where + | empty + | one (last : Scalar24) + | two (first last : Scalar24) + +def Pending.count : Pending → Nat + | .empty => 0 + | .one _ => 1 + | .two _ _ => 2 + +def Pending.first : Pending → Scalar24 + | .two first _ => first + | _ => fun _ => 0 + +def Pending.last : Pending → Scalar24 + | .empty => fun _ => 0 + | .one last | .two _ last => last + +/-- Tags are in block word 7. Counter 64 never encodes the role. -/ +inductive Role where + | observe | squeeze | powBase | powNonce + deriving DecidableEq + +def Role.word : Role → Nat + | .observe => 1 + | .squeeze => 2 + | .powBase => 3 + | .powNonce => 4 + +/-- Words 0..2 = first scalar, word 3 = count, words 4..6 = last +scalar, word 7 = role, all little endian as in `step_block`. -/ +def stepBlock (pending : Pending) (role : Role) : Block64 := fun i => + if h : i.val < 24 then pending.first ⟨i.val,h⟩ + else if h' : i.val < 32 then ByteCodec.encodeNat 8 pending.count ⟨i.val-24,by omega⟩ + else if h'' : i.val < 56 then pending.last ⟨i.val-32,by omega⟩ + else ByteCodec.encodeNat 8 role.word ⟨i.val-56,by omega⟩ + +def stepNode (cv : Digest32) (pending : Pending) (role : Role) : Node := + ⟨cv,stepBlock pending role,UInt64.ofNat 64,true⟩ + +def step (C : PrimitiveOracle) (cv : Digest32) (pending : Pending) (role : Role) : Digest32 := + C (stepNode cv pending role) + +structure Context where + cv : Digest32 + pending : Pending + +def emptyContext (cv : Digest32) : Context := ⟨cv,.empty⟩ + +/-- Source `new` uses ordinary 64-byte hashing from the parameter IV; +its `iv` argument is the first message half, not the primitive chaining value. -/ +def seedNode (iv publicInput : Digest32) : Node := + ⟨DuplexCompression.parameterIV,ByteCodec.pairBytes (iv,publicInput),UInt64.ofNat 64,true⟩ + +def new (C : PrimitiveOracle) (iv publicInput : Digest32) : Context := + emptyContext (C (seedNode iv publicInput)) + +/-- Source `from_label` uses the ordinary variable-length hash entry path, +including the actual length counters and final flag. No fixed seed is imposed. -/ +def fromLabel (C : PrimitiveOracle) (label : List Byte) : Context := + emptyContext (PublicMerkleLog.hash C label) + +/-- Nonmutating `state()` absorbs a nonempty buffer under tag 1. -/ +def exportedState (C : PrimitiveOracle) (context : Context) : Digest32 := + match context.pending with + | .empty => context.cv + | _ => step C context.cv context.pending .observe + +def stateCost (context : Context) : Nat := + match context.pending with + | .empty => 0 + | _ => 1 + +def flush (C : PrimitiveOracle) (context : Context) : Context := + emptyContext (exportedState C context) + +def observe (C : PrimitiveOracle) (context : Context) (scalar : Scalar24) : Context := + match context.pending with + | .empty => ⟨context.cv,.one scalar⟩ + | .one previous => ⟨context.cv,.two previous scalar⟩ + | .two _ _ => ⟨exportedState C context,.one scalar⟩ + +def observeCost (context : Context) : Nat := + match context.pending with + | .two _ _ => 1 + | _ => 0 + +/-- The challenge comprises exactly the first three 64-bit words. -/ +def challenge (digest : Digest32) : Scalar24 := fun i => digest ⟨i.val,by omega⟩ + +def sample (C : PrimitiveOracle) (context : Context) : Context × Scalar24 := + let digest := step C context.cv context.pending .squeeze + (emptyContext digest,challenge digest) + +def powBase (C : PrimitiveOracle) (context : Context) : Digest32 := + step C (exportedState C context) .empty .powBase + +def absorbNonce (C : PrimitiveOracle) (context : Context) (nonce : Scalar24) : Context := + emptyContext (step C (exportedState C context) (.one nonce) .powNonce) + +/-- This predicate uses ordinary hashing, not keyed transcript `step`. +The deployed search and verification evaluate this shared primitive as well. -/ +def powNode (base : Digest32) (nonce : Scalar24) : Node := + ⟨DuplexCompression.parameterIV, + ByteCodec.pairBytes (base,fun i => + if h : i.val < 24 then nonce ⟨i.val,h⟩ + else ByteCodec.encodeNat 8 4 ⟨i.val-24,by omega⟩),UInt64.ofNat 64,true⟩ + +@[simp] theorem sample_context (C : PrimitiveOracle) (context : Context) : + (sample C context).1 = emptyContext (C (stepNode context.cv context.pending .squeeze)) := rfl + +@[simp] theorem sample_challenge (C : PrimitiveOracle) (context : Context) : + (sample C context).2 = challenge (sample C context).1.cv := rfl + +@[simp] theorem sample_pending (C : PrimitiveOracle) (context : Context) : + (sample C context).1.pending = .empty := rfl + +@[simp] theorem observe_empty (C : PrimitiveOracle) (cv : Digest32) (x : Scalar24) : + observe C (emptyContext cv) x = ⟨cv,.one x⟩ := rfl + +@[simp] theorem observe_second (C : PrimitiveOracle) (cv : Digest32) (x y : Scalar24) : + observe C ⟨cv,.one x⟩ y = ⟨cv,.two x y⟩ := rfl + +@[simp] theorem observe_third (C : PrimitiveOracle) (cv : Digest32) (x y z : Scalar24) : + observe C ⟨cv,.two x y⟩ z = ⟨step C cv (.two x y) .observe,.one z⟩ := rfl + +/-- Exact operational lowering counts even construction calls whose internal +answers are not publicly exposed. Public primitive calls share this same table. -/ +def stateCalls : (context : Context) → Computation Digest32 (stateCost context) + | ⟨cv,.empty⟩ => .ret cv + | ⟨cv,.one x⟩ => .draw (stepNode cv (.one x) .observe) (fun d => .ret d) + | ⟨cv,.two x y⟩ => .draw (stepNode cv (.two x y) .observe) (fun d => .ret d) + +def observeCalls : (context : Context) → Scalar24 → Computation Context (observeCost context) + | ⟨cv,.empty⟩, scalar => .ret ⟨cv,.one scalar⟩ + | ⟨cv,.one previous⟩, scalar => .ret ⟨cv,.two previous scalar⟩ + | ⟨cv,.two x y⟩, scalar => .draw (stepNode cv (.two x y) .observe) + (fun d => .ret ⟨d,.one scalar⟩) + +def sampleCalls (context : Context) : Computation (Context × Scalar24) 1 := + .draw (stepNode context.cv context.pending .squeeze) (fun d => .ret (emptyContext d,challenge d)) + +def newCalls (iv publicInput : Digest32) : Computation Context 1 := + .draw (seedNode iv publicInput) (fun d => .ret (emptyContext d)) + +def powBaseCalls (context : Context) : Computation Digest32 (stateCost context+1) := + Sampling.bind (stateCalls context) (fun d => + .draw (stepNode d .empty .powBase) (fun answer => .ret answer)) + +def absorbNonceCalls (context : Context) (nonce : Scalar24) : + Computation Context (stateCost context+1) := + Sampling.bind (stateCalls context) (fun d => + .draw (stepNode d (.one nonce) .powNonce) (fun answer => .ret (emptyContext answer))) + +theorem stateCalls_eval (C : PrimitiveOracle) (context : Context) : + Sampling.eval C (stateCalls context) = exportedState C context := by + cases context with + | mk cv pending => cases pending <;> rfl + +theorem observeCalls_eval (C : PrimitiveOracle) (context : Context) (scalar : Scalar24) : + Sampling.eval C (observeCalls context scalar) = observe C context scalar := by + cases context with + | mk cv pending => cases pending <;> rfl + +theorem sampleCalls_eval (C : PrimitiveOracle) (context : Context) : + Sampling.eval C (sampleCalls context) = sample C context := rfl + +theorem newCalls_eval (C : PrimitiveOracle) (iv publicInput : Digest32) : + Sampling.eval C (newCalls iv publicInput) = new C iv publicInput := rfl + +theorem powBaseCalls_eval (C : PrimitiveOracle) (context : Context) : + Sampling.eval C (powBaseCalls context) = powBase C context := by + simp only [powBaseCalls,Sampling.eval_bind,stateCalls_eval] + rfl + +theorem absorbNonceCalls_eval (C : PrimitiveOracle) (context : Context) (nonce : Scalar24) : + Sampling.eval C (absorbNonceCalls context nonce) = absorbNonce C context nonce := by + simp only [absorbNonceCalls,Sampling.eval_bind,stateCalls_eval] + rfl + +def countBytes (block : Block64) : Fin 8 → Byte := fun i => block ⟨i.val+24,by omega⟩ +def roleBytes (block : Block64) : Fin 8 → Byte := fun i => block ⟨i.val+56,by omega⟩ +def firstBytes (block : Block64) : Scalar24 := fun i => block ⟨i.val,by omega⟩ +def lastBytes (block : Block64) : Scalar24 := fun i => block ⟨i.val+32,by omega⟩ + +@[simp] theorem countBytes_stepBlock (pending : Pending) (role : Role) : + countBytes (stepBlock pending role) = ByteCodec.encodeNat 8 pending.count := by + funext i + simp [countBytes,stepBlock,show ¬i.val+24 < 24 by omega,show i.val+24 < 32 by omega] + +@[simp] theorem roleBytes_stepBlock (pending : Pending) (role : Role) : + roleBytes (stepBlock pending role) = ByteCodec.encodeNat 8 role.word := by + funext i + simp [roleBytes,stepBlock,show ¬i.val+56 < 24 by omega, + show ¬i.val+56 < 32 by omega,show ¬i.val+56 < 56 by omega] + +@[simp] theorem firstBytes_stepBlock (pending : Pending) (role : Role) : + firstBytes (stepBlock pending role) = pending.first := by + funext i + simp [firstBytes,stepBlock,i.isLt] + +@[simp] theorem lastBytes_stepBlock (pending : Pending) (role : Role) : + lastBytes (stepBlock pending role) = pending.last := by + funext i + simp [lastBytes,stepBlock,show ¬i.val+32 < 24 by omega, + show ¬i.val+32 < 32 by omega,show i.val+32 < 56 by omega] + +theorem stepBlock_injective {a b : Pending} {r s : Role} + (same : stepBlock a r = stepBlock b s) : a = b ∧ r = s := by + have count := congrArg (ByteCodec.decodeNat 8 ∘ countBytes) same + have role := congrArg (ByteCodec.decodeNat 8 ∘ roleBytes) same + have first := congrArg firstBytes same + have last := congrArg lastBytes same + have ac : a.count < 256^8 := by cases a <;> norm_num [Pending.count] + have bc : b.count < 256^8 := by cases b <;> norm_num [Pending.count] + have rr : r.word < 256^8 := by cases r <;> norm_num [Role.word] + have ss : s.word < 256^8 := by cases s <;> norm_num [Role.word] + simp only [Function.comp_apply,countBytes_stepBlock, + ByteCodec.decodeNat_encodeNat _ _ ac,ByteCodec.decodeNat_encodeNat _ _ bc] at count + simp only [Function.comp_apply,roleBytes_stepBlock, + ByteCodec.decodeNat_encodeNat _ _ rr,ByteCodec.decodeNat_encodeNat _ _ ss] at role + simp only [firstBytes_stepBlock] at first + simp only [lastBytes_stepBlock] at last + constructor + · cases a <;> cases b <;> simp_all [Pending.count,Pending.first,Pending.last] + · cases r <;> cases s <;> simp_all [Role.word] + +/-- The readonly original CV plus pending buffer uniquely names a squeeze +input. This is a codec theorem, not a hash-binding assumption. -/ +theorem sampleNode_injective {a b : Context} + (same : stepNode a.cv a.pending .squeeze = stepNode b.cv b.pending .squeeze) : + a = b := by + have hc := congrArg Node.cv same + have hb := congrArg Node.block same + have hp := (stepBlock_injective hb).1 + cases a; cases b + simp_all [stepNode] + +/-- Variable-length ordinary hashing for the source's `from_label` constructor: +every chunk has its actual counter and final flag, including an empty label. -/ +def labelChunkCalls (cv : Digest32) (count : Nat) : + (chunks : List (List Byte)) → Computation (Option Digest32) chunks.length + | [] => .ret none + | [b] => .draw (PublicMerkleLog.node cv count b true) (fun d => .ret (some d)) + | b :: next :: rest => .draw (PublicMerkleLog.node cv count b false) + (fun d => labelChunkCalls d (count+b.length) (next::rest)) + +def fromLabelCalls (label : List Byte) : + Computation Context (PublicMerkleLog.chunks label).length := + mapResult (fun out => emptyContext (out.getD DuplexCompression.parameterIV)) + (labelChunkCalls DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks label)) + +theorem labelChunkCalls_eval (C : PrimitiveOracle) (cv : Digest32) (count : Nat) + (chunks : List (List Byte)) : + Sampling.eval C (labelChunkCalls cv count chunks) = + PublicMerkleLog.run (fun n => some (C n)) cv count chunks := by + induction chunks generalizing cv count with + | nil => rfl + | cons b rest ih => + cases rest with + | nil => rfl + | cons next rest => + simpa only [labelChunkCalls,Sampling.eval,PublicMerkleLog.run, + Option.bind_eq_bind,Option.bind_some] using ih (C (PublicMerkleLog.node cv count b false)) + (count+b.length) + +theorem fromLabelCalls_eval (C : PrimitiveOracle) (label : List Byte) : + Sampling.eval C (fromLabelCalls label) = fromLabel C label := by + simp only [fromLabelCalls,eval_mapResult,labelChunkCalls_eval,fromLabel,PublicMerkleLog.hash] + +#print axioms stepBlock_injective +#print axioms sampleNode_injective +#print axioms fromLabelCalls_eval + +#print axioms sampleCalls_eval +#print axioms powBaseCalls_eval +#print axioms absorbNonceCalls_eval +end Whir.DeployedTranscript diff --git a/verification/whir/Whir/DeployedTranscriptCoupling.lean b/verification/whir/Whir/DeployedTranscriptCoupling.lean new file mode 100644 index 000000000..4ae53762a --- /dev/null +++ b/verification/whir/Whir/DeployedTranscriptCoupling.lean @@ -0,0 +1,136 @@ +import Whir.DeployedTranscript +import Whir.PublicMerkleProbability + +/-! HISTORICAL public finite-compression factorization for the pre-#552 +context-key game. The ideal key is the full-CV/pending compression input, not +a semantic message history. This is NOT a full-message RO indifferentiability +claim and does NOT instantiate the current merged #552 mode. Public primitive +access, all output bits, ratchets, and adaptive computations are retained. -/ +namespace Whir.DeployedTranscriptCoupling +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram TypedOracleCompiler DeployedTranscript +open scoped BigOperators + +abbrev Tail8 := Fin 8 → Byte +abbrev ChallengeOracle := Node → Scalar24 +abbrev TailOracle := Node → Tail8 + +/-- The unexposed fourth word; it remains part of every public primitive answer +and every readonly source context after sampling. -/ +def tail (digest : Digest32) : Tail8 := fun i => digest ⟨i.val+24,by omega⟩ + +def assemble (low : Scalar24) (high : Tail8) : Digest32 := fun i => + if h : i.val < 24 then low ⟨i.val,h⟩ else high ⟨i.val-24,by omega⟩ + +@[simp] theorem challenge_assemble (low : Scalar24) (high : Tail8) : + challenge (assemble low high) = low := by + funext i + simp [challenge,assemble,i.isLt] + +@[simp] theorem tail_assemble (low : Scalar24) (high : Tail8) : + tail (assemble low high) = high := by + funext i + simp [tail,assemble,show ¬i.val+24 < 24 by omega] + +@[simp] theorem assemble_split (digest : Digest32) : + assemble (challenge digest) (tail digest) = digest := by + funext i + unfold assemble + split + · rfl + · simp only [tail] + congr 1 + apply Fin.ext + dsimp + omega + +def digestEquiv : Digest32 ≃ Scalar24 × Tail8 where + toFun digest := (challenge digest,tail digest) + invFun pair := assemble pair.1 pair.2 + left_inv := assemble_split + right_inv pair := by rcases pair with ⟨low,high⟩; simp + +/-- The actual context-key simulator: one RO lookup and one memoized random +64-bit extension per public primitive input. No observer class is restricted. -/ +def publicOracle (ro : ChallengeOracle) (seed : TailOracle) : PrimitiveOracle := + fun input => assemble (ro input) (seed input) + +/-- Every public primitive input is retained, including arbitrary chosen CVs +and inputs outside the source's step grammar. -/ +def simulatorAnswer (seed : TailOracle) (input : Node) : + Sampling Node (fun _ => Scalar24) Digest32 1 := + .draw input (fun answer => .ret (assemble answer (seed input))) + +theorem simulatorAnswer_eval (ro : ChallengeOracle) (seed : TailOracle) (input : Node) : + Sampling.eval ro (simulatorAnswer seed input) = publicOracle ro seed input := rfl + +/-- Actual ideal source sample: the construction directly requests its RO +coordinate, retains the random fourth word, and ratchets the full chaining CV. -/ +def idealSample (ro : ChallengeOracle) (seed : TailOracle) (context : Context) : + Context × Scalar24 := + let input := stepNode context.cv context.pending .squeeze + (emptyContext (assemble (ro input) (seed input)),ro input) + +theorem idealSample_source (ro : ChallengeOracle) (seed : TailOracle) (context : Context) : + idealSample ro seed context = DeployedTranscript.sample (publicOracle ro seed) context := by + simp [idealSample,DeployedTranscript.sample,DeployedTranscript.step,publicOracle] + +/-- A bijection between the ACTUAL uniformly sampled 256-bit compression table +and the independent 192-bit context-key RO plus memoized 64-bit simulator seed. -/ +def tableEquiv : PrimitiveOracle ≃ ChallengeOracle × TailOracle where + toFun C := (fun n => challenge (C n),fun n => tail (C n)) + invFun pair := publicOracle pair.1 pair.2 + left_inv C := by funext n; exact assemble_split (C n) + right_inv pair := by + apply Prod.ext + · funext n + exact challenge_assemble (pair.1 n) (pair.2 n) + · funext n + exact tail_assemble (pair.1 n) (pair.2 n) + +@[simp] theorem tableEquiv_inverse (coins : ChallengeOracle × TailOracle) : + tableEquiv.symm coins = publicOracle coins.1 coins.2 := rfl + +/-- Exact finite probabilities for arbitrary adaptive chosen-CV computations, +including source calls lowered by DeployedTranscript's checked equations. +The payoff may examine the complete public view and final readonly contexts. -/ +theorem public_table_expectation [Fintype PrimitiveOracle] + [Fintype ChallengeOracle] [Fintype TailOracle] (payoff : PrimitiveOracle → ℚ) : + average payoff = average (fun coins : ChallengeOracle × TailOracle => + payoff (publicOracle coins.1 coins.2)) := by + have h := RawOracleCoupling.average_equiv tableEquiv + (fun coins : ChallengeOracle × TailOracle => payoff (tableEquiv.symm coins)) + simpa only [Equiv.symm_apply_apply,tableEquiv_inverse] using h + +noncomputable def realProbability {R : Type} {Q : Nat} + (program : Computation R Q) (D : R → Bool) : ℚ := + distinguishProbability (fun C : PrimitiveOracle => Sampling.eval C program) D + +noncomputable def idealProbability {R : Type} {Q : Nat} + (program : Computation R Q) (D : R → Bool) : ℚ := + distinguishProbability (fun coins : ChallengeOracle × TailOracle => + Sampling.eval (publicOracle coins.1 coins.2) program) D + +/-- Zero loss in this precise context-key game, with no soundness premise, +no excluded observer, no assumed collision certificate, and no fixed-BLAKE +replacement. It does not promote context keys to full semantic histories. -/ +theorem actual_context_game_coupling {R : Type} {Q : Nat} + (program : Computation R Q) (D : R → Bool) : + realProbability program D = idealProbability program D := by + unfold realProbability idealProbability + rw [distinguish_average (inferInstance : Fintype PrimitiveOracle), + distinguish_average (inferInstance : Fintype (ChallengeOracle × TailOracle))] + exact public_table_expectation _ + +/-- Uniform source challenges have 192 bits, not 256. -/ +theorem challenge_card : Fintype.card Scalar24 = 2^192 := by + norm_num [Scalar24,Byte,Fintype.card_fun] + +/-- The independent simulator extension has exactly 64 bits. -/ +theorem tail_card : Fintype.card Tail8 = 2^64 := by + norm_num [Tail8,Byte,Fintype.card_fun] + +#print axioms public_table_expectation +#print axioms idealSample_source +#print axioms actual_context_game_coupling +end Whir.DeployedTranscriptCoupling diff --git a/verification/whir/Whir/DeployedTranscriptEntryAlias.lean b/verification/whir/Whir/DeployedTranscriptEntryAlias.lean new file mode 100644 index 000000000..ffe4f812f --- /dev/null +++ b/verification/whir/Whir/DeployedTranscriptEntryAlias.lean @@ -0,0 +1,92 @@ +import Whir.DeployedTranscriptCoupling + +/-! HISTORICAL pre-#552 constructor alias and exact finite probability gap. +It rules out independent constructor-tagged keys for that historical source, +not for the current merged #552 mode. The historical context-key game correctly +identifies the alias; no whole-message RO or current DMV conclusion follows. -/ +namespace Whir.DeployedTranscriptEntryAlias +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open DeployedTranscript + +/-- Both inputs are legal source constructors; no chaining state is injected. -/ +def aliasLabel (iv publicInput : Digest32) : List Byte := + List.ofFn (ByteCodec.pairBytes (iv,publicInput)) + +theorem constructors_alias (C : PrimitiveOracle) (iv publicInput : Digest32) : + fromLabel C (aliasLabel iv publicInput) = new C iv publicInput := by + have padded_pair : padded (aliasLabel iv publicInput).toArray = + ByteCodec.pairBytes (iv,publicInput) := by + funext i + simp only [padded,aliasLabel,List.getElem?_toArray,List.getElem?_ofFn,i.isLt, + ↓reduceDIte,Option.getD_some] + have length_label : (aliasLabel iv publicInput).length = 64 := List.length_ofFn + have chunks_label : PublicMerkleLog.chunks (aliasLabel iv publicInput) = + [aliasLabel iv publicInput] := by + rw [PublicMerkleLog.chunks] + simp only [length_label,Nat.le_refl,↓reduceIte] + simp only [fromLabel,new,PublicMerkleLog.hash,chunks_label,PublicMerkleLog.run, + Option.getD_some,PublicMerkleLog.node,length_label,Nat.zero_add,padded_pair,seedNode] + +/-- Four actual source calls, including both (identical) seed occurrences and +both squeeze occurrences; the cached primitive input does not waive source cost. -/ +def realExperiment (iv publicInput : Digest32) (C : PrimitiveOracle) : Scalar24 × Scalar24 := + ((DeployedTranscript.sample C (new C iv publicInput)).2, + (DeployedTranscript.sample C (fromLabel C (aliasLabel iv publicInput))).2) + +def equalityObserver (view : Scalar24 × Scalar24) : Bool := decide (view.1 = view.2) + +theorem realExperiment_equal (iv publicInput : Digest32) (C : PrimitiveOracle) : + equalityObserver (realExperiment iv publicInput C) = true := by + simp [equalityObserver,realExperiment,constructors_alias] + +/-- The alternative ideal gives distinct keys to the two constructor histories. +Its table is literally sampled uniformly; no soundness premise is involved. -/ +def separatedIdealExperiment (ro : Bool → Scalar24) : Scalar24 × Scalar24 := + (ro false,ro true) + +noncomputable def realProbability (iv publicInput : Digest32) : ℚ := + distinguishProbability (realExperiment iv publicInput) equalityObserver + +noncomputable def separatedIdealProbability : ℚ := + distinguishProbability separatedIdealExperiment equalityObserver + +theorem real_probability_one (iv publicInput : Digest32) : + realProbability iv publicInput = 1 := by + classical + unfold realProbability + rw [distinguish_average (inferInstance : Fintype PrimitiveOracle)] + simp only [realExperiment_equal,ite_true] + exact average_const _ + +theorem separated_ideal_probability : separatedIdealProbability = 1 / (2^192 : ℚ) := by + classical + unfold separatedIdealProbability + rw [distinguish_average (inferInstance : Fintype (Bool → Scalar24))] + have indicator (coin : Bool → Scalar24) : + (if equalityObserver (separatedIdealExperiment coin) then (1:ℚ) else 0) = + (if coin false = coin true then (1:ℚ) else 0) := by + by_cases h : coin false = coin true <;> + simp [equalityObserver,separatedIdealExperiment,h] + simp_rw [indicator] + rw [fresh_coordinate false (fun (rest : {b : Bool // b ≠ false} → Scalar24) d => + if d = rest ⟨true,by decide⟩ then (1:ℚ) else 0)] + have uniform (value : Scalar24) : + average (fun d : Scalar24 => if d = value then (1:ℚ) else 0) = + 1 / (2^192 : ℚ) := by + simp [average] + norm_num + simp only [uniform,average_const] + +/-- Exact finite distinguishing gap caused by separating actual aliases. +Canonical original-context/source-byte keys are necessary for a small-loss claim. -/ +theorem separated_constructor_gap (iv publicInput : Digest32) : + |realProbability iv publicInput - separatedIdealProbability| = + 1 - 1 / (2^192 : ℚ) := by + rw [real_probability_one,separated_ideal_probability] + rw [abs_of_nonneg] + norm_num + +#print axioms constructors_alias +#print axioms separated_ideal_probability +#print axioms separated_constructor_gap +end Whir.DeployedTranscriptEntryAlias diff --git a/verification/whir/Whir/DeployedTranscriptGame.lean b/verification/whir/Whir/DeployedTranscriptGame.lean new file mode 100644 index 000000000..eafa062db --- /dev/null +++ b/verification/whir/Whir/DeployedTranscriptGame.lean @@ -0,0 +1,243 @@ +import Whir.DeployedTranscriptCoupling + +/-! HISTORICAL pre-#552 tagged-scalar source game, not the current merged mode. +Contexts are created only through the two historical source constructors or +copied from live contexts. Readonly snapshots do not permit injection. The full +public view retains scalars, 256-bit states, chosen-CV calls, and contexts. +The ideal experiment is context-key RO, NOT full-message RO or current DMV. -/ +namespace Whir.DeployedTranscriptGame +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram TypedOracleCompiler DeployedTranscript +open DeployedTranscriptCoupling (ChallengeOracle TailOracle publicOracle) + +inductive CompressionProgram (R : Type) where + | done (result : R) + | ask (input : Node) (next : Digest32 → CompressionProgram R) + +namespace CompressionProgram +variable {R S : Type} + +def bind : CompressionProgram R → (R → CompressionProgram S) → CompressionProgram S + | .done r, next => next r + | .ask input continuation, next => .ask input (fun d => bind (continuation d) next) + +def map (f : R → S) : CompressionProgram R → CompressionProgram S + | .done r => .done (f r) + | .ask input next => .ask input (fun d => map f (next d)) + +def run (C : PrimitiveOracle) : CompressionProgram R → R × Nat + | .done r => (r,0) + | .ask input next => + let rest := run C (next (C input)) + (rest.1,rest.2+1) + +@[simp] theorem run_bind (C : PrimitiveOracle) (p : CompressionProgram R) + (next : R → CompressionProgram S) : + run C (bind p next) = + ((run C (next (run C p).1)).1,(run C p).2+(run C (next (run C p).1)).2) := by + induction p with + | done => simp [bind,run] + | ask input continuation ih => simp [bind,run,ih,Nat.add_comm,Nat.add_left_comm,Nat.add_assoc] + +@[simp] theorem run_map (C : PrimitiveOracle) (f : R → S) (p : CompressionProgram R) : + run C (map f p) = (f (run C p).1,(run C p).2) := by + induction p with + | done => rfl + | ask input next ih => simp [map,run,ih] + +/-- This is a worst-case reply-by-reply resource certificate, not acceptance +conditioning. Source internals and repeated inputs each pay their full calls. -/ +def Counts : Nat → CompressionProgram R → Prop + | _, .done _ => True + | Q, .ask _ next => 1 ≤ Q ∧ ∀ d, Counts (Q-1) (next d) + +theorem run_counted (C : PrimitiveOracle) (p : CompressionProgram R) (Q : Nat) + (counted : Counts Q p) : (run C p).2 ≤ Q := by + induction p generalizing Q with + | done => simp [run] + | ask input next ih => + have ht := ih (C input) (Q-1) (counted.2 _) + simp only [run] + have hc := counted.1 + omega + +def lower {Q : Nat} : Computation R Q → CompressionProgram R + | .ret r => .done r + | .draw input next => .ask input (fun d => lower (next d)) + +theorem lower_eval {Q : Nat} (C : PrimitiveOracle) (p : Computation R Q) : + (run C (lower p)).1 = Sampling.eval C p := by + induction p with + | ret => rfl + | draw input next ih => exact ih (C input) + +theorem lower_counted {Q : Nat} (p : Computation R Q) : Counts Q (lower p) := by + induction p with + | ret => trivial + | @draw n input next ih => exact ⟨by omega,by simpa using ih⟩ + +/-- Explicit finite stopping, useful for direct application of finite sampling +lemmas. A counted complete execution never uses the `none` exhaustion branch. -/ +def stop : (Q : Nat) → CompressionProgram R → Computation (Option R) Q + | _, .done r => .ret (some r) + | 0, .ask _ _ => .ret none + | Q+1, .ask input next => .draw input (fun d => stop Q (next d)) + +theorem stop_exact (C : PrimitiveOracle) (p : CompressionProgram R) (Q : Nat) + (counted : Counts Q p) : Sampling.eval C (stop Q p) = some (run C p).1 := by + induction p generalizing Q with + | done => cases Q <;> rfl + | ask input next ih => + cases Q with + | zero => simp [Counts] at counted + | succ Q => + simp only [Counts,Nat.add_sub_cancel] at counted + have ht := ih (C input) Q (counted.2 (C input)) + simpa only [stop,Sampling.eval,run] using ht +end CompressionProgram + +inductive Entry where + | seeded (iv publicInput : Digest32) + | label (bytes : List Byte) + +def Entry.calls : Entry → CompressionProgram Context + | .seeded iv publicInput => CompressionProgram.lower (newCalls iv publicInput) + | .label bytes => CompressionProgram.lower (fromLabelCalls bytes) + +def Entry.cost : Entry → Nat + | .seeded _ _ => 1 + | .label bytes => (PublicMerkleLog.chunks bytes).length + +theorem Entry.counted (entry : Entry) : CompressionProgram.Counts entry.cost entry.calls := by + cases entry <;> exact CompressionProgram.lower_counted _ + +inductive Operation where + | observe (scalar : Scalar24) + | sample + | context + | state + | powBase + | absorbNonce (nonce : Scalar24) + +def Operation.Answer : Operation → Type + | .observe _ | .absorbNonce _ => Unit + | .sample => Scalar24 + | .context => Context + | .state | .powBase => Digest32 + +def Operation.cost (context : Context) : Operation → Nat + | .observe _ => observeCost context + | .sample => 1 + | .context => 0 + | .state => stateCost context + | .powBase | .absorbNonce _ => stateCost context+1 + +/-- Only the source operation's real public answer reaches the continuation. +Internal observe/flush answers remain private; the context operation is readonly. -/ +def Operation.calls (context : Context) : (operation : Operation) → + CompressionProgram (Context × operation.Answer) + | .observe scalar => CompressionProgram.map (fun c => (c,())) + (CompressionProgram.lower (observeCalls context scalar)) + | .sample => CompressionProgram.lower (sampleCalls context) + | .context => .done (context,context) + | .state => CompressionProgram.map (fun d => (context,d)) + (CompressionProgram.lower (stateCalls context)) + | .powBase => CompressionProgram.map (fun d => (context,d)) + (CompressionProgram.lower (powBaseCalls context)) + | .absorbNonce nonce => CompressionProgram.map (fun c => (c,())) + (CompressionProgram.lower (absorbNonceCalls context nonce)) + +theorem CompressionProgram.map_counted {R S : Type} (f : R → S) + (p : CompressionProgram R) (Q : Nat) (counted : CompressionProgram.Counts Q p) : + CompressionProgram.Counts Q (CompressionProgram.map f p) := by + induction p generalizing Q with + | done => trivial + | ask input next ih => exact ⟨counted.1,fun d => ih d _ (counted.2 d)⟩ + +theorem Operation.counted (context : Context) (operation : Operation) : + CompressionProgram.Counts (operation.cost context) (operation.calls context) := by + cases operation <;> simp only [Operation.calls,Operation.cost] + all_goals first + | exact CompressionProgram.map_counted _ _ _ (CompressionProgram.lower_counted _) + | exact CompressionProgram.lower_counted _ + | trivial + +abbrev Heap (k : Nat) := Fin k → Context + +inductive Action (k : Nat) where + | primitive (purpose : Purpose) (input : Node) + | call (handle : Fin k) (operation : Operation) + | clone (source destination : Fin k) + | initialize (destination : Fin k) (entry : Entry) + +def Action.Answer {k : Nat} : Action k → Type + | .primitive _ _ => Digest32 + | .call _ operation => operation.Answer + | .clone _ _ | .initialize _ _ => Unit + +def Action.calls {k : Nat} (heap : Heap k) : (action : Action k) → + CompressionProgram (Heap k × action.Answer) + | .primitive _ input => .ask input (fun d => .done (heap,d)) + | .call handle operation => CompressionProgram.map + (fun result => (Function.update heap handle result.1,result.2)) + (operation.calls (heap handle)) + | .clone source destination => .done (Function.update heap destination (heap source),()) + | .initialize destination entry => CompressionProgram.map + (fun context => (Function.update heap destination context,())) entry.calls + +inductive Program (k : Nat) (R : Type) where + | done (result : R) + | ask (action : Action k) (next : action.Answer → Program k R) + +abbrev Observation (k : Nat) := Sigma (fun action : Action k => action.Answer) + +structure View (k : Nat) (R : Type) where + observations : List (Observation k) + result : R + +def prepend {k : Nat} {R : Type} (action : Action k) (answer : action.Answer) + (view : View k R) : View k R := ⟨⟨action,answer⟩::view.observations,view.result⟩ + +def compile {k : Nat} {R : Type} (heap : Heap k) : Program k R → CompressionProgram (View k R) + | .done r => .done ⟨[],r⟩ + | .ask action next => CompressionProgram.bind (action.calls heap) (fun result => + CompressionProgram.map (prepend action result.2) (compile result.1 (next result.2))) + +/-- Initial contexts also pay their actual constructor calls. No arbitrary +live CV is supplied to the experiment, and clone copies only a live source state. -/ +def initializeHeap : {k : Nat} → (Fin k → Entry) → CompressionProgram (Heap k) + | 0, _ => .done (fun i => Fin.elim0 i) + | k+1, entries => CompressionProgram.bind (entries 0).calls (fun context => + CompressionProgram.map (Fin.cases context) + (initializeHeap (fun i : Fin k => entries i.succ))) + +def experiment {k : Nat} {R : Type} (entries : Fin k → Entry) (program : Program k R) : + CompressionProgram (View k R) := + CompressionProgram.bind (initializeHeap entries) (fun heap => compile heap program) + +noncomputable def realProbability {k : Nat} {R : Type} (entries : Fin k → Entry) + (program : Program k R) (D : View k R → Bool) : ℚ := + distinguishProbability (fun C : PrimitiveOracle => (CompressionProgram.run C + (experiment entries program)).1) D + +noncomputable def idealProbability {k : Nat} {R : Type} (entries : Fin k → Entry) + (program : Program k R) (D : View k R → Bool) : ℚ := + distinguishProbability (fun coins : ChallengeOracle × TailOracle => + (CompressionProgram.run (publicOracle coins.1 coins.2) (experiment entries program)).1) D + +/-- End-to-end full-view equality for all adaptive deployed operations, both +actual constructors, readonly contexts, clones, and shared public primitives. +This endpoint is the explicitly defined context-key experiment only. -/ +theorem actual_source_context_game_coupling {k : Nat} {R : Type} + (entries : Fin k → Entry) (program : Program k R) (D : View k R → Bool) : + realProbability entries program D = idealProbability entries program D := by + unfold realProbability idealProbability + rw [distinguish_average (inferInstance : Fintype PrimitiveOracle), + distinguish_average (inferInstance : Fintype (ChallengeOracle × TailOracle))] + exact DeployedTranscriptCoupling.public_table_expectation _ + +#print axioms Entry.counted +#print axioms Operation.counted +#print axioms CompressionProgram.stop_exact +#print axioms actual_source_context_game_coupling +end Whir.DeployedTranscriptGame diff --git a/verification/whir/Whir/DeployedTranscriptSource.lean b/verification/whir/Whir/DeployedTranscriptSource.lean new file mode 100644 index 000000000..a60e16a3f --- /dev/null +++ b/verification/whir/Whir/DeployedTranscriptSource.lean @@ -0,0 +1,125 @@ +import Whir.DeployedTranscriptGame + +/-! HISTORICAL pre-#552 source-function refinement, not the current merged mode. +The reference interpreter calls the hand-ported historical operations rather +than compression programs; all public observations and contexts are retained. -/ +namespace Whir.DeployedTranscriptGame +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram TypedOracleCompiler DeployedTranscript +open DeployedTranscriptCoupling (ChallengeOracle TailOracle publicOracle) + +def Entry.evaluate (C : PrimitiveOracle) : Entry → Context + | .seeded iv publicInput => new C iv publicInput + | .label bytes => fromLabel C bytes + +theorem Entry.calls_source (C : PrimitiveOracle) (entry : Entry) : + (CompressionProgram.run C entry.calls).1 = entry.evaluate C := by + cases entry <;> simp only [Entry.calls,Entry.evaluate,CompressionProgram.lower_eval, + newCalls_eval,fromLabelCalls_eval] + +def Operation.evaluate (C : PrimitiveOracle) (context : Context) : + (operation : Operation) → Context × operation.Answer + | .observe scalar => (DeployedTranscript.observe C context scalar,()) + | .sample => DeployedTranscript.sample C context + | .context => (context,context) + | .state => (context,exportedState C context) + | .powBase => (context,DeployedTranscript.powBase C context) + | .absorbNonce nonce => (DeployedTranscript.absorbNonce C context nonce,()) + +theorem Operation.calls_source (C : PrimitiveOracle) (context : Context) + (operation : Operation) : + (CompressionProgram.run C (operation.calls context)).1 = operation.evaluate C context := by + cases operation with + | observe scalar => + simp only [Operation.calls,Operation.evaluate,CompressionProgram.run_map] + exact congrArg (fun c : Context => (c,())) + ((CompressionProgram.lower_eval C _).trans (observeCalls_eval C context scalar)) + | sample => + exact (CompressionProgram.lower_eval C _).trans (sampleCalls_eval C context) + | context => rfl + | state => + simp only [Operation.calls,Operation.evaluate,CompressionProgram.run_map] + exact congrArg (fun d : Digest32 => (context,d)) + ((CompressionProgram.lower_eval C _).trans (stateCalls_eval C context)) + | powBase => + simp only [Operation.calls,Operation.evaluate,CompressionProgram.run_map] + exact congrArg (fun d : Digest32 => (context,d)) + ((CompressionProgram.lower_eval C _).trans (powBaseCalls_eval C context)) + | absorbNonce nonce => + simp only [Operation.calls,Operation.evaluate,CompressionProgram.run_map] + exact congrArg (fun c : Context => (c,())) + ((CompressionProgram.lower_eval C _).trans (absorbNonceCalls_eval C context nonce)) + +def Action.evaluate {k : Nat} (C : PrimitiveOracle) (heap : Heap k) : + (action : Action k) → Heap k × action.Answer + | .primitive _ input => (heap,C input) + | .call handle operation => + let result := operation.evaluate C (heap handle) + (Function.update heap handle result.1,result.2) + | .clone source destination => (Function.update heap destination (heap source),()) + | .initialize destination entry => + (Function.update heap destination (entry.evaluate C),()) + +theorem Action.calls_source {k : Nat} (C : PrimitiveOracle) (heap : Heap k) + (action : Action k) : + (CompressionProgram.run C (action.calls heap)).1 = action.evaluate C heap := by + cases action <;> simp only [Action.calls,Action.evaluate, + CompressionProgram.run_map,Operation.calls_source,Entry.calls_source] + all_goals rfl + +def runSource {k : Nat} {R : Type} (C : PrimitiveOracle) (heap : Heap k) : + Program k R → View k R + | .done r => ⟨[],r⟩ + | .ask action next => + let result := action.evaluate C heap + prepend action result.2 (runSource C result.1 (next result.2)) + +theorem compile_source {k : Nat} {R : Type} (C : PrimitiveOracle) (heap : Heap k) + (program : Program k R) : + (CompressionProgram.run C (compile heap program)).1 = runSource C heap program := by + induction program generalizing heap with + | done => rfl + | ask action next ih => + simp only [compile,CompressionProgram.run_bind,CompressionProgram.run_map, + Action.calls_source,runSource] + exact congrArg (prepend action (action.evaluate C heap).2) + (ih (action.evaluate C heap).2 (action.evaluate C heap).1) + +def sourceHeap {k : Nat} (C : PrimitiveOracle) (entries : Fin k → Entry) : Heap k := + fun i => (entries i).evaluate C + +theorem initializeHeap_source {k : Nat} (C : PrimitiveOracle) (entries : Fin k → Entry) : + (CompressionProgram.run C (initializeHeap entries)).1 = sourceHeap C entries := by + induction k with + | zero => funext i; exact Fin.elim0 i + | succ k ih => + simp only [initializeHeap,CompressionProgram.run_bind,CompressionProgram.run_map, + Entry.calls_source] + rw [ih] + funext i + cases i using Fin.cases <;> rfl + +def sourceExperiment {k : Nat} {R : Type} (C : PrimitiveOracle) (entries : Fin k → Entry) + (program : Program k R) : View k R := runSource C (sourceHeap C entries) program + +theorem experiment_source {k : Nat} {R : Type} (C : PrimitiveOracle) (entries : Fin k → Entry) + (program : Program k R) : + (CompressionProgram.run C (experiment entries program)).1 = sourceExperiment C entries program := by + simp only [experiment,CompressionProgram.run_bind,initializeHeap_source, + compile_source,sourceExperiment] + +/-- Actual source interpreter in both finite games, with all source entry and +public-view conventions preserved. No full-message RO independence is claimed. -/ +theorem deployed_source_coupling {k : Nat} {R : Type} (entries : Fin k → Entry) + (program : Program k R) (D : View k R → Bool) : + distinguishProbability (fun C : PrimitiveOracle => sourceExperiment C entries program) D = + distinguishProbability (fun coins : ChallengeOracle × TailOracle => + sourceExperiment (publicOracle coins.1 coins.2) entries program) D := by + rw [distinguish_average (inferInstance : Fintype PrimitiveOracle), + distinguish_average (inferInstance : Fintype (ChallengeOracle × TailOracle))] + exact DeployedTranscriptCoupling.public_table_expectation _ + +#print axioms compile_source +#print axioms experiment_source +#print axioms deployed_source_coupling +end Whir.DeployedTranscriptGame diff --git a/verification/whir/Whir/DuplexRefinement.lean b/verification/whir/Whir/DuplexRefinement.lean index b0238f513..2b05a5afa 100644 --- a/verification/whir/Whir/DuplexRefinement.lean +++ b/verification/whir/Whir/DuplexRefinement.lean @@ -470,6 +470,30 @@ def evalFrame (c : Compression) (cv : Digest32) : Frame → Digest32 def evalHistory (c : Compression) (iv : Digest32) (h : FramedHistory) : Digest32 := h.frames.foldl (evalFrame c) (seed c iv h.domain h.statement).cv +/-- Runtime history replay stores each intermediate CV as bytes. Folding +digest-valued closures instead recursively recomputes older frames whenever a +later compression reads its input CV. The public literal evaluator stays fixed. -/ +def evalHistoryState (c : Compression) (iv : Digest32) (h : FramedHistory) : State := + h.frames.foldl (fun s f => memoCV s (evalFrame c s.cv f)) + (seed c iv h.domain h.statement) + +def evalHistoryMemo (c : Compression) (iv : Digest32) (h : FramedHistory) : Digest32 := + (evalHistoryState c iv h).cv + +@[csimp] theorem evalHistory_memo : evalHistory = evalHistoryMemo := by + funext c iv h + have fold : ∀ fs : List Frame, ∀ s : State, + (fs.foldl (fun s f => memoCV s (evalFrame c s.cv f)) s).cv = + fs.foldl (evalFrame c) s.cv := by + intro fs + induction fs with + | nil => intro s; rfl + | cons f fs ih => + intro s + rw [List.foldl_cons, List.foldl_cons, ih] + simp only [memoCV_eq] + exact (fold h.frames (seed c iv h.domain h.statement)).symm + def evalTerminal (c : Compression) (cv : Digest32) : Terminal → Digest32 | .output block => outputBlock c cv block | .commitment consumed => c cv (wordsBlock [consumed]) (UInt64.ofNat (7 * 2^56)) true diff --git a/verification/whir/Whir/ErasureInterpolation.lean b/verification/whir/Whir/ErasureInterpolation.lean new file mode 100644 index 000000000..b1bb808e1 --- /dev/null +++ b/verification/whir/Whir/ErasureInterpolation.lean @@ -0,0 +1,107 @@ +import Mathlib.LinearAlgebra.Lagrange + +/-! An actual quadratic field-operation erasure interpolation evaluator. Correctness requires enough distinct authenticated evaluations of the same polynomial. It does not locate a common agreement set inside an adversarial word or decode errors. Inversion counts as one field operation; a machine refinement must charge its implementation separately. -/ +namespace Whir.ErasureInterpolation +open Polynomial +open scoped BigOperators + +variable {F I : Type*} [Field F] + +/-- A product evaluator and its exact field-operation counter. Each factor uses two subtractions, one inversion, and two multiplications including multiplication into the accumulator. -/ +def product (nodes : List F) (node point : F) : F × Nat := + match nodes with + | [] => (1, 0) + | other :: rest => + let result := product rest node point + (((point - other) * (node - other)⁻¹) * result.1, result.2 + 5) + +theorem product_value (nodes : List F) (node point : F) : + (product nodes node point).1 = + (nodes.map fun other => (point - other) * (node - other)⁻¹).prod := by + induction nodes with + | nil => rfl + | cons other rest ih => simp [product, ih] + +theorem product_operations (nodes : List F) (node point : F) : + (product nodes node point).2 = 5 * nodes.length := by + induction nodes with + | nil => rfl + | cons other rest ih => simp [product, ih, Nat.mul_add] + +/-- The outer evaluator adds one multiply and one add per interpolation term. It receives explicit ordered lists, rather than using classical Finset enumeration. -/ +def evaluate (indices : List I) (others : I → List F) (nodes values : I → F) + (point : F) : F × Nat := + match indices with + | [] => (0, 0) + | index :: rest => + let basis := product (others index) (nodes index) point + let result := evaluate rest others nodes values point + (values index * basis.1 + result.1, basis.2 + result.2 + 2) + +theorem evaluate_value (indices : List I) (others : I → List F) (nodes values : I → F) + (point : F) : + (evaluate indices others nodes values point).1 = + (indices.map fun i => values i * + ((others i).map fun other => (point - other) * (nodes i - other)⁻¹).prod).sum := by + induction indices with + | nil => rfl + | cons index rest ih => simp [evaluate, product_value, ih] + +/-- The counter follows the executable recursion; the bound is quadratic when each basis has at most `width` factors. -/ +theorem evaluate_operations_le (indices : List I) (others : I → List F) + (nodes values : I → F) (point : F) (width : Nat) + (lengths : ∀ i ∈ indices, (others i).length ≤ width) : + (evaluate indices others nodes values point).2 ≤ indices.length * (5 * width + 2) := by + induction indices with + | nil => simp [evaluate] + | cons index rest ih => + have tail := ih (fun i hi => lengths i (by simp [hi])) + have head := lengths index (by simp) + simp only [evaluate, product_operations, List.length_cons, Nat.add_mul] + omega + +/-- The supplied lists are certified enumerations of the actual interpolation set. They are computational inputs; the proof does not choose or search for an agreement set. -/ +theorem evaluate_interpolates [DecidableEq I] + (records : Finset I) (indices : List I) (others : I → List F) + (nodes values : I → F) (point : F) + (enumeration : (indices : Multiset I) = records.val) + (basisEnumeration : ∀ i ∈ records, + (others i : Multiset F) = (records.erase i).val.map nodes) : + (evaluate indices others nodes values point).1 = + (Lagrange.interpolate records nodes values).eval point := by + rw [evaluate_value, Lagrange.interpolate_apply, Polynomial.eval_finsetSum] + rw [Finset.sum_eq_multiset_sum, ← enumeration] + change ((indices : Multiset I).map _).sum = ((indices : Multiset I).map _).sum + apply congrArg Multiset.sum + apply Multiset.map_congr rfl + intro i hi + have member : i ∈ records := by + change i ∈ records.val + rw [← enumeration] + exact hi + simp only [Polynomial.eval_mul, Polynomial.eval_C, Lagrange.basis, + Polynomial.eval_prod, Lagrange.basisDivisor, Polynomial.eval_sub, + Polynomial.eval_X] + rw [Finset.prod_eq_multiset_prod] + congr 1 + change ((others i : Multiset F).map _).prod = _ + rw [basisEnumeration i member, Multiset.map_map] + congr 1 + apply Multiset.map_congr rfl + intro j hj + exact mul_comm _ _ + +/-- With at least the degree threshold of distinct correct rows, the implemented evaluator recovers every evaluation of the actual polynomial. -/ +theorem evaluate_recovers [DecidableEq I] + (records : Finset I) (indices : List I) (others : I → List F) + (nodes values : I → F) (point : F) (p : F[X]) + (enumeration : (indices : Multiset I) = records.val) + (basisEnumeration : ∀ i ∈ records, + (others i : Multiset F) = (records.erase i).val.map nodes) + (distinct : Set.InjOn nodes records) (enough : p.degree < records.card) + (correct : ∀ i ∈ records, p.eval (nodes i) = values i) : + (evaluate indices others nodes values point).1 = p.eval point := by + rw [evaluate_interpolates records indices others nodes values point enumeration basisEnumeration, + ← Lagrange.eq_interpolate_of_eval_eq values distinct enough correct] + +end Whir.ErasureInterpolation diff --git a/verification/whir/Whir/FrobeniusExtraction.lean b/verification/whir/Whir/FrobeniusExtraction.lean new file mode 100644 index 000000000..0dfa5a626 --- /dev/null +++ b/verification/whir/Whir/FrobeniusExtraction.lean @@ -0,0 +1,72 @@ +import Whir.TraceExtraction + +/-! An in-place-friendly array ladder for the source trace splitter. It computes every required Frobenius scalar once; the recursion retains no duplicate power arrays. -/ +namespace Whir.FrobeniusExtraction +variable {F : Type*} [CommRing F] + +/-- The n successive scalar powers, using n−1 squarings and no inversions. -/ +def powers : Nat → F → Array F + | 0, _ => #[] + | n + 1, beta => + let previous := powers n beta + if n = 0 then previous.push beta + else + let last := previous.getD (n - 1) 0 + previous.push (last * last) + +theorem powers_size (count : Nat) (beta : F) : (powers count beta).size = count := by + induction count with + | zero => rfl + | succ count ih => simp only [powers]; split <;> simp [ih] + +theorem powers_value (count : Nat) (beta : F) : + powers count beta = Array.ofFn (fun i : Fin count => beta ^ (2 ^ i.val)) := by + induction count with + | zero => simp [powers] + | succ count ih => + simp only [powers, ih] + split + · subst count + simp + apply Array.ext + · simp + · intro i hi hi' + have same : i = 0 := by simpa using hi' + subst i + simp + · rename_i positive + apply Array.ext + · simp + · intro i hi hi' + have bound : i ≤ count := by simpa using hi' + by_cases old : i < count + · simp [Array.getElem_push, old] + · have same : i = count := by omega + subst i + have pred : count - 1 < count := by omega + simp only [Array.getElem_push, Array.size_ofFn, lt_self_iff_false, + dite_false, Array.getElem_ofFn, Array.getD, pred, dite_true] + change (Array.ofFn (fun i : Fin count => beta ^ (2 ^ i.val)))[count - 1]'(by simpa using pred) * + (Array.ofFn (fun i : Fin count => beta ^ (2 ^ i.val)))[count - 1]'(by simpa using pred) = + beta ^ (2 ^ count) + simp only [Array.getElem_ofFn] + rw [← pow_two, ← pow_mul] + congr 1 + have step : count = (count - 1) + 1 := by omega + rw [step, pow_succ] + simp + +/-- Counts exactly the scalar multiplication sites of the ladder (array work is separate). -/ +def multiplicationCalls : Nat → Nat + | 0 => 0 + | n + 1 => multiplicationCalls n + if n = 0 then 0 else 1 + +theorem multiplicationCalls_eq (count : Nat) : multiplicationCalls count = count - 1 := by + induction count with + | zero => rfl + | succ count ih => simp only [multiplicationCalls, ih]; split <;> omega + +#print axioms powers_size +#print axioms powers_value +#print axioms multiplicationCalls_eq +end Whir.FrobeniusExtraction diff --git a/verification/whir/Whir/InitialKnowledgeScheduleActual.lean b/verification/whir/Whir/InitialKnowledgeScheduleActual.lean new file mode 100644 index 000000000..86210c52d --- /dev/null +++ b/verification/whir/Whir/InitialKnowledgeScheduleActual.lean @@ -0,0 +1,87 @@ +import Whir.InitialKnowledgeSchedule + +/-! The actual causal six-fold trajectory instantiates the typed generic +SafeClaimFoldSchedule. All reindexings preserve physical coefficient order. -/ +namespace Whir.InitialKnowledgeSchedule +open Concrete Protocol CausalGame CausalExecution ExecutionShapes CausalProbability +open CandidateFolding SupportedCandidateExtraction ParameterBounds +set_option maxRecDepth 100000 +set_option maxHeartbeats 400000 + +private theorem cast_schedule_start {k N start start' finish : Nat} + (h : start' = start) (top : Bool) (enc : (Fin k → E) →ₗ[E] (Fin N → E)) + (C : Submodule E (Fin N → E)) (threshold : Nat) + (oracle : Fin start → Fin N → E) (last : Fin finish → Fin N → E) + (state endState : VerifierState E) (transform : Array E → Array E) + (schedule : SafeClaimFoldSchedule top enc C threshold oracle last state endState transform) : + SafeClaimFoldSchedule top enc C threshold (fun lane : Fin start' => oracle (Fin.cast h lane)) + last state endState transform := by + subst start' + exact schedule + +noncomputable def matrix (input : Public) (strategy : Strategy) (t : Tape input.config) + (i : Fin input.config.folds.size) (j : Nat) := + OracleReplay.oracleAt (i.val == 0) input.config.folds[i.val]! + (levelAt input strategy t i).oracle (challenges input.config t).levels[i.val]!.folds j + (N := length input.config i) + +/-- No abstract schedule is assumed: actual causal states, messages and oracle +matrices build it from the two incoming-prefix scalar exclusions. -/ +theorem actual_safe_claim_schedule (p : Profile) (lanes : Nat) (root : BaseOracle) + (claims : Array Claim) (strategy : Strategy) (t : Tape (config p)) + (i : Fin (config p).folds.size) (start count : Nat) + (bound : start+count ≤ (config p).folds[i.val]!) + (mca : ∀ j : Fin (config p).folds[i.val]!, ¬ RawMCA (Input p lanes root claims) strategy i j t) + (guard : ∀ j : Fin (config p).folds[i.val]!, ¬ ClaimEscape (Input p lanes root claims) strategy i j t) : + SafeClaimFoldSchedule (i.val == 0) + (concreteEncoder (remaining (config p) i) (config p).rates[i.val]!) + (LinearMap.range (concreteEncoder (remaining (config p) i) (config p).rates[i.val]!)) + (threshold (config p) i) + (matrix (Input p lanes root claims) strategy t i start) + (matrix (Input p lanes root claims) strategy t i (start+count)) + (foldAt (Input p lanes root claims) strategy t i start).state + (foldAt (Input p lanes root claims) strategy t i (start+count)).state + (foldFrom (Input p lanes root claims) t i start count) := by + induction count generalizing start with + | zero => exact SafeClaimFoldSchedule.done _ _ + | succ count ih => + let input := Input p lanes root claims + let j : Fin (config p).folds[i.val]! := ⟨start, by omega⟩ + have rest := ih (start+1) (by omega) + have endIndex : start+1+count = start+(count+1) := by omega + rw [endIndex] at rest + unfold matrix at rest + rw [OracleReplay.oracleAt_succ _ _ _ _ start j.isLt, foldAt_succ] at rest + simp only [foldStep, CausalFolds.block_eq] at rest + have weight : (foldAt input strategy t i start).state.weight.size = + (2 ^ (input.config.folds[i.val]! - (start+1)) * 2) * dimension input.config i := by + rw [(foldAt_shape p lanes root claims strategy t i start (by omega)).2] + rw [← CausalFolds.pair_width _ _ j.isLt, dimension, ← Nat.pow_add, Nat.add_comm] + have claimSafe : (challenges input.config t).levels[i.val]!.folds[start]! ∉ + candidateRoundEscape (arrayCandidates (i.val == 0) + (concreteEncoder (remaining input.config i) input.config.rates[i.val]!) + (paired input strategy t i j) (threshold input.config i)) + (foldAt input strategy t i start).state (CandidateFolding.foldBlock (i.val == 0) (dimension input.config i)) := by + unfold paired + rw [OracleReplay.paired_candidates] + simpa only [ClaimEscape, foldCandidates, CausalFolds.block_eq, j] using guard j + have schedule := SafeClaimFoldSchedule.step (paired input strategy t i j) + (foldAt input strategy t i start).state (challenges input.config t).levels[i.val]!.folds[start]! + (proof input strategy t).levels[i.val]!.afterFold[start]! weight (mca j) claimSafe rest + have width := CausalFolds.pair_width input.config.folds[i.val]! start j.isLt + have cast := cast_schedule_start width (i.val == 0) _ _ _ _ _ _ _ _ schedule + have oracle : (fun lane : Fin (2 ^ (input.config.folds[i.val]! - start)) => + paired input strategy t i j (Fin.cast width lane)) = matrix input strategy t i start := by + funext lane q + rfl + rw [oracle] at cast + have transform : (fun a => foldFrom input t i (start+1) count + (foldValues a (CandidateFolding.foldBlock (i.val == 0) (dimension input.config i)) + (challenges input.config t).levels[i.val]!.folds[start]!)) = foldFrom input t i start (count+1) := by + funext a + rw [foldFrom_succ, CausalFolds.block_eq] + rw [transform] at cast + exact cast + +#print axioms actual_safe_claim_schedule +end Whir.InitialKnowledgeSchedule diff --git a/verification/whir/Whir/InterleavedListExtraction.lean b/verification/whir/Whir/InterleavedListExtraction.lean new file mode 100644 index 000000000..f08c02686 --- /dev/null +++ b/verification/whir/Whir/InterleavedListExtraction.lean @@ -0,0 +1,271 @@ +import Whir.PCSListExtraction +import Whir.SupportedCandidateFolding + +set_option maxRecDepth 4096 +set_option maxHeartbeats 1600000 + +/-! Intermediate extension rows are LIST decoded with dense GS interpolation, +Roth--Ruckenstein and the actual Shoup root backend. The Cartesian assembly is +computable and never enumerates the extension field. Integer parameters are +checked before invoking the backend. -/ +namespace Whir.InterleavedListExtraction +open Concrete CompPoly +local instance : Field E := ExtractionField.field + +/-- Run the real backend only after its decidable integer certificate passes. -/ +def lanePolynomials (n rate errors multiplicity weightedDegree : Nat) + (received : Fin (2 ^ (n + rate)) → E) : List (CPolynomial E) := + let params := _root_.GuruswamiSudan.execParamsOfMultiplicityAndDegree + (2 ^ n) errors multiplicity weightedDegree + if _root_.GuruswamiSudan.paramsPassIntegerChecks (2 ^ n) (2 ^ (n + rate)) errors params then + (PCSListExtraction.listPolynomials (n + rate) params received).toList + else [] + +/-- Deduplication is by literal recovered E coefficient arrays. -/ +def laneWords (n rate errors multiplicity weightedDegree : Nat) + (received : Fin (2 ^ (n + rate)) → E) : List (Array E) := + ((lanePolynomials n rate errors multiplicity weightedDegree received).map + (ConcreteRowExtraction.coefficients n)).dedup + +def cartesian {α : Type*} : List (List α) → List (List α) + | [] => [[]] + | first :: rest => first.flatMap (fun value => (cartesian rest).map (value :: ·)) + +@[simp] theorem mem_cartesian {α : Type*} (choices : List (List α)) (values : List α) : + values ∈ cartesian choices ↔ List.Forall₂ (fun value options => value ∈ options) values choices := by + induction choices generalizing values with + | nil => cases values <;> simp [cartesian] + | cons first rest ih => + cases values with + | nil => simp [cartesian] + | cons value tail => simp [cartesian, ih, List.forall₂_cons] + +/-- Packing applies the inverse novel-basis transform to every E lane. It never +silently c0-projects intermediate extension coefficients. -/ +def assemble (n : Nat) (top : Bool) (rows : List (Array E)) : Array E := + if top then rows.toArray.flatten + else + let cached := rows.toArray + Array.ofFn fun i : Fin (rows.length * 2 ^ n) => + (cached[i.val % rows.length]!)[i.val / rows.length]! + +def candidates (n rate lanes errors multiplicity weightedDegree : Nat) (top : Bool) + (received : Fin lanes → Fin (2 ^ (n + rate)) → E) : List (Array E) := + (cartesian (List.ofFn fun lane => + laneWords n rate errors multiplicity weightedDegree (received lane))).map (assemble n top) + +theorem lanePolynomials_complete (n rate errors multiplicity weightedDegree : Nat) + (noWrap : n + rate ≤ 64) + (checked : _root_.GuruswamiSudan.paramsPassIntegerChecks (2 ^ n) (2 ^ (n + rate)) errors + (_root_.GuruswamiSudan.execParamsOfMultiplicityAndDegree + (2 ^ n) errors multiplicity weightedDegree) = true) + (received : Fin (2 ^ (n + rate)) → E) (polynomial : Polynomial E) + (degree : polynomial.degree < (2 ^ n : Nat)) + (distance : hammingDist received (fun i => polynomial.eval (E.ofK (UInt64.ofNat i.val))) ≤ errors) : + ∃ candidate ∈ lanePolynomials n rate errors multiplicity weightedDegree received, + candidate.toPoly = polynomial := by + have certificate := (_root_.GuruswamiSudan.paramsPassIntegerChecks_iff _ _ _ _).mp checked + simpa only [lanePolynomials, checked, ↓reduceIte] using + PCSListExtraction.listPolynomials_complete n rate noWrap _ errors certificate received polynomial degree distance + +theorem polynomial_coefficients (n : Nat) (noWrap : n ≤ 64) (p : CPolynomial E) + (degree : p.toPoly.degree < (2 ^ n : Nat)) : + (ConcreteRowExtraction.coefficients n p).size = 2 ^ n ∧ + AdditiveCode.concretePolynomial n (ConcreteRowExtraction.coefficients n p) = p.toPoly := by + obtain ⟨a, ha⟩ := (@AdditiveCode.polynomial_surjective E FieldModel.instFieldE + (AdditiveCode.bitBasis E.ofK) inferInstance n + (AdditiveCode.concrete_bitBasis_independent n noWrap) p.toPoly).mpr degree + have polynomial : AdditiveCode.concretePolynomial n (Array.ofFn a) = p.toPoly := by + simpa [AdditiveCode.concretePolynomial, AdditiveCode.arrayPolynomial, + AdditiveCode.concreteBaseRepresentation, QueryRefinement.concreteRepresentation] using ha + have recover := ConcreteRowExtraction.coefficients_recovers n noWrap + (Array.ofFn a) (by simp) p polynomial.symm + rw [recover] + exact ⟨by simp, polynomial⟩ + +theorem laneWords_complete (n rate errors multiplicity weightedDegree : Nat) + (noWrap : n + rate ≤ 64) + (checked : _root_.GuruswamiSudan.paramsPassIntegerChecks (2 ^ n) (2 ^ (n + rate)) errors + (_root_.GuruswamiSudan.execParamsOfMultiplicityAndDegree + (2 ^ n) errors multiplicity weightedDegree) = true) + (received : Fin (2 ^ (n + rate)) → E) (words : Array E) (shape : words.size = 2 ^ n) + (distance : hammingDist received + (fun i => (encode n rate words)[i.val]!) ≤ errors) : + words ∈ laneWords n rate errors multiplicity weightedDegree received := by + obtain ⟨p, member, polynomial⟩ := lanePolynomials_complete n rate errors multiplicity weightedDegree + noWrap checked received (AdditiveCode.concretePolynomial n words) + (AdditiveCode.concrete_polynomial_degree_lt n (by omega) words) (by + convert distance using 1 + congr 1 + funext i + exact (AdditiveCode.concrete_encode_eval n rate words shape i.val i.isLt).symm) + have recover := ConcreteRowExtraction.coefficients_recovers n (by omega) words shape p polynomial + simp only [laneWords, List.mem_dedup, List.mem_map] + exact ⟨p, member, recover⟩ + +/-- Whole interleaved candidate completeness, with each target lane decoded by +the actual GS backend before deterministic Cartesian packing. -/ +theorem candidates_complete (n rate lanes errors multiplicity weightedDegree : Nat) + (top : Bool) (noWrap : n + rate ≤ 64) + (checked : _root_.GuruswamiSudan.paramsPassIntegerChecks (2 ^ n) (2 ^ (n + rate)) errors + (_root_.GuruswamiSudan.execParamsOfMultiplicityAndDegree + (2 ^ n) errors multiplicity weightedDegree) = true) + (received : Fin lanes → Fin (2 ^ (n + rate)) → E) (words : Fin lanes → Array E) + (shape : ∀ lane, (words lane).size = 2 ^ n) + (distance : ∀ lane, hammingDist (received lane) + (fun i => (encode n rate (words lane))[i.val]!) ≤ errors) : + assemble n top (List.ofFn words) ∈ + candidates n rate lanes errors multiplicity weightedDegree top received := by + apply List.mem_map.mpr + refine ⟨List.ofFn words, (mem_cartesian _ _).mpr ?_, rfl⟩ + apply List.forall₂_iff_get.mpr + refine ⟨by simp, ?_⟩ + intro i hi hj + simpa using laneWords_complete n rate errors multiplicity weightedDegree noWrap checked + (received ⟨i, by simpa using hi⟩) (words ⟨i, by simpa using hi⟩) + (shape _) (distance _) + +open Classical in +theorem laneWords_sound (n rate errors multiplicity weightedDegree threshold : Nat) + (noWrap : n + rate ≤ 64) (radiusBound : errors + threshold ≤ 2 ^ (n + rate)) + (received : Fin (2 ^ (n + rate)) → E) (words : Array E) + (member : words ∈ laneWords n rate errors multiplicity weightedDegree received) : + words ∈ CandidateFolding.arrayCandidates true + (CandidateFolding.concreteEncoder n rate) (fun _ : Fin 1 => received) threshold := by + simp only [laneWords, List.mem_dedup, List.mem_map] at member + obtain ⟨p, hp, rfl⟩ := member + dsimp only [lanePolynomials] at hp + split at hp + · rename_i checked + have certificate := (_root_.GuruswamiSudan.paramsPassIntegerChecks_iff _ _ _ _).mp checked + have semantic := (_root_.GuruswamiSudan.mem_decodeWithParams_iff_degree_and_distance + PCSListExtraction.context _ certificate + (ωs := AdditiveCode.concreteDomain (n + rate) noWrap) + (w := PCSListExtraction.receivedWord (n + rate) received) (by rfl)).mp ⟨p, hp, rfl⟩ + obtain ⟨shape, polynomial⟩ := polynomial_coefficients n (by omega) p semantic.1 + apply (CandidateFolding.oneLane_arrayCandidates_mem_iff _ _ _ _ _).mpr + refine ⟨shape, ?_⟩ + have partition := _root_.GuruswamiSudan.agreement_card_add_hammingDist + (f := received) (ωs := AdditiveCode.concreteDomain (n + rate) noWrap) p.toPoly + have count : (Finset.univ.filter (fun i => received i = + p.toPoly.eval (E.ofK (UInt64.ofNat i.val)))).card ≥ threshold := by + have distance := semantic.2 + change hammingDist received + (fun i => p.toPoly.eval (E.ofK (UInt64.ofNat i.val))) ≤ errors at distance + change (Finset.univ.filter (fun i => received i = + p.toPoly.eval (E.ofK (UInt64.ofNat i.val)))).card + hammingDist received + (fun i => p.toPoly.eval (E.ofK (UInt64.ofNat i.val))) = 2 ^ (n + rate) at partition + omega + convert count using 1 + congr 1 + ext q + simp only [Finset.mem_filter, Finset.mem_univ, true_and] + rw [ConcreteCandidates.concreteEncoder_ofFn] + have array : Array.ofFn (fun j : Fin (2 ^ n) => + (ConcreteRowExtraction.coefficients n p)[j.val]!) = ConcreteRowExtraction.coefficients n p := by + apply Array.ext + · simp [shape] + · intro i hi hi' + simp [getElem!_pos, hi'] + rw [array, AdditiveCode.concrete_encode_eval n rate _ shape q.val q.isLt, polynomial] + exact eq_comm + · simp at hp + +open Classical in +/-- The actual executable per-lane list, after deduplication, inherits the +proved production Johnson cap. No candidate enumeration is used by the algorithm. -/ +theorem laneWords_production_bound (profile : ParameterBounds.Profile) + (level : Fin (ParameterBounds.config profile).folds.size) + (errors multiplicity weightedDegree : Nat) + (radiusBound : errors + ParameterBounds.threshold (ParameterBounds.config profile) level ≤ + ParameterBounds.length (ParameterBounds.config profile) level) + (received : Fin (ParameterBounds.length (ParameterBounds.config profile) level) → E) : + (laneWords (CausalGame.remaining (ParameterBounds.config profile) level) + (ParameterBounds.config profile).rates[level.val]! errors multiplicity weightedDegree received).length ≤ 2 ^ 32 := by + let words := laneWords (CausalGame.remaining (ParameterBounds.config profile) level) + (ParameterBounds.config profile).rates[level.val]! errors multiplicity weightedDegree received + have depth : CausalGame.remaining (ParameterBounds.config profile) level + + (ParameterBounds.config profile).rates[level.val]! ≤ 64 := by + have bound := (ParameterBounds.production_level_facts profile level).2.2.1 + have small : CausalGame.remaining (ParameterBounds.config profile) level + + (ParameterBounds.config profile).rates[level.val]! ≤ 26 := + (pow_le_pow_iff_right₀ (by decide : (1 : Nat) < 2)).mp bound + omega + have subset : words.toFinset ⊆ CandidateFolding.arrayCandidates true + (CandidateFolding.concreteEncoder (CausalGame.remaining (ParameterBounds.config profile) level) + (ParameterBounds.config profile).rates[level.val]!) + (fun _ : Fin 1 => received) (ParameterBounds.threshold (ParameterBounds.config profile) level) := by + intro word member + exact laneWords_sound _ _ _ _ _ _ depth radiusBound received word (List.mem_toFinset.mp member) + have nodup : words.Nodup := List.nodup_dedup _ + rw [← List.toFinset_card_of_nodup nodup] + exact (Finset.card_le_card subset).trans (ConcreteCandidates.production_arrayCandidates_card true + profile level (fun _ : Fin 1 => received)) + +/-- A concrete non-unique-radius E fixture: dimension 4, length 16, eight +agreements. Gao's radius permits six errors, but GS certifies eight. -/ +def fixtureParams := _root_.GuruswamiSudan.execParamsOfMultiplicityAndDegree 4 8 2 15 + +theorem fixture_certificate : _root_.GuruswamiSudan.GSParamCert 4 16 8 fixtureParams := + (_root_.GuruswamiSudan.paramsPassIntegerChecks_iff _ _ _ _).mp (by decide) + +/-- Exact cardinality of the executable assembly, including duplicates. -/ +theorem cartesian_length {α : Type*} (choices : List (List α)) : + (cartesian choices).length = (choices.map List.length).prod := by + induction choices with + | nil => simp [cartesian] + | cons first rest ih => simp [cartesian, List.length_flatMap, ih] + +theorem cartesian_length_le {α : Type*} (choices : List (List α)) (bound : Nat) + (bounded : ∀ options ∈ choices, options.length ≤ bound) : + (cartesian choices).length ≤ bound ^ choices.length := by + rw [cartesian_length] + simpa only [List.length_map] using List.prod_le_pow_length (choices.map List.length) bound (by + intro length member + obtain ⟨options, hoption, rfl⟩ := List.mem_map.mp member + exact bounded options hoption) + +/-- A derived polynomial bound for the actual Cartesian candidate ARRAY output +at supported intermediate levels with at most sixteen lanes. The exponent is +deliberately conservative; this is not a field-size enumeration. It bounds +candidate assembly, not uninstrumented GS-backend running time. -/ +theorem candidates_production_polynomial_bound (profile : ParameterBounds.Profile) + (level : Fin (ParameterBounds.config profile).folds.size) + (lanes : Nat) (fixedLanes : lanes ≤ 16) (top : Bool) + (errors multiplicity weightedDegree : Nat) + (radiusBound : errors + ParameterBounds.threshold (ParameterBounds.config profile) level ≤ + ParameterBounds.length (ParameterBounds.config profile) level) + (received : Fin lanes → Fin (ParameterBounds.length (ParameterBounds.config profile) level) → E) : + (candidates (CausalGame.remaining (ParameterBounds.config profile) level) + (ParameterBounds.config profile).rates[level.val]! lanes errors multiplicity weightedDegree + top received).length ≤ (ParameterBounds.length (ParameterBounds.config profile) level) ^ 512 := by + let N := ParameterBounds.length (ParameterBounds.config profile) level + have size : 2 ≤ N := by + have facts := ParameterBounds.production_level_facts profile level + have dimensionPositive := facts.1 + have dimensionBound := facts.2.1 + change _ < N at dimensionBound + omega + have count : (candidates (CausalGame.remaining (ParameterBounds.config profile) level) + (ParameterBounds.config profile).rates[level.val]! lanes errors multiplicity weightedDegree + top received).length ≤ (2 ^ 32) ^ lanes := by + unfold candidates + rw [List.length_map] + simpa only [List.length_ofFn] using cartesian_length_le + (List.ofFn fun lane => laneWords (CausalGame.remaining (ParameterBounds.config profile) level) + (ParameterBounds.config profile).rates[level.val]! errors multiplicity weightedDegree + (received lane)) (2 ^ 32) (by + intro options member + obtain ⟨lane, rfl⟩ := List.mem_ofFn.mp member + exact laneWords_production_bound profile level errors multiplicity weightedDegree + radiusBound (received lane)) + calc + _ ≤ (2 ^ 32) ^ lanes := count + _ ≤ (N ^ 32) ^ lanes := Nat.pow_le_pow_left (Nat.pow_le_pow_left size 32) lanes + _ = N ^ (32 * lanes) := (pow_mul N 32 lanes).symm + _ ≤ N ^ 512 := Nat.pow_le_pow_right (by omega) (by omega) + +#print axioms lanePolynomials_complete +#print axioms fixture_certificate +#print axioms mem_cartesian +end Whir.InterleavedListExtraction diff --git a/verification/whir/Whir/PCSBCSActualMerkleBound.lean b/verification/whir/Whir/PCSBCSActualMerkleBound.lean index 607226576..512ad281e 100644 --- a/verification/whir/Whir/PCSBCSActualMerkleBound.lean +++ b/verification/whir/Whir/PCSBCSActualMerkleBound.lean @@ -8,20 +8,16 @@ namespace Whir.PCSBCSActualMerkleBound open Concrete Protocol FiatShamirGame DuplexFraming DuplexPublicSimulator open PCSBCSSourcePrimitiveRootBudget PCSBCSMerkleQueryLog -variable (p : ParameterBounds.Profile) (Q : Nat) - (layout : PublicLog → Node → WHIRCallerClaims.CallerLayout) - (saved : PublicLog → Node → AnchoredHeaderCodec.Record) - (entry : PublicLog → Node → FramedHistory) - (answers : PublicLog → Node → FiatShamirGame.Coordinate → Digest32) - (headers : PublicLog → Node → AnchoredHeaderRoots.Public) +variable (p : ParameterBounds.Profile) (Q boundary : Nat) + (registry : AnchoredHeaderRoots.Public) theorem source_extraction_probability {T : Type} (program : PublicCompressionProgram.Computation T Q) : - extractionProbability (targets p Q layout saved entry answers headers) program ≤ + extractionProbability (targets p Q boundary registry) program ≤ PublicMerkleProbability.bound Q (Q*(Q+1)) := - multi_extraction_probability (targets p Q layout saved entry answers headers) Q (Q*(Q+1)) - (targets_cap p Q layout saved entry answers headers) - (targets_grow p Q layout saved entry answers headers) program + multi_extraction_probability (targets p Q boundary registry) Q (Q*(Q+1)) + (targets_cap p Q boundary registry) + (targets_grow p Q boundary registry) program theorem exact_merkle_loss (Q : Nat) : PublicMerkleProbability.bound Q (Q*(Q+1)) = diff --git a/verification/whir/Whir/PCSBCSAdaptiveSourceCallerSnapshot.lean b/verification/whir/Whir/PCSBCSAdaptiveSourceCallerSnapshot.lean new file mode 100644 index 000000000..c1e24d826 --- /dev/null +++ b/verification/whir/Whir/PCSBCSAdaptiveSourceCallerSnapshot.lean @@ -0,0 +1,127 @@ +import Whir.PCSBCSSourceCallerAnswers +import Whir.PCSBCSSourceCallerOriginal +import Whir.PCSBCSCapturedSourceStatePath +import Whir.PCSBCSSourceSavedRecordDecoder + +/-! Actual adaptive caller metadata factors through OTHER source table values. +The literal fresh caller decoder and its existing original preparation retain +the genuine earlier source coins, while root addresses use only public packet +entry bytes. No selected packet bytes, including unused output bytes, are an +input to this latent reconstruction or cause another operational query. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSAdaptiveSourceCallerSnapshot +open Concrete Protocol CausalGame CausalProbability FiatShamirGame +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSSourceCallerSnapshot +open PCSBCSCallerBinding PCSBCSCapturedSourceTransport +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +noncomputable local instance (key : Keys) : Fintype (Answers key) := + Restoration.instFintypeAnswer p Q iv boundary key + +/-- The actual partial constructor: source decoder, existing preparation, +first-mention root capture, and strict earlier native-reply inverse. Failures +remain None; no assumed compatible snapshot or successful oracle is supplied. -/ +noncomputable def builder {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R n) : Restoration.Builder p Q iv boundary := + fun current other _ => do + let saved ← PCSBCSSourceSavedRecordDecoder.decode p current.1.val + let sourceAnswers := PCSBCSSourceCallerAnswers.answersFromOther current other + let original ← PCSBCSSourceCallerOriginal.original p layout saved current.1.val sourceAnswers + fromCapture address ⟨saved.root,initialShape saved.shape⟩ + program original saved current other + +/-- Whole caller parsing sees only genuine bounded garbage-key values. Its +result, including the complete dependent prepared value and failures, is the +same for the actual source table and its erased completion. -/ +theorem original_other (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (current packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) : + PCSBCSSourceCallerOriginal.original p layout saved packet.1.val + (PCSBCSSourceCallerAnswers.answersFromOther current (fun key => table key.val)) = + PCSBCSSourceCallerOriginal.original p layout saved packet.1.val + (PCSBCSSourceCallerAnswers.answers table) := + PCSBCSSourceCallerOriginal.original_prior_only p layout saved packet.1.val _ _ + (PCSBCSSourceCallerAnswers.caller_outputs_other current packet table) + +/-- The denotational model is fixed outside the table average; actual earlier +caller coins and the complete adaptive saved record are reconstructed from +literal key metadata and erased values, not unrelated oracle callbacks. -/ +noncomputable def model {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R n) : NodeModel Keys Answers (Option (CallerData p)) := + Restoration.model p Q iv boundary (builder layout program) + +/-- Exact source assembly for every table, including parse/preparation errors. +All coordinates reached by the caller belong to the actual finite physical +source game; the outside-budget inert completion is not reached. -/ +theorem publicNode_exact {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R n) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) : + publicNode (model layout program) (.inl current) table = (do + let saved ← PCSBCSSourceSavedRecordDecoder.decode p current.1.val + let original ← PCSBCSSourceCallerOriginal.original p layout saved current.1.val + (PCSBCSSourceCallerAnswers.answers table) + fromCapture address + ⟨saved.root,initialShape saved.shape⟩ program original saved current + (fun key => table key.val)) := by + change (do + let saved ← PCSBCSSourceSavedRecordDecoder.decode p current.1.val + let original ← PCSBCSSourceCallerOriginal.original p layout saved current.1.val + (PCSBCSSourceCallerAnswers.answersFromOther current (fun key => table key.val)) + fromCapture address + ⟨saved.root,initialShape saved.shape⟩ program original saved current + (fun key => table key.val)) = _ + apply congrArg (fun continuation : AnchoredHeaderCodec.Record → Option (CallerData p) => + (PCSBCSSourceSavedRecordDecoder.decode p current.1.val).bind continuation) + funext saved + rw [original_other layout saved current current table] + +/-- A successful actual original constructor identifies the precise old-source +snapshot at this node. This is derived source equality, not a model-compatibility +premise. -/ +theorem publicNode_original {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (program : Sampling Keys Answers R n) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (original : CallerInput p) + (recovered : PCSBCSSourceSavedRecordDecoder.decode p current.1.val = some saved) + (constructed : PCSBCSSourceCallerOriginal.original p layout saved current.1.val + (PCSBCSSourceCallerAnswers.answers table) = some original) : + publicNode (model layout program) (.inl current) table = + fromCapture address + ⟨saved.root,initialShape saved.shape⟩ program original saved current + (fun key => table key.val) := by + have exactNode := publicNode_exact layout program current table + apply exactNode.trans + rw [recovered] + change (PCSBCSSourceCallerOriginal.original p layout saved current.1.val + (PCSBCSSourceCallerAnswers.answers table)).bind (fun input => + fromCapture address + ⟨saved.root,initialShape saved.shape⟩ program input saved current + (fun key => table key.val)) = _ + rw [constructed] + rfl + +/-- The additive conditional hazard applies to the actual adaptive erased +constructor. Its independent inputs are proved above, not asserted at the +Fiat-Shamir endpoint. -/ +theorem conditional_hazard {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R n) : + ConditionalHazard (model layout program) PCSRoundByRoundKnowledge.rbrError := + Restoration.conditional_hazard p Q iv boundary (builder layout program) + +#print axioms original_other +#print axioms publicNode_exact +#print axioms publicNode_original +#print axioms conditional_hazard +end Whir.PCSBCSAdaptiveSourceCallerSnapshot diff --git a/verification/whir/Whir/PCSBCSAdaptiveSourceKnowledgeProbability.lean b/verification/whir/Whir/PCSBCSAdaptiveSourceKnowledgeProbability.lean new file mode 100644 index 000000000..1b8ed6ca1 --- /dev/null +++ b/verification/whir/Whir/PCSBCSAdaptiveSourceKnowledgeProbability.lean @@ -0,0 +1,192 @@ +import Whir.PCSBCSAdaptiveSourceCallerSnapshot +import Whir.PCSBCSCapturedSourceProbability +import Whir.PCSBCSSourceSavedRecordProvenance + +/-! PCS-only adaptive source knowledge relation. Original coordinates may be +earlier caller coins: the actual source decoder and preparation reconstruct +them from erased OTHER values. A single fixed latent model therefore supports +the table average. The native codec/primitive evidence and the separately +charged Merkle bad-event boundary remain explicit; no Rust refinement or +concrete cryptographic assumption is silently added. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSAdaptiveSourceKnowledgeProbability +open Concrete Protocol CausalGame CausalProbability FiatShamirGame +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSSourceCallerSnapshot +open PCSBCSCapturedNativeReplyBridge +open PCSBCSCallerBinding PCSBCSCapturedSourceTransport PCSBCSCapturedSourceAcceptance +open PCSBCSCapturedSourceStatePath PCSBCSRestorationHazard PCSRoundByRoundTranscriptState +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +noncomputable local instance (key : Keys) : Fintype (Answers key) := + Restoration.instFintypeAnswer p Q iv boundary key + +/-- The original is the exact result of the existing source decoder and +preparation, not a caller held fixed independently of its earlier coins. The +native witness exposes actual acceptance and failure of the actual extractor, +with the fixed primitive and literal full-prefix native codec conditions. -/ +structure FailureWitness {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) where + saved : AnchoredHeaderCodec.Record + original : CallerInput p + native : PCSBCSCapturedSourceProbability.FailureWitness layout saved + (PCSBCSSourceCallerAnswers.answers table) program original table + constructed : PCSBCSSourceCallerOriginal.original p layout saved native.final.1.val + (PCSBCSSourceCallerAnswers.answers table) = some original + +def Failed {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : Prop := + Nonempty (FailureWitness layout program table) + +private theorem path_transport {K : Type} {A : K → Type} {P : Type} + (old next : NodeModel K A P) (table : Table K A) (exposed : List (Sigma A)) + (sameBefore : ∀ key, (⟨key,table key⟩ : Sigma A) ∈ exposed → + before next key table = before old key table) + (sameAfter : ∀ key, (⟨key,table key⟩ : Sigma A) ∈ exposed → + after next key table = after old key table) + {start finish : Bool} (path : StatePath old table exposed start finish) : + StatePath next table exposed start finish := by + induction path with + | nil state => exact .nil state + | step key recorded rest ih => + have result : StatePath next table exposed (before next key table) _ := + .step key recorded (by simpa only [sameAfter key recorded] using ih) + simpa only [sameBefore key recorded] using result + +private theorem path_exposed_mono {K : Type} {A : K → Type} {P : Type} + (model : NodeModel K A P) (table : Table K A) (old next : List (Sigma A)) + (subset : ∀ event ∈ old, event ∈ next) {start finish : Bool} + (path : StatePath model table old start finish) : + StatePath model table next start finish := by + induction path with + | nil state => exact .nil state + | step key recorded rest ih => exact .step key (subset _ recorded) ih + +private theorem data_literal (original : CallerInput p) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) + (replies : Array Reply) (q : Coordinate (ParameterBounds.config p)) (data : CallerData p) + (originalEq : data.original = original) (rootEq : data.observed.root = root) + (traceEq : data.observed.trace = incomingTrace ring t replies q) : + data = literalCallerData p original root ring t replies q := by + cases data with + | mk input observed => + cases observed with + | mk image trace => + dsimp only at originalEq rootEq traceEq + subst input image trace + rfl + +/-- Actual accepting source witnesses produce the path of ONE fixed adaptive +model. The state path, snapshot success, adjacent links, original input and +terminal restoration Boolean are all derived, not endpoint hypotheses. -/ +theorem accepted_failure_statePath {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (w : FailureWitness layout program table) : + StatePath (PCSBCSAdaptiveSourceCallerSnapshot.model layout program) + table (Sampling.execute table program).2 false true := by + classical + let saved := w.saved + let answers := PCSBCSSourceCallerAnswers.answers table + let addresses : Keys → List Reference := address + let ref : Reference := ⟨saved.root,initialShape saved.shape⟩ + let root := sourceRoot w.native.primitive addresses ref program table + let native := nativeReplies w.original root w.native.strategy w.native.ring w.native.tape + let old := Restoration.model p Q iv boundary + (PCSBCSCapturedSourceStatePath.builder addresses ref program w.original saved) + let next := PCSBCSAdaptiveSourceCallerSnapshot.model layout program + let selected : List (Sigma Answers) := (packets w.native.final).map fun current => + ⟨.inl current,table (.inl current)⟩ + have checked := PCSBCSCapturedSourceAcceptance.accepted_failure_statePath + w.native.primitive layout saved answers program table w.native.final w.original + w.native.claims w.native.valid w.native.profile w.native.caller w.native.bound + w.native.terminal w.native.recorded w.native.authentic w.native.clean w.native.ring + w.native.tape w.native.strategy w.native.raws w.native.transport w.native.accepted w.native.failed + have snapshots (current : EnteredPacket p Q iv boundary) (member : current ∈ packets w.native.final) : + fromCapture addresses ref program w.original saved current (fun key => table key.val) = + some (literalCallerData p w.original root w.native.ring w.native.tape native current.2.coord) := by + obtain ⟨data,assembled,originalEq,rootEq,traceEq⟩ := checked.2.1 current member + rw [data_literal w.original root w.native.ring w.native.tape native current.2.coord + data originalEq rootEq traceEq] at assembled + exact assembled + have chosenPath : StatePath old table selected false true := + accepted_failure_path_of_snapshots addresses ref program w.original saved table + (packets w.native.final) selected root w.native.ring w.native.tape w.native.strategy + (by intro current member; exact List.mem_map.mpr ⟨current,member,rfl⟩) + snapshots w.native.raws (packets_consecutive w.native.final w.native.terminal) + (packets_initial w.native.final w.native.terminal) + (packets_terminal w.native.final w.native.terminal) (packets_nonempty w.native.final) + w.native.accepted w.native.failed + have nodeEq (current : EnteredPacket p Q iv boundary) (member : current ∈ packets w.native.final) : + publicNode next (.inl current) table = publicNode old (.inl current) table := by + have constructed : PCSBCSSourceCallerOriginal.original p layout saved current.1.val answers = + some w.original := by + rw [packets_entry w.native.final current member] + exact w.constructed + have recovered : PCSBCSSourceSavedRecordDecoder.decode p current.1.val = some saved := by + rw [packets_entry w.native.final current member] + exact PCSBCSSourceSavedRecordProvenance.decode_saved_profileShape + p layout saved w.native.final.1.val answers w.native.claims w.native.caller + w.native.valid w.native.profile + exact PCSBCSAdaptiveSourceCallerSnapshot.publicNode_original layout saved program current + table w.original recovered constructed + have beforeEq (key : Keys) (recorded : (⟨key,table key⟩ : Sigma Answers) ∈ selected) : + before next key table = before old key table := by + obtain ⟨current,member,same⟩ := List.mem_map.mp recorded + have keyEq : .inl current = key := congrArg Sigma.fst same + subst key + unfold PCSStateRestoration.Latent.before + rw [nodeEq current member] + rfl + have afterEq (key : Keys) (recorded : (⟨key,table key⟩ : Sigma Answers) ∈ selected) : + after next key table = after old key table := by + obtain ⟨current,member,same⟩ := List.mem_map.mp recorded + have keyEq : .inl current = key := congrArg Sigma.fst same + subst key + unfold PCSStateRestoration.Latent.after + rw [nodeEq current member] + rfl + have transported := path_transport old next table selected beforeEq afterEq chosenPath + apply path_exposed_mono next table selected (Sampling.execute table program).2 _ transported + intro event recorded + obtain ⟨current,member,same⟩ := List.mem_map.mp recorded + have actual := w.native.recorded current member + rw [same] at actual + exact actual + +open Classical in +/-- Exact adaptive first-disclosure knowledge loss. Earlier caller coordinates +are actual source coins, reconstructed from erased values. The physical source +has Q requests total and the grouped source keeps index Q. This bounds the +explicit native-source relation outside the separately accounted Merkle bad +events; it is PCS-only and is not unconditional concrete hash security. -/ +theorem failure_probability {R : Type} + (layout : WHIRCallerClaims.CallerLayout) + (program : Sampling Keys Answers R Q) : + Soundness.uniformProb (Finset.univ.filter (Failed layout program)) ≤ + (Q : ℚ) * PCSRoundByRoundKnowledge.rbrError := by + have nonnegative : (0 : ℚ) ≤ PCSRoundByRoundKnowledge.rbrError := by + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + have result := accepted_path_failure_probability + (PCSBCSAdaptiveSourceCallerSnapshot.model layout program) Q 0 program + PCSRoundByRoundKnowledge.rbrError nonnegative + (PCSBCSAdaptiveSourceCallerSnapshot.conditional_hazard layout program) + (Failed layout program) (by + intro table failed + obtain ⟨w⟩ := failed + exact accepted_failure_statePath layout program table w) + simpa only [Nat.add_zero] using result + +#print axioms accepted_failure_statePath +#print axioms failure_probability +end Whir.PCSBCSAdaptiveSourceKnowledgeProbability diff --git a/verification/whir/Whir/PCSBCSAtomicAllocationTrace.lean b/verification/whir/Whir/PCSBCSAtomicAllocationTrace.lean new file mode 100644 index 000000000..e40fc7b27 --- /dev/null +++ b/verification/whir/Whir/PCSBCSAtomicAllocationTrace.lean @@ -0,0 +1,79 @@ +import Whir.PCSBCSChallengeOraclePackets + +/-! The actual atomic compiler records complete dependent packet answers. +This is a trace identity, not an assertion that native acceptance or every +completion prefix has already been recorded. -/ +set_option autoImplicit false +namespace Whir.PCSBCSAtomicAllocationTrace +open FiatShamirGame TypedOracleCompiler RawOracleCoupling PCSBCSChallengeOracle + +variable {Raw Packet : Type} {Block : Packet → Type} + +def allocation (part : Partition Raw Packet Block) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + (raw : Raw) : Sigma (part.Answer (D := Digest32)) := + match found : part.recognize raw with + | some block => ⟨.inl block.1,table (.inl block.1)⟩ + | none => ⟨.inr ⟨raw,found⟩,table (.inr ⟨raw,found⟩)⟩ + +theorem execute_request (part : Partition Raw Packet Block) + (table : (key : part.Key) → part.Answer (D := Digest32) key) (raw : Raw) : + (Sampling.execute table (Atomic.request part raw)).2 = [allocation part table raw] := by + unfold Atomic.request allocation + split + · rename_i first hit + split + · rename_i second other + have same := Option.some.inj (hit.symm.trans other) + cases same + rfl + · rename_i missed + have impossible := hit.symm.trans missed + cases impossible + · rename_i missed + split + · rename_i second hit + have impossible := missed.symm.trans hit + cases impossible + · rfl + +theorem execute_program (part : Partition Raw Packet Block) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + {R : Type} {n : Nat} (program : Sampling Raw (fun _ => Digest32) R n) : + (Sampling.execute table (Atomic.program part program)).2 = + ((Sampling.execute (part.join table) program).2.map + (fun actual => allocation part table actual.1)) := by + induction program with + | ret result => rfl + | draw raw next ih => + simp only [Atomic.program,Sampling.execute_pad,Sampling.execute_bind, + Atomic.eval_request,Sampling.execute,List.map_cons] + rw [execute_request,ih] + rfl + +theorem recognized_recorded (part : Partition Raw Packet Block) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + {R : Type} {n : Nat} (program : Sampling Raw (fun _ => Digest32) R n) + (raw : Raw) (answer : Digest32) (block : Sigma Block) + (recorded : (⟨raw,answer⟩ : Sigma (fun _ : Raw => Digest32)) ∈ + (Sampling.execute (part.join table) program).2) + (recognized : part.recognize raw = some block) : + (⟨.inl block.1,table (.inl block.1)⟩ : Sigma (part.Answer (D := Digest32))) ∈ + (Sampling.execute table (Atomic.program part program)).2 := by + rw [execute_program] + apply List.mem_map.mpr + refine ⟨⟨raw,answer⟩,recorded,?_⟩ + unfold allocation + split + · rename_i actual found + have same := Option.some.inj (found.symm.trans recognized) + cases same + rfl + · rename_i absent + have impossible := recognized.symm.trans absent + cases impossible + +#print axioms execute_request +#print axioms execute_program +#print axioms recognized_recorded +end Whir.PCSBCSAtomicAllocationTrace diff --git a/verification/whir/Whir/PCSBCSAtomicTrace.lean b/verification/whir/Whir/PCSBCSAtomicTrace.lean new file mode 100644 index 000000000..f891a677a --- /dev/null +++ b/verification/whir/Whir/PCSBCSAtomicTrace.lean @@ -0,0 +1,70 @@ +import Whir.RawOracleCoupling + +/-! Exact full-answer trace provenance for the actual global memo interpreter. +Cache hits retain the first allocation's complete answer, including hidden bytes. +The result concerns operational executions, not a supplied allocation certificate. -/ +set_option autoImplicit false +namespace Whir.PCSBCSAtomicTrace +open TypedOracleCompiler TypedFiatShamirGame RawOracleCoupling + +universe u v w +variable {Key : Type u} {Answer : Key → Type v} {R : Type w} +variable [DecidableEq Key] + +/-- Every cached answer has its literal dependent key/value in the allocated trace. -/ +def Recorded (cache : Cache Key Answer) (trace : List (Sigma Answer)) : Prop := + ∀ key answer, cache key = some answer → (⟨key,answer⟩ : Sigma Answer) ∈ trace + +omit [DecidableEq Key] in +theorem empty_recorded : Recorded (Answer := Answer) (fun _ : Key => none) [] := by + intro key answer hit + cases hit + +theorem insert_recorded {cache : Cache Key Answer} {before : List (Sigma Answer)} + (recorded : Recorded cache before) (key : Key) (answer : Answer key) : + Recorded (put cache key answer) (before ++ [⟨key,answer⟩]) := by + intro other value hit + by_cases same : other = key + · subst other + rw [put_self] at hit + cases Option.some.inj hit + exact List.mem_append_right _ (by simp) + · rw [put_other _ _ _ _ same] at hit + exact List.mem_append_left _ (recorded other value hit) + +/-- Every branch, including replay and early abort, preserves literal provenance. -/ +theorem memo_recorded {n : Nat} (program : Sampling Key Answer R n) + (cache : Cache Key Answer) {before trace : List (Sigma Answer)} + {result : R × Cache Key Answer} (recorded : Recorded cache before) + (run : Sampling.Runs (memo program cache) trace result) : + Recorded result.2 (before ++ trace) := by + induction program generalizing cache before trace result with + | ret value => + cases run + simpa only [List.append_nil] using recorded + | draw key next ih => + cases hit : cache key with + | some answer => + simp only [memo, hit, Sampling.runs_pad] at run + exact ih answer cache recorded run + | none => + simp only [memo, hit] at run + cases run with + | draw answer rest => + have extended := ih answer (put cache key answer) + (insert_recorded recorded key answer) rest + simpa only [List.append_assoc, List.singleton_append] using extended + +/-- A returned cached packet is found in the actual trace even when its last +use was only a replay. No per-block exposure or scalar-cache premise is needed. -/ +theorem cached_answer_allocated {n : Nat} (program : Sampling Key Answer R n) + {trace : List (Sigma Answer)} {result : R × Cache Key Answer} + (run : Sampling.Runs (memo program (fun _ => none)) trace result) + (key : Key) (answer : Answer key) (hit : result.2 key = some answer) : + (⟨key,answer⟩ : Sigma Answer) ∈ trace := by + have recorded := memo_recorded program (fun _ => none) empty_recorded run + simpa only [List.nil_append] using recorded key answer hit + +#print axioms memo_recorded +#print axioms cached_answer_allocated +end Whir.PCSBCSAtomicTrace diff --git a/verification/whir/Whir/PCSBCSCallerBusTablePolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerBusTablePolynomialBound.lean new file mode 100644 index 000000000..d4f7e5847 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerBusTablePolynomialBound.lean @@ -0,0 +1,1121 @@ +import Whir.PCSBCSCallerGKRPolynomialBound + +/-! Deterministic polynomial source-operation bounds for the concrete bus and +AIR receivers. Literal numeric configuration entries contribute additively to +size; these counters are not CPU timing bounds. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 +set_option linter.unusedSimpArgs false +namespace Whir.PCSBCSCallerParserCost +open Concrete WHIRCallerClaims + +/-- Unary magnitude of the literal AIR configuration, including list cells. -/ +def airLayoutSize (l : AirLayout) : Nat := + 1+l.tau+l.columns+l.publicColumns+ + (l.fields.map (fun f => 1+f.column+f.width)).sum + +private def tableStep (layout : AirLayout) (slices : List E) (c : Nat) + (state : List E × List E) : Parser (ForInStep (List E × List E)) := do + let found := fieldOf c layout.fields 0 + tick (found.work+2) + match found.value with + | some (f,start) => + let combined := combineBits ((slices.drop start).take f.width) + tick (dropCost start slices+takeCost f.width (slices.drop start)+ + combined.work+appendCost state.2+1) + pure (.yield (state.1,state.2++[combined.value])) + | none => + tick 1 + match state.1 with + | [] => do check false; pure (.yield state) + | x :: xs => do + tick (appendCost state.2+2) + pure (.yield (xs,state.2++[x])) + +private theorem tableStep_work_le (l : AirLayout) (slices : List E) + (c : Nat) (state : List E × List E) (tokens : List CallerToken) : + (tableStep l slices c state tokens).work ≤ + 2*state.2.length+3*slices.length*slices.length+20*slices.length+ + 5*l.fields.length+20 := by + have search := fieldOf_work_le c l.fields 0 + unfold tableStep + rw [tick_bind_work] + cases found : (fieldOf c l.fields 0).value with + | some pair => + rcases pair with ⟨f,start⟩ + dsimp only [] + rw [tick_bind_work] + have combined := combineBits_work_le ((slices.drop start).take f.width) + have short : ((slices.drop start).take f.width).length ≤ slices.length := by + simp only [List.length_take,List.length_drop] + omega + simp only [pure,dropCost,takeCost,appendCost,List.length_drop] + have h1 := Nat.min_le_right start slices.length + have h2 := Nat.min_le_right f.width (slices.length-start) + have square := Nat.mul_self_le_mul_self short + nlinarith [Nat.sub_le slices.length start] + | none => + dsimp only [] + rw [tick_bind_work] + cases cursor : state.1 with + | nil => simp [Bind.bind,check,bind,pure]; omega + | cons x xs => + rw [tick_bind_work] + simp only [pure,appendCost] + omega + +private theorem tableStep_success (l : AirLayout) (slices : List E) + (c : Nat) (state : List E × List E) (tokens rest : List CallerToken) + (step : ForInStep (List E × List E)) + (accepted : (tableStep l slices c state tokens).result = some (step,rest)) : + ∃ next, step = .yield next ∧ next.2.length = state.2.length+1 := by + unfold tableStep at accepted + dsimp only [Bind.bind,bind,tick] at accepted + cases found : (fieldOf c l.fields 0).value with + | some pair => + rcases pair with ⟨f,start⟩ + simp only [found,bind,tick,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,by simp⟩ + | none => + simp only [found] at accepted + cases cursor : state.1 with + | nil => simp [cursor,Bind.bind,bind,check,tick] at accepted + | cons x xs => + simp only [cursor,bind,tick,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,by simp⟩ + +private theorem tableLoop_work_le (l : AirLayout) (slices sent : List E) + (tokens : List CallerToken) : + (forIn (List.range (l.columns-l.publicColumns)) (sent,[]) + (tableStep l slices) tokens).work ≤ + (l.columns-l.publicColumns) * + (2*(l.columns-l.publicColumns)+3*slices.length*slices.length+ + 20*slices.length+5*l.fields.length+20) := by + have bounded := forIn_growth_work_le + (List.range (l.columns-l.publicColumns)) (sent,[]) (tableStep l slices) + (fun state => state.2.length) 2 + (3*slices.length*slices.length+20*slices.length+5*l.fields.length+20) 1 + (by intro c _ state ts; simpa [Nat.add_assoc] using tableStep_work_le l slices c state ts) + (by + intro c _ state ts step rest accepted + obtain ⟨next,rfl,growth⟩ := tableStep_success l slices c state ts rest step accepted + simp [iterationState,growth]) tokens + simpa [List.length_range,Nat.add_assoc] using bounded + +private theorem forIn_exact_growth {A B : Type} (xs : List A) (body : A → B → Parser (ForInStep B)) + (size : B → Nat) + (grows : ∀ x state ts step rest, (body x state ts).result = some (step,rest) → + ∃ next, step = .yield next ∧ size next = size state+1) + (initial final : B) (tokens rest : List CallerToken) + (accepted : (forIn xs initial body tokens).result = some (final,rest)) : + size final = size initial+xs.length := by + induction xs generalizing initial tokens with + | nil => + simp only [List.forIn_nil] at accepted + change some (initial,tokens) = some (final,rest) at accepted + cases accepted + simp + | cons x xs ih => + rw [List.forIn_cons] at accepted + change (bind (body x initial) _ tokens).result = some (final,rest) at accepted + cases first : (body x initial tokens).result with + | none => simp [bind,first] at accepted + | some pair => + rcases pair with ⟨step,middle⟩ + obtain ⟨next,rfl,growth⟩ := grows x initial tokens step middle first + simp only [bind,first] at accepted + have tail := ih next middle accepted + simp only [List.length_cons] + omega + +private theorem tableLoop_success (l : AirLayout) (slices sent : List E) + (tokens rest : List CallerToken) (final : List E × List E) + (accepted : (forIn (List.range (l.columns-l.publicColumns)) (sent,[]) + (tableStep l slices) tokens).result = some (final,rest)) : + final.2.length = l.columns-l.publicColumns := by + have exactLength := forIn_exact_growth + (List.range (l.columns-l.publicColumns)) (tableStep l slices) (fun state => state.2.length) + (fun c state ts step tail h => tableStep_success l slices c state ts tail step h) + (sent,[]) final tokens rest accepted + simpa using exactLength + +private theorem tick_work_le (n : Nat) (tokens : List CallerToken) : + (tick n tokens).work ≤ n := Nat.le_refl _ + +private theorem pure_work_le {A : Type} (value : A) (tokens : List CallerToken) : + ((Pure.pure value : Parser A) tokens).work ≤ 0 := Nat.le_refl _ + +private theorem tableLoop_work_size (l : AirLayout) (slices sent : List E) + (tokens : List CallerToken) + (length : slices.length = (l.fields.map BitField.width).sum) : + (forIn (List.range (l.columns-l.publicColumns)) (sent,[]) + (tableStep l slices) tokens).work ≤ + (l.columns-l.publicColumns) * + (2*(l.columns-l.publicColumns)+3*(l.fields.map BitField.width).sum* + (l.fields.map BitField.width).sum+ + 20*(l.fields.map BitField.width).sum+5*l.fields.length+20) := by + simpa [length] using tableLoop_work_le l slices sent tokens + +/-- A literal polynomial, valid for every input, including every rejecting +guard, exhausted cursor, and malformed or truncated scalar stream. -/ +def receiveTableWork (l : AirLayout) (p : List E) : Nat := + 10*p.length+20*l.columns+30*l.fields.length+2*l.fields.length*l.fields.length+ + 9*(l.fields.map BitField.width).sum+50+ + l.columns*(2*l.columns+3*(l.fields.map BitField.width).sum* + (l.fields.map BitField.width).sum+20*(l.fields.map BitField.width).sum+ + 5*l.fields.length+20) + +private theorem eraseDups_length_le {A : Type} [BEq A] (xs : List A) : + xs.eraseDups.length ≤ xs.length := by + have loop (as seen : List A) : + (List.eraseDupsBy.loop (fun a b => a == b) as seen).length ≤ as.length+seen.length := by + induction as generalizing seen with + | nil => simp [List.eraseDupsBy.loop] + | cons a as ih => + simp only [List.eraseDupsBy.loop] + split + · have := ih seen; simp only [List.length_cons]; omega + · have := ih (a::seen); simp only [List.length_cons] at *; omega + exact loop xs [] + +syntax "table_cost" : tactic +macro_rules +| `(tactic| table_cost) => `(tactic| + first + | exact tick_work_le _ _ + | exact check_work_le _ _ + | exact readScalars_work_le _ _ + | exact pure_work_le _ _ + | exact tableLoop_work_size _ _ _ _ (readScalars_success_length _ _ _ _ (by assumption)) + | (apply bind_work_le + · table_cost + · intro value tail parsed; table_cost)) + +theorem receiveTable_work_le (l : AirLayout) (p : List E) (tokens : List CallerToken) : + (receiveTable l p tokens).work ≤ receiveTableWork l p := by + have scans := allCost_le + (fun f : BitField => decide (f.column < l.columns-l.publicColumns) && decide (f.width ≤ 64)) + (fun f => if f.column < l.columns-l.publicColumns then 3 else 2) + l.fields 3 (by intro f _; split <;> omega) + have dups := eraseDupsCost_le 1 (l.fields.map BitField.column) [] + have short := eraseDups_length_le (l.fields.map BitField.column) + have hn := Nat.sub_le l.columns l.publicColumns + have loopMono : + (l.columns-l.publicColumns) * + (2*(l.columns-l.publicColumns)+3*(l.fields.map BitField.width).sum* + (l.fields.map BitField.width).sum+20*(l.fields.map BitField.width).sum+ + 5*l.fields.length+20) ≤ + l.columns*(2*l.columns+3*(l.fields.map BitField.width).sum* + (l.fields.map BitField.width).sum+20*(l.fields.map BitField.width).sum+ + 5*l.fields.length+20) := + Nat.mul_le_mul hn (by omega) + apply Nat.le_trans + · unfold receiveTable + table_cost + · simp only [receiveTableWork,lengthCost,takeCost,List.length_map,List.length_nil] at * + split <;> nlinarith [Nat.min_le_right l.tau p.length, + Nat.sub_le l.columns l.publicColumns, + Nat.sub_le (l.columns-l.publicColumns) l.fields.length] + +private theorem tick_bind_result {A : Type} (n : Nat) (next : Unit → Parser A) + (tokens : List CallerToken) : + ((tick n >>= next) tokens).result = (next () tokens).result := rfl + +private theorem bind_success {A B : Type} (before : Parser A) (next : A → Parser B) + (tokens rest : List CallerToken) (output : B) + (accepted : ((before >>= next) tokens).result = some (output,rest)) : + ∃ value middle, (before tokens).result = some (value,middle) ∧ + (next value middle).result = some (output,rest) := by + change (bind before next tokens).result = _ at accepted + cases first : (before tokens).result with + | none => simp [bind,first] at accepted + | some pair => + rcases pair with ⟨value,middle⟩ + exact ⟨value,middle,rfl,by simpa [bind,first] using accepted⟩ + +private theorem check_bind_success {A : Type} (ok : Bool) (next : Unit → Parser A) + (tokens rest : List CallerToken) (output : A) + (accepted : ((check ok >>= next) tokens).result = some (output,rest)) : + ok = true ∧ (next () tokens).result = some (output,rest) := by + cases ok + · simp [Bind.bind,check,bind] at accepted + · exact ⟨rfl,accepted⟩ + +/-- Actual returned cardinalities; no externally supplied claim-size certificate. -/ +theorem receiveTable_success_lengths (l : AirLayout) (p : List E) + (tokens rest : List CallerToken) (output : TableClaims) + (accepted : (receiveTable l p tokens).result = some (output,rest)) : + output.point.length = l.tau ∧ + output.evals.length = l.columns-l.publicColumns ∧ + output.slices.length = (l.fields.map BitField.width).sum := by + unfold receiveTable at accepted + simp only [tick_bind_result] at accepted + obtain ⟨valid,accepted⟩ := check_bind_success _ _ _ _ _ accepted + have tauBound : l.tau ≤ p.length := by + simp at valid + exact valid.2 + simp only [tick_bind_result] at accepted + obtain ⟨_,accepted⟩ := check_bind_success _ _ _ _ _ accepted + simp only [tick_bind_result] at accepted + obtain ⟨_,accepted⟩ := check_bind_success _ _ _ _ _ accepted + simp only [tick_bind_result] at accepted + obtain ⟨sent,middle,_,accepted⟩ := bind_success _ _ _ _ _ accepted + simp only [tick_bind_result] at accepted + obtain ⟨slices,middle,slicesRead,accepted⟩ := bind_success _ _ _ _ _ accepted + have slicesLength := readScalars_success_length _ _ _ _ slicesRead + simp only [tick_bind_result] at accepted + obtain ⟨final,middle,loopRead,accepted⟩ := bind_success _ _ _ _ _ accepted + have evalsLength := tableLoop_success l slices sent _ _ final loopRead + simp only [tick_bind_result] at accepted + obtain ⟨_,accepted⟩ := check_bind_success _ _ _ _ _ accepted + simp only [tick_bind_result,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + simp only [List.length_take,Nat.min_eq_left tauBound] + exact ⟨True.intro,evalsLength,slicesLength⟩ + +private theorem fieldSize_components (fs : List BitField) : + fs.length ≤ (fs.map (fun f => 1+f.column+f.width)).sum ∧ + (fs.map BitField.width).sum ≤ (fs.map (fun f => 1+f.column+f.width)).sum := by + induction fs with + | nil => simp + | cons f fs ih => + simp only [List.map_cons,List.sum_cons,List.length_cons] + omega + +theorem airLayoutSize_components (l : AirLayout) : + l.columns ≤ airLayoutSize l ∧ l.tau ≤ airLayoutSize l ∧ + l.fields.length ≤ airLayoutSize l ∧ + (l.fields.map BitField.width).sum ≤ airLayoutSize l := by + have := fieldSize_components l.fields + unfold airLayoutSize + omega + +theorem receiveTable_success_caps (l : AirLayout) (p : List E) + (tokens rest : List CallerToken) (output : TableClaims) (size : Nat) + (configuration : airLayoutSize l ≤ size) + (accepted : (receiveTable l p tokens).result = some (output,rest)) : + output.point.length ≤ size ∧ output.evals.length ≤ size ∧ output.slices.length ≤ size := by + have lengths := receiveTable_success_lengths l p tokens rest output accepted + have components := airLayoutSize_components l + omega + +theorem receiveTable_work_polynomial (l : AirLayout) (p : List E) + (tokens : List CallerToken) (size : Nat) + (configuration : airLayoutSize l ≤ size) (point : p.length ≤ size) : + (receiveTable l p tokens).work ≤ 100*(size+1)^3 := by + have components := airLayoutSize_components l + have columns : l.columns ≤ size := by omega + have fields : l.fields.length ≤ size := by omega + have widths : (l.fields.map BitField.width).sum ≤ size := by omega + have squares := Nat.mul_self_le_mul_self widths + have fieldSquares := Nat.mul_self_le_mul_self fields + have inner : + 2*l.columns+3*(l.fields.map BitField.width).sum*(l.fields.map BitField.width).sum+ + 20*(l.fields.map BitField.width).sum+5*l.fields.length+20 ≤ + 3*size*size+27*size+20 := by nlinarith + have loopBound := Nat.mul_le_mul columns inner + apply (receiveTable_work_le l p tokens).trans + unfold receiveTableWork + nlinarith + +/-- All literal AIR entries, with a cell charge for the outer list. -/ +def airLayoutsSize (layouts : List AirLayout) : Nat := + 1+(layouts.map (fun l => 1+airLayoutSize l)).sum + +private theorem airLayouts_components (layouts : List AirLayout) : + layouts.length ≤ (layouts.map (fun l => 1+airLayoutSize l)).sum ∧ + (∀ l ∈ layouts, airLayoutSize l ≤ (layouts.map (fun l => 1+airLayoutSize l)).sum) := by + induction layouts with + | nil => simp + | cons l ls ih => + simp only [List.map_cons,List.sum_cons,List.length_cons,List.mem_cons] + constructor + · omega + · intro next member + rcases member with rfl | member + · omega + · have := ih.2 next member; omega + +private theorem foldMax_le (xs : List Nat) (initial cap : Nat) + (start : initial ≤ cap) (entries : ∀ x ∈ xs, x ≤ cap) : + xs.foldl max initial ≤ cap := by + induction xs generalizing initial with + | nil => exact start + | cons x xs ih => + simp only [List.foldl_cons] + apply ih + · exact max_le start (entries x (by simp)) + · intro y member; exact entries y (by simp [member]) + +private theorem constraintRounds_work_le (n : Nat) (tokens : List CallerToken) : + ((List.range n).mapM (fun _ => do + tick 2 + let _ ← readScalars 3 + drawScalar) tokens).work ≤ 35*n := by + simpa using mapM_work_le (List.range n) _ 35 (by + intro i _ ts + rw [tick_bind_work] + have h := bind_work_le (readScalars 3) (fun _ => drawScalar) ts 29 4 + (readScalars_work_le 3 ts) (by intro _ tail _; exact drawScalar_work_le tail) + omega) tokens + +private theorem constraintTables_work_le (layouts : List AirLayout) (rounds : List E) + (tokens : List CallerToken) (size : Nat) + (configuration : airLayoutsSize layouts ≤ size) (point : rounds.length ≤ size) : + (layouts.mapM (fun l => do + tick (2*rounds.length+3) + receiveTable l rounds.reverse) tokens).work ≤ + (100*(size+1)^3+2*size+3)*layouts.length := by + apply mapM_work_le + intro l member ts + rw [tick_bind_work] + have entry := (airLayouts_components layouts).2 l member + have config : airLayoutSize l ≤ size := by + unfold airLayoutsSize at configuration + omega + have work := receiveTable_work_polynomial l rounds.reverse ts size config (by simpa) + omega + +theorem constraintClaims_work_polynomial (layouts : List AirLayout) (p : List E) + (tokens : List CallerToken) (size : Nat) + (configuration : airLayoutsSize layouts ≤ size) (point : p.length ≤ size) : + (constraintClaims layouts p tokens).work ≤ + 100*(size+1)^3*size+2*size*size+50*size+20 := by + have components := airLayouts_components layouts + have length : layouts.length ≤ size := by unfold airLayoutsSize at configuration; omega + have maxBound : (layouts.map AirLayout.tau).foldl max 0 ≤ size := by + apply foldMax_le _ _ _ (Nat.zero_le _) + intro tau member + obtain ⟨l,sourceMember,equal⟩ := List.mem_map.mp member + subst tau + have entry := components.2 l sourceMember + have tau := (airLayoutSize_components l).2.1 + unfold airLayoutsSize at configuration + omega + have mapBound := Nat.mul_le_mul_left (100*(size+1)^3+2*size+3) length + unfold constraintClaims + apply Nat.le_trans + · apply bind_work_le + · exact tick_work_le _ _ + · intro _ tail _ + apply bind_work_le + · exact check_work_le _ _ + · intro _ tail _ + apply bind_work_le + · exact tick_work_le _ _ + · intro _ tail _ + apply bind_work_le + · exact constraintRounds_work_le _ _ + · intro rounds tail parsed + have roundsLength := mapM_success_length _ _ _ _ _ parsed + apply constraintTables_work_le _ _ _ size configuration + simp only [List.length_range] at roundsLength + exact roundsLength.trans_le maxBound + · unfold lengthCost + simp only [Nat.add_mul] at mapBound + nlinarith + +/-- Successful constraint traversal returns exactly one table per literal AIR. -/ +theorem constraintClaims_success_length (layouts : List AirLayout) (p : List E) + (tokens rest : List CallerToken) (output : List TableClaims) + (accepted : (constraintClaims layouts p tokens).result = some (output,rest)) : + output.length = layouts.length := by + unfold constraintClaims at accepted + simp only [tick_bind_result] at accepted + obtain ⟨_,accepted⟩ := check_bind_success _ _ _ _ _ accepted + simp only [tick_bind_result] at accepted + obtain ⟨rounds,middle,_,accepted⟩ := bind_success _ _ _ _ _ accepted + exact mapM_success_length _ _ _ _ _ accepted + +private theorem forIn_success_growth {A B : Type} (xs : List A) + (body : A → B → Parser (ForInStep B)) (size : B → Nat) (delta : Nat) + (grows : ∀ x ∈ xs, ∀ state ts step rest, (body x state ts).result = some (step,rest) → + ∃ next, step = .yield next ∧ size next ≤ size state+delta) + (initial final : B) (tokens rest : List CallerToken) + (accepted : (forIn xs initial body tokens).result = some (final,rest)) : + size final ≤ size initial+delta*xs.length := by + induction xs generalizing initial tokens with + | nil => + simp only [List.forIn_nil] at accepted + change some (initial,tokens) = some (final,rest) at accepted + cases accepted + simp + | cons x xs ih => + rw [List.forIn_cons] at accepted + obtain ⟨step,middle,first,accepted⟩ := bind_success _ _ _ _ _ accepted + obtain ⟨next,rfl,growth⟩ := grows x (by simp) initial tokens step middle first + have tail := ih + (fun y member st ts outcome tail h => grows y (by simp [member]) st ts outcome tail h) + next middle accepted + simp only [List.length_cons,Nat.mul_add,Nat.mul_one] + omega + +private abbrev BusState := List (Nat × Nat) × List ColumnClaim +private def busStateSize (state : BusState) : Nat := state.1.length+state.2.length + +private def busCoordStep (point : List E) (block : BusBlock) (coord : BusCoord) + (state : BusState) : Parser (ForInStep BusState) := do + tick 2 + match coord with + | .column col => + tick (memberCost (col,block.kappa) 2 state.1+1) + if (col,block.kappa) ∉ state.1 then + let value ← readScalar + tick (appendCost state.1+appendCost state.2+takeCost block.kappa point+5) + pure (.yield (state.1++[(col,block.kappa)], + state.2++[⟨col,point.take block.kappa,value⟩])) + else pure (.yield state) + | .publicValue => pure (.yield state) + | .tableExpression => do check false; pure (.yield state) + +private theorem busCoord_work_le (point : List E) (block : BusBlock) (coord : BusCoord) + (state : BusState) (tokens : List CallerToken) : + (busCoordStep point block coord state tokens).work ≤ + 5*busStateSize state+2*point.length+20 := by + have memberBound := memberCost_le (match coord with | .column col => col | _ => 0,block.kappa) + 2 state.1 + unfold busCoordStep + rw [tick_bind_work] + cases coord with + | column col => + rw [tick_bind_work] + split + · apply Nat.le_trans + · apply Nat.add_le_add_left + apply Nat.add_le_add_left + apply bind_work_le + · exact readScalar_work_le _ + · intro value tail _ + rw [tick_bind_work] + exact Nat.le_refl _ + · simp only [busStateSize,appendCost,takeCost,pure] at * + nlinarith [Nat.min_le_right block.kappa point.length] + · simp only [pure,busStateSize] at * + omega + | publicValue => simp [pure,busStateSize] + | tableExpression => simp [Bind.bind,bind,check,pure,busStateSize] + +private theorem busCoord_success (point : List E) (block : BusBlock) (coord : BusCoord) + (state : BusState) (tokens rest : List CallerToken) (step : ForInStep BusState) + (accepted : (busCoordStep point block coord state tokens).result = some (step,rest)) : + ∃ next, step = .yield next ∧ busStateSize next ≤ busStateSize state+2 := by + unfold busCoordStep at accepted + simp only [tick_bind_result] at accepted + cases coord with + | column col => + simp only [tick_bind_result] at accepted + split at accepted + · obtain ⟨value,middle,_,accepted⟩ := bind_success _ _ _ _ _ accepted + simp only [tick_bind_result,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,by simp only [busStateSize,List.length_append,List.length_cons,List.length_nil]; omega⟩ + · simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,by omega⟩ + | publicValue => + simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,by omega⟩ + | tableExpression => simp [Bind.bind,bind,check] at accepted + +private def busBlockStep (point : List E) (block : BusBlock) + (state : BusState) : Parser (ForInStep BusState) := do + tick (lengthCost point+4) + check (block.kappa ≤ point.length) + if !block.tableOwned then + let next ← forIn block.coords state (busCoordStep point block) + pure (.yield next) + else pure (.yield state) + +private theorem busBlock_work_le (point : List E) (block : BusBlock) + (state : BusState) (tokens : List CallerToken) (size : Nat) + (coordinates : block.coords.length ≤ size) (pointBound : point.length ≤ size) : + (busBlockStep point block state tokens).work ≤ + 5*size*busStateSize state+20*size*size+21*size+28 := by + have loop := forIn_growth_work_le block.coords state (busCoordStep point block) + busStateSize 5 (2*point.length+20) 2 + (by intro c _ st ts; exact busCoord_work_le point block c st ts) + (by + intro c _ st ts step rest accepted + obtain ⟨next,rfl,growth⟩ := busCoord_success point block c st ts rest step accepted + exact growth) tokens + have loopBound : block.coords.length* + (5*(busStateSize state+2*block.coords.length)+(2*point.length+20)) ≤ + size*(5*busStateSize state+12*size+20) := + Nat.mul_le_mul coordinates (by omega) + unfold busBlockStep + rw [tick_bind_work] + apply Nat.le_trans + · apply Nat.add_le_add_left + apply bind_work_le + · exact check_work_le _ _ + · intro _ tail _ + split + · apply bind_work_le + · exact forIn_growth_work_le block.coords state (busCoordStep point block) + busStateSize 5 (2*point.length+20) 2 + (by intro c _ st ts; exact busCoord_work_le point block c st ts) + (by + intro c _ st ts step rest accepted + obtain ⟨next,rfl,growth⟩ := busCoord_success point block c st ts rest step accepted + exact growth) tail + · intro _ _ _; exact pure_work_le _ _ + · exact (pure_work_le _ _).trans (Nat.zero_le _) + · unfold lengthCost + nlinarith + + +private theorem busBlock_success (point : List E) (block : BusBlock) + (state : BusState) (tokens rest : List CallerToken) (step : ForInStep BusState) + (accepted : (busBlockStep point block state tokens).result = some (step,rest)) : + ∃ next, step = .yield next ∧ + busStateSize next ≤ busStateSize state+2*block.coords.length := by + unfold busBlockStep at accepted + simp only [tick_bind_result] at accepted + obtain ⟨_,accepted⟩ := check_bind_success _ _ _ _ _ accepted + split at accepted + · obtain ⟨next,middle,loopRead,accepted⟩ := bind_success _ _ _ _ _ accepted + have growth := forIn_success_growth block.coords (busCoordStep point block) + busStateSize 2 + (fun c _ st ts outcome tail h => busCoord_success point block c st ts tail outcome h) + state next tokens middle loopRead + simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨next,rfl,growth⟩ + · simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,by omega⟩ + +/-- Every bus literal (including unused producer windows and coordinate indices) +is represented additively; powers of two are not counted as input magnitude. -/ +def busCoordSize : BusCoord → Nat + | .column col => 1+col + | .publicValue => 1 + | .tableExpression => 1 +def busBlockSize (block : BusBlock) : Nat := + 2+block.kappa+(block.coords.map busCoordSize).sum +def busLayoutSize (l : BusLayout) : Nat := + 3+l.grinding+(l.push.map busBlockSize).sum+(l.pull.map busBlockSize).sum+ + (l.producers.map (fun p => 1+p.kappa+p.bits+p.window)).sum + +private theorem sum_bound {A : Type} (xs : List A) (weight : A → Nat) + (positive : ∀ x, 1 ≤ weight x) : + xs.length ≤ (xs.map weight).sum ∧ ∀ x ∈ xs, weight x ≤ (xs.map weight).sum := by + induction xs with + | nil => simp + | cons x xs ih => + simp only [List.map_cons,List.sum_cons,List.length_cons,List.mem_cons] + constructor + · have := positive x; omega + · intro next member + rcases member with rfl | member + · omega + · have := ih.2 next member; omega + +private theorem blockSize_components (block : BusBlock) : + block.coords.length ≤ busBlockSize block ∧ block.kappa ≤ busBlockSize block := by + have coords := sum_bound block.coords busCoordSize (by intro c; cases c <;> simp [busCoordSize]) + unfold busBlockSize + omega + +theorem busLayoutSize_components (l : BusLayout) : + (l.push++l.pull).length ≤ busLayoutSize l ∧ + ∀ block ∈ l.push++l.pull, block.coords.length ≤ busLayoutSize l := by + have entries := sum_bound (l.push++l.pull) busBlockSize + (by intro b; unfold busBlockSize; omega) + simp only [List.map_append,List.sum_append] at entries + unfold busLayoutSize + constructor + · omega + · intro b member + have entry := entries.2 b member + have coords := (blockSize_components b).1 + omega + +private theorem add_power_bound (a b x y : Nat) (left : x ≤ 2^a) (right : y ≤ 2^b) : + x+y ≤ 2^(1+a+b) := by + have l := Nat.pow_le_pow_right (by decide : 0<2) (Nat.le_add_right a b) + have r := Nat.pow_le_pow_right (by decide : 0<2) (Nat.le_add_left b a) + have equal : 2^(1+a+b) = 2^(a+b)*2 := by + rw [show 1+a+b = (a+b)+1 by omega,Nat.pow_succ] + rw [equal] + omega + +private theorem sum_power_bound {A : Type} (xs : List A) (value budget : A → Nat) + (entries : ∀ x, value x ≤ 2^(budget x)) : + (xs.map value).sum ≤ 2^((xs.map (fun x => 1+budget x)).sum) := by + induction xs with + | nil => simp + | cons x xs ih => + simp only [List.map_cons,List.sum_cons] + exact add_power_bound _ _ _ _ (entries x) ih + +theorem bus_mu_le_size (l : BusLayout) : l.mu ≤ busLayoutSize l := by + let pushSize := (l.push.map (fun b => 1+b.kappa)).sum + let pullSize := (l.pull.map (fun b => 1+b.kappa)).sum + let prodSize := (l.producers.map (fun p => 1+(p.bits+p.kappa))).sum + have push := sum_power_bound l.push (fun b => 2^b.kappa) BusBlock.kappa (by intro b; rfl) + have pull := sum_power_bound l.pull (fun b => 2^b.kappa) BusBlock.kappa (by intro b; rfl) + have producers := sum_power_bound l.producers (fun p => p.bits*2^p.kappa) + (fun p => p.bits+p.kappa) (by + intro p + rw [Nat.pow_add] + exact Nat.mul_le_mul_right _ (Nat.le_of_lt Nat.lt_two_pow_self)) + have stacked := add_power_bound pushSize prodSize _ _ push producers + have mass : max + ((l.push.map (fun b => 2^b.kappa)).sum+ + (l.producers.map (fun p => p.bits*2^p.kappa)).sum) + ((l.pull.map (fun b => 2^b.kappa)).sum) ≤ 2^(1+pushSize+prodSize+pullSize) := by + apply max_le + · exact stacked.trans (Nat.pow_le_pow_right (by decide) (by omega)) + · exact pull.trans (Nat.pow_le_pow_right (by decide) (by omega)) + have pushBudget : pushSize ≤ (l.push.map busBlockSize).sum := by + dsimp only [pushSize] + apply List.sum_le_sum + intro b member + unfold busBlockSize + omega + have pullBudget : pullSize ≤ (l.pull.map busBlockSize).sum := by + dsimp only [pullSize] + apply List.sum_le_sum + intro b member + unfold busBlockSize + omega + have prodBudget : prodSize ≤ + (l.producers.map (fun p => 1+p.kappa+p.bits+p.window)).sum := by + dsimp only [prodSize] + apply List.sum_le_sum + intro p member + omega + have exponential : max (max + ((l.push.map (fun b => 2^b.kappa)).sum+ + (l.producers.map (fun p => p.bits*2^p.kappa)).sum) + ((l.pull.map (fun b => 2^b.kappa)).sum)) 1 ≤ 2^(1+pushSize+prodSize+pullSize) := + max_le mass Nat.one_le_two_pow + have logarithm : Nat.log2 (max (max + ((l.push.map (fun b => 2^b.kappa)).sum+ + (l.producers.map (fun p => p.bits*2^p.kappa)).sum) + ((l.pull.map (fun b => 2^b.kappa)).sum)) 1-1) ≤ 1+pushSize+prodSize+pullSize := by + by_cases zero : max (max + ((l.push.map (fun b => 2^b.kappa)).sum+ + (l.producers.map (fun p => p.bits*2^p.kappa)).sum) + ((l.pull.map (fun b => 2^b.kappa)).sum)) 1-1 = 0 + · rw [zero,Nat.log2_zero]; omega + · have less : max (max + ((l.push.map (fun b => 2^b.kappa)).sum+ + (l.producers.map (fun p => p.bits*2^p.kappa)).sum) + ((l.pull.map (fun b => 2^b.kappa)).sum)) 1-1 < 2^(1+pushSize+prodSize+pullSize) := by + omega + exact Nat.le_of_lt ((Nat.log2_lt zero).2 less) + unfold BusLayout.mu busLayoutSize + dsimp only [] + split <;> omega + +private theorem sum_scaled_le {A : Type} (xs : List A) (value weight : A → Nat) + (scale : Nat) (entries : ∀ x, value x ≤ scale*weight x) : + (xs.map value).sum ≤ scale*(xs.map weight).sum := by + induction xs with + | nil => simp + | cons x xs ih => + have entry := entries x + simp only [List.map_cons,List.sum_cons] + nlinarith + +theorem bus_mu_work_le (l : BusLayout) : + (mu l).work ≤ 11*busLayoutSize l+17 := by + have push := sum_scaled_le l.push (fun b => 3*b.kappa+6) busBlockSize 7 + (by intro b; unfold busBlockSize; omega) + have pull := sum_scaled_le l.pull (fun b => 3*b.kappa+6) busBlockSize 7 + (by intro b; unfold busBlockSize; omega) + have producers := sum_scaled_le l.producers (fun p => 3*p.kappa+7) + (fun p => 1+p.kappa+p.bits+p.window) 7 (by intro p; omega) + have work := mu_work_le l + have logarithm := bus_mu_le_size l + unfold busLayoutSize at * + omega + +private theorem busLoop_work_le (l : BusLayout) (point : List E) + (tokens : List CallerToken) (size : Nat) + (configuration : busLayoutSize l ≤ size) (pointBound : point.length ≤ size) : + (forIn (l.push++l.pull) ([],[]) (busBlockStep point) tokens).work ≤ + size*(10*size*size*size+20*size*size+21*size+28) := by + have components := busLayoutSize_components l + have blocks : (l.push++l.pull).length ≤ size := components.1.trans configuration + have bounded := forIn_growth_work_le (l.push++l.pull) ([],[]) (busBlockStep point) + busStateSize (5*size) (20*size*size+21*size+28) (2*size) + (by + intro b member state ts + have coords := (components.2 b member).trans configuration + simpa [Nat.add_assoc] using busBlock_work_le point b state ts size coords pointBound) + (by + intro b member state ts step rest accepted + obtain ⟨next,rfl,growth⟩ := busBlock_success point b state ts rest step accepted + have coords := (components.2 b member).trans configuration + simp only [iterationState] + omega) tokens + have inner : 5*size*(busStateSize ([],[])+2*size*(l.push++l.pull).length)+ + (20*size*size+21*size+28) ≤ + 10*size*size*size+20*size*size+21*size+28 := by + have product := Nat.mul_le_mul_left (2*size) blocks + have scaled := Nat.mul_le_mul_left (5*size) product + simp only [busStateSize,List.length_nil] at * + nlinarith + exact bounded.trans (Nat.mul_le_mul blocks inner) + +private theorem busLoop_success_size (l : BusLayout) (point : List E) + (tokens rest : List CallerToken) (final : BusState) (size : Nat) + (configuration : busLayoutSize l ≤ size) + (accepted : (forIn (l.push++l.pull) ([],[]) (busBlockStep point) tokens).result = + some (final,rest)) : + final.2.length ≤ 2*size*size := by + have components := busLayoutSize_components l + have growth := forIn_success_growth (l.push++l.pull) (busBlockStep point) + busStateSize (2*size) (by + intro b member state ts step tail h + obtain ⟨next,rfl,bound⟩ := busBlock_success point b state ts tail step h + have coords := (components.2 b member).trans configuration + exact ⟨next,rfl,by omega⟩) ([],[]) final tokens rest accepted + have length := components.1.trans configuration + simp only [busStateSize,List.length_nil] at growth + nlinarith [Nat.mul_le_mul_left (2*size) length] + +private theorem mapM_success_all {A B : Type} (xs : List A) (body : A → Parser B) + (property : B → Prop) + (each : ∀ x ∈ xs, ∀ ts value rest, (body x ts).result = some (value,rest) → property value) + (tokens rest : List CallerToken) (output : List B) + (accepted : (xs.mapM body tokens).result = some (output,rest)) : + ∀ value ∈ output, property value := by + induction xs generalizing tokens output with + | nil => + simp only [List.mapM_nil] at accepted + change some ([],tokens) = some (output,rest) at accepted + cases accepted + simp + | cons x xs ih => + rw [List.mapM_cons] at accepted + obtain ⟨value,middle,first,accepted⟩ := bind_success _ _ _ _ _ accepted + obtain ⟨values,middle,last,accepted⟩ := bind_success _ _ _ _ _ accepted + change some (value::values,middle) = some (output,rest) at accepted + cases accepted + have head := each x (by simp) tokens value middle first + have tail := ih (fun y member ts v remaining h => each y (by simp [member]) ts v remaining h) + _ _ last + intro next member + rcases List.mem_cons.mp member with rfl | member + · exact head + · exact tail next member + +theorem constraintClaims_success_caps (layouts : List AirLayout) (p : List E) + (tokens rest : List CallerToken) (output : List TableClaims) (size : Nat) + (configuration : airLayoutsSize layouts ≤ size) + (accepted : (constraintClaims layouts p tokens).result = some (output,rest)) : + output.length ≤ size ∧ + ∀ table ∈ output, table.point.length ≤ size ∧ + table.evals.length ≤ size ∧ table.slices.length ≤ size := by + have cardinality := constraintClaims_success_length layouts p tokens rest output accepted + have components := airLayouts_components layouts + constructor + · unfold airLayoutsSize at configuration + omega + · unfold constraintClaims at accepted + simp only [tick_bind_result] at accepted + obtain ⟨_,accepted⟩ := check_bind_success _ _ _ _ _ accepted + simp only [tick_bind_result] at accepted + obtain ⟨rounds,middle,_,accepted⟩ := bind_success _ _ _ _ _ accepted + refine mapM_success_all _ _ + (fun table => table.point.length ≤ size ∧ table.evals.length ≤ size ∧ table.slices.length ≤ size) + ?_ _ _ _ accepted + intro l member ts table remaining h + simp only [tick_bind_result] at h + have lengths := receiveTable_success_lengths l rounds.reverse ts remaining table h + have sourceSize := components.2 l member + have config := airLayoutSize_components l + unfold airLayoutsSize at configuration + omega + +private theorem forIn_success_invariant {A B : Type} (xs : List A) + (body : A → B → Parser (ForInStep B)) (invariant : B → Prop) + (preserves : ∀ x state ts step rest, invariant state → + (body x state ts).result = some (step,rest) → + ∃ next, step = .yield next ∧ invariant next) + (initial final : B) (tokens rest : List CallerToken) + (start : invariant initial) + (accepted : (forIn xs initial body tokens).result = some (final,rest)) : + invariant final := by + induction xs generalizing initial tokens with + | nil => + simp only [List.forIn_nil] at accepted + change some (initial,tokens) = some (final,rest) at accepted + cases accepted + exact start + | cons x xs ih => + rw [List.forIn_cons] at accepted + obtain ⟨step,middle,first,accepted⟩ := bind_success _ _ _ _ _ accepted + obtain ⟨next,rfl,retained⟩ := preserves x initial tokens step middle start first + exact ih next middle retained accepted + +private def busPointInvariant (point : List E) (state : BusState) : Prop := + ∀ claim ∈ state.2, claim.point.length ≤ point.length + +private theorem busCoord_preserves (point : List E) (block : BusBlock) (coord : BusCoord) + (state : BusState) (tokens rest : List CallerToken) (step : ForInStep BusState) + (invariant : busPointInvariant point state) + (accepted : (busCoordStep point block coord state tokens).result = some (step,rest)) : + ∃ next, step = .yield next ∧ busPointInvariant point next := by + unfold busCoordStep at accepted + simp only [tick_bind_result] at accepted + cases coord with + | column col => + simp only [tick_bind_result] at accepted + split at accepted + · obtain ⟨value,middle,_,accepted⟩ := bind_success _ _ _ _ _ accepted + simp only [tick_bind_result,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + refine ⟨_,rfl,?_⟩ + intro claim member + rcases List.mem_append.mp member with member | member + · exact invariant claim member + · simp only [List.mem_singleton] at member + subst claim + simp only [List.length_take] + exact Nat.min_le_right _ _ + · simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,invariant⟩ + | publicValue => + simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,invariant⟩ + | tableExpression => simp [Bind.bind,bind,check] at accepted + +private theorem busBlock_preserves (point : List E) (block : BusBlock) + (state : BusState) (tokens rest : List CallerToken) (step : ForInStep BusState) + (invariant : busPointInvariant point state) + (accepted : (busBlockStep point block state tokens).result = some (step,rest)) : + ∃ next, step = .yield next ∧ busPointInvariant point next := by + unfold busBlockStep at accepted + simp only [tick_bind_result] at accepted + obtain ⟨_,accepted⟩ := check_bind_success _ _ _ _ _ accepted + split at accepted + · obtain ⟨next,middle,loopRead,accepted⟩ := bind_success _ _ _ _ _ accepted + have retained := forIn_success_invariant block.coords (busCoordStep point block) + (busPointInvariant point) + (fun c st ts outcome tail inv h => busCoord_preserves point block c st ts tail outcome inv h) + state next tokens middle invariant loopRead + simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨next,rfl,retained⟩ + · simp only [pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨_,rfl,invariant⟩ + +private def busTail (l : BusLayout) (point : List E) : + Parser (List E × List ColumnClaim) := do + tick (appendCost l.push+2) + let final ← forIn (l.push++l.pull) ([],[]) (busBlockStep point) + tick 3 + pure (point,final.2) + +private def busPrefix (l : BusLayout) : Parser (List E × List ColumnClaim) := do + let _ ← drawScalars 4 + let _ ← drawScalar + tick (mu l).work + let point ← gkrPoint (mu l).value + busTail l point + +private theorem busClaims_normalized (l : BusLayout) : + busClaims l = (do + tick 2 + if l.grinding > 0 then + let _ ← nonce l.grinding + busPrefix l + else busPrefix l) := rfl + +private theorem busTail_work_le (l : BusLayout) (point : List E) + (tokens : List CallerToken) (size : Nat) + (configuration : busLayoutSize l ≤ size) (pointBound : point.length ≤ size) : + (busTail l point tokens).work ≤ + size*(10*size*size*size+20*size*size+21*size+28)+2*size+6 := by + have blocks := (busLayoutSize_components l).1.trans configuration + have push : l.push.length ≤ size := by simp only [List.length_append] at blocks; omega + unfold busTail + rw [tick_bind_work] + apply Nat.le_trans + · apply Nat.add_le_add_left + apply bind_work_le + · exact busLoop_work_le l point tokens size configuration pointBound + · intro _ tail _ + rw [tick_bind_work] + exact Nat.le_refl _ + · simp only [appendCost,pure] + omega + +private theorem busTail_success_caps (l : BusLayout) (point : List E) + (tokens rest : List CallerToken) (output : List E × List ColumnClaim) (size : Nat) + (configuration : busLayoutSize l ≤ size) + (accepted : (busTail l point tokens).result = some (output,rest)) : + output.1 = point ∧ output.2.length ≤ 2*size*size ∧ + ∀ claim ∈ output.2, claim.point.length ≤ point.length := by + unfold busTail at accepted + simp only [tick_bind_result] at accepted + obtain ⟨final,middle,loopRead,accepted⟩ := bind_success _ _ _ _ _ accepted + have cardinality := busLoop_success_size l point tokens middle final size configuration loopRead + have points := forIn_success_invariant (l.push++l.pull) (busBlockStep point) + (busPointInvariant point) + (fun b st ts step tail inv h => busBlock_preserves point b st ts tail step inv h) + ([],[]) final tokens middle (by simp [busPointInvariant]) loopRead + simp only [tick_bind_result,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨rfl,cardinality,points⟩ + +theorem receiveTable_work_canonical (l : AirLayout) (p : List E) (tokens : List CallerToken) : + (receiveTable l p tokens).work ≤ 100*(airLayoutSize l+p.length+1)^3 := + receiveTable_work_polynomial l p tokens (airLayoutSize l+p.length) + (Nat.le_add_right _ _) (Nat.le_add_left _ _) + +theorem constraintClaims_work_canonical (layouts : List AirLayout) (p : List E) + (tokens : List CallerToken) : + (constraintClaims layouts p tokens).work ≤ + 100*(airLayoutsSize layouts+p.length+1)^3*(airLayoutsSize layouts+p.length)+ + 2*(airLayoutsSize layouts+p.length)*(airLayoutsSize layouts+p.length)+ + 50*(airLayoutsSize layouts+p.length)+20 := + constraintClaims_work_polynomial layouts p tokens (airLayoutsSize layouts+p.length) + (Nat.le_add_right _ _) (Nat.le_add_left _ _) + +private theorem busPrefix_success_decomposition (l : BusLayout) + (tokens rest : List CallerToken) (output : List E × List ColumnClaim) (size : Nat) + (configuration : busLayoutSize l ≤ size) + (accepted : (busPrefix l tokens).result = some (output,rest)) : + ∃ gkrTokens gkrRest, (gkrPoint (mu l).value gkrTokens).result = some (output.1,gkrRest) ∧ + output.2.length ≤ 2*size*size ∧ + ∀ claim ∈ output.2, claim.point.length ≤ output.1.length := by + unfold busPrefix at accepted + obtain ⟨_,middle,_,accepted⟩ := bind_success _ _ _ _ _ accepted + obtain ⟨_,gkrTokens,_,accepted⟩ := bind_success _ _ _ _ _ accepted + simp only [tick_bind_result] at accepted + obtain ⟨point,gkrRest,gkrRead,accepted⟩ := bind_success _ _ _ _ _ accepted + have caps := busTail_success_caps l point gkrRest rest output size configuration accepted + rw [← caps.1] at gkrRead + exact ⟨gkrTokens,gkrRest,gkrRead,caps.2.1,by simpa [caps.1] using caps.2.2⟩ + +theorem busClaims_success_decomposition (l : BusLayout) + (tokens rest : List CallerToken) (output : List E × List ColumnClaim) (size : Nat) + (configuration : busLayoutSize l ≤ size) + (accepted : (busClaims l tokens).result = some (output,rest)) : + ∃ gkrTokens gkrRest, (gkrPoint l.mu gkrTokens).result = some (output.1,gkrRest) ∧ + output.2.length ≤ 2*size*size ∧ + ∀ claim ∈ output.2, claim.point.length ≤ output.1.length := by + rw [busClaims_normalized] at accepted + simp only [tick_bind_result] at accepted + split at accepted + · obtain ⟨_,middle,_,accepted⟩ := bind_success _ _ _ _ _ accepted + simpa only [mu_erasure] using + busPrefix_success_decomposition l middle rest output size configuration accepted + · simpa only [mu_erasure] using + busPrefix_success_decomposition l tokens rest output size configuration accepted + +/-- Conservative quartic obtained from the actual nested bus visits. -/ +def busClaimsWork (size : Nat) : Nat := + size*(10*size*size*size+20*size*size+21*size+28)+ + 94*size*size+155*size+134 + +private theorem busGKR_work_le (l : BusLayout) (tokens : List CallerToken) (size : Nat) + (configuration : busLayoutSize l ≤ size) : + (gkrPoint (mu l).value tokens).work ≤ 94*size*size+142*size+62 := by + have bound := gkrPoint_work_le (mu l).value tokens + have magnitude := (bus_mu_le_size l).trans configuration + rw [mu_erasure] at bound ⊢ + have square := Nat.mul_self_le_mul_self magnitude + nlinarith + +private theorem busPrefix_work_le (l : BusLayout) (tokens : List CallerToken) (size : Nat) + (configuration : busLayoutSize l ≤ size) : + (busPrefix l tokens).work ≤ + size*(10*size*size*size+20*size*size+21*size+28)+ + 94*size*size+155*size+127 := by + have muCost := bus_mu_work_le l + have magnitude := (bus_mu_le_size l).trans configuration + unfold busPrefix + apply Nat.le_trans + · apply bind_work_le + · exact drawScalars_work_le _ _ + · intro _ tail _ + apply bind_work_le + · exact drawScalar_work_le _ + · intro _ tail _ + apply bind_work_le + · exact tick_work_le _ _ + · intro _ tail _ + apply bind_work_le + · exact busGKR_work_le l tail size configuration + · intro point tail parsed + have pointLength := gkrPoint_success_length (mu l).value _ point _ parsed + rw [mu_erasure] at pointLength + exact busTail_work_le l point tail size configuration + (pointLength.trans_le magnitude) + · omega + +theorem busClaims_work_polynomial (l : BusLayout) (tokens : List CallerToken) + (size : Nat) (configuration : busLayoutSize l ≤ size) : + (busClaims l tokens).work ≤ busClaimsWork size := by + rw [busClaims_normalized,tick_bind_work] + split + · apply Nat.le_trans + · apply Nat.add_le_add_left + apply bind_work_le + · exact nonce_work_le _ _ + · intro _ tail _; exact busPrefix_work_le l tail size configuration + · unfold busClaimsWork; omega + · have bound := busPrefix_work_le l tokens size configuration + unfold busClaimsWork + omega + +theorem busClaims_work_canonical (l : BusLayout) (tokens : List CallerToken) : + (busClaims l tokens).work ≤ busClaimsWork (busLayoutSize l) := + busClaims_work_polynomial l tokens (busLayoutSize l) (Nat.le_refl _) + +theorem busClaims_success_point_length (l : BusLayout) + (tokens rest : List CallerToken) (output : List E × List ColumnClaim) + (accepted : (busClaims l tokens).result = some (output,rest)) : + output.1.length = l.mu := by + obtain ⟨gkrTokens,gkrRest,gkrRead,_⟩ := + busClaims_success_decomposition l tokens rest output (busLayoutSize l) (Nat.le_refl _) accepted + exact gkrPoint_success_length l.mu gkrTokens output.1 gkrRest gkrRead + +theorem busClaims_success_caps (l : BusLayout) + (tokens rest : List CallerToken) (output : List E × List ColumnClaim) (size : Nat) + (configuration : busLayoutSize l ≤ size) + (accepted : (busClaims l tokens).result = some (output,rest)) : + output.1.length = l.mu ∧ output.1.length ≤ size ∧ output.2.length ≤ 2*size*size ∧ + ∀ claim ∈ output.2, claim.point.length ≤ size := by + obtain ⟨gkrTokens,gkrRest,gkrRead,cardinality,points⟩ := + busClaims_success_decomposition l tokens rest output size configuration accepted + have length := gkrPoint_success_length l.mu gkrTokens output.1 gkrRest gkrRead + have pointBound := length.trans_le ((bus_mu_le_size l).trans configuration) + exact ⟨length,pointBound,cardinality,fun claim member => (points claim member).trans pointBound⟩ + +#print axioms busClaims_work_polynomial +#print axioms busClaims_work_canonical +#print axioms busClaims_success_point_length +#print axioms busClaims_success_caps + +#print axioms busClaims_success_decomposition + +#print axioms bus_mu_le_size +#print axioms bus_mu_work_le +#print axioms constraintClaims_success_caps + +#print axioms constraintClaims_work_polynomial +#print axioms constraintClaims_success_length + +#print axioms receiveTable_work_le +#print axioms receiveTable_work_polynomial +#print axioms receiveTable_success_lengths +#print axioms receiveTable_success_caps +#print axioms receiveTable_work_canonical +#print axioms constraintClaims_work_canonical + +end Whir.PCSBCSCallerParserCost diff --git a/verification/whir/Whir/PCSBCSCallerBusTablePolynomialBoundSmoke.lean b/verification/whir/Whir/PCSBCSCallerBusTablePolynomialBoundSmoke.lean new file mode 100644 index 000000000..ede78e3a6 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerBusTablePolynomialBoundSmoke.lean @@ -0,0 +1,102 @@ +import Whir.PCSBCSCallerBusTablePolynomialBound + +/-! Executed accepted/rejected public-token fixtures for the actual counted AIR +and bus receiver paths, compared with their source erasures and work bounds. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCallerBusTablePolynomialBoundSmoke +open Concrete WHIRCallerClaims + +private def require (label : String) (ok : Bool) : IO Unit := + if ok then pure () else throw (IO.userError label) + +private def tableCase (label : String) (layout : AirLayout) (point : List E) + (tokens : List CallerToken) (accept : Bool) : IO Unit := do + let counted := PCSBCSCallerParserCost.receiveTable layout point tokens + let source := WHIRCallerClaims.receiveTable layout point tokens + require (label++": source erasure") (counted.result == source) + require (label++": acceptance") (counted.result.isSome == accept) + let size := PCSBCSCallerParserCost.airLayoutSize layout+point.length + require (label++": polynomial work") (counted.work ≤ 100*(size+1)^3) + require (label++": literal traversal bound") + (counted.work ≤ PCSBCSCallerParserCost.receiveTableWork layout point) + if let some (table,_) := counted.result then + require (label++": point length") (table.point.length == layout.tau) + require (label++": eval length") (table.evals.length == layout.columns-layout.publicColumns) + require (label++": slice length") (table.slices.length == (layout.fields.map BitField.width).sum) + +private def constraintCase (label : String) (layouts : List AirLayout) (point : List E) + (tokens : List CallerToken) (accept : Bool) : IO Unit := do + let counted := PCSBCSCallerParserCost.constraintClaims layouts point tokens + require (label++": source erasure") (counted.result == WHIRCallerClaims.constraintClaims layouts point tokens) + require (label++": acceptance") (counted.result.isSome == accept) + let size := PCSBCSCallerParserCost.airLayoutsSize layouts+point.length + require (label++": polynomial work") + (counted.work ≤ 100*(size+1)^3*size+2*size*size+50*size+20) + if let some (tables,_) := counted.result then + require (label++": table count") (tables.length == layouts.length) + +private def busCase (label : String) (layout : BusLayout) + (tokens : List CallerToken) (accept : Bool) : IO Unit := do + let counted := PCSBCSCallerParserCost.busClaims layout tokens + require (label++": source erasure") (counted.result == WHIRCallerClaims.busClaims layout tokens) + require (label++": acceptance") (counted.result.isSome == accept) + let size := PCSBCSCallerParserCost.busLayoutSize layout + require (label++": logarithmic magnitude") (layout.mu ≤ size) + require (label++": polynomial work") (counted.work ≤ PCSBCSCallerParserCost.busClaimsWork size) + if let some ((point,claims),_) := counted.result then + require (label++": GKR point length") (point.length == layout.mu) + require (label++": claim count") (claims.length ≤ 2*size*size) + require (label++": claim point lengths") (claims.all (fun c => c.point.length ≤ layout.mu)) + +private def zeroBus : List CallerToken := + List.replicate 5 (.draw 0) ++ [.sent 0,.draw 0] +private def oddBus : List CallerToken := + zeroBus ++ List.replicate 4 (.sent 0) ++ [.draw 1,.draw 0] +private def evenBus : List CallerToken := + zeroBus ++ List.replicate 8 (.sent 0) ++ [.draw 1,.draw 0,.draw 0] +private def nestedBus : List CallerToken := + oddBus ++ List.replicate 4 (.sent 0) ++ [.draw 1] ++ + List.replicate 8 (.sent 0) ++ [.draw 0,.draw 1,.draw 0] + +def smoke : IO Unit := do + tableCase "ordinary" ⟨1,2,0,[]⟩ [1] [.sent (E.ofK 2),.sent (E.ofK 3)] true + tableCase "selected bits" ⟨1,3,1,[⟨1,2⟩]⟩ [1] [.sent (E.ofK 2),.sent 1,.sent 0] true + tableCase "nonzero offset" ⟨0,2,0,[⟨1,2⟩,⟨0,1⟩]⟩ [] [.sent 1,.sent 0,.sent 1] true + require "selected bit offsets and basis values" + ((PCSBCSCallerParserCost.receiveTable ⟨0,2,0,[⟨1,2⟩,⟨0,1⟩]⟩ [] + [.sent 1,.sent 0,.sent 1]).result == + some (⟨[],[1,1],[1,0,1]⟩,[])) + tableCase "zero width" ⟨0,1,0,[⟨0,0⟩]⟩ [] [] true + tableCase "empty table" ⟨0,0,0,[]⟩ [] [] true + tableCase "invalid public columns" ⟨0,0,1,[]⟩ [] [] false + tableCase "invalid tau" ⟨2,0,0,[]⟩ [0] [] false + tableCase "invalid field column" ⟨0,1,0,[⟨1,1⟩]⟩ [] [] false + tableCase "invalid field width" ⟨0,1,0,[⟨0,65⟩]⟩ [] [] false + tableCase "duplicate fields" ⟨0,2,0,[⟨0,1⟩,⟨0,1⟩]⟩ [] [] false + tableCase "truncated cursor input" ⟨0,2,0,[]⟩ [] [.sent 1] false + tableCase "truncated slices" ⟨0,1,0,[⟨0,2⟩]⟩ [] [.sent 1] false + tableCase "wrong token kind" ⟨0,1,0,[]⟩ [] [.draw 1] false + constraintCase "empty constraints" [] [] [] true + constraintCase "constraint rounds and tables" [⟨1,1,0,[]⟩,⟨0,1,0,[⟨0,1⟩]⟩] + [0] [.sent 0,.sent 0,.sent 0,.draw 1,.sent (E.ofK 2),.sent 1] true + constraintCase "constraint point guard" [⟨1,0,0,[]⟩] [] [] false + constraintCase "constraint truncated round" [⟨1,0,0,[]⟩] [0] [.sent 0] false + constraintCase "constraint rejected table" [⟨0,1,0,[⟨0,65⟩]⟩] [] [] false + busCase "empty bus" ⟨[],[],[],0⟩ zeroBus true + busCase "duplicate bus coordinates" ⟨[⟨0,false,[.column 4,.column 4,.publicValue]⟩],[],[],0⟩ + (zeroBus++[.sent (E.ofK 2)]) true + busCase "owned table skipped" ⟨[⟨0,true,[.tableExpression]⟩],[],[],0⟩ zeroBus true + busCase "invalid expression" ⟨[⟨0,false,[.tableExpression]⟩],[],[],0⟩ zeroBus false + busCase "odd bus point" ⟨[⟨1,false,[.column 4]⟩],[],[],0⟩ (oddBus++[.sent (E.ofK 2)]) true + busCase "even bus point" ⟨[⟨2,false,[.column 4]⟩],[],[],0⟩ (evenBus++[.sent 1]) true + busCase "nested bus point" ⟨[⟨3,false,[.column 4]⟩],[],[],0⟩ (nestedBus++[.sent 1]) true + busCase "truncated nested bus" ⟨[⟨3,false,[.column 4]⟩],[],[],0⟩ oddBus false + busCase "valid nonce" ⟨[],[],[],3⟩ + (.nonce 3 (ByteCodec.encodeNat 24 0)::zeroBus) true + busCase "bad nonce" ⟨[],[],[],3⟩ [.nonce 2 (ByteCodec.encodeNat 24 0)] false + busCase "missing claim" ⟨[⟨0,false,[.column 4]⟩],[],[],0⟩ zeroBus false + IO.println "Counted/source bus and table polynomial smoke passed (29 accepted/rejected fixtures)." + +end Whir.PCSBCSCallerBusTablePolynomialBoundSmoke + +def main : IO Unit := Whir.PCSBCSCallerBusTablePolynomialBoundSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSCallerCPUPolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerCPUPolynomialBound.lean new file mode 100644 index 000000000..d58a01aec --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerCPUPolynomialBound.lean @@ -0,0 +1,1069 @@ +import Whir.PCSBCSCallerPayloadPolynomialBound + +/-! Actual CPU producer and nested register source-operation bounds. Rejection +retains its executed prefix; delayed getters are not evaluated by construction. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 +namespace Whir.PCSBCSCallerPayloadCost +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec +open PCSBCSCallerParserCost hiding pure liftOption + +abbrev CpuEarly := Option (List RingPCSGame.FamilyClaim × List ColumnClaim) +abbrev CpuSlices := CpuEarly × List E +abbrev CpuRings := CpuEarly × List RingPCSGame.FamilyClaim + +def cpuSliceStep (summed : List TableClaims) (t : Nat) (state : CpuSlices) : + Parser (ForInStep CpuSlices) := do + tick (1 + indexWork summed t) + match summed[t]? with + | some claims => + tick (2 * state.2.length + 2) + pure (.yield (none,state.2 ++ claims.slices)) + | _ => + let r ← PCSBCSCallerParserCost.liftOption 1 none + pure (.done (some r,state.2)) + +def cpuProducerStep (pair : BusProducer × TableClaims) (rings : List RingPCSGame.FamilyClaim) : + Parser (ForInStep (List RingPCSGame.FamilyClaim)) := + match pair with + | (p,c) => do + let ring := PCSBCSCallerParserCost.paddedRing p.window c.point c.evals + tick (1 + ring.work) + match ring.value with + | some claim => tick (2*rings.length+2); pure (.yield (rings ++ [claim])) + | none => PCSBCSCallerParserCost.check false; pure (.yield rings) + +def cpuRegisterStep (summed : List TableClaims) (word : RegisterWord) (state : CpuRings) : + Parser (ForInStep CpuRings) := do + tick 2 + match word.tables.head? with + | some first => + tick (indexWork summed first) + match summed[first]? with + | some firstClaims => + let slices ← forIn word.tables (none,[]) (cpuSliceStep summed) + match slices.1 with + | some r => pure (.done (some r,state.2)) + | none => + let ring := PCSBCSCallerParserCost.paddedRing word.offset firstClaims.point slices.2 + tick ring.work + match ring.value with + | some claim => tick (2*state.2.length+2); pure (.yield (none,state.2 ++ [claim])) + | none => PCSBCSCallerParserCost.check false; pure (.yield (none,state.2)) + | _ => + let r ← PCSBCSCallerParserCost.liftOption 1 none + pure (.done (some r,state.2)) + | _ => + let r ← PCSBCSCallerParserCost.liftOption 1 none + pure (.done (some r,state.2)) + +private theorem loop_preserves {A B : Type} (xs : List A) + (body : A → B → Parser (ForInStep B)) (P : B → Prop) + (each : ∀ x ∈ xs, ∀ st ts step rest, P st → + (body x st ts).result = some (step,rest) → P (iterationState step)) + (st : B) (ts : List CallerToken) (out : B) (rest : List CallerToken) + (start : P st) (h : (forIn xs st body ts).result = some (out,rest)) : P out := by + induction xs generalizing st ts with + | nil => change some (st,ts) = some (out,rest) at h; cases h; exact start + | cons x xs ih => + rw [List.forIn_cons] at h + obtain ⟨step,middle,first,last⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have retained := each x (by simp) st ts step middle start first + cases step with + | done value => change some (value,middle) = some (out,rest) at last; cases last; exact retained + | yield value => exact ih (by intro y hy; exact each y (by simp [hy])) value middle retained last + +private theorem loop_growth {A B : Type} (xs : List A) + (body : A → B → Parser (ForInStep B)) (size : B → Nat) (delta : Nat) + (each : ∀ x ∈ xs, ∀ st ts step rest, + (body x st ts).result = some (step,rest) → size (iterationState step) ≤ size st+delta) + (st : B) (ts : List CallerToken) (out : B) (rest : List CallerToken) + (h : (forIn xs st body ts).result = some (out,rest)) : size out ≤ size st+delta*xs.length := by + induction xs generalizing st ts with + | nil => change some (st,ts) = some (out,rest) at h; cases h; simp + | cons x xs ih => + rw [List.forIn_cons] at h + obtain ⟨step,middle,first,last⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have growth := each x (by simp) st ts step middle first + cases step with + | done value => + change some (value,middle) = some (out,rest) at last + cases last + simp only [iterationState,List.length_cons,Nat.mul_add,Nat.mul_one] at * + omega + | yield value => + have tail := ih (by intro y hy; exact each y (by simp [hy])) value middle last + simp only [iterationState,List.length_cons,Nat.mul_add,Nat.mul_one] at * + omega + +private theorem sliceStep_work (summed : List TableClaims) (t : Nat) (state : CpuSlices) + (ts : List CallerToken) : + (cpuSliceStep summed t state ts).work ≤ 2*state.2.length+2*summed.length+5 := by + have index := indexWork_le summed t + unfold cpuSliceStep + rw [tick_bind_work] + cases summed[t]? <;> simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure,PCSBCSCallerParserCost.liftOption] <;> omega + +private theorem sliceStep_success (summed : List TableClaims) (cap : Nat) + (caps : ∀ c ∈ summed, c.slices.length ≤ cap) + (t : Nat) (state : CpuSlices) (ts rest : List CallerToken) (step : ForInStep CpuSlices) + (h : (cpuSliceStep summed t state ts).result = some (step,rest)) : + (iterationState step).1 = none ∧ (iterationState step).2.length ≤ state.2.length+cap := by + unfold cpuSliceStep at h + cases lookup : summed[t]? with + | none => simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick,PCSBCSCallerParserCost.liftOption,lookup] at h + | some claims => + have bound := caps claims (List.mem_of_getElem? lookup) + simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure,lookup] at h + rcases h with ⟨rfl,rfl⟩ + simp [iterationState] + exact bound + + theorem cpuSliceLoop_work (summed : List TableClaims) (tables : List Nat) (cap : Nat) + (caps : ∀ c ∈ summed, c.slices.length ≤ cap) (ts : List CallerToken) : + (forIn tables (none,[]) (cpuSliceStep summed) ts).work ≤ + tables.length*(2*(cap*tables.length)+2*summed.length+5) := by + simpa [Nat.add_assoc] using forIn_growth_work_le tables (none,[]) (cpuSliceStep summed) + (fun st => st.2.length) 2 (2*summed.length+5) cap + (by intro t _ st tokens; exact sliceStep_work summed t st tokens) + (by intro t _ st tokens step rest h; exact (sliceStep_success summed cap caps t st tokens rest step h).2) ts + + theorem cpuSliceLoop_success (summed : List TableClaims) (tables : List Nat) (cap : Nat) + (caps : ∀ c ∈ summed, c.slices.length ≤ cap) (ts rest : List CallerToken) (out : CpuSlices) + (h : (forIn tables (none,[]) (cpuSliceStep summed) ts).result = some (out,rest)) : + out.1 = none ∧ out.2.length ≤ cap*tables.length := by + constructor + · exact loop_preserves tables (cpuSliceStep summed) (fun st => st.1 = none) + (by intro t _ st tokens step tail _ parsed; exact (sliceStep_success summed cap caps t st tokens tail step parsed).1) + (none,[]) ts out rest rfl h + · simpa using loop_growth tables (cpuSliceStep summed) (fun st => st.2.length) cap + (by intro t _ st tokens step tail parsed; exact (sliceStep_success summed cap caps t st tokens tail step parsed).2) + (none,[]) ts out rest h + +private theorem cpu_bind_bound {A B : Type} (p : Parser A) (f : A → Parser B) + (ts : List CallerToken) (m n total : Nat) (sum : m+n ≤ total) + (hp : (p ts).work ≤ m) + (hf : ∀ a rest, (p ts).result = some (a,rest) → (f a rest).work ≤ n) : + ((p >>= f) ts).work ≤ total := (bind_work_le p f ts m n hp hf).trans sum + +local macro "cpu_bind " m:term "," n:term : tactic => + `(tactic| (apply cpu_bind_bound _ _ _ $m $n; · first | omega | nlinarith)) + +theorem cpuProducerStep_work (p : BusProducer × TableClaims) + (rings : List RingPCSGame.FamilyClaim) (size : Nat) + (point : p.2.point.length ≤ size) (evals : p.2.evals.length ≤ size) + (ts : List CallerToken) : + (cpuProducerStep p rings ts).work ≤ 2*rings.length+3*size+10 := by + rcases p with ⟨p,c⟩ + dsimp only at point evals + have pad := paddedRing_work_le p.window c.point c.evals + unfold cpuProducerStep + rw [tick_bind_work] + cases (PCSBCSCallerParserCost.paddedRing p.window c.point c.evals).value <;> + simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + PCSBCSCallerParserCost.check,Pure.pure,PCSBCSCallerParserCost.pure] <;> omega + +private theorem cpuProducerStep_success (p : BusProducer × TableClaims) + (rings : List RingPCSGame.FamilyClaim) (ts rest : List CallerToken) + (step : ForInStep (List RingPCSGame.FamilyClaim)) + (h : (cpuProducerStep p rings ts).result = some (step,rest)) : + ∃ ring, step = .yield (rings ++ [ring]) ∧ ring.point.size = p.2.point.length := by + rcases p with ⟨p,c⟩ + unfold cpuProducerStep at h + cases pad : (PCSBCSCallerParserCost.paddedRing p.window c.point c.evals).value with + | none => + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + pad,PCSBCSCallerParserCost.check,Bool.false_eq_true,↓reduceIte] at h + cases h + | some ring => + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + pad,Pure.pure,PCSBCSCallerParserCost.pure,Option.some.injEq,Prod.mk.injEq] at h + rcases h with ⟨rfl,rfl⟩ + exact ⟨ring,rfl,paddedRing_success_point_size _ _ _ _ pad⟩ + +theorem cpuProducerLoop_work (pairs : List (BusProducer × TableClaims)) + (rings : List RingPCSGame.FamilyClaim) (size : Nat) + (caps : ∀ p ∈ pairs, p.2.point.length ≤ size ∧ p.2.evals.length ≤ size) + (ts : List CallerToken) : + (forIn pairs rings cpuProducerStep ts).work ≤ + pairs.length*(2*(rings.length+pairs.length)+3*size+10) := by + simpa [Nat.add_assoc] using forIn_growth_work_le pairs rings cpuProducerStep List.length + 2 (3*size+10) 1 + (by intro p hp st tokens; exact cpuProducerStep_work p st size (caps p hp).1 (caps p hp).2 tokens) + (by + intro p _ st tokens step rest h + obtain ⟨ring,rfl,_⟩ := cpuProducerStep_success p st tokens rest step h + simp [iterationState]) ts + +theorem cpuProducerLoop_success (pairs : List (BusProducer × TableClaims)) + (rings : List RingPCSGame.FamilyClaim) (size : Nat) + (caps : ∀ p ∈ pairs, p.2.point.length ≤ size) + (initial : ∀ r ∈ rings, r.point.size ≤ size) + (ts rest : List CallerToken) (out : List RingPCSGame.FamilyClaim) + (h : (forIn pairs rings cpuProducerStep ts).result = some (out,rest)) : + out.length ≤ rings.length+pairs.length ∧ ∀ r ∈ out, r.point.size ≤ size := by + constructor + · simpa using loop_growth pairs cpuProducerStep List.length 1 + (by + intro p _ st tokens step tail parsed + obtain ⟨ring,rfl,_⟩ := cpuProducerStep_success p st tokens tail step parsed + simp [iterationState]) rings ts out rest h + · apply loop_preserves pairs cpuProducerStep (fun st => ∀ r ∈ st, r.point.size ≤ size) + _ rings ts out rest initial h + intro p hp st tokens step tail inv parsed + obtain ⟨ring,rfl,dimension⟩ := cpuProducerStep_success p st tokens tail step parsed + simp only [iterationState,List.mem_append,List.mem_singleton] + intro r member + rcases member with member | rfl + · exact inv r member + · exact dimension.le.trans (caps p hp) + +theorem cpuRegisterStep_work (summed : List TableClaims) (word : RegisterWord) + (state : CpuRings) (size : Nat) (count : summed.length ≤ size) + (tables : word.tables.length ≤ size) + (caps : ∀ c ∈ summed, c.point.length ≤ size ∧ c.slices.length ≤ size) + (ts : List CallerToken) : + (cpuRegisterStep summed word state ts).work ≤ + 2*state.2.length+2*size^3+3*size^2+9*size+14 := by + unfold cpuRegisterStep + rw [tick_bind_work] + cases head : word.tables.head? with + | none => + simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.liftOption] + | some first => + rw [tick_bind_work] + have index := indexWork_le summed first + cases lookup : summed[first]? with + | none => + simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.liftOption] + omega + | some claims => + have firstCaps := caps claims (List.mem_of_getElem? lookup) + have slicesWork := cpuSliceLoop_work summed word.tables size (by intro c hc; exact (caps c hc).2) ts + dsimp only + apply Nat.le_trans (Nat.add_le_add_left (Nat.add_le_add_left + (bind_work_le _ _ ts + (word.tables.length*(2*(size*word.tables.length)+2*summed.length+5)) + (size*word.tables.length+2*size+2*state.2.length+9) slicesWork ?_) _) _) + · nlinarith [Nat.mul_le_mul tables tables, + Nat.mul_le_mul (Nat.mul_le_mul tables tables) (Nat.le_refl size), + Nat.mul_le_mul tables count, Nat.mul_le_mul_left size tables] + · intro slices rest parsed + have geometry := cpuSliceLoop_success summed word.tables size + (by intro c hc; exact (caps c hc).2) ts rest slices parsed + rw [geometry.1] + have pad := paddedRing_work_le word.offset claims.point slices.2 + rw [tick_bind_work] + cases (PCSBCSCallerParserCost.paddedRing word.offset claims.point slices.2).value <;> + simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + PCSBCSCallerParserCost.check,Pure.pure,PCSBCSCallerParserCost.pure] <;> omega + +private theorem cpuRegisterStep_success (summed : List TableClaims) (word : RegisterWord) + (state : CpuRings) (size : Nat) + (caps : ∀ c ∈ summed, c.point.length ≤ size ∧ c.slices.length ≤ size) + (ts rest : List CallerToken) (step : ForInStep CpuRings) + (h : (cpuRegisterStep summed word state ts).result = some (step,rest)) : + ∃ ring, step = .yield (none,state.2 ++ [ring]) ∧ ring.point.size ≤ size := by + unfold cpuRegisterStep at h + cases head : word.tables.head? with + | none => + simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + PCSBCSCallerParserCost.liftOption,head] at h + | some first => + cases lookup : summed[first]? with + | none => + simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + PCSBCSCallerParserCost.liftOption,head,lookup] at h + | some claims => + simp only [head,lookup] at h + change ((forIn word.tables (none,[]) (cpuSliceStep summed) >>= _) ts).result = some (step,rest) at h + obtain ⟨slices,middle,parsed,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have geometry := cpuSliceLoop_success summed word.tables size + (by intro c hc; exact (caps c hc).2) ts middle slices parsed + rw [geometry.1] at h + cases pad : (PCSBCSCallerParserCost.paddedRing word.offset claims.point slices.2).value with + | none => + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + pad,PCSBCSCallerParserCost.check,Bool.false_eq_true,↓reduceIte] at h + cases h + | some ring => + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + pad,Pure.pure,PCSBCSCallerParserCost.pure,Option.some.injEq,Prod.mk.injEq] at h + rcases h with ⟨rfl,rfl⟩ + exact ⟨ring,rfl,(paddedRing_success_point_size _ _ _ _ pad).le.trans + (caps claims (List.mem_of_getElem? lookup)).1⟩ + +theorem cpuRegisterLoop_work (summed : List TableClaims) (words : List RegisterWord) + (rings : List RingPCSGame.FamilyClaim) (size : Nat) (count : summed.length ≤ size) + (tables : ∀ w ∈ words, w.tables.length ≤ size) + (caps : ∀ c ∈ summed, c.point.length ≤ size ∧ c.slices.length ≤ size) + (ts : List CallerToken) : + (forIn words (none,rings) (cpuRegisterStep summed) ts).work ≤ + words.length*(2*(rings.length+words.length)+2*size^3+3*size^2+9*size+14) := by + have bounded := forIn_growth_work_le words (none,rings) (cpuRegisterStep summed) + (fun st => st.2.length) 2 (2*size^3+3*size^2+9*size+14) 1 + (by intro w hw st tokens; simpa [Nat.add_assoc] using cpuRegisterStep_work summed w st size count (tables w hw) caps tokens) + (by + intro w _ st tokens step rest parsed + obtain ⟨ring,rfl,_⟩ := cpuRegisterStep_success summed w st size caps tokens rest step parsed + simp [iterationState]) ts + simpa only [Nat.one_mul,Nat.add_assoc] using bounded + +theorem cpuRegisterLoop_success (summed : List TableClaims) (words : List RegisterWord) + (rings : List RingPCSGame.FamilyClaim) (size : Nat) + (caps : ∀ c ∈ summed, c.point.length ≤ size ∧ c.slices.length ≤ size) + (initial : ∀ r ∈ rings, r.point.size ≤ size) + (ts rest : List CallerToken) (out : CpuRings) + (h : (forIn words (none,rings) (cpuRegisterStep summed) ts).result = some (out,rest)) : + out.1 = none ∧ out.2.length ≤ rings.length+words.length ∧ + ∀ r ∈ out.2, r.point.size ≤ size := by + constructor + · exact loop_preserves words (cpuRegisterStep summed) (fun st => st.1 = none) + (by + intro w _ st tokens step tail _ parsed + obtain ⟨ring,rfl,_⟩ := cpuRegisterStep_success summed w st size caps tokens tail step parsed + rfl) (none,rings) ts out rest rfl h + constructor + · simpa using loop_growth words (cpuRegisterStep summed) (fun st => st.2.length) 1 + (by + intro w _ st tokens step tail parsed + obtain ⟨ring,rfl,_⟩ := cpuRegisterStep_success summed w st size caps tokens tail step parsed + simp [iterationState]) (none,rings) ts out rest h + · apply loop_preserves words (cpuRegisterStep summed) (fun st => ∀ r ∈ st.2, r.point.size ≤ size) + _ (none,rings) ts out rest initial h + intro w _ st tokens step tail inv parsed + obtain ⟨ring,rfl,dimension⟩ := cpuRegisterStep_success summed w st size caps tokens tail step parsed + simp only [iterationState,List.mem_append,List.mem_singleton] + intro r member + rcases member with member | rfl + · exact inv r member + · exact dimension + + +def cpuColumnsFinish (layout : CpuLayout) (bus : List ColumnClaim) + (columns : List TableClaims) (rings : List RingPCSGame.FamilyClaim) : + Parser (List RingPCSGame.FamilyClaim × List ColumnClaim) := do + let paired := (layout.tables.map CpuTableLayout.base).zip columns + let columnClaims ← charged (3*layout.tables.length+1+ + 4*min layout.tables.length columns.length+1+columnsWork bus paired) + (bus ++ paired.flatMap (fun (base,claims) => WHIRCallerClaims.tableColumns base claims)) + pure (rings,columnClaims) + +def cpuAfterPacked (layout : CpuLayout) (bus : List ColumnClaim) + (columns summed : List TableClaims) (packed : List RingPCSGame.FamilyClaim) : + Parser (List RingPCSGame.FamilyClaim × List ColumnClaim) := do + let producers ← charged (layout.tables.length+1+min layout.tables.length summed.length+1) + (summed.drop layout.tables.length) + tick (4*min layout.bus.producers.length producers.length+1) + let rings ← forIn (layout.bus.producers.zip producers) packed cpuProducerStep + let state ← forIn layout.registers (none,rings) (cpuRegisterStep summed) + match state.1 with + | some r => pure r + | none => cpuColumnsFinish layout bus columns state.2 + +def cpuAfterSummed (layout : CpuLayout) (bus : List ColumnClaim) + (settled summed : List TableClaims) : + Parser (List RingPCSGame.FamilyClaim × List ColumnClaim) := do + tick (settled.length+1+2*min settled.length layout.tables.length+1+ + allWork (·.settled) (fun _ => 1) (layout.tables.take settled.length)) + PCSBCSCallerParserCost.check (layout.tables.take settled.length |>.all (·.settled)) + tick (settled.length+1+min settled.length layout.tables.length+1+ + allWork (! ·.settled) (fun _ => 2) (layout.tables.drop settled.length)) + PCSBCSCallerParserCost.check (layout.tables.drop settled.length |>.all (! ·.settled)) + let columns ← charged (layout.tables.length+1+2*min layout.tables.length summed.length+1+ + settled.length+1+min settled.length (min layout.tables.length summed.length)+1+ + 2*settled.length+1) (settled ++ (summed.take layout.tables.length).drop settled.length) + let packed ← PCSBCSCallerParserCost.flockClaims layout.flock + cpuAfterPacked layout bus columns summed packed + +def cpuAfterBus (layout : CpuLayout) (point : List E) (bus : List ColumnClaim) : + Parser (List RingPCSGame.FamilyClaim × List ColumnClaim) := do + let settled ← settledClaims layout.tables point + let _ ← PCSBCSCallerParserCost.drawScalar + let producerAirs ← charged (7*layout.bus.producers.length+1) + (layout.bus.producers.map (fun p => (⟨p.kappa,2*p.bits,p.bits,[]⟩ : AirLayout))) + let airs ← charged (8*layout.tables.length+ + (layout.tables.map (fun t => t.summedColumns.length+1)).sum+2) + (layout.tables.map CpuTableLayout.air ++ producerAirs) + let summed ← PCSBCSCallerParserCost.constraintClaims airs point + cpuAfterSummed layout bus settled summed + +private theorem cpu_forIn_congr {A B : Type} (xs : List A) (st : B) + (f g : A → B → Parser (ForInStep B)) + (h : ∀ x s, f x s = g x s) (ts : List CallerToken) : + forIn xs st f ts = forIn xs st g ts := + congrArg (fun body : A → B → Parser (ForInStep B) => forIn xs st body ts) + (funext fun x => funext fun s => h x s) + +attribute [local irreducible] PCSBCSCallerParserCost.bind PCSBCSCallerParserCost.pure + PCSBCSCallerParserCost.tick PCSBCSCallerParserCost.liftOption + PCSBCSCallerParserCost.busClaims settledClaims PCSBCSCallerParserCost.drawScalar + PCSBCSCallerParserCost.constraintClaims PCSBCSCallerParserCost.flockClaims + PCSBCSCallerParserCost.paddedRing + +theorem cpuPayloadBeforeExit_normalized (layout : CpuLayout) : + cpuPayloadBeforeExit layout = + (PCSBCSCallerParserCost.busClaims layout.bus >>= fun pair => cpuAfterBus layout pair.1 pair.2) := by + unfold cpuPayloadBeforeExit + apply congrArg (fun next : (List E × List ColumnClaim) → + Parser (List RingPCSGame.FamilyClaim × List ColumnClaim) => + PCSBCSCallerParserCost.busClaims layout.bus >>= next) + funext pair + rcases pair with ⟨point,bus⟩ + unfold cpuAfterBus cpuAfterSummed cpuAfterPacked cpuColumnsFinish + cpuProducerStep cpuRegisterStep cpuSliceStep + dsimp only + simp only [Bind.bind,Pure.pure] + repeat' first + | rfl + | (apply cpu_forIn_congr; intro word state) + | (congr 1 <;> funext x) + all_goals + rename_i carrier + rcases carrier with ⟨early,values⟩ + cases early <;> rfl + +attribute [local semireducible] PCSBCSCallerParserCost.bind PCSBCSCallerParserCost.pure + PCSBCSCallerParserCost.tick PCSBCSCallerParserCost.liftOption + PCSBCSCallerParserCost.busClaims settledClaims PCSBCSCallerParserCost.drawScalar + PCSBCSCallerParserCost.constraintClaims PCSBCSCallerParserCost.flockClaims + PCSBCSCallerParserCost.paddedRing + +private theorem cpu_member_sum {A : Type} (xs : List A) (f : A → Nat) (x : A) + (h : x ∈ xs) : f x ≤ (xs.map f).sum := by + induction xs with + | nil => simp at h + | cons a xs ih => + simp only [List.mem_cons] at h + simp only [List.map_cons,List.sum_cons] + rcases h with rfl | h + · omega + · have := ih h; omega + +theorem cpuLiteralCaps (layout : CpuLayout) (size : Nat) (volume : cpuLayoutVolume layout ≤ size) : + layout.tables.length ≤ size ∧ layout.bus.producers.length ≤ size ∧ + layout.registers.length ≤ size ∧ + (∀ t ∈ layout.tables, cpuTableVolume t ≤ size) ∧ + (∀ w ∈ layout.registers, w.tables.length ≤ size) := by + have components := cpuLayoutVolume_components layout + have airLength (xs : List AirLayout) : xs.length ≤ airLayoutsSize xs := by + unfold airLayoutsSize + induction xs with + | nil => simp + | cons a xs ih => + simp only [List.map_cons,List.sum_cons,List.length_cons] at * + omega + have length := airLength (cpuAirs layout) + simp only [cpuAirs,List.length_append,List.length_map] at length + change layout.tables.length+layout.bus.producers.length ≤ airLayoutsSize (cpuAirs layout) at length + refine ⟨components.2.2.1.trans volume,by omega,components.2.2.2.2.2.trans volume,?_,?_⟩ + · intro t ht + have entry := cpu_member_sum layout.tables cpuTableVolume t ht + unfold cpuLayoutVolume at volume + omega + · intro w hw + have entry := cpu_member_sum layout.registers registerVolume w hw + unfold cpuLayoutVolume registerVolume at * + omega + +theorem cpuColumnsFinish_work (layout : CpuLayout) (bus : List ColumnClaim) + (columns : List TableClaims) (rings : List RingPCSGame.FamilyClaim) + (ts : List CallerToken) (size : Nat) (count : layout.tables.length ≤ size) + (busCount : bus.length ≤ 2*size*size) + (caps : ∀ t ∈ columns, t.evals.length ≤ size) : + (cpuColumnsFinish layout bus columns rings ts).work ≤ 12*size^2+11*size+4 := by + let paired := (layout.tables.map CpuTableLayout.base).zip columns + have pairCount : paired.length ≤ size := by + simp only [paired,List.length_zip,List.length_map] + exact (Nat.min_le_left _ _).trans count + have work := columnsWork_le bus paired size + (by intro p hp; exact caps p.2 (List.of_mem_zip hp).2) + unfold cpuColumnsFinish charged + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure] + change 3*layout.tables.length+1+4*min layout.tables.length columns.length+1+ + columnsWork bus paired+0+0 ≤ _ + nlinarith [Nat.min_le_left layout.tables.length columns.length, + Nat.mul_le_mul_left (8*size+4) pairCount] + +theorem cpuColumnsFinish_success (layout : CpuLayout) (bus : List ColumnClaim) + (columns : List TableClaims) (rings : List RingPCSGame.FamilyClaim) + (ts rest : List CallerToken) (out : List RingPCSGame.FamilyClaim × List ColumnClaim) + (size : Nat) (count : layout.tables.length ≤ size) (busCount : bus.length ≤ 2*size*size) + (busPoints : ∀ c ∈ bus, c.point.length ≤ size) + (caps : ∀ t ∈ columns, t.point.length ≤ size ∧ t.evals.length ≤ size) + (h : (cpuColumnsFinish layout bus columns rings ts).result = some (out,rest)) : + out.1 = rings ∧ out.2.length ≤ 3*size*size ∧ ∀ c ∈ out.2, c.point.length ≤ size := by + let paired := (layout.tables.map CpuTableLayout.base).zip columns + have pairCount : paired.length ≤ size := by + simp only [paired,List.length_zip,List.length_map] + exact (Nat.min_le_left _ _).trans count + have geometry := column_geometry bus paired size busCount busPoints pairCount + (by intro p hp; exact caps p.2 (List.of_mem_zip hp).2) + unfold cpuColumnsFinish charged at h + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure,Option.some.injEq,Prod.mk.injEq] at h + rcases h with ⟨rfl,rfl⟩ + exact ⟨rfl,geometry⟩ + +private theorem charged_bind_work {A B : Type} (n : Nat) (a : A) (f : A → Parser B) + (ts : List CallerToken) : ((charged n a >>= f) ts).work = n+(f a ts).work := by + simp only [charged,Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure,Nat.add_zero] + +private theorem charged_bind_result {A B : Type} (n : Nat) (a : A) (f : A → Parser B) + (ts : List CallerToken) : ((charged n a >>= f) ts).result = (f a ts).result := rfl + +def cpuBeforeExitWork (size : Nat) : Nat := + busClaimsWork size+100*(size+1)^3*size+2*size^4+110*size^3+300*size^2+1300*size+1000 + +def CpuClaimCaps (size : Nat) (out : List RingPCSGame.FamilyClaim × List ColumnClaim) : Prop := + out.1.length ≤ 3*size ∧ (∀ r ∈ out.1, r.point.size ≤ size) ∧ + out.2.length ≤ 3*size*size ∧ (∀ c ∈ out.2, c.point.length ≤ size) + +theorem cpuAfterPacked_work (layout : CpuLayout) (bus : List ColumnClaim) + (columns summed : List TableClaims) (packed : List RingPCSGame.FamilyClaim) + (ts : List CallerToken) (size : Nat) (volume : cpuLayoutVolume layout ≤ size) + (busCount : bus.length ≤ 2*size*size) (summedCount : summed.length ≤ size) + (summedCaps : ∀ t ∈ summed, t.point.length ≤ size ∧ t.evals.length ≤ size ∧ t.slices.length ≤ size) + (columnCaps : ∀ t ∈ columns, t.evals.length ≤ size) (packedCount : packed.length ≤ size) : + (cpuAfterPacked layout bus columns summed packed ts).work ≤ + 2*size^4+3*size^3+40*size^2+60*size+30 := by + have literals := cpuLiteralCaps layout size volume + let pairs := layout.bus.producers.zip (summed.drop layout.tables.length) + have pairCount : pairs.length ≤ size := by + simp only [pairs,List.length_zip] + exact (Nat.min_le_left _ _).trans literals.2.1 + have pairCaps : ∀ p ∈ pairs, p.2.point.length ≤ size ∧ p.2.evals.length ≤ size := by + intro p hp + have member := (List.of_mem_zip hp).2 + have source := List.mem_of_mem_drop member + exact ⟨(summedCaps p.2 source).1,(summedCaps p.2 source).2.1⟩ + have producerWork := cpuProducerLoop_work pairs packed size pairCaps ts + have producerCap : (forIn pairs packed cpuProducerStep ts).work ≤ size*(7*size+10) := by + apply producerWork.trans + exact Nat.mul_le_mul pairCount (by omega) + unfold cpuAfterPacked + rw [charged_bind_work,tick_bind_work] + apply Nat.le_trans (Nat.add_le_add_left (Nat.add_le_add_left + (bind_work_le _ _ ts (size*(7*size+10)) + (size*(2*size^3+3*size^2+15*size+14)+12*size^2+11*size+4) producerCap ?_) _) _) + · have mn := Nat.min_le_left layout.tables.length summed.length + have mp := Nat.min_le_left layout.bus.producers.length (summed.drop layout.tables.length).length + nlinarith + · intro rings rest parsed + have grown := loop_growth pairs cpuProducerStep List.length 1 + (by + intro p _ st tokens step tail accepted + obtain ⟨ring,rfl,_⟩ := cpuProducerStep_success p st tokens tail step accepted + simp [iterationState]) packed ts rings rest parsed + simp only [Nat.one_mul] at grown + have ringCount : rings.length ≤ 2*size := by omega + have registerWork := cpuRegisterLoop_work summed layout.registers rings size summedCount + literals.2.2.2.2 (by intro t ht; exact ⟨(summedCaps t ht).1,(summedCaps t ht).2.2⟩) rest + have registerCap : (forIn layout.registers (none,rings) (cpuRegisterStep summed) rest).work ≤ + size*(2*size^3+3*size^2+15*size+14) := by + apply registerWork.trans + exact Nat.mul_le_mul literals.2.2.1 (by omega) + cpu_bind (size*(2*size^3+3*size^2+15*size+14)), (12*size^2+11*size+4) + · exact registerCap + · intro state tail reached + have clean := loop_preserves layout.registers (cpuRegisterStep summed) (fun st => st.1 = none) + (by + intro w _ st tokens step remaining _ accepted + obtain ⟨ring,rfl,_⟩ := cpuRegisterStep_success summed w st size + (by intro t ht; exact ⟨(summedCaps t ht).1,(summedCaps t ht).2.2⟩) + tokens remaining step accepted + rfl) (none,rings) rest state tail rfl reached + rw [clean] + exact cpuColumnsFinish_work layout bus columns state.2 tail size literals.1 busCount columnCaps + +theorem cpuAfterPacked_success (layout : CpuLayout) (bus : List ColumnClaim) + (columns summed : List TableClaims) (packed : List RingPCSGame.FamilyClaim) + (ts rest : List CallerToken) (out : List RingPCSGame.FamilyClaim × List ColumnClaim) + (size : Nat) (volume : cpuLayoutVolume layout ≤ size) + (busCount : bus.length ≤ 2*size*size) (busPoints : ∀ c ∈ bus, c.point.length ≤ size) + (summedCaps : ∀ t ∈ summed, t.point.length ≤ size ∧ t.slices.length ≤ size) + (columnCaps : ∀ t ∈ columns, t.point.length ≤ size ∧ t.evals.length ≤ size) + (packedCount : packed.length ≤ size) (packedPoints : ∀ r ∈ packed, r.point.size ≤ size) + (h : (cpuAfterPacked layout bus columns summed packed ts).result = some (out,rest)) : + CpuClaimCaps size out := by + have literals := cpuLiteralCaps layout size volume + let pairs := layout.bus.producers.zip (summed.drop layout.tables.length) + have pairCount : pairs.length ≤ size := by + simp only [pairs,List.length_zip] + exact (Nat.min_le_left _ _).trans literals.2.1 + unfold cpuAfterPacked at h + rw [charged_bind_result] at h + change ((forIn pairs packed cpuProducerStep >>= _) ts).result = some (out,rest) at h + obtain ⟨rings,middle,parsed,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have producers := cpuProducerLoop_success pairs packed size + (by intro p hp; exact (summedCaps p.2 (List.mem_of_mem_drop (List.of_mem_zip hp).2)).1) + packedPoints ts middle rings parsed + obtain ⟨state,tail,reached,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have registers := cpuRegisterLoop_success summed layout.registers rings size summedCaps + producers.2 middle tail state reached + rw [registers.1] at h + have columns := cpuColumnsFinish_success layout bus columns state.2 tail rest out size + literals.1 busCount busPoints columnCaps h + unfold CpuClaimCaps + rw [columns.1] + refine ⟨?_,registers.2.2,columns.2⟩ + omega + +private theorem cpu_tick_bound {A : Type} (n : Nat) (p : Parser A) (ts : List CallerToken) + (cap total : Nat) (sum : n+cap ≤ total) (hp : (p ts).work ≤ cap) : + ((tick n >>= fun _ => p) ts).work ≤ total := by + rw [tick_bind_work] + exact (Nat.add_le_add_left hp n).trans sum + +local macro "cpu_tick " cap:term : tactic => + `(tactic| (apply cpu_tick_bound _ _ _ $cap; · first | omega | nlinarith)) + +private theorem cpuMergedCaps (layout : CpuLayout) (settled summed : List TableClaims) (size : Nat) + (settledCaps : ∀ t ∈ settled, t.point.length ≤ size ∧ t.evals.length ≤ size) + (summedCaps : ∀ t ∈ summed, t.point.length ≤ size ∧ t.evals.length ≤ size ∧ t.slices.length ≤ size) : + ∀ t ∈ settled ++ (summed.take layout.tables.length).drop settled.length, + t.point.length ≤ size ∧ t.evals.length ≤ size := by + intro t ht + rcases List.mem_append.mp ht with ht | ht + · exact settledCaps t ht + · have source := List.mem_of_mem_take (List.mem_of_mem_drop ht) + exact ⟨(summedCaps t source).1,(summedCaps t source).2.1⟩ + +theorem cpuAfterSummed_work (layout : CpuLayout) (bus : List ColumnClaim) + (settled summed : List TableClaims) (ts : List CallerToken) (size : Nat) + (volume : cpuLayoutVolume layout ≤ size) (busCount : bus.length ≤ 2*size*size) + (settledCount : settled.length ≤ size) (summedCount : summed.length ≤ size) + (settledCaps : ∀ t ∈ settled, t.point.length ≤ size ∧ t.evals.length ≤ size) + (summedCaps : ∀ t ∈ summed, t.point.length ≤ size ∧ t.evals.length ≤ size ∧ t.slices.length ≤ size) : + (cpuAfterSummed layout bus settled summed ts).work ≤ + 2*size^4+3*size^3+60*size^2+1000*size+800 := by + have literals := cpuLiteralCaps layout size volume + have components := cpuLayoutVolume_components layout + have flockConfig := components.2.2.2.1.trans volume + have allFirst := allWork_le (fun t : CpuTableLayout => t.settled) (fun _ => 1) + (layout.tables.take settled.length) 1 (by intro t _; exact Nat.le_refl _) + have allLast := allWork_le (fun t : CpuTableLayout => !t.settled) (fun _ => 2) + (layout.tables.drop settled.length) 2 (by intro t _; exact Nat.le_refl _) + have firstLen : (layout.tables.take settled.length).length ≤ size := + (List.length_take_le _ _).trans settledCount + have lastLen : (layout.tables.drop settled.length).length ≤ size := + (by rw [List.length_drop]; omega) + have merged := cpuMergedCaps layout settled summed size settledCaps summedCaps + unfold cpuAfterSummed + cpu_tick (2*size^4+3*size^3+60*size^2+994*size+797) + cpu_bind 3, (2*size^4+3*size^3+60*size^2+994*size+794) + · exact check_work_le _ _ + · intro _ rest _ + cpu_tick (2*size^4+3*size^3+60*size^2+987*size+791) + cpu_bind 3, (2*size^4+3*size^3+60*size^2+987*size+788) + · exact check_work_le _ _ + · intro _ tail _ + rw [charged_bind_work] + apply Nat.le_trans (Nat.add_le_add_left + (bind_work_le _ _ tail (20*size^2+800*size+700) + (2*size^4+3*size^3+40*size^2+60*size+30) ?_ ?_) _) + · nlinarith [Nat.min_le_left layout.tables.length summed.length, + Nat.min_le_left settled.length layout.tables.length, + Nat.min_le_left settled.length (min layout.tables.length summed.length)] + · have work := flockClaims_work_le layout.flock tail + have square := Nat.mul_self_le_mul_self flockConfig + nlinarith + · intro packed cursor accepted + have shape := (flockClaims_resource layout.flock tail).2 packed cursor accepted + have count := (FlockPolynomial.dimension_caps layout.flock).1.trans flockConfig + exact cpuAfterPacked_work layout bus _ summed packed cursor size volume busCount summedCount + summedCaps (by intro t ht; exact (merged t ht).2) (by omega) + +theorem cpuAfterSummed_success (layout : CpuLayout) (bus : List ColumnClaim) + (settled summed : List TableClaims) (ts rest : List CallerToken) + (out : List RingPCSGame.FamilyClaim × List ColumnClaim) (size : Nat) + (volume : cpuLayoutVolume layout ≤ size) (busCount : bus.length ≤ 2*size*size) + (busPoints : ∀ c ∈ bus, c.point.length ≤ size) + (settledCaps : ∀ t ∈ settled, t.point.length ≤ size ∧ t.evals.length ≤ size) + (summedCaps : ∀ t ∈ summed, t.point.length ≤ size ∧ t.evals.length ≤ size ∧ t.slices.length ≤ size) + (h : (cpuAfterSummed layout bus settled summed ts).result = some (out,rest)) : + CpuClaimCaps size out := by + have components := cpuLayoutVolume_components layout + have flockConfig := components.2.2.2.1.trans volume + unfold cpuAfterSummed at h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨columns,cursor,constructed,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have equal : columns = settled ++ (summed.take layout.tables.length).drop settled.length := by + change some (_,_) = some (columns,cursor) at constructed + exact (congrArg Prod.fst (Option.some.inj constructed)).symm + subst columns + obtain ⟨packed,tail,accepted,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have shape := (flockClaims_resource layout.flock cursor).2 packed tail accepted + have count := (FlockPolynomial.dimension_caps layout.flock).1.trans flockConfig + exact cpuAfterPacked_success layout bus _ summed packed tail rest out size volume + busCount busPoints (by intro t ht; exact ⟨(summedCaps t ht).1,(summedCaps t ht).2.2⟩) + (cpuMergedCaps layout settled summed size settledCaps summedCaps) + (by omega) (by intro r hr; exact (shape.2 r hr).trans flockConfig) h + +def cpuAfterBusWork (size : Nat) : Nat := + size*(2*size+100*(size+1)^2)+4+(7*size+1)+(8*size+size*(size+1)+2)+ + (100*(size+1)^3*size+2*size^2+50*size+20)+ + (2*size^4+3*size^3+60*size^2+1000*size+800) + +theorem cpuAfterBus_work (layout : CpuLayout) (point : List E) (bus : List ColumnClaim) + (ts : List CallerToken) (size : Nat) (volume : cpuLayoutVolume layout ≤ size) + (pointCap : point.length ≤ size) (busCount : bus.length ≤ 2*size*size) : + (cpuAfterBus layout point bus ts).work ≤ cpuAfterBusWork size := by + have literals := cpuLiteralCaps layout size volume + have components := cpuLayoutVolume_components layout + have airConfig := components.2.1.trans volume + have metadata := sumMap_le layout.tables (fun t => t.summedColumns.length+1) (size+1) + (by intro t ht; have c := cpuTableVolume_components t; have v := literals.2.2.2.1 t ht; omega) + have metadataCap : (layout.tables.map (fun t => t.summedColumns.length+1)).sum ≤ size*(size+1) := + metadata.trans (by simpa only [Nat.mul_comm] using Nat.mul_le_mul_left (size+1) literals.1) + unfold cpuAfterBus cpuAfterBusWork + cpu_bind (size*(2*size+100*(size+1)^2)), + (4+(7*size+1)+(8*size+size*(size+1)+2)+ + (100*(size+1)^3*size+2*size^2+50*size+20)+ + (2*size^4+3*size^3+60*size^2+1000*size+800)) + · exact (settledClaims_work_polynomial layout.tables point ts size literals.1 + literals.2.2.2.1 pointCap).trans + (Nat.mul_le_mul literals.1 (by omega)) + · intro settled rest accepted + have settledCaps := settledClaims_success_caps layout.tables point ts rest settled size + literals.1 literals.2.2.2.1 accepted + cpu_bind 4, ((7*size+1)+(8*size+size*(size+1)+2)+ + (100*(size+1)^3*size+2*size^2+50*size+20)+ + (2*size^4+3*size^3+60*size^2+1000*size+800)) + · exact drawScalar_work_le rest + · intro _ tail _ + rw [charged_bind_work,charged_bind_work] + apply Nat.le_trans (Nat.add_le_add_left (Nat.add_le_add_left + (bind_work_le _ _ tail (100*(size+1)^3*size+2*size^2+50*size+20) + (2*size^4+3*size^3+60*size^2+1000*size+800) ?_ ?_) _) _) + · omega + · simpa only [cpuAirs,Nat.pow_two,Nat.mul_assoc] using + constraintClaims_work_polynomial (cpuAirs layout) point tail size airConfig pointCap + · intro summed cursor received + have caps := constraintClaims_success_caps (cpuAirs layout) point tail cursor summed size airConfig received + exact cpuAfterSummed_work layout bus settled summed cursor size volume busCount + settledCaps.1 caps.1 settledCaps.2 caps.2 + +theorem cpuAfterBus_success (layout : CpuLayout) (point : List E) (bus : List ColumnClaim) + (ts rest : List CallerToken) (out : List RingPCSGame.FamilyClaim × List ColumnClaim) + (size : Nat) (volume : cpuLayoutVolume layout ≤ size) (busCount : bus.length ≤ 2*size*size) + (busPoints : ∀ c ∈ bus, c.point.length ≤ size) + (h : (cpuAfterBus layout point bus ts).result = some (out,rest)) : CpuClaimCaps size out := by + have literals := cpuLiteralCaps layout size volume + have airConfig := (cpuLayoutVolume_components layout).2.1.trans volume + unfold cpuAfterBus at h + obtain ⟨settled,middle,accepted,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have settledCaps := settledClaims_success_caps layout.tables point ts middle settled size + literals.1 literals.2.2.2.1 accepted + obtain ⟨_,tail,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + rw [charged_bind_result,charged_bind_result] at h + obtain ⟨summed,cursor,received,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have summedCaps := constraintClaims_success_caps (cpuAirs layout) point tail cursor summed size airConfig received + exact cpuAfterSummed_success layout bus settled summed cursor rest out size volume busCount + busPoints settledCaps.2 summedCaps.2 h + +theorem cpuPayloadBeforeExit_work_polynomial (layout : CpuLayout) (tokens : List CallerToken) + (size : Nat) (volume : cpuLayoutVolume layout ≤ size) : + (cpuPayloadBeforeExit layout tokens).work ≤ cpuBeforeExitWork size := by + have busConfig := (cpuLayoutVolume_components layout).1.trans volume + rw [cpuPayloadBeforeExit_normalized] + unfold cpuBeforeExitWork + apply cpu_bind_bound _ _ _ (busClaimsWork size) (cpuAfterBusWork size) + · unfold cpuAfterBusWork; nlinarith + · exact busClaims_work_polynomial layout.bus tokens size busConfig + · intro pair rest accepted + have caps := busClaims_success_caps layout.bus tokens rest pair size busConfig accepted + exact cpuAfterBus_work layout pair.1 pair.2 rest size volume caps.2.1 caps.2.2.1 + +theorem cpuPayloadBeforeExit_success_caps (layout : CpuLayout) (tokens rest : List CallerToken) + (out : List RingPCSGame.FamilyClaim × List ColumnClaim) (size : Nat) + (volume : cpuLayoutVolume layout ≤ size) + (h : (cpuPayloadBeforeExit layout tokens).result = some (out,rest)) : CpuClaimCaps size out := by + have busConfig := (cpuLayoutVolume_components layout).1.trans volume + rw [cpuPayloadBeforeExit_normalized] at h + obtain ⟨pair,middle,accepted,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have caps := busClaims_success_caps layout.bus tokens middle pair size busConfig accepted + exact cpuAfterBus_success layout pair.1 pair.2 middle rest out size volume caps.2.2.1 caps.2.2.2 h + +def cpuPayloadWorkPolynomial (size : Nat) : Nat := + cpuBeforeExitWork size+(3*size*size+5)*(2*(size+6)+15)+6*size^2+300 + +theorem cpuExitColumns_caps (column : Nat) (output : Fin 4 → UInt64) (cost : OutputCosts) : + ∀ c ∈ (exitClaims column output cost).value, c.point.length = 6 := by + intro c hc + simp only [exitClaims,WHIRCallerClaims.exitClaims,List.mem_cons,List.mem_ofFn] at hc + rcases hc with rfl | ⟨i,rfl⟩ <;> simp + +theorem cpuPayload_zero_work_polynomial (layout : CpuLayout) (cost : OutputCosts) + (tokens : List CallerToken) (size : Nat) (volume : cpuLayoutVolume layout ≤ size) : + (cpuPayload layout {cost with call := fun _ => 0} tokens).work ≤ cpuPayloadWorkPolynomial size := by + unfold cpuPayload cpuPayloadWorkPolynomial + cpu_bind (cpuBeforeExitWork size), ((3*size*size+5)*(2*(size+6)+15)+6*size^2+300) + · exact cpuPayloadBeforeExit_work_polynomial layout tokens size volume + · intro pair rest accepted + have caps := cpuPayloadBeforeExit_success_caps layout tokens rest pair size volume accepted + rcases pair with ⟨rings,columns⟩ + rw [charged_bind_work] + have exits := exitClaims_length layout.finalRegisterColumn layout.output {cost with call := fun _ => 0} + have columnCount : (columns ++ (exitClaims layout.finalRegisterColumn layout.output + {cost with call := fun _ => 0}).value).length ≤ 3*size*size+5 := by + simp only [List.length_append,exits]; exact Nat.add_le_add_right caps.2.2.1 5 + have pointCaps : ∀ c ∈ columns ++ (exitClaims layout.finalRegisterColumn layout.output + {cost with call := fun _ => 0}).value, c.point.length ≤ size+6 := by + intro c hc + rcases List.mem_append.mp hc with hc | hc + · exact (caps.2.2.2 c hc).trans (Nat.le_add_right _ _) + · rw [cpuExitColumns_caps _ _ _ c hc]; omega + have placed := placeClaims_work_le layout.placements _ (size+6) pointCaps + have placedCap := Nat.mul_le_mul_right (2*(size+6)+15) columnCount + let allColumns := columns ++ (exitClaims layout.finalRegisterColumn layout.output {cost with call := fun _ => 0}).value + change (PCSBCSCallerParserCost.placeClaims layout.placements allColumns).work ≤ _ at placed + have finish : ((PCSBCSCallerParserCost.liftOption + (PCSBCSCallerParserCost.placeClaims layout.placements allColumns).work + (PCSBCSCallerParserCost.placeClaims layout.placements allColumns).value >>= fun points => + (Pure.pure (rings,points) : Parser _)) rest).work ≤ + (3*size*size+5)*(2*(size+6)+15)+6 := by + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.liftOption] + cases (PCSBCSCallerParserCost.placeClaims layout.placements allColumns).value <;> + simp only [Option.map_none,Option.map_some,Pure.pure,PCSBCSCallerParserCost.pure,Nat.add_zero] + <;> omega + have exitWork : (exitClaims layout.finalRegisterColumn layout.output {cost with call := fun _ => 0}).work = 281 := by + simp [exitClaims_work,OutputCosts.total] + rw [exitWork] + nlinarith [caps.2.2.1] + +/-- Every token stream, including early and late rejection, pays only reached +getters. Callback prices are arbitrary naturals and never absorbed in volume. -/ +theorem cpuPayload_work_polynomial (layout : CpuLayout) (cost : OutputCosts) + (tokens : List CallerToken) (size : Nat) (volume : cpuLayoutVolume layout ≤ size) : + (cpuPayload layout cost tokens).work ≤ cpuPayloadWorkPolynomial size+ + (if (cpuPayloadBeforeExit layout tokens).result.isSome then cost.total else 0) := by + rw [cpuPayload_output_work] + exact Nat.add_le_add_right (cpuPayload_zero_work_polynomial layout cost tokens size volume) _ + +def cpuPointDimension : RingPCSGame.PointClaim → Nat + | .point _ p _ => p.size + | .strided _ _ _ p _ => p.size + +private theorem cpuPlaceLoop_dimensions (placements : Array Placement) + (columns : List ColumnClaim) (cap : Nat) + (caps : ∀ c ∈ columns, c.point.length ≤ cap) + (xs : List (Option RingPCSGame.PointClaim)) + (h : (PCSBCSCallerParserCost.placeClaimsLoop placements columns).value = some xs) : + ∀ x ∈ xs, ∀ p, x = some p → cpuPointDimension p ≤ cap := by + induction columns generalizing xs with + | nil => + change some [] = some xs at h; cases h; simp + | cons c cs ih => + simp only [PCSBCSCallerParserCost.placeClaimsLoop] at h + cases lookup : placements[c.column]? with + | none => simp only [lookup] at h; cases h + | some place => + cases tail : (PCSBCSCallerParserCost.placeClaimsLoop placements cs).value with + | none => simp only [lookup,tail,Option.map_none] at h; cases h + | some ys => + simp only [lookup,tail,Option.map_some,Option.some.injEq] at h + subst xs + intro x hx p equal + rcases List.mem_cons.mp hx with rfl | hx + · cases place <;> + simp only [PCSBCSCallerParserCost.placeClaim,Option.some.injEq,reduceCtorEq] at equal + all_goals subst p; simpa [cpuPointDimension] using caps c (by simp) + · exact ih (by intro d hd; exact caps d (by simp [hd])) ys tail x hx p equal + +theorem cpuPlaceClaims_dimensions (placements : Array Placement) (columns : List ColumnClaim) + (cap : Nat) (caps : ∀ c ∈ columns, c.point.length ≤ cap) + (points : Array RingPCSGame.PointClaim) + (h : (PCSBCSCallerParserCost.placeClaims placements columns).value = some points) : + ∀ p ∈ points.toList, cpuPointDimension p ≤ cap := by + unfold PCSBCSCallerParserCost.placeClaims at h + cases loop : (PCSBCSCallerParserCost.placeClaimsLoop placements columns).value with + | none => simp only [loop] at h; cases h + | some xs => + simp only [loop,Option.some.injEq] at h + subst points + intro p hp + simp only [List.mem_filterMap] at hp + obtain ⟨x,hx,equal⟩ := hp + exact cpuPlaceLoop_dimensions placements columns cap caps xs loop x hx p equal + +theorem cpuPayload_success_caps (layout : CpuLayout) (cost : OutputCosts) + (tokens rest : List CallerToken) (out : List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) + (size : Nat) (volume : cpuLayoutVolume layout ≤ size) + (h : (cpuPayload layout cost tokens).result = some (out,rest)) : + out.1.length ≤ 3*size ∧ (∀ r ∈ out.1, r.point.size ≤ size) ∧ + out.2.size ≤ 3*size*size+5 ∧ (∀ p ∈ out.2.toList, cpuPointDimension p ≤ size+6) := by + unfold cpuPayload at h + obtain ⟨pair,middle,accepted,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have caps := cpuPayloadBeforeExit_success_caps layout tokens middle pair size volume accepted + rcases pair with ⟨rings,columns⟩ + rw [charged_bind_result] at h + obtain ⟨points,tail,placed,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + change some ((rings,points),tail) = some (out,rest) at h + cases h + have placement : (PCSBCSCallerParserCost.placeClaims layout.placements + (columns ++ (exitClaims layout.finalRegisterColumn layout.output cost).value)).value = some points := by + change Option.map (fun x => (x,middle)) _ = some (points,rest) at placed + cases hv : (PCSBCSCallerParserCost.placeClaims layout.placements + (columns ++ (exitClaims layout.finalRegisterColumn layout.output cost).value)).value with + | none => simp only [hv,Option.map_none] at placed; cases placed + | some p => + simp only [hv,Option.map_some,Option.some.injEq,Prod.mk.injEq] at placed + exact congrArg some placed.1 + have pointCaps : ∀ c ∈ columns ++ (exitClaims layout.finalRegisterColumn layout.output cost).value, + c.point.length ≤ size+6 := by + intro c hc + rcases List.mem_append.mp hc with hc | hc + · exact (caps.2.2.2 c hc).trans (Nat.le_add_right _ _) + · rw [cpuExitColumns_caps _ _ _ c hc]; omega + refine ⟨caps.1,caps.2.1,?_,cpuPlaceClaims_dimensions _ _ _ pointCaps _ placement⟩ + have count := placeClaims_success_size _ _ _ placement + rw [List.length_append,exitClaims_length] at count + dsimp only [CpuClaimCaps] at caps ⊢ + omega + +private theorem cpuLoop_exact {A B : Type} (xs : List A) + (body : A → B → Parser (ForInStep B)) (size : B → Nat) + (each : ∀ x ∈ xs, ∀ st ts step rest, (body x st ts).result = some (step,rest) → + ∃ next, step = .yield next ∧ size next = size st+1) + (st : B) (ts : List CallerToken) (out : B) (rest : List CallerToken) + (h : (forIn xs st body ts).result = some (out,rest)) : + size out = size st+xs.length := by + induction xs generalizing st ts with + | nil => change some (st,ts) = some (out,rest) at h; cases h; simp + | cons x xs ih => + rw [List.forIn_cons] at h + obtain ⟨step,middle,first,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨next,rfl,growth⟩ := each x (by simp) st ts step middle first + have last := ih (by intro y hy; exact each y (by simp [hy])) next middle h + simp only [List.length_cons] + omega + +theorem cpuAfterPacked_family_count (layout : CpuLayout) (bus : List ColumnClaim) + (columns summed : List TableClaims) (packed : List RingPCSGame.FamilyClaim) + (ts rest : List CallerToken) (out : List RingPCSGame.FamilyClaim × List ColumnClaim) + (size : Nat) (summedCaps : ∀ t ∈ summed, t.point.length ≤ size ∧ t.slices.length ≤ size) + (h : (cpuAfterPacked layout bus columns summed packed ts).result = some (out,rest)) : + out.1.length = packed.length+ + (layout.bus.producers.zip (summed.drop layout.tables.length)).length+layout.registers.length := by + unfold cpuAfterPacked at h + rw [charged_bind_result] at h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨rings,middle,accepted,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have producers := cpuLoop_exact _ cpuProducerStep List.length + (by + intro p _ st tokens step tail parsed + obtain ⟨ring,rfl,_⟩ := cpuProducerStep_success p st tokens tail step parsed + exact ⟨st ++ [ring],rfl,by simp⟩) packed cursor rings middle accepted + obtain ⟨state,tail,reached,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have registers := cpuLoop_exact layout.registers (cpuRegisterStep summed) (fun st => st.2.length) + (by + intro w _ st tokens step remaining parsed + obtain ⟨ring,rfl,_⟩ := cpuRegisterStep_success summed w st size summedCaps tokens remaining step parsed + exact ⟨(none,st.2 ++ [ring]),rfl,by simp⟩) (none,rings) middle state tail reached + have clean := loop_preserves layout.registers (cpuRegisterStep summed) (fun st => st.1 = none) + (by + intro w _ st tokens step remaining _ parsed + obtain ⟨ring,rfl,_⟩ := cpuRegisterStep_success summed w st size summedCaps tokens remaining step parsed + rfl) (none,rings) middle state tail rfl reached + rw [clean] at h + unfold cpuColumnsFinish charged at h + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure,Option.some.injEq,Prod.mk.injEq] at h + rcases h with ⟨rfl,rfl⟩ + dsimp only at registers ⊢ + omega + +/-- Exact family cardinality on actual success: every declared producer and +register contributes once, even though all rejection prefixes remain bounded. -/ +theorem cpuPayloadBeforeExit_success_family_count (layout : CpuLayout) + (tokens rest : List CallerToken) (out : List RingPCSGame.FamilyClaim × List ColumnClaim) + (h : (cpuPayloadBeforeExit layout tokens).result = some (out,rest)) : + out.1.length = layout.flock.length+layout.bus.producers.length+layout.registers.length := by + rw [cpuPayloadBeforeExit_normalized] at h + obtain ⟨pair,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + unfold cpuAfterBus at h + obtain ⟨settled,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + rw [charged_bind_result,charged_bind_result] at h + obtain ⟨summed,cursor,received,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have cardinality := constraintClaims_success_length (cpuAirs layout) pair.1 _ cursor summed received + have caps := constraintClaims_success_caps (cpuAirs layout) pair.1 _ cursor summed + (airLayoutsSize (cpuAirs layout)) (Nat.le_refl _) received + unfold cpuAfterSummed at h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨_,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨columns,cursor,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + obtain ⟨packed,tail,accepted,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have packedCount := (flockClaims_success_layouts layout.flock cursor packed tail accepted).1 + have count := cpuAfterPacked_family_count layout pair.2 columns summed packed tail rest out + (airLayoutsSize (cpuAirs layout)) (by intro t ht; exact ⟨(caps.2 t ht).1,(caps.2 t ht).2.2⟩) h + simp only [cpuAirs,List.length_append,List.length_map] at cardinality + simp only [List.length_zip,List.length_drop,packedCount] at count + omega + +theorem cpuPayload_success_family_count (layout : CpuLayout) (cost : OutputCosts) + (tokens rest : List CallerToken) (out : List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) + (h : (cpuPayload layout cost tokens).result = some (out,rest)) : + out.1.length = layout.flock.length+layout.bus.producers.length+layout.registers.length := by + unfold cpuPayload at h + obtain ⟨pair,cursor,accepted,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + have count := cpuPayloadBeforeExit_success_family_count layout tokens cursor pair accepted + rcases pair with ⟨rings,columns⟩ + rw [charged_bind_result] at h + obtain ⟨points,tail,_,h⟩ := FlockPolynomial.bind_success _ _ _ _ _ h + change some ((rings,points),tail) = some (out,rest) at h + cases h + exact count + +/-- Canonical literal-layout bound, with no external work or size certificate. -/ +theorem cpuPayloadBeforeExit_work_literal_polynomial (layout : CpuLayout) + (tokens : List CallerToken) : + (cpuPayloadBeforeExit layout tokens).work ≤ cpuBeforeExitWork (cpuLayoutVolume layout) := + cpuPayloadBeforeExit_work_polynomial layout tokens _ (Nat.le_refl _) + +/-- The mandatory surcharge is the sum of the four actually reached output +calls. Construction does not invoke the families' delayed slice closures. -/ +theorem cpuPayload_work_literal_polynomial (layout : CpuLayout) (cost : OutputCosts) + (tokens : List CallerToken) : + (cpuPayload layout cost tokens).work ≤ cpuPayloadWorkPolynomial (cpuLayoutVolume layout)+ + ((outputGetterTrace layout tokens).map cost.call).sum := by + rw [outputGetterTrace_cost] + exact cpuPayload_work_polynomial layout cost tokens _ (Nat.le_refl _) + +theorem cpuPayload_resource (layout : CpuLayout) (cost : OutputCosts) (tokens : List CallerToken) : + (cpuPayload layout cost tokens).work ≤ cpuPayloadWorkPolynomial (cpuLayoutVolume layout)+ + ((outputGetterTrace layout tokens).map cost.call).sum ∧ + ∀ out rest, (cpuPayload layout cost tokens).result = some (out,rest) → + out.1.length = layout.flock.length+layout.bus.producers.length+layout.registers.length ∧ + (∀ r ∈ out.1, r.point.size ≤ cpuLayoutVolume layout) ∧ + out.2.size ≤ 3*cpuLayoutVolume layout*cpuLayoutVolume layout+5 ∧ + (∀ p ∈ out.2.toList, cpuPointDimension p ≤ cpuLayoutVolume layout+6) := by + refine ⟨cpuPayload_work_literal_polynomial layout cost tokens,?_⟩ + intro out rest accepted + have caps := cpuPayload_success_caps layout cost tokens rest out _ (Nat.le_refl _) accepted + exact ⟨cpuPayload_success_family_count layout cost tokens rest out accepted,caps.2⟩ + +#print axioms cpuPayloadBeforeExit_work_literal_polynomial +#print axioms cpuPayload_work_literal_polynomial +#print axioms cpuPayload_resource +#print axioms cpuPayloadBeforeExit_success_family_count +#print axioms cpuPayload_success_family_count +#print axioms cpuPayloadBeforeExit_normalized +#print axioms cpuSliceLoop_work +#print axioms cpuRegisterLoop_work +#print axioms cpuPayloadBeforeExit_work_polynomial +#print axioms cpuPayloadBeforeExit_success_caps +#print axioms cpuPayload_work_polynomial +#print axioms cpuPayload_success_caps +end Whir.PCSBCSCallerPayloadCost diff --git a/verification/whir/Whir/PCSBCSCallerCPUPolynomialBoundSmoke.lean b/verification/whir/Whir/PCSBCSCallerCPUPolynomialBoundSmoke.lean new file mode 100644 index 000000000..dde59d516 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerCPUPolynomialBoundSmoke.lean @@ -0,0 +1,85 @@ +import Whir.PCSBCSCallerCPUPolynomialBound + +/-! Finite executable checks of the actual counted CPU path and source erasure. +The zero arithmetic fixtures are projections, not security or honest-proof claims. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCallerCPUPolynomialBoundSmoke +open Concrete FiatShamirGame AnchoredHeaderCodec +open WHIRCallerClaims hiding cpuPayload +open PCSBCSCallerPayloadCost + +local instance : Zero E := ⟨E.zero⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +private def require (label : String) (ok : Bool) : IO Unit := + unless ok do throw (IO.userError label) + +private def layout : CpuLayout := + ⟨⟨[],[],[⟨0,1,0⟩],0⟩,List.replicate 11 ⟨0,0,0,false,[],[]⟩, + #[.committed 0 6],[⟨0,6,7⟩],[⟨0,[0,1]⟩],0,(fun i => UInt64.ofNat i.val),1⟩ + +private def tokens (l : CpuLayout) : List CallerToken := + ((WHIRCallerClaims.callerShape (.cpu l)).drop (rootScalarCount (.cpu l))).map fun event => + match event with + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) + +private def costs : OutputCosts := + ⟨(fun i => i.val*i.val+3),(fun _ => 0),(fun _ => 0),(fun _ => 0)⟩ + +private def familyShape (rs : List RingPCSGame.FamilyClaim) : List (Nat × Array E) := + rs.map fun r => (r.offset,r.point) + +private def pointShape : RingPCSGame.PointClaim → Nat × Nat × Nat × Nat × Array E × E + | .point offset point value => (0,offset,0,0,point,value) + | .strided offset slot stride point value => (1,offset,slot,stride,point,value) + +private def checkFixture (label : String) (l : CpuLayout) (ts : List CallerToken) + (beforeAccept payloadAccept : Bool) : IO Unit := do + let before := cpuPayloadBeforeExit l ts + let paid := cpuPayload l costs ts + let base := cpuPayload l OutputCosts.zero ts + let source := WHIRCallerClaims.cpuPayload l ts + let volume := cpuLayoutVolume l + require (label ++ ": before-exit outcome") (before.result.isSome == beforeAccept) + require (label ++ ": payload outcome") (paid.result.isSome == payloadAccept) + require (label ++ ": actual before-exit polynomial") (decide (before.work ≤ cpuBeforeExitWork volume)) + let getterWork := ((outputGetterTrace l ts).map costs.call).sum + require (label ++ ": actual payload polynomial") + (decide (paid.work ≤ cpuPayloadWorkPolynomial volume+getterWork)) + require (label ++ ": reached arbitrary output prices") (paid.work == base.work+getterWork) + require (label ++ ": erasure outcome") (source.isSome == paid.result.isSome) + match paid.result,source with + | some ((rings,points),rest),some ((sourceRings,sourcePoints),sourceRest) => + require (label ++ ": erasure cursor and concrete claims") + (rest == sourceRest && familyShape rings == familyShape sourceRings && + points.toList.map pointShape == sourcePoints.toList.map pointShape) + require (label ++ ": exact actual family count") + (rings.length == l.flock.length+l.bus.producers.length+l.registers.length) + require (label ++ ": actual dimensions and cardinality") + ((rings.all fun r => decide (r.point.size ≤ volume)) && + decide (points.size ≤ 3*volume*volume+5) && + (points.toList.all fun p => decide (cpuPointDimension p ≤ volume+6))) + | none,none => pure () + | _,_ => throw (IO.userError (label ++ ": source/counter disagreement")) + +def smoke : IO Unit := do + let ts := tokens layout + checkFixture "valid producer and nested register" layout ts true true + checkFixture "valid retained suffix" layout (ts ++ [.sent 37]) true true + checkFixture "early invalid token" layout [] false false + checkFixture "mid invalid token" layout (ts.take (ts.length/2)) false false + checkFixture "late invalid token" layout (ts.take (ts.length-1)) false false + checkFixture "empty register early-return carrier" {layout with registers := [⟨0,[]⟩]} ts false false + checkFixture "nested register missing lookup" {layout with registers := [⟨0,[0,50]⟩]} ts false false + checkFixture "late placement rejection charges getters" {layout with placements := #[]} ts true false + let settledBad := {layout with tables := [⟨0,0,1,true,[0,0],[]⟩] ++ layout.tables.drop 1} + checkFixture "invalid settled layout" settledBad (tokens settledBad) false false + let producerBad := {layout with bus := {layout.bus with producers := [⟨0,65,0⟩]}} + checkFixture "producer padding rejects oversized evaluation" producerBad (tokens producerBad) false false + IO.println "CPU polynomial smoke: valid producer/register; early/mid/late token/layout rejection; both actual counters, source erasure, dimensions, exact family count and reached arbitrary output prices checked" + +end Whir.PCSBCSCallerCPUPolynomialBoundSmoke + +def main : IO Unit := Whir.PCSBCSCallerCPUPolynomialBoundSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSCallerCompletionCausality.lean b/verification/whir/Whir/PCSBCSCallerCompletionCausality.lean new file mode 100644 index 000000000..af86bb1f9 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerCompletionCausality.lean @@ -0,0 +1,413 @@ +import Whir.PCSBCSSourcePublicMetadata +import Whir.PCSBCSSourceCallerAnswers +import Whir.PublicCompressionCouplingPrefixTrace +import Whir.PublicCompressionCouplingTerminalUnique +import Whir.WHIRHeaderRoots + +/-! Old-history completion has a literal, source-cost-charged atomic execution. +Its prefix queries are primitive OTHER keys and its terminal query is a raw +OTHER key. This holds even when completion runs after the selected packet. +The actual primitive completion is also related to a concretely constructed +source table, not an externally supplied consistency certificate. That table +is a pushforward of a primitive oracle, NOT an independent uniform mixed table; +no distributional coupling or knowledge-extraction conclusion is asserted. -/ +set_option autoImplicit false +set_option backward.isDefEq.respectTransparency false +namespace Whir.PCSBCSCallerCompletionCausality +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler RawOracleCoupling PublicCompressionProgram +open PCSBCSChallengeOracle PublicCompressionCouplingMixed +open PCSStateRestoration.Latent +noncomputable local instance : DecidableEq Coordinate := Classical.decEq _ + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +abbrev Caller (packet : EnteredPacket p Q iv boundary) := + {q : Coordinate // q ∈ WHIRCallerOutputs.callerOutputs packet.1.val} + +theorem caller_admissible (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + DuplexEncoding.Admissible q.val := + WHIRCallerOutputs.callerOutputs_admissible _ packet.2.2.entryValid _ q.property + +theorem caller_bounded (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + pathCost q.val ≤ Q := + PCSBCSSourceCallerAnswers.caller_output_bounded packet q.val q.property + +theorem primitive_other (n : Node) : (part).recognize (.inl n) = none := by + cases hit : (part).recognize (.inl n) with + | none => rfl + | some block => + have impossible := (part).encode_recognize _ block hit + change Sum.inr _ = Sum.inl n at impossible + cases impossible + +def primitiveKey (n : Node) : Keys := .inr ⟨.inl n, primitive_other n⟩ +def terminalKey (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : Keys := + .inr ⟨.inr (constructionKey Q iv q.val (caller_bounded packet q)), + PCSBCSSourceCallerAnswers.caller_output_recognize_none packet.1.val + packet.1.property packet.2.2.entryValid q.val q.property (caller_bounded packet q)⟩ + +theorem join_primitive (table : Table Keys Answers) (n : Node) : + (part).join table (.inl n) = table (primitiveKey n) := by + unfold Partition.join + split + · next block hit => + have impossible := hit.symm.trans (primitive_other (p := p) (Q := Q) + (iv := iv) (boundary := boundary) n) + cases impossible + · rfl + +theorem join_terminal (table : Table Keys Answers) + (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + (part).join table (.inr (constructionKey Q iv q.val (caller_bounded packet q))) = + table (terminalKey packet q) := by + unfold Partition.join + split + · next block hit => + have impossible := hit.symm.trans + (PCSBCSSourceCallerAnswers.caller_output_recognize_none packet.1.val + packet.1.property packet.2.2.entryValid q.val q.property (caller_bounded packet q)) + cases impossible + · rfl + +/-- The source lowering of the actual compiler's literal primitive prefix. -/ +def sourceBody (cv : Digest32) : (xs : List DuplexEncoding.Instruction) → + Sampling Keys Answers (Digest32 × BodyLog) xs.length + | [] => .ret (cv,[]) + | i :: rest => .draw (primitiveKey ⟨cv,i.1,i.2,true⟩) (fun d => + Sampling.bind (sourceBody d rest) (fun result => + .ret (n := 0) (result.1,(⟨cv,i.1,i.2,true⟩,d)::result.2))) + +/-- Prefix and terminal are all real Sampling draws, not a table callback. -/ +def oldConstruction (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + Sampling Keys Answers InspectedConstruction (pathCost q.val) := + Sampling.pad (n := (DuplexEncoding.plan q.val).dropLast.length + 1) (by + have h := DuplexRawProgram.pathCost_pos q.val + simp only [List.length_dropLast] + unfold pathCost at h ⊢ + omega) + (Sampling.bind (sourceBody iv (DuplexEncoding.plan q.val).dropLast) + (fun body => .draw (terminalKey packet q) (fun d => + .ret ⟨q.val,caller_admissible packet q,d,body.1,body.2⟩))) + +theorem sourceBody_actual (table : Table Keys Answers) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + Sampling.eval table (sourceBody cv xs) = + Sampling.eval ((part).join table) (bodyCalls Q cv xs) := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => + simp only [sourceBody,Sampling.eval,Sampling.eval_bind,bodyCalls, + PublicCompressionCouplingMixed.Computation.eval_map,join_primitive,ih] + +theorem oldConstruction_actual (table : Table Keys Answers) + (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + Sampling.eval table (oldConstruction packet q) = + Sampling.eval ((part).join table) + (causalConstruction Q iv q.val (caller_admissible packet q) (caller_bounded packet q)) := by + simp only [oldConstruction,Sampling.eval_pad,Sampling.eval_bind,Sampling.eval, + causalConstruction_eval,sourceBody_actual,join_terminal] + +/-- Literal prefix nodes cannot be ANY selected source terminal, independently +of chaining-value collisions or when these completion draws are scheduled. -/ +theorem prefix_not_terminal (C : PrimitiveOracle) (packet : EnteredPacket p Q iv boundary) + (q : Caller packet) (n : Node) (d : Digest32) + (member : (n,d) ∈ (Sampling.eval (oracle C (fun _ => d)) + (bodyCalls Q iv (DuplexEncoding.plan q.val).dropLast)).2) + (terminal : Node) (selected : isTerminal terminal) : n ≠ terminal := by + rw [PublicCompressionCouplingRecognition.inspection_body_nodes Q C (fun _ => d) + iv q.val (caller_admissible packet q)] at member + obtain ⟨node,hn,he⟩ := List.mem_map.mp member + have equal : node = n := congrArg Prod.fst he + subst node + have body := (traceHistory_valid (compressionOf C) iv q.val.history + (caller_admissible packet q).1).1.body + intro equal + subst terminal + exact body_no_terminal body n (List.mem_reverse.mp hn) selected + +/-- Recognition of the complete literal body has exactly the old raw key. +This does not assume the public predecessor search found that body. -/ +theorem complete_body_other (C : PrimitiveOracle) + (packet : EnteredPacket p Q iv boundary) (q : Caller packet) + (key : RawKey Q) + (recognized : extract (coordinateTree (compressionOf C) iv q.val) = + some (expandKey key)) : + (part).recognize (.inr key) = none := by + have extracted := coordinateTree_key (compressionOf C) iv q.val (caller_admissible packet q) + have expanded : expandKey key = expandKey + (constructionKey Q iv q.val (caller_bounded packet q)) := by + rw [expand_constructionKey] + exact Option.some.inj (recognized.symm.trans extracted) + have same := PublicCompressionCouplingRecognition.expandKey_injective expanded + rw [same] + exact PCSBCSSourceCallerAnswers.caller_output_recognize_none packet.1.val + packet.1.property packet.2.2.entryValid q.val q.property (caller_bounded packet q) + +/-- All executions of the actual source prefix are unchanged, including their +physical nodes and full answers, when only the selected packet is replaced. -/ +theorem sourceBody_update (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (full : EnteredPacket.Block current → Digest32) + (cv : Digest32) (xs : List DuplexEncoding.Instruction) : + Sampling.execute (Function.update table (.inl current) full) (sourceBody cv xs) = + Sampling.execute table (sourceBody cv xs) := by + classical + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => + have changed : Function.update table (.inl current) full + (primitiveKey (p := p) (Q := Q) (iv := iv) (boundary := boundary) + ⟨cv,i.1,i.2,true⟩) = + table (primitiveKey ⟨cv,i.1,i.2,true⟩) := by simp [primitiveKey] + simp only [sourceBody,Sampling.execute,changed,Sampling.execute_bind, + ← Sampling.execute_value,ih] + + theorem oldConstruction_update (current packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (full : EnteredPacket.Block current → Digest32) + (q : Caller packet) : + Sampling.execute (Function.update table (.inl current) full) (oldConstruction packet q) = + Sampling.execute table (oldConstruction packet q) := by + classical + simp only [oldConstruction,Sampling.execute_pad,Sampling.execute_bind, + ← Sampling.execute_value,sourceBody_update] + simp [Sampling.execute,terminalKey] + +theorem sourceBody_count (table : Table Keys Answers) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + (Sampling.execute table (sourceBody cv xs)).2.length = xs.length := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => + simp [sourceBody,Sampling.execute,Sampling.execute_bind,ih] + +theorem oldConstruction_count (table : Table Keys Answers) + (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + (Sampling.execute table (oldConstruction packet q)).2.length = pathCost q.val := by + simp only [oldConstruction,Sampling.execute_pad,Sampling.execute_bind, + List.length_append,sourceBody_count,Sampling.execute,List.length_cons,List.length_nil, + List.length_dropLast] + have h := DuplexRawProgram.pathCost_pos q.val + unfold pathCost at h ⊢ + omega + +theorem sourceBody_trace_other (table : Table Keys Answers) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) (current : EnteredPacket p Q iv boundary) : + ∀ event ∈ (Sampling.execute table (sourceBody cv xs)).2, + event.1 ≠ .inl current := by + induction xs generalizing cv with + | nil => simp [sourceBody,Sampling.execute] + | cons i rest ih => + simp only [sourceBody,Sampling.execute,Sampling.execute_bind, + List.append_nil,List.mem_cons] + intro event member + rcases member with equal | member + · subst event + simp [primitiveKey] + · exact ih _ event member + +theorem oldConstruction_trace_other (table : Table Keys Answers) + (current packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + ∀ event ∈ (Sampling.execute table (oldConstruction packet q)).2, + event.1 ≠ .inl current := by + simp only [oldConstruction,Sampling.execute_pad,Sampling.execute_bind, + List.mem_append] + intro event member + rcases member with earlier | terminal + · exact sourceBody_trace_other table _ _ current event earlier + · simp only [Sampling.execute,List.mem_cons,List.not_mem_nil,or_false] at terminal + subst event + simp [terminalKey] + + theorem oldConstruction_answer (table : Table Keys Answers) + (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + (Sampling.eval table (oldConstruction packet q)).advertised = + PCSBCSSourceCallerAnswers.answers table q.val := by + rw [oldConstruction_actual,causalConstruction_eval] + exact (PCSBCSSourceCallerAnswers.answers_bounded table q.val + (caller_bounded packet q)).symm + +/-- The outside callback is never used for a requested coordinate after this +execution: each coordinate is overwritten with its genuinely sampled answer. +No initial/prefix availability is required. Duplicates are charged explicitly. -/ +noncomputable def atomicComplete (packet : EnteredPacket p Q iv boundary) + (outside : Coordinate → Digest32) : (requests : List (Caller packet)) → + Sampling Keys Answers (Coordinate → Digest32) + ((requests.map (fun q => pathCost q.val)).sum) + | [] => .ret outside + | q :: rest => Sampling.bind (oldConstruction packet q) (fun observed => + atomicComplete packet (Function.update outside q.val observed.advertised) rest) + +theorem atomicComplete_preserves (packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (requests : List (Caller packet)) (q : Caller packet) + (absent : q ∉ requests) (outside : Coordinate → Digest32) : + Sampling.eval table (atomicComplete packet outside requests) q.val = outside q.val := by + classical + induction requests generalizing outside with + | nil => rfl + | cons s rest ih => + simp only [atomicComplete,Sampling.eval_bind] + rw [ih (fun member => absent (List.mem_cons_of_mem _ member))] + apply Function.update_of_ne + intro equal + have same : q = s := Subtype.ext equal + subst s + exact absent List.mem_cons_self + + theorem atomicComplete_answers (packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (outside : Coordinate → Digest32) + (requests : List (Caller packet)) : + ∀ q ∈ requests, Sampling.eval table (atomicComplete packet outside requests) q.val = + PCSBCSSourceCallerAnswers.answers table q.val := by + classical + induction requests generalizing outside with + | nil => simp + | cons q rest ih => + simp only [atomicComplete,Sampling.eval_bind,oldConstruction_answer] + intro r member + by_cases later : r ∈ rest + · exact ih _ r later + · have equal : r = q := (List.mem_cons.mp member).resolve_right later + subst r + rw [atomicComplete_preserves packet table rest q later] + simp + + theorem atomicComplete_update (current packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (full : EnteredPacket.Block current → Digest32) + (outside : Coordinate → Digest32) (requests : List (Caller packet)) : + Sampling.execute (Function.update table (.inl current) full) + (atomicComplete packet outside requests) = + Sampling.execute table (atomicComplete packet outside requests) := by + induction requests generalizing outside with + | nil => rfl + | cons q rest ih => + simp only [atomicComplete,Sampling.execute_bind,← Sampling.execute_value, + oldConstruction_update,ih] + +theorem atomicComplete_count (packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (outside : Coordinate → Digest32) + (requests : List (Caller packet)) : + (Sampling.execute table (atomicComplete packet outside requests)).2.length = + (requests.map (fun q => pathCost q.val)).sum := by + induction requests generalizing outside with + | nil => rfl + | cons q rest ih => + simp only [atomicComplete,Sampling.execute_bind,List.length_append, + oldConstruction_count,ih,List.map_cons,List.sum_cons] + +theorem atomicComplete_trace_other (packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (outside : Coordinate → Digest32) + (requests : List (Caller packet)) (current : EnteredPacket p Q iv boundary) : + ∀ event ∈ (Sampling.execute table (atomicComplete packet outside requests)).2, + event.1 ≠ .inl current := by + induction requests generalizing outside with + | nil => simp [atomicComplete,Sampling.execute] + | cons q rest ih => + simp only [atomicComplete,Sampling.execute_bind,List.mem_append] + intro event member + rcases member with first | later + · exact oldConstruction_trace_other table current packet q event first + · exact ih _ event later + +theorem atomicCompletion_budget (packet : EnteredPacket p Q iv boundary) + (requests : List (Caller packet)) : + (requests.map (fun q => pathCost q.val)).sum ≤ Q * requests.length := by + induction requests with + | nil => simp + | cons q rest ih => + have bound := caller_bounded packet q + simp only [List.map_cons,List.sum_cons,List.length_cons,Nat.mul_add,Nat.mul_one] + omega + + theorem atomicComplete_draws_le (packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (outside : Coordinate → Digest32) + (requests : List (Caller packet)) : + (Sampling.execute table (atomicComplete packet outside requests)).2.length ≤ + (requests.map (fun q => pathCost q.val)).sum := + (Sampling.execute_runs table _).length_le + + theorem atomic_original (packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (outside : Coordinate → Digest32) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) : + PCSBCSSourceCallerOriginal.original p layout saved packet.1.val + (Sampling.eval table (atomicComplete packet outside + (WHIRCallerOutputs.callerOutputs packet.1.val).attach)) = + PCSBCSSourceCallerOriginal.original p layout saved packet.1.val + (PCSBCSSourceCallerAnswers.answers table) := by + apply PCSBCSSourceCallerOriginal.original_prior_only + intro q member + exact atomicComplete_answers packet table outside _ ⟨q,member⟩ (List.mem_attach _ _) + +/-- Canonical concrete relation: raw mode values are computed by C itself. +Garbage raw keys retain C's primitive seed value; no actual caller uses that +branch. This source table is deliberately not claimed uniformly distributed. -/ +def realMixed (C : PrimitiveOracle) (iv : Digest32) : Key Q → Digest32 + | .inl n => C n + | .inr raw => match WHIRHeaderRoots.decodeRaw iv raw with + | some q => evalCoordinate (compressionOf C) iv q + | none => C ⟨iv,ByteCodec.pairBytes (iv,iv),0,true⟩ + +noncomputable def realSourceTable (C : PrimitiveOracle) : Table Keys Answers := + (part).split (realMixed C iv) + + theorem realSource_answers (C : PrimitiveOracle) + (packet : EnteredPacket p Q iv boundary) (q : Caller packet) : + PCSBCSSourceCallerAnswers.answers + (realSourceTable (p := p) (Q := Q) (iv := iv) (boundary := boundary) C) q.val = + evalCoordinate (compressionOf C) iv q.val := by + rw [PCSBCSSourceCallerAnswers.answers_bounded _ _ (caller_bounded packet q)] + simp only [realSourceTable,Partition.join_split,realMixed, + WHIRHeaderRoots.decodeRaw_construction iv q.val (caller_admissible packet q) + (caller_bounded packet q)] + +/-- Real missing-output execution recovers the actual original source input +against the concrete source table, with no C/table certificate or availability +premise. Its additional draw cap is the sum of all literal caller path costs. -/ + theorem real_original (C : PrimitiveOracle) (packet : EnteredPacket p Q iv boundary) + (log : PublicMerkleLog.PublicLog) (auth : PublicMerkleLog.AuthenticLog C log) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (outside : Coordinate → Digest32) : + PCSBCSSourceCallerOriginal.original p layout saved packet.1.val + (PCSBCSPublicCallerCompletion.callerAnswers iv + (Sampling.execute C + (PCSBCSPublicCallerCompletion.callerCompletion iv log packet.1.val)).1 + packet.1.val + (PCSBCSPublicCallerCompletion.callerCompletion_total C iv log auth packet.1.val) + outside) = + PCSBCSSourceCallerOriginal.original p layout saved packet.1.val + (PCSBCSSourceCallerAnswers.answers + (realSourceTable (p := p) (Q := Q) (iv := iv) (boundary := boundary) C)) := by + rw [PCSBCSPublicCallerCompletion.original_resolved C iv log auth packet.1.val + p layout saved outside] + apply PCSBCSSourceCallerOriginal.original_prior_only + intro q member + exact (realSource_answers C packet ⟨q,member⟩).symm + +/-- Cached real completion may use fewer draws; it always stays under the +literal sum, including missing outputs first evaluated after the source query. -/ +theorem real_completion_draws (C : PrimitiveOracle) + (packet : EnteredPacket p Q iv boundary) (log : PublicMerkleLog.PublicLog) : + (Sampling.execute C + (PCSBCSPublicCallerCompletion.callerCompletion iv log packet.1.val)).2.length ≤ + ((WHIRCallerOutputs.callerOutputs packet.1.val).map pathCost).sum := + PCSBCSPublicCallerCompletion.complete_draws_le C iv log _ + +#print axioms prefix_not_terminal +#print axioms complete_body_other +#print axioms oldConstruction_actual +#print axioms oldConstruction_update +#print axioms atomicComplete_answers +#print axioms atomicComplete_update +#print axioms atomicComplete_draws_le +#print axioms atomic_original +#print axioms realSource_answers +#print axioms real_original +#print axioms atomicComplete_count +#print axioms atomicComplete_trace_other +#print axioms atomicCompletion_budget +#print axioms real_completion_draws +end Whir.PCSBCSCallerCompletionCausality diff --git a/verification/whir/Whir/PCSBCSCallerFlockPolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerFlockPolynomialBound.lean new file mode 100644 index 000000000..c29e3465b --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerFlockPolynomialBound.lean @@ -0,0 +1,420 @@ +import Whir.PCSBCSCallerParserPolynomialBound + +/-! Concrete Flock caller work, including malformed layouts and token rejection. +The additive size charges declared Nat literals by value, not their bit length. +The counter is the existing source-operation counter; delayed slice closures are +not evaluated here and retain `assembleFlockGetterWork` as their access price. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCallerParserCost +open Concrete WHIRCallerClaims +set_option maxRecDepth 8192 +set_option maxHeartbeats 1000000 + +private theorem bind_bound {A B : Type} (p : Parser A) (f : A → Parser B) + (ts : List CallerToken) (m n total : Nat) (sum : m+n ≤ total) + (hp : (p ts).work ≤ m) + (hf : ∀ a rest, (p ts).result = some (a,rest) → (f a rest).work ≤ n) : + ((p >>= f) ts).work ≤ total := (bind_work_le p f ts m n hp hf).trans sum + +private theorem tick_bound {A : Type} (n : Nat) (p : Parser A) + (ts : List CallerToken) (cap total : Nat) (sum : n+cap ≤ total) + (hp : (p ts).work ≤ cap) : + ((tick n >>= fun _ => p) ts).work ≤ total := by + rw [tick_bind_work] + exact (Nat.add_le_add_left hp n).trans sum + +local macro "flock_bind " m:term "," n:term : tactic => + `(tactic| (apply bind_bound _ _ _ $m $n; · omega)) +local macro "flock_tick " n:term : tactic => + `(tactic| (apply tick_bound _ _ _ $n; · first | (unfold lengthCost; omega) | omega)) + +/-- Placement, declared dimensions, derived round/point numerals, and a cell. -/ +def flockLayoutSize (l : FlockLayout) : Nat := + 1+l.offset+l.kLog+l.instanceLog+l.logN+(l.kLog-6)+(l.logN-6) + +/-- Additive literal configuration size, including the list spine. -/ +def flockConfigurationSize (ls : List FlockLayout) : Nat := + 1+ls.length+(ls.map flockLayoutSize).sum + +namespace FlockPolynomial + +theorem literal_le_sum (ls : List FlockLayout) (l : FlockLayout) (h : l ∈ ls) : + flockLayoutSize l ≤ (ls.map flockLayoutSize).sum := by + induction ls with + | nil => simp at h + | cons a ls ih => + simp only [List.mem_cons] at h + simp only [List.map_cons,List.sum_cons] + rcases h with rfl | h + · omega + · exact (ih h).trans (Nat.le_add_left _ _) + +theorem layout_caps (ls : List FlockLayout) (l : FlockLayout) (h : l ∈ ls) : + l.logN ≤ flockConfigurationSize ls ∧ + l.kLog-6 ≤ flockConfigurationSize ls ∧ + l.logN-6 ≤ flockConfigurationSize ls := by + have hs := literal_le_sum ls l h + have localCap : l.logN ≤ flockLayoutSize l ∧ l.kLog-6 ≤ flockLayoutSize l ∧ + l.logN-6 ≤ flockLayoutSize l := by unfold flockLayoutSize; omega + unfold flockConfigurationSize + omega + +theorem max_fold_le (xs : List Nat) (cap start : Nat) + (hs : start ≤ cap) (hx : ∀ x ∈ xs, x ≤ cap) : xs.foldl max start ≤ cap := by + induction xs generalizing start with + | nil => exact hs + | cons x xs ih => + apply ih (max start x) (max_le hs (hx x (by simp))) + intro y hy + exact hx y (by simp [hy]) + +theorem dimension_caps (ls : List FlockLayout) : + ls.length ≤ flockConfigurationSize ls ∧ + (ls.map FlockLayout.logN).foldl max 0 ≤ flockConfigurationSize ls ∧ + (ls.map (fun l => l.kLog-6)).foldl max 0 ≤ flockConfigurationSize ls := by + refine ⟨by unfold flockConfigurationSize; omega, ?_, ?_⟩ + · apply max_fold_le _ _ _ (Nat.zero_le _) + intro x hx + obtain ⟨l,hl,rfl⟩ := List.mem_map.mp hx + exact (layout_caps ls l hl).1 + · apply max_fold_le _ _ _ (Nat.zero_le _) + intro x hx + obtain ⟨l,hl,rfl⟩ := List.mem_map.mp hx + exact (layout_caps ls l hl).2.1 + +/-- Literal two-coefficient sumcheck round used twice by `flockClaims`. -/ +def round (_ : Nat) : Parser E := do + tick 2 + let _ ← readScalars 2 + drawScalar + +theorem round_work_le (i : Nat) (ts : List CallerToken) : (round i ts).work ≤ 26 := by + unfold round + rw [tick_bind_work] + have h := bind_work_le (readScalars 2) (fun _ => drawScalar) ts 20 4 + (readScalars_work_le 2 ts) (by intro values rest parsed; exact drawScalar_work_le rest) + omega + +theorem rounds_work_le (n : Nat) (ts : List CallerToken) : + ((List.range n).mapM round ts).work ≤ 26*n := by + simpa using mapM_work_le (List.range n) round 26 + (fun i _ rest => round_work_le i rest) ts + +/-- Both growing sampled-coordinate lists have the actual requested length. -/ +theorem rounds_success_length (n : Nat) (ts : List CallerToken) (point : List E) + (rest : List CallerToken) + (h : ((List.range n).mapM round ts).result = some (point,rest)) : + point.length = n := by + simpa using mapM_success_length (List.range n) round ts point rest h + +def produce (zc lc : List E) (layout : FlockLayout) : Parser RingPCSGame.FamilyClaim := do + tick 2 + let slices ← readScalars 64 + let _ ← readScalar + let assembled := assembleFlock layout zc lc slices + tick (assembled.work+1) + match assembled.value with + | some claim => pure claim + | none => liftOption 0 none + +theorem produce_work_le (zc lc : List E) (l : FlockLayout) (ts : List CallerToken) : + (produce zc lc l ts).work ≤ 9*lc.length+6*zc.length+679 := by + unfold produce + flock_tick (9*lc.length+6*zc.length+677) + flock_bind 578, (9*lc.length+6*zc.length+99) + · exact readScalars_work_le 64 ts + · intro slices rest parsed + have hs := readScalars_success_length 64 ts slices rest parsed + flock_bind 4, (9*lc.length+6*zc.length+95) + · exact readScalar_work_le rest + · intro unused tail parsed + rw [tick_bind_work] + have ha := assembleFlock_work_le l zc lc slices + cases (assembleFlock l zc lc slices).value <;> + simp only [pure,liftOption] <;> omega + +/-- The assembly success branch supplies its actual point and slices; no honest +metadata hypothesis is required. Accesses to the returned closure remain deferred. -/ +theorem assemble_success (l : FlockLayout) (zc lc slices : List E) + (claim : RingPCSGame.FamilyClaim) + (h : (assembleFlock l zc lc slices).value = some claim) : + slices.length = 64 ∧ claim.offset = l.offset ∧ claim.point.size = l.logN-6 ∧ + (∀ i : Fin 64, claim.slices i = slices[i.val]?.getD 0) := by + simp only [assembleFlock] at h + split at h + · simp at h + · rename_i valid + have hv : 6 ≤ l.kLog ∧ 13 ≤ l.logN ∧ l.kLog-6 ≤ lc.length ∧ + l.logN-6 ≤ zc.length := by + simp at valid + omega + split at h + · rename_i hs + cases h + refine ⟨hs,rfl,?_,?_⟩ + · simp only [List.size_toArray,List.length_append,List.length_reverse, + List.length_take,List.length_drop,FlockLayout.logN] at * + omega + · intro i + have hi : i.val < slices.length := by rw [hs]; exact i.isLt + simp only [List.getElem?_eq_getElem hi,Option.getD_some] + · simp at h + +/-- Success elimination for the actual counted bind, retaining intermediate values. -/ +theorem bind_success {A B : Type} (p : Parser A) (f : A → Parser B) + (ts : List CallerToken) (v : B) (rest : List CallerToken) + (h : ((p >>= f) ts).result = some (v,rest)) : + ∃ a middle, (p ts).result = some (a,middle) ∧ + (f a middle).result = some (v,rest) := by + change (bind p f ts).result = _ at h + unfold bind at h + cases hp : (p ts).result with + | none => simp [hp] at h + | some pair => + rcases pair with ⟨a,middle⟩ + exact ⟨a,middle,rfl,by simpa only [hp] using h⟩ + +end FlockPolynomial + +/-- No token or metadata admissibility premise: failed prefixes are charged too. -/ +theorem flockClaims_work_le (ls : List FlockLayout) (ts : List CallerToken) : + (flockClaims ls ts).work ≤ + 20*(flockConfigurationSize ls)^2+800*flockConfigurationSize ls+700 := by + let s := flockConfigurationSize ls + let m := (ls.map FlockLayout.logN).foldl max 0 + let r := (ls.map (fun l => l.kLog-6)).foldl max 0 + have caps := FlockPolynomial.dimension_caps ls + have hn : ls.length ≤ s := caps.1 + have hm : m ≤ s := caps.2.1 + have hr : r ≤ s := caps.2.2 + have header : (3+if ls.isEmpty then 0 else + allCost (fun l => 6 ≤ l.kLog && 13 ≤ l.logN) + (fun l => if 6 ≤ l.kLog then 4 else 2) ls) ≤ 5*ls.length+4 := by + have h := allCost_le (fun l : FlockLayout => 6 ≤ l.kLog && 13 ≤ l.logN) + (fun l => if 6 ≤ l.kLog then 4 else 2) ls 4 + (by intro l hl; split <;> omega) + split <;> omega + unfold flockClaims + change _ ≤ 20*s^2+800*s+700 + flock_tick (20*s^2+795*s+696) + flock_bind 3, (20*s^2+795*s+693) + · exact check_work_le _ ts + · intro unused rest parsed + flock_tick (20*s^2+785*s+687) + flock_bind (9*s+2), (20*s^2+776*s+685) + · exact (drawScalars_work_le _ rest).trans (by omega) + · intro values rest parsed + flock_bind 4, (20*s^2+776*s+681) + · exact drawScalar_work_le rest + · intro unused rest parsed + flock_bind 578, (20*s^2+776*s+103) + · exact readScalars_work_le 64 rest + · intro values rest parsed + flock_bind 4, (20*s^2+776*s+99) + · exact drawScalar_work_le rest + · intro unused rest parsed + flock_tick (20*s^2+774*s+96) + flock_bind (26*s), (20*s^2+748*s+96) + · exact (FlockPolynomial.rounds_work_le _ rest).trans + (Nat.mul_le_mul_left 26 (by omega)) + · intro zc rest parsed + have hz : zc.length ≤ s := by + have h := mapM_success_length (List.range (m-6)) FlockPolynomial.round _ zc _ parsed + simp only [List.length_range] at h + omega + flock_tick (20*s^2+747*s+94) + flock_bind (27*s+2), (20*s^2+720*s+92) + · exact (readScalars_work_le _ rest).trans (by omega) + · intro values rest parsed + flock_bind 4, (20*s^2+720*s+88) + · exact drawScalar_work_le rest + · intro unused rest parsed + flock_tick (20*s^2+718*s+86) + flock_bind (26*s), (20*s^2+692*s+86) + · exact (FlockPolynomial.rounds_work_le _ rest).trans + (Nat.mul_le_mul_left 26 hr) + · intro lc rest parsed + have hl : lc.length ≤ s := by + have h := mapM_success_length (List.range r) FlockPolynomial.round _ lc _ parsed + simp only [List.length_range] at h + omega + have bound := mapM_work_le ls (FlockPolynomial.produce zc lc) (15*s+679) + (by intro l _ tail; have h := FlockPolynomial.produce_work_le zc lc l tail; omega) rest + have mul := Nat.mul_le_mul_left (15*s+679) hn + change ((ls.mapM (FlockPolynomial.produce zc lc)) rest).work ≤ + 20*s^2+692*s+86 + simp only [pow_two] + nlinarith + +namespace FlockPolynomial + +theorem produce_success (zc lc : List E) (l : FlockLayout) (ts rest : List CallerToken) + (claim : RingPCSGame.FamilyClaim) (h : (produce zc lc l ts).result = some (claim,rest)) : + ∃ slices : List E, slices.length = 64 ∧ + (assembleFlock l zc lc slices).value = some claim := by + unfold produce at h + obtain ⟨_,t0,_,h0⟩ := bind_success _ _ _ _ _ h + obtain ⟨slices,t1,hs,h1⟩ := bind_success _ _ _ _ _ h0 + obtain ⟨_,t2,_,h2⟩ := bind_success _ _ _ _ _ h1 + obtain ⟨_,t3,_,h3⟩ := bind_success _ _ _ _ _ h2 + have length := readScalars_success_length 64 t0 slices t1 hs + cases ha : (assembleFlock l zc lc slices).value with + | none => simp only [ha,liftOption,Option.map_none] at h3; cases h3 + | some value => + simp only [ha,pure,Option.some.injEq,Prod.mk.injEq] at h3 + rcases h3 with ⟨rfl,_⟩ + exact ⟨slices,length,ha⟩ + +theorem mapM_success_related {A B : Type} (xs : List A) (f : A → Parser B) + (R : A → B → Prop) + (body : ∀ a ∈ xs, ∀ ts v rest, (f a ts).result = some (v,rest) → R a v) + (ts : List CallerToken) (ys : List B) (rest : List CallerToken) + (h : (xs.mapM f ts).result = some (ys,rest)) : + ∀ y ∈ ys, ∃ x ∈ xs, R x y := by + induction xs generalizing ts ys rest with + | nil => + change some ([],ts) = some (ys,rest) at h + cases h + simp + | cons x xs ih => + rw [List.mapM_cons] at h + obtain ⟨y,middle,hy,ht⟩ := bind_success _ _ _ _ _ h + obtain ⟨tail,remaining,htail,hfinal⟩ := bind_success _ _ _ _ _ ht + change some (y::tail,remaining) = some (ys,rest) at hfinal + cases hfinal + have head := body x (by simp) ts y middle hy + have later := ih (fun a ha => body a (by simp [ha])) middle tail rest htail + intro value member + simp only [List.mem_cons] at member + rcases member with rfl | member + · exact ⟨x,by simp,head⟩ + · obtain ⟨a,ha,hr⟩ := later value member + exact ⟨a,by simp [ha],hr⟩ + +theorem producer_outputs (ls : List FlockLayout) (zc lc : List E) + (ts : List CallerToken) (claims : List RingPCSGame.FamilyClaim) + (rest : List CallerToken) + (h : (ls.mapM (produce zc lc) ts).result = some (claims,rest)) : + claims.length = ls.length ∧ + ∀ c ∈ claims, ∃ l ∈ ls, c.offset = l.offset ∧ c.point.size = l.logN-6 := by + refine ⟨mapM_success_length ls _ ts claims rest h, ?_⟩ + apply mapM_success_related ls (produce zc lc) + (fun l c => c.offset = l.offset ∧ c.point.size = l.logN-6) _ ts claims rest h + intro l _ tokens c tail accepted + obtain ⟨slices,_,assembled⟩ := produce_success zc lc l tokens tail c accepted + have shape := assemble_success l zc lc slices c assembled + exact ⟨shape.2.1,shape.2.2.1⟩ + +end FlockPolynomial + +/-- Exact producer cardinality and actual returned ring dimensions, even when +the accepted metadata differs from any intended honest configuration. -/ +theorem flockClaims_success_layouts (ls : List FlockLayout) (ts : List CallerToken) + (claims : List RingPCSGame.FamilyClaim) (rest : List CallerToken) + (accepted : (flockClaims ls ts).result = some (claims,rest)) : + claims.length = ls.length ∧ + ∀ c ∈ claims, ∃ l ∈ ls, c.offset = l.offset ∧ c.point.size = l.logN-6 := by + unfold flockClaims at accepted + repeat' (obtain ⟨value,middle,_,accepted⟩ := + FlockPolynomial.bind_success _ _ _ _ _ accepted) + exact FlockPolynomial.producer_outputs ls _ _ _ _ _ accepted + +/-- Parent-composable resource endpoint: additive literal size, quadratic work, +exact producer count, and a size cap for each actually returned point. -/ +theorem flockClaims_resource (ls : List FlockLayout) (ts : List CallerToken) : + (flockClaims ls ts).work ≤ + 20*(flockConfigurationSize ls)^2+800*flockConfigurationSize ls+700 ∧ + ∀ claims rest, (flockClaims ls ts).result = some (claims,rest) → + claims.length = ls.length ∧ + ∀ c ∈ claims, c.point.size ≤ flockConfigurationSize ls := by + refine ⟨flockClaims_work_le ls ts,?_⟩ + intro claims rest accepted + have shape := flockClaims_success_layouts ls ts claims rest accepted + refine ⟨shape.1,?_⟩ + intro c hc + obtain ⟨l,hl,_,point⟩ := shape.2 c hc + rw [point] + exact (FlockPolynomial.layout_caps ls l hl).2.2 + +/-! Persistent kernel smoke on the changed proof path. Erasure equates the +actual counted accepted/rejected result with the source interpreter. -/ +namespace FlockPolynomial.Smoke + +theorem accepted_counted_source : + ∃ claims, (flockClaims [⟨0,6,7⟩] PCSBCSCallerParserCost.Smoke.flockTokens).result = + some (claims,[]) ∧ + WHIRCallerClaims.flockClaims [⟨0,6,7⟩] PCSBCSCallerParserCost.Smoke.flockTokens = + some (claims,[]) ∧ claims.length = 1 ∧ + ∀ c ∈ claims, c.point.size = 7 := by + obtain ⟨claims,h⟩ := PCSBCSCallerParserCost.Smoke.minimal_flock_accepts + have shape := flockClaims_success_layouts [⟨0,6,7⟩] _ claims [] h + refine ⟨claims,h,?_,shape.1,?_⟩ + · change erase (flockClaims _) _ = _ at h + rwa [flockClaims_erasure] at h + · intro c hc + obtain ⟨l,hl,_,point⟩ := shape.2 c hc + simp only [List.mem_singleton] at hl + subst l + exact point + +theorem rejected_counted_source : + (flockClaims [⟨0,5,10⟩] []).result = none ∧ + WHIRCallerClaims.flockClaims [⟨0,5,10⟩] [] = none ∧ + (flockClaims [⟨0,5,10⟩] []).work ≤ + 20*(flockConfigurationSize [⟨0,5,10⟩])^2+ + 800*flockConfigurationSize [⟨0,5,10⟩]+700 := by + exact ⟨rfl,rfl,flockClaims_work_le _ _⟩ + +theorem token_rejection_counted_source : + (flockClaims [⟨0,6,7⟩] [.sent 0]).result = none ∧ + WHIRCallerClaims.flockClaims [⟨0,6,7⟩] [.sent 0] = none ∧ + 0 < (flockClaims [⟨0,6,7⟩] [.sent 0]).work := by + constructor + · rfl + constructor + · rfl + · decide + +def mixedLayouts : List FlockLayout := [⟨0,6,7⟩,⟨64,7,7⟩] + +def mixedTokens : List CallerToken := + List.replicate 2 (.draw 0) ++ List.replicate 64 (.sent 0) ++ [.draw 0] ++ + (List.replicate 8 [.sent 0,.sent 0,.draw 0]).flatten ++ + List.replicate 6 (.sent 0) ++ [.draw 0] ++ [.sent 0,.sent 0,.draw 0] ++ + List.replicate 130 (.sent 0) + +/-- Two unequal dimensions, nonempty lincheck, eight zerocheck coordinates, and +two separately consumed 64-slice blocks exercise the actual producer path. -/ +theorem mixed_accepted_counted : + ((flockClaims mixedLayouts mixedTokens).result.map + (fun (claims,rest) => (claims.map (fun c => (c.offset,c.point.size)),rest))) = + some ([(0,7),(64,8)],[]) := by rfl + +theorem mixed_accepted_source : + ((WHIRCallerClaims.flockClaims mixedLayouts mixedTokens).map + (fun (claims,rest) => (claims.map (fun c => (c.offset,c.point.size)),rest))) = + some ([(0,7),(64,8)],[]) := by + rw [← flockClaims_erasure] + exact mixed_accepted_counted + +theorem mixed_accepted_work : + (flockClaims mixedLayouts mixedTokens).work ≤ + 20*(flockConfigurationSize mixedLayouts)^2+ + 800*flockConfigurationSize mixedLayouts+700 := flockClaims_work_le _ _ + +theorem malformed_assembly_rejected : + (assembleFlock ⟨0,7,7⟩ (List.replicate 8 0) [] (List.replicate 64 0)).value = none ∧ + (assembleFlock ⟨0,6,7⟩ (List.replicate 7 0) [] (List.replicate 63 0)).value = none := by + constructor <;> rfl + +end FlockPolynomial.Smoke + +#print axioms flockClaims_resource +#print axioms flockClaims_success_layouts +#print axioms FlockPolynomial.Smoke.accepted_counted_source +#print axioms FlockPolynomial.Smoke.rejected_counted_source +#print axioms flockClaims_work_le +#print axioms FlockPolynomial.assemble_success +#print axioms FlockPolynomial.Smoke.mixed_accepted_counted +#print axioms FlockPolynomial.Smoke.mixed_accepted_source +end Whir.PCSBCSCallerParserCost diff --git a/verification/whir/Whir/PCSBCSCallerFlockPolynomialBoundSmoke.lean b/verification/whir/Whir/PCSBCSCallerFlockPolynomialBoundSmoke.lean new file mode 100644 index 000000000..8eee14e90 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerFlockPolynomialBoundSmoke.lean @@ -0,0 +1,100 @@ +import Whir.PCSBCSCallerFlockPolynomialBound + +/-! Executable counted/source Flock projection fixtures. Arithmetic messages are +not honest proof witnesses: these tests check actual parser and claim assembly, +not sumcheck validity or cryptographic security. -/ +namespace Whir.PCSBCSCallerFlockPolynomialBoundSmoke +open Concrete WHIRCallerClaims PCSBCSCallerParserCost + +private def require (label : String) (ok : Bool) : IO Unit := + unless ok do throw (IO.userError label) + +private def scalar (n : Nat) : E := E.ofK (UInt64.ofNat n) + +private def layouts : List FlockLayout := [⟨0,6,7⟩,⟨64,8,7⟩] + +private def slices (base : Nat) : List E := (List.range 64).map (fun i => scalar (base+i)) + +private def prelude : List CallerToken := + List.replicate 3 (.draw 0) ++ List.replicate 64 (.sent 0) ++ [.draw 0] + +private def zcTokens : List CallerToken := + ((List.range 9).map (fun i => [.sent 0,.sent 0,.draw (scalar (10+i))])).flatten + +private def fixture : List CallerToken := + prelude ++ zcTokens ++ List.replicate 6 (.sent 0) ++ [.draw 0] ++ + [.sent 0,.sent 0,.draw (scalar 40),.sent 0,.sent 0,.draw (scalar 41)] ++ + (slices 100).map CallerToken.sent ++ [.sent 0] ++ + (slices 200).map CallerToken.sent ++ [.sent 0] + +private def project (claims : List RingPCSGame.FamilyClaim) : + List (Nat × List E × List E) := + claims.map (fun c => (c.offset,c.point.toList,(List.finRange 64).map c.slices)) + +private def cap (ls : List FlockLayout) : Nat := + let s := flockConfigurationSize ls + 20*s^2+800*s+700 + +private def rejected (label : String) (ls : List FlockLayout) (tokens : List CallerToken) : IO Unit := do + let counted := PCSBCSCallerParserCost.flockClaims ls tokens + require (label ++ ": counted rejects") counted.result.isNone + require (label ++ ": source rejects") (WHIRCallerClaims.flockClaims ls tokens).isNone + require (label ++ ": rejection work remains bounded") (counted.work ≤ cap ls) + require (label ++ ": reached work is retained") (0 < counted.work) + +def smoke : IO Unit := do + let suffix := [CallerToken.sent (scalar 777)] + let counted := PCSBCSCallerParserCost.flockClaims layouts (fixture ++ suffix) + let source := WHIRCallerClaims.flockClaims layouts (fixture ++ suffix) + let expected : List (Nat × List E × List E) := + [(0,(List.range 7).map (fun i => scalar (10+i)),slices 100), + (64,[scalar 41,scalar 40] ++ (List.range 7).map (fun i => scalar (12+i)),slices 200)] + require "mixed counted claims preserve exact reverse/suffix points, slice blocks, offsets, and rest" + (match counted.result with + | some (claims,rest) => project claims == expected && rest == suffix + | none => false) + require "mixed source claims preserve exact reverse/suffix points, slice blocks, offsets, and rest" + (match source with + | some (claims,rest) => project claims == expected && rest == suffix + | none => false) + require "all accepted actual work is bounded by additive literal configuration size" + (counted.work ≤ cap layouts) + require "accepted producer count and unequal point dimensions are actual returned values" + (match counted.result with + | some (claims,_) => claims.length == 2 && claims.map (fun c => c.point.size) == [7,9] + | none => false) + rejected "empty layouts" [] fixture + rejected "kLog below six" [⟨0,5,10⟩] fixture + rejected "logN below thirteen" [⟨0,6,6⟩] fixture + rejected "wrong initial challenge token" layouts [.sent 0] + rejected "zerocheck rejects wrong challenge after reading both coefficients" layouts + (prelude ++ [.sent 0,.sent 0,.sent 0]) + rejected "truncated final producer slice block" layouts (fixture.take (fixture.length-2)) + let early := PCSBCSCallerParserCost.flockClaims layouts [.sent 0] + let late := PCSBCSCallerParserCost.flockClaims layouts (fixture.take (fixture.length-2)) + require "late failure retains strictly more work than prelude failure" (early.work < late.work) + let zc := (List.range 9).map (fun i => scalar (10+i)) + let lc := [scalar 40,scalar 41] + let assembled := PCSBCSCallerParserCost.assembleFlock ⟨64,8,7⟩ zc lc (slices 200) + require "per-layout actual assembly returns exact dimensions and endpoint slices" + (match assembled.value with + | some c => c.point.toList == expected[1]!.2.1 && + c.slices ⟨0,by decide⟩ == scalar 200 && c.slices ⟨63,by decide⟩ == scalar 263 + | none => false) + require "per-layout actual assembly counter satisfies its linear bound" + (assembled.work ≤ 9*lc.length+6*zc.length+(slices 200).length+30) + require "short lincheck metadata rejected by actual assembly" + (PCSBCSCallerParserCost.assembleFlock ⟨64,8,7⟩ zc [scalar 40] (slices 200)).value.isNone + require "short zerocheck metadata rejected by actual assembly" + (PCSBCSCallerParserCost.assembleFlock ⟨64,8,7⟩ (zc.take 8) lc (slices 200)).value.isNone + require "63-slice block rejected by actual assembly" + (PCSBCSCallerParserCost.assembleFlock ⟨64,8,7⟩ zc lc ((slices 200).take 63)).value.isNone + require "65-slice block rejected by actual assembly" + (PCSBCSCallerParserCost.assembleFlock ⟨64,8,7⟩ zc lc (slices 200 ++ [scalar 264])).value.isNone + require "deferred getter boundary prices remain separate from assembly" + (assembleFlockGetterWork ⟨0,by decide⟩ == 2 && assembleFlockGetterWork ⟨63,by decide⟩ == 65) + IO.println s!"counted/source flock runtime passed: accepted work={counted.work}, early rejection work={early.work}, late rejection work={late.work}, assembly work={assembled.work}, polynomial cap={cap layouts}" + +end Whir.PCSBCSCallerFlockPolynomialBoundSmoke + +def main : IO Unit := Whir.PCSBCSCallerFlockPolynomialBoundSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSCallerGKRPolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerGKRPolynomialBound.lean new file mode 100644 index 000000000..316ab0fda --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerGKRPolynomialBound.lean @@ -0,0 +1,163 @@ +import Whir.PCSBCSCallerParserPolynomialBound + +/-! Work and actual returned-point cardinality for the counted, factored source +GKR interpreter. Bounds include rejection and every visited nested round. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 +namespace Whir.PCSBCSCallerParserCost +open Concrete WHIRCallerClaims + +private theorem tick_result {A : Type} (n : Nat) (next : Unit → Parser A) + (tokens : List CallerToken) : + ((tick n >>= next) tokens).result = (next () tokens).result := rfl + +private theorem accepted_bind {A B : Type} (before : Parser A) (next : A → Parser B) + (tokens rest : List CallerToken) (output : B) + (accepted : ((before >>= next) tokens).result = some (output,rest)) : + ∃ value middle, (before tokens).result = some (value,middle) ∧ + (next value middle).result = some (output,rest) := + (bind_success_iff before next tokens output rest).mp accepted + +theorem gkrSeed_work_le (mu : Nat) (tokens : List CallerToken) : + (gkrSeed mu tokens).work ≤ 47 := by + unfold gkrSeed + split + · apply bind_work_le (readScalars 4) _ tokens 38 9 (readScalars_work_le 4 tokens) + intro _ tail _ + apply bind_work_le drawScalar _ tail 4 5 (drawScalar_work_le tail) + intro _ tail _ + apply bind_work_le drawScalar _ tail 4 1 (drawScalar_work_le tail) + intro _ tail _ + rw [tick_bind_work] + exact Nat.le_refl _ + · exact Nat.zero_le _ + +theorem gkrSeed_success_length (mu : Nat) (tokens : List CallerToken) + (point : List E) (rest : List CallerToken) + (accepted : (gkrSeed mu tokens).result = some (point,rest)) : + point.length = mu%2 := by + unfold gkrSeed at accepted + split at accepted + · next odd => + obtain ⟨_,middle,_,accepted⟩ := accepted_bind _ _ _ _ _ accepted + obtain ⟨x,middle,_,accepted⟩ := accepted_bind _ _ _ _ _ accepted + obtain ⟨_,middle,_,accepted⟩ := accepted_bind _ _ _ _ _ accepted + simp only [tick_result,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + simpa using odd.symm + · next even => + change some ([],tokens) = some (point,rest) at accepted + cases accepted + have small := Nat.mod_lt mu (by decide : 0<2) + simp only [List.length_nil] + omega + +private def gkrStep (_ : Nat) (point : List E) : Parser (ForInStep (List E)) := do + let next ← gkrRound point + pure (.yield next) + +private theorem gkrStep_work_le (i : Nat) (point : List E) (tokens : List CallerToken) : + (gkrStep i point tokens).work ≤ 47*point.length+93 := by + unfold gkrStep + simpa only [Nat.add_zero] using bind_work_le (gkrRound point) _ tokens + (47*point.length+93) 0 (gkrRound_work_le point tokens) + (by intro _ tail _; exact Nat.le_refl _) + +private theorem gkrStep_success (i : Nat) (point : List E) (tokens rest : List CallerToken) + (step : ForInStep (List E)) + (accepted : (gkrStep i point tokens).result = some (step,rest)) : + ∃ next, step = .yield next ∧ next.length = point.length+2 := by + unfold gkrStep at accepted + obtain ⟨next,middle,roundRead,accepted⟩ := accepted_bind _ _ _ _ _ accepted + have length := gkrRound_success_length point tokens next middle roundRead + change some (.yield next,middle) = some (step,rest) at accepted + cases accepted + exact ⟨next,rfl,length⟩ + +private theorem gkrLoop_success_length (xs : List Nat) (initial final : List E) + (tokens rest : List CallerToken) + (accepted : (forIn xs initial gkrStep tokens).result = some (final,rest)) : + final.length = initial.length+2*xs.length := by + induction xs generalizing initial tokens with + | nil => + simp only [List.forIn_nil] at accepted + change some (initial,tokens) = some (final,rest) at accepted + cases accepted + simp + | cons i xs ih => + rw [List.forIn_cons] at accepted + obtain ⟨step,middle,first,accepted⟩ := accepted_bind _ _ _ _ _ accepted + obtain ⟨next,rfl,growth⟩ := gkrStep_success i initial tokens middle step first + have tail := ih next middle accepted + simp only [List.length_cons,Nat.mul_add,Nat.mul_one] + omega + +private theorem gkrLoop_work_le (n : Nat) (initial : List E) (tokens : List CallerToken) + (seed : initial.length ≤ 1) : + (forIn (List.range n) initial gkrStep tokens).work ≤ n*(47*(1+2*n)+93) := by + have bound := forIn_growth_work_le (List.range n) initial gkrStep List.length 47 93 2 + (by intro i _ point ts; exact gkrStep_work_le i point ts) + (by + intro i _ point ts step rest accepted + obtain ⟨next,rfl,growth⟩ := gkrStep_success i point ts rest step accepted + simp only [iterationState] + omega) tokens + simp only [List.length_range] at bound + exact bound.trans (Nat.mul_le_mul_left n (by omega)) + +/-- Unconditional work bound: failures retain only their executed prefix. -/ +theorem gkrPoint_work_le (mu : Nat) (tokens : List CallerToken) : + (gkrPoint mu tokens).work ≤ 94*mu^2+142*mu+62 := by + have half := Nat.div_le_self mu 2 + have square := Nat.mul_self_le_mul_self half + unfold gkrPoint + apply Nat.le_trans + · apply bind_work_le + · exact readScalar_work_le _ + · intro _ tail _ + apply bind_work_le + · exact drawScalar_work_le _ + · intro _ tail _ + apply bind_work_le + · exact Nat.le_refl _ + · intro _ tail _ + apply bind_work_le + · exact gkrSeed_work_le _ _ + · intro seed tail parsed + have length := gkrSeed_success_length mu _ seed _ parsed + have small := Nat.mod_lt mu (by decide : 0<2) + apply bind_work_le + · exact Nat.le_refl _ + · intro _ tail _ + apply bind_work_le + · exact gkrLoop_work_le (mu/2) seed tail (by omega) + · intro _ tail _ + rw [tick_bind_work] + exact Nat.le_refl _ + · nlinarith + +/-- Exact length comes from the visited radix-four rounds and parity seed. -/ +theorem gkrPoint_success_length (mu : Nat) (tokens : List CallerToken) + (point : List E) (rest : List CallerToken) + (accepted : (gkrPoint mu tokens).result = some (point,rest)) : + point.length = mu := by + unfold gkrPoint at accepted + obtain ⟨_,middle,_,accepted⟩ := accepted_bind _ _ _ _ _ accepted + obtain ⟨_,middle,_,accepted⟩ := accepted_bind _ _ _ _ _ accepted + simp only [tick_result] at accepted + obtain ⟨seed,middle,seedRead,accepted⟩ := accepted_bind _ _ _ _ _ accepted + have seedLength := gkrSeed_success_length mu _ seed _ seedRead + simp only [tick_result] at accepted + obtain ⟨final,middle,loopRead,accepted⟩ := accepted_bind _ _ _ _ _ accepted + have finalLength := gkrLoop_success_length (List.range (mu/2)) seed final _ _ loopRead + simp only [tick_result,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + simp only [List.length_range] at finalLength + omega + +#print axioms gkrSeed_work_le +#print axioms gkrSeed_success_length +#print axioms gkrPoint_work_le +#print axioms gkrPoint_success_length +end Whir.PCSBCSCallerParserCost diff --git a/verification/whir/Whir/PCSBCSCallerParserCost.lean b/verification/whir/Whir/PCSBCSCallerParserCost.lean new file mode 100644 index 000000000..a629e6fa9 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerParserCost.lean @@ -0,0 +1,958 @@ +import Whir.WHIRCallerSource + +/-! Source-operation accounting, not CPU timing. One unit is a constructor, +branch, fixed-width field operation, or Nat arithmetic operation. List scans +pay one per visited cell plus their terminal test; allocating a list pays one +per cell. Array lookup pays its bounds test and lookup. Powers and logarithms +use the explicit multiplication/division recurrences below, rather than an +opaque primitive-work hypothesis. Field operations are fixed-width source +operations, not machine instructions. The administrative machinery of the +cost monad (including `pure`, `bind`, and the instrumentation itself) is not a +source operation; source constructors and branches are charged by `tick`. +Delayed ring-value functions have separate per-access charges: constructing +a closure does not execute its body. Failure retains the visited-prefix work. +Literal local charges account for fixed source expressions, not a reservation +for an entire parser. List-size charges are traversals, not unit-cost calls. -/ +namespace Whir.PCSBCSCallerParserCost +open Concrete WHIRCallerClaims + +structure Run (A : Type) where + result : Option (A × List CallerToken) + work : Nat + +abbrev Parser (A : Type) := List CallerToken → Run A + + def pure {A : Type} (a : A) : Parser A := fun ts => ⟨some (a,ts),0⟩ + def bind {A B : Type} (p : Parser A) (f : A → Parser B) : Parser B := fun ts => + let r := p ts + match r.result with + | none => ⟨none,r.work⟩ + | some (a,rest) => let s := f a rest; ⟨s.result,r.work+s.work⟩ +instance : Monad Parser where + pure := pure + bind := bind + +instance : LawfulMonad Parser := by + refine LawfulMonad.mk' Parser ?_ ?_ ?_ + · intro A p + funext ts + change bind p (fun a => pure (id a)) ts = p ts + simp only [bind] + cases h : p ts with + | mk result work => cases result with + | none => rfl + | some v => cases v; simp [pure] + · intro A B a f + funext ts + change bind (pure a) f ts = f a ts + simp [bind,pure] + · intro A B C p f g + funext ts + change bind (bind p f) g ts = bind p (fun a => bind (f a) g) ts + simp only [bind] + cases hr : (p ts).result with + | none => rfl + | some v => + rcases v with ⟨a,rest⟩ + cases hs : (f a rest).result with + | none => simp [hs] + | some w => rcases w with ⟨b,tail⟩; simp [hs,Nat.add_assoc] + + def erase {A : Type} (p : Parser A) : CallerParser A := fun ts => (p ts).result +@[simp] theorem erase_pure {A : Type} (a : A) : erase (Pure.pure a : Parser A) = Pure.pure a := rfl +@[simp] theorem pure_erasure {A : Type} (a : A) : erase (pure a) = Pure.pure a := rfl +@[simp] theorem erase_bind {A B : Type} (p : Parser A) (f : A → Parser B) : + erase (p >>= f) = erase p >>= fun a => erase (f a) := by + funext ts + change (match (p ts).result with + | none => (⟨none,(p ts).work⟩ : Run B) + | some (a,rest) => ⟨(f a rest).result,(p ts).work+(f a rest).work⟩).result = + (p ts).result.bind (fun (a,rest) => (f a rest).result) + cases (p ts).result with + | none => rfl + | some v => cases v; rfl + +@[simp] theorem erase_map {A B : Type} (f : A → B) (p : Parser A) : + erase (f <$> p) = f <$> erase p := by + simp only [← bind_pure_comp,erase_bind,erase_pure] +@[simp] theorem erase_ite {A : Type} (q : Prop) [Decidable q] (p r : Parser A) : + erase (if q then p else r) = if q then erase p else erase r := by + split <;> rfl +@[simp] theorem erase_option_match {A B : Type} (x : Option A) (p : Parser B) + (f : A → Parser B) : + erase (match x with | none => p | some a => f a) = + match x with | none => erase p | some a => erase (f a) := by cases x <;> rfl +@[simp] theorem erase_prod_match {A B C : Type} (x : A × B) (f : A → B → Parser C) : + erase (match x with | (a,b) => f a b) = + match x with | (a,b) => erase (f a b) := by cases x; rfl +@[simp] theorem erase_pairOption_match {A B C : Type} (x : Option (A × B)) + (p : Parser C) (f : A → B → Parser C) : + erase (match x with | some (a,b) => f a b | none => p) = + match x with | some (a,b) => erase (f a b) | none => erase p := by + cases x with + | none => rfl + | some v => cases v; rfl +@[simp] theorem erase_list_match {A B : Type} (xs : List A) (p : Parser B) + (f : A → List A → Parser B) : + erase (match xs with | [] => p | a::as => f a as) = + match xs with | [] => erase p | a::as => erase (f a as) := by cases xs <;> rfl +@[simp] theorem erase_coord_match {A : Type} (c : BusCoord) (col : Nat → Parser A) + (pub table : Parser A) : + erase (match c with | .column n => col n | .publicValue => pub | .tableExpression => table) = + match c with | .column n => erase (col n) | .publicValue => erase pub | + .tableExpression => erase table := by cases c <;> rfl + +@[simp] theorem erase_mapM {A B : Type} (xs : List A) (f : A → Parser B) : + erase (xs.mapM f) = xs.mapM (fun a => erase (f a)) := by + induction xs with + | nil => simp + | cons x xs ih => simp [List.mapM_cons,ih] + +@[simp] theorem erase_forIn {A B : Type} (xs : List A) (initial : B) + (body : A → B → Parser (ForInStep B)) : + erase (forIn xs initial body) = forIn xs initial (fun a b => erase (body a b)) := by + induction xs generalizing initial with + | nil => simp [List.forIn_nil] + | cons x xs ih => + simp only [List.forIn_cons,erase_bind] + congr 1 + funext step + cases step <;> simp [ih] + + def tick (n : Nat) : Parser Unit := fun ts => ⟨some ((),ts),n⟩ +@[simp] theorem tick_erasure (n : Nat) : erase (tick n) = Pure.pure () := rfl + def liftOption {A : Type} (n : Nat) (x : Option A) : Parser A := fun ts => + ⟨x.map (fun a => (a,ts)),n⟩ +@[simp] theorem liftOption_erasure {A : Type} (n : Nat) (x : Option A) : + erase (liftOption n x) = + match x with | some a => Pure.pure a | none => fun _ => none := by cases x <;> rfl + +structure Costed (A : Type) where + value : A + work : Nat + + def readScalar : Parser E + | .sent x :: rest => ⟨some (x,rest),4⟩ + | _ => ⟨none,3⟩ + def drawScalar : Parser E + | .draw x :: rest => ⟨some (x,rest),4⟩ + | _ => ⟨none,3⟩ + def check (ok : Bool) : Parser Unit := fun ts => + if ok then ⟨some ((),ts),3⟩ else ⟨none,2⟩ + def nonce (bits : Nat) : Parser Unit + | .nonce actual _ :: rest => + if actual = bits then ⟨some ((),rest),5⟩ else ⟨none,4⟩ + | _ => ⟨none,3⟩ + def readScalars : Nat → Parser (List E) + | 0 => do tick 2; return [] + | n+1 => do + tick 3 + let x ← readScalar + let xs ← readScalars n + tick 2 + return x :: xs + def drawScalars : Nat → Parser (List E) + | 0 => do tick 2; return [] + | n+1 => do + tick 3 + let x ← drawScalar + let xs ← drawScalars n + tick 2 + return x :: xs + +@[simp] theorem readScalar_erasure : erase readScalar = WHIRCallerClaims.readScalar := by + funext ts; cases ts with + | nil => rfl + | cons t ts => cases t <;> rfl +@[simp] theorem drawScalar_erasure : erase drawScalar = WHIRCallerClaims.drawScalar := by + funext ts; cases ts with + | nil => rfl + | cons t ts => cases t <;> rfl +@[simp] theorem check_erasure (ok : Bool) : erase (check ok) = WHIRCallerClaims.check ok := by + cases ok <;> rfl +@[simp] theorem nonce_erasure (n : Nat) : erase (nonce n) = WHIRCallerClaims.nonce n := by + funext ts; cases ts with + | nil => rfl + | cons t ts => cases t <;> simp [erase,nonce,WHIRCallerClaims.nonce]; split <;> rfl +@[simp] theorem readScalars_erasure (n : Nat) : erase (readScalars n) = WHIRCallerClaims.readScalars n := by + induction n with + | zero => simp [readScalars,WHIRCallerClaims.readScalars] + | succ n ih => simp [readScalars,WHIRCallerClaims.readScalars,ih] +@[simp] theorem drawScalars_erasure (n : Nat) : erase (drawScalars n) = WHIRCallerClaims.drawScalars n := by + induction n with + | zero => simp [drawScalars,WHIRCallerClaims.drawScalars] + | succ n ih => simp [drawScalars,WHIRCallerClaims.drawScalars,ih] + + theorem readScalar_work_le (ts : List CallerToken) : (readScalar ts).work ≤ 4 := by + cases ts with + | nil => decide + | cons t ts => cases t <;> simp [readScalar] + theorem drawScalar_work_le (ts : List CallerToken) : (drawScalar ts).work ≤ 4 := by + cases ts with + | nil => decide + | cons t ts => cases t <;> simp [drawScalar] +theorem check_work_le (ok : Bool) (ts : List CallerToken) : (check ok ts).work ≤ 3 := by + cases ok <;> simp [check] +theorem nonce_work_le (bits : Nat) (ts : List CallerToken) : (nonce bits ts).work ≤ 5 := by + cases ts with + | nil => simp [nonce] + | cons t ts => + cases t with + | sent x => simp [nonce] + | draw x => simp [nonce] + | nonce actual value => simp only [nonce]; split <;> simp + theorem readScalars_work_le (n : Nat) (ts : List CallerToken) : + (readScalars n ts).work ≤ 9*n+2 := by + induction n generalizing ts with + | zero => change 2 ≤ 2; omega + | succ n ih => + cases ts with + | nil => change 6 ≤ 9*(n+1)+2; omega + | cons t ts => + cases t <;> dsimp only [readScalars,Bind.bind,Pure.pure,bind,tick,pure,readScalar] + · have h := ih ts + cases (readScalars n ts).result <;> simp only [] <;> omega + · omega + · omega + theorem drawScalars_work_le (n : Nat) (ts : List CallerToken) : + (drawScalars n ts).work ≤ 9*n+2 := by + induction n generalizing ts with + | zero => change 2 ≤ 2; omega + | succ n ih => + cases ts with + | nil => change 6 ≤ 9*(n+1)+2; omega + | cons t ts => + cases t <;> dsimp only [drawScalars,Bind.bind,Pure.pure,bind,tick,pure,drawScalar] + · omega + · have h := ih ts + cases (drawScalars n ts).result <;> simp only [] <;> omega + · omega + +theorem readScalars_success (n : Nat) (ts : List CallerToken) (xs : List E) + (rest : List CallerToken) (h : (readScalars n ts).result = some (xs,rest)) : + xs.length = n ∧ rest.length+n = ts.length := by + induction n generalizing ts xs rest with + | zero => + simp [readScalars,Bind.bind,Pure.pure,bind,tick,pure] at h + rcases h with ⟨rfl,rfl⟩ + simp + | succ n ih => + cases ts with + | nil => change none = some (xs,rest) at h; cases h + | cons t ts => + cases t <;> dsimp only [readScalars,Bind.bind,Pure.pure,bind,tick,pure,readScalar] at h + · cases hr : (readScalars n ts).result with + | none => simp [hr] at h + | some v => + rcases v with ⟨ys,tail⟩ + simp only [hr] at h + have ht := ih ts ys tail hr + cases h + simp only [List.length_cons] + omega + · simp at h + · simp at h + +theorem drawScalars_success (n : Nat) (ts : List CallerToken) (xs : List E) + (rest : List CallerToken) (h : (drawScalars n ts).result = some (xs,rest)) : + xs.length = n ∧ rest.length+n = ts.length := by + induction n generalizing ts xs rest with + | zero => + simp [drawScalars,Bind.bind,Pure.pure,bind,tick,pure] at h + rcases h with ⟨rfl,rfl⟩ + simp + | succ n ih => + cases ts with + | nil => change none = some (xs,rest) at h; cases h + | cons t ts => + cases t <;> dsimp only [drawScalars,Bind.bind,Pure.pure,bind,tick,pure,drawScalar] at h + · simp at h + · cases hr : (drawScalars n ts).result with + | none => simp [hr] at h + | some v => + rcases v with ⟨ys,tail⟩ + simp only [hr] at h + have ht := ih ts ys tail hr + cases h + simp only [List.length_cons] + omega + · simp at h +theorem readScalars_success_length (n : Nat) (ts : List CallerToken) (xs : List E) + (rest : List CallerToken) (h : (readScalars n ts).result = some (xs,rest)) : + xs.length = n := (readScalars_success n ts xs rest h).1 +theorem drawScalars_success_length (n : Nat) (ts : List CallerToken) (xs : List E) + (rest : List CallerToken) (h : (drawScalars n ts).result = some (xs,rest)) : + xs.length = n := (drawScalars_success n ts xs rest h).1 + +theorem bind_work_le {A B : Type} (p : Parser A) (f : A → Parser B) + (ts : List CallerToken) (m n : Nat) (hp : (p ts).work ≤ m) + (hf : ∀ a rest, (p ts).result = some (a,rest) → (f a rest).work ≤ n) : + ((p >>= f) ts).work ≤ m+n := by + change (bind p f ts).work ≤ m+n + simp only [bind] + cases h : (p ts).result with + | none => simp; omega + | some v => rcases v with ⟨a,rest⟩; have ht := hf a rest h; simp; omega + + +/-- A list length inspects the terminal constructor as well as all cells. -/ +def lengthCost {A : Type} (xs : List A) : Nat := xs.length+1 +def appendCost {A : Type} (xs : List A) : Nat := 2*xs.length+1 +def takeCost {A : Type} (n : Nat) (xs : List A) : Nat := 2*min n xs.length+1 +def dropCost {A : Type} (n : Nat) (xs : List A) : Nat := min n xs.length+1 +def indexCost {A : Type} (n : Nat) (xs : List A) : Nat := min (n+1) xs.length+1 +def allCost {A : Type} (p : A → Bool) (cost : A → Nat) : List A → Nat + | [] => 1 + | x :: xs => cost x + 1 + if p x then allCost p cost xs else 0 +def memberCost {A : Type} [DecidableEq A] (x : A) (comparison : Nat) : List A → Nat + | [] => 1 + | y :: ys => comparison+1 + if x = y then 0 else memberCost x comparison ys +def eraseDupsCost {A : Type} [DecidableEq A] (comparison : Nat) : + List A → List A → Nat + | [], seen => 2*seen.length+2 + | x :: xs, seen => memberCost x comparison seen + 2 + + if x ∈ seen then eraseDupsCost comparison xs seen + else 1 + eraseDupsCost comparison xs (x :: seen) + +theorem allCost_le {A : Type} (p : A → Bool) (cost : A → Nat) + (xs : List A) (k : Nat) (h : ∀ x ∈ xs, cost x ≤ k) : + allCost p cost xs ≤ (k+1)*xs.length+1 := by + induction xs with + | nil => simp [allCost] + | cons x xs ih => + have hx := h x (by simp) + have ht := ih (fun y hy => h y (by simp [hy])) + simp only [allCost,List.length_cons] + split <;> nlinarith + +theorem memberCost_le {A : Type} [DecidableEq A] (x : A) (k : Nat) (xs : List A) : + memberCost x k xs ≤ (k+1)*xs.length+1 := by + induction xs with + | nil => simp [memberCost] + | cons y ys ih => + simp only [memberCost,List.length_cons] + split <;> nlinarith + +theorem eraseDupsCost_le {A : Type} [DecidableEq A] (k : Nat) (xs seen : List A) : + eraseDupsCost k xs seen ≤ + (k+1)*xs.length*(xs.length+seen.length)+4*xs.length+2*(xs.length+seen.length)+2 := by + induction xs generalizing seen with + | nil => simp [eraseDupsCost] + | cons x xs ih => + have hc := memberCost_le x k seen + simp only [eraseDupsCost,List.length_cons] + split + · have ht := ih seen; nlinarith + · have ht := ih (x::seen); simp only [List.length_cons] at ht; nlinarith + +theorem sum_map_le {A : Type} (xs : List A) (f : A → Nat) (n : Nat) + (h : ∀ x ∈ xs, f x ≤ n) : (xs.map f).sum ≤ xs.length*n := by + induction xs with + | nil => simp + | cons x xs ih => + have hx := h x (by simp) + have ht := ih (fun y hy => h y (by simp [hy])) + simp only [List.map_cons,List.sum_cons,List.length_cons] + nlinarith + +/-- Repeated multiplication: no opaque exponentiation work assumption. -/ +def pow2 : Nat → Costed Nat + | 0 => ⟨1,2⟩ + | n+1 => let r := pow2 n; ⟨r.value*2,r.work+3⟩ +@[simp] theorem pow2_erasure (n : Nat) : (pow2 n).value = 2^n := by + induction n with + | zero => rfl + | succ n ih => simp [pow2,ih,Nat.pow_succ] +theorem pow2_work (n : Nat) : (pow2 n).work = 3*n+2 := by + induction n with + | zero => rfl + | succ n ih => simp only [pow2,ih]; omega + +/-- The source's `Nat.log2_def` division recurrence, with reached branches. -/ +def log2 (n : Nat) : Costed Nat := + if h : 2 ≤ n then + let r := log2 (n/2) + ⟨r.value+1,r.work+4⟩ + else ⟨0,2⟩ +termination_by n +decreasing_by exact Nat.div_lt_self (by omega) (by decide) +@[simp] theorem log2_erasure (n : Nat) : (log2 n).value = Nat.log2 n := by + induction n using Nat.strong_induction_on with + | h n ih => + rw [log2,Nat.log2_def] + split + · next hn => simp only []; rw [ih (n/2) (Nat.div_lt_self (by omega) (by decide))] + · rfl +theorem log2_work_le (n : Nat) : (log2 n).work ≤ 4*n+2 := by + induction n using Nat.strong_induction_on with + | h n ih => + rw [log2] + split + · next hn => + have hd : n/2 < n := Nat.div_lt_self (by omega) (by decide) + have ht := ih (n/2) hd + simp only [] + omega + · simp only []; omega +theorem log2_work (n : Nat) : (log2 n).work = 4*Nat.log2 n+2 := by + induction n using Nat.strong_induction_on with + | h n ih => + rw [log2,Nat.log2_def] + split + · next hn => + have hd : n/2 < n := Nat.div_lt_self (by omega) (by decide) + have ht := ih (n/2) hd + simp only [] + omega + · rfl + +def mu (l : BusLayout) : Costed Nat := + let push := (l.push.map (fun b => (pow2 b.kappa).value)).sum + + (l.producers.map (fun p => p.bits * (pow2 p.kappa).value)).sum + let pull := (l.pull.map (fun b => (pow2 b.kappa).value)).sum + let logarithm := log2 (max (max push pull) 1 - 1) + ⟨logarithm.value + if max push pull ≤ 1 then 0 else 1, + (l.push.map (fun b => (pow2 b.kappa).work+4)).sum + + (l.producers.map (fun p => (pow2 p.kappa).work+5)).sum + + (l.pull.map (fun b => (pow2 b.kappa).work+4)).sum + + logarithm.work+15⟩ +@[simp] theorem mu_erasure (l : BusLayout) : (mu l).value = l.mu := by + simp only [mu,BusLayout.mu,pow2_erasure,log2_erasure] + +theorem mu_work_le (l : BusLayout) : + (mu l).work ≤ + (l.push.map (fun b => 3*b.kappa+6)).sum + + (l.producers.map (fun p => 3*p.kappa+7)).sum + + (l.pull.map (fun b => 3*b.kappa+6)).sum +4*l.mu+17 := by + simp only [mu,BusLayout.mu,pow2_work,pow2_erasure,log2_work,Nat.add_assoc,Nat.reduceAdd] + omega + +def fieldOf (column : Nat) : List BitField → Nat → Costed (Option (BitField × Nat)) + | [], _ => ⟨none,2⟩ + | f :: fs, offset => + if f.column = column then ⟨some (f,offset),5⟩ + else let r := fieldOf column fs (offset+f.width); ⟨r.value,4+r.work⟩ +@[simp] theorem fieldOf_erasure (column : Nat) (fs : List BitField) (offset : Nat) : + (fieldOf column fs offset).value = WHIRCallerClaims.fieldOf column fs offset := by + induction fs generalizing offset with + | nil => rfl + | cons f fs ih => simp only [fieldOf,WHIRCallerClaims.fieldOf]; split <;> simp [ih] +theorem fieldOf_work_le (column : Nat) (fs : List BitField) (offset : Nat) : + (fieldOf column fs offset).work ≤ 5*fs.length+2 := by + induction fs generalizing offset with + | nil => simp [fieldOf] + | cons f fs ih => + simp only [fieldOf,List.length_cons] + split + · simp; omega + · have h := ih (offset+f.width); simp; omega + +def combineBits (bits : List E) : Costed E := + ⟨(bits.zipIdx.map (fun (x,b) => x * E.ofK (UInt64.ofNat (pow2 b).value))).foldl (· + ·) 0, + (bits.zipIdx.map (fun (_,b) => (pow2 b).work+12)).sum+3⟩ +@[simp] theorem combineBits_erasure (bits : List E) : + (combineBits bits).value = WHIRCallerClaims.combineBits bits := by + simp only [combineBits,WHIRCallerClaims.combineBits,pow2_erasure] +theorem combineBits_work_le (bits : List E) : + (combineBits bits).work ≤ bits.length*(3*bits.length+14)+3 := by + have h := sum_map_le bits.zipIdx (fun p => (pow2 p.2).work+12) (3*bits.length+14) (by + intro p hp + have hat := List.mem_zipIdx_iff_getElem?.mp hp + have hi := (List.getElem?_eq_some_iff.mp hat).1 + rw [pow2_work] + omega) + simpa [combineBits] using Nat.add_le_add_right h 3 + +def placeClaim (p : Placement) (c : ColumnClaim) : Costed (Option RingPCSGame.PointClaim) := + match p with + | .committed offset _ => ⟨some (.point offset c.point.toArray c.value),2*c.point.length+4⟩ + | .port offset slot stride => + ⟨some (.strided offset slot stride c.point.toArray c.value),2*c.point.length+4⟩ + | .sliced => ⟨none,2⟩ +@[simp] theorem placeClaim_erasure (p : Placement) (c : ColumnClaim) : + (placeClaim p c).value = WHIRCallerClaims.placeClaim p c := by cases p <;> rfl +theorem placeClaim_work_le (p : Placement) (c : ColumnClaim) : + (placeClaim p c).work ≤ 2*c.point.length+4 := by cases p <;> simp [placeClaim] + +def placeClaimsLoop (placements : Array Placement) : + List ColumnClaim → Costed (Option (List (Option RingPCSGame.PointClaim))) + | [] => ⟨some [],2⟩ + | c :: cs => + match placements[c.column]? with + | none => ⟨none,4⟩ + | some p => + let located := placeClaim p c + let later := placeClaimsLoop placements cs + ⟨later.value.map (located.value :: ·),located.work+later.work+6⟩ + +def filterMapCost {A : Type} : List (Option A) → Nat + | [] => 1 + | none :: xs => filterMapCost xs+2 + | some _ :: xs => filterMapCost xs+3 +theorem filterMapCost_le {A : Type} (xs : List (Option A)) : + filterMapCost xs ≤ 3*xs.length+1 := by + induction xs with + | nil => simp [filterMapCost] + | cons x xs ih => cases x <;> simp only [filterMapCost,List.length_cons] <;> omega + +def placeClaims (placements : Array Placement) (claims : List ColumnClaim) : + Costed (Option (Array RingPCSGame.PointClaim)) := + let located := placeClaimsLoop placements claims + match located.value with + | none => ⟨none,located.work+1⟩ + | some xs => ⟨some ((xs.filterMap id).toArray), + located.work+filterMapCost xs+2*(xs.filterMap id).length+3⟩ + +theorem placeClaimsLoop_erasure (placements : Array Placement) (claims : List ColumnClaim) : + (placeClaimsLoop placements claims).value = + claims.mapM (fun c => do + let p ← placements[c.column]? + Pure.pure (WHIRCallerClaims.placeClaim p c)) := by + induction claims with + | nil => rfl + | cons c cs ih => + simp only [placeClaimsLoop,List.mapM_cons] + cases placements[c.column]? <;> simp [ih,Option.map_eq_bind] +@[simp] theorem placeClaims_erasure (placements : Array Placement) (claims : List ColumnClaim) : + (placeClaims placements claims).value = WHIRCallerClaims.placeClaims placements claims := by + simp only [placeClaims,placeClaimsLoop_erasure,WHIRCallerClaims.placeClaims] + cases claims.mapM (fun c => do + let p ← placements[c.column]? + Pure.pure (WHIRCallerClaims.placeClaim p c)) <;> rfl + +def tableColumns (base : Nat) (claims : TableClaims) : Costed (List ColumnClaim) := + ⟨claims.evals.zipIdx.map (fun (x,i) => ⟨base+i,claims.point,x⟩), + 6*claims.evals.length+2⟩ +@[simp] theorem tableColumns_erasure (base : Nat) (claims : TableClaims) : + (tableColumns base claims).value = WHIRCallerClaims.tableColumns base claims := rfl + +def paddedRing (offset : Nat) (point slices : List E) : + Costed (Option RingPCSGame.FamilyClaim) := + if slices.length ≤ 64 then + ⟨some ⟨offset,point.toArray,fun i => slices[i.val]?.getD 0⟩, + lengthCost slices+2*point.length+5⟩ + else ⟨none,lengthCost slices+2⟩ +@[simp] theorem paddedRing_erasure (offset : Nat) (point slices : List E) : + (paddedRing offset point slices).value = WHIRCallerClaims.paddedRing offset point slices := by + unfold paddedRing WHIRCallerClaims.paddedRing; split <;> rfl +/-- Work of a reached invocation of the ring's delayed slice getter. -/ +def paddedRingGetterWork (slices : List E) (i : Fin 64) : Nat := indexCost i.val slices+2 +theorem paddedRingGetterWork_le (slices : List E) (i : Fin 64) : + paddedRingGetterWork slices i ≤ 67 := by + unfold paddedRingGetterWork indexCost + have := i.isLt + omega +theorem paddedRing_work_le (offset : Nat) (point slices : List E) : + (paddedRing offset point slices).work ≤ slices.length+2*point.length+6 := by + simp only [paddedRing] + split <;> simp [lengthCost] <;> omega + +theorem tableColumns_work (base : Nat) (claims : TableClaims) : + (tableColumns base claims).work = 6*claims.evals.length+2 := rfl +theorem tableColumns_length (base : Nat) (claims : TableClaims) : + (tableColumns base claims).value.length = claims.evals.length := by + simp [tableColumns] +theorem tableColumns_point (base : Nat) (claims : TableClaims) (c : ColumnClaim) + (h : c ∈ (tableColumns base claims).value) : c.point = claims.point := by + simp only [tableColumns,List.mem_map] at h + obtain ⟨⟨x,i⟩,hx,hc⟩ := h + cases hc + rfl + +theorem paddedRing_success_point_size (offset : Nat) (point slices : List E) + (claim : RingPCSGame.FamilyClaim) (h : (paddedRing offset point slices).value = some claim) : + claim.point.size = point.length := by + simp only [paddedRing] at h + split at h + · cases h; simp + · simp at h + +theorem placeClaimsLoop_work_le (placements : Array Placement) + (claims : List ColumnClaim) (pointCap : Nat) + (h : ∀ c ∈ claims, c.point.length ≤ pointCap) : + (placeClaimsLoop placements claims).work ≤ claims.length*(2*pointCap+10)+2 := by + induction claims with + | nil => simp [placeClaimsLoop] + | cons c cs ih => + have hc := h c (by simp) + have ht := ih (fun c hc => h c (by simp [hc])) + have hp := placeClaim_work_le + simp only [placeClaimsLoop,List.length_cons] + split + · simp only []; nlinarith + · next p hp' => + have hh := hp p c + simp only [] + nlinarith + +theorem placeClaimsLoop_length (placements : Array Placement) + (claims : List ColumnClaim) (xs : List (Option RingPCSGame.PointClaim)) + (h : (placeClaimsLoop placements claims).value = some xs) : + xs.length = claims.length := by + induction claims generalizing xs with + | nil => simp [placeClaimsLoop] at h; subst xs; rfl + | cons c cs ih => + simp only [placeClaimsLoop] at h + split at h + · simp at h + · next p => + cases hr : (placeClaimsLoop placements cs).value with + | none => simp [hr] at h + | some ys => + simp only [hr,Option.map_some,Option.some.injEq] at h + subst xs + simp [ih ys hr] + +theorem placeClaims_work_le (placements : Array Placement) (claims : List ColumnClaim) + (pointCap : Nat) (h : ∀ c ∈ claims, c.point.length ≤ pointCap) : + (placeClaims placements claims).work ≤ claims.length*(2*pointCap+15)+6 := by + have hw := placeClaimsLoop_work_le placements claims pointCap h + simp only [placeClaims] + split + · simp only []; nlinarith + · next xs hs => + have hl := placeClaimsLoop_length placements claims xs hs + have hf := filterMapCost_le xs + have hk := List.length_filterMap_le (f := id) (l := xs) + simp only [] + nlinarith + +theorem placeClaims_success_size (placements : Array Placement) + (claims : List ColumnClaim) (points : Array RingPCSGame.PointClaim) + (h : (placeClaims placements claims).value = some points) : + points.size ≤ claims.length := by + simp only [placeClaims] at h + split at h + · simp at h + · next xs hs => + have hl := placeClaimsLoop_length placements claims xs hs + cases h + simpa only [List.size_toArray,hl] using List.length_filterMap_le id xs + + +def flockChecksWork (layout : FlockLayout) (zc lc : List E) : Nat := + if layout.kLog < 6 then 3 else + if layout.logN < 13 then 6 else + if lc.length < layout.kLog-6 then lengthCost lc+8 else + lengthCost lc+lengthCost zc+11 + +def assembleFlock (layout : FlockLayout) (zc lc slices : List E) : + Costed (Option RingPCSGame.FamilyClaim) := + let rest := layout.kLog-6 + let checks := flockChecksWork layout zc lc + if layout.kLog < 6 || layout.logN < 13 || lc.length < rest || + zc.length < layout.logN-6 then ⟨none,checks+1⟩ + else + if h : slices.length = 64 then + let left := (lc.take rest).reverse + let right := (zc.drop rest).take layout.instanceLog + ⟨some ⟨layout.offset,(left++right).toArray, + fun i => slices[i.val]'(by omega)⟩, + checks+lengthCost slices+takeCost rest lc+2*left.length+1+ + dropCost rest zc+takeCost layout.instanceLog (zc.drop rest)+ + appendCost left+2*(left.length+right.length)+6⟩ + else ⟨none,checks+lengthCost slices+3⟩ +@[simp] theorem assembleFlock_erasure (layout : FlockLayout) (zc lc slices : List E) : + (assembleFlock layout zc lc slices).value = + WHIRCallerClaims.assembleFlock layout zc lc slices := by + dsimp only [assembleFlock,WHIRCallerClaims.assembleFlock] + split + · rfl + · split <;> rfl + +theorem assembleFlock_work_le (layout : FlockLayout) (zc lc slices : List E) : + (assembleFlock layout zc lc slices).work ≤ + 9*lc.length+6*zc.length+slices.length+30 := by + have hc : flockChecksWork layout zc lc ≤ lc.length+zc.length+13 := by + unfold flockChecksWork + split + · omega + · split + · omega + · split <;> simp [lengthCost] <;> omega + simp only [assembleFlock] + split + · simp only []; omega + · split + · simp only [lengthCost,takeCost,dropCost,appendCost,List.length_reverse, + List.length_take,List.length_drop] at ⊢ + omega + · simp only [lengthCost] + omega + +/-- Work of a reached Flock slice getter, whose successful layout has 64 cells. -/ +def assembleFlockGetterWork (i : Fin 64) : Nat := i.val+2 +theorem assembleFlockGetterWork_le (i : Fin 64) : assembleFlockGetterWork i ≤ 65 := by + unfold assembleFlockGetterWork + have := i.isLt + omega + + +/-- One actual nested radix-four sumcheck round. Exposed so the work proof can +track the source-created point length without changing interpretation. -/ +def gkrRound (point : List E) : Parser (List E) := do + tick (lengthCost point+2*point.length+3) + let rounds ← (List.range point.length).mapM (fun _ => do + tick 2 + let _ ← readScalars 4 + drawScalar) + let _ ← readScalars 8 + let low ← drawScalar + let high ← drawScalar + let _ ← drawScalar + tick 3 + pure (low :: high :: rounds) + +/-- Actual odd leading sumcheck round, or the empty even seed. -/ +def gkrSeed (mu : Nat) : Parser (List E) := do + if mu % 2 = 1 then + let _ ← readScalars 4 + let x ← drawScalar + let _ ← drawScalar + tick 1 + pure [x] + else + pure [] + +def gkrPoint (mu : Nat) : Parser (List E) := do + let _ ← readScalar + let _ ← drawScalar + tick 4 + let mut point ← gkrSeed mu + tick (2*(mu/2)+2) + for _ in List.range (mu / 2) do + point ← gkrRound point + tick 1 + pure point + +def busClaims (layout : BusLayout) : Parser (List E × List ColumnClaim) := do + tick 2 + if layout.grinding > 0 then nonce layout.grinding + let _ ← drawScalars 4 + let _ ← drawScalar + let m := mu layout + tick m.work + let point ← gkrPoint m.value + let mut known : List (Nat × Nat) := [] + let mut claims := [] + tick (appendCost layout.push+2) + for block in layout.push ++ layout.pull do + tick (lengthCost point+4) + check (block.kappa ≤ point.length) + if !block.tableOwned then + for coord in block.coords do + tick 2 + match coord with + | .column col => + tick (memberCost (col,block.kappa) 2 known+1) + if (col,block.kappa) ∉ known then + let value ← readScalar + tick (appendCost known+appendCost claims+takeCost block.kappa point+5) + known := known ++ [(col,block.kappa)] + claims := claims ++ [⟨col,point.take block.kappa,value⟩] + | .publicValue => pure () + | .tableExpression => check false + tick 3 + pure (point,claims) + +def receiveTable (layout : AirLayout) (point : List E) : Parser TableClaims := do + tick (if layout.publicColumns ≤ layout.columns then lengthCost point+4 else 2) + check (layout.publicColumns ≤ layout.columns && layout.tau ≤ point.length) + tick 1 + let n := layout.columns-layout.publicColumns + tick (allCost (fun f => f.column < n && f.width ≤ 64) + (fun f => if f.column < n then 3 else 2) layout.fields) + check (layout.fields.all (fun f => f.column < n && f.width ≤ 64)) + let columns := layout.fields.map BitField.column + tick (2*layout.fields.length+1+eraseDupsCost 1 columns []+ + lengthCost columns.eraseDups+lengthCost layout.fields+1) + check (columns.eraseDups.length == layout.fields.length) + tick (lengthCost layout.fields+1) + let sent ← readScalars (n-layout.fields.length) + tick (4*layout.fields.length+2) + let slices ← readScalars ((layout.fields.map BitField.width).sum) + let mut cursor := sent + let mut evals := [] + tick (2*n+3) + for c in List.range n do + let found := fieldOf c layout.fields 0 + tick (found.work+2) + match found.value with + | some (f,start) => + let combined := combineBits ((slices.drop start).take f.width) + tick (dropCost start slices+takeCost f.width (slices.drop start)+ + combined.work+appendCost evals+1) + evals := evals ++ [combined.value] + | none => + tick 1 + match cursor with + | [] => check false + | x :: xs => + tick (appendCost evals+2) + evals := evals ++ [x] + cursor := xs + tick 1 + check cursor.isEmpty + tick (takeCost layout.tau point+3) + pure ⟨point.take layout.tau,evals,slices⟩ + +def constraintClaims (layouts : List AirLayout) (busPoint : List E) : + Parser (List TableClaims) := do + tick (4*layouts.length+lengthCost busPoint+3) + let n := (layouts.map AirLayout.tau).foldl max 0 + check (n ≤ busPoint.length) + tick (2*n+2) + let rounds ← (List.range n).mapM (fun _ => do + tick 2 + let _ ← readScalars 3 + drawScalar) + layouts.mapM (fun l => do + tick (2*rounds.length+3) + receiveTable l rounds.reverse) + +def flockClaims (layouts : List FlockLayout) : Parser (List RingPCSGame.FamilyClaim) := do + tick (3+if layouts.isEmpty then 0 else + allCost (fun l => 6 ≤ l.kLog && 13 ≤ l.logN) + (fun l => if 6 ≤ l.kLog then 4 else 2) layouts) + check (!layouts.isEmpty && layouts.all (fun l => 6 ≤ l.kLog && 13 ≤ l.logN)) + tick (10*layouts.length+6) + let m := (layouts.map FlockLayout.logN).foldl max 0 + let rounds := (layouts.map (fun l => l.kLog-6)).foldl max 0 + let _ ← drawScalars (m-13) + let _ ← drawScalar + let _ ← readScalars 64 + let _ ← drawScalar + tick (2*(m-6)+3) + let zc ← (List.range (m-6)).mapM (fun _ => do + tick 2 + let _ ← readScalars 2 + drawScalar) + tick (lengthCost layouts+1) + let _ ← readScalars (3*layouts.length) + let _ ← drawScalar + tick (2*rounds+2) + let lc ← (List.range rounds).mapM (fun _ => do + tick 2 + let _ ← readScalars 2 + drawScalar) + layouts.mapM (fun layout => do + tick 2 + let slices ← readScalars 64 + let _ ← readScalar + let assembled := assembleFlock layout zc lc slices + tick (assembled.work+1) + match assembled.value with + | some claim => pure claim + | none => liftOption 0 none) + +@[simp] theorem gkrPoint_erasure (m : Nat) : erase (gkrPoint m) = WHIRCallerClaims.gkrPoint m := by + by_cases parity : m % 2 = 1 <;> + simp [gkrPoint,gkrSeed,gkrRound,WHIRCallerClaims.gkrPoint,parity,bind_assoc] +@[simp] theorem busClaims_erasure (l : BusLayout) : erase (busClaims l) = WHIRCallerClaims.busClaims l := by + simp [busClaims,WHIRCallerClaims.busClaims] + rfl +@[simp] theorem receiveTable_erasure (l : AirLayout) (p : List E) : + erase (receiveTable l p) = WHIRCallerClaims.receiveTable l p := by + simp [receiveTable,WHIRCallerClaims.receiveTable] + congr! 32 + all_goals first | rfl | (split <;> simp_all) + all_goals split <;> simp_all +@[simp] theorem constraintClaims_erasure (ls : List AirLayout) (p : List E) : + erase (constraintClaims ls p) = WHIRCallerClaims.constraintClaims ls p := by + simp [constraintClaims,WHIRCallerClaims.constraintClaims] +set_option maxHeartbeats 1000000 in +@[simp] theorem flockClaims_erasure (ls : List FlockLayout) : + erase (flockClaims ls) = WHIRCallerClaims.flockClaims ls := by + simp [flockClaims,WHIRCallerClaims.flockClaims] + congr! 32 + all_goals first | rfl | (split <;> simp_all) + + +/-! Kernel-checked, scoped accepted/rejected token cases. These exercise actual +counted execution, including an early failure after a successful scalar read. -/ +namespace Smoke +theorem read_accepts (xs : List E) (rest : List CallerToken) : + (readScalars xs.length (xs.map CallerToken.sent ++ rest)).result = some (xs,rest) := by + change erase (readScalars xs.length) _ = _ + rw [readScalars_erasure,WHIRCallerClaims.readScalars_sent] +theorem draw_accepts (xs : List E) (rest : List CallerToken) : + (drawScalars xs.length (xs.map CallerToken.draw ++ rest)).result = some (xs,rest) := by + change erase (drawScalars xs.length) _ = _ + rw [drawScalars_erasure,WHIRCallerClaims.drawScalars_draw] +theorem read_rejects_draw : (readScalar [.draw 0]).result = none := rfl +theorem draw_rejects_sent : (drawScalar [.sent 0]).result = none := rfl +theorem failed_prefix_is_charged : + (readScalars 10 [.sent 0,.draw 0]).result = none ∧ + (readScalars 10 [.sent 0,.draw 0]).work = 13 := by constructor <;> rfl +theorem nonce_rejects_wrong_bits : + (nonce 4 [.nonce 8 (fun _ => 0)]).result = none ∧ + (nonce 4 [.nonce 8 (fun _ => 0)]).work = 4 := by constructor <;> rfl +theorem gkr_zero_accepts : + (gkrPoint 0 [.sent 0,.draw 0]).result = some ([],[]) := rfl +theorem gkr_odd_accepts : + (gkrPoint 1 [.sent 0,.draw 0,.sent 0,.sent 0,.sent 0,.sent 0,.draw 1,.draw 0]).result = + some ([1],[]) := rfl +theorem gkr_nested_accepts (x z low high : E) : + (gkrPoint 3 ([.sent 0,.draw 0] ++ List.replicate 4 (.sent 0) ++ [.draw x,.draw 0] ++ + List.replicate 4 (.sent 0) ++ [.draw z] ++ List.replicate 8 (.sent 0) ++ + [.draw low,.draw high,.draw 0])).result = some ([low,high,z],[]) := rfl +def busTokens : List CallerToken := [.draw 0,.draw 0,.draw 0,.draw 0,.draw 0,.sent 0,.draw 0] +theorem empty_bus_accepts : + (busClaims ⟨[],[],[],0⟩ busTokens).result = some (([],[]),[]) := by + change erase (busClaims _) _ = _ + rw [busClaims_erasure] + rfl +theorem invalid_bus_coord_rejects : + (busClaims ⟨[⟨0,false,[.tableExpression]⟩],[],[],0⟩ busTokens).result = none := by + change erase (busClaims _) _ = _ + rw [busClaims_erasure] + rfl +theorem bus_deduplicates : + (busClaims ⟨[⟨0,false,[.column 2,.column 2]⟩],[],[],0⟩ + (busTokens ++ [.sent 1])).result = some (([],[⟨2,[],1⟩]),[]) := by + change erase (busClaims _) _ = _ + rw [busClaims_erasure] + rfl +theorem ordinary_table_accepts : + (receiveTable ⟨1,2,0,[]⟩ [1] [.sent 0,.sent 1]).result = + some (⟨[1],[0,1],[]⟩,[]) := rfl +theorem public_columns_reject : + (receiveTable ⟨0,0,1,[]⟩ [] []).result = none := rfl +theorem duplicate_bit_columns_reject : + (receiveTable ⟨0,1,0,[⟨0,1⟩,⟨0,1⟩]⟩ [] []).result = none := rfl +theorem bit_table_accepts : + (receiveTable ⟨0,2,0,[⟨0,2⟩]⟩ [] [.sent 7,.sent 0,.sent 1]).result = + some (⟨[],[WHIRCallerClaims.combineBits [0,1],7],[0,1]⟩,[]) := by + change erase (receiveTable _ _) _ = _ + rw [receiveTable_erasure] + rfl +theorem empty_flock_rejects : (flockClaims [] []).result = none := rfl +theorem invalid_flock_rejects : (flockClaims [⟨0,5,10⟩] []).result = none := rfl +def flockTokens : List CallerToken := + [.draw 0] ++ List.replicate 64 (.sent 0) ++ [.draw 0] ++ + (List.replicate 7 [.sent 0,.sent 0,.draw 0]).flatten ++ + List.replicate 3 (.sent 0) ++ [.draw 0] ++ List.replicate 65 (.sent 0) +set_option maxRecDepth 4096 in +theorem minimal_flock_accepts : + ∃ claims, (flockClaims [⟨0,6,7⟩] flockTokens).result = some (claims,[]) := by + refine ⟨[⟨0,(List.replicate 7 (0 : E)).toArray, + fun i => (List.replicate 64 (0 : E))[i.val]'(by simp only [List.length_replicate]; exact i.isLt)⟩],?_⟩ + change erase (flockClaims _) _ = _ + rw [flockClaims_erasure] + rfl +end Smoke + +#print axioms gkrPoint_erasure +#print axioms busClaims_erasure +#print axioms receiveTable_erasure +#print axioms constraintClaims_erasure +#print axioms flockClaims_erasure +#print axioms readScalars_work_le +#print axioms placeClaims_work_le +#print axioms Smoke.invalid_bus_coord_rejects +#print axioms Smoke.gkr_nested_accepts +#print axioms Smoke.minimal_flock_accepts +#print axioms log2_work +#print axioms mu_work_le + +end Whir.PCSBCSCallerParserCost diff --git a/verification/whir/Whir/PCSBCSCallerParserPolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerParserPolynomialBound.lean new file mode 100644 index 000000000..bd46b934c --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerParserPolynomialBound.lean @@ -0,0 +1,291 @@ +import Whir.PCSBCSCallerParserCost + +/-! Compositional work lemmas for the concrete counted caller interpreter. +Bounds concern the declared source-operation counter, including rejection, +not CPU cycles. Concrete nested-loop bounds must be discharged separately. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCallerParserCost +open Concrete WHIRCallerClaims + +/-- A parser never invents token input. This is useful when bounding later +work by the public input size rather than an arbitrary callback result. -/ +def Nonexpanding {A : Type} (parser : Parser A) : Prop := + ∀ tokens value rest, (parser tokens).result = some (value,rest) → rest.length ≤ tokens.length + + +theorem pure_nonexpanding {A : Type} (value : A) : + Nonexpanding (Pure.pure value : Parser A) := by + intro tokens output rest found + have equal := Option.some.inj found + cases equal + exact Nat.le_refl _ + +theorem bind_nonexpanding {A B : Type} (parser : Parser A) (next : A → Parser B) + (before : Nonexpanding parser) (after : ∀ value, Nonexpanding (next value)) : + Nonexpanding (parser >>= next) := by + intro tokens output tail found + change (bind parser next tokens).result = some (output,tail) at found + unfold bind at found + cases result : (parser tokens).result with + | none => simp only [result] at found; cases found + | some pair => + rcases pair with ⟨value,rest⟩ + simp only [result] at found + exact (after value rest output tail found).trans (before tokens value rest result) + +#print axioms bind_work_le +#print axioms bind_nonexpanding +#print axioms readScalar_work_le +#print axioms drawScalar_work_le +#print axioms check_work_le +#print axioms nonce_work_le + +theorem tick_bind_work {A : Type} (n : Nat) (parser : Parser A) + (tokens : List CallerToken) : + ((tick n >>= fun _ => parser) tokens).work = n + (parser tokens).work := rfl + +theorem pure_work {A : Type} (value : A) (tokens : List CallerToken) : + ((Pure.pure value : Parser A) tokens).work = 0 := rfl + +/-- Both early termination and ordinary iteration retain the same invariant. -/ +def iterationState {A : Type} : ForInStep A → A + | .done value => value + | .yield value => value + +/-- Actual `forIn` work, including a failed body or early `done`, is bounded by +the visited-list capacity. The invariant bounds only source-created state. -/ +theorem forIn_work_le {A B : Type} (xs : List A) (initial : B) + (body : A → B → Parser (ForInStep B)) (invariant : B → Prop) (cap : Nat) + (initialBound : invariant initial) + (bodyBound : ∀ a ∈ xs, ∀ state tokens, invariant state → (body a state tokens).work ≤ cap) + (preserves : ∀ a ∈ xs, ∀ state tokens step rest, invariant state → + (body a state tokens).result = some (step,rest) → invariant (iterationState step)) + (tokens : List CallerToken) : + ((forIn xs initial body : Parser B) tokens).work ≤ cap*xs.length := by + induction xs generalizing initial tokens with + | nil => + simp only [List.forIn_nil,pure_work,List.length_nil,Nat.mul_zero] + exact Nat.le_refl _ + | cons a xs ih => + rw [List.forIn_cons] + have before := bodyBound a (by simp) initial tokens initialBound + have bounded := bind_work_le (body a initial) + (fun step => match step with + | .done state => (Pure.pure state : Parser B) + | .yield state => forIn xs state body) + tokens cap (cap*xs.length) before (by + intro step rest parsed + have retained := preserves a (by simp) initial tokens step rest initialBound parsed + cases step with + | done state => simp only [pure_work]; exact Nat.zero_le _ + | yield state => + apply ih state retained + · intro next member value tail bound + exact bodyBound next (by simp [member]) value tail bound + · intro next member value tail outcome unused bound reached + exact preserves next (by simp [member]) value tail outcome unused bound reached) + simp only [List.length_cons,Nat.mul_add,Nat.mul_one] + convert bounded using 1 + omega + +#print axioms forIn_work_le + +/-- A failed map still charges its executed stopping prefix. -/ +theorem mapM_work_le {A B : Type} (xs : List A) (body : A → Parser B) (cap : Nat) + (bodyBound : ∀ a ∈ xs, ∀ tokens, (body a tokens).work ≤ cap) + (tokens : List CallerToken) : + ((xs.mapM body : Parser (List B)) tokens).work ≤ cap*xs.length := by + induction xs generalizing tokens with + | nil => + simp only [List.mapM_nil,pure_work,List.length_nil,Nat.mul_zero] + exact Nat.le_refl _ + | cons a xs ih => + rw [List.mapM_cons] + have bounded := bind_work_le (body a) + (fun value => xs.mapM body >>= fun values => Pure.pure (value::values)) + tokens cap (cap*xs.length) (bodyBound a (by simp) tokens) (by + intro value rest parsed + have tailBound := ih (fun next member tail => bodyBound next (by simp [member]) tail) rest + have later := bind_work_le (xs.mapM body) (fun values => Pure.pure (value::values)) + rest (cap*xs.length) 0 tailBound (by + intro values unused result + simp only [pure_work] + exact Nat.le_refl _) + simpa only [Nat.add_zero] using later) + simp only [List.length_cons,Nat.mul_add,Nat.mul_one] + omega + +#print axioms mapM_work_le + + +/-- Affine work for a state that grows by at most `delta` per successful round. +A stopping or failing iteration pays only the executed prefix. -/ +theorem forIn_growth_work_le {A B : Type} (xs : List A) (initial : B) + (body : A → B → Parser (ForInStep B)) (size : B → Nat) (a b delta : Nat) + (bodyBound : ∀ x ∈ xs, ∀ state tokens, (body x state tokens).work ≤ a*size state+b) + (grows : ∀ x ∈ xs, ∀ state tokens step rest, + (body x state tokens).result = some (step,rest) → + size (iterationState step) ≤ size state+delta) + (tokens : List CallerToken) : + (forIn xs initial body tokens).work ≤ + xs.length*(a*(size initial+delta*xs.length)+b) := by + induction xs generalizing initial tokens with + | nil => + simp only [List.forIn_nil,List.length_nil,Nat.mul_zero,Nat.zero_mul,pure_work] + exact Nat.le_refl _ + | cons x xs ih => + rw [List.forIn_cons] + let cap := a*(size initial+delta*(xs.length+1))+b + have before : (body x initial tokens).work ≤ cap := by + apply (bodyBound x (by simp) initial tokens).trans + apply Nat.add_le_add_right + exact Nat.mul_le_mul_left a (Nat.le_add_right _ _) + have bounded := bind_work_le (body x initial) + (fun step => match step with + | .done state => Pure.pure state + | .yield state => forIn xs state body) + tokens cap (xs.length*cap) before (by + intro step rest parsed + cases step with + | done state => + simp only [pure_work] + exact Nat.zero_le _ + | yield state => + have next := grows x (by simp) initial tokens (.yield state) rest parsed + have tailBound := ih state + (fun y member value tail => bodyBound y (by simp [member]) value tail) + (fun y member value tail outcome unused reached => + grows y (by simp [member]) value tail outcome unused reached) rest + apply tailBound.trans + apply Nat.mul_le_mul_left xs.length + apply Nat.add_le_add_right + apply Nat.mul_le_mul_left a + simp only [iterationState] at next + simp only [Nat.mul_add,Nat.mul_one] + omega) + simp only [List.length_cons] + convert bounded using 1 + simp only [cap,Nat.add_mul,Nat.one_mul,Nat.add_comm] + +#print axioms forIn_growth_work_le + +/-- Successful monadic list traversal preserves its exact input cardinality. -/ +theorem mapM_success_length {A B : Type} (xs : List A) (f : A → Parser B) + (tokens : List CallerToken) (ys : List B) (rest : List CallerToken) + (accepted : (xs.mapM f tokens).result = some (ys,rest)) : + ys.length = xs.length := by + induction xs generalizing tokens ys rest with + | nil => + simp only [List.mapM_nil] at accepted + change some ([],tokens) = some (ys,rest) at accepted + cases accepted + rfl + | cons x xs ih => + simp only [List.mapM_cons] at accepted + change (bind (f x) (fun y => bind (xs.mapM f) (fun tail => pure (y::tail))) + tokens).result = some (ys,rest) at accepted + cases first : (f x tokens).result with + | none => simp [bind,first] at accepted + | some pair => + rcases pair with ⟨y,middle⟩ + cases last : (xs.mapM f middle).result with + | none => simp [bind,first,last] at accepted + | some pair => + rcases pair with ⟨tail,remaining⟩ + have tailLength := ih middle tail remaining last + simp only [bind,first,last,pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + simpa using congrArg Nat.succ tailLength + +#print axioms mapM_success_length + +/-- The literal nested GKR body has linear work in its entering point. -/ +theorem gkrRound_work_le (point : List E) (tokens : List CallerToken) : + (gkrRound point tokens).work ≤ 47*point.length+93 := by + let entry : Nat → Parser E := fun _ => do + tick 2 + let _ ← readScalars 4 + drawScalar + have entryBound (i : Nat) (ts : List CallerToken) : (entry i ts).work ≤ 44 := by + dsimp only [entry] + rw [tick_bind_work] + have bound := bind_work_le (readScalars 4) (fun _ => drawScalar) ts 38 4 + (readScalars_work_le 4 ts) (by intro values rest parsed; exact drawScalar_work_le rest) + omega + have roundsBound (ts : List CallerToken) : + ((List.range point.length).mapM entry ts).work ≤ 44*point.length := by + simpa using mapM_work_le (List.range point.length) entry 44 + (fun i _ rest => entryBound i rest) ts + let finish : List E → Parser (List E) := fun rounds => do + let _ ← readScalars 8 + let low ← drawScalar + let high ← drawScalar + let _ ← drawScalar + tick 3 + pure (low::high::rounds) + have finishBound (rounds : List E) (ts : List CallerToken) : (finish rounds ts).work ≤ 89 := by + dsimp only [finish] + apply bind_work_le (readScalars 8) _ ts 74 15 (readScalars_work_le 8 ts) + intro values rest parsed + apply bind_work_le drawScalar _ rest 4 11 (drawScalar_work_le rest) + intro low rest parsed + apply bind_work_le drawScalar _ rest 4 7 (drawScalar_work_le rest) + intro high rest parsed + apply bind_work_le drawScalar _ rest 4 3 (drawScalar_work_le rest) + intro unused rest parsed + rw [tick_bind_work] + exact Nat.le_refl _ + have mainBound := bind_work_le ((List.range point.length).mapM entry) finish tokens + (44*point.length) 89 (roundsBound tokens) (by + intro rounds rest parsed + exact finishBound rounds rest) + change (bind ((List.range point.length).mapM entry) finish tokens).work ≤ + 44*point.length+89 at mainBound + unfold gkrRound + rw [tick_bind_work] + change lengthCost point+2*point.length+3+ + (bind ((List.range point.length).mapM entry) finish tokens).work ≤ _ + unfold lengthCost + omega + +#print axioms gkrRound_work_le +/-- Literal successful continuation decomposition, including its cursor. -/ +theorem bind_success_iff {A B : Type} (p : Parser A) (f : A → Parser B) + (tokens : List CallerToken) (value : B) (rest : List CallerToken) : + (bind p f tokens).result = some (value,rest) ↔ + ∃ before middle, (p tokens).result = some (before,middle) ∧ + (f before middle).result = some (value,rest) := by + cases hp : (p tokens).result with + | none => simp [bind,hp] + | some pair => + rcases pair with ⟨before,middle⟩ + simp [bind,hp] + +theorem gkrRound_success_length (point : List E) (tokens : List CallerToken) + (value : List E) (rest : List CallerToken) + (accepted : (gkrRound point tokens).result = some (value,rest)) : + value.length = point.length+2 := by + unfold gkrRound at accepted + change (bind (tick _) _ tokens).result = some (value,rest) at accepted + obtain ⟨tickValue,first,started,accepted⟩ := bind_success_iff _ _ _ _ _ |>.mp accepted + change some ((),tokens) = some (tickValue,first) at started + cases started + obtain ⟨rounds,middle,mapped,accepted⟩ := bind_success_iff _ _ _ _ _ |>.mp accepted + have length := mapM_success_length _ _ _ rounds middle mapped + obtain ⟨unused,next,read,accepted⟩ := bind_success_iff _ _ _ _ _ |>.mp accepted + obtain ⟨low,next,drawn,accepted⟩ := bind_success_iff _ _ _ _ _ |>.mp accepted + obtain ⟨high,next,drawn,accepted⟩ := bind_success_iff _ _ _ _ _ |>.mp accepted + obtain ⟨unused,next,drawn,accepted⟩ := bind_success_iff _ _ _ _ _ |>.mp accepted + obtain ⟨tickValue,last,ticked,accepted⟩ := bind_success_iff _ _ _ _ _ |>.mp accepted + change some ((),next) = some (tickValue,last) at ticked + cases ticked + change some (low::high::rounds,next) = some (value,rest) at accepted + cases accepted + simpa using congrArg (fun n : Nat => n+2) length + +#print axioms gkrRound_success_length + + +#print axioms readScalars_work_le +#print axioms drawScalars_work_le +end Whir.PCSBCSCallerParserCost diff --git a/verification/whir/Whir/PCSBCSCallerPayloadCost.lean b/verification/whir/Whir/PCSBCSCallerPayloadCost.lean new file mode 100644 index 000000000..031a06176 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerPayloadCost.lean @@ -0,0 +1,1481 @@ +import Whir.PCSBCSCallerParserCost +import Whir.AnchoredSourceFreshCaller + +/-! Reached source-operation accounting for the historical payload and anchored +record transport. The units are source operations, not CPU time: a pattern, +branch, scalar/Nat operation, projection, or constructor costs one. List +traversals are charged per visited cons and their terminal nil; append charges +its copied left spine. Indexed list lookup charges the visited prefix, including +failure. Array lookup and fixed-width field operations are primitive operations. +Opaque CPU output evaluation is charged separately, once at each of its four +reached calls. No transcript, sampler, or output cache is re-executed. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCallerPayloadCost +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 + +structure OutputCosts where + call : Fin 4 → Nat + pending : Fin 8 → Nat + rootByte : Fin 32 → Nat + contextByte : Fin 32 → Nat + +def OutputCosts.total (cost : OutputCosts) : Nat := + (List.ofFn cost.call).sum + +def OutputCosts.zero : OutputCosts := ⟨fun _ => 0,fun _ => 0,fun _ => 0,fun _ => 0⟩ + +@[simp] theorem erase_someFirst {A B : Type} (x : Option A) + (yes : A → PCSBCSCallerParserCost.Parser B) (no : PCSBCSCallerParserCost.Parser B) : + PCSBCSCallerParserCost.erase (match x with | some a => yes a | _ => no) = + match x with | some a => PCSBCSCallerParserCost.erase (yes a) + | none => PCSBCSCallerParserCost.erase no := by + cases x <;> rfl + +/-- Charge an evaluated pure source expression without changing the cursor. -/ +def charged {A : Type} (work : Nat) (value : A) : PCSBCSCallerParserCost.Parser A := do + PCSBCSCallerParserCost.tick work + pure value + +@[simp] theorem erase_charged {A : Type} (work : Nat) (value : A) : + PCSBCSCallerParserCost.erase (charged work value) = pure value := by + simp [charged] + +/-- Short-circuit predicate traversal, including predicate and branch costs. -/ +def allWork {A : Type} (p : A → Bool) (predicateWork : A → Nat) : List A → Nat + | [] => 1 + | x :: xs => 2 + predicateWork x + if p x then allWork p predicateWork xs else 0 + +def containsWork (x : Nat) : List Nat → Nat + | [] => 1 + | y :: ys => 3 + if x == y then 0 else containsWork x ys + +def indexWork {A : Type} : List A → Nat → Nat + | [], _ => 1 + | _ :: _, 0 => 2 + | _ :: xs, n+1 => 2 + indexWork xs n + +def dupsWork : List Nat → List Nat → Nat + | [], seen => 2 * seen.length + 2 + | x :: xs, seen => 2 + containsWork x seen + + if seen.contains x then dupsWork xs seen else 1 + dupsWork xs (x :: seen) + +/-- Literal six-bit register coordinates; each range/map cell, testBit, branch, +field literal, and claim constructor is charged. The opaque getter is separate. -/ +def exitClaims (column : Nat) (output : Fin 4 → UInt64) (cost : OutputCosts) : + PCSBCSCallerParserCost.Costed (List ColumnClaim) := + ⟨WHIRCallerClaims.exitClaims column output, + 5 * (1 + (6 * 3 + 1) + (6 * 5 + 1)) + 4 * (1 + 1 + 1) + 14 + cost.total⟩ + +@[simp] theorem exitClaims_erasure (column : Nat) (output : Fin 4 → UInt64) + (cost : OutputCosts) : (exitClaims column output cost).value = WHIRCallerClaims.exitClaims column output := rfl + +theorem exitClaims_work (column : Nat) (output : Fin 4 → UInt64) (cost : OutputCosts) : + (exitClaims column output cost).work = 281 + cost.total := rfl + +theorem exitClaims_length (column : Nat) (output : Fin 4 → UInt64) (cost : OutputCosts) : + (exitClaims column output cost).value.length = 5 := by + simp [exitClaims,WHIRCallerClaims.exitClaims] + +theorem exitClaims_values (column : Nat) (output : Fin 4 → UInt64) (cost : OutputCosts) : + ((exitClaims column output cost).value.map ColumnClaim.value) = + E.ofK 93 :: List.ofFn (fun i => E.ofK (output i)) := by + simp [exitClaims,WHIRCallerClaims.exitClaims] + +def columnsWork (bus : List ColumnClaim) (paired : List (Nat × TableClaims)) : Nat := + 2 * bus.length + 1 + paired.length + 1 + + (paired.map (fun (base,claims) => + (PCSBCSCallerParserCost.tableColumns base claims).work + 2 * claims.evals.length + 1)).sum + +def recPayload (layout : RecLayout) : + PCSBCSCallerParserCost.Parser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) := do + let (point,bus) ← PCSBCSCallerParserCost.busClaims layout.bus + let _ ← PCSBCSCallerParserCost.drawScalar + let airs ← charged (3 * layout.tables.length + 1) (layout.tables.map Prod.snd) + let tables ← PCSBCSCallerParserCost.constraintClaims airs point + let rings ← PCSBCSCallerParserCost.flockClaims [layout.hash] + let paired := (layout.tables.map Prod.fst).zip tables + let columns ← charged (3 * layout.tables.length + 1 + 4 * min layout.tables.length tables.length + 1 + + columnsWork bus paired) + (bus ++ paired.flatMap (fun (base,claims) => WHIRCallerClaims.tableColumns base claims)) + let placed := PCSBCSCallerParserCost.placeClaims layout.placements columns + let points ← PCSBCSCallerParserCost.liftOption placed.work placed.value + pure (rings,points) + +def settledClaims (tables : List CpuTableLayout) (point : List E) : PCSBCSCallerParserCost.Parser (List TableClaims) := do + let mut claims := [] + for table in tables do + PCSBCSCallerParserCost.tick 2 + if table.settled then + PCSBCSCallerParserCost.tick (allWork (· < table.committedColumns) (fun _ => 2) table.summedColumns) + PCSBCSCallerParserCost.check (table.summedColumns.all (· < table.committedColumns)) + PCSBCSCallerParserCost.tick (dupsWork table.summedColumns [] + table.summedColumns.eraseDups.length + 1 + + table.summedColumns.length + 1 + 1) + PCSBCSCallerParserCost.check (table.summedColumns.eraseDups.length == table.summedColumns.length) + PCSBCSCallerParserCost.tick (table.summedColumns.length + 2) + let sent ← PCSBCSCallerParserCost.readScalars (table.committedColumns-table.summedColumns.length) + let mut remaining := sent + let mut evals := [] + PCSBCSCallerParserCost.tick (3 * table.committedColumns + 1) + for c in List.range table.committedColumns do + PCSBCSCallerParserCost.tick (1 + containsWork c table.summedColumns + 2 * evals.length + 2) + if c ∈ table.summedColumns then evals := evals ++ [0] + else + match remaining with + | [] => PCSBCSCallerParserCost.check false + | x :: xs => evals := evals ++ [x]; remaining := xs + PCSBCSCallerParserCost.tick (point.length + 4) + PCSBCSCallerParserCost.check (table.tau ≤ point.length && remaining.isEmpty) + PCSBCSCallerParserCost.tick (2 * min table.tau point.length + 1 + 2 * claims.length + 3) + claims := claims ++ [⟨point.take table.tau,evals,[]⟩] + pure claims + +def cpuPayloadBeforeExit (layout : CpuLayout) : + PCSBCSCallerParserCost.Parser (List RingPCSGame.FamilyClaim × List ColumnClaim) := do + let (point,bus) ← PCSBCSCallerParserCost.busClaims layout.bus + let settled ← settledClaims layout.tables point + let _ ← PCSBCSCallerParserCost.drawScalar + let producerAirs ← charged (7 * layout.bus.producers.length + 1) + (layout.bus.producers.map (fun p => (⟨p.kappa,2*p.bits,p.bits,[]⟩ : AirLayout))) + let airs ← charged (8 * layout.tables.length + + (layout.tables.map (fun t => t.summedColumns.length + 1)).sum + 2) + (layout.tables.map CpuTableLayout.air ++ producerAirs) + let summed ← PCSBCSCallerParserCost.constraintClaims airs point + PCSBCSCallerParserCost.tick (settled.length + 1 + 2 * min settled.length layout.tables.length + 1 + + allWork (·.settled) (fun _ => 1) (layout.tables.take settled.length)) + PCSBCSCallerParserCost.check (layout.tables.take settled.length |>.all (·.settled)) + PCSBCSCallerParserCost.tick (settled.length + 1 + min settled.length layout.tables.length + 1 + + allWork (! ·.settled) (fun _ => 2) (layout.tables.drop settled.length)) + PCSBCSCallerParserCost.check (layout.tables.drop settled.length |>.all (! ·.settled)) + let columns ← charged (layout.tables.length + 1 + 2 * min layout.tables.length summed.length + 1 + + settled.length + 1 + min settled.length (min layout.tables.length summed.length) + 1 + + 2 * settled.length + 1) (settled ++ (summed.take layout.tables.length).drop settled.length) + let packed ← PCSBCSCallerParserCost.flockClaims layout.flock + let producers ← charged (layout.tables.length + 1 + min layout.tables.length summed.length + 1) + (summed.drop layout.tables.length) + PCSBCSCallerParserCost.tick (4 * min layout.bus.producers.length producers.length + 1) + let mut rings := packed + for (p,c) in layout.bus.producers.zip producers do + let ring := PCSBCSCallerParserCost.paddedRing p.window c.point c.evals + PCSBCSCallerParserCost.tick (1 + ring.work) + match ring.value with + | some ring => PCSBCSCallerParserCost.tick (2 * rings.length + 2); rings := rings ++ [ring] + | none => PCSBCSCallerParserCost.check false + for word in layout.registers do + PCSBCSCallerParserCost.tick 2 + let some first := word.tables.head? | return ← PCSBCSCallerParserCost.liftOption 1 none + PCSBCSCallerParserCost.tick (indexWork summed first) + let some firstClaims := summed[first]? | return ← PCSBCSCallerParserCost.liftOption 1 none + let mut slices := [] + for t in word.tables do + PCSBCSCallerParserCost.tick (1 + indexWork summed t) + let some claims := summed[t]? | return ← PCSBCSCallerParserCost.liftOption 1 none + PCSBCSCallerParserCost.tick (2 * slices.length + 2) + slices := slices ++ claims.slices + let ring := PCSBCSCallerParserCost.paddedRing word.offset firstClaims.point slices + PCSBCSCallerParserCost.tick ring.work + match ring.value with + | some ring => PCSBCSCallerParserCost.tick (2 * rings.length + 2); rings := rings ++ [ring] + | none => PCSBCSCallerParserCost.check false + let paired := (layout.tables.map CpuTableLayout.base).zip columns + let columnClaims ← charged (3 * layout.tables.length + 1 + + 4 * min layout.tables.length columns.length + 1 + columnsWork bus paired) + (bus ++ paired.flatMap (fun (base,claims) => WHIRCallerClaims.tableColumns base claims)) + pure (rings,columnClaims) + +def cpuPayload (layout : CpuLayout) (cost : OutputCosts) : + PCSBCSCallerParserCost.Parser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) := do + let (rings,columns) ← cpuPayloadBeforeExit layout + let exits := exitClaims layout.finalRegisterColumn layout.output cost + let columnClaims ← charged (exits.work + 2 * columns.length + 1) (columns ++ exits.value) + let placed := PCSBCSCallerParserCost.placeClaims layout.placements columnClaims + let points ← PCSBCSCallerParserCost.liftOption placed.work placed.value + pure (rings,points) + +/-- This is the reached callback trace: the four indices are present exactly +when the ordinary caller reached exit construction, even if placement rejects. -/ +def outputGetterTrace (layout : CpuLayout) (tokens : List CallerToken) : List (Fin 4) := + if (cpuPayloadBeforeExit layout tokens).result.isSome then List.finRange 4 else [] + +theorem outputGetterTrace_length (layout : CpuLayout) (tokens : List CallerToken) : + (outputGetterTrace layout tokens).length = + if (cpuPayloadBeforeExit layout tokens).result.isSome then 4 else 0 := by + unfold outputGetterTrace + split <;> simp + +theorem outputGetterTrace_cost (layout : CpuLayout) (tokens : List CallerToken) (cost : OutputCosts) : + ((outputGetterTrace layout tokens).map cost.call).sum = + if (cpuPayloadBeforeExit layout tokens).result.isSome then cost.total else 0 := by + unfold outputGetterTrace + split <;> simp [List.finRange,OutputCosts.total] + + +def readAnnouncements : List Nat → PCSBCSCallerParserCost.Parser Unit + | [] => do PCSBCSCallerParserCost.tick 1; pure () + | height :: rest => do + PCSBCSCallerParserCost.tick 1 + let sent ← PCSBCSCallerParserCost.readScalar + PCSBCSCallerParserCost.tick 5 + PCSBCSCallerParserCost.check (sent == E.ofK (UInt64.ofNat height)) + readAnnouncements rest + +def prelude : CallerLayout → PCSBCSCallerParserCost.Parser Unit + | .recursion _ => do PCSBCSCallerParserCost.tick 1; pure () + | .cpu layout => do + PCSBCSCallerParserCost.tick (layout.tables.length + 3) + PCSBCSCallerParserCost.check (layout.tables.length == 11) + let heights ← charged (3 * layout.tables.length + 2) + (layout.tables.map CpuTableLayout.tau ++ [layout.logInvRate]) + readAnnouncements heights + let clock ← PCSBCSCallerParserCost.readScalar + PCSBCSCallerParserCost.tick (3 + (if clock.c1 == 0 then + 3 + (if clock.c2 == 0 then 125 + (if clock.c0.toNat / 2^40 == 1 then 4 else 0) else 0) else 0)) + PCSBCSCallerParserCost.check + (clock.c1 == 0 && clock.c2 == 0 && clock.c0.toNat / 2^40 == 1 && clock.c0.toNat % 32 == 0) + +def wordsWork (layout : CallerLayout) : Nat := + 3 + ((callerPlacements layout).toList.map (fun p => match p with + | .committed _ d => 3 * d + 5 + | _ => 2)).sum + +/-- Layout arithmetic includes every placement visit, repeated power, log2 +argument, and lane division; no supplied geometry certificate is evaluated. -/ +def shapeWork (layout : CallerLayout) : Nat := + let w := callerWords layout + let m := callerMu layout + 3 * wordsWork layout + 2 * (max w 1 - 1) + 3 * (m - 6) + 26 + +def scalarEqWork (x y : E) : Nat := + 4 + if x.c0 == y.c0 then 4 + if x.c1 == y.c1 then 4 else 0 else 0 + +def headerWork (shape : Shape) : List E → Nat + | [marker,sh,lanes,a,b] => + 6 + scalarEqWork marker anchorMarker + + if marker = anchorMarker then 4 + scalarEqWork sh (shapeScalar shape) + + if sh = shapeScalar shape then 2 + scalarEqWork lanes (lanesScalar shape) + + if lanes = lanesScalar shape then 2 + + if a.c2 = 0 then 2 + if b.c2 = 0 then 2 else 0 else 0 + else 0 + else 0 + else 0 + | _ => 1 + +def shapeValidWork (shape : Shape) : Nat := + 4 + if shape.logBatch < shape.logN then + 3 + if shape.logN < 64 then + 3 + if 1 ≤ shape.logRate then + 7 + if shape.logN - shape.logBatch + shape.logRate < 64 then + 3 + if 1 ≤ shape.lanes then 3 * shape.logBatch + 4 else 0 + else 0 + else 0 + else 0 + else 0 + +def receive (layout : CallerLayout) (original : Context) : + PCSBCSCallerParserCost.Parser Record := do + PCSBCSCallerParserCost.tick (shapeWork layout + shapeValidWork (AnchoredSourceCaller.shape layout)) + PCSBCSCallerParserCost.check (decide (AnchoredSourceCaller.shape layout).Valid) + let header ← PCSBCSCallerParserCost.readScalars 5 + PCSBCSCallerParserCost.tick (shapeWork layout + headerWork (AnchoredSourceCaller.shape layout) header) + let some root := parseHeader (AnchoredSourceCaller.shape layout) header | + return ← PCSBCSCallerParserCost.liftOption 1 none + PCSBCSCallerParserCost.tick (shapeWork layout + 1) + let point ← PCSBCSCallerParserCost.drawScalars (AnchoredSourceCaller.shape layout).logN + let value ← PCSBCSCallerParserCost.readScalar + PCSBCSCallerParserCost.tick (shapeWork layout + 1) + pure ⟨AnchoredSourceCaller.shape layout,root,original,point,value⟩ + +def payload (layout : CallerLayout) (cost : OutputCosts) : + PCSBCSCallerParserCost.Parser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) := + match layout with + | .recursion l => recPayload l + | .cpu l => cpuPayload l cost + +theorem sumMap_le {A : Type} (xs : List A) (f : A → Nat) (k : Nat) + (bound : ∀ x ∈ xs, f x ≤ k) : (xs.map f).sum ≤ k * xs.length := by + induction xs with + | nil => simp + | cons x xs ih => + have hx := bound x (by simp) + have ht := ih (fun y hy => bound y (by simp [hy])) + simp only [List.map_cons,List.sum_cons,List.length_cons] + nlinarith +/-- Each live pending pack pays its range cell and three word accesses, Nat +index arithmetic and branches. Fixed digest decoding pays four eight-byte +folds per digest (read, projection, shift, addition at each byte). -/ +def pendingPackWork (context : Context) (i : Nat) : Nat := + 23 + (if 3 * i + 1 < (context.pendingBytes + 7) / 8 then 6 else 1) + + (if 3 * i + 2 < (context.pendingBytes + 7) / 8 then 6 else 1) + +theorem pendingPackWork_le (context : Context) (i : Nat) : pendingPackWork context i ≤ 35 := by + simp only [pendingPackWork] + split <;> split <;> omega + +def openingWork (record : Record) : Nat := + let packs := (record.context.pendingBytes + 23) / 24 + 4 * (4 * (8 * 4 + 2) + 3) + 17 + + (3 * packs + 1) + ((List.range packs).map (pendingPackWork record.context)).sum + 1 + + 19 + (2 * packs + 1) + (2 * record.point.length + 1) + + +def scalarListEqWork : List E → List E → Nat + | [], _ => 1 + | _ :: _, [] => 1 + | x :: xs, y :: ys => 2 + scalarEqWork x y + if x == y then scalarListEqWork xs ys else 0 + +/-- Actual opaque pending-word accesses in one `pendingPacks` construction. +The source modulo-eight indices are retained even for non-normalized inputs. -/ +def pendingPackGetterTrace (context : Context) (i : Nat) : List (Fin 8) := + [⟨3*i % 8,Nat.mod_lt _ (by decide)⟩] ++ + (if 3*i+1 < (context.pendingBytes+7)/8 then + [⟨(3*i+1)%8,Nat.mod_lt _ (by decide)⟩] else []) ++ + (if 3*i+2 < (context.pendingBytes+7)/8 then + [⟨(3*i+2)%8,Nat.mod_lt _ (by decide)⟩] else []) + +def pendingGetterTrace (context : Context) : List (Fin 8) := + (List.range ((context.pendingBytes+23)/24)).flatMap (pendingPackGetterTrace context) + +def pendingGetterWork (context : Context) (cost : OutputCosts) : Nat := + ((pendingGetterTrace context).map cost.pending).sum + +/-- The two tuple projections each execute the complete 32-byte decoder. -/ +def digestGetterTrace : List (Fin 32) := List.finRange 32 ++ List.finRange 32 + +def openingGetterWork (record : Record) (cost : OutputCosts) : Nat := + pendingGetterWork record.context cost + (digestGetterTrace.map cost.rootByte).sum + + (digestGetterTrace.map cost.contextByte).sum + +def binding (record : Record) (cost : OutputCosts) : PCSBCSCallerParserCost.Parser Unit := do + PCSBCSCallerParserCost.tick (openingWork record + openingGetterWork record cost + (openingScalars record).length + 1) + let frame ← PCSBCSCallerParserCost.readScalars (openingScalars record).length + PCSBCSCallerParserCost.tick (openingWork record + openingGetterWork record cost + scalarListEqWork frame (openingScalars record)) + PCSBCSCallerParserCost.check (frame == openingScalars record) + +@[simp] theorem binding_ignore_output_prices (record : Record) (cost : OutputCosts) + (calls : Fin 4 → Nat) : + binding record {cost with call := calls} = binding record cost := rfl +def sourceClaims (layout : CallerLayout) (original : Context) (cost : OutputCosts) : + PCSBCSCallerParserCost.Parser AnchoredSourceCaller.Claims := do + prelude layout + let record ← receive layout original + let (families,points) ← payload layout cost + binding record cost + PCSBCSCallerParserCost.tick 3 + pure ⟨record,⟨record.root,families,points⟩⟩ + +def freshSourceClaims (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + PCSBCSCallerParserCost.Parser AnchoredSourceCaller.Claims := do + let (families,points) ← payload layout cost + binding saved cost + PCSBCSCallerParserCost.tick 3 + pure ⟨saved,⟨saved.root,families,points⟩⟩ + +@[simp] theorem readAnnouncements_erasure (heights : List Nat) : + PCSBCSCallerParserCost.erase (readAnnouncements heights) = WHIRCallerClaims.readAnnouncements heights := by + induction heights with + | nil => simp [readAnnouncements,WHIRCallerClaims.readAnnouncements] + | cons x xs ih => simp [readAnnouncements,WHIRCallerClaims.readAnnouncements,ih] + +@[simp] theorem prelude_erasure (layout : CallerLayout) : + PCSBCSCallerParserCost.erase (prelude layout) = AnchoredSourceCaller.prelude layout := by + cases layout <;> simp [prelude,AnchoredSourceCaller.prelude] + +@[simp] private theorem sourceFailure_bind {A B : Type} (f : A → CallerParser B) : + ((fun _ => none : CallerParser A) >>= f) = (fun _ => none : CallerParser B) := rfl + +@[simp] private theorem sourceFailure_map {A B : Type} (f : A → B) : + (@Functor.map CallerParser _ A B f (fun _ => none)) = + (fun _ => none : CallerParser B) := rfl +@[simp] theorem receive_erasure (layout : CallerLayout) (original : Context) : + PCSBCSCallerParserCost.erase (receive layout original) = AnchoredSourceCaller.receive layout original := by + simp [receive,AnchoredSourceCaller.receive] + congr! 8 + all_goals split <;> simp_all + +@[simp] theorem binding_erasure (record : Record) (cost : OutputCosts) : + PCSBCSCallerParserCost.erase (binding record cost) = AnchoredSourceCaller.binding record := by + simp [binding,AnchoredSourceCaller.binding] + +@[simp] theorem recPayload_erasure (layout : RecLayout) : + PCSBCSCallerParserCost.erase (recPayload layout) = WHIRCallerClaims.recPayload layout := by + simp [recPayload,WHIRCallerClaims.recPayload] + congr! 12 + all_goals try (split <;> simp_all) + +@[simp] theorem settledClaims_erasure (tables : List CpuTableLayout) (point : List E) : + PCSBCSCallerParserCost.erase (settledClaims tables point) = + WHIRCallerClaims.settledClaims tables point := by + simp [settledClaims,WHIRCallerClaims.settledClaims] + congr! 20 + all_goals split <;> simp_all + +/- The source's early-return desugaring carries an `Option finalResult` through +the register loops. Every attempted early return first executes the failing +parser. These helpers remove that unreachable carrier without assuming +acceptance or changing failures/cursors. -/ + +@[simp] private theorem erase_catchAll {A B : Type} (x : Option A) + (yes : A → PCSBCSCallerParserCost.Parser B) + (no : Option A → PCSBCSCallerParserCost.Parser B) : + PCSBCSCallerParserCost.erase (match x with | some a => yes a | missing => no missing) = + match x with | some a => PCSBCSCallerParserCost.erase (yes a) + | missing => PCSBCSCallerParserCost.erase (no missing) := by + cases x <;> rfl + + +private theorem sourceForIn_none {A B R : Type} (xs : List A) (initial : B) + (step : A → B → CallerParser B) : + forIn xs ((none : Option R),initial) (fun a state => do + let next ← step a state.2 + pure (.yield (none,next))) = + (do let last ← forIn xs initial (fun a value => do + let next ← step a value + pure (.yield next)) + pure (none,last)) := by + induction xs generalizing initial with + | nil => simp + | cons x xs ih => + simp only [List.forIn_cons,bind_assoc,pure_bind] + simp only [ih] + +private def sourceSliceStep (summed : List TableClaims) (t : Nat) (slices : List E) : + CallerParser (List E) := + match summed[t]? with + | some claims => pure (slices ++ claims.slices) + | none => fun _ => none + +private def sourceSlices (summed : List TableClaims) (tables : List Nat) (slices : List E) : + CallerParser (List E) := + forIn tables slices (fun t slices => do + let next ← sourceSliceStep summed t slices + pure (.yield next)) + +private def sourceSliceLoop {R : Type} (summed : List TableClaims) (tables : List Nat) + (slices : List E) : CallerParser (Option R × List E) := + forIn tables (none,slices) (fun t state => + match summed[t]? with + | some claims => pure (.yield (none,state.2 ++ claims.slices)) + | none => do + let out ← (fun _ => none : CallerParser R) + pure (.done (some out,state.2))) + +private theorem sourceSliceLoop_eq {R : Type} (summed : List TableClaims) (tables : List Nat) + (slices : List E) : sourceSliceLoop (R := R) summed tables slices = + forIn tables (none,slices) (fun t state => + match summed[t]? with + | some claims => pure (.yield (none,state.2 ++ claims.slices)) + | _missing => fun _ => none) := by + unfold sourceSliceLoop + congr 1 + funext t state + cases summed[t]? <;> simp + +private theorem sourceSliceLoop_normalize {R : Type} (summed : List TableClaims) + (tables : List Nat) (slices : List E) : + sourceSliceLoop (R := R) summed tables slices = + (do let out ← sourceSlices summed tables slices; pure (none,out)) := by + have body : (fun (t : Nat) (state : Option R × List E) => + show CallerParser (ForInStep (Option R × List E)) from match summed[t]? with + | some claims => pure (.yield (none,state.2 ++ claims.slices)) + | none => do + let out ← (fun _ => none : CallerParser R) + pure (.done (some out,state.2))) = + (fun t state => show CallerParser (ForInStep (Option R × List E)) from do + let next ← sourceSliceStep summed t state.2 + pure (.yield (none,next))) := by + funext t state + cases h : summed[t]? <;> simp [sourceSliceStep,h] + unfold sourceSliceLoop + rw [body,sourceForIn_none] + rfl + +private def sourceRegisterStep (summed : List TableClaims) (word : RegisterWord) + (rings : List RingPCSGame.FamilyClaim) : CallerParser (List RingPCSGame.FamilyClaim) := + match word.tables.head? with + | none => fun _ => none + | some first => match summed[first]? with + | none => fun _ => none + | some firstClaims => do + let slices ← sourceSlices summed word.tables [] + match WHIRCallerClaims.paddedRing word.offset firstClaims.point slices with + | some ring => pure (rings ++ [ring]) + | none => do WHIRCallerClaims.check false; pure rings + +private def sourceRegisterLoop {R : Type} (summed : List TableClaims) + (words : List RegisterWord) (rings : List RingPCSGame.FamilyClaim) : + CallerParser (Option R × List RingPCSGame.FamilyClaim) := + forIn words (none,rings) (fun word state => + match word.tables.head? with + | some first => match summed[first]? with + | some firstClaims => do + let pair ← sourceSliceLoop summed word.tables [] + match pair.1 with + | some out => pure (.done (some out,state.2)) + | none => match WHIRCallerClaims.paddedRing word.offset firstClaims.point pair.2 with + | some ring => pure (.yield (none,state.2 ++ [ring])) + | none => do WHIRCallerClaims.check false; pure (.yield (none,state.2)) + | none => do + let out ← (fun _ => none : CallerParser R) + pure (.done (some out,state.2)) + | none => do + let out ← (fun _ => none : CallerParser R) + pure (.done (some out,state.2))) + +private theorem sourceRegisterLoop_eq {R : Type} (summed : List TableClaims) + (words : List RegisterWord) (rings : List RingPCSGame.FamilyClaim) : + sourceRegisterLoop (R := R) summed words rings = + forIn words (none,rings) (fun word state => + match word.tables.head? with + | some first => match summed[first]? with + | some firstClaims => do + let pair ← sourceSliceLoop summed word.tables [] + match pair.1 with + | some out => pure (.done (some out,state.2)) + | none => match WHIRCallerClaims.paddedRing word.offset firstClaims.point pair.2 with + | some ring => pure (.yield (none,state.2 ++ [ring])) + | none => do WHIRCallerClaims.check false; pure (.yield (none,state.2)) + | _missing => fun _ => none + | _missing => fun _ => none) := by + unfold sourceRegisterLoop + congr 1 + funext word state + cases h : word.tables.head? with + | none => simp + | some first => + cases hc : summed[first]? <;> simp [hc] + +private theorem sourceRegisterLoop_normalize {R : Type} (summed : List TableClaims) + (words : List RegisterWord) (rings : List RingPCSGame.FamilyClaim) : + sourceRegisterLoop (R := R) summed words rings = + (do let out ← forIn words rings (fun word rings => do + let next ← sourceRegisterStep summed word rings + pure (.yield next)) + pure (none,out)) := by + unfold sourceRegisterLoop + simp only [sourceSliceLoop_normalize,bind_assoc,pure_bind] + have body : (fun (word : RegisterWord) (state : Option R × List RingPCSGame.FamilyClaim) => + show CallerParser (ForInStep (Option R × List RingPCSGame.FamilyClaim)) from match word.tables.head? with + | some first => match summed[first]? with + | some firstClaims => do + let slices ← sourceSlices summed word.tables [] + match WHIRCallerClaims.paddedRing word.offset firstClaims.point slices with + | some ring => pure (.yield (none,state.2 ++ [ring])) + | none => do WHIRCallerClaims.check false; pure (.yield (none,state.2)) + | none => fun _ => none + | none => fun _ => none) = + (fun word state => show CallerParser (ForInStep (Option R × List RingPCSGame.FamilyClaim)) from do + let next ← sourceRegisterStep summed word state.2 + pure (.yield (none,next))) := by + funext word state + cases h : word.tables.head? with + | none => simp [h,sourceRegisterStep] + | some first => + cases hc : summed[first]? with + | none => simp [h,hc,sourceRegisterStep] + | some claims => + simp only [h,hc,sourceRegisterStep] + simp only [bind_assoc] + congr 1 + funext slices + cases hr : WHIRCallerClaims.paddedRing word.offset claims.point slices <;> + simp [WHIRCallerClaims.check] + simp only [sourceFailure_bind] + rw [body,sourceForIn_none] + +private def sourceRegisterRaw {R : Type} (summed : List TableClaims) + (words : List RegisterWord) (rings : List RingPCSGame.FamilyClaim) : + CallerParser (Option R × List RingPCSGame.FamilyClaim) := + forIn words (none,rings) (fun word state => + match word.tables.head? with + | some first => match summed[first]? with + | some firstClaims => do + let pair ← forIn word.tables (none,[]) (fun t state => + match summed[t]? with + | some claims => pure (.yield (none,state.2 ++ claims.slices)) + | _missing => fun _ => none) + match pair.1 with + | some out => pure (.done (some out,state.2)) + | none => match WHIRCallerClaims.paddedRing word.offset firstClaims.point pair.2 with + | some ring => pure (.yield (none,state.2 ++ [ring])) + | none => do WHIRCallerClaims.check false; pure (.yield (none,state.2)) + | _missing => fun _ => none + | _missing => fun _ => none) + +private theorem sourceRegisterRaw_eq {R : Type} (summed : List TableClaims) + (words : List RegisterWord) (rings : List RingPCSGame.FamilyClaim) : + sourceRegisterRaw (R := R) summed words rings = sourceRegisterLoop summed words rings := by + unfold sourceRegisterRaw + rw [sourceRegisterLoop_eq] + congr 1 + funext word state + cases head : word.tables.head? with + | none => simp + | some first => + cases claimed : summed[first]? with + | none => simp [claimed] + | some claims => + simp only [claimed] + rw [sourceSliceLoop_eq] + +private def countedSliceRaw {R : Type} (summed : List TableClaims) (tables : List Nat) + (slices : List E) : PCSBCSCallerParserCost.Parser (Option R × List E) := + forIn tables (none,slices) (fun t state => do + PCSBCSCallerParserCost.tick (1 + indexWork summed t) + match summed[t]? with + | some claims => do + PCSBCSCallerParserCost.tick (2 * state.2.length + 2) + pure (.yield (none,state.2 ++ claims.slices)) + | _missing => do + let out ← PCSBCSCallerParserCost.liftOption 1 none + pure (.done (some out,state.2))) + +private theorem countedSliceRaw_erasure {R : Type} (summed : List TableClaims) + (tables : List Nat) (slices : List E) : + PCSBCSCallerParserCost.erase (countedSliceRaw (R := R) summed tables slices) = + sourceSliceLoop summed tables slices := by + simp only [countedSliceRaw,PCSBCSCallerParserCost.erase_forIn] + unfold sourceSliceLoop + congr 1 + funext t state + cases summed[t]? <;> simp + +private def countedRegisterRaw {R : Type} (summed : List TableClaims) + (words : List RegisterWord) (rings : List RingPCSGame.FamilyClaim) : + PCSBCSCallerParserCost.Parser (Option R × List RingPCSGame.FamilyClaim) := + forIn words (none,rings) (fun word state => + match word.tables.head? with + | some first => do + PCSBCSCallerParserCost.tick (indexWork summed first) + match summed[first]? with + | some firstClaims => do + let pair ← countedSliceRaw summed word.tables [] + match pair.1 with + | some out => pure (.done (some out,state.2)) + | none => do + PCSBCSCallerParserCost.tick + (PCSBCSCallerParserCost.paddedRing word.offset firstClaims.point pair.2).work + match WHIRCallerClaims.paddedRing word.offset firstClaims.point pair.2 with + | some ring => do + PCSBCSCallerParserCost.tick (2 * state.2.length + 2) + pure (.yield (none,state.2 ++ [ring])) + | none => do PCSBCSCallerParserCost.check false; pure (.yield (none,state.2)) + | _missing => do + let out ← PCSBCSCallerParserCost.liftOption 1 none + pure (.done (some out,state.2)) + | _missing => do + let out ← PCSBCSCallerParserCost.liftOption 1 none + pure (.done (some out,state.2))) + +private theorem countedRegisterRaw_erasure {R : Type} (summed : List TableClaims) + (words : List RegisterWord) (rings : List RingPCSGame.FamilyClaim) : + PCSBCSCallerParserCost.erase (countedRegisterRaw (R := R) summed words rings) = + sourceRegisterLoop summed words rings := by + simp only [countedRegisterRaw,PCSBCSCallerParserCost.erase_forIn] + unfold sourceRegisterLoop + congr 1 + funext word state + cases head : word.tables.head? with + | none => simp + | some first => + cases claimed : summed[first]? with + | none => simp [claimed] + | some claims => + simp only [claimed] + simp only [PCSBCSCallerParserCost.erase_bind,PCSBCSCallerParserCost.tick_erasure, + pure_bind,countedSliceRaw_erasure] + congr 1 + funext pair + cases branch : pair.1 with + | some out => simp + | none => + cases WHIRCallerClaims.paddedRing word.offset claims.point pair.2 <;> simp + +@[simp] theorem cpuPayload_erasure (layout : CpuLayout) (cost : OutputCosts) : + PCSBCSCallerParserCost.erase (cpuPayload layout cost) = WHIRCallerClaims.cpuPayload layout := by + simp [cpuPayload,cpuPayloadBeforeExit,WHIRCallerClaims.cpuPayload,bind_assoc] + congr 1 + funext bus + congr 1 + funext settled + congr 1 + funext coin + congr 1 + funext summed + simp_rw [← bind_pure_comp] + congr! 10 + · rename_i _ _ producer rings + cases WHIRCallerClaims.paddedRing producer.1.window producer.2.point producer.2.evals <;> + simp + · rename_i _ _ rings + conv_rhs => + lhs + change sourceRegisterRaw (R := List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) + summed layout.registers rings + rw [sourceRegisterRaw_eq,sourceRegisterLoop_normalize] + conv_lhs => + lhs + rw [←PCSBCSCallerParserCost.erase_forIn] + change PCSBCSCallerParserCost.erase + (countedRegisterRaw (R := List RingPCSGame.FamilyClaim × List ColumnClaim) + summed layout.registers rings) + rw [countedRegisterRaw_erasure,sourceRegisterLoop_normalize] + simp only [bind_assoc,pure_bind] + congr 1 + funext out + simp + split <;> simp_all + +@[simp] theorem payload_erasure (layout : CallerLayout) (cost : OutputCosts) : + PCSBCSCallerParserCost.erase (payload layout cost) = AnchoredSourceCaller.payload layout := by + cases layout <;> simp [payload,AnchoredSourceCaller.payload] + +@[simp] theorem sourceClaims_erasure (layout : CallerLayout) (original : Context) (cost : OutputCosts) : + PCSBCSCallerParserCost.erase (sourceClaims layout original cost) = + AnchoredSourceCaller.sourceClaims layout original := by + simp [sourceClaims,AnchoredSourceCaller.sourceClaims] + +@[simp] theorem freshSourceClaims_erasure (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + PCSBCSCallerParserCost.erase (freshSourceClaims layout saved cost) = + AnchoredSourceFreshCaller.sourceClaims layout saved := by + simp [freshSourceClaims,AnchoredSourceFreshCaller.sourceClaims] + +theorem allWork_le {A : Type} (p : A → Bool) (w : A → Nat) (xs : List A) (k : Nat) + (bound : ∀ x ∈ xs, w x ≤ k) : allWork p w xs ≤ (k + 2) * xs.length + 1 := by + induction xs with + | nil => simp [allWork] + | cons x xs ih => + have hx := bound x (by simp) + have ht := ih (fun y hy => bound y (by simp [hy])) + simp only [allWork,List.length_cons] + split <;> nlinarith + +theorem containsWork_le (x : Nat) (xs : List Nat) : + containsWork x xs ≤ 3 * xs.length + 1 := by + induction xs with + | nil => simp [containsWork] + | cons y ys ih => + simp only [containsWork,List.length_cons] + split <;> omega + +theorem indexWork_le {A : Type} (xs : List A) (index : Nat) : + indexWork xs index ≤ 2 * xs.length + 1 := by + induction xs generalizing index with + | nil => simp [indexWork] + | cons x xs ih => + cases index with + | zero => simp [indexWork]; omega + | succ n => + have ht := ih n + simp only [indexWork,List.length_cons] + omega + +theorem dupsWork_le (xs seen : List Nat) : + dupsWork xs seen ≤ 3 * (xs.length + seen.length + 1) * (xs.length + 1) := by + induction xs generalizing seen with + | nil => simp [dupsWork]; omega + | cons x xs ih => + have hc := containsWork_le x seen + have hs := ih seen + have hn := ih (x :: seen) + simp only [List.length_cons] at hn ⊢ + simp only [dupsWork] + split <;> nlinarith + +theorem openingWork_polynomial (record : Record) : + openingWork record ≤ 42 * (record.context.pendingBytes + record.point.length + 1) + 600 := by + have hd : (record.context.pendingBytes + 23) / 24 ≤ record.context.pendingBytes + 1 := by omega + have hs := sumMap_le (List.range ((record.context.pendingBytes + 23) / 24)) + (pendingPackWork record.context) 35 (fun i _ => pendingPackWork_le record.context i) + simp only [List.length_range] at hs + simp only [openingWork] + omega + +theorem cpuPayload_output_work (layout : CpuLayout) (cost : OutputCosts) (tokens : List CallerToken) : + (cpuPayload layout cost tokens).work = + (cpuPayload layout {cost with call := fun _ => 0} tokens).work + + if (cpuPayloadBeforeExit layout tokens).result.isSome then cost.total else 0 := by + cases h : (cpuPayloadBeforeExit layout tokens).result with + | none => + simp [cpuPayload,Bind.bind,PCSBCSCallerParserCost.bind,h] + | some pair => + rcases pair with ⟨⟨rings,columns⟩,rest⟩ + simp [cpuPayload,charged,Bind.bind,Pure.pure,PCSBCSCallerParserCost.bind, + PCSBCSCallerParserCost.tick,PCSBCSCallerParserCost.pure, + PCSBCSCallerParserCost.liftOption,exitClaims,OutputCosts.total,h] + split <;> simp_all <;> omega + +abbrev Schedule := List WHIRCallerShape.EventShape + +def scheduleReads (n : Nat) : PCSBCSCallerParserCost.Costed Schedule := + ⟨List.replicate n (.absorb 24),3 * n + 2⟩ + +def scheduleDraws (n : Nat) : PCSBCSCallerParserCost.Costed Schedule := + ⟨List.replicate n (.squeeze 24),3 * n + 2⟩ + +def scheduleAppend (a b : PCSBCSCallerParserCost.Costed Schedule) : + PCSBCSCallerParserCost.Costed Schedule := + ⟨a.value ++ b.value,a.work + b.work + 2 * a.value.length + 1⟩ + +def scheduleFlatMap {A : Type} (xs : List A) + (f : A → PCSBCSCallerParserCost.Costed Schedule) : PCSBCSCallerParserCost.Costed Schedule := + ⟨xs.flatMap (fun a => (f a).value),xs.length + 1 + + (xs.map (fun a => (f a).work + 2 * (f a).value.length + 1)).sum⟩ + +def scheduleRepeat (n : Nat) (a : PCSBCSCallerParserCost.Costed Schedule) : + PCSBCSCallerParserCost.Costed Schedule := + ⟨(List.replicate n a.value).flatten, + a.work + 3 * n + 1 + n * (2 * a.value.length + 2) + 1⟩ + +def gkrShape (mu : Nat) : PCSBCSCallerParserCost.Costed Schedule := + let odd := if mu % 2 = 1 then scheduleAppend (scheduleReads 4) (scheduleDraws 2) else ⟨[],1⟩ + let rows := scheduleFlatMap (List.range (mu / 2)) (fun i => + scheduleAppend + (scheduleRepeat (mu % 2 + 2 * i) (scheduleAppend (scheduleReads 4) (scheduleDraws 1))) + (scheduleAppend (scheduleReads 8) (scheduleDraws 3))) + let assembled := scheduleAppend (scheduleReads 1) + (scheduleAppend (scheduleDraws 1) (scheduleAppend odd rows)) + ⟨WHIRCallerClaims.gkrShape mu,assembled.work + 6 * (mu / 2) + 5⟩ + +def frameworkKeys (layout : BusLayout) : PCSBCSCallerParserCost.Costed (List (Nat × Nat)) := + let blocks := layout.push ++ layout.pull + let keys := blocks.flatMap (fun block => if block.tableOwned then [] + else block.coords.filterMap (fun coord => match coord with + | .column col => some (col,block.kappa) + | _ => none)) + let blockWork := blocks.map (fun block => 2 + if block.tableOwned then 1 else + 1 + (block.coords.map (fun coord => match coord with | .column _ => 5 | _ => 2)).sum) + ⟨WHIRCallerClaims.frameworkKeys layout, + 2 * layout.push.length + 1 + blocks.length + 1 + blockWork.sum + 2 * keys.length + + blocks.length + PCSBCSCallerParserCost.eraseDupsCost 2 keys []⟩ + +def busShape (layout : BusLayout) : PCSBCSCallerParserCost.Costed Schedule := + let grinding : PCSBCSCallerParserCost.Costed Schedule := + if layout.grinding > 0 then ⟨[.nonce layout.grinding],4⟩ else ⟨[],2⟩ + let keys := frameworkKeys layout + let m := PCSBCSCallerParserCost.mu layout + let assembled := scheduleAppend grinding (scheduleAppend (scheduleDraws 5) + (scheduleAppend (gkrShape m.value) (scheduleReads keys.value.length))) + ⟨WHIRCallerClaims.busShape layout,assembled.work + m.work + keys.work + keys.value.length + 1⟩ + +def constraintsShape (layouts : List AirLayout) : PCSBCSCallerParserCost.Costed Schedule := + let n := (layouts.map AirLayout.tau).foldl max 0 + let front := scheduleRepeat n (scheduleAppend (scheduleReads 3) (scheduleDraws 1)) + let tables := scheduleFlatMap layouts (fun l => + let fields := (l.fields.map BitField.width).sum + let a := scheduleAppend (scheduleReads (l.columns-l.publicColumns-l.fields.length)) + (scheduleReads fields) + ⟨a.value,a.work + 5 + l.fields.length + 1 + 5 * l.fields.length + 2⟩) + let assembled := scheduleAppend front tables + ⟨WHIRCallerClaims.constraintsShape layouts,assembled.work + 5 * layouts.length + 2⟩ + +def flockProgramShape (layouts : List FlockLayout) : PCSBCSCallerParserCost.Costed Schedule := + let m := (layouts.map FlockLayout.logN).foldl max 0 + let rounds := (layouts.map (fun l => l.kLog-6)).foldl max 0 + let round := scheduleAppend (scheduleReads 2) (scheduleDraws 1) + let assembled := scheduleAppend (scheduleDraws (m-13+1)) + (scheduleAppend (scheduleReads 64) (scheduleAppend (scheduleDraws 1) + (scheduleAppend (scheduleRepeat (m-6) round) + (scheduleAppend (scheduleReads (3*layouts.length)) (scheduleAppend (scheduleDraws 1) + (scheduleAppend (scheduleRepeat rounds round) + (scheduleFlatMap layouts (fun _ => scheduleAppend (scheduleReads 64) (scheduleReads 1))))))))) + ⟨WHIRCallerClaims.flockProgramShape layouts,assembled.work + 14 * layouts.length + 10⟩ + +def callerShape (layout : CallerLayout) : PCSBCSCallerParserCost.Costed Schedule := + match layout with + | .recursion l => + let assembled := scheduleAppend (scheduleReads 2) (scheduleAppend (busShape l.bus) + (scheduleAppend (scheduleDraws 1) + (scheduleAppend (constraintsShape (l.tables.map Prod.snd)) (flockProgramShape [l.hash])))) + ⟨WHIRCallerClaims.callerShape layout,assembled.work + 3 * l.tables.length + 4⟩ + | .cpu l => + let airs := l.tables.map CpuTableLayout.air ++ + l.bus.producers.map (fun p => (⟨p.kappa,2*p.bits,p.bits,[]⟩ : AirLayout)) + let settled := scheduleFlatMap l.tables (fun t => + if t.settled then + let a := scheduleReads (t.committedColumns-t.summedColumns.length) + ⟨a.value,a.work + t.summedColumns.length + 3⟩ + else ⟨[],2⟩) + let assembled := scheduleAppend (scheduleReads (l.tables.length+2)) + (scheduleAppend (scheduleReads 2) (scheduleAppend (busShape l.bus) + (scheduleAppend settled (scheduleAppend (scheduleDraws 1) + (scheduleAppend (constraintsShape airs) (flockProgramShape l.flock)))))) + ⟨WHIRCallerClaims.callerShape layout,assembled.work + 9 * l.tables.length + + (l.tables.map (fun t => t.summedColumns.length + 1)).sum + + 7 * l.bus.producers.length + 5⟩ + +/-- Recursive byte encoding visits exactly the requested little-endian prefix. -/ +def encodeByteWork : Nat → Nat + | 0 => 4 + | n+1 => 6 + encodeByteWork n + +def encodeScalarByteWork (i : Nat) : Nat := + if i < 8 then 3 + encodeByteWork i + else if i < 16 then 6 + encodeByteWork (i-8) else 6 + encodeByteWork (i-16) + +def scheduleEqWork : Schedule → Schedule → Nat + | [], _ => 1 + | _ :: _, [] => 1 + | x :: xs, y :: ys => 5 + if x = y then scheduleEqWork xs ys else 0 + +def tokensShape (tokens : List CallerToken) : PCSBCSCallerParserCost.Costed Schedule := + ⟨WHIRCallerClaims.tokensShape tokens,1 + (tokens.map (fun token => match token with + | .sent _ => 8 + 24 * 3 + 1 + ((List.range 24).map encodeScalarByteWork).sum + + 2 * 24 + 1 + 24 + 1 + | .draw _ => 4 + | .nonce _ _ => 4)).sum⟩ + +def freshCallerShape (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + PCSBCSCallerParserCost.Costed Schedule := + let base := callerShape layout + let n := rootScalarCount layout + let frame := openingScalars saved + ⟨AnchoredSourceFreshCaller.callerShape layout saved, + base.work + 2 + min n base.value.length + 1 + openingWork saved + openingGetterWork saved cost + frame.length + 1 + + 3 * frame.length + 2 + 2 * (base.value.drop n).length + 1⟩ + +@[simp] theorem freshCallerShape_ignore_output_prices (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (calls : Fin 4 → Nat) : + freshCallerShape layout saved {cost with call := calls} = freshCallerShape layout saved cost := rfl +def freshInterpret (layout : CallerLayout) (saved : Record) (cost : OutputCosts) + (tokens : List CallerToken) : PCSBCSCallerParserCost.Costed (Option AnchoredSourceCaller.Claims) := + let actual := tokensShape tokens + let expected := freshCallerShape layout saved cost + let compared := scheduleEqWork actual.value expected.value + let front := actual.work + expected.work + compared + 1 + if actual.value ≠ expected.value then ⟨none,front⟩ else + let parsed := freshSourceClaims layout saved cost tokens + match parsed.result with + | none => ⟨none,front + parsed.work + 1⟩ + | some (claims,rest) => + if rest.isEmpty then ⟨some claims,front + parsed.work + 3⟩ + else ⟨none,front + parsed.work + 3⟩ + +@[simp] theorem gkrShape_erasure (mu : Nat) : + (gkrShape mu).value = WHIRCallerClaims.gkrShape mu := rfl +@[simp] theorem frameworkKeys_erasure (layout : BusLayout) : + (frameworkKeys layout).value = WHIRCallerClaims.frameworkKeys layout := rfl +@[simp] theorem busShape_erasure (layout : BusLayout) : + (busShape layout).value = WHIRCallerClaims.busShape layout := rfl +@[simp] theorem constraintsShape_erasure (layouts : List AirLayout) : + (constraintsShape layouts).value = WHIRCallerClaims.constraintsShape layouts := rfl +@[simp] theorem flockProgramShape_erasure (layouts : List FlockLayout) : + (flockProgramShape layouts).value = WHIRCallerClaims.flockProgramShape layouts := rfl +@[simp] theorem callerShape_erasure (layout : CallerLayout) : + (callerShape layout).value = WHIRCallerClaims.callerShape layout := by cases layout <;> rfl +@[simp] theorem tokensShape_erasure (tokens : List CallerToken) : + (tokensShape tokens).value = WHIRCallerClaims.tokensShape tokens := rfl +@[simp] theorem freshCallerShape_erasure (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + (freshCallerShape layout saved cost).value = AnchoredSourceFreshCaller.callerShape layout saved := rfl + +theorem freshInterpret_erasure (layout : CallerLayout) (saved : Record) (cost : OutputCosts) + (tokens : List CallerToken) : (freshInterpret layout saved cost tokens).value = + AnchoredSourceFreshCaller.interpret layout saved tokens := by + have erased := congrFun (freshSourceClaims_erasure layout saved cost) tokens + change (freshSourceClaims layout saved cost tokens).result = _ at erased + by_cases h : WHIRCallerClaims.tokensShape tokens ≠ AnchoredSourceFreshCaller.callerShape layout saved + · simp [freshInterpret,AnchoredSourceFreshCaller.interpret,h] + · cases hr : (freshSourceClaims layout saved cost tokens).result with + | none => simp [freshInterpret,AnchoredSourceFreshCaller.interpret,h,← erased,hr] + | some pair => + rcases pair with ⟨claims,rest⟩ + cases rest <;> simp [freshInterpret,AnchoredSourceFreshCaller.interpret,h,← erased,hr] + +theorem scalarEqWork_le (x y : E) : scalarEqWork x y ≤ 12 := by + simp only [scalarEqWork]; split <;> (try split) <;> omega + +theorem scalarListEqWork_le (xs ys : List E) : + scalarListEqWork xs ys ≤ 14 * ys.length + 1 := by + induction ys generalizing xs with + | nil => cases xs <;> simp [scalarListEqWork] + | cons y ys ih => + cases xs with + | nil => simp [scalarListEqWork] + | cons x xs => + have h := scalarEqWork_le x y + have ht := ih xs + simp only [scalarListEqWork,List.length_cons] + split <;> omega + +theorem scheduleEqWork_le (xs ys : Schedule) : + scheduleEqWork xs ys ≤ 5 * ys.length + 1 := by + induction ys generalizing xs with + | nil => cases xs <;> simp [scheduleEqWork] + | cons y ys ih => + cases xs with + | nil => simp [scheduleEqWork] + | cons x xs => + have ht := ih xs + simp only [scheduleEqWork,List.length_cons] + split <;> omega + +theorem scalarByteWork_sum : + ((List.range 24).map encodeScalarByteWork).sum = 720 := by decide + +theorem tokensShape_work_le (tokens : List CallerToken) : + (tokensShape tokens).work ≤ 875 * tokens.length + 1 := by + induction tokens with + | nil => simp [tokensShape] + | cons token rest ih => + cases token <;> simp only [tokensShape,List.map_cons,List.sum_cons,List.length_cons, + scalarByteWork_sum] at * <;> omega + +theorem binding_work_le (record : Record) (cost : OutputCosts) (tokens : List CallerToken) : + (binding record cost tokens).work ≤ + 2 * openingWork record + 2 * openingGetterWork record cost + 24 * (openingScalars record).length + 7 := by + have hr := PCSBCSCallerParserCost.readScalars_work_le (openingScalars record).length tokens + simp only [binding,Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick] + cases h : (PCSBCSCallerParserCost.readScalars (openingScalars record).length tokens).result with + | none => dsimp only; omega + | some pair => + rcases pair with ⟨frame,rest⟩ + have he := scalarListEqWork_le frame (openingScalars record) + change _ ≤ _ + simp only [PCSBCSCallerParserCost.check] + split <;> dsimp only <;> omega + +theorem binding_polynomial (record : Record) (cost : OutputCosts) (tokens : List CallerToken) : + (binding record cost tokens).work ≤ + 108 * (record.context.pendingBytes + record.point.length + 1) + 1447 + 2 * openingGetterWork record cost := by + have hb := binding_work_le record cost tokens + have ho := openingWork_polynomial record + have hn := openingScalars_length record + have hd : (record.context.pendingBytes + 23) / 24 ≤ record.context.pendingBytes + 1 := by omega + omega + +theorem freshInterpret_work_le (layout : CallerLayout) (saved : Record) (cost : OutputCosts) + (tokens : List CallerToken) : + (freshInterpret layout saved cost tokens).work ≤ + (tokensShape tokens).work + (freshCallerShape layout saved cost).work + + scheduleEqWork (tokensShape tokens).value (freshCallerShape layout saved cost).value + + (freshSourceClaims layout saved cost tokens).work + 4 := by + by_cases shapeMismatch : WHIRCallerClaims.tokensShape tokens ≠ + AnchoredSourceFreshCaller.callerShape layout saved + · simp [freshInterpret,shapeMismatch] + omega + · cases parsed : (freshSourceClaims layout saved cost tokens).result with + | none => + simp [freshInterpret,shapeMismatch,parsed] + omega + | some pair => + rcases pair with ⟨claims,rest⟩ + cases remaining : rest.isEmpty <;> + simp [freshInterpret,shapeMismatch,parsed,remaining] + all_goals omega + + +theorem columnsWork_le (bus : List ColumnClaim) (paired : List (Nat × TableClaims)) (evalCap : Nat) + (cap : ∀ p ∈ paired, p.2.evals.length ≤ evalCap) : + columnsWork bus paired ≤ 2 * bus.length + paired.length * (8 * evalCap + 4) + 2 := by + have hs := sumMap_le paired (fun (base,claims) => + (PCSBCSCallerParserCost.tableColumns base claims).work + 2 * claims.evals.length + 1) + (8 * evalCap + 3) (by + intro p hp + have hc := cap p hp + rcases p with ⟨base,claims⟩ + dsimp only at hc ⊢ + simp only [PCSBCSCallerParserCost.tableColumns_work] + omega) + simp only [columnsWork] + nlinarith + +theorem freshCallerShape_work_le (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + (freshCallerShape layout saved cost).work ≤ + (callerShape layout).work + openingWork saved + openingGetterWork saved cost + + 3 * (callerShape layout).value.length + 4 * (openingScalars saved).length + 7 := by + have hm : min (rootScalarCount layout) (callerShape layout).value.length ≤ + (callerShape layout).value.length := Nat.min_le_right _ _ + have hd : ((callerShape layout).value.drop (rootScalarCount layout)).length ≤ + (callerShape layout).value.length := by simp + simp only [freshCallerShape] + omega + +theorem freshCallerShape_length_le (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + (freshCallerShape layout saved cost).value.length ≤ + (callerShape layout).value.length + (openingScalars saved).length := by + simp only [freshCallerShape_erasure,callerShape_erasure,AnchoredSourceFreshCaller.callerShape, + AnchoredSourceCaller.reads,List.length_append,List.length_replicate,List.length_drop] + omega + +theorem freshInterpret_compositional_bound (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) : + (freshInterpret layout saved cost tokens).work ≤ + 875 * tokens.length + (callerShape layout).work + openingWork saved + openingGetterWork saved cost + + 8 * (callerShape layout).value.length + 9 * (openingScalars saved).length + + (freshSourceClaims layout saved cost tokens).work + 13 := by + have hi := freshInterpret_work_le layout saved cost tokens + have ht := tokensShape_work_le tokens + have hc := freshCallerShape_work_le layout saved cost + have hl := freshCallerShape_length_le layout saved cost + have he := scheduleEqWork_le (tokensShape tokens).value (freshCallerShape layout saved cost).value + omega + +theorem freshInterpret_exact (layout : CallerLayout) (saved : Record) (cost : OutputCosts) + (tokens : List CallerToken) (claims : AnchoredSourceCaller.Claims) : + (freshInterpret layout saved cost tokens).value = some claims ↔ + WHIRCallerClaims.tokensShape tokens = AnchoredSourceFreshCaller.callerShape layout saved ∧ + (freshSourceClaims layout saved cost tokens).result = some (claims,[]) := by + rw [freshInterpret_erasure,AnchoredSourceFreshCaller.interpret_exact] + change (_ ∧ _) ↔ (_ ∧ PCSBCSCallerParserCost.erase (freshSourceClaims layout saved cost) tokens = _) + rw [freshSourceClaims_erasure] + +theorem binding_exact (record : Record) (cost : OutputCosts) (suffix : List CallerToken) : + (binding record cost ((openingScalars record).map CallerToken.sent ++ suffix)).result = some ((),suffix) := by + change PCSBCSCallerParserCost.erase (binding record cost) _ = _ + rw [binding_erasure] + exact AnchoredSourceCaller.binding_exact record suffix + +theorem binding_frame_rejected (record : Record) (cost : OutputCosts) (frame : List E) (suffix : List CallerToken) + (length : frame.length = (openingScalars record).length) (changed : frame ≠ openingScalars record) : + (binding record cost (frame.map CallerToken.sent ++ suffix)).result = none := by + change PCSBCSCallerParserCost.erase (binding record cost) _ = _ + rw [binding_erasure] + exact AnchoredSourceFreshCaller.binding_frame_rejected record frame suffix length changed + +/-- Closed geometry avoids evaluating `openingScalars` solely to obtain its +length while computing a trace. -/ +def freshShapeForTrace (layout : CallerLayout) (saved : Record) : Schedule := + (WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout) ++ + AnchoredSourceCaller.reads (10 + saved.point.length + (saved.context.pendingBytes+23)/24) + +theorem freshShapeForTrace_erasure (layout : CallerLayout) (saved : Record) : + freshShapeForTrace layout saved = AnchoredSourceFreshCaller.callerShape layout saved := by + simp [freshShapeForTrace,AnchoredSourceFreshCaller.callerShape,openingScalars_length] +def freshOutputGetterTrace (layout : CallerLayout) (tokens : List CallerToken) : List (Fin 4) := + match layout with + | .cpu l => outputGetterTrace l tokens + | .recursion _ => [] + +def freshInterpretOutputGetterTrace (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) : List (Fin 4) := + if WHIRCallerClaims.tokensShape tokens = freshShapeForTrace layout saved + then freshOutputGetterTrace layout tokens else [] + +theorem freshOutputGetterTrace_length_le (layout : CallerLayout) (tokens : List CallerToken) : + (freshOutputGetterTrace layout tokens).length ≤ 4 := by + cases layout with + | recursion _ => simp [freshOutputGetterTrace] + | cpu l => + simp only [freshOutputGetterTrace,outputGetterTrace_length] + split <;> omega + +theorem freshInterpretOutputGetterTrace_length_le (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) : (freshInterpretOutputGetterTrace layout saved tokens).length ≤ 4 := by + unfold freshInterpretOutputGetterTrace + split + · exact freshOutputGetterTrace_length_le layout tokens + · simp + +theorem freshSourceClaims_output_work (layout : CpuLayout) (saved : Record) (cost : OutputCosts) + (tokens : List CallerToken) : + (freshSourceClaims (.cpu layout) saved cost tokens).work = + (freshSourceClaims (.cpu layout) saved {cost with call := fun _ => 0} tokens).work + + if (cpuPayloadBeforeExit layout tokens).result.isSome then cost.total else 0 := by + have hw := cpuPayload_output_work layout cost tokens + have hr : (cpuPayload layout cost tokens).result = (cpuPayload layout {cost with call := fun _ => 0} tokens).result := by + change PCSBCSCallerParserCost.erase (cpuPayload layout cost) tokens = + PCSBCSCallerParserCost.erase (cpuPayload layout {cost with call := fun _ => 0}) tokens + rw [cpuPayload_erasure,cpuPayload_erasure] + simp only [freshSourceClaims,payload,Bind.bind,Pure.pure,PCSBCSCallerParserCost.bind] + rw [hr] + cases h : (cpuPayload layout {cost with call := fun _ => 0} tokens).result with + | none => omega + | some pair => + rcases pair with ⟨⟨families,points⟩,rest⟩ + simp only [binding_ignore_output_prices] + omega + +theorem freshSourceClaims_output_bound (layout : CallerLayout) (saved : Record) (cost : OutputCosts) + (tokens : List CallerToken) : + (freshSourceClaims layout saved cost tokens).work ≤ + (freshSourceClaims layout saved {cost with call := fun _ => 0} tokens).work + cost.total := by + cases layout with + | recursion l => simp [freshSourceClaims,payload] + | cpu l => + rw [freshSourceClaims_output_work] + split <;> omega + +theorem shapeValidWork_le (shape : Shape) : + shapeValidWork shape ≤ 3 * shape.logBatch + 24 := by + unfold shapeValidWork + repeat' first | omega | split + +theorem headerWork_le (shape : Shape) (header : List E) : headerWork shape header ≤ 54 := by + unfold headerWork scalarEqWork + repeat' first | omega | split + +theorem wordsWork_le (layout : CallerLayout) (dimensionCap : Nat) + (cap : ∀ p ∈ (callerPlacements layout).toList, ∀ o d, p = .committed o d → d ≤ dimensionCap) : + wordsWork layout ≤ (3 * dimensionCap + 5) * (callerPlacements layout).size + 3 := by + have hs := sumMap_le (callerPlacements layout).toList + (fun p => match p with | .committed _ d => 3 * d + 5 | _ => 2) + (3 * dimensionCap + 5) (by + intro p hp + cases p with + | committed o d => + have hd := cap _ hp o d rfl + dsimp only + omega + | port o slot stride => dsimp only; omega + | sliced => dsimp only; omega) + simp only [Array.length_toList] at hs + simp only [wordsWork] + omega + +theorem settledClaims_success_geometry (tables : List CpuTableLayout) (point : List E) + (tokens rest : List CallerToken) (claims : List TableClaims) + (success : (settledClaims tables point tokens).result = some (claims,rest)) : + List.Forall₂ WHIRCallerGeometry.SettledGeometry (tables.filter CpuTableLayout.settled) claims := by + have erased := congrFun (settledClaims_erasure tables point) tokens + change (settledClaims tables point tokens).result = _ at erased + exact WHIRCallerGeometry.settledClaims_geometry tables point tokens claims rest (erased.symm.trans success) + +theorem settledClaims_success_length (tables : List CpuTableLayout) (point : List E) + (tokens rest : List CallerToken) (claims : List TableClaims) + (success : (settledClaims tables point tokens).result = some (claims,rest)) : + claims.length = (tables.filter CpuTableLayout.settled).length := + (settledClaims_success_geometry tables point tokens rest claims success).length_eq.symm + +/-- Proof-side access trace. Its construction does not call an opaque accessor. -/ +structure GetterTrace where + outputs : List (Fin 4) + pendingWords : List (Fin 8) + rootBytes : List (Fin 32) + contextBytes : List (Fin 32) + +def GetterTrace.empty : GetterTrace := ⟨[],[],[],[]⟩ + +def GetterTrace.append (a b : GetterTrace) : GetterTrace := + ⟨a.outputs ++ b.outputs,a.pendingWords ++ b.pendingWords, + a.rootBytes ++ b.rootBytes,a.contextBytes ++ b.contextBytes⟩ + +def GetterTrace.price (trace : GetterTrace) (cost : OutputCosts) : Nat := + (trace.outputs.map cost.call).sum + (trace.pendingWords.map cost.pending).sum + + (trace.rootBytes.map cost.rootByte).sum + (trace.contextBytes.map cost.contextByte).sum + +@[simp] theorem GetterTrace.price_append (a b : GetterTrace) (cost : OutputCosts) : + (a.append b).price cost = a.price cost + b.price cost := by + simp only [GetterTrace.price,GetterTrace.append,List.map_append,List.sum_append] + omega + +@[simp] theorem GetterTrace.price_zero (trace : GetterTrace) : + trace.price OutputCosts.zero = 0 := by + simp [GetterTrace.price,OutputCosts.zero,List.sum_replicate] + +def openingGetterTrace (record : Record) : GetterTrace := + ⟨[],pendingGetterTrace record.context,digestGetterTrace,digestGetterTrace⟩ + +def bindingGetterTrace (record : Record) (tokens : List CallerToken) : GetterTrace := + let frameLength := 10 + record.point.length + (record.context.pendingBytes+23)/24 + let first := openingGetterTrace record + if (PCSBCSCallerParserCost.readScalars frameLength tokens).result.isSome + then first.append first else first + +private theorem mapM_isSome_all {A B : Type} (xs : List A) (f : A → Option B) : + (xs.mapM f).isSome = xs.all (fun x => (f x).isSome) := by + induction xs with + | nil => rfl + | cons x xs ih => + cases hx : f x <;> cases ht : xs.mapM f <;> simp_all [List.mapM_cons,List.all] + +theorem placeClaims_isSome (placements : Array Placement) (claims : List ColumnClaim) : + (PCSBCSCallerParserCost.placeClaims placements claims).value.isSome = + claims.all (fun c => decide (c.column < placements.size)) := by + rw [PCSBCSCallerParserCost.placeClaims_erasure] + unfold WHIRCallerClaims.placeClaims + let locate := fun c : ColumnClaim => do + let p ← placements[c.column]? + pure (WHIRCallerClaims.placeClaim p c) + have hm := mapM_isSome_all claims locate + have hl : ∀ c, (locate c).isSome = decide (c.column < placements.size) := by + intro c + have hb := isSome_getElem? placements c.column + cases h : placements[c.column]? <;> simp [locate,h] at * <;> assumption + simp only [hl] at hm + cases h : claims.mapM locate with + | none => + simp only [h,Option.isSome_none] at hm + rw [← hm] + rfl + | some located => + simp only [h,Option.isSome_some] at hm + rw [← hm] + rfl + +/-- CPU completion is decided from actual parsed column indices. The five exit +claims all use the public final-register column; their opaque values cannot +change whether placement rejects. No output getter is executed by this scanner. -/ +def payloadPendingCursor (layout : CallerLayout) (tokens : List CallerToken) : Option (List CallerToken) := + match layout with + | .recursion l => (recPayload l tokens).result.map Prod.snd + | .cpu l => (cpuPayloadBeforeExit l tokens).result.bind (fun ((_,columns),rest) => + if columns.all (fun c => decide (c.column < l.placements.size)) && + decide (l.finalRegisterColumn < l.placements.size) + then some rest else none) + +theorem payloadPendingCursor_erasure (layout : CallerLayout) (cost : OutputCosts) + (tokens : List CallerToken) : + payloadPendingCursor layout tokens = (payload layout cost tokens).result.map Prod.snd := by + cases layout with + | recursion l => rfl + | cpu l => + cases h : (cpuPayloadBeforeExit l tokens).result with + | none => simp [payloadPendingCursor,payload,cpuPayload,Bind.bind,PCSBCSCallerParserCost.bind,h] + | some pair => + rcases pair with ⟨⟨rings,columns⟩,rest⟩ + have hp := placeClaims_isSome l.placements + (columns ++ WHIRCallerClaims.exitClaims l.finalRegisterColumn l.output) + have hexit : (WHIRCallerClaims.exitClaims l.finalRegisterColumn l.output).all + (fun c => decide (c.column < l.placements.size)) = + decide (l.finalRegisterColumn < l.placements.size) := by + simp [WHIRCallerClaims.exitClaims,List.ofFn_succ] + simp only [List.all_append,hexit] at hp + simp only [payloadPendingCursor,payload,cpuPayload,charged,Bind.bind,Pure.pure, + PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick,PCSBCSCallerParserCost.pure, + PCSBCSCallerParserCost.liftOption,exitClaims,h] + cases placed : (PCSBCSCallerParserCost.placeClaims l.placements + (columns ++ WHIRCallerClaims.exitClaims l.finalRegisterColumn l.output)).value <;> + simp_all + +def freshSourceClaimsGetterTrace (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) : GetterTrace := + let outputs : GetterTrace := ⟨freshOutputGetterTrace layout tokens,[],[],[]⟩ + match payloadPendingCursor layout tokens with + | none => outputs + | some rest => outputs.append (bindingGetterTrace saved rest) + + +def freshInterpretGetterTrace (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) : GetterTrace := + let shape := openingGetterTrace saved + if WHIRCallerClaims.tokensShape tokens = freshShapeForTrace layout saved + then shape.append (freshSourceClaimsGetterTrace layout saved tokens) + else shape + +theorem digestGetterTrace_length : digestGetterTrace.length = 64 := by + simp [digestGetterTrace] + +theorem openingGetterTrace_price (record : Record) (cost : OutputCosts) : + (openingGetterTrace record).price cost = openingGetterWork record cost := by + simp [openingGetterTrace,GetterTrace.price,openingGetterWork,pendingGetterWork] + +theorem binding_getter_work (record : Record) (cost : OutputCosts) + (tokens : List CallerToken) : + (binding record cost tokens).work = (binding record OutputCosts.zero tokens).work + + (bindingGetterTrace record tokens).price cost := by + have hz : openingGetterWork record OutputCosts.zero = 0 := by + rw [← openingGetterTrace_price] + simp + have hn := openingScalars_length record + cases h : (PCSBCSCallerParserCost.readScalars (openingScalars record).length tokens).result with + | none => + simp [binding,Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + h,hz,bindingGetterTrace,← hn,openingGetterTrace_price] + omega + | some pair => + rcases pair with ⟨frame,rest⟩ + simp [binding,Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + PCSBCSCallerParserCost.check,h,hz,bindingGetterTrace, + ← hn,openingGetterTrace_price,GetterTrace.price_append] + split <;> simp <;> omega + +theorem pendingPackGetterTrace_length_le (context : Context) (i : Nat) : + (pendingPackGetterTrace context i).length ≤ 3 := by + simp only [pendingPackGetterTrace,List.length_append] + split <;> split <;> simp + +theorem pendingGetterTrace_length_le (context : Context) : + (pendingGetterTrace context).length ≤ 3 * ((context.pendingBytes+23)/24) := by + have hs := sumMap_le (List.range ((context.pendingBytes+23)/24)) + (fun i => (pendingPackGetterTrace context i).length) 3 + (fun i _ => pendingPackGetterTrace_length_le context i) + simpa [pendingGetterTrace,List.length_flatMap] using hs + +theorem bindingGetterTrace_bound (record : Record) (tokens : List CallerToken) : + (bindingGetterTrace record tokens).outputs = [] ∧ + (bindingGetterTrace record tokens).pendingWords.length ≤ 2 * (pendingGetterTrace record.context).length ∧ + (bindingGetterTrace record tokens).rootBytes.length ≤ 128 ∧ + (bindingGetterTrace record tokens).contextBytes.length ≤ 128 := by + unfold bindingGetterTrace + dsimp only + split <;> simp [openingGetterTrace,GetterTrace.append,digestGetterTrace] <;> omega + +theorem freshSourceClaimsGetterTrace_bound (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) : + (freshSourceClaimsGetterTrace layout saved tokens).outputs.length ≤ 4 ∧ + (freshSourceClaimsGetterTrace layout saved tokens).pendingWords.length ≤ + 2 * (pendingGetterTrace saved.context).length ∧ + (freshSourceClaimsGetterTrace layout saved tokens).rootBytes.length ≤ 128 ∧ + (freshSourceClaimsGetterTrace layout saved tokens).contextBytes.length ≤ 128 := by + have ho := freshOutputGetterTrace_length_le layout tokens + unfold freshSourceClaimsGetterTrace + cases h : payloadPendingCursor layout tokens with + | none => + dsimp only + simp only [List.length_nil] + exact ⟨ho,by omega,by omega,by omega⟩ + | some rest => + have hb := bindingGetterTrace_bound saved rest + simp only [GetterTrace.append,List.length_append] + simpa [hb.1] using And.intro ho hb.2 + +theorem freshInterpretGetterTrace_bound (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) : + (freshInterpretGetterTrace layout saved tokens).outputs.length ≤ 4 ∧ + (freshInterpretGetterTrace layout saved tokens).pendingWords.length ≤ + 3 * (pendingGetterTrace saved.context).length ∧ + (freshInterpretGetterTrace layout saved tokens).rootBytes.length ≤ 192 ∧ + (freshInterpretGetterTrace layout saved tokens).contextBytes.length ≤ 192 := by + have hb := freshSourceClaimsGetterTrace_bound layout saved tokens + unfold freshInterpretGetterTrace + split + · simp only [GetterTrace.append,openingGetterTrace,List.length_append, + List.length_nil,Nat.zero_add,digestGetterTrace_length] + omega + · simp [openingGetterTrace,digestGetterTrace] + omega + +/-- A polynomial callback component using the caller's explicit per-access caps. +The exact reached indices remain available in `freshInterpretGetterTrace`. -/ +theorem freshInterpretGetterTrace_price_le (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) (cost : OutputCosts) + (outputCap pendingCap rootCap contextCap : Nat) + (outputs : ∀ i, cost.call i ≤ outputCap) + (pending : ∀ i, cost.pending i ≤ pendingCap) + (root : ∀ i, cost.rootByte i ≤ rootCap) + (context : ∀ i, cost.contextByte i ≤ contextCap) : + (freshInterpretGetterTrace layout saved tokens).price cost ≤ + 4 * outputCap + 9 * ((saved.context.pendingBytes+23)/24) * pendingCap + + 192 * rootCap + 192 * contextCap := by + let t := freshInterpretGetterTrace layout saved tokens + have ht := freshInterpretGetterTrace_bound layout saved tokens + have hp := pendingGetterTrace_length_le saved.context + have ho := sumMap_le t.outputs cost.call outputCap (fun i _ => outputs i) + have hw := sumMap_le t.pendingWords cost.pending pendingCap (fun i _ => pending i) + have hr := sumMap_le t.rootBytes cost.rootByte rootCap (fun i _ => root i) + have hc := sumMap_le t.contextBytes cost.contextByte contextCap (fun i _ => context i) + change _ + _ + _ + _ ≤ _ + dsimp only [t] at ho hw hr hc + have hn : (freshInterpretGetterTrace layout saved tokens).pendingWords.length ≤ + 9 * ((saved.context.pendingBytes+23)/24) := by omega + have a := Nat.mul_le_mul_left outputCap ht.1 + have b := Nat.mul_le_mul_left pendingCap hn + have c := Nat.mul_le_mul_left rootCap ht.2.2.1 + have d := Nat.mul_le_mul_left contextCap ht.2.2.2 + nlinarith + + + +#print axioms freshSourceClaims_output_work + +#print axioms binding_polynomial +#print axioms cpuPayload_output_work +#print axioms freshInterpret_erasure + +#print axioms recPayload_erasure +#print axioms cpuPayload_erasure +#print axioms sourceClaims_erasure +#print axioms freshSourceClaims_erasure +#print axioms dupsWork_le + +end Whir.PCSBCSCallerPayloadCost diff --git a/verification/whir/Whir/PCSBCSCallerPayloadCostSmoke.lean b/verification/whir/Whir/PCSBCSCallerPayloadCostSmoke.lean new file mode 100644 index 000000000..eeb4e472f --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerPayloadCostSmoke.lean @@ -0,0 +1,194 @@ +import Whir.PCSBCSCallerPayloadCost + +/-! Actual source-token execution tests. Zero-valued arithmetic messages are +claim-projection fixtures, not honest verified proofs or a security endpoint. -/ +namespace Whir.PCSBCSCallerPayloadCostSmoke +open Concrete FiatShamirGame AnchoredHeaderCodec +open WHIRCallerClaims hiding recPayload settledClaims +open PCSBCSCallerPayloadCost + +local instance : Add E := ⟨E.add⟩ +local instance : Mul E := ⟨E.mul⟩ +local instance : Zero E := ⟨E.zero⟩ +local instance : One E := ⟨E.one⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +private def require (label : String) (ok : Bool) : IO Unit := + unless ok do throw (IO.userError label) + +private def zeroToken : WHIRCallerShape.EventShape → CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) + +private def zeroCosts : OutputCosts := ⟨(fun _ => 0),(fun _ => 0),(fun _ => 0),(fun _ => 0)⟩ +private def getterCosts : OutputCosts := ⟨(fun i => i.val + 3),(fun _ => 0),(fun _ => 0),(fun _ => 0)⟩ + +private def recLayout : RecLayout := + ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ + +private def cpuLayout : CpuLayout := + ⟨⟨[],[],[],0⟩,List.replicate 11 ⟨0,0,0,false,[],[]⟩, + #[.committed 0 6],[⟨0,6,7⟩],[],0,(fun i => UInt64.ofNat i.val),1⟩ + +private def fixture (layout : CallerLayout) : List CallerToken := + ((WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout)).map zeroToken + +private def saved (layout : CallerLayout) : Record := + ⟨AnchoredSourceCaller.shape layout,ByteCodec.encodeNat 32 17, + ⟨ByteCodec.encodeNat 32 19,(fun _ => none),0,true,0,0⟩, + List.replicate (AnchoredSourceCaller.shape layout).logN 0,23⟩ + +def smoke : IO Unit := do + let recTokens := fixture (.recursion recLayout) + let rr := recPayload recLayout (recTokens ++ [.sent 29]) + require "recursion payload accepted and retains exact suffix" (match rr.result with + | some ((families,points),rest) => families.length == 1 && points.size == 0 && rest == [.sent 29] + | none => false) + require "recursion source accepts same token execution" (WHIRCallerClaims.recPayload recLayout recTokens).isSome + require "malformed recursion token rejected with positive reached work" + ((recPayload recLayout [.sent 0]).result.isNone && (recPayload recLayout [.sent 0]).work > 0) + let recSaved := saved (.recursion recLayout) + let recFresh := recTokens ++ (openingScalars recSaved).map CallerToken.sent + require "fresh recursion binding and exact schedule accepted" + (freshInterpret (.recursion recLayout) recSaved getterCosts recFresh).value.isSome + require "recursion has no opaque CPU getters" + ((freshSourceClaims (.recursion recLayout) recSaved getterCosts recFresh).work == + (freshSourceClaims (.recursion recLayout) recSaved zeroCosts recFresh).work) + let recOriginal := (headerScalars recSaved.shape recSaved.root).map CallerToken.sent ++ + recSaved.point.map CallerToken.draw ++ [.sent recSaved.value] ++ recFresh + require "original anchored recursion receive and binding accepted" (match + (sourceClaims (.recursion recLayout) recSaved.context getterCosts recOriginal).result with + | some (claims,rest) => decide (claims.record = recSaved) && rest.isEmpty + | none => false) + let cpuTokens := fixture (.cpu cpuLayout) + let cr := cpuPayload cpuLayout getterCosts (cpuTokens ++ [.sent 29]) + require "CPU payload accepted and emits five exit points" (match cr.result with + | some ((families,points),rest) => families.length == 1 && points.size == 5 && rest == [.sent 29] + | none => false) + require "CPU fourth output is placed at register thirteen with original value" (match cr.result with + | some ((_,points),_) => match points[4]? with + | some (RingPCSGame.PointClaim.point _ point value) => + point.toList == [1,0,1,1,0,0] && value == E.ofK 3 + | _ => false + | none => false) + require "CPU source accepts same token execution" (WHIRCallerClaims.cpuPayload cpuLayout cpuTokens).isSome + let base := cpuPayload cpuLayout zeroCosts cpuTokens + let paid := cpuPayload cpuLayout getterCosts cpuTokens + require "exactly four reached output getter invocations" (paid.work == base.work + 18) + require "trace contains exactly the four output indices" (outputGetterTrace cpuLayout cpuTokens == List.finRange 4) + let early := cpuPayload cpuLayout getterCosts [.sent 0] + let earlyBase := cpuPayload cpuLayout zeroCosts [.sent 0] + require "early CPU rejection does not invoke getters" (early.result.isNone && early.work == earlyBase.work) + require "early failure getter trace is empty" (outputGetterTrace cpuLayout [.sent 0]).isEmpty + let record := saved (.cpu cpuLayout) + let freshTokens := cpuTokens ++ (openingScalars record).map CallerToken.sent + let fresh := freshSourceClaims (.cpu cpuLayout) record getterCosts (freshTokens ++ [.sent 31]) + require "fresh source retains immutable record and suffix" (match fresh.result with + | some (claims,rest) => decide (claims.record = record) && rest == [.sent 31] + | none => false) + require "fresh exact interpreter accepts complete source token form" + (freshInterpret (.cpu cpuLayout) record getterCosts freshTokens).value.isSome + require "fresh exact interpreter rejects leftover tokens" + (freshInterpret (.cpu cpuLayout) record getterCosts (freshTokens ++ [.sent 31])).value.isNone + require "fresh exact interpreter rejects inserted original header" + (freshInterpret (.cpu cpuLayout) record getterCosts + ((headerScalars record.shape record.root).map CallerToken.sent ++ freshTokens)).value.isNone + require "fresh exact interpreter rejects resampled anchor" + (freshInterpret (.cpu cpuLayout) record getterCosts + (cpuTokens ++ record.point.map CallerToken.draw ++ (openingScalars record).map CallerToken.sent)).value.isNone + let changed := {record with value := record.value + 1} + let rejected := cpuTokens ++ (openingScalars changed).map CallerToken.sent + let failPaid := freshSourceClaims (.cpu cpuLayout) record getterCosts rejected + let failBase := freshSourceClaims (.cpu cpuLayout) record zeroCosts rejected + require "binding rejection still charges four already reached getters" + (failPaid.result.isNone && failPaid.work == failBase.work + 18) + require "duplicate settled columns rejected" ((settledClaims + [⟨0,0,2,true,[0,0],[]⟩] [] []).result.isNone) + require "out of range settled column rejected" ((settledClaims + [⟨0,0,1,true,[1],[]⟩] [] []).result.isNone) + let settled := settledClaims [⟨0,0,3,true,[1],[]⟩] [] [.sent 7,.sent 9,.draw 11] + require "settled ordinary and summed columns preserve order and rest" (match settled.result with + | some ([claim],rest) => claim.evals == [7,0,9] && rest == [.draw 11] + | _ => false) + require "missing settled ordinary scalar rejected" + ((settledClaims [⟨0,0,3,true,[1],[]⟩] [] [.sent 7]).result.isNone) + let registered := {cpuLayout with registers := [⟨0,[0,1]⟩]} + let registerRun := cpuPayload registered getterCosts cpuTokens + require "real register slice traversal constructs its padded ring" (match registerRun.result with + | some ((rings,points),rest) => rings.length == 2 && points.size == 5 && rest.isEmpty + | _ => false) + require "real source register interpreter agrees on acceptance" + (WHIRCallerClaims.cpuPayload registered cpuTokens).isSome + require "register success reaches all four output getters" + ((outputGetterTrace registered cpuTokens).length == 4) + require "empty register table list rejects before getters" + ((cpuPayload {cpuLayout with registers := [⟨0,[]⟩]} getterCosts cpuTokens).result.isNone) + require "out of range register table index rejected" + ((cpuPayload {cpuLayout with registers := [⟨0,[20]⟩]} getterCosts cpuTokens).result.isNone) + let mixed := {cpuLayout with tables := + [⟨0,0,0,false,[],[]⟩,⟨0,0,0,true,[],[]⟩] ++ List.replicate 9 ⟨0,0,0,false,[],[]⟩} + require "non-prefix settled layout rejected after real table execution" + ((cpuPayload mixed getterCosts (fixture (.cpu mixed))).result.isNone) + let ground := {cpuLayout with bus := {cpuLayout.bus with grinding := 7}} + require "wrong proof of work nonce rejected" + ((cpuPayload ground getterCosts [.nonce 8 (ByteCodec.encodeNat 24 0)]).result.isNone) + let preludeTokens := (List.replicate 11 (CallerToken.sent 0)) ++ + [.sent (E.ofK 1),.sent (E.ofK (UInt64.ofNat (2^40)))] + let originalTokens := preludeTokens ++ + (headerScalars record.shape record.root).map CallerToken.sent ++ record.point.map CallerToken.draw ++ + [.sent record.value] ++ freshTokens + let original := sourceClaims (.cpu cpuLayout) record.context getterCosts originalTokens + require "original anchored CPU source accepts prelude header anchor payload and binding" (match original.result with + | some (claims,rest) => decide (claims.record = record) && rest.isEmpty + | none => false) + require "bad CPU prelude clock rejected" ((prelude (.cpu cpuLayout) + ((List.replicate 11 (CallerToken.sent 0)) ++ [.sent 1,.sent 0])).result.isNone) + let pendingContext := {record.context with + pendingBytes := 17 + pending := fun i => if i.val < 3 then some (UInt64.ofNat (i.val+1)) else none} + let pendingRecord := {record with context := pendingContext} + let metadataCosts := {getterCosts with + pending := fun _ => 7 + rootByte := fun _ => 3 + contextByte := fun _ => 5} + let pendingFrame := (openingScalars pendingRecord).map CallerToken.sent + require "pending pack has exactly three reached word getters" + ((pendingGetterTrace pendingContext).length == 3) + require "one opening evaluates both digest projections and live pending words" + (openingGetterWork pendingRecord metadataCosts == 533) + let fullBinding := binding pendingRecord metadataCosts pendingFrame + let fullBindingBase := binding pendingRecord getterCosts pendingFrame + require "complete binding charges both reached metadata encodings" + (fullBinding.result.isSome && fullBinding.work == fullBindingBase.work + 1066) + let shortBinding := binding pendingRecord metadataCosts [] + let shortBindingBase := binding pendingRecord getterCosts [] + require "truncated binding charges only its reached first metadata encoding" + (shortBinding.result.isNone && shortBinding.work == shortBindingBase.work + 533) + let pendingFreshTokens := cpuTokens ++ pendingFrame + let pendingFull := freshInterpret (.cpu cpuLayout) pendingRecord metadataCosts pendingFreshTokens + let pendingBase := freshInterpret (.cpu cpuLayout) pendingRecord getterCosts pendingFreshTokens + require "fresh full interpretation charges shape plus two binding encodings" + (pendingFull.value.isSome && pendingFull.work == pendingBase.work + 1599) + let rejectedShape := freshInterpret (.cpu cpuLayout) pendingRecord metadataCosts [] + let rejectedShapeBase := freshInterpret (.cpu cpuLayout) pendingRecord getterCosts [] + require "shape rejection still charges expected shape metadata but no CPU getter" + (rejectedShape.value.isNone && rejectedShape.work == rejectedShapeBase.work + 533) + let trace := freshInterpretGetterTrace (.cpu cpuLayout) pendingRecord pendingFreshTokens + require "full interpretation traces exact reached accessor multiplicities" + (trace.outputs.length == 4 && trace.pendingWords.length == 9 && + trace.rootBytes.length == 192 && trace.contextBytes.length == 192) + require "weighted reached trace is exactly the full primitive fee delta" + (trace.price metadataCosts == 1617 && + pendingFull.work == + (freshInterpret (.cpu cpuLayout) pendingRecord zeroCosts pendingFreshTokens).work + + trace.price metadataCosts) + let failedTrace := freshInterpretGetterTrace (.cpu cpuLayout) pendingRecord [] + require "shape rejection trace omits all unreached payload and binding accesses" + (failedTrace.outputs.isEmpty && failedTrace.pendingWords.length == 3 && + failedTrace.rootBytes.length == 64 && failedTrace.contextBytes.length == 64) + IO.println "counted caller payload: CPU, recursion, malformed forms, binding, suffixes, and four getter charges passed" + +end Whir.PCSBCSCallerPayloadCostSmoke + +def main : IO Unit := Whir.PCSBCSCallerPayloadCostSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSCallerPayloadPolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerPayloadPolynomialBound.lean new file mode 100644 index 000000000..37fb16972 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerPayloadPolynomialBound.lean @@ -0,0 +1,437 @@ +import Whir.PCSBCSCallerPayloadCost +import Whir.PCSBCSCallerBusTablePolynomialBound +import Whir.PCSBCSCallerFlockPolynomialBound + +/-! Literal public-layout volume and deterministic resource bounds. Numeric +metadata contributes by value. These are bounds on the declared reached source +operations, not machine timing; arbitrary accessor prices remain explicit. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 +namespace Whir.PCSBCSCallerPayloadCost +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec + +private theorem bind_bound {A B : Type} (p : PCSBCSCallerParserCost.Parser A) + (f : A → PCSBCSCallerParserCost.Parser B) (ts : List CallerToken) + (m n total : Nat) (sum : m+n ≤ total) (hp : (p ts).work ≤ m) + (hf : ∀ a rest, (p ts).result = some (a,rest) → (f a rest).work ≤ n) : + ((p >>= f) ts).work ≤ total := + (PCSBCSCallerParserCost.bind_work_le p f ts m n hp hf).trans sum + +private theorem tick_bound {A : Type} (n : Nat) (p : PCSBCSCallerParserCost.Parser A) + (ts : List CallerToken) (cap total : Nat) (sum : n+cap ≤ total) + (hp : (p ts).work ≤ cap) : + ((PCSBCSCallerParserCost.tick n >>= fun _ => p) ts).work ≤ total := by + rw [PCSBCSCallerParserCost.tick_bind_work] + exact (Nat.add_le_add_left hp n).trans sum + +local macro "payload_bind " m:term "," n:term : tactic => + `(tactic| (apply bind_bound _ _ _ $m $n; · first | omega | nlinarith)) +local macro "payload_tick " n:term : tactic => + `(tactic| (apply tick_bound _ _ _ $n; · first | omega | nlinarith)) + +def placementVolume : Placement → Nat + | .committed offset dimension => 1+offset+dimension + | .port offset slot stride => 1+offset+slot+stride + | .sliced => 1 + +def placementsVolume (placements : Array Placement) : Nat := + 1+placements.size+(placements.toList.map placementVolume).sum + +def cpuTableVolume (table : CpuTableLayout) : Nat := + 1+table.base+table.tau+table.committedColumns+table.summedColumns.length+ + table.summedColumns.sum+(table.summedBits.map (fun f => 1+f.column+f.width)).sum + +def registerVolume (word : RegisterWord) : Nat := + 1+word.offset+word.tables.length+word.tables.sum + +def recLayoutVolume (layout : RecLayout) : Nat := + 1+PCSBCSCallerParserCost.busLayoutSize layout.bus+ + PCSBCSCallerParserCost.airLayoutsSize (layout.tables.map Prod.snd)+ + layout.tables.length+(layout.tables.map Prod.fst).sum+ + placementsVolume layout.placements+ + PCSBCSCallerParserCost.flockConfigurationSize [layout.hash]+layout.logInvRate + +def cpuAirs (layout : CpuLayout) : List AirLayout := + layout.tables.map CpuTableLayout.air ++ + layout.bus.producers.map (fun p => (⟨p.kappa,2*p.bits,p.bits,[]⟩ : AirLayout)) + +def cpuLayoutVolume (layout : CpuLayout) : Nat := + 1+PCSBCSCallerParserCost.busLayoutSize layout.bus+ + PCSBCSCallerParserCost.airLayoutsSize (cpuAirs layout)+ + layout.tables.length+(layout.tables.map cpuTableVolume).sum+ + placementsVolume layout.placements+ + PCSBCSCallerParserCost.flockConfigurationSize layout.flock+ + layout.registers.length+(layout.registers.map registerVolume).sum+ + layout.finalRegisterColumn+layout.logInvRate + +def layoutVolume : CallerLayout → Nat + | .recursion l => recLayoutVolume l + | .cpu l => cpuLayoutVolume l + +private theorem member_sum_le {A : Type} (xs : List A) (f : A → Nat) + (x : A) (member : x ∈ xs) : f x ≤ (xs.map f).sum := by + induction xs with + | nil => simp at member + | cons y ys ih => + simp only [List.mem_cons] at member + simp only [List.map_cons,List.sum_cons] + rcases member with rfl | member + · omega + · exact (ih member).trans (Nat.le_add_left _ _) + +theorem recLayoutVolume_components (l : RecLayout) : + PCSBCSCallerParserCost.busLayoutSize l.bus ≤ recLayoutVolume l ∧ + PCSBCSCallerParserCost.airLayoutsSize (l.tables.map Prod.snd) ≤ recLayoutVolume l ∧ + l.tables.length ≤ recLayoutVolume l ∧ + PCSBCSCallerParserCost.flockConfigurationSize [l.hash] ≤ recLayoutVolume l ∧ + placementsVolume l.placements ≤ recLayoutVolume l := by + unfold recLayoutVolume + omega + +theorem cpuLayoutVolume_components (l : CpuLayout) : + PCSBCSCallerParserCost.busLayoutSize l.bus ≤ cpuLayoutVolume l ∧ + PCSBCSCallerParserCost.airLayoutsSize (cpuAirs l) ≤ cpuLayoutVolume l ∧ + l.tables.length ≤ cpuLayoutVolume l ∧ + PCSBCSCallerParserCost.flockConfigurationSize l.flock ≤ cpuLayoutVolume l ∧ + placementsVolume l.placements ≤ cpuLayoutVolume l ∧ + l.registers.length ≤ cpuLayoutVolume l := by + unfold cpuLayoutVolume + omega + +theorem column_geometry (bus : List ColumnClaim) (paired : List (Nat × TableClaims)) + (size : Nat) (busLength : bus.length ≤ 2*size*size) + (busPoints : ∀ c ∈ bus, c.point.length ≤ size) + (pairedLength : paired.length ≤ size) + (tables : ∀ p ∈ paired, p.2.point.length ≤ size ∧ p.2.evals.length ≤ size) : + (bus ++ paired.flatMap (fun p => WHIRCallerClaims.tableColumns p.1 p.2)).length ≤ 3*size*size ∧ + ∀ c ∈ bus ++ paired.flatMap (fun p => WHIRCallerClaims.tableColumns p.1 p.2), + c.point.length ≤ size := by + constructor + · have total := sumMap_le paired + (fun p => (WHIRCallerClaims.tableColumns p.1 p.2).length) size (by + intro p hp + have count := PCSBCSCallerParserCost.tableColumns_length p.1 p.2 + rw [PCSBCSCallerParserCost.tableColumns_erasure] at count + exact count.trans_le (tables p hp).2) + simp only [List.length_append,List.length_flatMap] + nlinarith + · intro c hc + rcases List.mem_append.mp hc with hc | hc + · exact busPoints c hc + · obtain ⟨p,hp,hc⟩ := List.mem_flatMap.mp hc + have point := PCSBCSCallerParserCost.tableColumns_point p.1 p.2 c + rw [PCSBCSCallerParserCost.tableColumns_erasure] at point + rw [point hc] + exact (tables p hp).1 + +private def recFinish (l : RecLayout) (bus : List ColumnClaim) (tables : List TableClaims) + (rings : List RingPCSGame.FamilyClaim) : + PCSBCSCallerParserCost.Parser (List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim) := do + let paired := (l.tables.map Prod.fst).zip tables + let columns ← charged (3*l.tables.length+1+4*min l.tables.length tables.length+1+ + columnsWork bus paired) + (bus ++ paired.flatMap (fun p => WHIRCallerClaims.tableColumns p.1 p.2)) + let placed := PCSBCSCallerParserCost.placeClaims l.placements columns + let points ← PCSBCSCallerParserCost.liftOption placed.work placed.value + pure (rings,points) + +private theorem recFinish_work_le (l : RecLayout) (bus : List ColumnClaim) + (tables : List TableClaims) (rings : List RingPCSGame.FamilyClaim) + (tokens : List CallerToken) (size : Nat) + (layout : l.tables.length ≤ size) + (busLength : bus.length ≤ 2*size*size) + (busPoints : ∀ c ∈ bus, c.point.length ≤ size) + (tableCaps : ∀ c ∈ tables, c.point.length ≤ size ∧ c.evals.length ≤ size) : + (recFinish l bus tables rings tokens).work ≤ + 6*size^3+57*size^2+13*size+10 := by + let paired := (l.tables.map Prod.fst).zip tables + have length : paired.length ≤ size := by + simp only [paired,List.length_zip,List.length_map] + exact (Nat.min_le_left _ _).trans layout + have caps : ∀ p ∈ paired, p.2.point.length ≤ size ∧ p.2.evals.length ≤ size := by + intro p hp + have ht := (List.of_mem_zip hp).2 + exact tableCaps p.2 ht + have geometry := column_geometry bus paired size busLength busPoints length caps + have construction := columnsWork_le bus paired size (fun p hp => (caps p hp).2) + have placed := PCSBCSCallerParserCost.placeClaims_work_le l.placements + (bus ++ paired.flatMap (fun p => WHIRCallerClaims.tableColumns p.1 p.2)) size geometry.2 + have placedProduct := Nat.mul_le_mul_right (2*size+15) geometry.1 + have constructionProduct := Nat.mul_le_mul_right (8*size+4) length + dsimp only [paired] at construction geometry placed placedProduct constructionProduct + unfold recFinish charged + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure,PCSBCSCallerParserCost.liftOption] + cases (PCSBCSCallerParserCost.placeClaims l.placements + (bus ++ paired.flatMap (fun p => WHIRCallerClaims.tableColumns p.1 p.2))).value <;> + simp only [Option.map_none,Option.map_some,Nat.add_zero] <;> + nlinarith [Nat.min_le_left l.tables.length tables.length] + +theorem recPayload_work_polynomial (l : RecLayout) (tokens : List CallerToken) + (size : Nat) (volume : recLayoutVolume l ≤ size) : + (recPayload l tokens).work ≤ + PCSBCSCallerParserCost.busClaimsWork size+ + 100*(size+1)^3*size+6*size^3+79*size^2+874*size+738 := by + have components := recLayoutVolume_components l + have busConfig := components.1.trans volume + have airConfig := components.2.1.trans volume + have count := components.2.2.1.trans volume + have flockConfig := components.2.2.2.1.trans volume + unfold recPayload + change ((do + let pair ← PCSBCSCallerParserCost.busClaims l.bus + let _ ← PCSBCSCallerParserCost.drawScalar + let airs ← charged (3*l.tables.length+1) (l.tables.map Prod.snd) + let tables ← PCSBCSCallerParserCost.constraintClaims airs pair.1 + let rings ← PCSBCSCallerParserCost.flockClaims [l.hash] + recFinish l pair.2 tables rings) tokens).work ≤ _ + payload_bind (PCSBCSCallerParserCost.busClaimsWork size), + (100*(size+1)^3*size+6*size^3+79*size^2+874*size+738) + · exact PCSBCSCallerParserCost.busClaims_work_polynomial l.bus tokens size busConfig + · intro pair rest accepted + have busCaps := PCSBCSCallerParserCost.busClaims_success_caps l.bus tokens rest pair size busConfig accepted + payload_bind 4, (100*(size+1)^3*size+6*size^3+79*size^2+874*size+734) + · exact PCSBCSCallerParserCost.drawScalar_work_le rest + · intro unused tail accepted + unfold charged + simp only [bind_assoc,pure_bind] + rw [PCSBCSCallerParserCost.tick_bind_work] + have later : ((do + let tables ← PCSBCSCallerParserCost.constraintClaims (l.tables.map Prod.snd) pair.1 + let rings ← PCSBCSCallerParserCost.flockClaims [l.hash] + recFinish l pair.2 tables rings) tail).work ≤ + 100*(size+1)^3*size+6*size^3+79*size^2+871*size+733 := by + payload_bind (100*(size+1)^3*size+2*size^2+50*size+20), + (6*size^3+77*size^2+821*size+713) + · simpa only [pow_two,Nat.mul_assoc] using + PCSBCSCallerParserCost.constraintClaims_work_polynomial _ _ tail size airConfig busCaps.2.1 + · intro tables tableRest received + have tableCaps := PCSBCSCallerParserCost.constraintClaims_success_caps _ _ tail tableRest tables size airConfig received + payload_bind (20*size^2+800*size+700), + (6*size^3+57*size^2+13*size+10) + · have hw := PCSBCSCallerParserCost.flockClaims_work_le [l.hash] tableRest + nlinarith [Nat.mul_self_le_mul_self flockConfig] + · intro rings final accepted + exact recFinish_work_le l pair.2 tables rings final size count busCaps.2.2.1 + busCaps.2.2.2 (fun c hc => ⟨(tableCaps.2 c hc).1,(tableCaps.2 c hc).2.1⟩) + nlinarith + +private def settledColumnStep (table : CpuTableLayout) (c : Nat) + (state : List E × List E) : + PCSBCSCallerParserCost.Parser (ForInStep (List E × List E)) := do + PCSBCSCallerParserCost.tick (1+containsWork c table.summedColumns+2*state.2.length+2) + if c ∈ table.summedColumns then pure (.yield (state.1,state.2++[0])) + else match state.1 with + | [] => do PCSBCSCallerParserCost.check false; pure (.yield state) + | x::xs => pure (.yield (xs,state.2++[x])) + +private theorem settledColumnStep_work (table : CpuTableLayout) (c : Nat) + (state : List E × List E) (tokens : List CallerToken) : + (settledColumnStep table c state tokens).work ≤ + 2*state.2.length+3*table.summedColumns.length+6 := by + have search := containsWork_le c table.summedColumns + unfold settledColumnStep + rw [PCSBCSCallerParserCost.tick_bind_work] + split + · simp only [PCSBCSCallerParserCost.pure_work]; omega + · cases state.1 with + | nil => simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.check]; omega + | cons x xs => simp only [PCSBCSCallerParserCost.pure_work]; omega + +private theorem settledColumnStep_growth (table : CpuTableLayout) (c : Nat) + (state : List E × List E) (tokens rest : List CallerToken) + (step : ForInStep (List E × List E)) + (accepted : (settledColumnStep table c state tokens).result = some (step,rest)) : + (PCSBCSCallerParserCost.iterationState step).2.length ≤ state.2.length+1 := by + unfold settledColumnStep at accepted + simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick] at accepted + split at accepted + · simp only [Pure.pure,PCSBCSCallerParserCost.pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + simp [PCSBCSCallerParserCost.iterationState] + · cases remaining : state.1 with + | nil => simp [remaining,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.check] at accepted + | cons x xs => + rw [remaining] at accepted + simp only [Pure.pure,PCSBCSCallerParserCost.pure,Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + simp [PCSBCSCallerParserCost.iterationState] + +private theorem settledColumnLoop_work (table : CpuTableLayout) (sent : List E) + (tokens : List CallerToken) : + (forIn (List.range table.committedColumns) (sent,[]) (settledColumnStep table) tokens).work ≤ + table.committedColumns*(2*table.committedColumns+3*table.summedColumns.length+6) := by + have growth := PCSBCSCallerParserCost.forIn_growth_work_le + (List.range table.committedColumns) (sent,[]) (settledColumnStep table) + (fun state => state.2.length) 2 (3*table.summedColumns.length+6) 1 + (fun c _ state ts => settledColumnStep_work table c state ts) + (fun c _ state ts step rest h => settledColumnStep_growth table c state ts rest step h) tokens + simpa [Nat.add_assoc] using growth + +private def settledTableStep (point : List E) (table : CpuTableLayout) + (claims : List TableClaims) : PCSBCSCallerParserCost.Parser (ForInStep (List TableClaims)) := do + PCSBCSCallerParserCost.tick 2 + if table.settled then + PCSBCSCallerParserCost.tick (allWork (· < table.committedColumns) (fun _ => 2) table.summedColumns) + PCSBCSCallerParserCost.check (table.summedColumns.all (· < table.committedColumns)) + PCSBCSCallerParserCost.tick (dupsWork table.summedColumns []+table.summedColumns.eraseDups.length+1+ + table.summedColumns.length+1+1) + PCSBCSCallerParserCost.check (table.summedColumns.eraseDups.length==table.summedColumns.length) + PCSBCSCallerParserCost.tick (table.summedColumns.length+2) + let sent ← PCSBCSCallerParserCost.readScalars (table.committedColumns-table.summedColumns.length) + PCSBCSCallerParserCost.tick (3*table.committedColumns+1) + let state ← forIn (List.range table.committedColumns) (sent,[]) (settledColumnStep table) + PCSBCSCallerParserCost.tick (point.length+4) + PCSBCSCallerParserCost.check (table.tau≤point.length && state.1.isEmpty) + PCSBCSCallerParserCost.tick (2*min table.tau point.length+1+2*claims.length+3) + pure (.yield (claims++[⟨point.take table.tau,state.2,[]⟩])) + else pure (.yield claims) + +private theorem settledClaims_normalized (tables : List CpuTableLayout) (point : List E) : + settledClaims tables point = + (forIn tables [] (settledTableStep point) >>= fun claims => pure claims) := rfl + +private theorem dedup_length_le {A : Type} [BEq A] (xs : List A) : + xs.eraseDups.length ≤ xs.length := by + have loop (as seen : List A) : + (List.eraseDupsBy.loop (fun a b => a == b) as seen).length ≤ as.length+seen.length := by + induction as generalizing seen with + | nil => simp [List.eraseDupsBy.loop] + | cons a as ih => + simp only [List.eraseDupsBy.loop] + split + · have := ih seen; simp only [List.length_cons]; omega + · have := ih (a::seen); simp only [List.length_cons] at *; omega + exact loop xs [] + +private theorem settledTableStep_work (point : List E) (table : CpuTableLayout) + (claims : List TableClaims) (tokens : List CallerToken) (size : Nat) + (columns : table.committedColumns ≤ size) (summed : table.summedColumns.length ≤ size) + (pointCap : point.length ≤ size) : + (settledTableStep point table claims tokens).work ≤ 2*claims.length+100*(size+1)^2 := by + have all := allWork_le (· < table.committedColumns) (fun _ => 2) table.summedColumns 2 (by simp) + have distinct := dupsWork_le table.summedColumns [] + have erased := dedup_length_le table.summedColumns + let c := table.committedColumns + let u := table.summedColumns.length + let p := point.length + let loop := c*(2*c+3*u+6) + have allCost : allWork (· < table.committedColumns) (fun _ => 2) table.summedColumns ≤ 4*u+1 := all + have dupsCost : dupsWork table.summedColumns []+table.summedColumns.eraseDups.length+1+ + table.summedColumns.length+1+1 ≤ 3*(u+1)^2+2*u+3 := by + dsimp only [u] + simp only [List.length_nil] at distinct + nlinarith + have detailed : (settledTableStep point table claims tokens).work ≤ + 2*claims.length+loop+3*(u+1)^2+7*u+12*c+3*p+40 := by + unfold settledTableStep + payload_tick (2*claims.length+loop+3*(u+1)^2+7*u+12*c+3*p+38) + split + · payload_tick (2*claims.length+loop+3*(u+1)^2+3*u+12*c+3*p+37) + payload_bind 3, (2*claims.length+loop+3*(u+1)^2+3*u+12*c+3*p+34) + · exact PCSBCSCallerParserCost.check_work_le _ _ + · intro unused rest checked + payload_tick (2*claims.length+loop+u+12*c+3*p+31) + payload_bind 3, (2*claims.length+loop+u+12*c+3*p+28) + · exact PCSBCSCallerParserCost.check_work_le _ _ + · intro unused tail checked + payload_tick (2*claims.length+loop+12*c+3*p+26) + payload_bind (9*c+2), (2*claims.length+loop+3*c+3*p+24) + · have read := PCSBCSCallerParserCost.readScalars_work_le + (table.committedColumns-table.summedColumns.length) tail + dsimp [c] at *; omega + · intro sent remaining read + payload_tick (2*claims.length+loop+3*p+23) + payload_bind loop, (2*claims.length+3*p+23) + · exact settledColumnLoop_work table sent remaining + · intro state suffix stateRead + payload_tick (2*claims.length+2*p+19) + payload_bind 3, (2*claims.length+2*p+16) + · exact PCSBCSCallerParserCost.check_work_le _ _ + · intro unused final checked + rw [PCSBCSCallerParserCost.tick_bind_work] + simp only [PCSBCSCallerParserCost.pure_work] + dsimp [p] at *; omega + · simp only [PCSBCSCallerParserCost.pure_work] + omega + dsimp [loop,c,u,p] at detailed + have product : table.committedColumns*(2*table.committedColumns+3*table.summedColumns.length+6) ≤ + size*(5*size+6) := Nat.mul_le_mul columns (by omega) + nlinarith [Nat.mul_self_le_mul_self summed] + +private theorem settledTableStep_growth (point : List E) (table : CpuTableLayout) + (claims : List TableClaims) (tokens rest : List CallerToken) + (step : ForInStep (List TableClaims)) + (accepted : (settledTableStep point table claims tokens).result = some (step,rest)) : + (PCSBCSCallerParserCost.iterationState step).length ≤ claims.length+1 := by + unfold settledTableStep at accepted + repeat' first + | dsimp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + Pure.pure,PCSBCSCallerParserCost.pure] at accepted + | split at accepted + all_goals simp only [Option.some.injEq,Prod.mk.injEq,reduceCtorEq] at accepted + all_goals rcases accepted with ⟨rfl,rfl⟩ + all_goals simp [PCSBCSCallerParserCost.iterationState] + +theorem cpuTableVolume_components (table : CpuTableLayout) : + table.committedColumns ≤ cpuTableVolume table ∧ + table.summedColumns.length ≤ cpuTableVolume table ∧ + table.tau ≤ cpuTableVolume table := by + unfold cpuTableVolume + omega + +theorem settledClaims_work_polynomial (tables : List CpuTableLayout) (point : List E) + (tokens : List CallerToken) (size : Nat) (_count : tables.length ≤ size) + (volume : ∀ table ∈ tables, cpuTableVolume table ≤ size) (pointCap : point.length ≤ size) : + (settledClaims tables point tokens).work ≤ + tables.length*(2*tables.length+100*(size+1)^2) := by + rw [settledClaims_normalized] + have growth := PCSBCSCallerParserCost.forIn_growth_work_le tables [] + (settledTableStep point) List.length 2 (100*(size+1)^2) 1 + (by + intro table member claims ts + have caps := cpuTableVolume_components table + exact settledTableStep_work point table claims ts size + (caps.1.trans (volume table member)) (caps.2.1.trans (volume table member)) pointCap) + (fun table _ claims ts step rest h => settledTableStep_growth point table claims ts rest step h) tokens + have bound : (forIn tables [] (settledTableStep point) tokens).work ≤ + tables.length*(2*tables.length+100*(size+1)^2) := by + simpa using growth + have final := PCSBCSCallerParserCost.bind_work_le + (forIn tables [] (settledTableStep point)) (fun value => PCSBCSCallerParserCost.pure value) + tokens _ 0 bound + (by intro value rest accepted; exact (PCSBCSCallerParserCost.pure_work value rest).le) + simpa only [Nat.add_zero,Pure.pure,PCSBCSCallerParserCost.pure] using final + +theorem settledClaims_success_caps (tables : List CpuTableLayout) (point : List E) + (tokens rest : List CallerToken) (claims : List TableClaims) (size : Nat) + (count : tables.length ≤ size) + (volume : ∀ table ∈ tables, cpuTableVolume table ≤ size) + (accepted : (settledClaims tables point tokens).result = some (claims,rest)) : + claims.length ≤ size ∧ + ∀ c ∈ claims, c.point.length ≤ size ∧ c.evals.length ≤ size := by + constructor + · rw [settledClaims_success_length tables point tokens rest claims accepted] + exact (List.length_filter_le _ _).trans count + · have geometry := settledClaims_success_geometry tables point tokens rest claims accepted + have filtered : ∀ table ∈ tables.filter CpuTableLayout.settled, cpuTableVolume table ≤ size := by + intro table member + exact volume table (List.mem_filter.mp member).1 + clear accepted + generalize tables.filter CpuTableLayout.settled = selected at geometry filtered + induction geometry with + | nil => simp + | @cons table claim selected claims g relation ih => + intro c member + rcases List.mem_cons.mp member with rfl | member + · have v := filtered table (by simp) + have dimensions := cpuTableVolume_components table + exact ⟨g.1.trans (dimensions.2.2.trans v),g.2.trans (dimensions.1.trans v)⟩ + · exact ih (fun t ht => filtered t (List.mem_cons_of_mem _ ht)) c member + +#print axioms recPayload_work_polynomial +#print axioms settledClaims_work_polynomial +#print axioms settledClaims_success_caps + +end Whir.PCSBCSCallerPayloadCost diff --git a/verification/whir/Whir/PCSBCSCallerSchedulePolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerSchedulePolynomialBound.lean new file mode 100644 index 000000000..db4f773a0 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerSchedulePolynomialBound.lean @@ -0,0 +1,432 @@ +import Whir.PCSBCSCallerPayloadPolynomialBound + +/-! Bounds for the actual source schedule constructors. Literal numeric metadata +is charged by value; duplicate framework keys pay the actual dedup traversal. +These bounds do not require validity of the caller layout. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSCallerPayloadCost +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec + +private theorem sum_member {A : Type} (xs : List A) (f : A → Nat) + (x : A) (hx : x ∈ xs) : f x ≤ (xs.map f).sum := by + induction xs with + | nil => simp at hx + | cons a xs ih => + simp only [List.mem_cons] at hx + simp only [List.map_cons,List.sum_cons] + rcases hx with rfl | hx + · omega + · have := ih hx; omega + +private theorem sum_count {A : Type} (xs : List A) (f : A → Nat) + (hf : ∀ x ∈ xs, 1 ≤ f x) : xs.length ≤ (xs.map f).sum := by + induction xs with + | nil => simp + | cons a xs ih => + have ha := hf a (by simp) + have ht := ih (by intro x hx; exact hf x (by simp [hx])) + simp only [List.length_cons,List.map_cons,List.sum_cons] + omega + +private theorem flat_resource {A : Type} (xs : List A) + (f : A → PCSBCSCallerParserCost.Costed Schedule) (w n : Nat) + (h : ∀ x ∈ xs, (f x).work ≤ w ∧ (f x).value.length ≤ n) : + (scheduleFlatMap xs f).work ≤ xs.length+1+xs.length*(w+2*n+1) ∧ + (scheduleFlatMap xs f).value.length ≤ xs.length*n := by + have hw := sumMap_le xs (fun x => (f x).work+2*(f x).value.length+1) + (w+2*n+1) (by intro x hx; have := h x hx; omega) + have hn := sumMap_le xs (fun x => (f x).value.length) n + (by intro x hx; exact (h x hx).2) + simp only [scheduleFlatMap,List.length_flatMap] + simpa only [Nat.mul_comm] using (show + xs.length+1+(xs.map (fun x => (f x).work+2*(f x).value.length+1)).sum ≤ + xs.length+1+(w+2*n+1)*xs.length ∧ + (xs.map (fun x => (f x).value.length)).sum ≤ n*xs.length from ⟨by omega,hn⟩) + +private theorem repeat_resource (k : Nat) (a : PCSBCSCallerParserCost.Costed Schedule) + (w n : Nat) (h : a.work ≤ w ∧ a.value.length ≤ n) : + (scheduleRepeat k a).work ≤ w+3*k+2+k*(2*n+2) ∧ + (scheduleRepeat k a).value.length ≤ k*n := by + have length : (List.replicate k a.value).flatten.length = k*a.value.length := by + induction k with + | zero => simp + | succ k ih => simp [List.replicate_succ,ih,Nat.succ_mul,Nat.add_comm] + simp only [scheduleRepeat,length] + constructor <;> nlinarith [Nat.mul_le_mul_left k h.2] + +@[simp] theorem gkrShape_value (mu : Nat) : + (gkrShape mu).value = WHIRCallerClaims.gkrShape mu := rfl +@[simp] theorem frameworkKeys_value (layout : BusLayout) : + (frameworkKeys layout).value = WHIRCallerClaims.frameworkKeys layout := rfl +@[simp] theorem busShape_value (layout : BusLayout) : + (busShape layout).value = WHIRCallerClaims.busShape layout := rfl +@[simp] theorem constraintsShape_value (layouts : List AirLayout) : + (constraintsShape layouts).value = WHIRCallerClaims.constraintsShape layouts := rfl +@[simp] theorem flockProgramShape_value (layouts : List FlockLayout) : + (flockProgramShape layouts).value = WHIRCallerClaims.flockProgramShape layouts := rfl +@[simp] theorem callerShape_value (layout : CallerLayout) : + (callerShape layout).value = WHIRCallerClaims.callerShape layout := by cases layout <;> rfl +@[simp] theorem freshCallerShape_value (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + (freshCallerShape layout saved cost).value = AnchoredSourceFreshCaller.callerShape layout saved := rfl + +private theorem gkr_assembled_value (mu : Nat) : + (scheduleAppend (scheduleReads 1) + (scheduleAppend (scheduleDraws 1) + (scheduleAppend (if mu % 2 = 1 then scheduleAppend (scheduleReads 4) (scheduleDraws 2) + else ⟨[],1⟩) + (scheduleFlatMap (List.range (mu/2)) (fun i => + scheduleAppend (scheduleRepeat (mu%2+2*i) + (scheduleAppend (scheduleReads 4) (scheduleDraws 1))) + (scheduleAppend (scheduleReads 8) (scheduleDraws 3))))))).value = + WHIRCallerClaims.gkrShape mu := by + simp only [scheduleAppend,scheduleReads,scheduleDraws,scheduleRepeat,scheduleFlatMap, + WHIRCallerClaims.gkrShape,List.append_assoc] + split <;> rfl + + theorem gkrShape_resource (mu size : Nat) (bound : mu ≤ size) : + (gkrShape mu).work ≤ 300*(size+1)^2 ∧ + (gkrShape mu).value.length ≤ 300*(size+1)^2 := by + have odd : (if mu%2=1 then scheduleAppend (scheduleReads 4) (scheduleDraws 2) + else (⟨[],1⟩ : PCSBCSCallerParserCost.Costed Schedule)).work ≤ 33 ∧ + (if mu%2=1 then scheduleAppend (scheduleReads 4) (scheduleDraws 2) + else (⟨[],1⟩ : PCSBCSCallerParserCost.Costed Schedule)).value.length ≤ 6 := by + split <;> simp [scheduleAppend,scheduleReads,scheduleDraws] + have rows := flat_resource (List.range (mu/2)) (fun i => + scheduleAppend (scheduleRepeat (mu%2+2*i) + (scheduleAppend (scheduleReads 4) (scheduleDraws 1))) + (scheduleAppend (scheduleReads 8) (scheduleDraws 3))) (80*size+100) (10*size+11) (by + intro i hi + have index := List.mem_range.mp hi + have rem := Nat.mod_lt mu (by decide : 0<2) + have rep := repeat_resource (mu%2+2*i) + (scheduleAppend (scheduleReads 4) (scheduleDraws 1)) 28 5 + (by simp [scheduleAppend,scheduleReads,scheduleDraws]) + simp only [scheduleAppend,scheduleReads,scheduleDraws,scheduleRepeat,List.length_append, + List.length_replicate] at rep ⊢ + constructor <;> nlinarith [Nat.div_mul_le_self mu 2]) + simp only [List.length_range] at rows + have count : mu/2 ≤ size := (Nat.div_le_self _ _).trans bound + have rw := Nat.mul_le_mul_right (80*size+100+2*(10*size+11)+1) count + have rn := Nat.mul_le_mul_right (10*size+11) count + simp only [gkrShape] + rw [← gkr_assembled_value mu] + simp only [scheduleAppend,scheduleReads,scheduleDraws, + List.length_append,List.length_replicate] at odd rows ⊢ + constructor <;> nlinarith [Nat.div_le_self mu 2] +private theorem dedup_length {A : Type} [BEq A] (xs : List A) : + xs.eraseDups.length ≤ xs.length := by + have loop (as seen : List A) : + (List.eraseDupsBy.loop (fun a b => a == b) as seen).length ≤ as.length+seen.length := by + induction as generalizing seen with + | nil => simp [List.eraseDupsBy.loop] + | cons a as ih => + simp only [List.eraseDupsBy.loop] + split + · have := ih seen; simp only [List.length_cons]; omega + · have := ih (a::seen); simp only [List.length_cons] at *; omega + exact loop xs [] + +theorem frameworkKeys_resource (l : BusLayout) (size : Nat) + (volume : PCSBCSCallerParserCost.busLayoutSize l ≤ size) : + (frameworkKeys l).work ≤ 30*(size+1)^4 ∧ + (frameworkKeys l).value.length ≤ size^2 := by + let blocks := l.push++l.pull + let keys := blocks.flatMap (fun b => if b.tableOwned then [] + else b.coords.filterMap (fun c => match c with | .column col => some (col,b.kappa) | _ => none)) + have caps := PCSBCSCallerParserCost.busLayoutSize_components l + have count : blocks.length ≤ size := caps.1.trans volume + have coords : ∀ b ∈ blocks, b.coords.length ≤ size := by + intro b hb; exact (caps.2 b hb).trans volume + have raw : keys.length ≤ size*size := by + have hs := sumMap_le blocks (fun b => + (if b.tableOwned then [] else b.coords.filterMap (fun c => + match c with | .column col => some (col,b.kappa) | _ => none)).length) size (by + intro b hb + split + · simp + · exact (List.length_filterMap_le _ _).trans (coords b hb)) + simp only [keys,List.length_flatMap] + exact hs.trans (Nat.mul_le_mul_left size count) + have bw := sumMap_le blocks (fun b => 2+if b.tableOwned then 1 else + 1+(b.coords.map (fun c => match c with | .column _ => 5 | _ => 2)).sum) + (3+5*size) (by + intro b hb + have hs := sumMap_le b.coords (fun c => match c with | .column _ => 5 | _ => 2) + 5 (by intro c _; cases c <;> simp) + have hc := coords b hb + split <;> nlinarith) + have cost := PCSBCSCallerParserCost.eraseDupsCost_le 2 keys [] + have out := dedup_length keys + have push : l.push.length ≤ size := by simp only [blocks,List.length_append] at count; omega + have sumcap := Nat.mul_le_mul_left (3+5*size) count + have square := Nat.mul_self_le_mul_self raw + change (frameworkKeys l).work ≤ _ ∧ (WHIRCallerClaims.frameworkKeys l).length ≤ _ + change _ ∧ keys.eraseDups.length ≤ size^2 + simp only [frameworkKeys] + change 2*l.push.length+1+blocks.length+1+ + (blocks.map (fun b => 2+if b.tableOwned then 1 else + 1+(b.coords.map (fun c => match c with | .column _ => 5 | _ => 2)).sum)).sum+ + 2*keys.length+blocks.length+PCSBCSCallerParserCost.eraseDupsCost 2 keys [] ≤ _ ∧ _ + simp only [List.length_nil,Nat.add_zero] at cost + constructor <;> nlinarith [out] + +private theorem bus_assembled_value (l : BusLayout) : + (scheduleAppend (if l.grinding>0 then ⟨[.nonce l.grinding],4⟩ else ⟨[],2⟩) + (scheduleAppend (scheduleDraws 5) + (scheduleAppend (gkrShape l.mu) (scheduleReads (frameworkKeys l).value.length)))).value = + WHIRCallerClaims.busShape l := by + simp only [scheduleAppend,scheduleDraws,scheduleReads,gkrShape_value,frameworkKeys_value, + WHIRCallerClaims.busShape,List.append_assoc] + split <;> rfl + +theorem busShape_resource (l : BusLayout) (size : Nat) + (volume : PCSBCSCallerParserCost.busLayoutSize l ≤ size) : + (busShape l).work ≤ 1500*(size+1)^4 ∧ + (busShape l).value.length ≤ 1500*(size+1)^4 := by + have keys := frameworkKeys_resource l size volume + have gkr := gkrShape_resource l.mu size ((PCSBCSCallerParserCost.bus_mu_le_size l).trans volume) + have muCost := PCSBCSCallerParserCost.bus_mu_work_le l + have grinding : (if l.grinding>0 then + (⟨[.nonce l.grinding],4⟩ : PCSBCSCallerParserCost.Costed Schedule) else ⟨[],2⟩).work ≤ 4 ∧ + (if l.grinding>0 then + (⟨[.nonce l.grinding],4⟩ : PCSBCSCallerParserCost.Costed Schedule) else ⟨[],2⟩).value.length ≤ 1 := by + split <;> simp + simp only [busShape,PCSBCSCallerParserCost.mu_erasure] + rw [← bus_assembled_value l] + simp only [scheduleAppend,scheduleReads,scheduleDraws,List.length_append,List.length_replicate] + constructor <;> nlinarith [Nat.zero_le ((size+1)^2)] + +private theorem air_caps (ls : List AirLayout) (size : Nat) + (volume : PCSBCSCallerParserCost.airLayoutsSize ls ≤ size) : + ls.length ≤ size ∧ ∀ l ∈ ls, + l.tau ≤ size ∧ l.columns ≤ size ∧ l.fields.length ≤ size ∧ + (l.fields.map BitField.width).sum ≤ size := by + have count := sum_count ls (fun l => 1+PCSBCSCallerParserCost.airLayoutSize l) + (by intro l _; omega) + constructor + · unfold PCSBCSCallerParserCost.airLayoutsSize at volume; omega + · intro l hl + have member := sum_member ls (fun l => 1+PCSBCSCallerParserCost.airLayoutSize l) l hl + have fields := sum_count l.fields (fun f => 1+f.column+f.width) (by intro f _; omega) + have widths : (l.fields.map BitField.width).sum ≤ + (l.fields.map (fun f => 1+f.column+f.width)).sum := by + apply List.sum_le_sum; intro f _; omega + unfold PCSBCSCallerParserCost.airLayoutsSize PCSBCSCallerParserCost.airLayoutSize at * + omega + +private theorem constraints_assembled_value (ls : List AirLayout) : + (scheduleAppend (scheduleRepeat ((ls.map AirLayout.tau).foldl max 0) + (scheduleAppend (scheduleReads 3) (scheduleDraws 1))) + (scheduleFlatMap ls (fun l => + let a := scheduleAppend (scheduleReads (l.columns-l.publicColumns-l.fields.length)) + (scheduleReads (l.fields.map BitField.width).sum) + ⟨a.value,a.work+5+l.fields.length+1+5*l.fields.length+2⟩))).value = + WHIRCallerClaims.constraintsShape ls := by + rfl + +theorem constraintsShape_resource (ls : List AirLayout) (size : Nat) + (volume : PCSBCSCallerParserCost.airLayoutsSize ls ≤ size) : + (constraintsShape ls).work ≤ 200*(size+1)^2 ∧ + (constraintsShape ls).value.length ≤ 200*(size+1)^2 := by + have caps := air_caps ls size volume + have rounds : (ls.map AirLayout.tau).foldl max 0 ≤ size := by + apply PCSBCSCallerParserCost.FlockPolynomial.max_fold_le _ _ _ (Nat.zero_le _) + intro t ht + obtain ⟨l,hl,rfl⟩ := List.mem_map.mp ht + exact (caps.2 l hl).1 + have front := repeat_resource ((ls.map AirLayout.tau).foldl max 0) + (scheduleAppend (scheduleReads 3) (scheduleDraws 1)) 23 4 + (by simp [scheduleAppend,scheduleReads,scheduleDraws]) + have tables := flat_resource ls (fun l => + let a := scheduleAppend (scheduleReads (l.columns-l.publicColumns-l.fields.length)) + (scheduleReads (l.fields.map BitField.width).sum) + ⟨a.value,a.work+5+l.fields.length+1+5*l.fields.length+2⟩) (14*size+13) (2*size) (by + intro l hl + have hc := caps.2 l hl + simp only [scheduleAppend,scheduleReads,List.length_append,List.length_replicate] + constructor <;> omega) + have pw := Nat.mul_le_mul_right (14*size+13+2*(2*size)+1) caps.1 + have pn := Nat.mul_le_mul_right (2*size) caps.1 + simp only [constraintsShape] + rw [← constraints_assembled_value ls] + simp only [scheduleAppend,List.length_append] at front tables ⊢ + constructor <;> nlinarith + +private theorem flock_assembled_value (ls : List FlockLayout) : + (scheduleAppend (scheduleDraws ((ls.map FlockLayout.logN).foldl max 0-13+1)) + (scheduleAppend (scheduleReads 64) (scheduleAppend (scheduleDraws 1) + (scheduleAppend (scheduleRepeat ((ls.map FlockLayout.logN).foldl max 0-6) + (scheduleAppend (scheduleReads 2) (scheduleDraws 1))) + (scheduleAppend (scheduleReads (3*ls.length)) (scheduleAppend (scheduleDraws 1) + (scheduleAppend (scheduleRepeat ((ls.map (fun l => l.kLog-6)).foldl max 0) + (scheduleAppend (scheduleReads 2) (scheduleDraws 1))) + (scheduleFlatMap ls (fun _ => scheduleAppend (scheduleReads 64) (scheduleReads 1)))))))))).value = + WHIRCallerClaims.flockProgramShape ls := by + simp only [scheduleAppend,scheduleReads,scheduleDraws,scheduleRepeat,scheduleFlatMap, + WHIRCallerClaims.flockProgramShape,List.append_assoc] + rfl + +theorem flockProgramShape_resource (ls : List FlockLayout) (size : Nat) + (volume : PCSBCSCallerParserCost.flockConfigurationSize ls ≤ size) : + (flockProgramShape ls).work ≤ 2000*(size+1) ∧ + (flockProgramShape ls).value.length ≤ 2000*(size+1) := by + have caps := PCSBCSCallerParserCost.FlockPolynomial.dimension_caps ls + have count := caps.1.trans volume + have m := caps.2.1.trans volume + have r := caps.2.2.trans volume + have first := repeat_resource ((ls.map FlockLayout.logN).foldl max 0-6) + (scheduleAppend (scheduleReads 2) (scheduleDraws 1)) 18 3 + (by simp [scheduleAppend,scheduleReads,scheduleDraws]) + have last := repeat_resource ((ls.map (fun l => l.kLog-6)).foldl max 0) + (scheduleAppend (scheduleReads 2) (scheduleDraws 1)) 18 3 + (by simp [scheduleAppend,scheduleReads,scheduleDraws]) + have tables := flat_resource ls (fun _ => scheduleAppend (scheduleReads 64) (scheduleReads 1)) + 328 65 (by intro _ _; simp [scheduleAppend,scheduleReads]) + simp only [flockProgramShape] + rw [← flock_assembled_value ls] + simp only [scheduleAppend,scheduleDraws,scheduleReads,List.length_append,List.length_replicate] + at first last tables ⊢ + constructor <;> omega + +private theorem cpu_schedule_metadata (l : CpuLayout) (size : Nat) + (volume : cpuLayoutVolume l ≤ size) : + (∀ t ∈ l.tables, t.committedColumns ≤ size ∧ t.summedColumns.length ≤ size) ∧ + (l.tables.map (fun t => t.summedColumns.length+1)).sum ≤ size ∧ + l.bus.producers.length ≤ size := by + have sumcap : (l.tables.map cpuTableVolume).sum ≤ size := by + unfold cpuLayoutVolume at volume; omega + have entries : ∀ t ∈ l.tables, t.committedColumns ≤ size ∧ t.summedColumns.length ≤ size := by + intro t ht + have member := sum_member l.tables cpuTableVolume t ht + have localBudget := member.trans sumcap + unfold cpuTableVolume at localBudget + omega + have summed : (l.tables.map (fun t => t.summedColumns.length+1)).sum ≤ + (l.tables.map cpuTableVolume).sum := by + apply List.sum_le_sum + intro t _ + unfold cpuTableVolume + omega + have producers := sum_count l.bus.producers (fun p => 1+p.kappa+p.bits+p.window) + (by intro p _; omega) + have bus := (cpuLayoutVolume_components l).1.trans volume + unfold PCSBCSCallerParserCost.busLayoutSize at bus + exact ⟨entries,summed.trans sumcap,by omega⟩ + +private theorem rec_assembled_value (l : RecLayout) : + (scheduleAppend (scheduleReads 2) (scheduleAppend (busShape l.bus) + (scheduleAppend (scheduleDraws 1) + (scheduleAppend (constraintsShape (l.tables.map Prod.snd)) (flockProgramShape [l.hash]))))).value = + WHIRCallerClaims.callerShape (.recursion l) := by + simp only [scheduleAppend,scheduleReads,scheduleDraws,busShape_value, + constraintsShape_value,flockProgramShape_value,WHIRCallerClaims.callerShape,List.append_assoc] + rfl + +private theorem cpu_assembled_value (l : CpuLayout) : + (scheduleAppend (scheduleReads (l.tables.length+2)) + (scheduleAppend (scheduleReads 2) (scheduleAppend (busShape l.bus) + (scheduleAppend (scheduleFlatMap l.tables (fun t => + if t.settled then + let a := scheduleReads (t.committedColumns-t.summedColumns.length) + ⟨a.value,a.work+t.summedColumns.length+3⟩ + else ⟨[],2⟩)) (scheduleAppend (scheduleDraws 1) + (scheduleAppend (constraintsShape (cpuAirs l)) (flockProgramShape l.flock))))))).value = + WHIRCallerClaims.callerShape (.cpu l) := by + simp only [scheduleAppend,scheduleReads,scheduleDraws,busShape_value, + constraintsShape_value,flockProgramShape_value,scheduleFlatMap, + WHIRCallerClaims.callerShape,cpuAirs,List.append_assoc,apply_ite] + rfl + +/-- No validity or supplied work certificate: the actual constructors are +bounded for every literal CPU and recursive configuration. -/ +theorem callerShape_resource (layout : CallerLayout) (size : Nat) + (volume : layoutVolume layout ≤ size) : + (callerShape layout).work ≤ 10000*(size+1)^4 ∧ + (callerShape layout).value.length ≤ 10000*(size+1)^4 := by + cases layout with + | recursion l => + change recLayoutVolume l ≤ size at volume + have caps := recLayoutVolume_components l + have bus := busShape_resource l.bus size (caps.1.trans volume) + have airs := constraintsShape_resource (l.tables.map Prod.snd) size (caps.2.1.trans volume) + have flock := flockProgramShape_resource [l.hash] size (caps.2.2.2.1.trans volume) + have count := caps.2.2.1.trans volume + simp only [callerShape] + rw [← rec_assembled_value l] + simp only [scheduleAppend,scheduleReads,scheduleDraws,List.length_append,List.length_replicate] + constructor <;> nlinarith [Nat.zero_le (size^2),Nat.zero_le (size^3)] + | cpu l => + change cpuLayoutVolume l ≤ size at volume + have caps := cpuLayoutVolume_components l + have bus := busShape_resource l.bus size (caps.1.trans volume) + have airs := constraintsShape_resource (cpuAirs l) size (caps.2.1.trans volume) + have flock := flockProgramShape_resource l.flock size (caps.2.2.2.1.trans volume) + have count := caps.2.2.1.trans volume + have metadata := cpu_schedule_metadata l size volume + have settled := flat_resource l.tables (fun t => + if t.settled then + let a := scheduleReads (t.committedColumns-t.summedColumns.length) + ⟨a.value,a.work+t.summedColumns.length+3⟩ + else ⟨[],2⟩) (4*size+5) size (by + intro t ht + have localCap := metadata.1 t ht + split <;> simp only [scheduleReads,List.length_replicate,List.length_nil] <;> omega) + have sw := Nat.mul_le_mul_right (4*size+5+2*size+1) count + have sn := Nat.mul_le_mul_right size count + simp only [callerShape] + change _ ∧ (WHIRCallerClaims.callerShape (.cpu l)).length ≤ _ + rw [← cpu_assembled_value l] + change (scheduleAppend (scheduleReads (l.tables.length+2)) + (scheduleAppend (scheduleReads 2) (scheduleAppend (busShape l.bus) + (scheduleAppend (scheduleFlatMap l.tables (fun t => + if t.settled then + let a := scheduleReads (t.committedColumns-t.summedColumns.length) + ⟨a.value,a.work+t.summedColumns.length+3⟩ + else ⟨[],2⟩)) (scheduleAppend (scheduleDraws 1) + (scheduleAppend (constraintsShape (cpuAirs l)) (flockProgramShape l.flock))))))).work+ + 9*l.tables.length+(l.tables.map (fun t => t.summedColumns.length+1)).sum+ + 7*l.bus.producers.length+5 ≤ _ ∧ _ + simp only [scheduleAppend,scheduleReads,scheduleDraws,List.length_append,List.length_replicate] + at settled ⊢ + constructor <;> nlinarith [Nat.zero_le (size^2),Nat.zero_le (size^3)] + +/-- Mandatory opening serialization and pending/root/context accessor prices +remain explicit; none are hidden behind a free cost hypothesis. -/ +theorem freshCallerShape_resource (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (size : Nat) (volume : layoutVolume layout ≤ size) : + (freshCallerShape layout saved cost).work ≤ + 30000*(size+1)^4+openingWork saved+openingGetterWork saved cost+ + 4*(openingScalars saved).length+7 ∧ + (freshCallerShape layout saved cost).value.length ≤ + 10000*(size+1)^4+(openingScalars saved).length := by + have base := callerShape_resource layout size volume + simp only [freshCallerShape,AnchoredSourceFreshCaller.callerShape, + callerShape_value,AnchoredSourceCaller.reads,List.length_append,List.length_drop, + List.length_replicate] + simp only [callerShape_value] at base + constructor <;> omega + +theorem freshCallerShape_resource_volume (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (size : Nat) (volume : layoutVolume layout ≤ size) + (recordVolume : saved.context.pendingBytes+saved.point.length+1 ≤ size) : + (freshCallerShape layout saved cost).work ≤ + 30000*(size+1)^4+46*size+647+openingGetterWork saved cost ∧ + (freshCallerShape layout saved cost).value.length ≤ 10000*(size+1)^4+size+10 := by + have schedule := freshCallerShape_resource layout saved cost size volume + have opening := openingWork_polynomial saved + have frame := openingScalars_length saved + have packs : (saved.context.pendingBytes+23)/24 ≤ saved.context.pendingBytes+1 := by omega + constructor <;> omega + +#print axioms gkrShape_resource +#print axioms frameworkKeys_resource +#print axioms busShape_resource +#print axioms constraintsShape_resource +#print axioms flockProgramShape_resource +#print axioms callerShape_resource +#print axioms freshCallerShape_resource +#print axioms freshCallerShape_resource_volume + +end Whir.PCSBCSCallerPayloadCost diff --git a/verification/whir/Whir/PCSBCSCallerSchedulePolynomialBoundSmoke.lean b/verification/whir/Whir/PCSBCSCallerSchedulePolynomialBoundSmoke.lean new file mode 100644 index 000000000..40ab15548 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerSchedulePolynomialBoundSmoke.lean @@ -0,0 +1,144 @@ +import Whir.PCSBCSCallerSchedulePolynomialBound + +/-! Executable checks of actual CPU/recursive schedule construction and reached +parser rejection. Zero messages are projection fixtures, not valid proofs. -/ +namespace Whir.PCSBCSCallerSchedulePolynomialBoundSmoke +open Concrete FiatShamirGame AnchoredHeaderCodec +open WHIRCallerClaims hiding recPayload settledClaims +open PCSBCSCallerPayloadCost + +local instance : Add E := ⟨E.add⟩ +local instance : Mul E := ⟨E.mul⟩ +local instance : Zero E := ⟨E.zero⟩ +local instance : One E := ⟨E.one⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +private def require (label : String) (ok : Bool) : IO Unit := + unless ok do throw (IO.userError label) + +private def zeroToken : WHIRCallerShape.EventShape → CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) + +private def baseRec : RecLayout := + ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ +private def baseCpu : CpuLayout := + ⟨⟨[],[],[],0⟩,List.replicate 11 ⟨0,0,0,false,[],[]⟩, + #[.committed 0 6],[⟨0,6,7⟩],[⟨0,[0,1]⟩],0,(fun i => UInt64.ofNat i.val),1⟩ +private def zeroCosts : OutputCosts := ⟨(fun _ => 0),(fun _ => 0),(fun _ => 0),(fun _ => 0)⟩ +private def prices : OutputCosts := ⟨(fun i => i.val+3),(fun _ => 7),(fun _ => 3),(fun _ => 5)⟩ +private def saved (layout : CallerLayout) : Record := + ⟨AnchoredSourceCaller.shape layout,ByteCodec.encodeNat 32 17, + ⟨ByteCodec.encodeNat 32 19,(fun _ => none),0,true,0,0⟩, + List.replicate (AnchoredSourceCaller.shape layout).logN 0,23⟩ + +private def checkLayout (layout : CallerLayout) : IO Unit := do + let shape := PCSBCSCallerPayloadCost.callerShape layout + let n := layoutVolume layout + require "actual caller schedule equals source" (shape.value == WHIRCallerClaims.callerShape layout) + require "actual caller constructor work bound" (shape.work <= 10000*(n+1)^4) + require "actual caller schedule length bound" (shape.value.length <= 10000*(n+1)^4) + let r := saved layout + let fresh := PCSBCSCallerPayloadCost.freshCallerShape layout r prices + require "actual fresh schedule equals source" + (fresh.value == AnchoredSourceFreshCaller.callerShape layout r) + require "fresh mandatory accessor prices retained" + (fresh.work == (PCSBCSCallerPayloadCost.freshCallerShape layout r zeroCosts).work+ + openingGetterWork r prices) + let size := n+r.context.pendingBytes+r.point.length+1 + require "actual fresh work polynomial" (fresh.work <= + 30000*(size+1)^4+46*size+647+openingGetterWork r prices) + require "actual fresh length polynomial" (fresh.value.length <= 10000*(size+1)^4+size+10) + +def smoke : IO Unit := do + for mu in [0,1,2,3,4,7,12] do + let g := PCSBCSCallerPayloadCost.gkrShape mu + require "zero odd even nested GKR source equality" (g.value == WHIRCallerClaims.gkrShape mu) + require "actual GKR construction polynomial" (g.work <= 300*(mu+1)^2) + require "actual nested GKR length polynomial" (g.value.length <= 300*(mu+1)^2) + IO.println "actual zero/odd/even/nested GKR schedule checks passed" + let unique : BusLayout := ⟨[⟨3,false,[.column 1,.column 2,.publicValue]⟩],[],[],7⟩ + let duplicate : BusLayout := + ⟨[⟨3,false,[.column 1,.column 2,.publicValue,.column 1]⟩], + [⟨3,false,[.column 2,.tableExpression]⟩,⟨9,true,[.column 8]⟩], + [⟨2,3,5⟩],7⟩ + require "framework dedup preserves first mention order" + ((PCSBCSCallerPayloadCost.frameworkKeys duplicate).value == [(1,3),(2,3)]) + require "actual duplicate traversal is priced" + ((PCSBCSCallerPayloadCost.frameworkKeys duplicate).work > + (PCSBCSCallerPayloadCost.frameworkKeys unique).work) + for bus in [unique,duplicate,⟨[],[],[],0⟩] do + let n := PCSBCSCallerParserCost.busLayoutSize bus + let keys := PCSBCSCallerPayloadCost.frameworkKeys bus + require "actual dedup source equality" (keys.value == WHIRCallerClaims.frameworkKeys bus) + require "actual dedup work polynomial" (keys.work <= 30*(n+1)^4) + require "actual dedup length polynomial" (keys.value.length <= n^2) + let shape := PCSBCSCallerPayloadCost.busShape bus + require "actual bus source equality" (shape.value == WHIRCallerClaims.busShape bus) + require "actual bus work polynomial" (shape.work <= 1500*(n+1)^4) + require "actual bus length polynomial" (shape.value.length <= 1500*(n+1)^4) + let airs : List AirLayout := [⟨4,7,1,[⟨1,3⟩,⟨5,2⟩]⟩,⟨2,0,9,[⟨12,0⟩]⟩] + let cn := PCSBCSCallerParserCost.airLayoutsSize airs + let constraints := PCSBCSCallerPayloadCost.constraintsShape airs + require "fields and saturating malformed AIR source equality" + (constraints.value == WHIRCallerClaims.constraintsShape airs) + require "actual field schedule work polynomial" (constraints.work <= 200*(cn+1)^2) + require "actual field schedule length polynomial" (constraints.value.length <= 200*(cn+1)^2) + for flocks in [[],[⟨0,0,0⟩],[⟨0,6,7⟩,⟨3,9,8⟩],[⟨0,5,2⟩,⟨3,9,8⟩]] do + let n := PCSBCSCallerParserCost.flockConfigurationSize flocks + let shape := PCSBCSCallerPayloadCost.flockProgramShape flocks + require "empty invalid and mixed flock schedule equality" + (shape.value == WHIRCallerClaims.flockProgramShape flocks) + require "actual flock construction work polynomial" (shape.work <= 2000*(n+1)) + require "actual flock construction length polynomial" (shape.value.length <= 2000*(n+1)) + IO.println "actual dedup, AIR fields, and mixed/invalid flock schedule checks passed" + let complexRec := {baseRec with bus := duplicate, tables := [(3,⟨4,7,1,[⟨1,3⟩,⟨5,2⟩]⟩)]} + let complexCpu := {baseCpu with + bus := duplicate + tables := [⟨1,4,7,true,[1,3],[⟨1,2⟩]⟩,⟨3,2,1,false,[9,9],[⟨9,0⟩]⟩] + flock := [⟨0,6,7⟩,⟨3,9,8⟩]} + for layout in [CallerLayout.recursion baseRec,.cpu baseCpu,.recursion complexRec,.cpu complexCpu, + .recursion {complexRec with hash := ⟨0,0,0⟩},.cpu {complexCpu with flock := []}] do + checkLayout layout + IO.println "actual CPU/recursive and fresh schedule bounds passed" + let recTokens := ((WHIRCallerClaims.callerShape (.recursion baseRec)).drop + (rootScalarCount (.recursion baseRec))).map zeroToken + let cpuTokens := ((WHIRCallerClaims.callerShape (.cpu baseCpu)).drop + (rootScalarCount (.cpu baseCpu))).map zeroToken + require "recursive actual payload accepts positive fixture" (recPayload baseRec recTokens).result.isSome + require "recursive source accepts same fixture" (WHIRCallerClaims.recPayload baseRec recTokens).isSome + require "CPU actual register traversal accepts positive fixture" (cpuPayload baseCpu prices cpuTokens).result.isSome + require "CPU source accepts same register fixture" (WHIRCallerClaims.cpuPayload baseCpu cpuTokens).isSome + let recSaved := saved (.recursion baseRec) + let fresh := recTokens ++ (openingScalars recSaved).map CallerToken.sent + require "exact fresh recursive interpreter accepts actual schedule" + (freshInterpret (.recursion baseRec) recSaved prices fresh).value.isSome + require "exact fresh interpreter rejects trailing scalar" + (freshInterpret (.recursion baseRec) recSaved prices (fresh++[.sent 0])).value.isNone + require "actual recursive truncation rejects with reached work" + ((recPayload baseRec [.sent 0]).result.isNone && (recPayload baseRec [.sent 0]).work > 0) + require "actual malformed duplicate settled columns reject" + ((settledClaims [⟨0,0,2,true,[0,0],[]⟩] [] []).result.isNone) + require "actual invalid flock boundary rejects" + ((PCSBCSCallerParserCost.flockClaims [⟨0,5,2⟩] []).result.isNone) + IO.println "actual source payload acceptance and malformed boundary rejection checks passed" + let pendingContext := {recSaved.context with + pendingBytes := 49 + pending := fun i => if i.val < 7 then some (UInt64.ofNat (i.val+1)) else none} + let pending := {recSaved with context := pendingContext} + let paid := PCSBCSCallerPayloadCost.freshCallerShape (.recursion complexRec) pending prices + let free := PCSBCSCallerPayloadCost.freshCallerShape (.recursion complexRec) pending zeroCosts + require "pending root and context accessors are mandatory exact prices" + (paid.work == free.work+openingGetterWork pending prices && openingGetterWork pending prices > 0) + let pendingSize := layoutVolume (.recursion complexRec)+pending.context.pendingBytes+ + pending.point.length+1 + require "actual saved pending point and frame volume work bound" + (paid.work <= 30000*(pendingSize+1)^4+46*pendingSize+647+openingGetterWork pending prices) + require "actual saved pending point and frame volume length bound" + (paid.value.length <= 10000*(pendingSize+1)^4+pendingSize+10) + IO.println "PCSBCSCallerSchedulePolynomialBoundSmoke: all actual schedule and boundary checks passed" + +end Whir.PCSBCSCallerSchedulePolynomialBoundSmoke + +def main : IO Unit := Whir.PCSBCSCallerSchedulePolynomialBoundSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSCallerSourcePolynomialBound.lean b/verification/whir/Whir/PCSBCSCallerSourcePolynomialBound.lean new file mode 100644 index 000000000..22d35ed2f --- /dev/null +++ b/verification/whir/Whir/PCSBCSCallerSourcePolynomialBound.lean @@ -0,0 +1,565 @@ +import Whir.PCSBCSCallerPayloadPolynomialBound +import Whir.PCSBCSCallerSchedulePolynomialBound +import Whir.PCSBCSCallerCPUPolynomialBound + +/-! Anchored source resource bounds in actual public metadata, placement word +volume, record coordinates and token lengths. Accessor prices stay explicit. +No theorem assumes the work of the parser it bounds. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +set_option maxHeartbeats 1600000 +namespace Whir.PCSBCSCallerPayloadCost +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec + +/-- Public placement word volume is the source's sum of `2^dimension`, not a +reservation supplied by a caller. Including it accounts for the declared Nat +logarithm source-operation model in `shapeWork`. -/ +def layoutPublicSize (layout : CallerLayout) : Nat := + 1+layoutVolume layout+callerWords layout+callerMu layout + +def recordPublicSize (saved : Record) : Nat := + 1+saved.context.pendingBytes+saved.point.length + +def freshPublicSize (layout : CallerLayout) (saved : Record) (tokens : List CallerToken) : Nat := + layoutVolume layout+recordPublicSize saved+tokens.length + +private theorem summand_le {A : Type} (xs : List A) (f : A → Nat) + (x : A) (member : x ∈ xs) : f x ≤ (xs.map f).sum := by + induction xs with + | nil => simp at member + | cons y ys ih => + simp only [List.mem_cons] at member + simp only [List.map_cons,List.sum_cons] + rcases member with rfl | member + · omega + · exact (ih member).trans (Nat.le_add_left _ _) + +theorem placement_volume_le (layout : CallerLayout) : + placementsVolume (callerPlacements layout) ≤ layoutVolume layout := by + cases layout with + | recursion l => exact (recLayoutVolume_components l).2.2.2.2 + | cpu l => exact (cpuLayoutVolume_components l).2.2.2.2.1 + +theorem shapeWork_polynomial (layout : CallerLayout) (size : Nat) + (volume : layoutPublicSize layout ≤ size) : + shapeWork layout ≤ 9*size^2+20*size+35 := by + have placement := placement_volume_le layout + have components : layoutVolume layout ≤ size ∧ callerWords layout ≤ size ∧ callerMu layout ≤ size := by + unfold layoutPublicSize at volume + omega + have count : (callerPlacements layout).size ≤ size := by + unfold placementsVolume at placement + omega + have dims : ∀ p ∈ (callerPlacements layout).toList, ∀ o d, + p = .committed o d → d ≤ size := by + intro p member o d equal + subst p + have memberVolume := summand_le (callerPlacements layout).toList placementVolume (.committed o d) member + simp only [placementVolume] at memberVolume + unfold placementsVolume at placement + omega + have words := wordsWork_le layout size dims + have product := Nat.mul_le_mul_left (3*size+5) count + have positive : 1 ≤ size := by + unfold layoutPublicSize at volume + omega + unfold shapeWork + nlinarith [Nat.sub_le (max (callerWords layout) 1) 1, + Nat.sub_le (callerMu layout) 6,Nat.max_le.mpr ⟨components.2.1,positive⟩] + +private theorem source_bind_bound {A B : Type} (p : PCSBCSCallerParserCost.Parser A) + (f : A → PCSBCSCallerParserCost.Parser B) (ts : List CallerToken) + (m n total : Nat) (sum : m+n ≤ total) (hp : (p ts).work ≤ m) + (hf : ∀ a rest, (p ts).result = some (a,rest) → (f a rest).work ≤ n) : + ((p >>= f) ts).work ≤ total := + (PCSBCSCallerParserCost.bind_work_le p f ts m n hp hf).trans sum + +local macro "source_bind " m:term "," n:term : tactic => + `(tactic| (apply source_bind_bound _ _ _ $m $n; · first | omega | nlinarith)) + +private theorem source_tick_bound {A : Type} (n : Nat) (parser : PCSBCSCallerParserCost.Parser A) + (ts : List CallerToken) (cap total : Nat) (sum : n+cap ≤ total) + (bound : (parser ts).work ≤ cap) : + ((PCSBCSCallerParserCost.tick n >>= fun _ => parser) ts).work ≤ total := by + rw [PCSBCSCallerParserCost.tick_bind_work] + exact (Nat.add_le_add_left bound n).trans sum + +local macro "source_tick " n:term : tactic => + `(tactic| (apply source_tick_bound _ _ _ $n; · first | omega | nlinarith)) + +theorem readAnnouncements_work_le (heights : List Nat) (tokens : List CallerToken) : + (readAnnouncements heights tokens).work ≤ 13*heights.length+1 := by + induction heights generalizing tokens with + | nil => simp [readAnnouncements,PCSBCSCallerParserCost.tick] + | cons height heights ih => + simp only [List.length_cons] + unfold readAnnouncements + source_tick (13*heights.length+13) + source_bind 4, (13*heights.length+9) + · exact PCSBCSCallerParserCost.readScalar_work_le tokens + · intro scalar rest read + source_tick (13*heights.length+4) + source_bind 3, (13*heights.length+1) + · exact PCSBCSCallerParserCost.check_work_le _ _ + · intro unused tail checked + exact ih tail + +theorem prelude_work_polynomial (layout : CallerLayout) (tokens : List CallerToken) + (size : Nat) (volume : layoutVolume layout ≤ size) : + (prelude layout tokens).work ≤ 17*size+169 := by + cases layout with + | recursion l => + simp [prelude,PCSBCSCallerParserCost.tick] + | cpu l => + have count := (cpuLayoutVolume_components l).2.2.1.trans volume + have detailed : (prelude (.cpu l) tokens).work ≤ 17*l.tables.length+169 := by + unfold prelude + source_tick (16*l.tables.length+166) + source_bind 3, (16*l.tables.length+163) + · exact PCSBCSCallerParserCost.check_work_le _ _ + · intro unused rest checked + unfold charged + simp only [bind_assoc,pure_bind] + source_tick (13*l.tables.length+161) + source_bind (13*(l.tables.length+1)+1), 147 + · simpa only [List.length_append,List.length_map,List.length_cons,List.length_nil, + Nat.add_zero] using readAnnouncements_work_le + (l.tables.map CpuTableLayout.tau++[l.logInvRate]) rest + · intro unused tail checked + source_bind 4, 143 + · exact PCSBCSCallerParserCost.readScalar_work_le tail + · intro clock suffix checked + have clockCost : 3+(if clock.c1==0 then 3+ + (if clock.c2==0 then 125+(if clock.c0.toNat/2^40==1 then 4 else 0) + else 0) else 0) ≤ 135 := by + repeat' first | split | omega + source_tick 3 + exact PCSBCSCallerParserCost.check_work_le _ _ + nlinarith + +theorem receive_work_local (layout : CallerLayout) (original : Context) (tokens : List CallerToken) : + (receive layout original tokens).work ≤ 4*shapeWork layout+9*callerMu layout+156 := by + have valid : shapeValidWork (AnchoredSourceCaller.shape layout) ≤ 42 := by + simpa only [AnchoredSourceCaller.shape] using shapeValidWork_le (AnchoredSourceCaller.shape layout) + unfold receive + source_tick (3*shapeWork layout+9*callerMu layout+114) + source_bind 3, (3*shapeWork layout+9*callerMu layout+111) + · exact PCSBCSCallerParserCost.check_work_le _ _ + · intro unused rest checked + source_bind 47, (3*shapeWork layout+9*callerMu layout+64) + · exact PCSBCSCallerParserCost.readScalars_work_le 5 rest + · intro header tail received + have headerCost := headerWork_le (AnchoredSourceCaller.shape layout) header + source_tick (2*shapeWork layout+9*callerMu layout+10) + cases parsed : parseHeader (AnchoredSourceCaller.shape layout) header with + | none => + simp [PCSBCSCallerParserCost.liftOption] + | some root => + source_tick (shapeWork layout+9*callerMu layout+9) + source_bind (9*callerMu layout+2), (shapeWork layout+7) + · exact PCSBCSCallerParserCost.drawScalars_work_le _ _ + · intro point remaining sampled + source_bind 4, (shapeWork layout+3) + · exact PCSBCSCallerParserCost.readScalar_work_le remaining + · intro value suffix read + source_tick 0 + exact (PCSBCSCallerParserCost.pure_work _ _).le + +theorem receive_work_polynomial (layout : CallerLayout) (original : Context) + (tokens : List CallerToken) (size : Nat) (volume : layoutPublicSize layout ≤ size) : + (receive layout original tokens).work ≤ 36*size^2+89*size+300 := by + have work := receive_work_local layout original tokens + have shape := shapeWork_polynomial layout size volume + have dimension : callerMu layout ≤ size := by + unfold layoutPublicSize at volume + omega + nlinarith + +theorem receive_success_fields (layout : CallerLayout) (original : Context) + (tokens rest : List CallerToken) (record : Record) + (accepted : (receive layout original tokens).result = some (record,rest)) : + record.context = original ∧ record.point.length = callerMu layout := by + unfold receive at accepted + by_cases valid : decide (AnchoredSourceCaller.shape layout).Valid = true + · simp only [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + PCSBCSCallerParserCost.check,valid,ite_true] at accepted + cases headerRead : (PCSBCSCallerParserCost.readScalars 5 tokens).result with + | none => simp [headerRead] at accepted + | some pair => + rcases pair with ⟨header,tail⟩ + rw [headerRead] at accepted + dsimp only at accepted + cases parsed : parseHeader (AnchoredSourceCaller.shape layout) header with + | none => simp [parsed,PCSBCSCallerParserCost.liftOption] at accepted + | some root => + rw [parsed] at accepted + dsimp only [PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick] at accepted + cases draw : (PCSBCSCallerParserCost.drawScalars (AnchoredSourceCaller.shape layout).logN tail).result with + | none => simp [draw] at accepted + | some pair => + rcases pair with ⟨point,remaining⟩ + have pointLength := PCSBCSCallerParserCost.drawScalars_success_length _ _ _ _ draw + rw [draw] at accepted + dsimp only [PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick] at accepted + cases read : (PCSBCSCallerParserCost.readScalar remaining).result with + | none => simp [read] at accepted + | some pair => + rcases pair with ⟨value,suffix⟩ + simp only [read,Pure.pure,PCSBCSCallerParserCost.pure, + Option.some.injEq,Prod.mk.injEq] at accepted + rcases accepted with ⟨rfl,rfl⟩ + exact ⟨rfl,pointLength⟩ + · simp [Bind.bind,PCSBCSCallerParserCost.bind,PCSBCSCallerParserCost.tick, + PCSBCSCallerParserCost.check,valid] at accepted + +theorem freshSourceClaims_work_local (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) : + (freshSourceClaims layout saved cost tokens).work ≤ + (payload layout cost tokens).work+108*recordPublicSize saved+1450+ + 2*openingGetterWork saved cost := by + unfold freshSourceClaims + source_bind (payload layout cost tokens).work, + (108*recordPublicSize saved+1450+2*openingGetterWork saved cost) + · exact Nat.le_refl _ + · intro pair tail parsed + rcases pair with ⟨families,points⟩ + source_bind (108*recordPublicSize saved+1447+2*openingGetterWork saved cost), 3 + · have bound := binding_polynomial saved cost tail + unfold recordPublicSize + omega + · intro unused rest checked + source_tick 0 + exact (PCSBCSCallerParserCost.pure_work _ _).le + +theorem freshInterpret_work_local (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) : + (freshInterpret layout saved cost tokens).work ≤ + (payload layout cost tokens).work+(callerShape layout).work+ + 8*(callerShape layout).value.length+875*tokens.length+ + 159*recordPublicSize saved+2153+3*openingGetterWork saved cost := by + have composite := freshInterpret_compositional_bound layout saved cost tokens + have fresh := freshSourceClaims_work_local layout saved cost tokens + have opening := openingWork_polynomial saved + have length := openingScalars_length saved + have packs : (saved.context.pendingBytes+23)/24 ≤ saved.context.pendingBytes+1 := by omega + unfold recordPublicSize + unfold recordPublicSize at fresh + omega + +#print axioms freshSourceClaims_work_local +#print axioms freshInterpret_work_local + +theorem freshCallerShape_work_polynomial (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (size : Nat) (volume : layoutVolume layout ≤ size) + (recordVolume : recordPublicSize saved ≤ size) : + (freshCallerShape layout saved cost).work ≤ + 30000*(size+1)^4+46*size+647+openingGetterWork saved cost := by + have record : saved.context.pendingBytes+saved.point.length+1 ≤ size := by + unfold recordPublicSize at recordVolume + omega + exact (freshCallerShape_resource_volume layout saved cost size volume record).1 + +/-- The fee of actual reached CPU getter applications, without evaluating an +output getter while constructing the trace. -/ +def payloadGetterPrice (layout : CallerLayout) (cost : OutputCosts) (tokens : List CallerToken) : Nat := + (⟨freshOutputGetterTrace layout tokens,[],[],[]⟩ : GetterTrace).price cost + +theorem payload_getter_work (layout : CallerLayout) (cost : OutputCosts) (tokens : List CallerToken) : + (payload layout cost tokens).work = (payload layout OutputCosts.zero tokens).work+ + payloadGetterPrice layout cost tokens := by + cases layout with + | recursion l => + simp [payload,payloadGetterPrice,freshOutputGetterTrace,GetterTrace.price] + | cpu l => + have work := cpuPayload_output_work l cost tokens + have zero : cpuPayload l {cost with call := fun _ => 0} = cpuPayload l OutputCosts.zero := rfl + rw [zero] at work + have tracePrice : payloadGetterPrice (.cpu l) cost tokens = + if (cpuPayloadBeforeExit l tokens).result.isSome then cost.total else 0 := by + simp [payloadGetterPrice,GetterTrace.price,freshOutputGetterTrace,outputGetterTrace, + OutputCosts.total,List.finRange] + split <;> simp_all + simpa only [payload,tracePrice] using work + +private theorem payload_result_prices (layout : CallerLayout) (cost : OutputCosts) + (tokens : List CallerToken) : + (payload layout cost tokens).result = (payload layout OutputCosts.zero tokens).result := by + have a := congrFun (payload_erasure layout cost) tokens + have b := congrFun (payload_erasure layout OutputCosts.zero) tokens + exact a.trans b.symm + +private theorem binding_result_prices (saved : Record) (cost : OutputCosts) (tokens : List CallerToken) : + (binding saved cost tokens).result = (binding saved OutputCosts.zero tokens).result := by + have a := congrFun (binding_erasure saved cost) tokens + have b := congrFun (binding_erasure saved OutputCosts.zero) tokens + exact a.trans b.symm + +theorem freshSourceClaims_getter_work (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) : + (freshSourceClaims layout saved cost tokens).work = + (freshSourceClaims layout saved OutputCosts.zero tokens).work+ + (freshSourceClaimsGetterTrace layout saved tokens).price cost := by + have payloadWork := payload_getter_work layout cost tokens + have same := payload_result_prices layout cost tokens + have cursor := payloadPendingCursor_erasure layout cost tokens + cases parsed : (payload layout cost tokens).result with + | none => + have base : (payload layout OutputCosts.zero tokens).result = none := same.symm.trans parsed + have noCursor : payloadPendingCursor layout tokens = none := by simp [cursor,parsed] + simp only [freshSourceClaims,Bind.bind,PCSBCSCallerParserCost.bind,parsed,base, + freshSourceClaimsGetterTrace,noCursor] + exact payloadWork + | some pair => + rcases pair with ⟨⟨families,points⟩,tail⟩ + have base : (payload layout OutputCosts.zero tokens).result = some ((families,points),tail) := + same.symm.trans parsed + have someCursor : payloadPendingCursor layout tokens = some tail := by simp [cursor,parsed] + have bindingWork := binding_getter_work saved cost tail + have bindingSame := binding_result_prices saved cost tail + cases checked : (binding saved cost tail).result with + | none => + have baseChecked : (binding saved OutputCosts.zero tail).result = none := + bindingSame.symm.trans checked + simp only [freshSourceClaims,Bind.bind,PCSBCSCallerParserCost.bind,parsed,base, + checked,baseChecked,freshSourceClaimsGetterTrace,someCursor,GetterTrace.price_append] + unfold payloadGetterPrice at payloadWork + omega + | some pair => + rcases pair with ⟨unused,rest⟩ + have baseChecked : (binding saved OutputCosts.zero tail).result = some (unused,rest) := + bindingSame.symm.trans checked + simp only [freshSourceClaims,Bind.bind,PCSBCSCallerParserCost.bind,parsed,base, + checked,baseChecked,PCSBCSCallerParserCost.tick, + freshSourceClaimsGetterTrace,someCursor,GetterTrace.price_append] + unfold payloadGetterPrice at payloadWork + omega + +theorem freshCallerShape_getter_work (layout : CallerLayout) (saved : Record) (cost : OutputCosts) : + (freshCallerShape layout saved cost).work = + (freshCallerShape layout saved OutputCosts.zero).work+openingGetterWork saved cost := by + have zero : openingGetterWork saved OutputCosts.zero = 0 := by + rw [←openingGetterTrace_price] + simp + simp only [freshCallerShape,zero] + omega + +theorem freshInterpret_getter_work (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) : + (freshInterpret layout saved cost tokens).work = + (freshInterpret layout saved OutputCosts.zero tokens).work+ + (freshInterpretGetterTrace layout saved tokens).price cost := by + have expectedWork := freshCallerShape_getter_work layout saved cost + have sourceWork := freshSourceClaims_getter_work layout saved cost tokens + have same : (freshSourceClaims layout saved cost tokens).result = + (freshSourceClaims layout saved OutputCosts.zero tokens).result := by + have a := congrFun (freshSourceClaims_erasure layout saved cost) tokens + have b := congrFun (freshSourceClaims_erasure layout saved OutputCosts.zero) tokens + exact a.trans b.symm + by_cases matched : WHIRCallerClaims.tokensShape tokens = + AnchoredSourceFreshCaller.callerShape layout saved + · cases parsed : (freshSourceClaims layout saved cost tokens).result with + | none => + have base : (freshSourceClaims layout saved OutputCosts.zero tokens).result = none := same.symm.trans parsed + simp [freshInterpret,matched,parsed,base,freshInterpretGetterTrace, + freshShapeForTrace_erasure,openingGetterTrace_price] + omega + | some pair => + rcases pair with ⟨claims,rest⟩ + have base : (freshSourceClaims layout saved OutputCosts.zero tokens).result = some (claims,rest) := + same.symm.trans parsed + cases remaining : rest.isEmpty <;> + simp [freshInterpret,matched,parsed,base,remaining,freshInterpretGetterTrace, + freshShapeForTrace_erasure,openingGetterTrace_price] <;> omega + · simp [freshInterpret,matched,freshInterpretGetterTrace, + freshShapeForTrace_erasure,openingGetterTrace_price] + omega + +#print axioms freshCallerShape_getter_work +#print axioms freshInterpret_getter_work + +private def sourcePrefix (layout : CallerLayout) (original : Context) : + PCSBCSCallerParserCost.Parser Record := do + prelude layout + receive layout original + +private theorem sourceClaims_normalized (layout : CallerLayout) (original : Context) (cost : OutputCosts) : + sourceClaims layout original cost = + (sourcePrefix layout original >>= fun record => freshSourceClaims layout record cost) := by + simp only [sourceClaims,sourcePrefix,freshSourceClaims,bind_assoc] + +/-- Prelude/header/point reception invokes no opaque accessor: returning the +immutable record is not evaluation of its byte or pending-word functions. -/ +def sourceClaimsGetterTrace (layout : CallerLayout) (original : Context) + (tokens : List CallerToken) : GetterTrace := + match (sourcePrefix layout original tokens).result with + | none => .empty + | some (record,rest) => freshSourceClaimsGetterTrace layout record rest + +theorem sourceClaims_getter_work (layout : CallerLayout) (original : Context) + (cost : OutputCosts) (tokens : List CallerToken) : + (sourceClaims layout original cost tokens).work = + (sourceClaims layout original OutputCosts.zero tokens).work+ + (sourceClaimsGetterTrace layout original tokens).price cost := by + rw [sourceClaims_normalized,sourceClaims_normalized] + cases parsed : (sourcePrefix layout original tokens).result with + | none => + simp [Bind.bind,PCSBCSCallerParserCost.bind,parsed, + sourceClaimsGetterTrace,GetterTrace.empty,GetterTrace.price] + | some pair => + rcases pair with ⟨record,rest⟩ + have work := freshSourceClaims_getter_work layout record cost rest + simp only [Bind.bind,PCSBCSCallerParserCost.bind,parsed,sourceClaimsGetterTrace] + omega + +#print axioms sourceClaims_getter_work + +/-- Sum of the two proven concrete branch polynomials, not a parser reserve. +Each constituent is derived from actual successful-state geometry and failed +prefix work of the literal counted interpreter. -/ +def payloadWorkPolynomial (size : Nat) : Nat := + cpuPayloadWorkPolynomial size+PCSBCSCallerParserCost.busClaimsWork size+ + 100*(size+1)^3*size+6*size^3+79*size^2+874*size+738 + +def freshSourceWorkPolynomial (size : Nat) : Nat := + payloadWorkPolynomial size+108*size+1450 + +def freshInterpretWorkPolynomial (size : Nat) : Nat := + payloadWorkPolynomial size+90000*(size+1)^4+1034*size+2153 + +def sourceWorkPolynomial (size : Nat) : Nat := + payloadWorkPolynomial size+36*size^2+214*size+1919 + +theorem payload_zero_work_polynomial (layout : CallerLayout) (tokens : List CallerToken) + (size : Nat) (volume : layoutVolume layout ≤ size) : + (payload layout OutputCosts.zero tokens).work ≤ payloadWorkPolynomial size := by + cases layout with + | recursion l => + have bound := recPayload_work_polynomial l tokens size volume + change (recPayload l tokens).work ≤ _ + unfold payloadWorkPolynomial + omega + | cpu l => + have bound := cpuPayload_work_polynomial l OutputCosts.zero tokens size volume + have total : OutputCosts.zero.total = 0 := by + simp [OutputCosts.total,OutputCosts.zero] + simp only [total,ite_self,Nat.add_zero] at bound + change (cpuPayload l OutputCosts.zero tokens).work ≤ _ + unfold payloadWorkPolynomial + omega + +theorem payload_work_polynomial (layout : CallerLayout) (cost : OutputCosts) + (tokens : List CallerToken) (size : Nat) (volume : layoutVolume layout ≤ size) : + (payload layout cost tokens).work ≤ payloadWorkPolynomial size+payloadGetterPrice layout cost tokens := by + rw [payload_getter_work] + exact Nat.add_le_add_right (payload_zero_work_polynomial layout tokens size volume) _ + +theorem freshSourceClaims_zero_work_polynomial (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) (size : Nat) (volume : layoutVolume layout ≤ size) + (recordVolume : recordPublicSize saved ≤ size) : + (freshSourceClaims layout saved OutputCosts.zero tokens).work ≤ freshSourceWorkPolynomial size := by + have work := freshSourceClaims_work_local layout saved OutputCosts.zero tokens + have payload := payload_zero_work_polynomial layout tokens size volume + have zero : openingGetterWork saved OutputCosts.zero = 0 := by + rw [←openingGetterTrace_price] + simp + rw [zero] at work + unfold freshSourceWorkPolynomial + omega + +theorem freshSourceClaims_work_polynomial (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) (size : Nat) + (volume : layoutVolume layout ≤ size) (recordVolume : recordPublicSize saved ≤ size) : + (freshSourceClaims layout saved cost tokens).work ≤ freshSourceWorkPolynomial size+ + (freshSourceClaimsGetterTrace layout saved tokens).price cost := by + rw [freshSourceClaims_getter_work] + exact Nat.add_le_add_right (freshSourceClaims_zero_work_polynomial layout saved tokens size volume recordVolume) _ + +theorem freshInterpret_zero_work_polynomial (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) (size : Nat) (volume : layoutVolume layout ≤ size) + (recordVolume : recordPublicSize saved ≤ size) (tokenVolume : tokens.length ≤ size) : + (freshInterpret layout saved OutputCosts.zero tokens).work ≤ freshInterpretWorkPolynomial size := by + have work := freshInterpret_work_local layout saved OutputCosts.zero tokens + have payload := payload_zero_work_polynomial layout tokens size volume + have schedules := callerShape_resource layout size volume + have zero : openingGetterWork saved OutputCosts.zero = 0 := by + rw [←openingGetterTrace_price] + simp + rw [zero] at work + unfold freshInterpretWorkPolynomial + omega + +/-- Fresh interpretation never runs `receive`/`shapeWork`. Its resource bound +therefore needs only literal layout metadata, immutable record/public token +lengths, and exact reached callback prices—not committed word volume. -/ +theorem freshInterpret_work_polynomial (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) (size : Nat) + (volume : layoutVolume layout ≤ size) (recordVolume : recordPublicSize saved ≤ size) + (tokenVolume : tokens.length ≤ size) : + (freshInterpret layout saved cost tokens).work ≤ freshInterpretWorkPolynomial size+ + (freshInterpretGetterTrace layout saved tokens).price cost := by + rw [freshInterpret_getter_work] + exact Nat.add_le_add_right + (freshInterpret_zero_work_polynomial layout saved tokens size volume recordVolume tokenVolume) _ + +/-- Original reception prices the source's literal committed-word volume in +`shapeWork`: this is not a polynomial claim in only compact dimension bits. -/ +theorem sourceClaims_zero_work_polynomial (layout : CallerLayout) (original : Context) + (tokens : List CallerToken) (size : Nat) (volume : layoutPublicSize layout ≤ size) + (recordVolume : original.pendingBytes+callerMu layout+1 ≤ size) : + (sourceClaims layout original OutputCosts.zero tokens).work ≤ sourceWorkPolynomial size := by + have metadata : layoutVolume layout ≤ size := by + unfold layoutPublicSize at volume + omega + unfold sourceClaims sourceWorkPolynomial + source_bind (17*size+169), (payloadWorkPolynomial size+36*size^2+197*size+1750) + · exact prelude_work_polynomial layout tokens size metadata + · intro unused rest checked + source_bind (36*size^2+89*size+300), (payloadWorkPolynomial size+108*size+1450) + · exact receive_work_polynomial layout original rest size volume + · intro record tail received + have fields := receive_success_fields layout original rest tail record received + have recordCap : recordPublicSize record ≤ size := by + unfold recordPublicSize + rw [fields.1,fields.2] + omega + exact freshSourceClaims_zero_work_polynomial layout record tail size metadata recordCap + +theorem sourceClaims_work_polynomial (layout : CallerLayout) (original : Context) + (cost : OutputCosts) (tokens : List CallerToken) (size : Nat) + (volume : layoutPublicSize layout ≤ size) + (recordVolume : original.pendingBytes+callerMu layout+1 ≤ size) : + (sourceClaims layout original cost tokens).work ≤ sourceWorkPolynomial size+ + (sourceClaimsGetterTrace layout original tokens).price cost := by + rw [sourceClaims_getter_work] + exact Nat.add_le_add_right + (sourceClaims_zero_work_polynomial layout original tokens size volume recordVolume) _ + +/-- Canonical closed bound on actual public input sizes: no caller-supplied +parser work bound, operation certificate, or reservation is a premise. -/ +theorem freshInterpret_work_actual_sizes (layout : CallerLayout) (saved : Record) + (cost : OutputCosts) (tokens : List CallerToken) : + (freshInterpret layout saved cost tokens).work ≤ + freshInterpretWorkPolynomial (freshPublicSize layout saved tokens)+ + (freshInterpretGetterTrace layout saved tokens).price cost := by + apply freshInterpret_work_polynomial + · unfold freshPublicSize; omega + · unfold freshPublicSize; omega + · unfold freshPublicSize; omega + +#print axioms freshInterpret_work_actual_sizes + +#print axioms payload_work_polynomial +#print axioms freshSourceClaims_work_polynomial +#print axioms freshInterpret_work_polynomial +#print axioms sourceClaims_work_polynomial + +#print axioms payload_getter_work +#print axioms freshSourceClaims_getter_work + +#print axioms receive_success_fields + +#print axioms shapeWork_polynomial +#print axioms prelude_work_polynomial +#print axioms receive_work_polynomial + +end Whir.PCSBCSCallerPayloadCost diff --git a/verification/whir/Whir/PCSBCSCapturedIdealNativeAcceptance.lean b/verification/whir/Whir/PCSBCSCapturedIdealNativeAcceptance.lean new file mode 100644 index 000000000..cb2776ebb --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedIdealNativeAcceptance.lean @@ -0,0 +1,197 @@ +import Whir.PCSBCSNativeIdealCallerOriginal +import Whir.PCSBCSNativePacketCodec +import Whir.PCSBCSMerkleSeedProjection +import Whir.PCSBCSCapturedSourceAcceptance +import Whir.PCSBCSObservedPrimitiveExtension + +/-! Historical pre-#607 native/captured join. The checked endpoint below transports +only the rows actually queried by an accepted native opening. It deliberately +retains the existing OpenPrimitiveBad alternative: first raw prequeries may +capture a root before its announcement, and later log growth is not a whole-table +identity. This is an intermediate, not ObserverRefines or an FS security theorem. + +Endpoint hypotheses are: stack mode; aggregate source budget; actual mixed driver +success; caller family cap; membership of the selected opening in that result; +actual visit of an entered source packet in the raw allocation compiler; and +membership of the selected shape address in that packet's literal parsed roles. +No accepted original, compatible snapshot, capture/oracle equality, accepted +interactive experiment, source soundness, or observer refinement is assumed. +The final two hypotheses retain the source chronology/address join explicitly. +The conclusion uses the native frozenQueryOracle of the actual capture prefix; +it does not yet prove selectPhase equality or ReplyTransport for the native +same-tape interactive replies. Those require the scheduled phase-reference and +query-codec crosswalk, and transport of each nonterminal next-root reply without +equating a later physical registry with the earlier captured full oracle. +No FrozenExtractionBad probability charge or enclosing-adversary refinement is +derived here; the OpenPrimitiveBad alternative is left intact for that join. +-/ +set_option autoImplicit false +namespace Whir.PCSBCSCapturedIdealNativeAcceptance +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open RawOracleCoupling PCSBCSChallengeOracle WHIRSourceChronology AnchoredPhysicalDriver +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache PCSBCSCapturedNativeReplyBridge +open PCSBCSCapturedSourceAcceptance PublicMerkleLog MerkleTransport +open MerkleTransport.Commitments + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) + (limit : WHIRPhysicalVerifier.sourceBudget ctx Q packet ≤ B) + +private noncomputable abbrev part := EnteredPacket.partition (p := packet.val.profile) (Q := B) + (iv := ctx.iv) (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length) + +/-- The literal grouped raw compiler, without a fabricated allocation trace. -/ +noncomputable def allocationProgram := + Atomic.program (part ctx Q packet B) + (PublicCompressionCouplingMixed.compile B ctx.iv [] + (WHIRSourceChronology.compile + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + (WHIRPhysicalVerifier.sourceBudget ctx Q packet) limit + ((WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap .fresh model ctx stack Q packet saved proofs))) + +noncomputable def table (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) := + (part ctx Q packet B).split (PublicCompressionCouplingMixed.oracle seed ro) + +private abbrev view (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) := + AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro + +/-- The allocation compiler's result is the actual mixed driver view, not a +supplied tuple-copy equation. Its trace remains the actual grouped query trace. -/ +theorem allocation_result (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) : + Sampling.eval (table ctx Q packet B seed ro) + (allocationProgram cap model ctx stack Q packet saved proofs B limit) = + view cap model ctx stack Q packet saved proofs B limit seed ro := by + unfold allocationProgram + rw [Atomic.eval_program] + simp only [table,Partition.join_split] + rfl + +/-- Actual complete primitive replay, including nonordinary simulator answers. +Its extension is not a uniform primitive and is not the independent source RO. -/ +theorem observed_snapshot (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) : + WHIRPhysicalSnapshots.Invariant + (PCSBCSObservedPrimitiveExtension.extension seed + (DuplexPublicSimulator.finalLog [] + (view cap model ctx stack Q packet saved proofs B limit seed ro).observations)) + (WHIRSourceObserver.replayTracked (CausalBindingState.empty cap) + (view cap model ctx stack Q packet saved proofs B limit seed ro).result.events) := by + simpa only [view,AnchoredMixedIdealSourceAcceptance.mixedView, + PublicCompressionCouplingMixed.compile_actual,DuplexPublicSimulator.simulator] using + PCSBCSObservedPrimitiveExtension.ideal_snapshot seed ro ctx.iv + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs) + (WHIRPhysicalVerifier.sourceBudget ctx Q packet) limit + (AnchoredPhysicalDriver.verifySource_counted cap .fresh model ctx stack Q packet saved proofs) + +/-- The source address for exactly this native opening's geometry. -/ +def openingReference (opening : WHIRPhysicalVerifier.QueryOpening packet.val.profile) + (lanes : Nat) : Reference := + ⟨opening.root,⟨(ParameterBounds.length (ParameterBounds.config packet.val.profile) opening.level.val).log2, + WHIRPhysicalVerifier.leafWords packet.val.profile opening.level.val, + if opening.level.val = 0 then lanes else WHIRPhysicalVerifier.leafWords packet.val.profile opening.level.val⟩⟩ + +/-- Strongest checked local join: exact caller original, actual raw-prefix +capture, and actual native queried rows (all phases, repetitions preserved), or +the existing captured-prefix bad event. No later physical registry is identified +with the earlier captured table. -/ +theorem mixed_success_captured_rows + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (view cap model ctx stack Q packet saved proofs B limit seed ro).result.value = some a) + (opening : WHIRPhysicalVerifier.QueryOpening packet.val.profile) + (member : opening ∈ a.wire.openings) + (current : EnteredPacket packet.val.profile B ctx.iv + (RawWHIRKeys.entry ctx packet.val).frames.length) + (visited : (.inl current : (part ctx Q packet B).Key) ∈ + ((Sampling.execute (table ctx Q packet B seed ro) + (allocationProgram cap model ctx stack Q packet saved proofs B limit)).2.map Sigma.fst)) + (mentioned : openingReference ctx Q packet opening saved.shape.lanes ∈ + PCSBCSCapturedSourceTransport.address (.inl current)) : + ∃ input : PCSBCSCallerBinding.CallerInput packet.val.profile, + PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table ctx Q packet B seed ro)) = some input ∧ + input.m = a.request.claims.count ∧ + (∀ root ring, OriginalClaimsChecker.input input.prepared root ring = + ⟨ParameterBounds.config packet.val.profile,saved.shape.lanes,root, + AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) saved + a.request.claims.family a.request.claims.points ring⟩) ∧ + ∃ f : Frozen, + PCSBCSSourceRootCapture.capture + PCSBCSCapturedSourceTransport.address + (openingReference ctx Q packet opening saved.shape.lanes) + (allocationProgram cap model ctx stack Q packet saved proofs B limit) + (table ctx Q packet B seed ro) = some f ∧ + AuthenticLog seed f.queryPrefix ∧ + (¬ OutputCollision f.queryPrefix → f.raw = sourceRoot seed + PCSBCSCapturedSourceTransport.address + (openingReference ctx Q packet opening saved.shape.lanes) + (allocationProgram cap model ctx stack Q packet saved proofs B limit) + (table ctx Q packet B seed ro)) ∧ + (opening.result.rows = WHIRPhysicalVerifier.atQueries + (WHIRPhysicalVerifier.frozenQueryOracle (hash seed) + ⟨recordDomain (records f.queryPrefix),[]⟩ opening.root packet.val.profile + opening.level.val saved.shape.lanes) + (WHIRPhysicalVerifier.queryIndices packet.val.profile opening.level opening.sample) ∨ + PublicMerkleBinding.OpenPrimitiveBad seed f.queryPrefix opening.root opening.result.paths) := by + obtain ⟨input,original,count,statement⟩ := PCSBCSNativeIdealCallerOriginal.fresh_original + cap model ctx stack Q packet saved proofs B limit seed ro a familyCap success + refine ⟨input,original,count,statement,?_⟩ + let addresses : (part ctx Q packet B).Key → List Reference := + PCSBCSCapturedSourceTransport.address + let ref := openingReference ctx Q packet opening saved.shape.lanes + let program := allocationProgram cap model ctx stack Q packet saved proofs B limit + obtain ⟨f,captured⟩ := PCSBCSSourceRootCapture.capture_exists addresses ref + (.inl current) mentioned program (table ctx Q packet B seed ro) visited + obtain ⟨events,found,frozen,_⟩ := PCSBCSSourceRootCapture.capture_provenance addresses ref + program (table ctx Q packet B seed ro) f captured + have authentic : AuthenticLog seed f.queryPrefix := by + rw [frozen] + exact PCSBCSMerkleSeedProjection.firstMention_authentic seed ro addresses ref program events found + have log : sourceLog addresses ref program (table ctx Q packet B seed ro) = f.queryPrefix := by + rw [frozen] + simp only [sourceLog,found,Option.getD_some,freeze_prefix] + refine ⟨f,captured,authentic,?_,?_⟩ + · intro clean + exact captured_sourceRoot seed addresses ref program (table ctx Q packet B seed ro) f + captured (log.symm ▸ authentic) (log.symm ▸ clean) + · obtain ⟨run,_,consistent⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨_,_,_,_,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + obtain ⟨proof,_,accepted,_⟩ := AnchoredIdealPhysicalAcceptance.observed_real + (observed opening member) seed ctx.iv consistent + exact WHIRPhysicalVerifier.openQuery_binding seed ctx.iv f.queryPrefix authentic + ⟨recordDomain (records f.queryPrefix),[]⟩ rfl packet.val.profile opening.level + saved.shape.lanes proof opening.root opening.sample opening.result accepted +end Driver + +/-- Literal entered-packet full blocks, including the unused suffix of the last +block. The native answer is the inverse index cast of the actual source table +answer, not a supplied scalar-cache or compatible-answer certificate. -/ +theorem entered_packet_codec (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (sourceTable : PCSStateRestoration.Latent.Table + (PCSBCSSourceRootCapture.Key (p := packet.val.profile) (Q := Q) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length)) + (PCSBCSSourceRootCapture.Answer)) : + let current := PCSBCSNativePacketBridge.enteredPacket ctx stack Q packet + let full := sourceTable (.inl current) + let native := (PCSBCSNativePacketCodec.nativeFullBlocksEquiv ctx stack Q packet).symm full + WHIRRawReplay.decodePacket ctx stack Q packet native = grouped current.2.coord full := by + dsimp only + rw [PCSBCSNativePacketCodec.decodePacket_eq_grouped] + exact congrArg (grouped (PCSBCSNativePacketBridge.query ctx Q packet)) + ((PCSBCSNativePacketCodec.nativeFullBlocksEquiv ctx stack Q packet).apply_symm_apply + (sourceTable (.inl (PCSBCSNativePacketBridge.enteredPacket ctx stack Q packet)))) + +#print axioms observed_snapshot +#print axioms mixed_success_captured_rows +#print axioms allocation_result +#print axioms entered_packet_codec +end Whir.PCSBCSCapturedIdealNativeAcceptance diff --git a/verification/whir/Whir/PCSBCSCapturedNativePhaseQuery.lean b/verification/whir/Whir/PCSBCSCapturedNativePhaseQuery.lean new file mode 100644 index 000000000..f00613d03 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedNativePhaseQuery.lean @@ -0,0 +1,540 @@ +import Whir.PCSBCSCapturedIdealNativeAcceptance +import Whir.PCSBCSMerkleRootCacheTransport + +/-! Exact historical phase/query crosswalk at ONE captured prefix. No theorem +identifies this table with a later physical registry. Initial occupied lanes may +be any admitted suffix of the full zero-prefixed leaf; extension lanes use all +three limbs, in wire order. Primitive bad alternatives are not discharged. + +The next-root projection below concerns the parsed root's captured prefix only. +To apply it to an actual native fold reply one must still establish that reply's +full next table uses this prefix; queried-row binding alone cannot establish that +fact, especially when raw construction prequeries preceded announcement. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCapturedNativePhaseQuery +open Concrete Protocol CausalGame CausalProbability FiatShamirGame WHIRHistory +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache PCSBCSMerkleLeafImages +open PCSBCSSourceFrozenAccessor PCSBCSFrozenOracleRows PCSBCSCapturedNativeReplyBridge +open PublicMerkleLog MerkleTransport MerkleTransport.Commitments WHIRPhysicalRows + +private theorem fieldWords_lanes (fields : List E) (i : Nat) (inside : i < fields.length) : + (ByteCodec.fieldWords fields)[3*i]! = fields[i]!.c0 ∧ + (ByteCodec.fieldWords fields)[3*i+1]! = fields[i]!.c1 ∧ + (ByteCodec.fieldWords fields)[3*i+2]! = fields[i]!.c2 := by + induction fields generalizing i with + | nil => simp at inside + | cons x xs ih => + cases i with + | zero => simp [ByteCodec.fieldWords] + | succ i => + have hi : i < xs.length := by simpa using inside + have index0 : 3*(i+1) = Nat.succ (Nat.succ (Nat.succ (3*i))) := by omega + have index1 : 3*(i+1)+1 = Nat.succ (Nat.succ (Nat.succ (3*i+1))) := by omega + have index2 : 3*(i+1)+2 = Nat.succ (Nat.succ (Nat.succ (3*i+2))) := by omega + simpa only [ByteCodec.fieldWords,List.flatMap_cons,List.append_assoc, + List.cons_append,List.nil_append,index0,index1,index2,List.getElem!_cons_succ] + using ih i hi + +/-- The array codec and the actual native list codec agree on every limb; +there is no zero-c2 restriction and no reversal or discarded remainder. -/ +theorem extensionRow_wordsToFields (words : List K) (fields : List E) + (decoded : ByteCodec.wordsToFields words = some fields) : + extensionRow words.toArray = some fields.toArray := by + have wordsEq := (ByteCodec.fieldWords_wordsToFields words fields decoded).symm + have size := ByteCodec.wordsToFields_length words fields decoded + unfold extensionRow + simp only [List.size_toArray, size, Nat.mul_mod_right, ↓reduceIte] + congr 1 + apply Array.ext + · simp only [Array.size_ofFn,List.size_toArray] + omega + · intro i hi hj + have inside : i < fields.length := by simpa using hj + have limbs := fieldWords_lanes fields i inside + simp only [Array.getElem_ofFn, List.getElem_toArray] + rw [wordsEq] + simp only [List.getElem!_toArray] + rw [limbs.1, limbs.2.1, limbs.2.2, getElem!_pos fields i inside] + +private theorem mapM_of_rows {α β : Type} [Inhabited β] + (xs : Array α) (f : α → Option β) (ys : Array β) + (size : ys.size = xs.size) + (rows : ∀ i : Fin xs.size, f xs[i] = some ys[i.val]!) : xs.mapM f = some ys := by + rw [Array.mapM_eq_mapM_toList] + have related : List.Forall₂ (fun x y => f x = some y) xs.toList ys.toList := by + apply List.forall₂_of_length_eq_of_get (by simpa using size.symm) + intro i hi hy + simpa [getElem!_pos, show i < ys.size by simpa using hy] using + rows ⟨i,by simpa using hi⟩ + have traversal (as : List α) (bs : List β) + (h : List.Forall₂ (fun x y => f x = some y) as bs) : as.mapM f = some bs := by + induction h with + | nil => rfl + | cons equal _ ih => simp only [List.mapM_cons,equal,ih]; rfl + rw [traversal _ _ related] + simp + +/-- Full later leaves are consecutive three-word E lanes, including ghost +zero rows. This equation uses exactly the same snapshot, never a later one. -/ +theorem extensionOracle_compact_full (hash : Primitive) (snapshot : Snapshot) + (root : Digest32) (height numRows width : Nat) : + extensionOracle (compactBaseOracle hash snapshot root height numRows (3*width) (3*width)) = + some (intermediateOracle hash snapshot root height numRows width) := by + unfold extensionOracle + apply mapM_of_rows + · simp [compactBaseOracle_size,intermediateOracle_size] + · intro i + have inside : i.val < numRows := by + simpa only [compactBaseOracle_size] using i.isLt + simp only [Fin.getElem_fin] + rw [← getElem!_pos (compactBaseOracle hash snapshot root height numRows (3*width) (3*width)) + i.val i.isLt] + rw [compactBaseOracle_get _ _ _ _ _ _ _ _ inside, + intermediateOracle_get _ _ _ _ _ _ _ inside] + simp only [compactBaseRow,Nat.sub_self,List.drop_zero] + exact extensionRow_wordsToFields _ _ (intermediateRow_decoded hash snapshot root height i.val width).1 + +/-- Exact initial/full-later source/native phase codec at an authentic capture. +For phase zero `occupied` is arbitrary; only later phases are fully occupied. -/ +theorem frozenOracle_native (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (p : ParameterBounds.Profile) (root : Digest32) (phase lanes : Nat) + (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) : + frozenOracle phase (freeze log root + ⟨(ParameterBounds.length (ParameterBounds.config p) phase).log2, + WHIRPhysicalVerifier.leafWords p phase, + if phase = 0 then lanes else WHIRPhysicalVerifier.leafWords p phase⟩) = + some (WHIRPhysicalVerifier.frozenQueryOracle (hash C) + ⟨recordDomain (records log),[]⟩ root p phase lanes) := by + let ref : Reference := ⟨root, + ⟨(ParameterBounds.length (ParameterBounds.config p) phase).log2, + WHIRPhysicalVerifier.leafWords p phase, + if phase = 0 then lanes else WHIRPhysicalVerifier.leafWords p phase⟩⟩ + have raw := (next_image_provenance C log ref auth clean).2 + change (freeze log root ref.shape).raw = _ at raw + unfold frozenOracle + rw [raw] + have count : 2^(ParameterBounds.length (ParameterBounds.config p) phase).log2 = + ParameterBounds.length (ParameterBounds.config p) phase := by + simp [ParameterBounds.length] + by_cases base : phase = 0 + · simp [ref,base,WHIRPhysicalVerifier.frozenQueryOracle,ParameterBounds.length] + · simp only [base,↓reduceIte,WHIRPhysicalVerifier.frozenQueryOracle] + simp only [ref,count,WHIRPhysicalVerifier.leafWords,base,↓reduceIte] + exact extensionOracle_compact_full _ _ _ _ _ _ + +/-- Actual typed native samples use the same strided query extraction as the +source parser, including repetitions and the original ordering. -/ +theorem queryIndices_derived (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) (x : Sample (.query i)) : + deriveQueries (remaining (ParameterBounds.config p) i.val + (ParameterBounds.config p).rates[i.val]!) + (ParameterBounds.config p).queries[i.val]! (Array.ofFn x.1) = + some (WHIRPhysicalVerifier.queryIndices p i x).toArray := by + have depth := TapeValidity.config_query_depth (ParameterBounds.config p) + (ParameterBounds.production_config_valid p).1 i.val i.isLt + unfold WHIRPhysicalVerifier.queryIndices + rw [Array.toArray_toList] + exact QueryBatchSoundness.queries_actual _ _ x.1 (by omega) depth.2 + +private theorem queryRows_list (oracle : Oracle) (qs : List Nat) + (bound : ∀ q ∈ qs, q < oracle.size) : + queryRows oracle qs.toArray = some (WHIRPhysicalVerifier.atQueries oracle qs) := by + unfold queryRows WHIRPhysicalVerifier.atQueries + apply mapM_of_rows + · simp + · intro i + have inside : i.val < qs.length := by simpa using i.isLt + have rowBound := bound qs[i.val] (List.getElem_mem inside) + change oracle[qs[i.val]]? = some ((qs.map (fun q => oracle[q]!)).toArray)[i.val]! + rw [getElem!_pos ((qs.map (fun q => oracle[q]!)).toArray) i.val (by simp [inside])] + simp [rowBound] + +/-- Checked source lookup is exactly native read-at-indices, with bounds proved +from the actual typed sampler rather than supplied selected-row equality. -/ +theorem queryRows_atQueries (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) (x : Sample (.query i)) + (oracle : Oracle) (size : oracle.size = ParameterBounds.length (ParameterBounds.config p) i.val) : + queryRows oracle (WHIRPhysicalVerifier.queryIndices p i x).toArray = + some (WHIRPhysicalVerifier.atQueries oracle (WHIRPhysicalVerifier.queryIndices p i x)) := by + apply queryRows_list + intro q member + have nativeMember : q ∈ QueryBatchSoundness.queries + (remaining (ParameterBounds.config p) i.val + (ParameterBounds.config p).rates[i.val]!) + (ParameterBounds.config p).queries[i.val]! x.1 := by + simpa only [WHIRPhysicalVerifier.queryIndices,Array.mem_def] using member + obtain ⟨j,hj,same⟩ := Array.mem_iff_getElem.mp nativeMember + have count : j < (ParameterBounds.config p).queries[i.val]! := by + rw [← QueryBatchSoundness.queries_size _ _ x.1] + exact hj + have queryBound := QueryBatchSoundness.queries_bound + (remaining (ParameterBounds.config p) i.val + (ParameterBounds.config p).rates[i.val]!) + (ParameterBounds.config p).queries[i.val]! x.1 j count + rw [size,← same] + rw [getElem!_pos (QueryBatchSoundness.queries + (remaining (ParameterBounds.config p) i.val + (ParameterBounds.config p).rates[i.val]!) + (ParameterBounds.config p).queries[i.val]! x.1) j hj] at queryBound + exact queryBound + +/-- Exact semantic selected rows whenever the source's padding/status guard +admits them. Authentication of that guard is derived below from native opening +acceptance, not assumed by this pure codec equation. -/ +theorem selectPhase_rows (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (p : ParameterBounds.Profile) (root : Digest32) (i : Fin (ParameterBounds.config p).folds.size) + (lanes : Nat) (x : Sample (.query i)) + (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) + (selected : Selected) + (selection : selectPhase i.val (freeze log root + ⟨(ParameterBounds.length (ParameterBounds.config p) i.val).log2, + WHIRPhysicalVerifier.leafWords p i.val, + if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val⟩) + (WHIRPhysicalVerifier.queryIndices p i x).toArray = some selected) : + selected.rows = WHIRPhysicalVerifier.atQueries + (WHIRPhysicalVerifier.frozenQueryOracle (hash C) ⟨recordDomain (records log),[]⟩ root p i.val lanes) + (WHIRPhysicalVerifier.queryIndices p i x) := by + obtain ⟨_,oracle,decoded,size,rows⟩ := selectPhase_order _ _ _ _ selection + have equal := Option.some.inj (decoded.symm.trans + (frozenOracle_native C log p root i.val lanes auth clean)) + subst oracle + apply Array.ext + · simpa [WHIRPhysicalVerifier.atQueries] using size + · intro j hj hn + have inside : j < (WHIRPhysicalVerifier.queryIndices p i x).toArray.size := by + simpa [size] using hj + have row := rows ⟨j,inside⟩ + simpa [WHIRPhysicalVerifier.atQueries,getElem!_pos,hj] using row + +theorem decodeRows_projection (phase rowWords leafWords : Nat) + (paths : List RawPath) (native : Oracle) + (later : phase ≠ 0 → rowWords = leafWords) + (decoded : WHIRPhysicalVerifier.decodeRows (phase == 0) rowWords leafWords paths = some native) : + List.Forall₂ (fun path row => + rowCodec phase (path.leafData.drop (leafWords-rowWords)).toArray = some row) + paths native.toList := by + by_cases base : phase = 0 + · simp only [WHIRPhysicalVerifier.decodeRows,base,beq_self_eq_true,↓reduceIte, + Option.some.injEq] at decoded + subst native + induction paths with + | nil => exact .nil + | cons path paths ih => exact .cons (by simp [rowCodec,base]) ih + · simp only [WHIRPhysicalVerifier.decodeRows,show (phase == 0) = false by simp [base], + Bool.false_eq_true,↓reduceIte] at decoded + obtain ⟨fields,collected,equal⟩ := Option.map_eq_some_iff.mp decoded + subst native + have related := (collect_spec _ _ _).mp collected + clear collected decoded + induction related with + | nil => exact .nil + | cons h _ ih => + apply List.Forall₂.cons _ ih + simpa [rowCodec,base,later base] using extensionRow_wordsToFields _ _ h + +/-- Native accepted openings authenticate the full initial zero prefix before +selecting its occupied suffix. No selected-row equality or source replay is an +input. Later openings authenticate all three limbs of every occupied E lane. +The existing primitive bad branch, including output collision, remains literal. -/ +theorem openQuery_selectPhase (C : DuplexModeGame.PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (p : ParameterBounds.Profile) + (i : Fin (ParameterBounds.config p).folds.size) (lanes : Nat) + (fits : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (proof : PrunedMerklePaths) (root : Digest32) (x : Sample (.query i)) + (out : WHIRPhysicalVerifier.Opened) + (accepted : (DuplexModeGame.runReal C iv (WHIRPhysicalVerifier.openQuery p i lanes proof root x)).view.result = + some out) : + (∃ selected, selectPhase i.val (freeze log root + ⟨(ParameterBounds.length (ParameterBounds.config p) i.val).log2, + WHIRPhysicalVerifier.leafWords p i.val, + if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val⟩) + (WHIRPhysicalVerifier.queryIndices p i x).toArray = some selected ∧ + selected.rows = out.rows ∧ selected.queries = (WHIRPhysicalVerifier.queryIndices p i x).toArray ∧ + ∀ cell ∈ selected.cells, cell.available = true ∧ cell.paddingValid = true) ∨ + PublicMerkleBinding.OpenPrimitiveBad C log root out.paths := by + let shape : Shape := ⟨(ParameterBounds.length (ParameterBounds.config p) i.val).log2, + WHIRPhysicalVerifier.leafWords p i.val, + if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val⟩ + have shapeFits : shape.occupied ≤ shape.leafWords := by + dsimp [shape] + split + next base => simpa [WHIRPhysicalVerifier.leafWords,base] using fits + next => exact Nat.le_refl _ + obtain ⟨opened,decoded⟩ := WHIRPhysicalVerifier.openRows_real_accepted C iv proof root + (ParameterBounds.length (ParameterBounds.config p) i.val) + (WHIRPhysicalVerifier.queryIndices p i x) shape.occupied shape.leafWords (i.val == 0) out accepted + have bounds := WHIRPhysicalVerifier.path_input_bounds C proof root + (ParameterBounds.length (ParameterBounds.config p) i.val) + (WHIRPhysicalVerifier.queryIndices p i x) shape.occupied shape.leafWords out.paths opened + (WHIRPhysicalVerifier.production_leaf_byte_limit p i) + rcases PCSBCSMerkleSourceRows.pruned_opened_compact C log auth root proof + (ParameterBounds.length (ParameterBounds.config p) i.val) shape.leafWords shape.occupied + (WHIRPhysicalVerifier.queryIndices p i x) out.paths opened bounds with transport | bad + · obtain ⟨oracle,oracleDecoded,_⟩ := PCSBCSSourceFrozenAccessorStructural.frozenOracle_freeze + log root shape shapeFits i.val (by + by_cases base : i.val = 0 + · exact Or.inl base + · right; simp [shape,base,WHIRPhysicalVerifier.leafWords]) + have projection := decodeRows_projection i.val shape.occupied shape.leafWords out.paths out.rows + (by intro later; simp [shape,later]) decoded + left + exact select_accepted i.val (freeze log root shape) + (WHIRPhysicalVerifier.queryIndices p i x).toArray out.paths shape.leafWords shape.occupied + out.rows oracle oracleDecoded + (PCSBCSSourceFrozenAccessorStructural.freeze_shape_exact log root shape shapeFits).2.1 + (by simpa [freeze,shape] using transport) projection + · exact Or.inr bad + +/-- Parsed historical next-root roles fix the full later shape. This is the +exact projection required by NativeEvidence.next for the *captured-prefix* +native table, not an identification with the native driver's later table. -/ +theorem parsed_next_projection (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (p : ParameterBounds.Profile) (i : Fin (ParameterBounds.config p).folds.size) + (j : Fin (ParameterBounds.config p).folds[i.val]!) (m : Pending) (ref : Reference) + (parsed : parsePhase (ParameterBounds.config p) (.fold i j) m (i.val+1) 2 = some ref) + (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) : + extensionOracle (compactBaseOracle (hash C) ⟨recordDomain (records log),[]⟩ + ref.root ref.shape.height (2^ref.shape.height) ref.shape.leafWords ref.shape.occupied) = + some (WHIRPhysicalVerifier.frozenQueryOracle (hash C) ⟨recordDomain (records log),[]⟩ + ref.root p (i.val+1) 0) ∧ + frozenOracle (i.val+1) (freeze log ref.root ref.shape) = + some (WHIRPhysicalVerifier.frozenQueryOracle (hash C) ⟨recordDomain (records log),[]⟩ + ref.root p (i.val+1) 0) := by + have shape := (parsePhase_admitted _ _ _ _ _ _ parsed).2.2.2 + have geometry : ref.shape = + ⟨(ParameterBounds.length (ParameterBounds.config p) (i.val+1)).log2, + WHIRPhysicalVerifier.leafWords p (i.val+1), + if i.val+1 = 0 then 0 else WHIRPhysicalVerifier.leafWords p (i.val+1)⟩ := by + rw [shape] + simp [phaseShape,ParameterBounds.length,WHIRPhysicalVerifier.leafWords] + have decoded := frozenOracle_native C log p ref.root (i.val+1) 0 auth clean + rw [← geometry] at decoded + refine ⟨?_,decoded⟩ + have raw := (next_image_provenance C log ref auth clean).2 + simpa only [frozenOracle,Nat.add_eq_zero_iff,Nat.one_ne_zero,and_false,↓reduceIte,raw] using decoded + + +private theorem remaining_initial (c : Config) : remaining c 0 = c.logN-c.folds[0]! := by + have first (xs : List Nat) : (xs.take 1).sum = xs.toArray[0]! := by + cases xs <;> simp + change c.logN-(c.folds.toList.take 1).sum = c.logN-c.folds[0]! + rw [first] + +private theorem sameShape_exact (a b : Shape) (same : sameShape a b = true) : a = b := by + cases a + cases b + simp only [sameShape,Bool.and_eq_true,beq_iff_eq] at same + obtain ⟨⟨rfl,rfl⟩,rfl⟩ := same + rfl + +/-- The actual source phase parser admits exactly the native geometry. Initial +lane occupancy is copied from the saved record, not replaced by the full cube. -/ +theorem phaseReference_geometry (p : ParameterBounds.Profile) (saved : AnchoredHeaderCodec.Record) + (messages : List Pending) (phase : Nat) (ref : Reference) + (reference : phaseReference (ParameterBounds.config p) saved messages phase = some ref) : + ref.shape = ⟨(ParameterBounds.length (ParameterBounds.config p) phase).log2, + WHIRPhysicalVerifier.leafWords p phase, + if phase = 0 then saved.shape.lanes else WHIRPhysicalVerifier.leafWords p phase⟩ := by + unfold phaseReference at reference + by_cases base : phase = 0 + · simp only [base,↓reduceIte] at reference + split at reference + next compatible => + have initial := (parseInitial_admitted saved _ _ ref reference).2.2.2 + rw [initial] + obtain ⟨logN,batch,rate⟩ := compatible + simp [initialShape,base,ParameterBounds.length,WHIRPhysicalVerifier.leafWords, + remaining_initial,logN,batch,rate] + next => contradiction + · simp only [base,↓reduceIte] at reference + split at reference + next admitted => + cases found : (phaseReferences (ParameterBounds.config p) messages)[phase-1]? with + | none => simp [found] at reference + | some other => + simp only [found,Bind.bind,Option.bind] at reference + split at reference + next same => + have shape := sameShape_exact other.shape _ same + cases Option.some.inj reference + rw [shape] + simp [phaseShape,ParameterBounds.length,WHIRPhysicalVerifier.leafWords,base] + next => contradiction + next => contradiction + +/-- Parser-admitted Reference crosswalk; both sides consult its actual captured +log, including earlier raw construction prequeries. -/ +theorem phaseReference_frozenOracle (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (p : ParameterBounds.Profile) (saved : AnchoredHeaderCodec.Record) + (messages : List Pending) (phase : Nat) (ref : Reference) + (reference : phaseReference (ParameterBounds.config p) saved messages phase = some ref) + (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) : + frozenOracle phase (freeze log ref.root ref.shape) = + some (WHIRPhysicalVerifier.frozenQueryOracle (hash C) + ⟨recordDomain (records log),[]⟩ ref.root p phase saved.shape.lanes) := by + rw [phaseReference_geometry p saved messages phase ref reference] + exact frozenOracle_native C log p ref.root phase saved.shape.lanes auth clean + +/-- The full image needed by the source opening is the exact native leaf image, +not a fully-occupied substitute. Compacting it returns the actual native proof. -/ +theorem native_openSource_fullImage (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves rowWords leafWords : Nat) (qs : List Nat) + (paths : List RawPath) + (opened : proof.open hash root numLeaves qs rowWords leafWords = some paths) : + PCSBCSMerkleFullSourceTransport.openSource hash + ⟨proof.leafData.map (MerkleBinding.leafImage 0 leafWords),proof.siblingHashes⟩ + root numLeaves qs leafWords rowWords = some paths := by + have conditions := ((open_spec _ _ _ _ _ _ _ _).mp opened).1 + have compact : collect (PCSBCSMerkleFullSourceTransport.compactLeaf leafWords rowWords) + (proof.leafData.map (MerkleBinding.leafImage 0 leafWords)) = some proof.leafData := by + apply (collect_spec _ _ _).mpr + apply List.forall₂_map_left_iff.mpr + have each : ∀ row ∈ proof.leafData, + PCSBCSMerkleFullSourceTransport.compactLeaf leafWords rowWords + (MerkleBinding.leafImage 0 leafWords row) = some row := by + intro row member + have width := conditions.widths row member + simp [PCSBCSMerkleFullSourceTransport.compactLeaf,conditions.fits, + MerkleBinding.leafImage,width,zeroPrefix_replicate] + apply List.forall₂_of_length_eq_of_get rfl + intro n hn hm + exact each _ (List.getElem_mem hn) + unfold PCSBCSMerkleFullSourceTransport.openSource PCSBCSMerkleFullSourceTransport.compactProof + rw [compact] + exact opened + +section SourceQuery +open TypedOracleCompiler PCSStateRestoration.Latent +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} + {R : Type} {count : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Exact query constructor for the parent's ReplyTransport. The source log is +computed by firstMention, and the same-tape sample is read directly from past. +Only real native opening acceptance, literal source reference admission and +authentic captured-prefix evidence remain inputs; neither selected-row equality, +accepted replay nor ReaderTransport is assumed. This local theorem does not +eliminate any enclosing FrozenExtractionBad alternative. -/ +theorem source_query_of_native + (addresses : Keys → List Reference) (program : Sampling Keys Answers R count) + (table : Table Keys Answers) (C : DuplexModeGame.PrimitiveOracle) + (current : Coordinate (ParameterBounds.config p)) (saved : AnchoredHeaderCodec.Record) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (m : Pending) (digest : Digest32) + (i : Fin (ParameterBounds.config p).folds.size) (a : Message E) + (earlier : position (.query i : Coordinate (ParameterBounds.config p)) < position current) + (ref : Reference) + (reference : phaseReference (ParameterBounds.config p) saved + (messages.reverse.take (position (.query i : Coordinate (ParameterBounds.config p))+1)).reverse + i.val = some ref) + (auth : AuthenticLog C (sourceLog addresses ref program table)) + (fits : saved.shape.lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (proof : PrunedMerklePaths) (out : WHIRPhysicalVerifier.Opened) + (accepted : (DuplexModeGame.runReal C iv + (WHIRPhysicalVerifier.openQuery p i saved.shape.lanes proof ref.root (past (.query i) earlier))).view.result = + some out) : + SourceEvidence addresses program table C current saved messages past m digest + (.query i) (.query out.rows a) ∨ + PublicMerkleBinding.OpenPrimitiveBad C (sourceLog addresses ref program table) ref.root out.paths := by + let log := sourceLog addresses ref program table + let x := past (.query i) earlier + let qs := (WHIRPhysicalVerifier.queryIndices p i x).toArray + have geometry := phaseReference_geometry p saved _ i.val ref reference + have shapeFits : ref.shape.occupied ≤ ref.shape.leafWords := by + rw [geometry] + dsimp only + split + next base => simpa [WHIRPhysicalVerifier.leafWords,base] using fits + next => exact Nat.le_refl _ + have codec : i.val = 0 ∨ ref.shape.occupied % 3 = 0 := by + by_cases base : i.val = 0 + · exact Or.inl base + · right; simp [geometry,base,WHIRPhysicalVerifier.leafWords] + obtain ⟨opened,decoded⟩ := WHIRPhysicalVerifier.openRows_real_accepted C iv proof ref.root + (ParameterBounds.length (ParameterBounds.config p) i.val) qs.toList + ref.shape.occupied ref.shape.leafWords (i.val == 0) out + (by simpa [qs,geometry,WHIRPhysicalVerifier.openQuery,x] using accepted) + have full := native_openSource_fullImage (hash C) proof ref.root + (ParameterBounds.length (ParameterBounds.config p) i.val) + ref.shape.occupied ref.shape.leafWords qs.toList out.paths opened + have bounds := WHIRPhysicalVerifier.path_input_bounds C proof ref.root + (ParameterBounds.length (ParameterBounds.config p) i.val) qs.toList + ref.shape.occupied ref.shape.leafWords out.paths opened + (by rw [geometry]; exact WHIRPhysicalVerifier.production_leaf_byte_limit p i) + have projected := decodeRows_projection i.val ref.shape.occupied ref.shape.leafWords + out.paths out.rows (by intro later; simp [geometry,later]) decoded + by_cases bad : PublicMerkleBinding.OpenPrimitiveBad C log ref.root out.paths + · exact Or.inr bad + · left + exact .query i a out.rows earlier ref log reference rfl shapeFits codec qs + (queryIndices_derived p i x) + (ParameterBounds.length (ParameterBounds.config p) i.val) + ⟨proof.leafData.map (MerkleBinding.leafImage 0 ref.shape.leafWords),proof.siblingHashes⟩ + out.paths (by rw [geometry]) auth full bounds bad projected +/-- Actual capture provenance gives the phase codec at the literal stored +prefix, not at a later root announcement or a supplied frozen-oracle callback. -/ +theorem captured_phase_oracle + (addresses : Keys → List Reference) (program : Sampling Keys Answers R count) + (table : Table Keys Answers) (C : DuplexModeGame.PrimitiveOracle) + (saved : AnchoredHeaderCodec.Record) (messages : List Pending) + (phase : Nat) (ref : Reference) (f : Frozen) + (reference : phaseReference (ParameterBounds.config p) saved messages phase = some ref) + (captured : PCSBCSSourceRootCapture.capture addresses ref program table = some f) + (auth : AuthenticLog C f.queryPrefix) (clean : ¬ OutputCollision f.queryPrefix) : + frozenOracle phase f = some (WHIRPhysicalVerifier.frozenQueryOracle (hash C) + ⟨recordDomain (records f.queryPrefix),[]⟩ ref.root p phase saved.shape.lanes) := by + obtain ⟨events,_,frozen,_⟩ := PCSBCSSourceRootCapture.capture_provenance + addresses ref program table f captured + have literal : f = freeze f.queryPrefix ref.root ref.shape := by + rw [frozen] + rfl + nth_rw 1 [literal] + exact phaseReference_frozenOracle C f.queryPrefix p saved messages phase ref reference auth clean + +/-- Actual native opening at an actually captured, parser-admitted Reference: +all selected cells authenticate full leaf images, all padded initial shapes are +supported, and query order/repetitions are preserved. The bad case is unchanged. -/ +theorem captured_query_selection + (addresses : Keys → List Reference) (program : Sampling Keys Answers R count) + (table : Table Keys Answers) (C : DuplexModeGame.PrimitiveOracle) + (saved : AnchoredHeaderCodec.Record) (messages : List Pending) + (i : Fin (ParameterBounds.config p).folds.size) (ref : Reference) (f : Frozen) + (reference : phaseReference (ParameterBounds.config p) saved messages i.val = some ref) + (captured : PCSBCSSourceRootCapture.capture addresses ref program table = some f) + (auth : AuthenticLog C f.queryPrefix) + (fits : saved.shape.lanes ≤ 2^(ParameterBounds.config p).folds[0]!) + (proof : PrunedMerklePaths) (x : Sample (.query i)) (out : WHIRPhysicalVerifier.Opened) + (accepted : (DuplexModeGame.runReal C iv + (WHIRPhysicalVerifier.openQuery p i saved.shape.lanes proof ref.root x)).view.result = some out) : + (∃ selected, selectPhase i.val f (WHIRPhysicalVerifier.queryIndices p i x).toArray = some selected ∧ + selected.rows = out.rows ∧ selected.queries = (WHIRPhysicalVerifier.queryIndices p i x).toArray ∧ + ∀ cell ∈ selected.cells, cell.available = true ∧ cell.paddingValid = true) ∨ + PublicMerkleBinding.OpenPrimitiveBad C f.queryPrefix ref.root out.paths := by + obtain ⟨events,_,frozen,_⟩ := PCSBCSSourceRootCapture.capture_provenance + addresses ref program table f captured + have literal : f = freeze f.queryPrefix ref.root ref.shape := by + rw [frozen] + rfl + have geometry := phaseReference_geometry p saved messages i.val ref reference + have good := openQuery_selectPhase C iv f.queryPrefix auth p i saved.shape.lanes fits proof ref.root x out accepted + rw [← geometry] at good + nth_rw 1 [literal] + exact good + +end SourceQuery + +#print axioms extensionRow_wordsToFields +#print axioms extensionOracle_compact_full +#print axioms frozenOracle_native +#print axioms queryIndices_derived +#print axioms queryRows_atQueries +#print axioms selectPhase_rows +#print axioms openQuery_selectPhase +#print axioms parsed_next_projection +#print axioms decodeRows_projection +#print axioms phaseReference_geometry +#print axioms phaseReference_frozenOracle +#print axioms native_openSource_fullImage +#print axioms source_query_of_native +#print axioms captured_phase_oracle +#print axioms captured_query_selection +end Whir.PCSBCSCapturedNativePhaseQuery diff --git a/verification/whir/Whir/PCSBCSCapturedNativeReplyBridge.lean b/verification/whir/Whir/PCSBCSCapturedNativeReplyBridge.lean new file mode 100644 index 000000000..520857eea --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedNativeReplyBridge.lean @@ -0,0 +1,482 @@ +import Whir.PCSBCSCapturedSourceTransport + +/-! Native formal-model reply transport. Source tags and erased-field normal +forms are explicit. Accepted full padded openings authenticate query suffixes +outside OpenPrimitiveBad; a phase codec then transports the actual semantic +rows, in derived order, without deduplication. Next tables come from the +primitive-prefix snapshot, not a digest-to-oracle callback. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCapturedNativeReplyBridge +open Concrete Protocol CausalGame CausalProbability FiatShamirGame WHIRHistory +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache PCSBCSMerkleLeafImages +open PCSBCSSourceFrozenAccessor PCSBCSSourceReplyInversion PCSBCSFrozenOracleRows +open PublicMerkleLog MerkleTransport +open MerkleTransport.Commitments + +/-- The native phase codec, preserving wire lane order. -/ +def rowCodec (phase : Nat) (words : Array K) : Option (Array E) := + if phase = 0 then some (words.map E.ofK) else extensionRow words + +private theorem mapM_some {α β : Type} [Inhabited β] (xs : Array α) (f : α → Option β) + (ys : Array β) (size : ys.size = xs.size) + (each : ∀ i : Fin xs.size, f xs[i] = some ys[i.val]!) : xs.mapM f = some ys := by + rw [Array.mapM_eq_mapM_toList] + have rel : List.Forall₂ (fun x y => f x = some y) xs.toList ys.toList := by + apply List.forall₂_of_length_eq_of_get (by simpa using size.symm) + intro i hi hy + simpa [getElem!_pos,show i < ys.size by simpa using hy] using each ⟨i,by simpa using hi⟩ + have go (as : List α) (bs : List β) + (h : List.Forall₂ (fun x y => f x = some y) as bs) : as.mapM f = some bs := by + induction h with + | nil => rfl + | cons h _ ih => simp only [List.mapM_cons,h,ih]; rfl + rw [go _ _ rel] + simp + +/-- Checked full-table decoding gives precisely the same per-row codec. -/ +theorem frozenOracle_row (phase : Nat) (f : Frozen) (oracle : Oracle) + (decoded : frozenOracle phase f = some oracle) : + oracle.size = f.raw.size ∧ ∀ i : Fin f.raw.size, + rowCodec phase f.raw[i] = some oracle[i.val]! := by + by_cases base : phase = 0 + · simp only [frozenOracle,base,↓reduceIte,Option.some.injEq] at decoded + subst oracle + refine ⟨by simp [liftRoot],?_⟩ + intro i + simp [rowCodec,base,liftRoot,getElem!_pos] + · have parsed : f.raw.mapM extensionRow = some oracle := by + simpa only [frozenOracle,base,↓reduceIte,extensionOracle] using decoded + rw [Array.mapM_eq_mapM_toList] at parsed + obtain ⟨rows,hr,heq⟩ := Option.map_eq_some_iff.mp parsed + have rel := WHIRCallerGeometry.option_mapM_rel extensionRow f.raw.toList rows hr + have same : rows.toArray = oracle := heq + subst oracle + refine ⟨by simpa using rel.length_eq.symm,?_⟩ + intro i + have hi : i.val < rows.length := by rw [← rel.length_eq]; simp + have row := rel.get (i := i.val) (by simp) hi + simpa [rowCodec,base,getElem!_pos,hi] using row + +/-- Accepted source openings imply both status bits. Thus even an all-zero +unavailable ghost cannot serve as an authenticated source row. -/ +theorem accepted_rows (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (ref : Reference) (numLeaves : Nat) (queries : List Nat) + (proof : PrunedMerklePaths) (output : List RawPath) + (height : ref.shape.height = numLeaves.log2) (auth : AuthenticLog C log) + (accepted : PCSBCSMerkleFullSourceTransport.openSource (hash C) proof ref.root + numLeaves queries ref.shape.leafWords ref.shape.occupied = some output) + (bounds : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (hashing (hash C)), bytes.length < 2^64) + (quiet : ¬ PublicMerkleBinding.OpenPrimitiveBad C log ref.root output) : + List.Forall₂ (fun q path => (freeze log ref.root ref.shape).raw[q]! = + (path.leafData.drop (ref.shape.leafWords-ref.shape.occupied)).toArray ∧ + ((freeze log ref.root ref.shape).cells[q]?).map + (fun cell => (cell.available,cell.paddingValid)) = some (true,true)) queries output := by + obtain ⟨compact,_,opened⟩ := PCSBCSMerkleFullSourceTransport.openSource_refines + (hash C) proof ref.root numLeaves queries ref.shape.leafWords ref.shape.occupied output accepted + rcases PCSBCSMerkleSourceRows.pruned_opened_compact C log auth ref.root compact + numLeaves ref.shape.leafWords ref.shape.occupied queries output opened bounds with good | bad + · simpa only [freeze,height] using good + · exact (quiet bad).elim + +/-- Semantic query rows are decoded from the accepted full opening suffixes, +not equated to captured rows as a premise. Repeated queries remain repeated. -/ +theorem select_accepted (phase : Nat) (f : Frozen) (qs : Array Nat) + (output : List RawPath) (leafWords occupied : Nat) (native : Oracle) + (oracle : Oracle) (decoded : frozenOracle phase f = some oracle) + (shape : f.raw.size = f.cells.size) + (transport : List.Forall₂ (fun q path => f.raw[q]! = + (path.leafData.drop (leafWords-occupied)).toArray ∧ + (f.cells[q]?).map (fun cell => (cell.available,cell.paddingValid)) = some (true,true)) qs.toList output) + (projection : List.Forall₂ (fun path row => + rowCodec phase (path.leafData.drop (leafWords-occupied)).toArray = some row) output native.toList) : + ∃ selected, selectPhase phase f qs = some selected ∧ selected.rows = native ∧ + selected.queries = qs ∧ ∀ cell ∈ selected.cells, cell.available = true ∧ cell.paddingValid = true := by + have nativeSize : native.size = qs.size := by + have h := transport.length_eq.trans projection.length_eq + simpa using h.symm + have cellAt (i : Fin qs.size) : ∃ cell, f.cells[qs[i]]? = some cell ∧ + cell.available = true ∧ cell.paddingValid = true := by + have ho : i.val < output.length := by rw [← transport.length_eq]; simp + have status := (transport.get (i := i.val) (by simp) ho).2 + obtain ⟨cell,hc,hflags⟩ := Option.map_eq_some_iff.mp status + exact ⟨cell,hc,(Prod.mk.inj hflags).1,(Prod.mk.inj hflags).2⟩ + let cells := qs.map (fun q => f.cells[q]!) + have cellsParsed : qs.mapM (fun q => f.cells[q]?) = some cells := by + apply mapM_some _ _ _ (by simp [cells]) + intro i + obtain ⟨cell,hc,_,_⟩ := cellAt i + change f.cells[qs[i]]? = some cells[i.val]! + have same : cells[i.val]! = cell := by + rw [getElem!_pos cells i.val (by simp [cells])] + simp only [cells,Array.getElem_map] + change f.cells[qs[i]]! = cell + rw [getElem!_def,hc] + rw [same] + exact hc + have rowsParsed : queryRows oracle qs = some native := by + apply mapM_some _ _ _ nativeSize + intro i + obtain ⟨cell,hc,_,_⟩ := cellAt i + have inside : qs[i] < f.cells.size := (Array.getElem?_eq_some_iff.mp hc).1 + have rawInside : qs[i] < f.raw.size := by rw [shape]; exact inside + have ho : i.val < output.length := by rw [← transport.length_eq]; simp + have hn : i.val < native.size := by rw [nativeSize]; exact i.isLt + have suffix := (transport.get (i := i.val) (by simp) ho).1 + have projected := projection.get (i := i.val) ho (by simpa using hn) + have codec := (frozenOracle_row phase f oracle decoded).2 ⟨qs[i],rawInside⟩ + simp only [List.get_eq_getElem,Array.getElem_toList] at suffix projected + simp only [Fin.getElem_fin] at codec rawInside ⊢ + rw [getElem!_pos f.raw (qs[i.val]) rawInside] at suffix + rw [suffix] at codec + have equal : oracle[qs[i]]! = native[i.val]! := by + rw [projected] at codec + simpa [getElem!_pos native i.val hn] using (Option.some.inj codec).symm + have bound : qs[i] < oracle.size := by rw [(frozenOracle_row phase f oracle decoded).1]; exact rawInside + simp only [Fin.getElem_fin] at equal bound + rw [Array.getElem?_eq_getElem bound,← getElem!_pos oracle (qs[i.val]) bound,equal] + have flags : cells.all (fun cell => !cell.available || cell.paddingValid) = true := by + rw [Array.all_eq_true] + intro i hi + have iq : i < qs.size := by simpa [cells] using hi + obtain ⟨cell,hc,ha,hp⟩ := cellAt ⟨i,iq⟩ + change f.cells[qs[i]]? = some cell at hc + simp only [cells,Array.getElem_map] + change (!f.cells[qs[i]]!.available || f.cells[qs[i]]!.paddingValid) = true + rw [getElem!_def,hc] + simp only [ha,hp,Bool.not_true,Bool.false_or] + refine ⟨⟨qs,native,cells⟩,?_,rfl,rfl,?_⟩ + · unfold selectPhase + rw [decoded] + dsimp only [Bind.bind,Option.bind] + rw [rowsParsed] + dsimp only [Bind.bind,Option.bind] + rw [cellsParsed] + dsimp only [Bind.bind,Option.bind] + rw [flags] + rfl + · intro cell member + obtain ⟨q,hq,rfl⟩ := Array.mem_map.mp member + obtain ⟨i,hi,heq⟩ := Array.mem_iff_getElem.mp hq + obtain ⟨actual,hc,ha,hp⟩ := cellAt ⟨i,hi⟩ + change f.cells[qs[i]]? = some actual at hc + rw [← heq,getElem!_def,hc] + exact ⟨ha,hp⟩ + +/-- Full next-image provenance includes all rows, including unavailable defaults +and invalid padding. It is not just a quotient equality at queried indexes. -/ +theorem next_image_provenance (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (ref : Reference) (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) : + imageTable (freeze log ref.root ref.shape).cells = + MerkleTransport.Commitments.baseOracle (hash C) + ⟨recordDomain (records log),[]⟩ ref.root ref.shape.height (2^ref.shape.height) ref.shape.leafWords ∧ + (freeze log ref.root ref.shape).raw = WHIRPhysicalRows.compactBaseOracle (hash C) + ⟨recordDomain (records log),[]⟩ ref.root ref.shape.height (2^ref.shape.height) + ref.shape.leafWords ref.shape.occupied := by + exact ⟨PCSBCSMerkleSourceRows.imageRoot0_eq_baseOracle C log auth clean ref.root + ref.shape.height ref.shape.leafWords ref.shape.occupied, + PCSBCSMerkleSourceRows.compactRoot0_eq_compactBaseOracle C log auth clean ref.root + ref.shape.height ref.shape.leafWords ref.shape.occupied⟩ + +/-- Opening the full index range transports a genuine native full table and +authenticates every cell. This stronger statement is needed if the native model +uses a fully available table rather than the total primitive snapshot view. -/ +theorem accepted_full_table (C : DuplexModeGame.PrimitiveOracle) (log : PublicLog) + (ref : Reference) (numLeaves : Nat) (proof : PrunedMerklePaths) (output : List RawPath) + (height : ref.shape.height = numLeaves.log2) (auth : AuthenticLog C log) + (accepted : PCSBCSMerkleFullSourceTransport.openSource (hash C) proof ref.root numLeaves + (List.range (2^ref.shape.height)) ref.shape.leafWords ref.shape.occupied = some output) + (bounds : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (hashing (hash C)), bytes.length < 2^64) + (quiet : ¬ PublicMerkleBinding.OpenPrimitiveBad C log ref.root output) : + (freeze log ref.root ref.shape).raw = + (output.map (fun path => (path.leafData.drop (ref.shape.leafWords-ref.shape.occupied)).toArray)).toArray ∧ + ∀ i < 2^ref.shape.height, + ((freeze log ref.root ref.shape).cells[i]?).map + (fun cell => (cell.available,cell.paddingValid)) = some (true,true) := by + have transport := accepted_rows C log ref numLeaves (List.range (2^ref.shape.height)) + proof output height auth accepted bounds quiet + have length : output.length = 2^ref.shape.height := by simpa using transport.length_eq.symm + constructor + · apply Array.ext + · simp [freeze,compactTable,sourceCells_size,length] + · intro i hi ho + have inside : i < 2^ref.shape.height := by + simpa only [freeze,compactTable,Array.size_map,sourceCells_size] using hi + have related := (transport.get (i := i) (by simpa using inside) (by omega)).1 + simpa only [List.get_eq_getElem,List.getElem_range, + getElem!_pos (freeze log ref.root ref.shape).raw i hi, + List.getElem_toArray,List.getElem_map] using related + · intro i hi + have related := (transport.get (i := i) (by simpa using hi) (by omega)).2 + simpa only [List.get_eq_getElem,List.getElem_range] using related + +/-- The capture field of NativeEvidence on the production registry is supplied +by actual first-mention execution, not by a supplied frozen oracle callback. -/ +theorem captured_freeze_provenance {p : ParameterBounds.Profile} {Q : Nat} + {iv : Digest32} {boundary : Nat} {R : Type} {n : Nat} + (addresses : PCSBCSSourceRootCapture.Key (p := p) (Q := Q) (iv := iv) + (boundary := boundary) → List Reference) + (program : TypedOracleCompiler.Sampling _ (PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary)) R n) + (table : PCSStateRestoration.Latent.Table _ _) (current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (ref : Reference) (mentioned : ref ∈ addresses (.inl current)) + (visited : (.inl current : PCSBCSSourceRootCapture.Key) ∈ + ((TypedOracleCompiler.Sampling.execute table program).2.map Sigma.fst)) : + ∃ events, PCSBCSFirstRootDisclosure.firstMention addresses ref program table = some events ∧ + PCSBCSSourceCallerSnapshot.capturedRegistry addresses program current (fun key => table key.val) ref = + some (freeze (PCSBCSSourceRootCapture.ordinaryPrefix events) ref.root ref.shape) := by + obtain ⟨f,captured⟩ := PCSBCSSourceRootCapture.capture_exists addresses ref + (.inl current) mentioned program table visited + obtain ⟨events,first,frozen,_⟩ := PCSBCSSourceRootCapture.capture_provenance + addresses ref program table f captured + refine ⟨events,first,?_⟩ + rw [PCSBCSSourceCallerSnapshot.capturedRegistry_enabled addresses program current table ref mentioned, + captured,frozen] + +/-- Local native-model input contract. No constructor takes canonicalReply +compatibility or a constructed accessor. Capture storage must be the literal +freeze of the identified ordinary primitive prefix. Source admission, scalar +projection, and chronological message index are supplied separately. -/ +inductive NativeEvidence {c : Config} (current : Coordinate c) + (saved : AnchoredHeaderCodec.Record) (registry : Captures) (messages : List Pending) + (past : WHIRFiatShamir.Prefix current) (m : Pending) (digest : Digest32) + (C : DuplexModeGame.PrimitiveOracle) : + Coordinate c → Reply → Prop where + | initial (a : Message E) : NativeEvidence current saved registry messages past m digest C .initial (.initial a) + | ood (i : Fin c.folds.size) (j : Fin (oodCount c i.val)) (a : OodClaim) : + NativeEvidence current saved registry messages past m digest C (.ood i j) (.ood a) + | tail (j : Fin (c.logN-c.folds.toList.sum)) (a : Message E) : + NativeEvidence current saved registry messages past m digest C (.tail j) (.tail a) + | middle (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) (a : Message E) + (notLast : j.val+1 ≠ c.folds[i.val]!) : + NativeEvidence current saved registry messages past m digest C (.fold i j) (.fold a none #[]) + | terminal (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) (a : Message E) (residual : Array E) + (last : j.val+1 = c.folds[i.val]!) (terminal : ¬ i.val+1 < c.folds.size) + (width : residual.size = 2^remaining c i.val) : + NativeEvidence current saved registry messages past m digest C (.fold i j) (.fold a none residual) + | next (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) (a : Message E) (native : Oracle) + (last : j.val+1 = c.folds[i.val]!) (later : i.val+1 < c.folds.size) + (ref : Reference) (log : PublicLog) + (reference : parsePhase c (.fold i j) m (i.val+1) 2 = some ref) + (captured : registry ref = some (freeze log ref.root ref.shape)) + (fits : ref.shape.occupied ≤ ref.shape.leafWords) + (auth : AuthenticLog C log) (clean : ¬ OutputCollision log) + (projection : extensionOracle (WHIRPhysicalRows.compactBaseOracle (hash C) + ⟨recordDomain (records log),[]⟩ ref.root ref.shape.height (2^ref.shape.height) + ref.shape.leafWords ref.shape.occupied) = some native) : + NativeEvidence current saved registry messages past m digest C (.fold i j) (.fold a (some native) #[]) + | query (i : Fin c.folds.size) (a : Message E) (native : Oracle) + (earlier : position (.query i : Coordinate c) < position current) + (ref : Reference) (log : PublicLog) + (reference : phaseReference c saved + (messages.reverse.take (position (.query i : Coordinate c)+1)).reverse i.val = some ref) + (captured : registry ref = some (freeze log ref.root ref.shape)) + (fits : ref.shape.occupied ≤ ref.shape.leafWords) + (codec : i.val = 0 ∨ ref.shape.occupied % 3 = 0) + (qs : Array Nat) + (derived : deriveQueries (remaining c i.val+c.rates[i.val]!) c.queries[i.val]! + (Array.ofFn (past (.query i) earlier).1) = some qs) + (numLeaves : Nat) (proof : PrunedMerklePaths) (output : List RawPath) + (height : ref.shape.height = numLeaves.log2) (auth : AuthenticLog C log) + (accepted : PCSBCSMerkleFullSourceTransport.openSource (hash C) proof ref.root + numLeaves qs.toList ref.shape.leafWords ref.shape.occupied = some output) + (bounds : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (hashing (hash C)), bytes.length < 2^64) + (quiet : ¬ PublicMerkleBinding.OpenPrimitiveBad C log ref.root output) + (projection : List.Forall₂ (fun path row => + rowCodec i.val (path.leafData.drop (ref.shape.leafWords-ref.shape.occupied)).toArray = some row) + output native.toList) : + NativeEvidence current saved registry messages past m digest C (.query i) (.query native a) + +/-- Compatibility is a conclusion of accepted opening/full-table transport and +the native normal-form contract, never an acceptance-to-compatibility premise. -/ +theorem native_compatible {c : Config} {C : DuplexModeGame.PrimitiveOracle} (current q : Coordinate c) + (saved : AnchoredHeaderCodec.Record) (registry : Captures) (messages : List Pending) + (past : WHIRFiatShamir.Prefix current) (m : Pending) (digest : Digest32) (native : Reply) + (earlier : position q < position current) + (evidence : NativeEvidence current saved registry messages past m digest C q native) : + ∃ access, build current saved registry messages past q m = some access ∧ + canonicalReply q digest ((oracles access).next q) ((oracles access).rows q) native = some native := by + cases evidence with + | initial a => + refine ⟨{},?_,rfl⟩ + simp only [build,dite_eq_left earlier] + | ood i j a => exact ⟨{},by simp [build,earlier],rfl⟩ + | tail j a => exact ⟨{},by simp [build,earlier],rfl⟩ + | middle i j a notLast => + have notLast' : j.val+1 ≠ c.folds[i.val] := by simpa using notLast + exact ⟨{},by simp [build,earlier,notLast'],by simp [canonicalReply,notLast']⟩ + | terminal i j a residual last terminal width => + exact ⟨{},by simp [build,earlier,last,terminal],by simp [canonicalReply,last,terminal,width]⟩ + | next i j a native last later ref log reference captured fits auth clean projection => + have raw := (next_image_provenance C log ref auth clean).2 + have decoded : frozenOracle (i.val+1) (freeze log ref.root ref.shape) = some native := by + simp only [frozenOracle,Nat.add_eq_zero_iff,Nat.one_ne_zero,and_false,↓reduceIte] + rw [raw] + exact projection + refine ⟨⟨#[],native,#[],#[],(freeze log ref.root ref.shape).cells.map status⟩,?_,?_⟩ + · exact build_fold_next current saved registry messages past i j m earlier last later ref _ + native reference (PCSBCSSourceFrozenAccessorStructural.lookup_freeze registry log ref fits captured) decoded + · simp [canonicalReply,last,later,oracles] + | query i a native queryEarlier ref log reference captured fits codec qs derived + numLeaves proof output height auth accepted bounds quiet projection => + obtain ⟨oracle,decoded,_⟩ := PCSBCSSourceFrozenAccessorStructural.frozenOracle_freeze + log ref.root ref.shape fits i.val codec + have transport := accepted_rows C log ref numLeaves qs.toList proof output height auth accepted bounds quiet + obtain ⟨selected,hs,rows,_,_⟩ := select_accepted i.val (freeze log ref.root ref.shape) qs + output ref.shape.leafWords ref.shape.occupied native oracle decoded + (PCSBCSSourceFrozenAccessorStructural.freeze_shape_exact log ref.root ref.shape fits).2.1 + transport projection + refine ⟨⟨selected.rows,#[],qs,selected.cells.map status,#[]⟩,?_,?_⟩ + · exact build_query current saved registry messages past i m queryEarlier ref _ qs selected + reference (PCSBCSSourceFrozenAccessorStructural.lookup_freeze registry log ref fits captured) derived hs + · simp [canonicalReply,oracles,rows] + +/-- Exact chronological inverse of the actual native earlier reply. -/ +theorem inverseAt_native {c : Config} {C : DuplexModeGame.PrimitiveOracle} (current : Coordinate c) + (saved : AnchoredHeaderCodec.Record) (registry : Captures) (messages : List Pending) + (past : WHIRFiatShamir.Prefix current) (n : Nat) (q : Coordinate c) + (m : Pending) (digest : Digest32) (native : Reply) + (coordinate : (schedule c)[n]? = some q) (message : messages.reverse[n+1]? = some m) + (earlier : position q < position current) + (scalars : replyScalars q digest native = some m.scalars) + (evidence : NativeEvidence current saved registry messages past m digest C q native) : + PCSBCSSourceFrozenAccessor.inverseAt current saved registry messages past n = some ⟨native,m.nonce⟩ := by + obtain ⟨access,built,compatible⟩ := native_compatible current q saved registry messages past + m digest native earlier evidence + rw [inverseAt_integration current saved registry messages past n q m access coordinate message built] + have roundtrip := scalar_roundtrip (oracles access) q digest native m.nonce + rw [scalars,Option.bind_some,compatible] at roundtrip + exact roundtrip + +open TypedOracleCompiler PCSStateRestoration.Latent +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Literal ordinary records before the first mention. The empty default does +not grant authentication: accepted transport still requires AuthenticLog and +absence of OpenPrimitiveBad, and the production address gate proves existence. -/ +noncomputable def sourceLog {R : Type} {n : Nat} (addresses : Keys → List Reference) + (ref : Reference) (program : Sampling Keys Answers R n) (table : Table Keys Answers) : PublicLog := + PCSBCSSourceRootCapture.ordinaryPrefix + ((PCSBCSFirstRootDisclosure.firstMention addresses ref program table).getD []) + +/-- A fixed source projection, not a supplied oracle. Only mentioned roles are +used; their actual captures are proved equal to this literal first-mention view. -/ +noncomputable def sourceRegistry {R : Type} {n : Nat} (addresses : Keys → List Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : Captures := + fun ref => some (freeze (sourceLog addresses ref program table) ref.root ref.shape) + +/-- The log field in source evidence cannot choose a different primitive prefix: +the frozen record retains the actual prefix, not just its extracted table. -/ +theorem sourceRegistry_log_exact {R : Type} {n : Nat} (addresses : Keys → List Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) (ref : Reference) + (log : PublicLog) + (projected : sourceRegistry addresses program table ref = some (freeze log ref.root ref.shape)) : + log = sourceLog addresses ref program table := by + have same := Option.some.inj projected + exact (congrArg Frozen.queryPrefix same).symm + +/-- Native source evidence fixes logs/tables by actual program execution. +The NativeEvidence capture field now concerns the computed source projection; +the actual capturedRegistry success is a theorem, not an input. -/ +abbrev SourceEvidence {R : Type} {n : Nat} {c : Config} (addresses : Keys → List Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (C : DuplexModeGame.PrimitiveOracle) + (current : Coordinate c) (saved : AnchoredHeaderCodec.Record) (messages : List Pending) + (past : WHIRFiatShamir.Prefix current) (m : Pending) (digest : Digest32) + (q : Coordinate c) (native : Reply) : Prop := + NativeEvidence current saved (sourceRegistry addresses program table) messages past m digest C q native + +theorem source_registry_enabled {R : Type} {n : Nat} (addresses : Keys → List Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) (ref : Reference) + (mentioned : ref ∈ addresses (.inl current)) + (visited : (.inl current : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst)) : + PCSBCSSourceCallerSnapshot.capturedRegistry addresses program current (fun key => table key.val) ref = + sourceRegistry addresses program table ref := by + obtain ⟨events,first,captured⟩ := captured_freeze_provenance addresses program table current ref mentioned visited + simpa only [sourceRegistry,sourceLog,first,Option.getD_some] using captured + +/-- Every needed role is obtained from the literal current packet's admitted +root-address list, including the next root announced by this exact message. -/ +theorem source_nativeEvidence {R : Type} {count : Nat} (addresses : Keys → List Reference) + (program : Sampling Keys Answers R count) (table : Table Keys Answers) + (C : DuplexModeGame.PrimitiveOracle) + (current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (saved : AnchoredHeaderCodec.Record) (past : WHIRFiatShamir.Prefix current.2.coord) + (n : Nat) (q : Coordinate (ParameterBounds.config p)) (m : Pending) (digest : Digest32) + (native : Reply) (coordinate : (schedule (ParameterBounds.config p))[n]? = some q) + (message : current.2.messages.reverse[n+1]? = some m) + (addressRoles : addresses (.inl current) = + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) current.2.messages) + (visited : (.inl current : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst)) + (evidence : SourceEvidence addresses program table C current.2.coord saved current.2.messages + past m digest q native) : + NativeEvidence current.2.coord saved + (PCSBCSSourceCallerSnapshot.capturedRegistry addresses program current (fun key => table key.val)) + current.2.messages past m digest C q native := by + cases evidence with + | initial a => exact .initial a + | ood i j a => exact .ood i j a + | tail j a => exact .tail j a + | middle i j a notLast => exact .middle i j a notLast + | terminal i j a residual last terminal width => exact .terminal i j a residual last terminal width + | next i j a native last later ref log reference captured fits auth clean projection => + have member := PCSBCSCapturedSourceTransport.foldReference_member (ParameterBounds.config p) + current.2.messages n i j m ref coordinate message reference + have mentioned : ref ∈ addresses (.inl current) := by + rw [addressRoles] + exact List.mem_cons_of_mem _ member + have actual := (source_registry_enabled addresses program table current ref mentioned visited).trans captured + exact .next i j a native last later ref log reference actual fits auth clean projection + | query i a native earlier ref log reference captured fits codec qs derived + numLeaves proof output height auth accepted bounds quiet projection => + have member := PCSBCSCapturedSourceTransport.phaseReference_member (ParameterBounds.config p) + saved current.2.messages i.val (position (.query i : Coordinate (ParameterBounds.config p))+1) ref reference + have mentioned : ref ∈ addresses (.inl current) := by rw [addressRoles]; exact member + have actual := (source_registry_enabled addresses program table current ref mentioned visited).trans captured + exact .query i a native earlier ref log reference actual fits codec qs derived numLeaves proof + output height auth accepted bounds quiet projection + +/-- Production captured-registry native inverse. Neither capture availability +nor semantic compatibility is a free premise; visited address membership and +first-mention source provenance supply the former, accepted transport the latter. -/ +theorem inverseAt_source_native {R : Type} {count : Nat} (addresses : Keys → List Reference) + (program : Sampling Keys Answers R count) (table : Table Keys Answers) + (C : DuplexModeGame.PrimitiveOracle) + (current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (saved : AnchoredHeaderCodec.Record) (past : WHIRFiatShamir.Prefix current.2.coord) + (n : Nat) (q : Coordinate (ParameterBounds.config p)) (m : Pending) (digest : Digest32) + (native : Reply) (coordinate : (schedule (ParameterBounds.config p))[n]? = some q) + (message : current.2.messages.reverse[n+1]? = some m) + (earlier : position q < position current.2.coord) + (scalars : replyScalars q digest native = some m.scalars) + (addressRoles : addresses (.inl current) = + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) current.2.messages) + (visited : (.inl current : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst)) + (evidence : SourceEvidence addresses program table C current.2.coord saved current.2.messages + past m digest q native) : + PCSBCSSourceFrozenAccessor.inverseAt current.2.coord saved + (PCSBCSSourceCallerSnapshot.capturedRegistry addresses program current (fun key => table key.val)) + current.2.messages past n = some ⟨native,m.nonce⟩ := by + exact inverseAt_native current.2.coord saved _ current.2.messages past n q m digest native + coordinate message earlier scalars + (source_nativeEvidence addresses program table C current saved past n q m digest native + coordinate message addressRoles visited evidence) + +#print axioms source_registry_enabled +#print axioms sourceRegistry_log_exact +#print axioms source_nativeEvidence +#print axioms inverseAt_source_native + +#print axioms accepted_rows +#print axioms select_accepted +#print axioms next_image_provenance +#print axioms accepted_full_table +#print axioms captured_freeze_provenance +#print axioms native_compatible +#print axioms inverseAt_native + +end Whir.PCSBCSCapturedNativeReplyBridge diff --git a/verification/whir/Whir/PCSBCSCapturedNativeReplyBridgeSmoke.lean b/verification/whir/Whir/PCSBCSCapturedNativeReplyBridgeSmoke.lean new file mode 100644 index 000000000..847e6d09a --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedNativeReplyBridgeSmoke.lean @@ -0,0 +1,182 @@ +import Whir.PCSBCSCapturedNativeReplyBridge + +/-! Real BLAKE2s full padded source opening, native codec projection and exact +chronological captured inverse. These finite executions exercise the native +formal-model transport path, not a universal Rust/Aeneas refinement. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCapturedNativeReplyBridgeSmoke +open Concrete Protocol CausalGame CausalProbability WHIRHistory FiatShamirGame +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache PCSBCSMerkleLeafImages +open PCSBCSSourceFrozenAccessor PCSBCSCapturedNativeReplyBridge +open MerkleTransport PublicMerkleLog DuplexModeGame +open AnchoredHeaderCodec + +private def toy : Config := ⟨3,#[1,1],#[1,1],#[3,3],#[0,0]⟩ +private def digest (n : Nat) : Digest32 := fun i => ⟨(n / 256^i.val)%256,Nat.mod_lt _ (by decide)⟩ +private def recordedTree (extension : Bool) (missing : Option Nat) : + Nat → Nat → Digest32 × DuplexPublicSimulator.PublicLog + | 0,start => + let words : List K := if extension then [UInt64.ofNat (100+start),200,300,400,500,600] + else [0,UInt64.ofNat (10+start)] + let bytes := ByteCodec.wordsBytes words + (hashBlake2s bytes,if missing == some start then [] else plan blake2sOracle bytes) + | height+1,start => + let l := recordedTree extension missing height start + let r := recordedTree extension missing height (start+2^height) + let bytes := List.ofFn (ByteCodec.pairBytes (l.1,r.1)) + (hashBlake2s bytes,l.2 ++ r.2 ++ plan blake2sOracle bytes) + +private def firstTree := recordedTree false none 3 0 +private def nextTree := recordedTree true none 2 0 +private def saved : Record := + ⟨⟨3,1,1,1⟩,firstTree.1,⟨digest 0,fun _ => none,0,true,0,0⟩,[0,0,0],0⟩ +private def firstRef : Reference := ⟨saved.root,initialShape saved.shape⟩ +private def nextRef : Reference := ⟨nextTree.1,phaseShape toy 1⟩ +private def rootFrozen : Frozen := freeze firstTree.2 firstRef.root firstRef.shape +private def nextFrozen : Frozen := freeze nextTree.2 nextRef.root nextRef.shape +private def registry : Captures := fun ref => + if ref = firstRef then some rootFrozen else if ref = nextRef then some nextFrozen else none +private def query : Coordinate toy := .query ⟨0,by decide⟩ +private def boundary : Coordinate toy := .fold ⟨0,by decide⟩ ⟨0,by decide⟩ +private def current : Coordinate toy := .query ⟨1,by decide⟩ +private def tape : Tape toy := + (coordinates toy).symm fun q => match q with + | .query _ => (fun _ => (⟨219,20,21⟩ : E),0) + | _ => 0 +private def past : WHIRFiatShamir.Prefix current := WHIRFiatShamir.Prefix.ofTape current tape +private def fields (q : Coordinate toy) : List E := + match q with + | .fold i j => [0,0] ++ if j.val+1 = toy.folds[i.val]! then + if i.val+1 < toy.folds.size then rootScalars nextRef.root + else List.replicate (2^remaining toy i.val) 0 + else [] + | .ood _ _ => [0,0,0] + | _ => [0,0] +private def messages : List Pending := + ((List.range (position current+1)).map fun n => + (⟨if n = 0 then [] else fields (((schedule toy)[n-1]?).getD .initial), + match ((schedule toy)[n]?).getD .initial with + | .query _ => some (0,0) + | _ => none⟩ : Pending)).reverse + +private def require (label : String) (ok : Bool) : IO Unit := do + unless ok do throw (IO.userError s!"native reply bridge: {label}") + IO.println s!"native reply bridge PASS: {label}" + +private def queryProof : PrunedMerklePaths := + ⟨[[0,13],[0,17]],[(recordedTree false none 0 2).1,(recordedTree false none 0 6).1, + (recordedTree false none 1 0).1,(recordedTree false none 1 4).1]⟩ + +private def extensionProof : PrunedMerklePaths := + ⟨[[101,200,300,400,500,600],[102,200,300,400,500,600]], + [(recordedTree true none 0 0).1,(recordedTree true none 0 3).1]⟩ + +private def openingRows (phase leafWords occupied : Nat) (paths : List RawPath) : Option Oracle := + (paths.mapM (fun path => rowCodec phase (path.leafData.drop (leafWords-occupied)).toArray)).map List.toArray + +private def paddedTree (bad : Nat) : Nat → Nat → Digest32 × DuplexPublicSimulator.PublicLog + | 0,start => + let words : List K := [if start = bad then 9 else 0,UInt64.ofNat (10+start)] + let bytes := ByteCodec.wordsBytes words + (hashBlake2s bytes,plan blake2sOracle bytes) + | h+1,start => + let l := paddedTree bad h start + let r := paddedTree bad h (start+2^h) + let bytes := List.ofFn (ByteCodec.pairBytes (l.1,r.1)) + (hashBlake2s bytes,l.2 ++ r.2 ++ plan blake2sOracle bytes) + +private def requireQuery (saved' : AnchoredHeaderCodec.Record) (registry' : Captures) + (native : Oracle) : IO Unit := do + match inverseAt current saved' registry' messages past (position query) with + | none => throw (IO.userError "native chronological query inverse rejected") + | some inverted => match inverted.reply with + | .query rows m => + require "accepted native query equals captured inverse including duplicates and nonce" + (rows == native && m.u0 == 0 && m.u2 == 0 && + inverted.nonce == (messages.reverse[position query+1]?).bind Pending.nonce) + | _ => throw (IO.userError "native chronological query inverse wrong tag") + +def smoke : IO Unit := do + let qs := [3,7,3] + let opened ← match PCSBCSMerkleFullSourceTransport.openSource hashBlake2s queryProof + firstRef.root 8 qs 2 1 with + | some paths => pure paths + | none => throw (IO.userError "actual padded base source opening rejected") + let native ← match openingRows 0 2 1 opened with + | some rows => pure rows + | none => throw (IO.userError "actual accepted base suffix codec rejected") + require "full padded opening preserves derived repeated order" + (opened.map RawPath.leafIndex == qs && native == #[#[E.ofK 13],#[E.ofK 17],#[E.ofK 13]]) + requireQuery saved registry native + require "wrong root rejects actual BLAKE2s opening" + (PCSBCSMerkleFullSourceTransport.openSource hashBlake2s queryProof (digest 99) 8 qs 2 1).isNone + require "missing source proof row rejects rather than zero authenticating" + (PCSBCSMerkleFullSourceTransport.openSource hashBlake2s + ⟨[[0,13]],queryProof.siblingHashes⟩ firstRef.root 8 qs 2 1).isNone + require "missing first capture rejects chronological inverse" + (inverseAt current saved (fun _ => none) messages past (position query)).isNone + let incomplete := recordedTree false (some 3) 3 0 + let ghost := freeze incomplete.2 firstRef.root firstRef.shape + let ghostAccess ← match build current saved + (fun ref => if ref = firstRef then some ghost else registry ref) messages past query ⟨[0,0],none⟩ with + | some a => pure a + | none => throw (IO.userError "ghost source storage selection rejected") + require "unavailable repeated ghost cells cannot match accepted native rows or authenticate" + (ghostAccess.rows != native && ghostAccess.selectedStatus[0]! == ⟨false,false⟩ && + ghostAccess.selectedStatus[2]! == ⟨false,false⟩) + let bad := paddedTree 3 3 0 + let badSaved := {saved with root := bad.1} + let badRef : Reference := ⟨bad.1,firstRef.shape⟩ + let badFrozen := freeze bad.2 bad.1 badRef.shape + let badProof : PrunedMerklePaths := ⟨[[9,13],[0,17]],queryProof.siblingHashes⟩ + require "real nonzero padding hashes to its own root but source opening rejects" + ((badProof.open hashBlake2s bad.1 8 qs 2 2).isSome && + (PCSBCSMerkleFullSourceTransport.openSource hashBlake2s badProof bad.1 8 qs 2 1).isNone) + require "available bad padding rejects actual captured chronological inverse" + (inverseAt current badSaved (fun ref => if ref = badRef then some badFrozen else registry ref) + messages past (position query)).isNone + let tail : Coordinate toy := .tail ⟨0,by decide⟩ + let tailPast := WHIRFiatShamir.Prefix.ofTape tail tape + let tailMessages := (⟨[0,0],none⟩ : Pending) :: messages + let extensionOpened ← match PCSBCSMerkleFullSourceTransport.openSource hashBlake2s + extensionProof nextRef.root 4 [1,2,1] 6 6 with + | some paths => pure paths + | none => throw (IO.userError "actual extension source opening rejected") + let extensionNative ← match openingRows 1 6 6 extensionOpened with + | some rows => pure rows + | none => throw (IO.userError "actual extension native codec rejected") + match inverseAt tail saved registry tailMessages tailPast (position current) with + | some inverted => match inverted.reply with + | .query rows _ => + require "extension accepted reply transports exact consecutive triples and duplicates" + (rows == extensionNative && rows.size == 3 && rows[0]! == rows[2]!) + | _ => throw (IO.userError "extension query tag mismatch") + | none => throw (IO.userError "extension captured query inverse rejected") + let fullNext : PrunedMerklePaths := ⟨(List.range 4).map (fun n => + [UInt64.ofNat (100+n),200,300,400,500,600]),[]⟩ + let fullOpened ← match PCSBCSMerkleFullSourceTransport.openSource hashBlake2s fullNext + nextRef.root 4 [0,1,2,3] 6 6 with + | some paths => pure paths + | none => throw (IO.userError "full next source table opening rejected") + let fullNative ← match openingRows 1 6 6 fullOpened with + | some rows => pure rows + | none => throw (IO.userError "full next source table codec rejected") + match inverseAt current saved registry messages past (position boundary) with + | some inverted => match inverted.reply with + | .fold _ (some next) residual => + require "nonterminal fold transports full next table rather than query subset" + (next == fullNative && next.size == 4 && residual.isEmpty && nextFrozen.cells.all (·.available)) + | _ => throw (IO.userError "nonterminal fold tag mismatch") + | none => throw (IO.userError "nonterminal captured inverse rejected") + require "missing next capture rejects nonterminal fold" + (inverseAt current saved (fun ref => if ref = firstRef then some rootFrozen else none) + messages past (position boundary)).isNone + require "wrong/missing full next opening rejects" + ((PCSBCSMerkleFullSourceTransport.openSource hashBlake2s fullNext (digest 88) 4 [0,1,2,3] 6 6).isNone && + (PCSBCSMerkleFullSourceTransport.openSource hashBlake2s ⟨fullNext.leafData.drop 1,[]⟩ + nextRef.root 4 [0,1,2,3] 6 6).isNone) + require "malformed extension suffix does not drop limbs" (rowCodec 1 #[1,2]).isNone + +end Whir.PCSBCSCapturedNativeReplyBridgeSmoke + +def main : IO Unit := Whir.PCSBCSCapturedNativeReplyBridgeSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSCapturedSourceAcceptance.lean b/verification/whir/Whir/PCSBCSCapturedSourceAcceptance.lean new file mode 100644 index 000000000..3e97f2e74 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedSourceAcceptance.lean @@ -0,0 +1,276 @@ +import Whir.PCSBCSCapturedSourceStatePath +import Whir.PCSBCSCapturedNativeReplyBridge + +/-! Accepting PCS-only source adapter. Root0 is the full-table projection of +actual ordinary records preceding its first literal address mention, NOT an +independent hidden oracle string. SourceEvidence exposes exact native tag, +shape, phase-codec and primitive/opening transport conditions. This theorem is +not universal Rust refinement, and does not assume semantic equivalence or a +Fiat-Shamir probability certificate. The probabilistic obligations remain the +finite first-disclosure n*rbrError term (physical indexed compilation n=Q), the +separate existing Merkle primitive bad events, and compression/construction coupling. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 100000 +namespace Whir.PCSBCSCapturedSourceAcceptance +open Concrete Protocol CausalGame CausalProbability FiatShamirGame WHIRHistory +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSMerkleRootCache +open PCSBCSSourceCallerSnapshot PCSBCSSourceReplyInversion +open PCSBCSCallerBinding PCSBCSRestorationHazard PCSRoundByRoundTranscriptState +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent +open PCSBCSCapturedSourceStatePath PCSBCSCapturedSourceTransport PCSBCSCapturedNativeReplyBridge +open PublicMerkleLog +open MerkleTransport.Commitments + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Literal public-input binding only, not truth of the claims. The fixed +original input is kept independent of every whole packet answer. -/ +def BoundOriginal (original : CallerInput p) (saved : AnchoredHeaderCodec.Record) + (claims : AnchoredSourceCaller.Claims) : Prop := + claims.record = saved ∧ claims.caller.root = saved.root ∧ + original.lanes = saved.shape.lanes ∧ List.ofFn original.family = claims.caller.families ∧ + original.points = claims.caller.points ∧ original.anchorPoint = saved.point.toArray ∧ + original.anchorValue = saved.value + + +/-- The native full-table projection preserves unavailable ghost defaults. Only +accepted opened rows obtain authenticity; full rectangularity alone does not. -/ +noncomputable def sourceRoot {R : Type} {n : Nat} + (C : DuplexModeGame.PrimitiveOracle) (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : BaseOracle := + WHIRPhysicalRows.compactBaseOracle (hash C) + ⟨recordDomain (records (sourceLog addresses ref program table)),[]⟩ + ref.root ref.shape.height (2^ref.shape.height) ref.shape.leafWords ref.shape.occupied + +/-- Exactly the replies of the native PCS-only source machine on its projected +Root0 input and independently bound original caller. -/ +def nativeReplies (original : CallerInput p) (root : BaseOracle) + (strategy : RingPCSGame.Prefix → Strategy) (ring : RingPCSGame.Prefix) + (t : Tape (ParameterBounds.config p)) : Array Reply := + PCSRoundByRoundTranscriptState.replies + (ExecutionShapes.Input p original.lanes root + (OriginalClaimsChecker.input original.prepared root ring).claims) (strategy ring) t + +theorem captured_sourceRoot {R : Type} {n : Nat} + (C : DuplexModeGame.PrimitiveOracle) (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) (f : Frozen) + (captured : PCSBCSSourceRootCapture.capture addresses ref program table = some f) + (auth : AuthenticLog C (sourceLog addresses ref program table)) + (clean : ¬ OutputCollision (sourceLog addresses ref program table)) : + f.raw = sourceRoot C addresses ref program table := by + obtain ⟨events,found,frozen,_⟩ := PCSBCSSourceRootCapture.capture_provenance + addresses ref program table f captured + have log : sourceLog addresses ref program table = PCSBCSSourceRootCapture.ordinaryPrefix events := by + simp only [sourceLog,found,Option.getD_some] + rw [frozen] + unfold sourceRoot + rw [log] + exact (next_image_provenance C _ ref (log ▸ auth) (log ▸ clean)).2 + +open Classical in +/-- The actual native initial projection ignores every bit of the selected +whole packet, not only its consumed challenge bytes. -/ +theorem sourceRoot_current_independent {R : Type} {n : Nat} + (C : DuplexModeGame.PrimitiveOracle) (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (mentioned : ref ∈ addresses (.inl current)) + (full : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth current.2.coord)) → Digest32) : + sourceRoot C addresses ref program (Function.update table (.inl current) full) = + sourceRoot C addresses ref program table := by + have same : sourceLog addresses ref program (Function.update table (.inl current) full) = + sourceLog addresses ref program table := by + unfold sourceLog + rw [PCSBCSFirstRootDisclosure.first_mention_answer_independent + addresses (.inl current) ref mentioned program table full] + unfold sourceRoot + rw [same] + +/-- Native source parser evidence at the actual chronological positions. These +are primitive/shape/source-codec hypotheses, never constructed accessor, +canonical reply, or whole-prefix completeness hypotheses. -/ +def ReplyTransport {R : Type} {n : Nat} + (addresses : Keys → List Reference) (program : Sampling Keys Answers R n) + (table : Table Keys Answers) (C : DuplexModeGame.PrimitiveOracle) (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (native : Array Reply) : Prop := + ∀ j, j < position current.2.coord → + ∃ q m digest, + (schedule (ParameterBounds.config p))[j]? = some q ∧ + current.2.messages.reverse[j+1]? = some m ∧ + replyScalars q digest native[j]! = some m.scalars ∧ + SourceEvidence addresses program table C current.2.coord saved current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) m digest q native[j]! + +/-- Every scheduled next-root scalar role is admitted by the actual source +reply transport. There is no separate root-parser completeness premise. -/ +theorem roles_from_transport {R : Type} {count : Nat} + (addresses : Keys → List Reference) (program : Sampling Keys Answers R count) + (table : Table Keys Answers) (C : DuplexModeGame.PrimitiveOracle) + (saved : AnchoredHeaderCodec.Record) (current : EnteredPacket p Q iv boundary) + (native : Array Reply) (transport : ReplyTransport addresses program table C saved current native) : + phaseRolesAdmitted (ParameterBounds.config p) current.2.messages = true := by + unfold phaseRolesAdmitted + rw [List.all_eq_true] + rintro ⟨m,n⟩ member + dsimp only + by_cases initial : n = 0 + · simp only [initial,↓reduceIte] + · simp only [initial,↓reduceIte] + have indexed := List.mk_mem_zipIdx_iff_getElem?.mp member + have inside : n < current.2.messages.length := by + have size := (List.getElem?_eq_some_iff.mp indexed).1 + simpa only [List.length_reverse] using size + have positionEq := current.2.2.position_eq + have earlier : n-1 < position current.2.coord := by + change current.2.messages.length-1 = position current.2.coord at positionEq + omega + obtain ⟨q,message,digest,coordinate,atMessage,_,evidence⟩ := transport (n-1) earlier + have previous : n-1+1 = n := by omega + rw [previous] at atMessage + have same : message = m := Option.some.inj (atMessage.symm.trans indexed) + subst message + rw [coordinate] + simp only [Option.getD_some] + generalize replySame : native[n-1]! = reply at evidence + cases evidence with + | initial a => rfl + | ood i j a => rfl + | tail j a => rfl + | middle i j a notLast => + have guard : ¬ (j.val+1 = (ParameterBounds.config p).folds[i.val]! ∧ + i.val+1 < (ParameterBounds.config p).folds.size) := fun h => notLast h.1 + simp only [guard,↓reduceIte] + | terminal i j a residual last terminal width => simp [terminal] + | next i j a native last later ref log reference captured fits auth clean projection => + simp [last,later,reference] + | query i a native earlier ref log reference captured fits codec qs derived + numLeaves proof output height auth accepted bounds quiet projection => rfl + +theorem schedule_coordinate_position {c : Config} (n : Nat) (q : Coordinate c) + (coordinate : (schedule c)[n]? = some q) : position q = n := by + obtain ⟨inside,stored⟩ := List.getElem?_eq_some_iff.mp coordinate + rw [← stored] + exact position_schedule_get c ⟨n,inside⟩ + +theorem source_inverse {R : Type} {n : Nat} + (addresses : Keys → List Reference) (program : Sampling Keys Answers R n) + (table : Table Keys Answers) (C : DuplexModeGame.PrimitiveOracle) (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (native : Array Reply) + (addressRoles : addresses (.inl current) = + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) current.2.messages) + (visited : (.inl current : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst)) + (transport : ReplyTransport addresses program table C saved current native) + (j : Nat) (earlier : j < position current.2.coord) : + (PCSBCSSourceFrozenAccessor.inverseAt current.2.coord saved + (capturedRegistry addresses program current (fun key => table key.val)) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) j).map Inverted.reply = some native[j]! := by + obtain ⟨q,m,digest,coordinate,message,scalars,evidence⟩ := transport j earlier + have prior : position q < position current.2.coord := by + rw [schedule_coordinate_position j q coordinate] + exact earlier + rw [inverseAt_source_native addresses program table C current saved + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) j q m digest + native[j]! coordinate message prior scalars addressRoles visited evidence] + rfl + +/-- Complete deterministic adapter: public byte-only root addresses, actual +visited literal source prefixes and capture, independently bound caller, exact +native earlier replies, derived adjacent identities, initial false, and accepted +extraction-failure terminal true construct the latent restoration StatePath. +No unqueried-entry caller coverage, path link, or inverse success is assumed. -/ +theorem accepted_failure_statePath {R : Type} {n : Nat} + (C : DuplexModeGame.PrimitiveOracle) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (answers : FiatShamirGame.Coordinate → Digest32) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (final : EnteredPacket p Q iv boundary) (original : CallerInput p) + (claims : AnchoredSourceCaller.Claims) + (valid : saved.Valid) (profile : profileShape p saved.shape) + (caller : AnchoredSourceFreshCaller.decode layout saved final.1.val answers = some claims) + (bound : BoundOriginal original saved claims) + (terminal : final.2.coord = lastCoordinate (ParameterBounds.config p)) + (recorded : ∀ current ∈ packets final, + (⟨.inl current,table (.inl current)⟩ : Sigma Answers) ∈ (Sampling.execute table program).2) + (auth : AuthenticLog C (sourceLog address + ⟨saved.root,initialShape saved.shape⟩ program table)) + (clean : ¬ OutputCollision (sourceLog address + ⟨saved.root,initialShape saved.shape⟩ program table)) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) + (strategy : RingPCSGame.Prefix → Strategy) + (raws : ∀ current ∈ packets final, + grouped current.2.coord (table (.inl current)) = literalRaw ring t current.2.coord) + (transport : ∀ current ∈ packets final, + ReplyTransport address program table C saved current + (nativeReplies original + (sourceRoot C address ⟨saved.root,initialShape saved.shape⟩ program table) + strategy ring t)) + (accepted : experiment (OriginalClaimsChecker.input original.prepared + (sourceRoot C address ⟨saved.root,initialShape saved.shape⟩ program table) ring) + (strategy ring) t = true) + (failure : ¬ ∃ w, + PCSRoundByRoundKnowledge.extract p original.lanes original.family original.points original.anchorPoint + original.anchorValue (sourceRoot C address ⟨saved.root,initialShape saved.shape⟩ program table) = some w ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) original.lanes + (sourceRoot C address ⟨saved.root,initialShape saved.shape⟩ program table) + original.family original.points original.anchorPoint original.anchorValue w) : + BoundOriginal original saved claims ∧ + (∀ current ∈ packets final, ∃ data, + fromCapture address ⟨saved.root,initialShape saved.shape⟩ program + original saved current (fun key => table key.val) = some data ∧ data.original = original ∧ + data.observed.root = + sourceRoot C address ⟨saved.root,initialShape saved.shape⟩ program table ∧ + data.observed.trace = incomingTrace ring t + (nativeReplies original + (sourceRoot C address ⟨saved.root,initialShape saved.shape⟩ program table) + strategy ring t) current.2.coord) ∧ + StatePath (Restoration.model p Q iv boundary + (builder address ⟨saved.root,initialShape saved.shape⟩ program original saved)) + table (Sampling.execute table program).2 false true := by + have addressRoles (current : EnteredPacket p Q iv boundary) (member : current ∈ packets final) : + address (.inl current) = + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) current.2.messages := + address_packet layout saved answers current valid profile claims + (by rw [packets_entry final current member]; exact caller) + (roles_from_transport _ _ _ C _ current _ (transport current member)) + have mentions (current : EnteredPacket p Q iv boundary) (member : current ∈ packets final) : + (⟨saved.root,initialShape saved.shape⟩ : Reference) ∈ address (.inl current) := by + rw [addressRoles current member] + exact List.mem_cons_self + have finalMember := final_mem_packets final + have visited : (.inl final : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst) := + List.mem_map.mpr ⟨⟨.inl final,table (.inl final)⟩,recorded final finalMember,rfl⟩ + obtain ⟨frozen,captured⟩ := PCSBCSSourceRootCapture.capture_exists + address ⟨saved.root,initialShape saved.shape⟩ (.inl final) + (mentions final finalMember) program table visited + have root := captured_sourceRoot C address ⟨saved.root,initialShape saved.shape⟩ + program table frozen captured auth clean + have assembled (current : EnteredPacket p Q iv boundary) (member : current ∈ packets final) := + fromCapture_exact address ⟨saved.root,initialShape saved.shape⟩ program + original saved current table frozen + (by rw [capturedRegistry_enabled _ _ _ _ _ (mentions current member)]; exact captured) + ring t _ (by + intro earlier + rw [PCSBCSSourcePacketTape.rawPrefix_table] + exact raws (current.predecessor earlier) (predecessor_mem_packets final current member earlier)) + (source_inverse _ _ _ C _ _ _ (addressRoles current member) + (List.mem_map.mpr ⟨⟨.inl current,table (.inl current)⟩,recorded current member,rfl⟩) + (transport current member)) + simp only [root] at assembled + refine ⟨bound,?_,?_⟩ + · intro current member + exact ⟨_,assembled current member,rfl,rfl,rfl⟩ + · exact accepted_failure_path_of_snapshots address + ⟨saved.root,initialShape saved.shape⟩ program original saved table (packets final) + (Sampling.execute table program).2 _ ring t strategy recorded assembled raws + (packets_consecutive final terminal) (packets_initial final terminal) + (packets_terminal final terminal) (packets_nonempty final) accepted failure + +#print axioms captured_sourceRoot +#print axioms source_inverse +#print axioms accepted_failure_statePath +#print axioms sourceRoot_current_independent +#print axioms roles_from_transport +end Whir.PCSBCSCapturedSourceAcceptance diff --git a/verification/whir/Whir/PCSBCSCapturedSourceExecutable.lean b/verification/whir/Whir/PCSBCSCapturedSourceExecutable.lean new file mode 100644 index 000000000..42570d5b8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedSourceExecutable.lean @@ -0,0 +1,97 @@ +import Whir.PCSBCSCapturedSourceTransport + +/-! Executable full-table specialization of the erased captured builder. Its +checked equality permits IO tests to run actual first-mention capture and the +actual reply constructor, without compiling Classical erased-key equality. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCapturedSourceExecutable +open Concrete Protocol CausalGame CausalProbability FiatShamirGame +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSMerkleRootCache +open PCSBCSSourceCallerSnapshot PCSBCSSourceReplyInversion +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Same first-disclosure walk, using the Reference's executable equality. The +key equality instance is not consulted by the disclosure finder. -/ +def capture {R : Type} {n : Nat} (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : Option Frozen := + (PCSBCSFirstRootDisclosure.firstMention addresses ref program table).map fun events => + freeze (PCSBCSSourceRootCapture.ordinaryPrefix events) ref.root ref.shape + +/-- Only references addressed by the current literal packet are enabled. -/ +def registry {R : Type} {n : Nat} (addresses : Keys → List Reference) + (program : Sampling Keys Answers R n) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) : PCSBCSSourceFrozenAccessor.Captures := + fun ref => if ref ∈ addresses (.inl current) then capture addresses ref program table else none + +/-- Actual first-mention freezing, strict previous packet tape, and checked +frozen reply decoding. This is not a supplied oracle or a supplied success +certificate. The table's selected answer is never an incoming-state input. -/ +def snapshotFromTable {R : Type} {n : Nat} (addresses : Keys → List Reference) + (ref : Reference) (program : Sampling Keys Answers R n) + (original : PCSBCSCallerBinding.CallerInput p) (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) : + Option (PCSBCSCallerBinding.CallerData p) := do + let captures := registry addresses program current table + let root ← captures ref + let replies ← PCSBCSSourceFrozenReplies.replies current.2.coord saved captures current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) + pure ⟨original,PCSBCSRestorationHazard.incomingData p root.raw + (PCSBCSSourcePacketTape.ringPrefix current (fun key => table key.val)) + (PCSBCSSourcePacketTape.tape current (fun key => table key.val)) replies current.2.coord⟩ + +theorem capture_eq {R : Type} {n : Nat} (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : + capture addresses ref program table = PCSBCSSourceRootCapture.capture addresses ref program table := by + unfold capture PCSBCSSourceRootCapture.capture + congr 2 + +/-- The executable specialization is exactly the source constructor on a +shared table, rather than an independently specified approximation. -/ +theorem snapshotFromTable_eq {R : Type} {n : Nat} (addresses : Keys → List Reference) + (ref : Reference) (program : Sampling Keys Answers R n) + (original : PCSBCSCallerBinding.CallerInput p) (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) : + snapshotFromTable addresses ref program original saved current table = + fromCapture addresses ref program original saved current (fun key => table key.val) := by + have same : registry addresses program current table = + capturedRegistry addresses program current (fun key => table key.val) := by + rw [capturedRegistry_actual] + funext reference + unfold registry + rw [capture_eq] + unfold snapshotFromTable fromCapture + rw [same] + +open Classical in +theorem snapshotFromTable_current_independent {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) (program : Sampling Keys Answers R n) + (original : PCSBCSCallerBinding.CallerInput p) (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) + (full : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth current.2.coord)) → Digest32) : + snapshotFromTable addresses ref program original saved current + (Function.update table (.inl current) full) = + snapshotFromTable addresses ref program original saved current table := by + rw [snapshotFromTable_eq,snapshotFromTable_eq] + exact captured_snapshot_answer_independent addresses ref program original saved current table full + +theorem snapshotFromTable_original {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) (program : Sampling Keys Answers R n) + (original : PCSBCSCallerBinding.CallerInput p) (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) + (data : PCSBCSCallerBinding.CallerData p) + (assembled : snapshotFromTable addresses ref program original saved current table = some data) : + data.original = original := by + rw [snapshotFromTable_eq] at assembled + exact captured_original_preserved addresses ref program original saved current + (fun key => table key.val) data assembled + +#print axioms capture_eq +#print axioms snapshotFromTable_eq +#print axioms snapshotFromTable_current_independent +#print axioms snapshotFromTable_original +end Whir.PCSBCSCapturedSourceExecutable diff --git a/verification/whir/Whir/PCSBCSCapturedSourceExecutableSmoke.lean b/verification/whir/Whir/PCSBCSCapturedSourceExecutableSmoke.lean new file mode 100644 index 000000000..257fd748d --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedSourceExecutableSmoke.lean @@ -0,0 +1,185 @@ +import Whir.PCSBCSCapturedSourceExecutable +import Whir.PCSBCSSourceCallerOriginal +import Whir.PublicMerkleProgram + +/-! Actual first-disclosure source construction on the lowest production +profile, with real BLAKE2s primitive Merkle records and the literal prepared +original caller. Construction-output fixture coins are explicit, not deployed +duplex outputs or an accepted PCS proof. Missing, future and malformed records +retain their actual capture/status behavior rather than granting honesty. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCapturedSourceExecutableSmoke +open Concrete Protocol CausalGame CausalProbability FiatShamirGame +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSMerkleRootCache +open PCSBCSCapturedSourceExecutable DuplexModeGame PublicMerkleLog + +local instance : Add E := ⟨E.add⟩ +local instance : Mul E := ⟨E.mul⟩ +local instance : Zero E := ⟨E.zero⟩ +local instance : One E := ⟨E.one⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +private def p : ParameterBounds.Profile := ⟨⟨0,by decide⟩,⟨0,by decide⟩⟩ +private def layout : WHIRCallerClaims.CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ +private def Q : Nat := 2^20 +private def digest (n : Nat) : Digest32 := + fun i => ⟨(n / 256^i.val)%256,Nat.mod_lt _ (by decide)⟩ +private def iv : Digest32 := digest 0 + +private def recordedTree (bad : Option Nat) : Nat → Nat → Digest32 × DuplexPublicSimulator.PublicLog + | 0,start => + let words := (List.replicate 48 (if bad == some start then (9 : K) else 0)) ++ + ((List.range 16).map fun lane => UInt64.ofNat (10+start+lane)) + let bytes := ByteCodec.wordsBytes words + PublicMerkleProgram.withHashStored blake2sOracle bytes (fun root => + (root,plan blake2sOracle bytes)) + | height+1,start => + let left := recordedTree bad height start + let right := recordedTree bad height (start+2^height) + let bytes := List.ofFn (ByteCodec.pairBytes (left.1,right.1)) + PublicMerkleProgram.withHashStored blake2sOracle bytes (fun root => + (root,left.2 ++ right.2 ++ plan blake2sOracle bytes)) + +private def savedFor (root : Digest32) : AnchoredHeaderCodec.Record := + ⟨AnchoredSourceCaller.shape layout,root,⟨digest 19,(fun _ => none),0,true,0,0⟩, + E.ofK 3 :: List.replicate 14 0,E.ofK 23⟩ +private def zeroToken : WHIRCallerShape.EventShape → WHIRCallerClaims.CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) +private def entryFor (saved : AnchoredHeaderCodec.Record) : FramedHistory := + WHIRCallerClaims.tokenHistory (digest 11) (digest 13) + (((WHIRCallerClaims.callerShape layout).drop + (WHIRCallerClaims.rootScalarCount layout)).map zeroToken ++ + (AnchoredHeaderCodec.openingScalars saved).map WHIRCallerClaims.CallerToken.sent) +private def boundary (saved : AnchoredHeaderCodec.Record) : Nat := (entryFor saved).frames.length +private def current (saved : AnchoredHeaderCodec.Record) : + Option (EnteredPacket p Q iv (boundary saved)) := + let entry := entryFor saved + if valid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f then + if admitted : WHIRHistory.scheduledAdmissible (ParameterBounds.config p) + [⟨[],none⟩] = true then + if bounded : ∀ block : Fin (PCSBCSChallengeOracle.blocks + (PCSBCSRounds.rawWidth (.initial : Coordinate (ParameterBounds.config p)))), + DuplexFraming.pathCost (WHIRCallerPrefix.outputKeyFrom + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) entry [⟨[],none⟩] block.val) ≤ Q then + some ⟨⟨entry,rfl⟩,⟨.initial,{ + messages := [⟨[],none⟩] + nonempty := by decide + admitted := admitted + entryValid := valid + position_eq := rfl + pathBound := bounded}⟩⟩ + else none + else none + else none + +private abbrev Keys (saved : AnchoredHeaderCodec.Record) := + PCSBCSSourceRootCapture.Key (p := p) (Q := Q) (iv := iv) (boundary := boundary saved) +private abbrev Answers (saved : AnchoredHeaderCodec.Record) := + PCSBCSSourceRootCapture.Answer (p := p) (Q := Q) (iv := iv) (boundary := boundary saved) + +private def primitiveKey (saved : AnchoredHeaderCodec.Record) (input : DuplexFraming.Node) : Keys saved := + .inr ⟨.inl input,by + classical + simp [EnteredPacket.partition,partitionOfInjection,EnteredPacket.encode]⟩ + +private def table (saved : AnchoredHeaderCodec.Record) (salt : Nat) : Table (Keys saved) (Answers saved) + | .inl packet => fun block => digest (salt+block.val+position packet.2.coord) + | .inr other => match other.val with + | .inl input => blake2sOracle input + | .inr _ => digest 0 + +private def ordinary (saved : AnchoredHeaderCodec.Record) {n : Nat} + (log : DuplexPublicSimulator.PublicLog) (tail : Sampling (Keys saved) (Answers saved) Unit n) : + Sampling (Keys saved) (Answers saved) Unit (log.length+n) := + match log with + | [] => Sampling.pad (by simp) tail + | record::rest => Sampling.pad (by simp only [List.length_cons]; omega) + (.draw (primitiveKey saved record.1) (fun _ => ordinary saved rest tail)) + +private def addresses (saved : AnchoredHeaderCodec.Record) : Keys saved → List Reference + | .inl _ => [⟨saved.root,initialShape saved.shape⟩] + | .inr _ => [] + +private def require (label : String) (ok : Bool) : IO Unit := do + unless ok do throw (IO.userError s!"captured source executable: {label}") + IO.println s!"captured source executable PASS: {label}" + +private def runSnapshot (saved : AnchoredHeaderCodec.Record) + (cur : EnteredPacket p Q iv (boundary saved)) + (original : PCSBCSCallerBinding.CallerInput p) (before after : DuplexPublicSimulator.PublicLog) + (salt : Nat) : Option (PCSBCSCallerBinding.CallerData p) := + let program := ordinary saved before + (.draw (.inl cur) (fun _ => ordinary saved after (Sampling.ret (n := 0) ()))) + snapshotFromTable (addresses saved) ⟨saved.root,initialShape saved.shape⟩ + program original saved cur (table saved salt) + +private def inspect (saved : AnchoredHeaderCodec.Record) + (cur : EnteredPacket p Q iv (boundary saved)) (log : DuplexPublicSimulator.PublicLog) : Option Frozen := + let program := ordinary saved log (.draw (.inl cur) (fun _ => Sampling.ret (n := 0) ())) + capture (addresses saved) ⟨saved.root,initialShape saved.shape⟩ program (table saved 0) + +def smoke : IO Unit := do + let shape := initialShape (savedFor (digest 17)).shape + require "real lowest production geometry, full 64-word leaf and 16 occupied lanes" + ((ParameterBounds.config p).logN == 15 && shape.height == 10 && + shape.leafWords == 64 && shape.occupied == 16) + let tree := recordedTree none shape.height 0 + let saved := savedFor tree.1 + let cur ← match current saved with + | none => throw (IO.userError "literal production source packet admission rejected") + | some cur => pure cur + let original ← match PCSBCSSourceCallerOriginal.original p layout saved (entryFor saved) + (fun _ => digest 0) with + | none => throw (IO.userError "actual original source constructor rejected") + | some original => pure original + require "packet has actual initial coordinate, complete source shape and immutable anchor" + (position cur.2.coord == 0 && decide saved.Valid && + original.anchorValue == saved.value && original.anchorPoint == saved.point.toArray) + let actual ← match runSnapshot saved cur original tree.2 [] 0 with + | none => throw (IO.userError "actual first-mention source snapshot rejected") + | some data => pure data + require "captured native compact Root0 comes from real padded BLAKE2s images" + (actual.observed.root.size == 1024 && actual.observed.root[0]!.size == 16 && + (actual.observed.root[0]!)[0]! == 10 && (actual.observed.root[3]!)[2]! == 15) + require "whole source snapshot retains independent original and strict initial incoming trace" + (actual.original.anchorPoint == original.anchorPoint && actual.original.anchorValue == original.anchorValue && + actual.original.m == original.m && actual.observed.trace.answers.isEmpty) + let altered ← match runSnapshot saved cur original tree.2 [] 999 with + | none => throw (IO.userError "changed whole current output rejected incoming snapshot") + | some data => pure data + require "changing all current raw output bytes cannot enter incoming Root0 or replies" + (altered.observed.root == actual.observed.root && altered.observed.trace.answers.isEmpty && + altered.original.anchorPoint == actual.original.anchorPoint) + let future ← match runSnapshot saved cur original [] tree.2 0 with + | none => throw (IO.userError "actual ghost first capture rejected structural storage") + | some data => pure data + require "future primitive records do not retroactively populate the first captured Root0" + (future.observed.root.size == 1024 && future.observed.root[0]!.size == 16 && + (future.observed.root[0]!)[0]! == 0 && (actual.observed.root[0]!)[0]! != 0) + let noMention := ordinary saved tree.2 (Sampling.ret (n := 0) ()) + require "missing first mention rejects actual source constructor" + (snapshotFromTable (addresses saved) ⟨saved.root,initialShape saved.shape⟩ + noMention original saved cur (table saved 0)).isNone + require "disabled reference address does not become an authenticated zero table" + (snapshotFromTable (fun _ => []) ⟨saved.root,initialShape saved.shape⟩ + (ordinary saved tree.2 (.draw (.inl cur) (fun _ => Sampling.ret (n := 0) ()))) + original saved cur (table saved 0)).isNone + let malformed := recordedTree (some 3) shape.height 0 + let badSaved := savedFor malformed.1 + let badCur ← match current badSaved with + | none => throw (IO.userError "bad-padding packet's syntax admission rejected") + | some cur => pure cur + let frozen ← match inspect badSaved badCur malformed.2 with + | none => throw (IO.userError "actual malformed-image first capture missing") + | some frozen => pure frozen + require "genuinely hashed nonzero prefix remains available but padding-invalid" + (frozen.cells[3]!.available && !frozen.cells[3]!.paddingValid && + frozen.cells[0]!.available && frozen.cells[0]!.paddingValid) + IO.println s!"captured source executable PASS: physical BLAKE2s records {tree.2.length}" +end Whir.PCSBCSCapturedSourceExecutableSmoke + +def main : IO Unit := Whir.PCSBCSCapturedSourceExecutableSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSCapturedSourceProbability.lean b/verification/whir/Whir/PCSBCSCapturedSourceProbability.lean new file mode 100644 index 000000000..ca0e93410 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedSourceProbability.lean @@ -0,0 +1,120 @@ +import Whir.PCSBCSCapturedSourceAcceptance +import Whir.PCSBCSChallengeOracleEnteredGames + +/-! PCS-only source-game composition with fixed caller metadata. The failure +relation uses the literal caller decoder, native acceptance, the actual decoder +extractor, and explicit native primitive/codec evidence. It does not accept a +StatePath, restoration Boolean, compatible snapshot, or probability certificate. +The source answers and original caller in this module are fixed outside the +table average, but public root addresses have no caller-answer input. Adaptive +earlier caller coins require the separate erased-value adapter. +The indexed atomic source has Q draws, not Q per prover round. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSCapturedSourceProbability +open Concrete Protocol CausalGame CausalProbability FiatShamirGame +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSSourceCallerSnapshot +open PCSBCSCallerBinding PCSBCSCapturedSourceAcceptance +open PCSBCSCapturedSourceTransport PCSBCSCapturedSourceStatePath +open PCSBCSCapturedNativeReplyBridge PCSBCSRestorationHazard PCSRoundByRoundTranscriptState +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent +open PublicMerkleLog MerkleTransport.Commitments + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +noncomputable local instance (key : Keys) : Fintype (Answers key) := + Restoration.instFintypeAnswer p Q iv boundary key + +/-- Literal accepted source run outside the separately charged Merkle bad + events. Every root and native reply is derived from the same primitive and + first-captured prefix. The caller is independently fixed; no honesty of its + original claims is assumed. -/ +structure FailureWitness {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (answers : FiatShamirGame.Coordinate → Digest32) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (table : Table Keys Answers) where + primitive : DuplexModeGame.PrimitiveOracle + final : EnteredPacket p Q iv boundary + claims : AnchoredSourceCaller.Claims + valid : saved.Valid + profile : profileShape p saved.shape + caller : AnchoredSourceFreshCaller.decode layout saved final.1.val answers = some claims + bound : BoundOriginal original saved claims + terminal : final.2.coord = lastCoordinate (ParameterBounds.config p) + recorded : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + (⟨.inl current,table (.inl current)⟩ : Sigma Answers) ∈ (Sampling.execute table program).2 + authentic : AuthenticLog primitive (sourceLog address + ⟨saved.root,initialShape saved.shape⟩ program table) + clean : ¬ OutputCollision (sourceLog address + ⟨saved.root,initialShape saved.shape⟩ program table) + ring : RingPCSGame.Prefix + tape : Tape (ParameterBounds.config p) + strategy : RingPCSGame.Prefix → Strategy + raws : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + grouped current.2.coord (table (.inl current)) = + literalRaw ring tape current.2.coord + transport : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + ReplyTransport address program table primitive saved current + (nativeReplies original + (sourceRoot primitive address + ⟨saved.root,initialShape saved.shape⟩ program table) strategy ring tape) + accepted : experiment (OriginalClaimsChecker.input original.prepared + (sourceRoot primitive address + ⟨saved.root,initialShape saved.shape⟩ program table) ring) (strategy ring) tape = true + failed : ¬ ∃ w, + PCSRoundByRoundKnowledge.extract p original.lanes original.family original.points + original.anchorPoint original.anchorValue + (sourceRoot primitive address + ⟨saved.root,initialShape saved.shape⟩ program table) = some w ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) original.lanes + (sourceRoot primitive address + ⟨saved.root,initialShape saved.shape⟩ program table) + original.family original.points original.anchorPoint original.anchorValue w + +/-- The source relation, not a free assumed accepted path. -/ +def Failed {R : Type} {n : Nat} + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (answers : FiatShamirGame.Coordinate → Digest32) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (table : Table Keys Answers) : Prop := + Nonempty (FailureWitness layout saved answers program original table) + +open Classical in +/-- Exact first-disclosure loss for the actual captured adapter with fixed +source callback and original caller. The physical compiler and atomic grouping +both retain index Q; this is not the adaptive-caller Fiat-Shamir endpoint. -/ +theorem fixed_metadata_failure_probability {R : Type} + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (answers : FiatShamirGame.Coordinate → Digest32) + (program : Sampling Keys Answers R Q) (original : CallerInput p) : + Soundness.uniformProb (Finset.univ.filter + (Failed layout saved answers program original)) ≤ + (Q : ℚ) * PCSRoundByRoundKnowledge.rbrError := by + let model := Restoration.model p Q iv boundary + (builder address ⟨saved.root,initialShape saved.shape⟩ + program original saved) + have nonnegative : (0 : ℚ) ≤ PCSRoundByRoundKnowledge.rbrError := by + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + have result := accepted_path_failure_probability model Q 0 program + PCSRoundByRoundKnowledge.rbrError nonnegative + (Restoration.conditional_hazard p Q iv boundary + (builder address ⟨saved.root,initialShape saved.shape⟩ + program original saved)) + (Failed layout saved answers program original) (by + intro table failed + obtain ⟨w⟩ := failed + exact (accepted_failure_statePath w.primitive layout saved answers program table + w.final original w.claims w.valid w.profile w.caller w.bound w.terminal + w.recorded w.authentic w.clean w.ring w.tape w.strategy w.raws w.transport + w.accepted w.failed).2.2) + simpa only [Nat.add_zero] using result + +#print axioms fixed_metadata_failure_probability +end Whir.PCSBCSCapturedSourceProbability diff --git a/verification/whir/Whir/PCSBCSCapturedSourceStatePath.lean b/verification/whir/Whir/PCSBCSCapturedSourceStatePath.lean new file mode 100644 index 000000000..6e4ef97bb --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedSourceStatePath.lean @@ -0,0 +1,442 @@ +import Whir.PCSBCSCapturedSourceTransport +import Whir.PCSBCSChallengeOracleRestoration +import Whir.PCSBCSRestorationLiteralPath +import Whir.PCSBCSLiteralStatePath +import Whir.PCSRoundByRoundPublicEndpoint + +/-! Exact strict-trace identities for the literal captured builder. These +identities are deterministic; no probability composition or Rust refinement is +hidden in this module's endpoints. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 100000 +namespace Whir.PCSBCSCapturedSourceStatePath +open Concrete Protocol CausalGame CausalProbability FiatShamirGame WHIRHistory +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSMerkleRootCache +open PCSBCSSourceCallerSnapshot PCSBCSSourceReplyInversion +open PCSBCSCallerBinding PCSBCSRestorationHazard PCSRoundByRoundTranscriptState +open TypedOracleCompiler TypedFiatShamirGame PCSStateRestoration.Latent +open CausalPositions + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- The production builder receives only other full packets; its unused +Earlier argument is not a supplied recovery oracle. -/ +noncomputable def builder {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (saved : AnchoredHeaderCodec.Record) : Restoration.Builder p Q iv boundary := + fun current other _ => fromCapture addresses ref program original saved current other + +/-- The path is the actual terminal Pending history, truncated at every +scheduled coordinate. No caller-supplied list of restoration links is used. -/ +def packetAt (final : EnteredPacket p Q iv boundary) + (q : Coordinate (ParameterBounds.config p)) : EnteredPacket p Q iv boundary := + if earlier : position q < position final.2.coord then final.predecessor ⟨q,earlier⟩ else final + +abbrev packets (final : EnteredPacket p Q iv boundary) : List (EnteredPacket p Q iv boundary) := + (schedule (ParameterBounds.config p)).map (packetAt final) + +theorem packetAt_coord (final : EnteredPacket p Q iv boundary) + (terminal : final.2.coord = lastCoordinate (ParameterBounds.config p)) + (q : Coordinate (ParameterBounds.config p)) : (packetAt final q).2.coord = q := by + by_cases earlier : position q < position final.2.coord + · have equal : packetAt final q = final.predecessor ⟨q,earlier⟩ := dite_eq_left earlier + rw [equal] + rfl + · have equal : packetAt final q = final := dite_eq_right earlier + rw [equal] + apply CausalPrefix.position_injective + have largest := lastCoordinate_max (ParameterBounds.config p) q + rw [← terminal] at largest + omega + +theorem packetAt_entry (final : EnteredPacket p Q iv boundary) + (q : Coordinate (ParameterBounds.config p)) : (packetAt final q).1 = final.1 := by + by_cases earlier : position q < position final.2.coord + · have equal : packetAt final q = final.predecessor ⟨q,earlier⟩ := dite_eq_left earlier + rw [equal] + rfl + · have equal : packetAt final q = final := dite_eq_right earlier + rw [equal] + +theorem final_mem_packets (final : EnteredPacket p Q iv boundary) : final ∈ packets final := by + apply List.mem_map.mpr + refine ⟨final.2.coord,coordinate_mem_schedule _,?_⟩ + simp [packetAt] + +theorem packets_entry (final current : EnteredPacket p Q iv boundary) + (member : current ∈ packets final) : current.1 = final.1 := by + obtain ⟨q,_,equal⟩ := List.mem_map.mp member + rw [← equal] + exact packetAt_entry final q + +/-- Every strict source-history ancestor is literally another packet in the +constructed path. Its answer is already assigned in the same global table. -/ +theorem predecessor_mem_packets (final current : EnteredPacket p Q iv boundary) + (member : current ∈ packets final) (earlier : current.Earlier) : + current.predecessor earlier ∈ packets final := by + have source : current = final ∨ ∃ r : final.Earlier, current = final.predecessor r := by + obtain ⟨q,_,equal⟩ := List.mem_map.mp member + by_cases before : position q < position final.2.coord + · exact Or.inr ⟨⟨q,before⟩,equal.symm.trans (dite_eq_left before)⟩ + · exact Or.inl (equal.symm.trans (dite_eq_right before)) + rcases source with rfl | ⟨r,rfl⟩ + · apply List.mem_map.mpr + refine ⟨earlier.val,coordinate_mem_schedule _,?_⟩ + exact dite_eq_left earlier.property + · have nested : position earlier.val < position final.2.coord := earlier.property.trans r.property + rw [PCSBCSSourcePacketTape.predecessor_comp final r earlier] + apply List.mem_map.mpr + refine ⟨earlier.val,coordinate_mem_schedule _,?_⟩ + exact dite_eq_left nested + +theorem packets_nonempty (final : EnteredPacket p Q iv boundary) : packets final ≠ [] := by + intro empty + have scheduleEmpty := List.map_eq_nil_iff.mp empty + have member := coordinate_mem_schedule (.initial : Coordinate (ParameterBounds.config p)) + rw [scheduleEmpty] at member + cases member + +theorem packets_consecutive (final : EnteredPacket p Q iv boundary) + (terminal : final.2.coord = lastCoordinate (ParameterBounds.config p)) + (i : Nat) (hi : i+1 < (packets final).length) : + position ((packets final)[i+1]'hi).2.coord = + position ((packets final)[i]'(by omega)).2.coord + 1 := by + have bound : i+1 < depth (ParameterBounds.config p) := by simpa only [packets,List.length_map,depth] using hi + have getAt (j : Nat) (hj : j < (packets final).length) : + ((packets final)[j]'hj).2.coord = + (schedule (ParameterBounds.config p))[j]'(by simpa only [packets,List.length_map] using hj) := by + have equal : (packets final)[j]'hj = packetAt final + ((schedule (ParameterBounds.config p))[j]'(by simpa only [packets,List.length_map] using hj)) := + List.getElem_map (packetAt final) + rw [equal,packetAt_coord final terminal] + rw [getAt (i+1) hi,getAt i (by omega)] + exact (position_schedule_get (ParameterBounds.config p) ⟨i+1,bound⟩).trans + (congrArg (fun n : Nat => n+1) + (position_schedule_get (ParameterBounds.config p) ⟨i,by omega⟩)).symm + +theorem packets_initial (final : EnteredPacket p Q iv boundary) + (terminal : final.2.coord = lastCoordinate (ParameterBounds.config p)) + (current : EnteredPacket p Q iv boundary) + (first : (packets final).head? = some current) : current.2.coord = .initial := by + have initial := schedule_get_position (.initial : Coordinate (ParameterBounds.config p)) + simp only [position_initial] at initial + have head : (schedule (ParameterBounds.config p)).head? = some .initial := by + simpa only [List.head?_eq_getElem?] using initial + simp only [packets,List.head?_map,head,Option.map_some,Option.some.injEq] at first + rw [← first] + exact packetAt_coord final terminal .initial + +theorem lastCoordinate_position (c : Config) : + position (lastCoordinate c) = depth c - 1 := by + have positive : 0 < depth c := by + simpa only [position_initial] using position_lt_depth (.initial : Coordinate c) + let q := (schedule c)[depth c-1]'(by unfold depth at *; omega) + have positionQ : position q = depth c-1 := position_schedule_get c ⟨depth c-1,by omega⟩ + have largest := lastCoordinate_max c q + have inside := position_lt_depth (lastCoordinate c) + omega + +theorem packets_terminal (final : EnteredPacket p Q iv boundary) + (terminal : final.2.coord = lastCoordinate (ParameterBounds.config p)) + (current : EnteredPacket p Q iv boundary) + (last : (packets final).getLast? = some current) : + current.2.coord = lastCoordinate (ParameterBounds.config p) := by + simp only [packets,List.getLast?_map] at last + obtain ⟨q,atLast,equal⟩ := Option.map_eq_some_iff.mp last + rw [← equal,packetAt_coord final terminal] + apply CausalPrefix.position_injective + rw [lastCoordinate_position] + rw [List.getLast?_eq_getElem?] at atLast + obtain ⟨inside,stored⟩ := List.getElem?_eq_some_iff.mp atLast + rw [← stored] + exact position_schedule_get (ParameterBounds.config p) + ⟨depth (ParameterBounds.config p)-1,inside⟩ + +/-- A decoded strict prefix agrees with the native trace exactly, including +array length. Future source responses cannot enter via a default get. -/ +theorem replies_exact (current : Coordinate (ParameterBounds.config p)) + (saved : AnchoredHeaderCodec.Record) (registry : PCSBCSSourceFrozenAccessor.Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (native : Array Reply) (parsed : Array Reply) + (assembled : PCSBCSSourceFrozenReplies.replies current saved registry messages past = some parsed) + (inverses : ∀ j, j < position current → + (PCSBCSSourceFrozenAccessor.inverseAt current saved registry messages past j).map Inverted.reply = some native[j]!) : + parsed = priorAnswers native (position current) := by + apply Array.ext + · rw [PCSBCSSourceFrozenReplies.replies_size current saved registry messages past parsed assembled] + simp [priorAnswers] + · intro j left right + have earlier : j < position current := by + rw [PCSBCSSourceFrozenReplies.replies_size current saved registry messages past parsed assembled] at left + exact left + have actual := PCSBCSSourceFrozenReplies.replies_index current saved registry messages past parsed assembled j earlier + rw [inverses j earlier] at actual + have equal : parsed[j]! = native[j]! := by + rw [getElem!_def,← actual] + have projected := priorAnswers_get native (position current) j earlier + simpa only [getElem!_pos parsed j left, + getElem!_pos (priorAnswers native (position current)) j right] using equal.trans projected.symm + +/-- Strict incoming traces use only earlier literal packet answers. The current +whole packet is never read in these identities. -/ +theorem incoming_exact (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) (native parsed : Array Reply) + (answers : parsed = priorAnswers native (position current.2.coord)) + (raws : ∀ r : current.Earlier, + PCSBCSSourcePacketTape.rawPrefix current (fun key => table key.val) r.val r.property = literalRaw ring t r.val) : + incomingTrace (PCSBCSSourcePacketTape.ringPrefix current (fun key => table key.val)) + (PCSBCSSourcePacketTape.tape current (fun key => table key.val)) parsed current.2.coord = + incomingTrace ring t native current.2.coord := by + unfold incomingTrace + congr 1 + · by_cases initial : current.2.coord = .initial + · simp [initial] + · have earlier : position (.initial : Coordinate (ParameterBounds.config p)) < position current.2.coord := + noninitial_positive current.2.coord initial + have equal := congrArg Prod.fst (raws ⟨.initial,earlier⟩) + simp only [PCSBCSSourcePacketTape.ringPrefix,PCSBCSSourcePacketTape.ringOfPrefix, + dite_eq_left earlier,literalRaw] at equal ⊢ + simpa only [incomingTrace,ite_eq_right initial] using congrArg some equal + · funext r + by_cases earlier : position r < position current.2.coord + · have sample := PCSBCSSourcePacketTape.get_table current table ⟨r,earlier⟩ + have raw := raws ⟨r,earlier⟩ + have projected : PCSBCSSourcePacketTape.project r (literalRaw ring t r) = get r t := by + cases r <;> rfl + rw [← PCSBCSSourcePacketTape.rawPrefix_table current table ⟨r,earlier⟩,raw,projected] at sample + simp only [earlier,↓reduceIte,sample] + · simp only [earlier,↓reduceIte] + · rw [answers] + apply Array.ext + · simp [priorAnswers] + · intro j left right + have earlier : j < position current.2.coord := by simpa [priorAnswers] using left + have outer := priorAnswers_get (priorAnswers native (position current.2.coord)) + (position current.2.coord) j earlier + simpa only [getElem!_pos (priorAnswers (priorAnswers native (position current.2.coord)) + (position current.2.coord)) j left, + getElem!_pos (priorAnswers native (position current.2.coord)) j right] using outer + +/-- Successful actual capture assembly is the literal native incoming state, +not merely an equality of selected scalar fields. -/ +theorem fromCapture_exact {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (saved : AnchoredHeaderCodec.Record) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (frozen : Frozen) + (root : capturedRegistry addresses program current (fun key => table key.val) ref = some frozen) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) (native : Array Reply) + (raws : ∀ r : current.Earlier, + PCSBCSSourcePacketTape.rawPrefix current (fun key => table key.val) r.val r.property = literalRaw ring t r.val) + (inverses : ∀ j, j < position current.2.coord → + (PCSBCSSourceFrozenAccessor.inverseAt current.2.coord saved + (capturedRegistry addresses program current (fun key => table key.val)) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) j).map Inverted.reply = some native[j]!) : + fromCapture addresses ref program original saved current (fun key => table key.val) = + some (literalCallerData p original frozen.raw ring t native current.2.coord) := by + obtain ⟨parsed,assembled⟩ := PCSBCSCapturedSourceTransport.replies_complete current.2.coord saved + (capturedRegistry addresses program current (fun key => table key.val)) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) (by + intro j earlier + obtain ⟨reply,found,_⟩ := Option.map_eq_some_iff.mp (inverses j earlier) + exact ⟨reply,found⟩) + have exactAnswers := replies_exact current.2.coord saved + (capturedRegistry addresses program current (fun key => table key.val)) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) native parsed assembled inverses + have trace := incoming_exact current table ring t native parsed exactAnswers raws + simp only [fromCapture,root,assembled] + dsimp only [Bind.bind,Option.bind,Pure.pure] + unfold literalCallerData incomingData + rw [trace] + +theorem node_after {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (saved : AnchoredHeaderCodec.Record) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) (native : Array Reply) + (assembled : fromCapture addresses ref program original saved current (fun key => table key.val) = + some (literalCallerData p original root ring t native current.2.coord)) + (raw : grouped current.2.coord (table (.inl current)) = literalRaw ring t current.2.coord) : + after (Restoration.model p Q iv boundary (builder addresses ref program original saved)) + (.inl current) table = literalState p original root ring t native current.2.coord := by + change (match fromCapture addresses ref program original saved current (fun key => table key.val) with + | some caller => (callerCertificate p).after caller current.2.coord + (grouped current.2.coord (table (.inl current))) + | none => false) = _ + rw [assembled,raw] + exact literal_after p original root ring t native current.2.coord + +theorem node_before {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (saved : AnchoredHeaderCodec.Record) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) (native : Array Reply) + (assembled : fromCapture addresses ref program original saved current (fun key => table key.val) = + some (literalCallerData p original root ring t native current.2.coord)) + (different : current.2.coord ≠ .initial) : + before (Restoration.model p Q iv boundary (builder addresses ref program original saved)) + (.inl current) table = + literalState p original root ring t native + (predecessor current.2.coord (noninitial_positive current.2.coord different)) := by + have recovered : publicNode (Restoration.model p Q iv boundary + (builder addresses ref program original saved)) (.inl current) table = + some (literalCallerData p original root ring t native current.2.coord) := assembled + unfold PCSStateRestoration.Latent.before + rw [recovered] + change (callerCertificate p).before + (literalCallerData p original root ring t native current.2.coord) current.2.coord = _ + exact literal_before p original root ring t native current.2.coord different + +theorem node_initial {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (saved : AnchoredHeaderCodec.Record) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) (native : Array Reply) + (assembled : fromCapture addresses ref program original saved current (fun key => table key.val) = + some (literalCallerData p original root ring t native current.2.coord)) + (initial : current.2.coord = .initial) : + before (Restoration.model p Q iv boundary (builder addresses ref program original saved)) + (.inl current) table = false := by + have recovered : publicNode (Restoration.model p Q iv boundary + (builder addresses ref program original saved)) (.inl current) table = + some (literalCallerData p original root ring t native current.2.coord) := assembled + unfold PCSStateRestoration.Latent.before + rw [recovered] + change (callerCertificate p).before + (literalCallerData p original root ring t native current.2.coord) current.2.coord = false + rw [initial] + rfl + +/-- Neighbouring identities are proved from actual decoded snapshots and +literal consecutive coordinates. No before/after links are free premises. -/ +theorem path_of_snapshots {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (saved : AnchoredHeaderCodec.Record) (table : Table Keys Answers) + (packets : List (EnteredPacket p Q iv boundary)) (exposed : List (Sigma Answers)) + (root : BaseOracle) (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) + (native : Array Reply) (last : Bool) + (recorded : ∀ current ∈ packets, (⟨.inl current,table (.inl current)⟩ : Sigma Answers) ∈ exposed) + (assembled : ∀ current ∈ packets, + fromCapture addresses ref program original saved current (fun key => table key.val) = + some (literalCallerData p original root ring t native current.2.coord)) + (raws : ∀ current ∈ packets, + grouped current.2.coord (table (.inl current)) = literalRaw ring t current.2.coord) + (consecutive : ∀ i (hi : i+1 < packets.length), + position (packets[i+1]'hi).2.coord = position (packets[i]'(by omega)).2.coord + 1) + (initial : ∀ current, packets.head? = some current → current.2.coord = .initial) + (terminal : ∀ current, packets.getLast? = some current → + literalState p original root ring t native current.2.coord = last) + (nonempty : packets ≠ []) : + StatePath (Restoration.model p Q iv boundary (builder addresses ref program original saved)) + table exposed false last := by + classical + apply PCSBCSLiteralStatePath.of_round_links _ table exposed (packets.map Sum.inl) false last + · intro key member + obtain ⟨current,hcurrent,hkey⟩ := List.mem_map.mp member + rw [← hkey] + exact recorded current hcurrent + · intro i hi + have bound : i+1 < packets.length := by simpa only [List.length_map] using hi + let first := packets[i]'(by omega) + let second := packets[i+1]'bound + have firstMem : first ∈ packets := List.getElem_mem _ + have secondMem : second ∈ packets := List.getElem_mem _ + have positions := consecutive i bound + have different : second.2.coord ≠ .initial := by + intro equal + rw [equal,position_initial] at positions + omega + have predecessorSame : predecessor second.2.coord + (noninitial_positive second.2.coord different) = first.2.coord := by + apply CausalPrefix.position_injective + rw [predecessor_position] + change position second.2.coord = position first.2.coord + 1 at positions + omega + simp only [List.getElem_map] + rw [node_after addresses ref program original saved first table root ring t native + (assembled first firstMem) (raws first firstMem), + node_before addresses ref program original saved second table root ring t native + (assembled second secondMem) different,predecessorSame] + · intro key head + cases packets with + | nil => simp at head + | cons current rest => + simp only [List.map_cons,List.head?_cons,Option.some.injEq] at head + subst key + exact node_initial addresses ref program original saved current table root ring t native + (assembled current (by simp)) (initial current rfl) + · intro key final + have mapped : (packets.map (Sum.inl : EnteredPacket p Q iv boundary → Keys)).getLast? = + packets.getLast?.map Sum.inl := List.getLast?_map + rw [mapped] at final + obtain ⟨current,atLast,same⟩ := Option.map_eq_some_iff.mp final + subst key + have member : current ∈ packets := List.mem_of_getLast? atLast + rw [node_after addresses ref program original saved current table root ring t native + (assembled current member) (raws current member)] + exact terminal current atLast + · intro empty + have noPackets : packets = [] := List.map_eq_nil_iff.mp empty + exact (nonempty noPackets).elim + +/-- The terminal Boolean is derived from actual native PCS experiment +acceptance and failure of the actual original-claims extractor. -/ +theorem accepted_failure_path_of_snapshots {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (original : CallerInput p) + (saved : AnchoredHeaderCodec.Record) (table : Table Keys Answers) + (packets : List (EnteredPacket p Q iv boundary)) (exposed : List (Sigma Answers)) + (root : BaseOracle) (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) + (strategy : RingPCSGame.Prefix → Strategy) + (recorded : ∀ current ∈ packets, (⟨.inl current,table (.inl current)⟩ : Sigma Answers) ∈ exposed) + (assembled : ∀ current ∈ packets, + fromCapture addresses ref program original saved current (fun key => table key.val) = + some (literalCallerData p original root ring t + (PCSRoundByRoundTranscriptState.replies + (ExecutionShapes.Input p original.lanes root + (OriginalClaimsChecker.input original.prepared root ring).claims) (strategy ring) t) + current.2.coord)) + (raws : ∀ current ∈ packets, + grouped current.2.coord (table (.inl current)) = literalRaw ring t current.2.coord) + (consecutive : ∀ i (hi : i+1 < packets.length), + position (packets[i+1]'hi).2.coord = position (packets[i]'(by omega)).2.coord + 1) + (initial : ∀ current, packets.head? = some current → current.2.coord = .initial) + (terminal : ∀ current, packets.getLast? = some current → + current.2.coord = lastCoordinate (ParameterBounds.config p)) + (nonempty : packets ≠ []) + (accepted : CausalGame.experiment (OriginalClaimsChecker.input original.prepared root ring) + (strategy ring) t = true) + (failure : ¬ ∃ w, + PCSRoundByRoundKnowledge.extract p original.lanes original.family original.points + original.anchorPoint original.anchorValue root = some w ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) original.lanes root + original.family original.points original.anchorPoint original.anchorValue w) : + StatePath (Restoration.model p Q iv boundary (builder addresses ref program original saved)) + table exposed false true := by + apply path_of_snapshots addresses ref program original saved table packets exposed root ring t + _ true recorded assembled raws consecutive initial _ nonempty + intro current atLast + rw [terminal current atLast] + exact literal_accepted_extraction_failure_final p original.lanes original.family original.points + original.anchorPoint original.anchorValue original.prepared root strategy original.familyCap + original.claimCap ring t accepted failure + +#print axioms replies_exact +#print axioms incoming_exact +#print axioms fromCapture_exact +#print axioms node_after +#print axioms node_before +#print axioms node_initial +#print axioms path_of_snapshots +#print axioms accepted_failure_path_of_snapshots +end Whir.PCSBCSCapturedSourceStatePath diff --git a/verification/whir/Whir/PCSBCSCapturedSourceTransport.lean b/verification/whir/Whir/PCSBCSCapturedSourceTransport.lean new file mode 100644 index 000000000..d5706e3f6 --- /dev/null +++ b/verification/whir/Whir/PCSBCSCapturedSourceTransport.lean @@ -0,0 +1,238 @@ +import Whir.PCSBCSSourceCallerSnapshot +import Whir.PCSBCSSourceFrozenAccessorStructural +import Whir.PCSBCSMerkleRootCacheTransport +import Whir.PCSBCSSourcePrimitiveRootBudget + +/-! Literal root-address and strict-prefix transport for the captured source +builder. Shape admission is not authentication; authenticated full padded +openings, rather than unavailable default cells, supply opening transport. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCapturedSourceTransport +open Concrete Protocol CausalGame CausalProbability FiatShamirGame WHIRHistory +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSMerkleRootCache +open PCSBCSSourceCallerSnapshot PCSBCSSourceReplyInversion +open TypedOracleCompiler TypedFiatShamirGame +open PCSStateRestoration.Latent + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- The address reads only the literal construction entry and Pending bytes. +Unqueried caller answers cannot decide whether an earlier prequery mentions a +root. Primitive-query keys do not announce source roots. -/ +def address : Keys → List Reference + | .inl packet => (PCSBCSSourcePrimitiveRootBudget.openingReferencesFromEntry p packet.1.val + (WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + packet.1.val packet.2.messages 0)).getD [] + | .inr _ => [] + +/-- Once the literal caller parser admits the immutable binding, its exact +root roles are the initial root followed by the scheduled prior fold roots. -/ +theorem address_packet (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (answers : FiatShamirGame.Coordinate → Digest32) + (current : EnteredPacket p Q iv boundary) + (valid : saved.Valid) (profile : profileShape p saved.shape) + (claims : AnchoredSourceCaller.Claims) + (caller : AnchoredSourceFreshCaller.decode layout saved current.1.val answers = some claims) + (roles : phaseRolesAdmitted (ParameterBounds.config p) current.2.messages = true) : + address (.inl current) = + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) current.2.messages := by + have parsed := parsePendingKey_roundtrip p current.1.val current.2.messages + current.2.2.nonempty current.2.2.admitted 0 + have semantic : parseReferences p layout saved current.1.val answers + (WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + current.1.val current.2.messages 0) = + some (⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) current.2.messages) := by + simp [parseReferences,valid,profile,caller,parsed,roles] + have admission := PCSBCSSourcePrimitiveRootBudget.openingReferencesFromEntry_native p layout saved answers + current.1.val _ _ semantic + simp only [address,admission,Option.getD_some] + +/-- Root roles in any literal chronological prefix also occur in the current +packet. This is address membership, not a promise that the root is available. -/ +theorem phaseReferences_prefix (c : Config) (messages : List Pending) (count : Nat) + (ref : Reference) + (member : ref ∈ phaseReferences c (messages.reverse.take count).reverse) : + ref ∈ phaseReferences c messages := by + obtain ⟨⟨m,n⟩,inside,parsed⟩ := List.mem_filterMap.mp member + simp only [List.reverse_reverse] at inside + have indexed := List.mk_mem_zipIdx_iff_getElem?.mp inside + have original : messages.reverse[n]? = some m := by + have bound : n < count := by + have h := List.getElem?_eq_some_iff.mp indexed + have length : n < (messages.reverse.take count).length := h.1 + simp only [List.length_take] at length + omega + simpa only [List.getElem?_take,bound,↓reduceIte] using indexed + exact List.mem_filterMap.mpr ⟨(m,n),List.mk_mem_zipIdx_iff_getElem?.mpr original,parsed⟩ + +/-- The accessor's checked phase role necessarily belongs to the literal +current root-role list; future roots cannot enter via a suffix search. -/ +theorem phaseReference_member (c : Config) (saved : AnchoredHeaderCodec.Record) + (messages : List Pending) (phase count : Nat) (ref : Reference) + (parsed : PCSBCSSourceFrozenAccessor.phaseReference c saved + (messages.reverse.take count).reverse phase = some ref) : + ref ∈ ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences c messages := by + unfold PCSBCSSourceFrozenAccessor.phaseReference at parsed + split at parsed + next initial => + split at parsed + next => + have equal := (parseInitial_admitted saved (AnchoredHeaderCodec.openingScalars saved) 3 ref parsed).2.2.2 + simp only [equal,List.mem_cons, true_or] + next => contradiction + next => + split at parsed + next => + obtain ⟨found,indexed,continued⟩ := Option.bind_eq_some_iff.mp parsed + split at continued + next => + cases Option.some.inj continued + exact List.mem_cons_of_mem _ (phaseReferences_prefix c messages count ref (List.mem_of_getElem? indexed)) + next => contradiction + next => contradiction + +/-- A next root announced by a literal final nonterminal fold is already +addressed by the current Pending history, at its exact scheduled index. -/ +theorem foldReference_member (c : Config) (messages : List Pending) (n : Nat) + (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) (m : Pending) (ref : Reference) + (coordinate : (schedule c)[n]? = some (.fold i j)) + (message : messages.reverse[n+1]? = some m) + (parsed : parsePhase c (.fold i j) m (i.val+1) 2 = some ref) : + ref ∈ phaseReferences c messages := by + apply List.mem_filterMap.mpr + refine ⟨(m,n+1),List.mk_mem_zipIdx_iff_getElem?.mpr message,?_⟩ + change phaseAt c (n+1) m = some ref + simpa only [phaseAt,Nat.add_eq_zero_iff,Nat.one_ne_zero,and_false,↓reduceIte, + Nat.add_sub_cancel,coordinate,Option.getD_some] using parsed + +/-- Every enabled, actually visited root has a first-disclosure capture. The +constructor does not demand that unqueried leaves be physically available. -/ +theorem registry_exists {R : Type} {n : Nat} + (addresses : Keys → List Reference) (program : Sampling Keys Answers R n) + (table : Table Keys Answers) (current : EnteredPacket p Q iv boundary) + (ref : Reference) (mentioned : ref ∈ addresses (.inl current)) + (visited : (.inl current : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst)) : + ∃ frozen, capturedRegistry addresses program current (fun key => table key.val) ref = some frozen := by + obtain ⟨frozen,captured⟩ := PCSBCSSourceRootCapture.capture_exists addresses ref + (.inl current) mentioned program table visited + exact ⟨frozen,by rw [capturedRegistry_enabled addresses program current table ref mentioned]; exact captured⟩ + +/-- Enabled visited roots pass the actual storage checks because capture is a +literal freeze, not because of an assumed valid registry or honest root. -/ +theorem lookup_exists {R : Type} {n : Nat} + (addresses : Keys → List Reference) (program : Sampling Keys Answers R n) + (table : Table Keys Answers) (current : EnteredPacket p Q iv boundary) + (ref : Reference) (mentioned : ref ∈ addresses (.inl current)) + (fits : ref.shape.occupied ≤ ref.shape.leafWords) + (visited : (.inl current : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst)) : + ∃ frozen, PCSBCSSourceFrozenAccessor.lookup + (capturedRegistry addresses program current (fun key => table key.val)) ref = some frozen ∧ + PCSBCSSourceRootCapture.capture addresses ref program table = some frozen := by + obtain ⟨frozen,captured⟩ := PCSBCSSourceRootCapture.capture_exists addresses ref + (.inl current) mentioned program table visited + obtain ⟨events,_,equal,_⟩ := PCSBCSSourceRootCapture.capture_provenance + addresses ref program table frozen captured + refine ⟨frozen,?_,captured⟩ + rw [equal] + apply PCSBCSSourceFrozenAccessorStructural.lookup_freeze _ _ ref fits + rw [capturedRegistry_enabled addresses program current table ref mentioned,captured,equal] + +/-- Completeness of the real forward builder follows from individual checked +inverse successes, not from a supplied whole-prefix work certificate. -/ +theorem collect_complete {c : Config} (current : Coordinate c) + (saved : AnchoredHeaderCodec.Record) (registry : PCSBCSSourceFrozenAccessor.Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (stages : Array (Coordinate c)) (chronological : Array Pending) (count start : Nat) + (out : Array Reply) + (available : ∀ j, j < count → ∃ reply, + PCSBCSSourceFrozenReplies.inverseIndexed current saved registry messages past stages chronological (start+j) = some reply) : + ∃ result, PCSBCSSourceFrozenReplies.collect current saved registry messages past + stages chronological count start out = some result := by + induction count generalizing start out with + | zero => exact ⟨out,rfl⟩ + | succ count ih => + obtain ⟨reply,parsed⟩ := available 0 (by omega) + simp only [Nat.add_zero] at parsed + obtain ⟨result,rest⟩ := ih (start+1) (out.push reply.reply) (by + intro j earlier + simpa only [Nat.add_assoc,Nat.add_comm,Nat.add_left_comm] using available (j+1) (by omega)) + exact ⟨result,by simp only [PCSBCSSourceFrozenReplies.collect,parsed]; exact rest⟩ + +/-- Full padded source openings either agree with the actual captured suffix +and prove both status bits, or exhibit the existing ordinary primitive bad +event. No completeness or leaf-availability promise replaces this dichotomy. -/ +theorem captured_opening {R : Type} {n : Nat} + (addresses : Keys → List Reference) (program : Sampling Keys Answers R n) + (table : Table Keys Answers) (ref : Reference) (f : Frozen) + (captured : PCSBCSSourceRootCapture.capture addresses ref program table = some f) + (C : DuplexModeGame.PrimitiveOracle) (proof : MerkleTransport.PrunedMerklePaths) + (numLeaves : Nat) (queries : List Nat) (output : List MerkleTransport.RawPath) + (height : ref.shape.height = numLeaves.log2) + (auth : PublicMerkleLog.AuthenticLog C f.queryPrefix) + (accepted : PCSBCSMerkleFullSourceTransport.openSource (PublicMerkleLog.hash C) + proof ref.root numLeaves queries ref.shape.leafWords ref.shape.occupied = some output) + (bounds : ∀ path ∈ output, ∀ bytes ∈ + path.opening.inputs (MerkleTransport.hashing (PublicMerkleLog.hash C)), bytes.length < 2^64) : + List.Forall₂ (fun q path => f.raw[q]! = + (path.leafData.drop (ref.shape.leafWords-ref.shape.occupied)).toArray ∧ + (f.cells[q]?).map (fun cell => (cell.available,cell.paddingValid)) = some (true,true)) + queries output ∨ PublicMerkleBinding.OpenPrimitiveBad C f.queryPrefix ref.root output := by + obtain ⟨events,_,frozen,_⟩ := PCSBCSSourceRootCapture.capture_provenance + addresses ref program table f captured + obtain ⟨compact,_,opened⟩ := PCSBCSMerkleFullSourceTransport.openSource_refines + (PublicMerkleLog.hash C) proof ref.root numLeaves queries ref.shape.leafWords + ref.shape.occupied output accepted + have rows := PCSBCSMerkleSourceRows.pruned_opened_compact C f.queryPrefix auth ref.root + compact numLeaves ref.shape.leafWords ref.shape.occupied queries output opened bounds + rw [frozen] at rows ⊢ + simpa only [freeze,height] using rows + +/-- The actual successful inverse determines the exact strict answer array, +including all repeated query indexes. -/ +theorem replies_complete {c : Config} (current : Coordinate c) + (saved : AnchoredHeaderCodec.Record) (registry : PCSBCSSourceFrozenAccessor.Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (available : ∀ j, j < position current → ∃ reply, + PCSBCSSourceFrozenAccessor.inverseAt current saved registry messages past j = some reply) : + ∃ result, PCSBCSSourceFrozenReplies.replies current saved registry messages past = some result := by + apply collect_complete + intro j earlier + simpa only [Nat.zero_add,PCSBCSSourceFrozenReplies.inverseIndexed_eq] using available j earlier + +/-- Once actual checked earlier inverses succeed, the visited initial-root +address gives a successful captured caller snapshot. -/ +theorem fromCapture_complete {R : Type} {n : Nat} + (addresses : Keys → List Reference) (program : Sampling Keys Answers R n) + (table : Table Keys Answers) (current : EnteredPacket p Q iv boundary) + (ref : Reference) (input : PCSBCSCallerBinding.CallerInput p) + (saved : AnchoredHeaderCodec.Record) (mentioned : ref ∈ addresses (.inl current)) + (visited : (.inl current : Keys) ∈ ((Sampling.execute table program).2.map Sigma.fst)) + (available : ∀ j, j < position current.2.coord → ∃ reply, + PCSBCSSourceFrozenAccessor.inverseAt current.2.coord saved + (capturedRegistry addresses program current (fun key => table key.val)) + current.2.messages (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) j = some reply) : + ∃ data, fromCapture addresses ref program input saved current (fun key => table key.val) = some data := by + obtain ⟨root,captured⟩ := registry_exists addresses program table current ref mentioned visited + obtain ⟨answers,parsed⟩ := replies_complete current.2.coord saved + (capturedRegistry addresses program current (fun key => table key.val)) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val)) available + exact ⟨⟨input,PCSBCSRestorationHazard.incomingData p root.raw + (PCSBCSSourcePacketTape.ringPrefix current (fun key => table key.val)) + (PCSBCSSourcePacketTape.tape current (fun key => table key.val)) answers current.2.coord⟩,by + simp only [fromCapture,captured,parsed]; rfl⟩ + +#print axioms address_packet +#print axioms phaseReferences_prefix +#print axioms phaseReference_member +#print axioms registry_exists +#print axioms collect_complete +#print axioms captured_opening +#print axioms replies_complete +#print axioms fromCapture_complete +#print axioms foldReference_member +#print axioms lookup_exists +end Whir.PCSBCSCapturedSourceTransport diff --git a/verification/whir/Whir/PCSBCSChallengeOracleChain.lean b/verification/whir/Whir/PCSBCSChallengeOracleChain.lean new file mode 100644 index 000000000..161bbddd2 --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleChain.lean @@ -0,0 +1,139 @@ +import Whir.PCSBCSChallengeOracle + +/-! A separate 192-bit challenge-chain birthday calculation. It is not a +source-history collision estimate and is not charged by the 256-bit duplex +coupling theorem. It applies only when an actual compiler uses E-valued chaining +answers. Every adaptive request and repeated query is retained. -/ +set_option autoImplicit false +namespace Whir.PCSBCSChallengeOracle +open Concrete FiatShamirGame TypedOracleCompiler +open scoped BigOperators + +private theorem uniform_targets (seen : Finset E) : + average (fun a : E => if a ∈ seen then (1:ℚ) else 0) = seen.card / (2^192 : ℚ) := by + classical + simp [average, FieldModel.card_E] + norm_num + +/-- Lazy chain collision monitor. Cache hits return the old answer; only a +fresh query can collide with an earlier distinct-input output. -/ +noncomputable def chainRisk {K R : Type*} [DecidableEq K] {n : Nat} : + Sampling K (fun _ => E) R n → (K → Option E) → Finset E → ℚ + | .ret _, _, _ => 0 + | .draw key next, cache, seen => + match cache key with + | some a => chainRisk (next a) cache seen + | none => average (fun a : E => if a ∈ seen then 1 + else chainRisk (next a) (TypedFiatShamirGame.put cache key a) (insert a seen)) + +def chainLedger (remaining previous : Nat) : ℚ := + ((remaining : ℚ)*previous + remaining*(remaining-1)/2) / 2^192 + +private theorem chainLedger_nonneg (remaining previous : Nat) : + 0 ≤ chainLedger remaining previous := by + cases remaining with + | zero => simp [chainLedger] + | succ n => unfold chainLedger; simp only [Nat.cast_add, Nat.cast_one, add_sub_cancel_right]; positivity + +private theorem chainLedger_step (remaining previous : Nat) : + chainLedger (remaining+1) previous = + (previous : ℚ)/2^192 + chainLedger remaining (previous+1) := by + unfold chainLedger + push_cast + ring + +theorem chainRisk_bound {K R : Type*} [DecidableEq K] {n : Nat} + (p : Sampling K (fun _ => E) R n) (cache : K → Option E) (seen : Finset E) : + chainRisk p cache seen ≤ chainLedger n seen.card := by + classical + induction p generalizing cache seen with + | ret value => exact chainLedger_nonneg _ _ + | @draw n key next ih => + cases hit : cache key with + | some a => + simp only [chainRisk, hit] + have step := chainLedger_step n seen.card + have bound := ih a cache seen + have mono : chainLedger n seen.card ≤ chainLedger n (seen.card+1) := by + unfold chainLedger; push_cast; have hn : (0:ℚ) ≤ n := by positivity + have hd : (0:ℚ) < 2^192 := by positivity + apply (div_le_div_iff_of_pos_right hd).mpr + nlinarith + have positive : (0:ℚ) ≤ (seen.card:ℚ)/2^192 := by positivity + rw [step] + linarith + | none => + simp only [chainRisk, hit] + calc + _ ≤ average (fun a : E => (if a ∈ seen then (1:ℚ) else 0) + + chainLedger n (seen.card+1)) := by + apply average_mono + intro a + by_cases bad : a ∈ seen + · simp only [bad, ↓reduceIte] + have nonneg := chainLedger_nonneg n (seen.card+1) + linarith + · have bound := ih a (TypedFiatShamirGame.put cache key a) (insert a seen) + simpa only [bad, ↓reduceIte, zero_add, Finset.card_insert_of_notMem bad] using bound + _ = (seen.card:ℚ)/2^192 + chainLedger n (seen.card+1) := by + rw [average_add, uniform_targets, average_const] + _ = _ := (chainLedger_step n seen.card).symm + +/-- An actual Boolean event, not an assumed loss bound. -/ +noncomputable def chainAlarm {K R : Type*} [DecidableEq K] {n : Nat} : + (K → E) → Sampling K (fun _ => E) R n → (K → Option E) → Finset E → Bool + | _, .ret _, _, _ => false + | table, .draw key next, cache, seen => + match cache key with + | some a => chainAlarm table (next a) cache seen + | none => if table key ∈ seen then true else + chainAlarm table (next (table key)) + (TypedFiatShamirGame.put cache key (table key)) (insert (table key) seen) + +theorem chainAlarm_table_eq_risk {K R : Type*} [Fintype K] [DecidableEq K] {n : Nat} + (p : Sampling K (fun _ => E) R n) (cache : K → Option E) (seen : Finset E) : + average (fun table : K → E => + if chainAlarm (RawOracleCoupling.overlay cache table) p cache seen then (1:ℚ) else 0) = + chainRisk p cache seen := by + induction p generalizing cache seen with + | ret value => simp [chainAlarm, chainRisk, average_const] + | draw key next ih => + cases hit : cache key with + | some a => simp [chainAlarm, chainRisk, hit, ih] + | none => + rw [RawOracleCoupling.overlay_average cache key hit + (fun table => if chainAlarm table (.draw key next) cache seen then (1:ℚ) else 0)] + simp only [chainRisk, hit] + apply congrArg average + funext a + by_cases bad : a ∈ seen + · simp [chainAlarm, RawOracleCoupling.overlay, hit, bad, average_const] + · rw [← ih a (TypedFiatShamirGame.put cache key a) (insert a seen)] + simp only [bad, ↓reduceIte] + apply congrArg average + funext table + simp [chainAlarm, RawOracleCoupling.overlay, TypedFiatShamirGame.put_self, hit, bad] + +/-- Derived 192-bit term, deliberately separate from duplexModeLoss. The +sharper Q(Q-1)/2 term is proved en route; Q² is a conservative exact expression. -/ +theorem actual_chain_collision_bound {K R : Type*} [Fintype K] [DecidableEq K] {Q : Nat} + (p : Sampling K (fun _ => E) R Q) : + average (fun table : K → E => if chainAlarm table p (fun _ => none) ∅ then (1:ℚ) else 0) ≤ + (Q:ℚ)^2 / 2^192 := by + have exactRisk := chainAlarm_table_eq_risk p (fun _ => none) ∅ + simp only [RawOracleCoupling.overlay_empty] at exactRisk + have bound := chainRisk_bound p (fun _ => none) ∅ + simp only [Finset.card_empty] at bound + calc + _ = chainRisk p (fun _ => none) ∅ := exactRisk + _ ≤ chainLedger Q 0 := bound + _ ≤ (Q:ℚ)^2/2^192 := by + unfold chainLedger + simp only [Nat.cast_zero, mul_zero, zero_add] + apply (div_le_div_iff_of_pos_right (by positivity : (0:ℚ) < 2^192)).mpr + have nonneg : (0:ℚ) ≤ Q := by positivity + nlinarith + +#print axioms chainAlarm_table_eq_risk +#print axioms actual_chain_collision_bound +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleDomains.lean b/verification/whir/Whir/PCSBCSChallengeOracleDomains.lean new file mode 100644 index 000000000..96add2a5c --- /dev/null +++ b/verification/whir/Whir/PCSBCSChallengeOracleDomains.lean @@ -0,0 +1,52 @@ +import Whir.PCSBCSChallengeOracleSource + +/-! Separate ideal challenge/Merkle domains are proved from the actual #552 +node tag, not inferred from a purpose label. Actual tag-zero Merkle compression +inputs use the independent simulator seed table, never a challenge packet RO +request. Arbitrary other primitive observations are still allowed. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSChallengeOracle +open FiatShamirGame DuplexFraming DuplexModeGame DuplexPublicSimulator + +/-- Tag zero cannot be a #552 output/commitment/PoW terminal. -/ +theorem merkle_tag_zero_not_terminal (input : Node) (zero : tag input = 0) : + ¬isTerminal input := by + simp [isTerminal, zero] + +/-- For all logs, including malformed/adversarial logs, a Merkle node cannot +recognize a challenge construction key. Cache hits remain ordinary replays. -/ +theorem merkle_no_challenge_key (Q : Nat) (log : PublicLog) (input : Node) + (zero : tag input = 0) : privateKey Q log input = none := by + have notTerminal := merkle_tag_zero_not_terminal input zero + simp [privateKey, recognized, notTerminal] + +/-- Fresh Merkle-domain calls query only the independent seed table. They +contribute zero PRIVATE challenge-RO requests, but still cost one PUBLIC +compression call and retain their entire observed 256-bit answer. -/ +theorem fresh_merkle_ideal_answer (Q : Nat) (ro : RawKey Q → Digest32) + (seed : Seed) (log : PublicLog) (input : Node) + (zero : tag input = 0) (fresh : lookup log input = none) : + runRO ro ((simulator Q).answer ⟨seed,log⟩ input) = + ((⟨seed,observe log input (seed input)⟩,seed input),0) := by + simp [simulator, fresh, merkle_no_challenge_key Q log input zero, runRO] + +open Classical in +/-- The whole ideal mixed table splits exactly into an independent seed table +and a challenge raw RO, preserving arbitrary payoffs of both domains. -/ +theorem separate_domain_table (Q : Nat) + (payoff : Seed × (RawKey Q → Digest32) → ℚ) : + letI := seedFintype + letI := rawOracleFintype Q + letI := PublicCompressionCouplingMixed.mixedKeyFintype Q + average (fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + payoff (PublicCompressionCouplingMixed.tableEquiv Q table)) = average payoff := by + let := seedFintype + let := rawOracleFintype Q + let := PublicCompressionCouplingMixed.mixedKeyFintype Q + exact RawOracleCoupling.average_equiv (PublicCompressionCouplingMixed.tableEquiv Q) payoff + +#print axioms merkle_no_challenge_key +#print axioms fresh_merkle_ideal_answer +#print axioms separate_domain_table +end Whir.PCSBCSChallengeOracle diff --git a/verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean b/verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean index 8efef16c5..6c1c1adec 100644 --- a/verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean +++ b/verification/whir/Whir/PCSBCSChallengeOracleRestoration.lean @@ -29,14 +29,14 @@ noncomputable local instance (key : Key p Q iv boundary) : Fintype (Answer p Q i | .inr _ => inferInstance abbrev Builder := (current : EnteredPacket p Q iv boundary) → - current.OtherValues → (∀ earlier : current.Earlier, Raw earlier.val) → CallerData p + current.OtherValues → (∀ earlier : current.Earlier, Raw earlier.val) → Option (CallerData p) open Classical in noncomputable def model (build : Builder p Q iv boundary) : PCSStateRestoration.Latent.NodeModel (Key p Q iv boundary) (Answer p Q iv boundary) (Option (CallerData p)) where reconstruct key other := match key with - | .inl current => some (current.metadataFromOther (build current) other) + | .inl current => current.metadataFromOther (build current) other | .inr _ => none before data key := match key, data with | .inl current, some caller => (callerCertificate p).before caller current.2.coord @@ -72,14 +72,19 @@ theorem conditional_hazard (build : Builder p Q iv boundary) : intro key other undoomed cases key with | inl current => - change (callerCertificate p).before - (current.metadataFromOther (build current) other) current.2.coord = false at undoomed - have bound := whole_packet_fiber p Q iv boundary - (current.metadataFromOther (build current) other) current undoomed - unfold Soundness.uniformProb at bound ⊢ - simp only [model,Fintype.card_eq_nat_card] at bound ⊢ - convert bound using 1 - congr 2 + cases recovered : current.metadataFromOther (build current) other with + | none => + simp only [model,recovered,Bool.false_eq_true,Finset.filter_false, + Soundness.uniformProb,Finset.card_empty,Nat.cast_zero,zero_div] + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + | some caller => + simp only [model,recovered] at undoomed + change (callerCertificate p).before caller current.2.coord = false at undoomed + have bound := whole_packet_fiber p Q iv boundary caller current undoomed + unfold Soundness.uniformProb at bound ⊢ + simp only [model,recovered,Fintype.card_eq_nat_card] at bound ⊢ + exact bound | inr garbage => simp only [model,Bool.false_eq_true,Finset.filter_false,Soundness.uniformProb, Finset.card_empty,Nat.cast_zero,zero_div] diff --git a/verification/whir/Whir/PCSBCSConstructionReplayTrace.lean b/verification/whir/Whir/PCSBCSConstructionReplayTrace.lean new file mode 100644 index 000000000..c436a3178 --- /dev/null +++ b/verification/whir/Whir/PCSBCSConstructionReplayTrace.lean @@ -0,0 +1,197 @@ +import Whir.PCSBCSPublicCallerAnswers + +/-! Physical replay for the actual public-compression compiler. `queryTrace`, +`primitiveLog`, and the prefixes in `AskBoundary` are chronological execute +traces. A boundary prefix includes the current query's complete physical plan; +it is not a strictly-prior-query log. Newest-first histories are obtained only +by the explicit reversal lemmas below. No availability or security hypothesis +is used: plan membership is derived from compilation along the real run. -/ +set_option autoImplicit false +namespace Whir.PCSBCSConstructionReplayTrace +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler PublicCompressionProgram PublicMerkleLog + +/-- Actual Sampling calls of one query, in chronological order. -/ +def queryTrace (C : PrimitiveOracle) (iv : Digest32) (q : Query) : PublicLog := + toLog (Sampling.execute C (queryCalls iv q)).2 + +theorem queryTrace_authentic (C : PrimitiveOracle) (iv : Digest32) (q : Query) : + AuthenticLog C (queryTrace C iv q) := execute_authentic C _ + +/-- The compiler emits this query's calls before its actual adaptive continuation. -/ +theorem primitiveLog_ask {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (q : Query) (next : Digest32 → Program R) (Q : Nat) + (counted : Counts Q (.ask q next)) : + primitiveLog C iv (.ask q next) Q counted = queryTrace C iv q ++ + primitiveLog C iv (next (realAnswer C iv q)) (Q-q.cost) (counted.2 _) := by + simp only [primitiveLog,PublicCompressionProgram.compile,Sampling.execute_pad, + Sampling.execute_bind,execute_mapResult,queryCalls_eval,toLog,List.map_append,queryTrace] + +/-- Each public observation has its real answer, without an assumed soundness contract. -/ +theorem observation_answer {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (o : Observation) + (observed : o ∈ (runReal C iv p).view.observations) : + o.answer = realAnswer C iv o.query := by + induction p with + | done => simp [runReal] at observed + | ask q next ih => + simp only [runReal,prepend,List.mem_cons] at observed + rcases observed with rfl | observed + · rfl + · exact ih _ observed + +/-- Actual compile recursion supplies every physical call of every observed query. -/ +theorem observation_trace_membership {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (counted : Counts Q p) (o : Observation) + (observed : o ∈ (runReal C iv p).view.observations) : + ∀ event ∈ queryTrace C iv o.query, event ∈ primitiveLog C iv p Q counted := by + induction p generalizing Q with + | done => simp [runReal] at observed + | ask q next ih => + rw [primitiveLog_ask] + simp only [runReal,prepend,List.mem_cons] at observed + rcases observed with rfl | observed + · exact fun _ member => List.mem_append_left _ member + · intro event member + exact List.mem_append_right _ (ih _ _ (counted.2 _) observed event member) + +/-- Literal plan membership is a consequence of compilation, not an input contract. -/ +theorem construction_plan_membership {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (counted : Counts Q p) + (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) (d : Digest32) + (observed : (⟨.construction coordinate valid,d⟩ : Observation) ∈ + (runReal C iv p).view.observations) : + ∀ event ∈ toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan coordinate))).2, + event ∈ primitiveLog C iv p Q counted := + observation_trace_membership C iv p Q counted _ observed + +/-- Every construction observation is recovered from the compiler's full physical log. -/ +theorem construction_replay {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (counted : Counts Q p) + (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) (d : Digest32) + (observed : (⟨.construction coordinate valid,d⟩ : Observation) ∈ + (runReal C iv p).view.observations) : + PCSBCSPublicCallerAnswers.answer? (primitiveLog C iv p Q counted) iv coordinate = some d := by + have actual := observation_answer C iv p _ observed + change d = evalCoordinate (compressionOf C) iv coordinate at actual + rw [actual] + exact PCSBCSPublicCallerAnswers.answer_from_recorded_construction C _ + (primitiveLog_authentic C iv p Q counted) iv coordinate + (construction_plan_membership C iv p Q counted coordinate valid d observed) + +/-- A reached ask boundary of the real adaptive run. `before` contains only the +physical calls of earlier asks, chronologically; no future continuation is run +in constructing it. The current query's own calls are added for replay. -/ +inductive AskBoundary (C : PrimitiveOracle) (iv : Digest32) {R : Type} : + Program R → PublicLog → Query → (Digest32 → Program R) → Prop where + | here (q : Query) (next : Digest32 → Program R) : + AskBoundary C iv (.ask q next) [] q next + | step (head : Query) (tail : Digest32 → Program R) + {before : PublicLog} {q : Query} {next : Digest32 → Program R} + (reached : AskBoundary C iv (tail (realAnswer C iv head)) before q next) : + AskBoundary C iv (.ask head tail) (queryTrace C iv head ++ before) q next + +/-- Every actual observation has a reached boundary, including repeated queries. -/ +theorem observation_boundary {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (o : Observation) + (observed : o ∈ (runReal C iv p).view.observations) : + ∃ before next, AskBoundary C iv p before o.query next ∧ + o.answer = realAnswer C iv o.query := by + induction p with + | done => simp [runReal] at observed + | ask q tail ih => + simp only [runReal,prepend,List.mem_cons] at observed + rcases observed with rfl | observed + · exact ⟨[],tail,.here q tail,rfl⟩ + · obtain ⟨before,next,reached,actual⟩ := ih _ observed + exact ⟨queryTrace C iv q ++ before,next,.step q tail reached,actual⟩ + +/-- The reached boundary gives an exact chronological split of the actual +compiled trace, with a Counts-certified actual remainder. -/ +theorem boundary_physical_split {R : Type} (C : PrimitiveOracle) (iv : Digest32) + {p : Program R} {before : PublicLog} {q : Query} {next : Digest32 → Program R} + (reached : AskBoundary C iv p before q next) (Q : Nat) (counted : Counts Q p) : + ∃ (remaining : Nat) (restCounted : Counts remaining (next (realAnswer C iv q))), + primitiveLog C iv p Q counted = (before ++ queryTrace C iv q) ++ + primitiveLog C iv (next (realAnswer C iv q)) remaining restCounted := by + induction reached generalizing Q with + | here q next => + refine ⟨Q-q.cost,counted.2 _,?_⟩ + simpa only [List.nil_append] using (primitiveLog_ask C iv q next Q counted) + | step head tail reached ih => + obtain ⟨remaining,restCounted,split⟩ := ih (Q-head.cost) (counted.2 _) + refine ⟨remaining,restCounted,?_⟩ + rw [primitiveLog_ask,split] + simp only [List.append_assoc] + +/-- Earlier physical calls are authenticated by execute recursion alone. -/ +theorem boundary_before_authentic {R : Type} (C : PrimitiveOracle) (iv : Digest32) + {p : Program R} {before : PublicLog} {q : Query} {next : Digest32 → Program R} + (reached : AskBoundary C iv p before q next) : AuthenticLog C before := by + induction reached with + | here => intro n d member; cases member + | step head tail reached ih => + intro n d member + rcases List.mem_append.mp member with member | member + · exact queryTrace_authentic C iv head n d member + · exact ih n d member + +/-- Replay uses only earlier calls and the current query's own plan. Neither +Counts, the remainder, nor any future answers are needed by this theorem. -/ +theorem boundary_prefix_replay {R : Type} (C : PrimitiveOracle) (iv : Digest32) + {p : Program R} {before : PublicLog} {coordinate : Coordinate} + {valid : DuplexEncoding.Admissible coordinate} {next : Digest32 → Program R} + (reached : AskBoundary C iv p before (.construction coordinate valid) next) : + PCSBCSPublicCallerAnswers.answer? + (before ++ queryTrace C iv (.construction coordinate valid)) iv coordinate = + some (evalCoordinate (compressionOf C) iv coordinate) := by + apply PCSBCSPublicCallerAnswers.answer_from_recorded_construction C + · intro n d member + rcases List.mem_append.mp member with member | member + · exact boundary_before_authentic C iv reached n d member + · exact queryTrace_authentic C iv _ n d member + · exact fun _ member => List.mem_append_right _ member + +/-- Explicit conversion: chronological membership is unchanged by reversal. -/ +theorem reverse_membership (log : PublicLog) (event : Node × Digest32) : + event ∈ log.reverse ↔ event ∈ log := List.mem_reverse + +/-- Reversal converts the full chronological split to a newest-first split. +The future is the left segment, and is excluded from the boundary history. -/ +theorem boundary_newest_first_split {R : Type} (C : PrimitiveOracle) (iv : Digest32) + {p : Program R} {before : PublicLog} {q : Query} {next : Digest32 → Program R} + (reached : AskBoundary C iv p before q next) (Q : Nat) (counted : Counts Q p) : + ∃ (remaining : Nat) (restCounted : Counts remaining (next (realAnswer C iv q))), + (primitiveLog C iv p Q counted).reverse = + (primitiveLog C iv (next (realAnswer C iv q)) remaining restCounted).reverse ++ + (queryTrace C iv q).reverse ++ before.reverse := by + obtain ⟨remaining,restCounted,split⟩ := boundary_physical_split C iv reached Q counted + refine ⟨remaining,restCounted,?_⟩ + rw [split] + simp only [List.reverse_append,List.append_assoc] + +/-- Actual boundary replay also succeeds in newest-first scanner order. This +is a proved reversal conversion, not a chronological/strictly-earlier conflation. -/ +theorem boundary_newest_first_replay {R : Type} (C : PrimitiveOracle) (iv : Digest32) + {p : Program R} {before : PublicLog} {coordinate : Coordinate} + {valid : DuplexEncoding.Admissible coordinate} {next : Digest32 → Program R} + (reached : AskBoundary C iv p before (.construction coordinate valid) next) : + PCSBCSPublicCallerAnswers.answer? + (before ++ queryTrace C iv (.construction coordinate valid)).reverse iv coordinate = + some (evalCoordinate (compressionOf C) iv coordinate) := by + apply PCSBCSPublicCallerAnswers.answer_from_recorded_construction C + · intro n d member + rcases List.mem_append.mp (List.mem_reverse.mp member) with member | member + · exact boundary_before_authentic C iv reached n d member + · exact queryTrace_authentic C iv _ n d member + · intro event member + exact List.mem_reverse.mpr (List.mem_append_right _ member) + +#print axioms construction_plan_membership +#print axioms construction_replay +#print axioms observation_boundary +#print axioms boundary_physical_split +#print axioms boundary_prefix_replay +#print axioms boundary_newest_first_split +#print axioms boundary_newest_first_replay +end Whir.PCSBCSConstructionReplayTrace diff --git a/verification/whir/Whir/PCSBCSCoordinateCodecCost.lean b/verification/whir/Whir/PCSBCSCoordinateCodecCost.lean new file mode 100644 index 000000000..41d13596a --- /dev/null +++ b/verification/whir/Whir/PCSBCSCoordinateCodecCost.lean @@ -0,0 +1,475 @@ +import Whir.PCSBCSSourceCoordinateDecoder + +/-! Concrete canonical coordinate codec resource instrumentation. Read-run +recognition, block loads, list reconstruction and exact equalities are charged +as fixed-byte/list operations; no compression or metadata oracle is invoked. -/ +set_option autoImplicit false +namespace Whir.PCSBCSCoordinateCodecCost +open Concrete FiatShamirGame DuplexRefinement DuplexEncoding DuplexModeGame + +/-- Number of frames plus payload bytes. Nonce payloads occupy 24 bytes. -/ +def frameUnits : Frame → Nat + | .absorb _ bytes => bytes.length+1 + | .nonce _ _ _ => 25 + +def bodyUnits (frames : List Frame) : Nat := (frames.map frameUnits).sum + +def readRunCount (first : Bool) : List Instruction → Option (Nat × List Byte × List Instruction) × Nat + | [] => (none,1) + | (b,t)::rest => + if readRole t = role first true then + (some (readPrevious t,takeBytes b (readLength t),rest),1024) + else if readRole t = role first false then + let prior := readRunCount false rest + (prior.1.map (fun p => (readPrevious t,takeBytes b (readLength t) ++ p.2.1,p.2.2)),prior.2+1024) + else (none,16) + +theorem readRunCount_value (first : Bool) (xs : List Instruction) : + (readRunCount first xs).1 = readRun first xs := by + induction xs generalizing first with + | nil => rfl + | cons pair rest ih => + rcases pair with ⟨b,t⟩ + simp only [readRunCount,readRun] + split + · rfl + · split + · rw [ih] + cases readRun false rest <;> rfl + · rfl + +theorem readRunCount_bound (first : Bool) (xs : List Instruction) : + (readRunCount first xs).2 ≤ 1024*(xs.length+1) := by + induction xs generalizing first with + | nil => simp [readRunCount] + | cons pair rest ih => + rcases pair with ⟨b,t⟩ + have prior := ih false + simp only [readRunCount,List.length_cons] + split + · omega + · split <;> dsimp only <;> omega + +theorem readRun_bytes (first : Bool) (xs : List Instruction) (p : Nat) (bs : List Byte) + (tail : List Instruction) (parsed : readRun first xs = some (p,bs,tail)) : + bs.length ≤ 64*(xs.length-tail.length) := by + induction xs generalizing first p bs tail with + | nil => simp [readRun] at parsed + | cons pair rest ih => + rcases pair with ⟨b,t⟩ + have takeBound : (takeBytes b (readLength t)).length ≤ 64 := by + simp [takeBytes,blockBytes] + simp only [readRun] at parsed + split at parsed + · cases parsed; simpa using takeBound + · split at parsed + · cases h : readRun false rest with + | none => simp [h] at parsed + | some value => + rcases value with ⟨old,bytes,remaining⟩ + have prior := ih false old bytes remaining h + have shorter := readRun_shorter false rest old bytes remaining h + simp only [h,Option.some.injEq] at parsed + obtain ⟨rfl,rfl,rfl⟩ := parsed + simp only [List.length_append,List.length_cons] + omega + · contradiction + +def readBodyCount : List Instruction → Option (List Frame × Terminal) × Nat + | [] => (none,1) + | [(b,t)] => (readBody [(b,t)],2048) + | (b,t)::next::rest => + if readRole t = 9 then + let later := readBodyCount (next::rest) + (later.1.map (fun p => (.nonce (wordAt b 24) (wordAt b 32) + (fun i => b ⟨i.val,by omega⟩)::p.1,p.2)),later.2+2048) + else + let run := readRunCount true ((b,t)::next::rest) + match h : run.1 with + | none => (none,run.2+16) + | some (previous,bytes,tail) => + let later := readBodyCount tail + (later.1.map (fun p => (.absorb previous bytes::p.1,p.2)),run.2+later.2+16) +termination_by xs => xs.length +decreasing_by + · simp_wf + · have hs := readRun_shorter true _ _ _ _ (readRunCount_value _ _ ▸ h) + simp_all only [List.length_cons] + +theorem readBodyCount_value (xs : List Instruction) : + (readBodyCount xs).1 = readBody xs := by + induction xs using (measure List.length).wf.induction with + | h xs ih => + cases xs with + | nil => simp only [readBodyCount,readBody] + | cons pair rest => + rcases pair with ⟨b,t⟩ + cases rest with + | nil => simp only [readBodyCount] + | cons next rest => + rw [readBodyCount,readBody] + split + · dsimp only + rw [ih (next::rest) (by exact Nat.lt_succ_self _)] + cases readBody (next::rest) <;> rfl + · dsimp only + rw [readRunCount_value] + cases h : readRun true ((b,t)::next::rest) with + | none => rfl + | some value => + rcases value with ⟨previous,bytes,tail⟩ + have shorter := readRun_shorter true _ _ _ _ h + dsimp only + rw [ih tail shorter] + cases readBody tail <;> rfl + +theorem readBodyCount_bound (xs : List Instruction) : + (readBodyCount xs).2 ≤ 4096*(xs.length+1)*(xs.length+1) := by + induction xs using (measure List.length).wf.induction with + | h xs ih => + cases xs with + | nil => simp [readBodyCount] + | cons pair rest => + rcases pair with ⟨b,t⟩ + cases rest with + | nil => simp [readBodyCount] + | cons next rest => + have prior := ih (next::rest) (by exact Nat.lt_succ_self _) + have runCap := readRunCount_bound true ((b,t)::next::rest) + rw [readBodyCount] + split + · dsimp only; simp only [List.length_cons] at *; nlinarith + · dsimp only + cases h : (readRunCount true ((b,t)::next::rest)).1 with + | none => simp only [List.length_cons] at *; nlinarith + | some value => + rcases value with ⟨previous,bytes,tail⟩ + have shorter := readRun_shorter true _ _ _ _ (readRunCount_value _ _ ▸ h) + have later := ih tail shorter + simp only [List.length_cons] at * + have smaller : tail.length+1 ≤ rest.length+2 := by omega + nlinarith + +theorem readBody_units (xs : List Instruction) (fs : List Frame) (terminal : Terminal) + (parsed : readBody xs = some (fs,terminal)) : bodyUnits fs ≤ 65*xs.length := by + induction xs using (measure List.length).wf.induction generalizing fs terminal with + | h xs ih => + cases xs with + | nil => simp [readBody] at parsed + | cons pair rest => + rcases pair with ⟨b,t⟩ + cases rest with + | nil => + simp only [readBody] at parsed + split at parsed + · cases parsed; simp [bodyUnits] + · split at parsed + · cases parsed; simp [bodyUnits] + · split at parsed + · cases parsed; simp [bodyUnits] + · contradiction + | cons next rest => + rw [readBody] at parsed + split at parsed + · cases h : readBody (next::rest) with + | none => simp [h] at parsed + | some value => + rcases value with ⟨frames,ending⟩ + have prior := ih (next::rest) (by exact Nat.lt_succ_self _) frames ending h + simp only [h,Option.some.injEq] at parsed + obtain ⟨rfl,rfl⟩ := parsed + simp only [bodyUnits,List.map_cons,List.sum_cons,frameUnits,List.length_cons] at * + omega + · split at parsed + · rename_i previous bytes tail hr + cases hb : readBody tail with + | none => simp [hb] at parsed + | some value => + rcases value with ⟨frames,ending⟩ + have shorter := readRun_shorter true _ _ _ _ hr + have prior := ih tail shorter frames ending hb + have bytesCap := readRun_bytes true _ _ _ _ hr + simp only [hb,Option.some.injEq] at parsed + obtain ⟨rfl,rfl⟩ := parsed + simp only [bodyUnits,List.map_cons,List.sum_cons,frameUnits,List.length_cons] at * + omega + · contradiction + +def chunksCount (first : Bool) (previous : Nat) (pending : List Byte) : + List Byte → List Instruction × Nat + | [] => (if pending = [] then [] else [chunk first true previous pending],pending.length+1024) + | b::bs => + if pending.length = 64 then + let later := chunksCount false 0 [b] bs + (chunk first false previous pending::later.1,pending.length+1024+later.2) + else + let later := chunksCount first previous (pending++[b]) bs + (later.1,2*pending.length+4+later.2) + +theorem chunksCount_value (first : Bool) (previous : Nat) (pending bs : List Byte) : + (chunksCount first previous pending bs).1 = chunks first previous pending bs := by + induction bs generalizing first previous pending with + | nil => rfl + | cons b bs ih => + simp only [chunksCount,chunks] + split <;> simp [ih] + +theorem chunksCount_bound (first : Bool) (previous : Nat) (pending bs : List Byte) + (small : pending.length ≤ 64) : + (chunksCount first previous pending bs).2 ≤ 2048*(bs.length+1) := by + induction bs generalizing first previous pending with + | nil => simp only [chunksCount,List.length_nil]; omega + | cons b bs ih => + simp only [chunksCount,List.length_cons] + split + · have later := ih false 0 [b] (by simp); dsimp only; omega + · have nextSmall : (pending++[b]).length ≤ 64 := by simp; omega + have later := ih first previous (pending++[b]) nextSmall + dsimp only + omega + +theorem chunks_length (first : Bool) (previous : Nat) (pending bs : List Byte) : + (chunks first previous pending bs).length ≤ bs.length+1 := by + induction bs generalizing first previous pending with + | nil => simp only [chunks,List.length_nil]; split <;> simp + | cons b bs ih => + simp only [chunks,List.length_cons] + split + · have later := ih false 0 [b]; simp only [List.length_cons]; omega + · exact (ih first previous (pending++[b])).trans (by omega) + +def framePlanCount : Frame → List Instruction × Nat + | .absorb previous bytes => chunksCount true previous [] bytes + | .nonce previous bits nonce => ([(nonceBlock nonce previous bits,UInt64.ofNat (9*2^56))],2048) + +theorem framePlanCount_value (f : Frame) : (framePlanCount f).1 = framePlan f := by + cases f <;> simp [framePlanCount,framePlan,chunksCount_value] + +def framesPlanCount : List Frame → List Instruction × Nat + | [] => ([],1) + | f::rest => + let first := framePlanCount f + let later := framesPlanCount rest + (first.1++later.1,first.2+later.2+first.1.length+2) + +theorem framesPlanCount_value (fs : List Frame) : + (framesPlanCount fs).1 = fs.flatMap framePlan := by + induction fs with + | nil => rfl + | cons f fs ih => simp only [framesPlanCount,List.flatMap_cons,framePlanCount_value,ih] + +theorem framePlan_length (f : Frame) : (framePlan f).length ≤ frameUnits f := by + cases f with + | absorb previous bytes => exact chunks_length true previous [] bytes + | nonce previous bits nonce => simp [framePlan,frameUnits] + +theorem framesPlanCount_bound (fs : List Frame) : + (framesPlanCount fs).2 ≤ 4096*(bodyUnits fs+1) := by + induction fs with + | nil => simp [framesPlanCount,bodyUnits] + | cons f fs ih => + have positive : 1 ≤ frameUnits f := by cases f <;> simp [frameUnits] + have size := framePlan_length f + have first : (framePlanCount f).2 ≤ 2048*frameUnits f := by + cases f with + | absorb previous bytes => exact chunksCount_bound true previous [] bytes (by simp) + | nonce previous bits nonce => simp [framePlanCount,frameUnits] + simp only [framesPlanCount,framePlanCount_value,bodyUnits,List.map_cons,List.sum_cons] at * + nlinarith + +theorem framesPlan_length (fs : List Frame) : + (fs.flatMap framePlan).length ≤ bodyUnits fs := by + induction fs with + | nil => simp [bodyUnits] + | cons f fs ih => + have first := framePlan_length f + simp only [List.flatMap_cons,List.length_append,bodyUnits,List.map_cons,List.sum_cons] at * + omega + +def planCount (q : Coordinate) : List Instruction × Nat := + let frames := framesPlanCount q.history.frames + ((ByteCodec.pairBytes (q.history.domain,q.history.statement),UInt64.ofNat (2^56)):: + frames.1++[terminalPlan q.terminal],frames.2+frames.1.length+4096) + +theorem planCount_value (q : Coordinate) : (planCount q).1 = plan q := by + simp [planCount,plan,framesPlanCount_value] + +theorem planCount_bound (q : Coordinate) : + (planCount q).2 ≤ 8192*(bodyUnits q.history.frames+1) := by + have frames := framesPlanCount_bound q.history.frames + have size := framesPlan_length q.history.frames + unfold planCount + dsimp only + rw [framesPlanCount_value] + nlinarith + +def parseCount : List Instruction → Option Coordinate × Nat + | [] => (none,1) + | (b,t)::rest => + if readRole t = 1 then + let body := readBodyCount rest + (body.1.map (fun p => ⟨⟨(fun i => b ⟨i.val,by omega⟩), + (fun i => b ⟨i.val+32,by omega⟩),p.1⟩,p.2⟩),body.2+16) + else (none,16) + +theorem parseCount_value (xs : List Instruction) : (parseCount xs).1 = parse xs := by + cases xs with + | nil => rfl + | cons pair rest => + rcases pair with ⟨b,t⟩ + simp only [parseCount,parse] + split + · rw [readBodyCount_value] + cases readBody rest <;> rfl + · rfl + +theorem parseCount_bound (xs : List Instruction) : + (parseCount xs).2 ≤ 8192*(xs.length+1)*(xs.length+1) := by + cases xs with + | nil => simp [parseCount] + | cons pair rest => + rcases pair with ⟨b,t⟩ + have bound := readBodyCount_bound rest + simp only [parseCount,List.length_cons] + split <;> dsimp only <;> nlinarith + +theorem parse_units (xs : List Instruction) (q : Coordinate) (parsed : parse xs = some q) : + bodyUnits q.history.frames ≤ 65*xs.length := by + cases xs with + | nil => simp [parse] at parsed + | cons pair rest => + rcases pair with ⟨b,t⟩ + simp only [parse] at parsed + split at parsed + · cases h : readBody rest with + | none => simp [h] at parsed + | some value => + rcases value with ⟨frames,terminal⟩ + simp only [h,Option.some.injEq] at parsed + subst q + have bound := readBody_units rest frames terminal h + simp only [List.length_cons] + exact bound.trans (by omega) + · contradiction + +/-- Each list equality pays the full inspected input-volume upper charge, +including unequal lengths; success never trusts a truncating zip. -/ +def decodeCount (xs : List Instruction) : Option Coordinate × Nat := + let parsed := parseCount xs + match parsed.1 with + | none => (none,parsed.2) + | some q => + let reconstructed := planCount q + (if Admissible q ∧ reconstructed.1 = xs then some q else none, + parsed.2+reconstructed.2+65536*(xs.length+reconstructed.1.length+1)) + +theorem decodeCount_value (xs : List Instruction) : + (decodeCount xs).1 = decode xs := by + simp only [decodeCount,decode,parseCount_value] + cases parse xs <;> simp only [planCount_value] + +def codecPolynomial (n : Nat) : Nat := 2000000*(n+2)*(n+2) + +theorem decodeCount_bound (xs : List Instruction) : + (decodeCount xs).2 ≤ codecPolynomial xs.length := by + have parsing := parseCount_bound xs + unfold decodeCount + dsimp only + cases h : (parseCount xs).1 with + | none => unfold codecPolynomial; nlinarith + | some q => + have units := parse_units xs q (parseCount_value xs ▸ h) + have reconstruction := planCount_bound q + have size := framesPlan_length q.history.frames + have planSize : (planCount q).1.length ≤ bodyUnits q.history.frames+2 := by + rw [planCount_value] + simp only [plan,List.length_cons,List.length_append,List.length_nil] + omega + unfold codecPolynomial + nlinarith + +open DuplexFraming + +def modeKeyCount (iv : Digest32) (q : Coordinate) : Extracted × Nat := + let encoded := planCount q + (keyFromPlan iv encoded.1,encoded.2+16*encoded.1.length+4) + +theorem modeKeyCount_value (iv : Digest32) (q : Coordinate) : + (modeKeyCount iv q).1 = modeKey iv q := by + simp [modeKeyCount,modeKey,planCount_value] + +/-- Two exact raw-key comparisons share one reconstructed mode key. -/ +def decodeExtractedCount (iv : Digest32) (key : Extracted) : Option Coordinate × Nat := + let xs := extractedPlan key + let parsed := decodeCount xs + match parsed.1 with + | none => (none,parsed.2+8*(key.message.length+key.template.length)+1) + | some q => + let rebuilt := modeKeyCount iv q + (if key.message = rebuilt.1.message ∧ key.template = rebuilt.1.template then some q else none, + parsed.2+rebuilt.2+8*(key.message.length+key.template.length)+ + 65536*(key.message.length+key.template.length+ + rebuilt.1.message.length+rebuilt.1.template.length+1)) + +theorem decodeExtractedCount_value (iv : Digest32) (key : Extracted) : + (decodeExtractedCount iv key).1 = PCSBCSSourceCoordinateDecoder.decodeExtracted iv key := by + simp only [decodeExtractedCount,PCSBCSSourceCoordinateDecoder.decodeExtracted,decodeCount_value] + cases decode (extractedPlan key) <;> simp only [modeKeyCount_value] + +def extractedPolynomial (n : Nat) : Nat := 8000000*(n+2)*(n+2) + +theorem decodeExtractedCount_bound (iv : Digest32) (key : Extracted) (n : Nat) + (messageCap : key.message.length ≤ n) (templateCap : key.template.length ≤ n) : + (decodeExtractedCount iv key).2 ≤ extractedPolynomial n := by + have xsCap : (extractedPlan key).length ≤ n := by + simp only [extractedPlan,List.length_reverse,List.length_map,List.length_zip] + omega + have parsing := decodeCount_bound (extractedPlan key) + unfold decodeExtractedCount + dsimp only + cases h : (decodeCount (extractedPlan key)).1 with + | none => unfold codecPolynomial at parsing; unfold extractedPolynomial; nlinarith + | some q => + have decoded : decode (extractedPlan key) = some q := decodeCount_value _ ▸ h + have exactPlan := (decode_sound decoded).2 + have parsed : parse (extractedPlan key) = some q := by + unfold decode at decoded + cases hp : parse (extractedPlan key) with + | none => simp [hp] at decoded + | some candidate => + simp only [hp] at decoded + split at decoded + · cases decoded; rfl + · contradiction + have units := parse_units _ _ parsed + have rebuild := planCount_bound q + have planSize : (planCount q).1.length ≤ n := by + rw [planCount_value,exactPlan] + exact xsCap + have lengths : (modeKeyCount iv q).1.message.length ≤ n ∧ + (modeKeyCount iv q).1.template.length ≤ n := by + simp only [modeKeyCount_value,modeKey,keyFromPlan,List.length_map,List.length_reverse,exactPlan] + exact ⟨xsCap,xsCap⟩ + change (decodeCount (extractedPlan key)).2 + (modeKeyCount iv q).2 + + 8*(key.message.length+key.template.length) + + 65536*(key.message.length+key.template.length+ + (modeKeyCount iv q).1.message.length+(modeKeyCount iv q).1.template.length+1) ≤ _ + have rebuildingCost : (modeKeyCount iv q).2 ≤ 8192*(bodyUnits q.history.frames+1)+16*n+4 := by + unfold modeKeyCount + dsimp only + omega + unfold codecPolynomial at parsing + unfold extractedPolynomial + nlinarith + +#print axioms chunksCount_value +#print axioms decodeCount_value +#print axioms decodeCount_bound +#print axioms decodeExtractedCount_value +#print axioms decodeExtractedCount_bound + +#print axioms readRunCount_value +#print axioms readBodyCount_value +#print axioms readBodyCount_bound +#print axioms readBody_units +end Whir.PCSBCSCoordinateCodecCost diff --git a/verification/whir/Whir/PCSBCSExecutedCoordinateRecovery.lean b/verification/whir/Whir/PCSBCSExecutedCoordinateRecovery.lean new file mode 100644 index 000000000..4747fec92 --- /dev/null +++ b/verification/whir/Whir/PCSBCSExecutedCoordinateRecovery.lean @@ -0,0 +1,136 @@ +import Whir.PCSBCSSourceCoordinateDecoderSource +import Whir.PublicCompressionCouplingPrefixTrace +import Whir.PublicCompressionCouplingClosure +import Whir.PublicCompressionProgram +import Whir.PCSBCSSourcePrimitiveRootBudget + +/-! Recovery from the actual executed primitive ancestry, rather than an +assumed recognized compression tree. The terminal remains outside its prefix; +freshness, collision freedom and the full public-log budget are explicit. -/ +namespace Whir.PCSBCSExecutedCoordinateRecovery +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame DuplexPublicSimulator +open PublicCompressionProgram PublicCompressionCouplingMixed +open PublicCompressionCouplingRecognition TypedOracleCompiler +set_option autoImplicit false +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 + + theorem planCalls_body (C : PrimitiveOracle) (Q : Nat) (ro : RawKey Q → Digest32) + (cv : Digest32) (xs : List DuplexEncoding.Instruction) : + (Sampling.execute C (planCalls cv xs)).1 = + (Sampling.eval (oracle C ro) (bodyCalls Q cv xs)).1 ∧ + toLog (Sampling.execute C (planCalls cv xs)).2 = + (Sampling.eval (oracle C ro) (bodyCalls Q cv xs)).2 := by + induction xs generalizing cv with + | nil => exact ⟨rfl,rfl⟩ + | cons i rest ih => + simp only [planCalls,Sampling.execute,bodyCalls,Sampling.eval, + PublicCompressionCouplingMixed.Computation.eval_map,oracle] + constructor + · exact (ih (C ⟨cv,i.1,i.2,true⟩)).1 + · simpa only [toLog,List.map_cons] using + congrArg (fun log => (⟨cv,i.1,i.2,true⟩,C ⟨cv,i.1,i.2,true⟩)::log) + (ih (C ⟨cv,i.1,i.2,true⟩)).2 + + theorem body_value (C : PrimitiveOracle) (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : + (Sampling.execute C (planCalls iv (DuplexEncoding.plan q).dropLast)).1 = + (traceHistory (compressionOf C) iv q.history).state.cv := by + rw [(planCalls_body C 0 (fun _ => iv) iv _).1,← coordinate_body_plan] + exact congrArg Prod.fst + (bodyCalls_tree (traceHistory_valid (compressionOf C) iv q.history valid.1).1 + 0 iv (traceHistory_anchored (compressionOf C) iv q.history valid.1) (fun _ => iv)) + + theorem body_records (C : PrimitiveOracle) (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : + toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan q).dropLast)).2 = + (traceHistory (compressionOf C) iv q.history).nodes.reverse.map (fun n => (n,C n)) := by + rw [(planCalls_body C 0 (fun _ => iv) iv _).2] + exact inspection_body_nodes 0 C (fun _ => iv) iv q valid + + theorem executed_publicBody (C : PrimitiveOracle) (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (prior : PublicLog) : + PublicBody + ((toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior) + (traceHistory (compressionOf C) iv q.history).state.cv + (traceHistory (compressionOf C) iv q.history).nodes := by + classical + apply Tree.publicBody_of_exposure + (traceHistory_valid (compressionOf C) iv q.history valid.1).1 _ Finset.univ + · intro n d member + exact Finset.mem_univ _ + · intro n member hit + apply List.mem_append_left + rw [body_records C iv q valid,← List.map_reverse,List.reverse_reverse] + exact List.mem_map.mpr ⟨n,member,rfl⟩ + · exact Finset.mem_univ _ + + theorem recover_executed_prefix (C : PrimitiveOracle) (iv : Digest32) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (prior : PublicLog) (Q : Nat) + (priorAuth : PublicMerkleLog.AuthenticLog C prior) + (clean : ¬ OutputCollision + ((toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior)) + (fresh : lookup + ((toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior) + (terminalNode (Sampling.execute C + (planCalls iv (DuplexEncoding.plan q).dropLast)).1 q.terminal) = none) + (budget : (toLog (Sampling.execute C + (planCalls iv (DuplexEncoding.plan q).dropLast)).2).length + prior.length + 1 ≤ Q) : + PCSBCSSourceCoordinateDecoder.recover Q iv + ((toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior) + (terminalNode (Sampling.execute C + (planCalls iv (DuplexEncoding.plan q).dropLast)).1 q.terminal) = some q := by + rw [body_value C iv q valid] at fresh ⊢ + have auth : PublicMerkleLog.AuthenticLog C + ((toLog (Sampling.execute C + (planCalls iv (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior) := by + intro n d member + rcases List.mem_append.mp member with member | member + · exact execute_authentic C _ n d (List.mem_reverse.mp member) + · exact priorAuth n d member + have functional : Functional + ((toLog (Sampling.execute C + (planCalls iv (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior) := by + intro n a b ha hb + exact (auth n a ha).symm.trans (auth n b hb) + apply PCSBCSSourceCoordinateDecoder.recover_from_publicBody functional clean fresh + · exact terminal_node _ _ + · cases q.terminal <;> simpa only [terminalNode] using executed_publicBody C iv q valid prior + · exact PCSBCSSourceCoordinateDecoder.coordinateTree_sourceShape (compressionOf C) iv q valid + · simpa only [List.length_append,List.length_reverse] using budget + + theorem references_executed_prefix (C : PrimitiveOracle) + (p : ParameterBounds.Profile) (Q boundary : Nat) (registry : AnchoredHeaderRoots.Public) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (prior : PublicLog) + (priorAuth : PublicMerkleLog.AuthenticLog C prior) + (clean : ¬ OutputCollision + ((toLog (Sampling.execute C + (planCalls PCSBCSSourceCoordinateDecoder.seedIV (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior)) + (fresh : lookup + ((toLog (Sampling.execute C + (planCalls PCSBCSSourceCoordinateDecoder.seedIV (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior) + (terminalNode (Sampling.execute C + (planCalls PCSBCSSourceCoordinateDecoder.seedIV (DuplexEncoding.plan q).dropLast)).1 q.terminal) = none) + (budget : (toLog (Sampling.execute C + (planCalls PCSBCSSourceCoordinateDecoder.seedIV (DuplexEncoding.plan q).dropLast)).2).length + + prior.length + 1 ≤ Q) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (answers : Coordinate → Digest32) (refs : List PCSBCSSourceRootReferences.Reference) + (native : PCSBCSSourceRootReferences.parseReferences p layout saved + (PCSBCSSourcePrimitiveRootBudget.entry q boundary) answers q = some refs) : + ∀ ref ∈ refs, ref ∈ PCSBCSSourcePrimitiveRootBudget.references p Q boundary registry + ((toLog (Sampling.execute C + (planCalls PCSBCSSourceCoordinateDecoder.seedIV (DuplexEncoding.plan q).dropLast)).2).reverse ++ prior) + (terminalNode (Sampling.execute C + (planCalls PCSBCSSourceCoordinateDecoder.seedIV (DuplexEncoding.plan q).dropLast)).1 q.terminal) := by + exact PCSBCSSourcePrimitiveRootBudget.references_native p Q boundary registry _ _ q + (recover_executed_prefix C _ q valid prior Q priorAuth clean fresh budget) + layout saved answers refs native + +#print axioms planCalls_body +#print axioms body_value +#print axioms body_records +#print axioms executed_publicBody +#print axioms recover_executed_prefix +#print axioms references_executed_prefix +end Whir.PCSBCSExecutedCoordinateRecovery diff --git a/verification/whir/Whir/PCSBCSIdealConstructionAnswers.lean b/verification/whir/Whir/PCSBCSIdealConstructionAnswers.lean new file mode 100644 index 000000000..6369fe3ba --- /dev/null +++ b/verification/whir/Whir/PCSBCSIdealConstructionAnswers.lean @@ -0,0 +1,44 @@ +import Whir.PublicCompressionCouplingMixed + +/-! Construction observations in the actual ideal runner name and return their +literal bounded raw key. The simulator may change primitive replies, but cannot +replace or resample these construction answers. -/ +set_option autoImplicit false +namespace Whir.PCSBCSIdealConstructionAnswers +open FiatShamirGame DuplexFraming DuplexModeGame + +/-- Every observed construction answer comes from the same independent RO, +including arbitrary primitive calls, cached simulator replies and early abort. -/ +theorem construction_observations {Q : Nat} {Seed State R : Type} + (sim : Simulator Q Seed State) (ro : RawKey Q → Digest32) (iv : Digest32) + (state : State) (program : Program R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : Counts remaining program) : + ∀ coordinate valid answer, + (⟨.construction coordinate valid,answer⟩ : Observation) ∈ + (runIdeal sim ro iv state program remaining limit counted).view.observations → + ∃ bound : pathCost coordinate ≤ Q, + answer = ro (constructionKey Q iv coordinate bound) := by + induction program generalizing state remaining with + | done value => simp [runIdeal] + | ask query next ih => + cases query with + | primitive purpose input => + intro coordinate valid answer member + simp only [runIdeal,prepend,List.mem_cons] at member + rcases member with impossible | later + · cases impossible + · exact ih (runRO ro (sim.answer state input)).1.2 + (runRO ro (sim.answer state input)).1.1 (remaining-1) (by omega) + (counted.2 _) coordinate valid answer later + | construction coordinate valid => + intro other otherValid answer member + simp only [runIdeal,prepend,List.mem_cons] at member + rcases member with first | later + · cases first + exact ⟨counted.1.trans limit,rfl⟩ + · exact ih (ro (constructionKey Q iv coordinate (counted.1.trans limit))) + state (remaining-pathCost coordinate) (by omega) (counted.2 _) + other otherValid answer later + +#print axioms construction_observations +end Whir.PCSBCSIdealConstructionAnswers diff --git a/verification/whir/Whir/PCSBCSMerkleSeedProjection.lean b/verification/whir/Whir/PCSBCSMerkleSeedProjection.lean new file mode 100644 index 000000000..96e2d2b1e --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleSeedProjection.lean @@ -0,0 +1,340 @@ +import Whir.PCSBCSCapturedNativeReplyBridge +import Whir.PCSBCSActualMerkleBound + +/-! Ordinary Merkle nodes use the seed summand of the actual mixed compiler. +Cached public replies remain observations but allocate no physical draw. The +invariant below concerns only tag-zero records, not equality of public logs. +The grouped first-mention prefix is authenticated directly by physical seed +coordinates; no hidden full-table extraction is assumed. -/ +set_option autoImplicit false +namespace Whir.PCSBCSMerkleSeedProjection +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +/-- The exact count-plus-chunk induction and UInt64 no-wrap bound are already +proved by PublicMerkleLog; retain that bound at the seed-projection boundary. -/ +theorem plan_tag_zero (C : PrimitiveOracle) (bytes : List Byte) + (bound : bytes.length < 2^56) (n : Node) (d : Digest32) + (member : (n,d) ∈ PublicMerkleLog.plan C bytes) : tag n = 0 := + PublicMerkleLog.plan_tag_zero C bytes bound n d member + +theorem not_terminal {input : Node} (ordinary : tag input = 0) : ¬ isTerminal input := by + simp [isTerminal,ordinary] + +theorem recognized_none (log : DuplexPublicSimulator.PublicLog) {input : Node} + (ordinary : tag input = 0) : DuplexPublicSimulator.recognized log input = none := by + simp [DuplexPublicSimulator.recognized,not_terminal ordinary] + +theorem privateKey_none (Q : Nat) (log : DuplexPublicSimulator.PublicLog) {input : Node} + (ordinary : tag input = 0) : DuplexPublicSimulator.privateKey Q log input = none := by + unfold DuplexPublicSimulator.privateKey + rw [recognized_none log ordinary] + split <;> rfl + +theorem plan_privateKey_none (Q : Nat) (log : DuplexPublicSimulator.PublicLog) + (C : PrimitiveOracle) (bytes : List Byte) (bound : bytes.length < 2^56) + (n : Node) (d : Digest32) (member : (n,d) ∈ PublicMerkleLog.plan C bytes) : + DuplexPublicSimulator.privateKey Q log n = none := + privateKey_none Q log (plan_tag_zero C bytes bound n d member) + +theorem primitiveCalls_miss (Q : Nat) (log : DuplexPublicSimulator.PublicLog) + (input : Node) (ordinary : tag input = 0) + (miss : DuplexPublicSimulator.lookup log input = none) : + PublicCompressionCouplingMixed.primitiveCalls Q log input = + .draw (.inl input) (fun answer => + .ret (DuplexPublicSimulator.observe log input answer,answer)) := by + simp [PublicCompressionCouplingMixed.primitiveCalls,miss,privateKey_none Q log ordinary] + +theorem primitiveCalls_hit (Q : Nat) (log : DuplexPublicSimulator.PublicLog) + (input : Node) (answer : Digest32) + (hit : DuplexPublicSimulator.lookup log input = some answer) : + PublicCompressionCouplingMixed.primitiveCalls Q log input = + .ret (DuplexPublicSimulator.observe log input answer,answer) := by + simp [PublicCompressionCouplingMixed.primitiveCalls,hit] + +/-- A miss has precisely one physical seed draw, even though the simulator's +runRO meter does not count fallback seed evaluations as private RO draws. -/ +theorem execute_miss (Q : Nat) (seed : PrimitiveOracle) (ro : RawKey Q → Digest32) + (log : DuplexPublicSimulator.PublicLog) (input : Node) (ordinary : tag input = 0) + (miss : DuplexPublicSimulator.lookup log input = none) : + Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) = + ((DuplexPublicSimulator.observe log input (seed input),seed input), + [⟨.inl input,seed input⟩]) := by + rw [primitiveCalls_miss Q log input ordinary miss] + rfl + +theorem execute_hit (Q : Nat) (seed : PrimitiveOracle) (ro : RawKey Q → Digest32) + (log : DuplexPublicSimulator.PublicLog) (input : Node) (answer : Digest32) + (hit : DuplexPublicSimulator.lookup log input = some answer) : + Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) = + ((DuplexPublicSimulator.observe log input answer,answer),[]) := by + rw [primitiveCalls_hit Q log input answer hit] + rfl + +/-- Nonordinary public answers may come from the private-key summand. Only the +ordinary part must agree with the seed, and this is maintained operationally. -/ +def OrdinaryAuthentic (seed : PrimitiveOracle) (log : DuplexPublicSimulator.PublicLog) : Prop := + ∀ n d, (n,d) ∈ log → tag n = 0 → seed n = d + +theorem lookup_mem {log : DuplexPublicSimulator.PublicLog} {input : Node} {answer : Digest32} + (hit : DuplexPublicSimulator.lookup log input = some answer) : (input,answer) ∈ log := by + unfold DuplexPublicSimulator.lookup at hit + cases found : log.find? (fun e => decide (e.1 = input)) with + | none => simp [found] at hit + | some entry => + have hm := List.mem_of_find?_eq_some found + have he := List.find?_some found + have hn : entry.1 = input := of_decide_eq_true he + have hd : entry.2 = answer := by simpa [found] using hit + have same : entry = (input,answer) := Prod.ext hn hd + simpa only [same] using hm + +theorem observe_preserves (seed : PrimitiveOracle) (log : DuplexPublicSimulator.PublicLog) + (auth : OrdinaryAuthentic seed log) (input : Node) (answer : Digest32) + (correct : tag input = 0 → seed input = answer) : + OrdinaryAuthentic seed (DuplexPublicSimulator.observe log input answer) := by + intro n d member ordinary + rcases List.mem_cons.mp member with same | prior + · cases same + exact correct ordinary + · exact auth n d prior ordinary + +theorem primitiveCalls_preserves (Q : Nat) (seed : PrimitiveOracle) (ro : RawKey Q → Digest32) + (log : DuplexPublicSimulator.PublicLog) (auth : OrdinaryAuthentic seed log) (input : Node) : + let result := Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) + OrdinaryAuthentic seed result.1 ∧ (tag input = 0 → seed input = result.2) := by + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => + rw [primitiveCalls_hit Q log input answer hit] + simp only [Sampling.eval] + have correct : tag input = 0 → seed input = answer := auth input answer (lookup_mem hit) + exact ⟨observe_preserves seed log auth input answer correct,correct⟩ + | none => + by_cases ordinary : tag input = 0 + · rw [primitiveCalls_miss Q log input ordinary hit] + change OrdinaryAuthentic seed + (DuplexPublicSimulator.observe log input (seed input)) ∧ + (tag input = 0 → seed input = seed input) + exact ⟨observe_preserves seed log auth input (seed input) (fun _ => rfl),fun _ => rfl⟩ + · unfold PublicCompressionCouplingMixed.primitiveCalls + rw [hit] + cases key : DuplexPublicSimulator.privateKey Q log input <;> + simp only [Sampling.eval,PublicCompressionCouplingMixed.oracle] + · exact ⟨observe_preserves seed log auth input (seed input) (fun h => (ordinary h).elim), + fun h => (ordinary h).elim⟩ + · exact ⟨observe_preserves seed log auth input (ro _) (fun h => (ordinary h).elim), + fun h => (ordinary h).elim⟩ + +def AuthenticObservations (seed : PrimitiveOracle) (seen : List Observation) : Prop := + ∀ purpose input answer, (⟨.primitive purpose input,answer⟩ : Observation) ∈ seen → + tag input = 0 → seed input = answer + +/-- Adaptive continuations and arbitrary nonordinary/construction queries are +allowed. Each cached ordinary hit is justified by the preceding invariant. -/ +theorem compile_authentic {R : Type} (Q : Nat) (seed : PrimitiveOracle) + (ro : RawKey Q → Digest32) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (auth : OrdinaryAuthentic seed log) (program : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining program) : + AuthenticObservations seed + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q iv log program remaining cap counted)).observations := by + induction program generalizing log remaining with + | done => simp [PublicCompressionCouplingMixed.compile,Sampling.eval,AuthenticObservations] + | ask query next ih => + cases query with + | primitive purpose input => + simp only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe] + have step := primitiveCalls_preserves Q seed ro log auth input + let result := Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) + have tail := ih result.2 result.1 step.1 (remaining-1) (by omega) (counted.2 result.2) + intro purpose' input' answer member ordinary + rcases List.mem_cons.mp member with same | prior + · cases same + exact step.2 ordinary + · exact tail purpose' input' answer prior ordinary + | construction coordinate valid => + simp only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval, + PublicCompressionCouplingMixed.oracle,PublicCompressionCouplingMixed.Computation.eval_map, + DuplexRawProgram.observe] + have tail := ih + (ro (constructionKey Q iv coordinate (counted.1.trans cap))) log auth + (remaining-pathCost coordinate) (by omega) + (counted.2 (ro (constructionKey Q iv coordinate (counted.1.trans cap)))) + intro purpose input answer member ordinary + rcases List.mem_cons.mp member with same | prior + · cases same + · exact tail purpose input answer prior ordinary + +theorem compile_empty_authentic {R : Type} (Q : Nat) (seed : PrimitiveOracle) + (ro : RawKey Q → Digest32) (iv : Digest32) (program : Program R) (remaining : Nat) + (cap : remaining ≤ Q) (counted : Counts remaining program) : + AuthenticObservations seed + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)).observations := + compile_authentic Q seed ro iv [] (by simp [OrdinaryAuthentic]) program remaining cap counted + +/-- Any relevant observation prefix, including a capture boundary, inherits +ordinary authenticity; cached hits need not appear in the physical draw trace. -/ +theorem observations_prefix {seed : PrimitiveOracle} {seen earlier : List Observation} + (auth : AuthenticObservations seed seen) (included : ∀ o ∈ earlier, o ∈ seen) : + AuthenticObservations seed earlier := by + intro purpose input answer member + exact auth purpose input answer (included _ member) + +/-- A public Merkle interpreter receives relevant ordinary observations, not +construction answers or a hidden oracle table. Repetitions are retained. -/ +def ordinaryObservations (seen : List Observation) : PublicMerkleLog.PublicLog := + seen.filterMap fun observation => match observation.query with + | .primitive _ input => + if tag input = 0 then some (input,observation.answer) else none + | .construction _ _ => none + +theorem ordinaryObservations_authentic (seed : PrimitiveOracle) (seen : List Observation) + (auth : AuthenticObservations seed seen) : + PublicMerkleLog.AuthenticLog seed (ordinaryObservations seen) := by + intro n d member + obtain ⟨observation,present,record⟩ := List.mem_filterMap.mp member + rcases observation with ⟨query,answer⟩ + cases query with + | construction coordinate valid => simp at record + | primitive purpose input => + by_cases ordinary : tag input = 0 + · simp only [ordinary,↓reduceIte,Option.some.injEq,Prod.mk.injEq] at record + rcases record with ⟨rfl,rfl⟩ + exact auth purpose input answer present ordinary + · simp [ordinary] at record + +theorem observation_parse_seed (seed : PrimitiveOracle) (seen : List Observation) + (auth : AuthenticObservations seed seen) (n : Node) (d : Digest32) (bytes : List Byte) + (parsed : PublicMerkleLog.parse (ordinaryObservations seen) n d = some bytes) : + PublicMerkleLog.hash seed bytes = d := + PublicMerkleLog.parse_authentic seed (ordinaryObservations seen) + (ordinaryObservations_authentic seed seen auth) n d bytes parsed + +section GroupedPrefix +open PCSBCSSourceRootCapture +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Each actual physical seed event is authentic, independently of its tag. +This is a coordinatewise property of the literal partition split, not a +whole-game AuthenticLog premise. -/ +theorem ordinaryRecord_split (seed : PrimitiveOracle) (ro : RawKey Q → Digest32) (key : Keys) : + PublicMerkleLog.AuthenticLog seed + (ordinaryRecord ⟨key, + (PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := Q) (iv := iv) + (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro) key⟩) := by + cases key with + | inl packet => simp [ordinaryRecord,PublicMerkleLog.AuthenticLog] + | inr other => + cases raw : other.val with + | inl input => + simp [ordinaryRecord,RawOracleCoupling.Partition.split,raw, + PublicCompressionCouplingMixed.oracle,PublicMerkleLog.AuthenticLog] + | inr rawKey => simp [ordinaryRecord,raw,PublicMerkleLog.AuthenticLog] + +theorem authentic_fold (seed : PrimitiveOracle) (events : List (Sigma Answers)) + (each : ∀ event ∈ events, PublicMerkleLog.AuthenticLog seed (ordinaryRecord event)) + (log : DuplexPublicSimulator.PublicLog) (auth : PublicMerkleLog.AuthenticLog seed log) : + PublicMerkleLog.AuthenticLog seed + (events.foldl (fun prior event => ordinaryRecord event ++ prior) log) := by + induction events generalizing log with + | nil => exact auth + | cons event rest ih => + apply ih + · intro e member + exact each e (List.mem_cons_of_mem _ member) + · intro n d member + rcases List.mem_append.mp member with current | prior + · exact each event (List.mem_cons_self) n d current + · exact auth n d prior + +theorem ordinaryPrefix_authentic (seed : PrimitiveOracle) (events : List (Sigma Answers)) + (each : ∀ event ∈ events, PublicMerkleLog.AuthenticLog seed (ordinaryRecord event)) : + PublicMerkleLog.AuthenticLog seed (ordinaryPrefix events) := + authentic_fold seed events each [] (by simp [PublicMerkleLog.AuthenticLog]) + +/-- Literal pre-first-mention physical events suffice to authenticate the +captured public prefix. No assertion about captured leaf availability follows. -/ +theorem firstMention_authentic {R : Type} {count : Nat} + (seed : PrimitiveOracle) (ro : RawKey Q → Digest32) + (addresses : Keys → List PCSBCSSourceRootReferences.Reference) + (ref : PCSBCSSourceRootReferences.Reference) (program : Sampling Keys Answers R count) + (events : List (Sigma Answers)) + (found : PCSBCSFirstRootDisclosure.firstMention addresses ref program + ((PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := Q) (iv := iv) + (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro)) = some events) : + PublicMerkleLog.AuthenticLog seed (ordinaryPrefix events) := by + apply ordinaryPrefix_authentic + induction program generalizing events with + | ret result => simp [PCSBCSFirstRootDisclosure.firstMention] at found + | draw key next ih => + unfold PCSBCSFirstRootDisclosure.firstMention at found + split at found + · have empty : events = [] := (Option.some.inj found).symm + subst events + simp + · cases tailFound : PCSBCSFirstRootDisclosure.firstMention addresses ref + (next ((PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := Q) (iv := iv) + (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro) key)) + ((PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := Q) (iv := iv) + (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro)) with + | none => simp [tailFound] at found + | some tail => + simp only [tailFound,Option.map_some,Option.some.injEq] at found + subst events + intro event member + rcases List.mem_cons.mp member with same | prior + · subst event + exact ordinaryRecord_split seed ro key + · exact ih _ tail tailFound event prior + +theorem firstMention_parse_seed {R : Type} {count : Nat} + (seed : PrimitiveOracle) (ro : RawKey Q → Digest32) + (addresses : Keys → List PCSBCSSourceRootReferences.Reference) + (ref : PCSBCSSourceRootReferences.Reference) (program : Sampling Keys Answers R count) + (events : List (Sigma Answers)) + (found : PCSBCSFirstRootDisclosure.firstMention addresses ref program + ((PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := Q) (iv := iv) + (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro)) = some events) + (n : Node) (d : Digest32) (bytes : List Byte) + (parsed : PublicMerkleLog.parse (ordinaryPrefix events) n d = some bytes) : + PublicMerkleLog.hash seed bytes = d := + PublicMerkleLog.parse_authentic seed (ordinaryPrefix events) + (firstMention_authentic seed ro addresses ref program events found) n d bytes parsed + +/-- The native-reply bridge's literal sourceLog is authentic under the exact +mixed table split. An absent capture gives an empty authentic log, not a full +Merkle image or an accepted opening. -/ +theorem sourceLog_authentic {R : Type} {count : Nat} + (seed : PrimitiveOracle) (ro : RawKey Q → Digest32) + (addresses : Keys → List PCSBCSSourceRootReferences.Reference) + (ref : PCSBCSSourceRootReferences.Reference) (program : Sampling Keys Answers R count) : + PublicMerkleLog.AuthenticLog seed + (PCSBCSCapturedNativeReplyBridge.sourceLog addresses ref program + ((PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := Q) (iv := iv) + (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro))) := by + unfold PCSBCSCapturedNativeReplyBridge.sourceLog + cases found : PCSBCSFirstRootDisclosure.firstMention addresses ref program + ((PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := Q) (iv := iv) + (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro)) with + | none => simp [ordinaryPrefix,PublicMerkleLog.AuthenticLog] + | some events => + exact firstMention_authentic seed ro addresses ref program events found +end GroupedPrefix + +#print axioms plan_privateKey_none +#print axioms execute_miss +#print axioms execute_hit +#print axioms primitiveCalls_preserves +#print axioms compile_empty_authentic +#print axioms firstMention_authentic +#print axioms observation_parse_seed +#print axioms firstMention_parse_seed +#print axioms sourceLog_authentic +end Whir.PCSBCSMerkleSeedProjection diff --git a/verification/whir/Whir/PCSBCSMerkleSeedProjectionSmoke.lean b/verification/whir/Whir/PCSBCSMerkleSeedProjectionSmoke.lean new file mode 100644 index 000000000..b0b6d7e41 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleSeedProjectionSmoke.lean @@ -0,0 +1,81 @@ +import Whir.PCSBCSMerkleSeedProjection + +/-! Small real-BLAKE2s plans, source primitiveCalls, physical allocation traces, +and repeated observations. Counter-only negative cases avoid gigantic inputs. -/ +set_option autoImplicit false +namespace Whir.PCSBCSMerkleSeedProjectionSmoke +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open PublicCompressionCouplingMixed + +private def require (label : String) (ok : Bool) : IO Unit := do + unless ok do throw (IO.userError s!"Merkle seed projection: {label}") + IO.println s!"Merkle seed projection PASS: {label}" + +private def raw : RawKey 16 → Digest32 := fun _ _ => 255 +private def table : Key 16 → Digest32 := oracle blake2sOracle raw +private def bytes (size : Nat) : List Byte := + (List.range size).map fun n => ⟨n%256,Nat.mod_lt _ (by decide)⟩ + +private def runPlan (log : DuplexPublicSimulator.PublicLog) : + List (Node × Digest32) → Bool × DuplexPublicSimulator.PublicLog × Nat + | [] => (true,log,0) + | (input,expected) :: rest => + let result := Sampling.execute table (primitiveCalls 16 log input) + let later := runPlan result.1.1 rest + (decide (result.1.2 = expected) && later.1,later.2.1,result.2.length+later.2.2) + +private def twice (input : Node) : Program (Digest32 × Digest32) := + .ask (.primitive .direct input) fun first => + .ask (.primitive .verification input) fun second => .done (first,second) + +private theorem twice_counted (input : Node) : Counts 2 (twice input) := by + simp [twice,Counts,Query.cost] + +private def smoke : IO Unit := do + for size in [0,1,24,48,64,65,128,129] do + let plan := PublicMerkleLog.plan blake2sOracle (bytes size) + require s!"plan {size}: all nodes tag zero" + (plan.all fun entry => decide (tag entry.1 = 0)) + require s!"plan {size}: no private-key rerouting" + (plan.all fun entry => (DuplexPublicSimulator.privateKey 16 [] entry.1).isNone) + let fresh := runPlan [] plan + require s!"plan {size}: fresh source replies equal real BLAKE compression" fresh.1 + require s!"plan {size}: every fresh node allocates one draw" + (fresh.2.2 == plan.length) + let cached := runPlan fresh.2.1 plan + require s!"plan {size}: cached replies remain authentic" cached.1 + require s!"plan {size}: cached nodes allocate no draw" (cached.2.2 == 0) + let input := PublicMerkleLog.node DuplexCompression.parameterIV 0 (bytes 24) true + let expected := blake2sOracle input + let fresh := Sampling.execute table (primitiveCalls 16 [] input) + require "fresh primitiveCalls draws exactly .inl input" + (match fresh.2 with + | [⟨.inl n,d⟩] => decide (n = input ∧ d = expected) + | _ => false) + let cached := Sampling.execute table (primitiveCalls 16 fresh.1.1 input) + require "cached primitiveCalls retains public answer and has no physical draw" + (decide (cached.1.2 = expected) && cached.2.isEmpty) + let prior : Digest32 := fun _ => 17 + let inconsistent := Sampling.execute table (primitiveCalls 16 [(input,prior)] input) + require "arbitrary cached public answer is retained, not silently seed-replaced" + (decide (inconsistent.1.2 = prior) && inconsistent.2.isEmpty) + let compiled := compile 16 DuplexCompression.parameterIV [] (twice input) 2 + (by decide) (twice_counted input) + let execution := Sampling.execute table compiled + require "actual mixed compile: two observations but only one physical seed draw" + (execution.1.observations.length == 2 && execution.2.length == 1) + require "actual mixed compile: both source replies equal the seed compression" + (decide (execution.1.result = (expected,expected))) + let oversized := PublicMerkleLog.node DuplexCompression.parameterIV (2^56) [] true + require "unbounded ordinary-node tag-zero assumption is rejected at 2^56" + (decide (tag oversized = 1 ∧ tag oversized ≠ 0)) + let terminal := PublicMerkleLog.node DuplexCompression.parameterIV (6*2^56) [] true + require "unbounded ordinary-node nonterminal assumption is rejected" + (decide (tag terminal = 6 ∧ isTerminal terminal)) + let wrapped := PublicMerkleLog.node DuplexCompression.parameterIV (2^64+1) [] true + require "UInt64 wrap is not a substitute for the 56-bit source bound" + (decide (wrapped.tweak.toNat = 1 ∧ tag wrapped = 0)) + +end Whir.PCSBCSMerkleSeedProjectionSmoke + +def main : IO Unit := Whir.PCSBCSMerkleSeedProjectionSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSMerkleTableAuthenticity.lean b/verification/whir/Whir/PCSBCSMerkleTableAuthenticity.lean new file mode 100644 index 000000000..457ab07fc --- /dev/null +++ b/verification/whir/Whir/PCSBCSMerkleTableAuthenticity.lean @@ -0,0 +1,46 @@ +import Whir.PCSBCSMerkleSeedProjection + +/-! Every atomic source table has its literal primitive/raw-oracle decomposition. +Captured ordinary prefix authenticity is derived, not an assumed whole-game +certificate. This does not authenticate missing leaves or exclude collisions. -/ +set_option autoImplicit false +namespace Whir.PCSBCSMerkleTableAuthenticity +open Concrete FiatShamirGame DuplexModeGame TypedOracleCompiler TypedFiatShamirGame +open PCSStateRestoration.Latent +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSCapturedNativeReplyBridge + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +noncomputable def seed (table : Table Keys Answers) : PrimitiveOracle := + fun input => (part).join table (.inl input) + +noncomputable def raw (table : Table Keys Answers) : DuplexModeGame.RawKey Q → Digest32 := + fun key => (part).join table (.inr key) + +theorem oracle_eq (table : Table Keys Answers) : + PublicCompressionCouplingMixed.oracle (seed table) (raw table) = (part).join table := by + funext key + cases key <;> rfl + +theorem split_eq (table : Table Keys Answers) : + (part).split (PublicCompressionCouplingMixed.oracle (seed table) (raw table)) = table := by + rw [oracle_eq] + exact (part).split_join table + +/-- Even adaptively selected addresses use the same literal table's seed. -/ +theorem sourceLog_authentic {R : Type} {n : Nat} + (addresses : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (table : Table Keys Answers) : + PublicMerkleLog.AuthenticLog (seed table) (sourceLog addresses ref program table) := by + have derived := PCSBCSMerkleSeedProjection.sourceLog_authentic + (seed table) (raw table) addresses ref program + rw [split_eq] at derived + exact derived + +#print axioms oracle_eq +#print axioms split_eq +#print axioms sourceLog_authentic +end Whir.PCSBCSMerkleTableAuthenticity diff --git a/verification/whir/Whir/PCSBCSMixedConstructionTrace.lean b/verification/whir/Whir/PCSBCSMixedConstructionTrace.lean new file mode 100644 index 000000000..283c89e00 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMixedConstructionTrace.lean @@ -0,0 +1,109 @@ +import Whir.PCSBCSAtomicAllocationTrace +import Whir.PublicCompressionCouplingMixed + +/-! Literal construction observations in the mixed source compiler retain +actual raw draw provenance, including primitive simulator work between them. -/ +set_option autoImplicit false +namespace Whir.PCSBCSMixedConstructionTrace +open FiatShamirGame DuplexFraming DuplexModeGame +open TypedOracleCompiler (Sampling) +open PublicCompressionCouplingMixed + +theorem execute_map {Q n : Nat} {R S : Type} (table : Key Q → Digest32) + (f : R → S) (program : Computation Q R n) : + (Sampling.execute table (PublicCompressionCouplingMixed.Computation.map f program)).2 = + (Sampling.execute table program).2 := by + induction program with + | ret result => rfl + | draw key next ih => + simp only [PublicCompressionCouplingMixed.Computation.map,Sampling.execute,ih] + +theorem compiled_recorded {Q : Nat} {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (program : Program R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : Counts remaining program) : + ∀ (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) (answer : Digest32), + (⟨.construction coordinate valid,answer⟩ : Observation) ∈ + (Sampling.eval (oracle seed ro) (compile Q iv log program remaining limit counted)).observations → + ∃ bound : pathCost coordinate ≤ Q, + (⟨.inr (constructionKey Q iv coordinate bound),answer⟩ : + Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seed ro) (compile Q iv log program remaining limit counted)).2 := by + induction program generalizing log remaining with + | done result => simp [compile,Sampling.eval] + | ask query next ih => + cases query with + | primitive purpose input => + intro coordinate valid answer member + simp only [compile,Sampling.eval_pad,Sampling.eval_bind,PublicCompressionCouplingMixed.Computation.eval_map, + DuplexRawProgram.observe,List.mem_cons] at member + rcases member with impossible | later + · cases impossible + · obtain ⟨bound,recorded⟩ := ih + (Sampling.eval (oracle seed ro) (primitiveCalls Q log input)).2 + (Sampling.eval (oracle seed ro) (primitiveCalls Q log input)).1 + (remaining-1) (by omega) (counted.2 _) coordinate valid answer later + refine ⟨bound,?_⟩ + rw [compile,Sampling.execute_pad,Sampling.execute_bind,execute_map] + exact List.mem_append_right _ recorded + | construction requested admitted => + intro coordinate valid answer member + simp only [compile,Sampling.eval_pad,Sampling.eval,PublicCompressionCouplingMixed.Computation.eval_map, + DuplexRawProgram.observe,List.mem_cons] at member + rcases member with same | later + · cases same + refine ⟨counted.1.trans limit,?_⟩ + simp only [compile,Sampling.execute_pad,Sampling.execute,execute_map] + exact List.mem_cons_self + · obtain ⟨bound,recorded⟩ := ih (oracle seed ro + (.inr (constructionKey Q iv requested (counted.1.trans limit)))) log + (remaining-pathCost requested) (by omega) (counted.2 _) coordinate valid answer later + refine ⟨bound,?_⟩ + simp only [compile,Sampling.execute_pad,Sampling.execute,execute_map] + exact List.mem_cons_of_mem _ recorded + +theorem ideal_recorded {Q : Nat} {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (program : Program R) (remaining : Nat) (limit : remaining ≤ Q) + (counted : Counts remaining program) + (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) (answer : Digest32) + (member : (⟨.construction coordinate valid,answer⟩ : Observation) ∈ + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨seed,log⟩ + program remaining limit counted).view.observations) : + ∃ bound : pathCost coordinate ≤ Q, + (⟨.inr (constructionKey Q iv coordinate bound),answer⟩ : + Sigma (fun _ : Key Q => Digest32)) ∈ + (Sampling.execute (oracle seed ro) (compile Q iv log program remaining limit counted)).2 := by + apply compiled_recorded seed ro iv log program remaining limit counted coordinate valid answer + rw [compile_actual] + exact member + +theorem ideal_packet_recorded {Q : Nat} {R Packet : Type} {Block : Packet → Type} + (part : RawOracleCoupling.Partition (Key Q) Packet Block) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey Q → Digest32) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (program : Program R) (remaining : Nat) + (limit : remaining ≤ Q) (counted : Counts remaining program) + (coordinate : Coordinate) (valid : DuplexEncoding.Admissible coordinate) + (bound : pathCost coordinate ≤ Q) (answer : Digest32) (block : Sigma Block) + (member : (⟨.construction coordinate valid,answer⟩ : Observation) ∈ + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨seed,log⟩ + program remaining limit counted).view.observations) + (recognized : part.recognize (.inr (constructionKey Q iv coordinate bound)) = some block) : + (⟨.inl block.1,(part.split (oracle seed ro)) (.inl block.1)⟩ : + Sigma (part.Answer (D := Digest32))) ∈ + (Sampling.execute (part.split (oracle seed ro)) + (PCSBCSChallengeOracle.Atomic.program part + (compile Q iv log program remaining limit counted))).2 := by + obtain ⟨actualBound,recorded⟩ := ideal_recorded seed ro iv log program remaining limit counted + coordinate valid answer member + apply PCSBCSAtomicAllocationTrace.recognized_recorded part (part.split (oracle seed ro)) + (compile Q iv log program remaining limit counted) + (.inr (constructionKey Q iv coordinate actualBound)) answer block + · simpa only [RawOracleCoupling.Partition.join_split] using recorded + · exact recognized + +#print axioms execute_map +#print axioms compiled_recorded +#print axioms ideal_recorded +#print axioms ideal_packet_recorded +end Whir.PCSBCSMixedConstructionTrace diff --git a/verification/whir/Whir/PCSBCSMixedOrdinaryMerkle.lean b/verification/whir/Whir/PCSBCSMixedOrdinaryMerkle.lean new file mode 100644 index 000000000..26addd3f0 --- /dev/null +++ b/verification/whir/Whir/PCSBCSMixedOrdinaryMerkle.lean @@ -0,0 +1,215 @@ +import Whir.PCSBCSMerkleSeedProjection +import Whir.PublicMerkleProgram + +/-! Ordinary Merkle consistency for the historical pre-#607 #552 simulator. +Only role-zero primitive replies are authenticated by the fallback seed. Raw +construction replies and all other primitive replies remain unrestricted. +The initial-state theorems derive this property from actual mixed compilation, +without a supplied log/lookup certificate. Ordinary counters are the exact +real-byte counters of PublicMerkleLog.node, not counters with ignored bits. -/ +set_option autoImplicit false +namespace Whir.PCSBCSMixedOrdinaryMerkle +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler + +/-- Exact role-zero condition on the actual UInt64 counter. -/ +theorem tag_zero_iff (input : Node) : tag input = 0 ↔ input.tweak.toNat < 2^56 := by + simp only [tag] + omega + +/-- The machine-level condition includes UInt64 reduction. The no-wrap source +bound below is deliberately stronger; wrapping is not source domain separation. -/ +theorem node_tag_zero_iff_mod (cv : Digest32) (count : Nat) (bytes : List Byte) + (last : Bool) : + tag (PublicMerkleLog.node cv count bytes last) = 0 ↔ + (count + bytes.length) % 2^64 < 2^56 := by + rw [tag_zero_iff] + simp only [PublicMerkleLog.node, UInt64.toNat_ofNat'] + +/-- A nonwrapped ordinary request has role zero exactly when its cumulative +real-byte count is below 2^56; padding does not enter that count. -/ +theorem node_tag_zero_iff (cv : Digest32) (count : Nat) (bytes : List Byte) + (last : Bool) (noWrap : count + bytes.length < 2^64) : + tag (PublicMerkleLog.node cv count bytes last) = 0 ↔ count + bytes.length < 2^56 := by + rw [node_tag_zero_iff_mod, Nat.mod_eq_of_lt noWrap] + +/-- Neither finality nor the purpose label can turn a role-zero input into a +recognized duplex terminal. -/ +theorem ordinary_privateKey_none (Q : Nat) (log : DuplexPublicSimulator.PublicLog) + (input : Node) (ordinary : tag input = 0) : + DuplexPublicSimulator.privateKey Q log input = none := + PCSBCSMerkleSeedProjection.privateKey_none Q log ordinary + +/-- Concrete source formula for a single compression request. -/ +theorem node_privateKey_none (Q : Nat) (log : DuplexPublicSimulator.PublicLog) + (cv : Digest32) (count : Nat) (bytes : List Byte) (last : Bool) + (bound : count + bytes.length < 2^56) : + DuplexPublicSimulator.privateKey Q log (PublicMerkleLog.node cv count bytes last) = none := + ordinary_privateKey_none Q log _ (PublicMerkleLog.ordinary_tag_zero cv count bytes last bound) + +/-- The induction invariant is only the ordinary sublog, never the full log. -/ +theorem primitiveCalls_ordinary (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) + (auth : PCSBCSMerkleSeedProjection.OrdinaryAuthentic seed log) (input : Node) + (ordinary : tag input = 0) : + Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.primitiveCalls Q log input) = + (DuplexPublicSimulator.observe log input (seed input), seed input) := by + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => + have eq : seed input = answer := auth input answer + (DuplexPublicSimulator.lookup_mem hit) ordinary + simp [PublicCompressionCouplingMixed.primitiveCalls, hit, eq, Sampling.eval] + | none => + simp [PublicCompressionCouplingMixed.primitiveCalls, hit, + ordinary_privateKey_none Q log input ordinary, Sampling.eval, + PublicCompressionCouplingMixed.oracle] + +/-- Covers a first call and every cache hit, including hits after arbitrary +construction calls (which do not update the simulator log). -/ +theorem simulator_ordinary_answer (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (log : DuplexPublicSimulator.PublicLog) + (auth : PCSBCSMerkleSeedProjection.OrdinaryAuthentic seed log) (input : Node) + (ordinary : tag input = 0) : + (runRO ro ((DuplexPublicSimulator.simulator Q).answer ⟨seed,log⟩ input)).1 = + (⟨seed,DuplexPublicSimulator.observe log input (seed input)⟩,seed input) := by + rw [PublicCompressionCouplingMixed.primitiveCalls_actual, + primitiveCalls_ordinary Q seed ro log auth input ordinary] + +/-- All purposes are covered, rather than assuming a purpose identifies a +hash domain. There is no conclusion about construction or nonzero-role replies. -/ +theorem mixed_compile_ordinary {R : Type} (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (program : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + PCSBCSMerkleSeedProjection.AuthenticObservations seed + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)).observations := + PCSBCSMerkleSeedProjection.compile_empty_authentic Q seed ro iv program remaining cap counted + +/-- Actual ideal execution, starting from the simulator's actual empty log. -/ +theorem runIdeal_initial_ordinary {R : Type} (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (program : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + PCSBCSMerkleSeedProjection.AuthenticObservations seed + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv + ((DuplexPublicSimulator.simulator Q).initial seed) + program remaining cap counted).view.observations := by + have actual := mixed_compile_ordinary Q seed ro iv program remaining cap counted + rw [PublicCompressionCouplingMixed.compile_actual] at actual + exact actual + +/-- Native acceptance's primitive-only consistency interface, derived rather +than supplied. Verification is just one of the purposes covered above. -/ +theorem runIdeal_initial_answers {R : Type} (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (program : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + ∀ o ∈ (runIdeal (DuplexPublicSimulator.simulator Q) ro iv + ((DuplexPublicSimulator.simulator Q).initial seed) + program remaining cap counted).view.observations, + ∀ input, o.query = .primitive .verification input → tag input = 0 → o.answer = seed input := by + intro o member input query ordinary + have eq : o = (⟨.primitive .verification input,o.answer⟩ : Observation) := by + cases o + simp_all + have auth := runIdeal_initial_ordinary Q seed ro iv program remaining cap counted + exact (auth .verification input o.answer (eq ▸ member) ordinary).symm + +/-- Chronological folding retains only public primitive records, in newest +first cache order. Independent construction answers are never inserted. -/ +theorem finalLog_ordinary (seed : DuplexPublicSimulator.Seed) + (seen : List Observation) (auth : PCSBCSMerkleSeedProjection.AuthenticObservations seed seen) + (log : DuplexPublicSimulator.PublicLog) + (initial : PCSBCSMerkleSeedProjection.OrdinaryAuthentic seed log) : + PCSBCSMerkleSeedProjection.OrdinaryAuthentic seed (DuplexPublicSimulator.finalLog log seen) := by + induction seen generalizing log with + | nil => exact initial + | cons o rest ih => + have tail : PCSBCSMerkleSeedProjection.AuthenticObservations seed rest := by + intro purpose input answer member + exact auth purpose input answer (List.mem_cons_of_mem _ member) + cases o with + | mk query answer => + cases query with + | primitive purpose input => + exact ih tail _ (PCSBCSMerkleSeedProjection.observe_preserves seed log initial input answer + (auth purpose input answer (List.mem_cons_self))) + | construction coordinate valid => exact ih tail log initial + +/-- Every prefix, not just a completed run, has the same ordinary cache answer. +No consistency requirement is imposed on nonordinary records in that prefix. -/ +theorem mixed_prefix_lookup {R : Type} (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (program : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) + (earlier : List Observation) + (included : ∀ o ∈ earlier, o ∈ + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)).observations) + (input : Node) (answer : Digest32) (ordinary : tag input = 0) + (hit : DuplexPublicSimulator.lookup (DuplexPublicSimulator.finalLog [] earlier) input = some answer) : + answer = seed input := by + have auth := PCSBCSMerkleSeedProjection.observations_prefix + (mixed_compile_ordinary Q seed ro iv program remaining cap counted) included + have logAuth := finalLog_ordinary seed earlier auth [] + (by simp [PCSBCSMerkleSeedProjection.OrdinaryAuthentic]) + exact (logAuth input answer (DuplexPublicSimulator.lookup_mem hit) ordinary).symm + +/-- The first-record chronological Merkle interpreter agrees too, including +repeated queries. Its filtered log is authentic, but the full observed log is not +claimed to be authentic under Seed. -/ +theorem mixed_chronological_log {R : Type} (Q : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) (program : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + PublicMerkleLog.AuthenticLog seed (PCSBCSMerkleSeedProjection.ordinaryObservations + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)).observations) := + PCSBCSMerkleSeedProjection.ordinaryObservations_authentic seed _ + (mixed_compile_ordinary Q seed ro iv program remaining cap counted) + +/-- The counter bound follows the production recursion count+b.length, on +actual adaptive hash runs, not just on a predeclared seed-generated plan. -/ +theorem hashFrom_trace_tag_zero {cv : Digest32} {count : Nat} + {bs : List (List Byte)} {hne : bs ≠ []} {trace : List Observation} {digest : Digest32} + (run : PublicMerkleProgram.Runs (PublicMerkleProgram.hashFrom cv count bs hne) trace digest) + (bound : count + bs.flatten.length < 2^56) : + ∀ o ∈ trace, ∃ input, o.query = .primitive .verification input ∧ tag input = 0 := by + induction bs generalizing cv count trace digest with + | nil => contradiction + | cons b rest ih => + cases rest with + | nil => + cases run with + | ask answer run => + cases run + intro o member + have eq := List.mem_singleton.mp member + subst o + refine ⟨_,rfl,PublicMerkleLog.ordinary_tag_zero _ _ _ _ ?_⟩ + simpa only [List.flatten_cons,List.flatten_nil,List.append_nil] using bound + | cons next rest => + cases run with + | ask answer run => + have tailBound : count + b.length + (next :: rest).flatten.length < 2^56 := by + simpa only [List.flatten_cons,List.length_append,Nat.add_assoc] using bound + intro o member + rcases List.mem_cons.mp member with rfl | prior + · refine ⟨_,rfl,PublicMerkleLog.ordinary_tag_zero _ _ _ _ ?_⟩ + omega + · exact ih run tailBound o prior + +/-- Exact source precondition: total unpadded input byte length is below 2^56. +This covers the empty-input final block as well as every multi-block prefix. -/ +theorem hash_trace_tag_zero {bytes : List Byte} {trace : List Observation} {digest : Digest32} + (run : PublicMerkleProgram.Runs (PublicMerkleProgram.hash bytes) trace digest) + (bound : bytes.length < 2^56) : + ∀ o ∈ trace, ∃ input, o.query = .primitive .verification input ∧ tag input = 0 := + hashFrom_trace_tag_zero run + (by simpa only [PublicMerkleLog.chunks_flatten,Nat.zero_add] using bound) + +#print axioms node_tag_zero_iff_mod +#print axioms node_privateKey_none +#print axioms simulator_ordinary_answer +#print axioms mixed_compile_ordinary +#print axioms runIdeal_initial_answers +#print axioms mixed_prefix_lookup +#print axioms mixed_chronological_log +#print axioms hash_trace_tag_zero +end Whir.PCSBCSMixedOrdinaryMerkle diff --git a/verification/whir/Whir/PCSBCSNativeCallerOriginal.lean b/verification/whir/Whir/PCSBCSNativeCallerOriginal.lean new file mode 100644 index 000000000..fc012d91b --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeCallerOriginal.lean @@ -0,0 +1,207 @@ +import Whir.AnchoredPhysicalPreparation +import Whir.PCSBCSSourceCallerOriginal +import Whir.PCSBCSCallerCompletionCausality +import Whir.PCSBCSNativePacketBridge + +/-! Exact original reconstruction for the fresh physical caller. Earlier +answers are obtained from the executed source, not a compatibility callback. +This module does not identify physical and atomic frozen Merkle captures. -/ +namespace Whir.PCSBCSNativeCallerOriginal +open Concrete Protocol FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open WHIRCallerSupport WHIRSourceChronology WHIRPhysicalCaller AnchoredPhysicalDriver +open PCSBCSSourceCallerOriginal PCSBCSRestorationHazard PCSRoundByRoundTranscriptState +open PCSBCSCallerBinding +set_option autoImplicit false +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 + + theorem real_observations {R : Type} (C : PrimitiveOracle) (iv : Digest32) (program : Program R) : + ∀ o ∈ (runReal C iv program).view.observations, o.answer = realAnswer C iv o.query := by + induction program with + | done => simp [runReal] + | ask query next ih => + intro o member + rcases List.mem_cons.mp member with equal | member + · subst o + rfl + · exact ih (realAnswer C iv query) o member + + theorem real_caller_prefix {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (ctx : RawWHIRKeys.Context) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (before after : List Observation) + (splitTrace : (runReal C iv program).view.observations = before ++ after) + (queries : before.map Observation.query = (WHIRModeFinal.callerPositions ctx Q packet).map + (fun q => Query.construction q.val (RawWHIRKeys.callerOutput_admissible ctx Q packet q.val q.property))) : + ∀ wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val), + latestAnswers before wanted = some (evalCoordinate (compressionOf C) iv wanted) := by + intro wanted prior + have queried : Query.construction wanted (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) ∈ + before.map Observation.query := by + rw [queries] + exact List.mem_map.mpr ⟨⟨wanted,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨o,member,equal⟩ := List.mem_map.mp queried + apply latestAnswers_consistent before wanted + (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) _ ⟨o,member,equal⟩ + intro observation member proof same + have actual := real_observations C iv program observation (by + rw [splitTrace] + exact List.mem_append_left _ member) + rw [same] at actual + exact actual + + theorem request_original (cap : Nat) (p : ParameterBounds.Profile) (model : ProductionLayout) + (saved : AnchoredHeaderCodec.Record) (configured : configuration p saved) + (shape : saved.shape = AnchoredSourceCaller.shape model.layout) + (entry : FramedHistory) (answers : Coordinate → Option Digest32) + (request : CausalBindingState.ClaimRequest cap p) + (familyCap : cap ≤ 2^64) + (accepted : AnchoredPhysicalDriver.request .fresh cap p model.layout saved entry answers = some request) : + ∃ input : CallerInput p, + original p model.layout saved entry (fun q => (answers q).getD zeroDigest) = some input ∧ + input.m = request.claims.count ∧ + ∀ root seed, OriginalClaimsChecker.input input.prepared root seed = + ⟨ParameterBounds.config p,saved.shape.lanes,root, + AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config p) saved + request.claims.family request.claims.points seed⟩ := by + have guards := AnchoredPhysicalPreparation.request_guards .fresh cap p model saved configured shape + entry answers request accepted + unfold AnchoredPhysicalDriver.request at accepted + split at accepted + next present => + cases decoded : AnchoredPhysicalDriver.decodeCaller .fresh model.layout saved entry + (fun q => (answers q).getD zeroDigest) with + | none => simp [decoded] at accepted + | some claims => + simp only [decoded,bind,Option.bind] at accepted + split at accepted + next mismatch => contradiction + next matched => + split at accepted + next lanes => + split at accepted + next families => + split at accepted + next points => + cases Option.some.inj accepted + have familyBound : claims.caller.families.length ≤ 2^64 := families.trans familyCap + change OriginalClaimsChecker.Guards (ParameterBounds.config p) saved.shape.lanes + (indexedFamily claims) claims.caller.points saved.point.toArray at guards + cases prepared : OriginalClaimsChecker.prepare (ParameterBounds.config p) saved.shape.lanes + (indexedFamily claims) claims.caller.points saved.point.toArray saved.value with + | none => + simp only [OriginalClaimsChecker.prepare,dite_eq_left guards] at prepared + cases prepared + | some cached => + let input : CallerInput p := ⟨saved.shape.lanes,claims.caller.families.length,indexedFamily claims, + claims.caller.points,saved.point.toArray,saved.value,cached,familyBound,points⟩ + refine ⟨input,?_,rfl,?_⟩ + · have fresh : AnchoredSourceFreshCaller.decode model.layout saved entry + (fun q => (answers q).getD zeroDigest) = some claims := decoded + simp only [original,fresh] + dsimp only [Bind.bind,Option.bind] + rw [dite_eq_left familyBound,dite_eq_left points,prepared] + rfl + · intro root seed + change CausalGame.Public.mk (ParameterBounds.config p) saved.shape.lanes root + (OriginalClaimsChecker.input cached root seed).claims = _ + apply congrArg (CausalGame.Public.mk (ParameterBounds.config p) saved.shape.lanes root) + exact OriginalClaimsChecker.input_claims cached root seed + next => contradiction + next => contradiction + next => contradiction + next => contradiction + + theorem real_verifySource_original (cap : Nat) (model : ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array MerkleTransport.PrunedMerklePaths) + (C : PrimitiveOracle) (iv : Digest32) + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (runReal C iv (compile + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs))).view.result.value = some a) : + ∃ input : CallerInput packet.val.profile, + original packet.val.profile model.layout saved (RawWHIRKeys.entry ctx packet.val) + (evalCoordinate (compressionOf C) iv) = some input ∧ + input.m = a.request.claims.count ∧ + ∀ root seed, OriginalClaimsChecker.input input.prepared root seed = + ⟨ParameterBounds.config packet.val.profile,saved.shape.lanes,root, + AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) saved + a.request.claims.family a.request.claims.points seed⟩ := by + let source := AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs + have run := WHIRPhysicalCaller.real_source_runs C iv source + change (runReal C iv (compile source)).view.result.value = some a at success + rw [success] at run + obtain ⟨caller,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + obtain ⟨before,after,splitTrace,_,queries,parsed⟩ := caller + obtain ⟨_,shape,_,_,_,_,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_success + cap .fresh model ctx stack Q packet saved proofs _ a run + have splitReal : (runReal C iv (compile source)).view.observations = before ++ after := by + rw [← WHIRSourceChronology.real_source_trace] + exact splitTrace + have earlier := real_caller_prefix C iv (compile source) ctx Q packet before after splitReal queries + obtain ⟨input,reconstructed,count,statement⟩ := request_original cap packet.val.profile model saved + a.configuration shape (RawWHIRKeys.entry ctx packet.val) (latestAnswers before) a.request familyCap parsed + refine ⟨input,?_,count,statement⟩ + rw [← reconstructed] + apply original_prior_only + intro q member + rw [earlier q member] + rfl + + theorem real_verifySource_constructed (cap : Nat) (model : ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array MerkleTransport.PrunedMerklePaths) (C : PrimitiveOracle) (iv : Digest32) + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + {sourceQ boundary : Nat} + (entered : PCSBCSChallengeOracle.EnteredPacket packet.val.profile sourceQ iv boundary) + (entry : RawWHIRKeys.entry ctx packet.val = entered.1.val) + (success : (runReal C iv (compile + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs))).view.result.value = some a) : + ∃ input : CallerInput packet.val.profile, + original packet.val.profile model.layout saved entered.1.val + (PCSBCSSourceCallerAnswers.answers + (PCSBCSCallerCompletionCausality.realSourceTable (p := packet.val.profile) + (Q := sourceQ) (iv := iv) (boundary := boundary) C)) = some input ∧ + input.m = a.request.claims.count ∧ + ∀ root seed, OriginalClaimsChecker.input input.prepared root seed = + ⟨ParameterBounds.config packet.val.profile,saved.shape.lanes,root, + AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) saved + a.request.claims.family a.request.claims.points seed⟩ := by + obtain ⟨input,reconstructed,count,statement⟩ := + real_verifySource_original cap model ctx stack Q packet saved proofs C iv a familyCap success + rw [entry] at reconstructed + refine ⟨input,?_,count,statement⟩ + rw [← reconstructed] + apply original_prior_only + intro q member + exact PCSBCSCallerCompletionCausality.realSource_answers C entered ⟨q,member⟩ + + theorem real_verifySource_native_input (cap : Nat) (model : ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array MerkleTransport.PrunedMerklePaths) (C : PrimitiveOracle) + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (runReal C ctx.iv (compile + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs))).view.result.value = some a) : + let entered := PCSBCSNativePacketBridge.enteredPacket ctx stack Q packet + ∃ input : CallerInput packet.val.profile, + original packet.val.profile model.layout saved entered.1.val + (PCSBCSSourceCallerAnswers.answers + (PCSBCSCallerCompletionCausality.realSourceTable (p := packet.val.profile) + (Q := Q) (iv := ctx.iv) (boundary := entered.1.val.frames.length) C)) = some input ∧ + input.m = a.request.claims.count ∧ + ∀ root seed, OriginalClaimsChecker.input input.prepared root seed = + ⟨ParameterBounds.config packet.val.profile,saved.shape.lanes,root, + AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) saved + a.request.claims.family a.request.claims.points seed⟩ := + real_verifySource_constructed cap model ctx stack Q packet saved proofs C ctx.iv a familyCap + (PCSBCSNativePacketBridge.enteredPacket ctx stack Q packet) rfl success + +#print axioms real_caller_prefix +#print axioms request_original +#print axioms real_verifySource_original +#print axioms real_verifySource_constructed +#print axioms real_verifySource_native_input +end Whir.PCSBCSNativeCallerOriginal diff --git a/verification/whir/Whir/PCSBCSNativeCapturedLogs.lean b/verification/whir/Whir/PCSBCSNativeCapturedLogs.lean new file mode 100644 index 000000000..e0624e015 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeCapturedLogs.lean @@ -0,0 +1,133 @@ +import Whir.PCSBCSNativeCapturedRows + +/-! Literal capture logs are subsets of the ordinary records in the actual +allocation trace. This removes per-reference collision exclusions once a +single whole ordinary trace is clean; no probability bound is assumed here. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeCapturedLogs +open Concrete FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler TypedFiatShamirGame +open PCSStateRestoration.Latent PCSBCSSourceRootCapture PCSBCSCapturedNativeReplyBridge +open PCSBCSSourceRootReferences PublicMerkleLog + +section Prefix +universe u v w z +variable {Key : Type u} {Answer : Key → Type v} {Root : Type w} {R : Type z} + [DecidableEq Root] + +theorem firstMention_trace_prefix (address : Key → List Root) (root : Root) + {n : Nat} (program : Sampling Key Answer R n) (table : Table Key Answer) + (before : List (Sigma Answer)) + (found : PCSBCSFirstRootDisclosure.firstMention address root program table = some before) : + ∃ after, (Sampling.execute table program).2 = before ++ after := by + induction program generalizing before with + | ret => simp [PCSBCSFirstRootDisclosure.firstMention] at found + | draw key next ih => + unfold PCSBCSFirstRootDisclosure.firstMention at found + split at found + · have empty : before = [] := (Option.some.inj found).symm + subst before + exact ⟨(Sampling.execute table (.draw key next)).2,rfl⟩ + · cases tailFound : PCSBCSFirstRootDisclosure.firstMention address root (next (table key)) table with + | none => simp [tailFound] at found + | some tail => + simp only [tailFound,Option.map_some,Option.some.injEq] at found + subst before + obtain ⟨after,equal⟩ := ih (table key) tail tailFound + exact ⟨after,by simp only [Sampling.execute,equal,List.cons_append]⟩ +end Prefix + +section Records +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "Keys" => PCSBCSSourceRootCapture.Key (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +private theorem fold_membership (events : List (Sigma Answers)) (prior : PublicLog) + (record : Node × Digest32) : + record ∈ events.foldl (fun log event => ordinaryRecord event ++ log) prior ↔ + (∃ event ∈ events, record ∈ ordinaryRecord event) ∨ record ∈ prior := by + induction events generalizing prior with + | nil => simp + | cons event rest ih => + rw [List.foldl_cons,ih,List.mem_append] + constructor + · rintro (⟨found,present,recorded⟩ | (current | old)) + · exact Or.inl ⟨found,List.mem_cons_of_mem event present,recorded⟩ + · exact Or.inl ⟨event,List.mem_cons_self,current⟩ + · exact Or.inr old + · rintro (⟨found,present,recorded⟩ | old) + · rcases List.mem_cons.mp present with equal | present + · subst found + exact Or.inr (Or.inl recorded) + · exact Or.inl ⟨found,present,recorded⟩ + · exact Or.inr (Or.inr old) + +theorem ordinaryPrefix_membership (events : List (Sigma Answers)) (record : Node × Digest32) : + record ∈ ordinaryPrefix events ↔ ∃ event ∈ events, record ∈ ordinaryRecord event := by + simpa only [ordinaryPrefix,List.not_mem_nil,or_false] using fold_membership events [] record + +theorem sourceLog_subset {R : Type} {n : Nat} (address : Keys → List Reference) + (ref : Reference) (program : Sampling Keys Answers R n) (table : Table Keys Answers) : + ∀ record ∈ sourceLog address ref program table, + record ∈ ordinaryPrefix (Sampling.execute table program).2 := by + cases found : PCSBCSFirstRootDisclosure.firstMention address ref program table with + | none => simp [sourceLog,found,ordinaryPrefix] + | some before => + obtain ⟨after,trace⟩ := firstMention_trace_prefix address ref program table before found + intro record member + have captured : record ∈ ordinaryPrefix before := by simpa only [sourceLog,found,Option.getD_some] using member + obtain ⟨event,present,recorded⟩ := (ordinaryPrefix_membership before record).mp captured + apply (ordinaryPrefix_membership _ record).mpr + exact ⟨event,trace ▸ List.mem_append_left after present,recorded⟩ + +theorem sourceLog_collision {R : Type} {n : Nat} (address : Keys → List Reference) + (ref : Reference) (program : Sampling Keys Answers R n) (table : Table Keys Answers) + (bad : OutputCollision (sourceLog address ref program table)) : + OutputCollision (ordinaryPrefix (Sampling.execute table program).2) := by + obtain ⟨a,b,d,left,right,different⟩ := bad + exact ⟨a,b,d,sourceLog_subset address ref program table _ left, + sourceLog_subset address ref program table _ right,different⟩ +end Records + +section Driver +open MerkleTransport MerkleTransport.Commitments WHIRPhysicalVerifier +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) + (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +noncomputable def wholeLog : PublicLog := + ordinaryPrefix (Sampling.execute + (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) + (PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit)).2 + +theorem referenceLog_authentic (ref : Reference) : + AuthenticLog seed + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref) := by + unfold PCSBCSNativeCapturedRows.referenceLog + exact PCSBCSMerkleSeedProjection.sourceLog_authentic seed ro _ ref _ + +theorem referenceLog_collision (ref : Reference) + (bad : OutputCollision + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref)) : + OutputCollision (wholeLog cap model ctx stack Q packet saved proofs B limit seed ro) := by + unfold PCSBCSNativeCapturedRows.referenceLog at bad + exact sourceLog_collision _ ref _ _ bad + +theorem referenceLog_clean + (clean : ¬ OutputCollision (wholeLog cap model ctx stack Q packet saved proofs B limit seed ro)) + (ref : Reference) : + ¬ OutputCollision + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref) := + fun bad => clean (referenceLog_collision cap model ctx stack Q packet saved proofs B limit seed ro ref bad) +end Driver + +#print axioms firstMention_trace_prefix +#print axioms ordinaryPrefix_membership +#print axioms sourceLog_subset +#print axioms sourceLog_collision +#print axioms referenceLog_authentic +#print axioms referenceLog_collision +#print axioms referenceLog_clean +end Whir.PCSBCSNativeCapturedLogs diff --git a/verification/whir/Whir/PCSBCSNativeCapturedOracles.lean b/verification/whir/Whir/PCSBCSNativeCapturedOracles.lean new file mode 100644 index 000000000..f240aaa57 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeCapturedOracles.lean @@ -0,0 +1,159 @@ +import Whir.PCSBCSNativeCapturedRows +import Whir.PCSBCSNativeOracleReplay +import Whir.PCSBCSCapturedNativePhaseQuery + +/-! First-address getters, not later physical registry getters. Native success +fixes the initial digest; every actual selected row comes from its own captured +prefix unless the retained primitive-opening bad event occurs. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeCapturedOracles +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open MerkleTransport MerkleTransport.Commitments PublicMerkleLog +open WHIRPhysicalVerifier WHIRPhysicalReplay AnchoredPhysicalDriver +open PCSBCSSourceRootReferences + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) + (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +noncomputable def logFor (root : Digest32) (level : Nat) : PublicLog := + PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro + ⟨root,PCSBCSNativeRootRoles.nativeShape packet.val.profile saved level⟩ + +noncomputable def base : CausalGame.BaseOracle := + WHIRPhysicalRows.compactBaseOracle (hash seed) + ⟨recordDomain (records (logFor cap model ctx stack Q packet saved proofs B limit seed ro saved.root 0)),[]⟩ + saved.root (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2 + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0) + (leafWords packet.val.profile 0) saved.shape.lanes + +noncomputable def roots : WHIRReplay.Roots := fun root level => + frozenQueryOracle (hash seed) + ⟨recordDomain (records (logFor cap model ctx stack Q packet saved proofs B limit seed ro root level)),[]⟩ + root packet.val.profile level (2^(ParameterBounds.config packet.val.profile).folds[0]!) + +theorem roots_rectangular (root : Digest32) (level : Nat) : + oracleValid (roots cap model ctx stack Q packet saved proofs B limit seed ro root level) + (ParameterBounds.length (ParameterBounds.config packet.val.profile) level) + (2^(ParameterBounds.config packet.val.profile).folds[level]!) = true := by + have shape := frozenQueryOracle_valid (hash seed) + ⟨recordDomain (records (logFor cap model ctx stack Q packet saved proofs B limit seed ro root level)),[]⟩ + root packet.val.profile level (2^(ParameterBounds.config packet.val.profile).folds[0]!) (by rfl) + by_cases zero : level = 0 + · simpa only [roots,zero,ite_true] using shape + · simpa only [roots,ite_eq_right zero] using shape + +theorem base_valid (fits : saved.shape.lanes ≤ 2^(ParameterBounds.config packet.val.profile).folds[0]!) : + oracleValid (CausalGame.liftRoot (base cap model ctx stack Q packet saved proofs B limit seed ro)) + (2^((ParameterBounds.config packet.val.profile).logN-(ParameterBounds.config packet.val.profile).folds[0]!+ + (ParameterBounds.config packet.val.profile).rates[0]!)) saved.shape.lanes = true := by + have shape := WHIRPhysicalVerifier.compactBaseOracle_valid (hash seed) + ⟨recordDomain (records (logFor cap model ctx stack Q packet saved proofs B limit seed ro saved.root 0)),[]⟩ + saved.root (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2 + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0) + (2^(ParameterBounds.config packet.val.profile).folds[0]!) saved.shape.lanes fits + simpa only [base,leafWords,ite_true,ParameterBounds.length, + PCSBCSNativeRootRoles.production_initial_remaining] using shape + +theorem opening_log (profile : profileShape packet.val.profile saved.shape) + (opening : QueryOpening packet.val.profile) : + PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening = + logFor cap model ctx stack Q packet saved proofs B limit seed ro opening.root opening.level.val := by + unfold PCSBCSNativeCapturedRows.openingLog logFor + congr 1 + exact congrArg (fun shape => Reference.mk opening.root shape) + (PCSBCSNativeRootRoles.nativeShape_opening packet.val.profile saved profile opening.level.val).symm + +theorem verifySource_initial_root (a : Accepted ctx Q cap packet saved) + (observations : List Observation) + (run : PublicMerkleProgram.Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) observations (some a)) + (opening : QueryOpening packet.val.profile) (member : opening ∈ a.wire.openings) + (zero : opening.level.val = 0) : opening.root = saved.root := by + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs observations a run + have rooted := WHIRPhysicalRoots.trace_rooted saved.root trace opening member + have allRoots := WHIRPhysicalRoots.trace_roots saved.root + (WHIRPhysicalReplay.completion_chain ctx Q packet) trace + have label := rooted.1 + rw [allRoots,zero] at label + have same : saved.root = opening.root := by simpa using label + exact same.symm + +theorem mixed_success_boundRows + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths) : + WHIRPhysicalRoots.BoundRows (base cap model ctx stack Q packet saved proofs B limit seed ro) + (roots cap model ctx stack Q packet saved proofs B limit seed ro) a.wire := by + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro + rw [success] at run + have row := PCSBCSNativeCapturedRows.mixed_success_captured_rows cap model ctx stack Q packet saved proofs + B limit seed ro a familyCap success + intro opening member + have good := (row opening member).2.resolve_right (quiet opening member) + rw [opening_log cap model ctx stack Q packet saved proofs B limit seed ro a.configuration.2 opening] at good + by_cases zero : opening.level.val = 0 + · have rootEq := verifySource_initial_root cap model ctx stack Q packet saved proofs + a _ run opening member zero + simpa only [zero,rootEq,ite_true,base,frozenQueryOracle] using good + · simpa only [roots,frozenQueryOracle,ite_eq_right zero] using good + +theorem mixed_success_experiment + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths) : + ∃ replay : StackWHIRReplay.Replay packet.val.profile cap, ∃ proof, + replay.original = PCSBCSNativeOracleReplay.original a + (base cap model ctx stack Q packet saved proofs B limit seed ro) ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) + replay.whir.replies = .ok proof ∧ + WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a + (base cap model ctx stack Q packet saved proofs B limit seed ro))) + (roots cap model ctx stack Q packet saved proofs B limit seed ro) (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile a.history).tail⟩ = + some replay ∧ + CausalGame.experiment + (PCSBCSNativeOracleReplay.input a + (base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨_,_,lanesEq,_,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + have fits : saved.shape.lanes ≤ 2^(ParameterBounds.config packet.val.profile).folds[0]! := by + rw [← lanesEq] + exact a.request.lane_bound + exact PCSBCSNativeOracleReplay.verifySource_experiment .fresh model proofs _ a run + (base cap model ctx stack Q packet saved proofs B limit seed ro) + (roots cap model ctx stack Q packet saved proofs B limit seed ro) + (base_valid cap model ctx stack Q packet saved proofs B limit seed ro fits) + (roots_rectangular cap model ctx stack Q packet saved proofs B limit seed ro) + (mixed_success_boundRows cap model ctx stack Q packet saved proofs B limit seed ro a familyCap success quiet) + +end Driver +#print axioms roots_rectangular +#print axioms base_valid +#print axioms opening_log +#print axioms verifySource_initial_root +#print axioms mixed_success_boundRows +#print axioms mixed_success_experiment +end Whir.PCSBCSNativeCapturedOracles diff --git a/verification/whir/Whir/PCSBCSNativeCapturedReplyTransport.lean b/verification/whir/Whir/PCSBCSNativeCapturedReplyTransport.lean new file mode 100644 index 000000000..df92f9d7b --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeCapturedReplyTransport.lean @@ -0,0 +1,962 @@ +import Whir.PCSBCSNativeCapturedOracles +import Whir.PCSBCSNativeCapturedTape +import Whir.PCSBCSNativeSourceOriginal + +/-! Historical native captured-prefix reply joins. The next-root getter below +uses the very same first-address log as source inversion. It never identifies +an earlier capture with a later physical Merkle registry. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 100000 +namespace Whir.PCSBCSNativeCapturedReplyTransport +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open MerkleTransport MerkleTransport.Commitments PublicMerkleLog +open WHIRPhysicalVerifier WHIRPhysicalReplay AnchoredPhysicalDriver +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache +open PCSBCSCapturedNativeReplyBridge PCSBCSCapturedNativePhaseQuery +open PCSBCSSourceFrozenAccessor PCSBCSFrozenOracleRows + +/-- Actual physical root-role lookup implies source phase parsing at that +literal packet, including partially occupied initial shapes. -/ +theorem phaseReference_of_roles {ctx : RawWHIRKeys.Context} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) + (packet : RawWHIRKeys.Packet ctx Q) (state : WireState p) + (valid : saved.Valid) (profile : profileShape p saved.shape) + (roles : PCSBCSNativeRootRoles.RootRoles saved packet state) + (level : Nat) (root : Digest32) (found : state.roots[level]? = some root) : + phaseReference (ParameterBounds.config p) saved packet.val.messages level = + some ⟨root,PCSBCSNativeRootRoles.nativeShape p saved level⟩ := by + have indexed : + (PCSBCSNativeRootRoles.nativeReferences p saved state.roots)[level]? = + some ⟨root,PCSBCSNativeRootRoles.nativeShape p saved level⟩ := by + simp [PCSBCSNativeRootRoles.nativeReferences, List.getElem?_map, + List.getElem?_zipIdx, found] + rw [roles.references] at indexed + cases level with + | zero => + simp only [List.getElem?_cons_zero, Option.some.injEq] at indexed + rw [← indexed] + simp only [phaseReference, ↓reduceIte, parseInitial_roundtrip saved valid] + exact ite_eq_left profile + | succ level => + simp only [List.getElem?_cons_succ] at indexed + have shape : PCSBCSNativeRootRoles.nativeShape p saved (level+1) = + phaseShape (ParameterBounds.config p) (level+1) := by + simp [PCSBCSNativeRootRoles.nativeShape] + simp only [phaseReference, Nat.add_eq_zero_iff, Nat.one_ne_zero, and_false, + ↓reduceIte, roles.admitted, Nat.add_sub_cancel, indexed] + simp [shape, sameShape] + +/-- Each retained query has the reference of its own chronological input +packet, not the root-role list of a later packet. -/ +def QueryRoles {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) + (messages : List WHIRHistory.Pending) (state : WireState p) : Prop := + ∀ opening ∈ state.openings, + CausalProbability.position (.query opening.level : CausalProbability.Coordinate + (ParameterBounds.config p)) < messages.length ∧ + phaseReference (ParameterBounds.config p) saved + (messages.reverse.take (CausalProbability.position (.query opening.level : + CausalProbability.Coordinate (ParameterBounds.config p))+1)).reverse opening.level.val = + some (PCSBCSNativeRootRoles.openingRole saved opening) + +theorem QueryRoles.cons {p : ParameterBounds.Profile} {saved : AnchoredHeaderCodec.Record} + {messages : List WHIRHistory.Pending} {state : WireState p} + (roles : QueryRoles saved messages state) (m : WHIRHistory.Pending) : + QueryRoles saved (m::messages) state := by + intro opening member + obtain ⟨bound,reference⟩ := roles opening member + refine ⟨by simpa only [List.length_cons] using Nat.lt_succ_of_lt bound, ?_⟩ + have count : CausalProbability.position (.query opening.level : + CausalProbability.Coordinate (ParameterBounds.config p))+1 ≤ messages.reverse.length := by + simpa only [List.length_reverse] using Nat.succ_le_of_lt bound + simpa only [List.reverse_cons, List.take_append, Nat.sub_eq_zero_of_le count, + List.take_zero, List.append_nil] using reference + +theorem takeSample_queryRoles {ctx : RawWHIRKeys.Context} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) + (packet : RawWHIRKeys.Packet ctx Q) (proofs : Array PrunedMerklePaths) + (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : PublicMerkleProgram.Runs + (takeSample saved.shape.lanes proofs state q x) trace (some out)) + (valid : saved.Valid) (profile : profileShape p saved.shape) + (position : CausalProbability.position q+1 = packet.val.messages.length) + (prior : QueryRoles saved packet.val.messages state) + (roles : PCSBCSNativeRootRoles.RootRoles saved packet out) : + QueryRoles saved packet.val.messages out := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run + obtain ⟨before,opened,after,_,_,continued⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + intro opening member + rcases List.mem_cons.mp member with rfl | member + · refine ⟨by dsimp only; omega, ?_⟩ + have full : (packet.val.messages.reverse.take + (CausalProbability.position (.query i : + CausalProbability.Coordinate (ParameterBounds.config p))+1)).reverse = + packet.val.messages := by + rw [position] + rw [← List.length_reverse (as := packet.val.messages), List.take_length, List.reverse_reverse] + rw [full] + exact phaseReference_of_roles saved packet _ valid profile roles i.val _ hr + · exact prior opening member + · cases run + | initial => cases run; exact prior + | fold i j => cases run; exact prior + | ood i j => cases run; exact prior + | tail j => cases run; exact prior + +theorem step_queryRoles {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) + {proofs : Array PrunedMerklePaths} {packet : RawWHIRKeys.Packet ctx Q} + {profile : packet.val.profile = p} {state out : WireState p} + {raw : RawOracleCoupling.Concrete.GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p saved.shape.lanes proofs packet profile state raw out) + (valid : saved.Valid) (geometry : profileShape p saved.shape) + (prior : QueryRoles saved packet.val.messages state) + (roles : PCSBCSNativeRootRoles.RootRoles saved packet out) : + QueryRoles saved packet.val.messages out := by + cases step with + | run parsed size shape boundNonce accepted opened => + have absorbOpenings := PCSBCSNativeRootRoles.absorbResponse_openings _ _ _ _ parsed + have nonceOpenings := (PCSBCSNativeRootRoles.afterNonce_roots _ _ _ boundNonce).2 + apply takeSample_queryRoles saved packet _ _ _ _ _ _ opened valid geometry + · have positive := List.length_pos_iff.mpr packet.property.2.1 + have atPosition := packetQuery_position ctx Q p packet profile + omega + · intro opening member + rw [nonceOpenings,absorbOpenings] at member + exact prior opening member + · exact ⟨roles.count,roles.references,roles.admitted,roles.openings⟩ + +/-- Native execution derives every query's prefix reference, including the +initial partial occupancy and all full extension phases. -/ +theorem trace_queryRoles {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) + {proofs : Array PrunedMerklePaths} {packet : RawWHIRKeys.Packet ctx Q} + {packets : List (RawWHIRKeys.Packet ctx Q)} {out : WireState p} {history} + (valid : saved.Valid) (profile : profileShape p saved.shape) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p saved.shape.lanes proofs packets + (initialWireState p saved.root) out history) : + QueryRoles saved packet.val.messages out := by + induction chain generalizing out history with + | initial packet single => + cases trace with + | cons packetProfile step rest => + cases rest + apply step_queryRoles saved step valid profile + · intro opening member + cases member + · exact PCSBCSNativeRootRoles.roles_initial saved single step + | next m prior messages statement packetProfile ih => + obtain ⟨middle,before,after,hist,first,last⟩ := Trace.append_inv _ _ trace + cases last with + | cons finalProfile step rest => + cases rest + apply step_queryRoles saved step valid profile + · rw [messages] + exact (ih first).cons m + · exact PCSBCSNativeRootRoles.roles_next saved m messages + (trace_completed saved.root prior first) + (PCSBCSNativeRootRoles.trace_rootRoles saved prior first) step + +/-- The one tape input consists of actual whole construction-packet answers. +The current answer is never read when reconstructing its incoming prefix. -/ +theorem strictPrefix_of_raws {p : ParameterBounds.Profile} {Q : Nat} + {iv : Digest32} {boundary : Nat} + (final current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) + (table : PCSBCSSourcePacketTape.Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (ring : RingPCSGame.Prefix) (tape : CausalGame.Tape (ParameterBounds.config p)) + (raws : ∀ packet ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped packet.2.coord (table (.inl packet)) = + PCSBCSRestorationHazard.literalRaw ring tape packet.2.coord) : + PCSBCSSourcePacketTape.strictPrefix current (fun key => table key.val) = + WHIRFiatShamir.Prefix.ofTape current.2.coord tape := by + funext q earlier + change PCSBCSSourcePacketTape.project q + (PCSBCSChallengeOracle.grouped q (table (.inl (current.predecessor ⟨q,earlier⟩)))) = + CausalProbability.get q tape + have raw := raws _ (PCSBCSCapturedSourceStatePath.predecessor_mem_packets final current member ⟨q,earlier⟩) + change PCSBCSChallengeOracle.grouped q _ = PCSBCSRestorationHazard.literalRaw ring tape q at raw + rw [raw] + cases q <;> rfl + +theorem packets_query_prefix {p : ParameterBounds.Profile} {Q : Nat} + {iv : Digest32} {boundary : Nat} + (final current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) + (earlier : CausalProbability.position q < CausalProbability.position current.2.coord) : + current.2.messages.reverse.take (CausalProbability.position q+1) = + final.2.messages.reverse.take (CausalProbability.position q+1) := by + obtain ⟨r,_,equal⟩ := List.mem_map.mp member + subst current + by_cases before : CausalProbability.position r < CausalProbability.position final.2.coord + · have same : PCSBCSCapturedSourceStatePath.packetAt final r = final.predecessor ⟨r,before⟩ := + dite_eq_left before + rw [same] at earlier ⊢ + change (final.2.messages.drop + (CausalProbability.position final.2.coord-CausalProbability.position r)).reverse.take + (CausalProbability.position q+1) = _ + rw [List.reverse_drop, List.take_take] + have size := PCSBCSChallengeOracle.CanonicalPacket.messages_length final.2 + have limit : CausalProbability.position q+1 ≤ final.2.messages.length - + (CausalProbability.position final.2.coord-CausalProbability.position r) := by + change CausalProbability.position q < CausalProbability.position r at earlier + omega + rw [Nat.min_eq_left limit] + · rw [show PCSBCSCapturedSourceStatePath.packetAt final r = final from dite_eq_right before] + +/-- Successful physical-history parsing, retaining only the fields used by +the strict chronological reply transport. This is derived from the decoder. -/ +inductive Parses (p : ParameterBounds.Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (statement : Digest32) : + List WHIRHistory.Pending → + List (WHIRHistory.Pending × Sigma (@CausalProbability.Sample (ParameterBounds.config p))) → + WHIRReplay.Replay p → Prop where + | initial {m input} : + Parses p catalog roots rows statement [m] [] ⟨input,WHIRReplay.zeroTape p,#[]⟩ + | next {m previous older past q x before response} + (prior : Parses p catalog roots rows statement (previous::older) past before) + (position : CausalProbability.position q = older.length) + (parsed : WHIRPhysicalHistory.reply roots rows q m = some response) : + Parses p catalog roots rows statement (m::previous::older) ((previous,⟨q,x⟩)::past) + ⟨before.statement,CausalProbability.set q before.tape x,before.replies.push response⟩ + +theorem parses_of_decode (p : ParameterBounds.Profile) (catalog : WHIRReplay.Catalog p) + (roots : WHIRReplay.Roots) (rows : WHIRPhysicalHistory.Rows) (statement : Digest32) + (messages : List WHIRHistory.Pending) + (ancestors : List (WHIRHistory.Pending × Sigma (@CausalProbability.Sample (ParameterBounds.config p)))) + (out : WHIRReplay.Replay p) + (decoded : WHIRPhysicalHistory.decodeHistory p catalog roots rows statement messages ancestors = some out) : + Parses p catalog roots rows statement messages ancestors out := by + induction messages generalizing ancestors out with + | nil => cases decoded + | cons m messages ih => + cases messages with + | nil => + cases ancestors with + | cons entry rest => cases decoded + | nil => + simp only [WHIRPhysicalHistory.decodeHistory] at decoded + split at decoded + · cases found : catalog statement with + | none => simp [found] at decoded + | some input => + simp [found] at decoded + subst out + exact .initial + · cases decoded + | cons previous older => + cases ancestors with + | nil => cases decoded + | cons entry past => + rcases entry with ⟨previous',q,x⟩ + simp only [WHIRPhysicalHistory.decodeHistory] at decoded + split at decoded + · rename_i same + subst previous' + split at decoded + · split at decoded + · rename_i atPosition + split at decoded + · split at decoded + · cases prior : WHIRPhysicalHistory.decodeHistory p catalog roots rows statement + (previous::older) past with + | none => simp [prior] at decoded + | some before => + simp only [prior,WHIRPhysicalHistory.step] at decoded + obtain ⟨response,parsed,equal⟩ := Option.map_eq_some_iff.mp decoded + subst out + exact .next (ih past before prior) atPosition parsed + · cases decoded + · cases decoded + · cases decoded + · cases decoded + · cases decoded + +theorem Parses.size {p : ParameterBounds.Profile} {catalog : WHIRReplay.Catalog p} + {roots : WHIRReplay.Roots} {rows : WHIRPhysicalHistory.Rows} {statement messages ancestors out} + (parsed : Parses p catalog roots rows statement messages ancestors out) : + out.replies.size = messages.length-1 := by + induction parsed with + | initial => rfl + | next prior position decoded ih => + simp only [Array.size_push,List.length_cons] at ih ⊢ + omega + +theorem Parses.replyAt {p : ParameterBounds.Profile} {catalog : WHIRReplay.Catalog p} + {roots : WHIRReplay.Roots} {rows : WHIRPhysicalHistory.Rows} {statement messages ancestors out} + (parsed : Parses p catalog roots rows statement messages ancestors out) + (j : Nat) (earlier : j < out.replies.size) : + ∃ q m previous x, + (WHIRHistory.schedule (ParameterBounds.config p))[j]? = some q ∧ + messages.reverse[j+1]? = some m ∧ + WHIRPhysicalHistory.reply roots rows q m = some out.replies[j]! ∧ + (previous,⟨q,x⟩) ∈ ancestors := by + induction parsed generalizing j with + | initial => simp only [Array.size_empty] at earlier; omega + | @next m previous older past q x before response prior position decoded ih => + have size := prior.size + simp only [List.length_cons,Nat.add_sub_cancel] at size + by_cases last : j = before.replies.size + · subst j + have atPosition : CausalProbability.position q = before.replies.size := position.trans size.symm + refine ⟨q,m,previous,x,?_,?_,?_,List.mem_cons_self⟩ + · rw [← atPosition] + exact WHIRHistory.schedule_get_position q + · rw [size] + simp [List.reverse_cons] + · simpa only [getElem!_pos (before.replies.push response) before.replies.size + (by simp),Array.getElem_push_eq] using decoded + · have bound : j < before.replies.size := by simp only [Array.size_push] at earlier; omega + obtain ⟨coordinate,message,old,sample,scheduled,atMessage,atReply,inPast⟩ := ih j bound + refine ⟨coordinate,message,old,sample,scheduled,?_,?_,List.mem_cons_of_mem _ inPast⟩ + · rw [List.reverse_cons,List.getElem?_append_left (by + simp only [List.length_reverse,List.length_cons] + omega)] + exact atMessage + · have atIndex : (before.replies.push response)[j]! = before.replies[j]! := by + rw [getElem!_pos _ j (by simp; omega),getElem!_pos _ j bound,Array.getElem_push_lt bound] + rw [atIndex] + exact atReply + +theorem packets_position_le {p : ParameterBounds.Profile} {Q : Nat} + {iv : Digest32} {boundary : Nat} + (final current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) : + CausalProbability.position current.2.coord ≤ CausalProbability.position final.2.coord := by + obtain ⟨q,_,equal⟩ := List.mem_map.mp member + subst current + by_cases earlier : CausalProbability.position q < CausalProbability.position final.2.coord + · rw [show PCSBCSCapturedSourceStatePath.packetAt final q = final.predecessor ⟨q,earlier⟩ from + dite_eq_left earlier] + exact Nat.le_of_lt earlier + · rw [show PCSBCSCapturedSourceStatePath.packetAt final q = final from dite_eq_right earlier] + +theorem packets_message_at {p : ParameterBounds.Profile} {Q : Nat} + {iv : Digest32} {boundary : Nat} + (final current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) + (j : Nat) (earlier : j < CausalProbability.position current.2.coord) : + current.2.messages.reverse[j+1]? = final.2.messages.reverse[j+1]? := by + obtain ⟨q,_,equal⟩ := List.mem_map.mp member + subst current + by_cases before : CausalProbability.position q < CausalProbability.position final.2.coord + · have same : PCSBCSCapturedSourceStatePath.packetAt final q = final.predecessor ⟨q,before⟩ := + dite_eq_left before + rw [same] at earlier ⊢ + change (final.2.messages.drop + (CausalProbability.position final.2.coord-CausalProbability.position q)).reverse[j+1]? = _ + rw [List.reverse_drop,List.getElem?_take] + have size := PCSBCSChallengeOracle.CanonicalPacket.messages_length final.2 + have bound : j+1 < final.2.messages.length - + (CausalProbability.position final.2.coord-CausalProbability.position q) := by + change j < CausalProbability.position q at earlier + omega + rw [ite_eq_left bound] + · rw [show PCSBCSCapturedSourceStatePath.packetAt final q = final from dite_eq_right before] + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) + (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +noncomputable abbrev addresses := + PCSBCSCapturedSourceTransport.address (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length) + +noncomputable abbrev program := + PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit + +noncomputable abbrev table := PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro + +/-- Ordinary authentication follows from the actual mixed table's seed summand, +including captures preceding root announcements. It is not a row-equality input. -/ +theorem referenceLog_authentic (ref : Reference) : + AuthenticLog seed (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs + B limit seed ro ref) := by + exact PCSBCSMerkleSeedProjection.sourceLog_authentic seed ro + (addresses ctx Q packet B) ref + (program cap model ctx stack Q packet saved proofs B limit) + +/-- Parsed next roles have exactly the shape used by the captured root getter. -/ +theorem next_log (i : Fin (ParameterBounds.config packet.val.profile).folds.size) + (j : Fin (ParameterBounds.config packet.val.profile).folds[i.val]!) + (m : WHIRHistory.Pending) (ref : Reference) + (parsed : parsePhase (ParameterBounds.config packet.val.profile) (.fold i j) m (i.val+1) 2 = some ref) : + PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref = + PCSBCSNativeCapturedOracles.logFor cap model ctx stack Q packet saved proofs B limit seed ro + ref.root (i.val+1) := by + have shape := (parsePhase_admitted _ _ _ _ _ _ parsed).2.2.2 + unfold PCSBCSNativeCapturedOracles.logFor + congr 1 + cases ref + congr 1 + +/-- The full next table is the projection of the same literal captured prefix. +No later whole-cache equality is present, even as an intermediate hypothesis. -/ +theorem next_projection (i : Fin (ParameterBounds.config packet.val.profile).folds.size) + (j : Fin (ParameterBounds.config packet.val.profile).folds[i.val]!) + (m : WHIRHistory.Pending) (ref : Reference) + (parsed : parsePhase (ParameterBounds.config packet.val.profile) (.fold i j) m (i.val+1) 2 = some ref) + (clean : ¬ OutputCollision (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved + proofs B limit seed ro ref)) : + extensionOracle (WHIRPhysicalRows.compactBaseOracle (hash seed) + ⟨recordDomain (records (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved + proofs B limit seed ro ref)),[]⟩ ref.root ref.shape.height (2^ref.shape.height) + ref.shape.leafWords ref.shape.occupied) = + some (PCSBCSNativeCapturedOracles.roots cap model ctx stack Q packet saved proofs B limit seed ro + ref.root (i.val+1)) := by + have projection := (parsed_next_projection seed + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref) + packet.val.profile i j m ref parsed + (referenceLog_authentic cap model ctx stack Q packet saved proofs B limit seed ro ref) clean).1 + rw [next_log cap model ctx stack Q packet saved proofs B limit seed ro i j m ref parsed] at projection ⊢ + simpa only [PCSBCSNativeCapturedOracles.roots, frozenQueryOracle, Nat.add_eq_zero_iff, + Nat.one_ne_zero, and_false, ↓reduceIte] using projection + +/-- A real native opening against its parser-admitted reference supplies source +query evidence or the exact captured-prefix opening bad event used by BoundRows. +Neither full occupancy nor captured/native row equality is an input. -/ +theorem query_evidence + (current : CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) + (messages : List WHIRHistory.Pending) (past : WHIRFiatShamir.Prefix current) + (m : WHIRHistory.Pending) (digest : Digest32) + (i : Fin (ParameterBounds.config packet.val.profile).folds.size) (a : Message E) + (earlier : CausalProbability.position (.query i : CausalProbability.Coordinate + (ParameterBounds.config packet.val.profile)) < CausalProbability.position current) + (ref : Reference) + (reference : phaseReference (ParameterBounds.config packet.val.profile) saved + (messages.reverse.take (CausalProbability.position (.query i : CausalProbability.Coordinate + (ParameterBounds.config packet.val.profile))+1)).reverse i.val = some ref) + (fits : saved.shape.lanes ≤ 2^(ParameterBounds.config packet.val.profile).folds[0]!) + (proof : PrunedMerklePaths) (out : Opened) + (accepted : (runReal seed ctx.iv + (openQuery packet.val.profile i saved.shape.lanes proof ref.root (past (.query i) earlier))).view.result = + some out) : + SourceEvidence (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed current saved messages past m digest (.query i) (.query out.rows a) ∨ + PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref) + ref.root out.paths := by + exact source_query_of_native (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed current saved messages past m digest i a earlier ref reference + (referenceLog_authentic cap model ctx stack Q packet saved proofs B limit seed ro ref) + fits proof out accepted +/-- Every actual accepted native query transports to every later literal +construction packet. Reference, authentication, sampled queries and semantic +rows are derived from the run. The sole tape premise is whole-packet raw +agreement; the bad alternative is the parent's exact openingLog event. -/ +theorem mixed_success_query + (a : Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved + proofs ctx.iv B limit seed ro).result.value = some a) + (final current : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv + (RawWHIRKeys.entry ctx packet.val).frames.length) + (messages : final.2.messages = packet.val.messages) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) + (ring : RingPCSGame.Prefix) + (raws : ∀ sourcePacket ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped sourcePacket.2.coord + ((table ctx Q packet B seed ro) (.inl sourcePacket)) = + PCSBCSRestorationHazard.literalRaw ring a.wire.tape sourcePacket.2.coord) + (opening : QueryOpening packet.val.profile) (opened : opening ∈ a.wire.openings) + (earlier : CausalProbability.position (.query opening.level : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) < + CausalProbability.position current.2.coord) + (m : WHIRHistory.Pending) (digest : Digest32) (introMessage : Message E) : + SourceEvidence (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed current.2.coord saved current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table ctx Q packet B seed ro) key.val)) + m digest (.query opening.level) (.query opening.result.rows introMessage) ∨ + PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths := by + obtain ⟨run,_,consistent⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨_,_,lanesEq,trace,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + have chain := completion_chain ctx Q packet + have reference := (trace_queryRoles saved a.configuration.1 a.configuration.2 chain trace opening opened).2 + have earlierPrefix := packets_query_prefix final current member (.query opening.level) earlier + rw [← messages,← earlierPrefix] at reference + have sample := (WHIRPhysicalRoots.trace_samples saved.root chain trace opening opened).2 + have past := strictPrefix_of_raws final current member (table ctx Q packet B seed ro) ring a.wire.tape raws + have sampleAt : PCSBCSSourcePacketTape.strictPrefix current + (fun key => (table ctx Q packet B seed ro) key.val) (.query opening.level) earlier = + opening.sample := by + rw [past] + exact sample + obtain ⟨proof,_,accepted,_⟩ := AnchoredIdealPhysicalAcceptance.observed_real + (observed opening opened) seed ctx.iv consistent + have fits : saved.shape.lanes ≤ 2^(ParameterBounds.config packet.val.profile).folds[0]! := by + rw [← lanesEq] + exact a.request.lane_bound + have evidence := query_evidence cap model ctx stack Q packet saved proofs B limit seed ro + current.2.coord current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table ctx Q packet B seed ro) key.val)) + m digest opening.level introMessage earlier (PCSBCSNativeRootRoles.openingRole saved opening) + reference fits proof opening.result (by simpa only [sampleAt,PCSBCSNativeRootRoles.openingRole] using accepted) + have log : PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro + (PCSBCSNativeRootRoles.openingRole saved opening) = + PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening := by + exact (PCSBCSNativeCapturedOracles.opening_log cap model ctx stack Q packet saved proofs B limit seed ro + a.configuration.2 opening).symm + rw [log] at evidence + exact evidence + +theorem decodeMessage_fields (xs : List E) (message : Message E) + (parsed : WHIRHistory.decodeMessage xs = some message) : + xs = WHIRHistory.messageScalars message := by + cases xs with + | nil => cases parsed + | cons a rest => + cases rest with + | nil => cases parsed + | cons b rest => + cases rest with + | cons c rest => cases parsed + | nil => + cases Option.some.inj parsed + rfl + +private theorem source_of_parser + (current : CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) + (messages : List WHIRHistory.Pending) (past : WHIRFiatShamir.Prefix current) + (q : CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) + (m : WHIRHistory.Pending) (native : CausalGame.Reply) (rows : WHIRPhysicalHistory.Rows) + (earlier : CausalProbability.position q < CausalProbability.position current) + (parsed : WHIRPhysicalHistory.reply + (PCSBCSNativeCapturedOracles.roots cap model ctx stack Q packet saved proofs B limit seed ro) + rows q m = some native) + (clean : ∀ ref, ¬ OutputCollision + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref)) + (queries : ∀ (i : Fin (ParameterBounds.config packet.val.profile).folds.size) (introMessage : Message E), + CausalProbability.position (.query i : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) < + CausalProbability.position current → + SourceEvidence (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed current saved messages past m DuplexRefinement.zeroDigest (.query i) (.query (rows i.val) introMessage)) : + ∃ digest, WHIRHistory.replyScalars q digest native = some m.scalars ∧ + SourceEvidence (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed current saved messages past m digest q native := by + cases q with + | initial => + obtain ⟨message,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + exact ⟨DuplexRefinement.zeroDigest,congrArg some (decodeMessage_fields _ _ decoded).symm,.initial message⟩ + | tail j => + obtain ⟨message,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + exact ⟨DuplexRefinement.zeroDigest,congrArg some (decodeMessage_fields _ _ decoded).symm,.tail j message⟩ + | query i => + obtain ⟨message,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + exact ⟨DuplexRefinement.zeroDigest,congrArg some (decodeMessage_fields _ _ decoded).symm, + queries i message earlier⟩ + | ood i j => + cases m with + | mk scalars nonce => + cases scalars with + | nil => cases parsed + | cons value rest => + cases rest with + | nil => cases parsed + | cons a rest => + cases rest with + | nil => cases parsed + | cons b rest => + cases rest with + | cons c rest => cases parsed + | nil => + cases Option.some.inj parsed + exact ⟨DuplexRefinement.zeroDigest,rfl,.ood i j ⟨value,⟨a,b⟩⟩⟩ + | fold i j => + cases m with + | mk scalars nonce => + cases scalars with + | nil => cases parsed + | cons a rest => + cases rest with + | nil => cases parsed + | cons b rest => + by_cases last : j.val+1 = (ParameterBounds.config packet.val.profile).folds[i.val]! + · by_cases later : i.val+1 < (ParameterBounds.config packet.val.profile).folds.size + · cases rest with + | nil => simp [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last,later] at parsed + | cons r rest => + cases rest with + | nil => simp [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last,later] at parsed + | cons s rest => + cases rest with + | cons extra rest => + simp [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last,later] at parsed + | nil => + simp only [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars, + last,↓reduceIte,later] at parsed + obtain ⟨digest,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + let ref : Reference := ⟨digest,phaseShape (ParameterBounds.config packet.val.profile) (i.val+1)⟩ + have reference : parsePhase (ParameterBounds.config packet.val.profile) (.fold i j) + ⟨[a,b,r,s],nonce⟩ (i.val+1) 2 = some ref := by + simp [parsePhase,last,later,parseRootScalars,decoded,ref] + have auth := referenceLog_authentic cap model ctx stack Q packet saved proofs B limit seed ro ref + have projection := next_projection cap model ctx stack Q packet saved proofs B limit seed ro + i j ⟨[a,b,r,s],nonce⟩ ref reference (clean ref) + have pair := ByteCodec.hashToScalars_scalarsToHash (r,s) digest decoded + refine ⟨digest,?_,?_⟩ + · simp only [WHIRHistory.replyScalars,last,↓reduceIte,WHIRHistory.boundaryScalars, + later,WHIRHistory.messageScalars,WHIRHistory.rootScalars,pair] + rfl + · exact .next i j ⟨a,b⟩ _ last later ref + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref) + reference rfl (Nat.le_refl _) auth (clean ref) projection + · simp only [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last, + ↓reduceIte,ite_eq_right later] at parsed + split at parsed + · rename_i width + cases Option.some.inj parsed + refine ⟨DuplexRefinement.zeroDigest,?_,.terminal i j ⟨a,b⟩ rest.toArray last later ?_⟩ + · simp [WHIRHistory.replyScalars,last,WHIRHistory.boundaryScalars,later, + WHIRHistory.messageScalars] + · simpa only [List.size_toArray] using width + · cases parsed + · simp only [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars, + ite_eq_right last] at parsed + split at parsed + · rename_i empty + subst rest + cases Option.some.inj parsed + exact ⟨DuplexRefinement.zeroDigest,by simp only [WHIRHistory.replyScalars, + ite_eq_right last,WHIRHistory.messageScalars,List.append_nil],.middle i j ⟨a,b⟩ last⟩ + · cases parsed + +/-- Deterministic reply join for the canonical replay decoder. Physical scalar +normal forms, chronological messages, query proofs and next tables are derived; +only the separately owned whole-packet raw join and primitive event exclusions +remain premises. The decoder equation is supplied by the native run endpoint. -/ +theorem replyTransport_of_canonical_decode + (a : Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved + proofs ctx.iv B limit seed ro).result.value = some a) + (replay : StackWHIRReplay.Replay packet.val.profile cap) + (decoded : WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro))) + (PCSBCSNativeCapturedOracles.roots cap model ctx stack Q packet saved proofs B limit seed ro) + (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages, + (localHistory ctx stack Q packet.val.profile a.history).tail⟩ = some replay) + (final : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv + (RawWHIRKeys.entry ctx packet.val).frames.length) + (messages : final.2.messages = packet.val.messages) + (raws : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped current.2.coord ((table ctx Q packet B seed ro) (.inl current)) = + PCSBCSRestorationHazard.literalRaw replay.initial.1 a.wire.tape current.2.coord) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths) + (clean : ∀ ref, ¬ OutputCollision + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref)) : + ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSCapturedSourceAcceptance.ReplyTransport (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed saved current replay.whir.replies := by + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + have chain := completion_chain ctx Q packet + let original := PCSBCSNativeOracleReplay.original a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) + obtain ⟨initial,_,rest⟩ := Option.bind_eq_some_iff.mp decoded + obtain ⟨whir,parsedWhir,equal⟩ := Option.bind_eq_some_iff.mp rest + have equal : (⟨original,initial,whir⟩ : StackWHIRReplay.Replay packet.val.profile cap) = replay := + Option.some.inj equal + have whirEq : whir = replay.whir := congrArg StackWHIRReplay.Replay.whir equal + have parsed := parses_of_decode packet.val.profile (StackWHIRReplay.localCatalog original initial) + (PCSBCSNativeCapturedOracles.roots cap model ctx stack Q packet saved proofs B limit seed ro) + (fun i => a.wire.rows[i]!) packet.val.statement packet.val.messages + ((localHistory ctx stack Q packet.val.profile a.history).tail.map StackWHIRReplay.projectEntry) + replay.whir (by + rw [← whirEq] + exact parsedWhir) + have size : replay.whir.replies.size = CausalProbability.position final.2.coord := by + rw [parsed.size,← messages,PCSBCSChallengeOracle.CanonicalPacket.messages_length final.2] + omega + intro current member j earlier + have bound : j < replay.whir.replies.size := by + rw [size] + exact Nat.lt_of_lt_of_le earlier (packets_position_le final current member) + obtain ⟨q,m,previous,sample,scheduled,atMessage,atReply,inAncestors⟩ := parsed.replyAt j bound + have qPosition := PCSBCSCapturedSourceAcceptance.schedule_coordinate_position j q scheduled + have prior : CausalProbability.position q < CausalProbability.position current.2.coord := by + rw [qPosition] + exact earlier + have currentMessage : current.2.messages.reverse[j+1]? = some m := by + rw [packets_message_at final current member j earlier,messages] + exact atMessage + obtain ⟨digest,scalars,evidence⟩ := source_of_parser cap model ctx stack Q packet saved proofs B limit seed ro + current.2.coord current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table ctx Q packet B seed ro) key.val)) + q m replay.whir.replies[j]! (fun i => a.wire.rows[i]!) prior atReply clean (by + intro i introMessage earlierQuery + have queryBound : CausalProbability.position (.query i : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) < replay.whir.replies.size := by + rw [size] + exact Nat.lt_of_lt_of_le earlierQuery (packets_position_le final current member) + obtain ⟨coordinate,message,old,x,atCoordinate,_,_,inPast⟩ := + parsed.replyAt (CausalProbability.position (.query i : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile))) queryBound + have same : coordinate = .query i := Option.some.inj + (atCoordinate.symm.trans (WHIRHistory.schedule_get_position (.query i))) + subst coordinate + have recorded := WHIRPhysicalRoots.projectEntry_query_mem + (localHistory ctx stack Q packet.val.profile a.history).tail old i x inPast + have recorded : (old,⟨.query i,x⟩) ∈ localHistory ctx stack Q packet.val.profile a.history := + List.mem_of_mem_tail recorded + obtain ⟨opening,opened,level,sample⟩ := WHIRPhysicalRoots.trace_recorded trace _ recorded + have row := (WHIRPhysicalRoots.trace_rooted saved.root trace opening opened).2 + cases opening with + | mk level' root x' result => + dsimp only at level sample row + subst level' + have rowEq : a.wire.rows[i.val]! = result.rows := by + rw [getElem!_def,row] + have source := (mixed_success_query cap model ctx stack Q packet saved proofs B limit seed ro a success + final current messages member replay.initial.1 raws ⟨i,root,x',result⟩ opened earlierQuery + m DuplexRefinement.zeroDigest introMessage).resolve_right + (quiet ⟨i,root,x',result⟩ opened) + rw [rowEq] + exact source) + exact ⟨q,m,digest,scheduled,currentMessage,scalars,evidence⟩ + +/-- The literal captured assembly contains exactly the strict native replies, +the actual earlier sampled challenges, and the initial captured source root. -/ +def CapturedAssembly (original : PCSBCSCallerBinding.CallerInput packet.val.profile) + (current : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv + (RawWHIRKeys.entry ctx packet.val).frames.length) + (ring : RingPCSGame.Prefix) (tape : CausalGame.Tape (ParameterBounds.config packet.val.profile)) + (native : Array CausalGame.Reply) : Prop := + ∃ parsed, + PCSBCSSourceFrozenReplies.replies current.2.coord saved + (PCSBCSSourceCallerSnapshot.capturedRegistry (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) current + (fun key => (table ctx Q packet B seed ro) key.val)) + current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table ctx Q packet B seed ro) key.val)) = + some parsed ∧ + parsed = PCSRoundByRoundTranscriptState.priorAnswers native (CausalProbability.position current.2.coord) ∧ + PCSBCSRestorationHazard.incomingTrace + (PCSBCSSourcePacketTape.ringPrefix current (fun key => (table ctx Q packet B seed ro) key.val)) + (PCSBCSSourcePacketTape.tape current (fun key => (table ctx Q packet B seed ro) key.val)) parsed current.2.coord = + PCSBCSRestorationHazard.incomingTrace ring tape native current.2.coord ∧ + PCSBCSSourceCallerSnapshot.fromCapture (addresses ctx Q packet B) + ⟨saved.root,initialShape saved.shape⟩ (program cap model ctx stack Q packet saved proofs B limit) + original saved current (fun key => (table ctx Q packet B seed ro) key.val) = + some (PCSBCSRestorationHazard.literalCallerData packet.val.profile original + (PCSBCSNativeSourceOriginal.sourceBase cap model ctx stack Q packet saved proofs B limit seed ro) + ring tape native current.2.coord) + +private theorem captured_assembly + (a : Accepted ctx Q cap packet saved) + (original : PCSBCSCallerBinding.CallerInput packet.val.profile) (claims : AnchoredSourceCaller.Claims) + (caller : AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table ctx Q packet B seed ro)) = some claims) + (final current : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv + (RawWHIRKeys.entry ctx packet.val).frames.length) + (entry : final.1.val = RawWHIRKeys.entry ctx packet.val) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) + (recorded : (⟨.inl current,(table ctx Q packet B seed ro) (.inl current)⟩ : + Sigma PCSBCSSourceRootCapture.Answer) ∈ + (Sampling.execute (table ctx Q packet B seed ro) + (program cap model ctx stack Q packet saved proofs B limit)).2) + (ring : RingPCSGame.Prefix) (tape : CausalGame.Tape (ParameterBounds.config packet.val.profile)) + (native : Array CausalGame.Reply) + (raws : ∀ sourcePacket ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped sourcePacket.2.coord ((table ctx Q packet B seed ro) (.inl sourcePacket)) = + PCSBCSRestorationHazard.literalRaw ring tape sourcePacket.2.coord) + (transport : PCSBCSCapturedSourceAcceptance.ReplyTransport (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed saved current native) + (clean : ∀ ref, ¬ OutputCollision + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref)) : + CapturedAssembly cap model ctx stack Q packet saved proofs B limit seed ro original current ring tape native := by + have currentEntry : current.1.val = RawWHIRKeys.entry ctx packet.val := + (congrArg Subtype.val (PCSBCSCapturedSourceStatePath.packets_entry final current member)).trans entry + have roles := PCSBCSCapturedSourceAcceptance.roles_from_transport + (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed saved current native transport + have addressRoles := PCSBCSCapturedSourceTransport.address_packet model.layout saved + (PCSBCSSourceCallerAnswers.answers (table ctx Q packet B seed ro)) current + a.configuration.1 a.configuration.2 claims (by simpa only [currentEntry] using caller) roles + have visited : (.inl current) ∈ + ((Sampling.execute (table ctx Q packet B seed ro) + (program cap model ctx stack Q packet saved proofs B limit)).2.map Sigma.fst) := + List.mem_map.mpr ⟨_,recorded,rfl⟩ + let ref : Reference := ⟨saved.root,initialShape saved.shape⟩ + let log := PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref + have mentioned : ref ∈ addresses ctx Q packet B (.inl current) := by + change ref ∈ PCSBCSCapturedSourceTransport.address (.inl current) + rw [addressRoles] + exact List.mem_cons_self + have root := source_registry_enabled (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + current ref mentioned visited + have root : PCSBCSSourceCallerSnapshot.capturedRegistry (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) current + (fun key => (table ctx Q packet B seed ro) key.val) ref = some (freeze log ref.root ref.shape) := root + have inverses := PCSBCSCapturedSourceAcceptance.source_inverse + (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed saved current native addressRoles visited transport + obtain ⟨parsed,assembled⟩ := PCSBCSCapturedSourceTransport.replies_complete current.2.coord saved + (PCSBCSSourceCallerSnapshot.capturedRegistry (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) current + (fun key => (table ctx Q packet B seed ro) key.val)) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table ctx Q packet B seed ro) key.val)) + (by + intro j earlier + obtain ⟨inverted,found,_⟩ := Option.map_eq_some_iff.mp (inverses j earlier) + exact ⟨inverted,found⟩) + have parsedEq := PCSBCSCapturedSourceStatePath.replies_exact current.2.coord saved _ _ _ native parsed assembled inverses + have priorRaws : ∀ earlier : current.Earlier, + PCSBCSSourcePacketTape.rawPrefix current (fun key => (table ctx Q packet B seed ro) key.val) + earlier.val earlier.property = PCSBCSRestorationHazard.literalRaw ring tape earlier.val := by + intro earlier + rw [PCSBCSSourcePacketTape.rawPrefix_table] + exact raws _ (PCSBCSCapturedSourceStatePath.predecessor_mem_packets final current member earlier) + have incoming := PCSBCSCapturedSourceStatePath.incoming_exact current + (table ctx Q packet B seed ro) ring tape native parsed parsedEq priorRaws + have snapshot := PCSBCSCapturedSourceStatePath.fromCapture_exact + (addresses ctx Q packet B) ref + (program cap model ctx stack Q packet saved proofs B limit) original saved current + (table ctx Q packet B seed ro) (freeze log ref.root ref.shape) root ring tape native priorRaws inverses + have rawEq : (freeze log ref.root ref.shape).raw = + PCSBCSNativeSourceOriginal.sourceBase cap model ctx stack Q packet saved proofs B limit seed ro := + (next_image_provenance seed log ref + (referenceLog_authentic cap model ctx stack Q packet saved proofs B limit seed ro ref) (clean ref)).2 + rw [rawEq] at snapshot + exact ⟨parsed,assembled,parsedEq,incoming,snapshot⟩ + +/-- Actual mixed-source composition for every literal recorded construction +packet. Both the native strategy and the captured snapshots use the canonically +restored replies. Arbitrary partial initial occupancy is retained. The only +cryptographic exclusions are the actual openingLog bad events and captured +ordinary-prefix output collisions; no FS probability bound is asserted. -/ +theorem mixed_success_replyTransport + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved + proofs ctx.iv B limit seed ro).result.value = some a) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths) + (clean : ∀ ref, ¬ OutputCollision + (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro ref)) : + ∃ (original : PCSBCSCallerBinding.CallerInput packet.val.profile) + (claims : AnchoredSourceCaller.Claims) (replay : StackWHIRReplay.Replay packet.val.profile cap) + (proof : Opening) (bounded : DuplexFraming.pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B), + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket ctx stack B packetB + let native := PCSBCSCapturedSourceAcceptance.nativeReplies original + (PCSBCSNativeSourceOriginal.sourceBase cap model ctx stack Q packet saved proofs B limit seed ro) + (fun _ => CausalStrategy.indexedStrategy replay.whir.replies) replay.initial.1 a.wire.tape + PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table ctx Q packet B seed ro)) = some original ∧ + AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table ctx Q packet B seed ro)) = some claims ∧ + PCSBCSCapturedSourceAcceptance.BoundOriginal original saved claims ∧ + final.2.coord = PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config packet.val.profile) ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) + replay.whir.replies = .ok proof ∧ + WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro))) + (PCSBCSNativeCapturedOracles.roots cap model ctx stack Q packet saved proofs B limit seed ro) + (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile a.history).tail⟩ = + some replay ∧ + CausalGame.experiment + (OriginalClaimsChecker.input original.prepared + (PCSBCSNativeSourceOriginal.sourceBase cap model ctx stack Q packet saved proofs B limit seed ro) + replay.initial.1) (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true ∧ + native = replay.whir.replies ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped current.2.coord ((table ctx Q packet B seed ro) (.inl current)) = + PCSBCSRestorationHazard.literalRaw replay.initial.1 a.wire.tape current.2.coord) ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSCapturedSourceAcceptance.ReplyTransport (addresses ctx Q packet B) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + seed saved current native) ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + CapturedAssembly cap model ctx stack Q packet saved proofs B limit seed ro + original current replay.initial.1 a.wire.tape native) := by + obtain ⟨original,claims,replay,proof,reconstructed,caller,bound,initial,lambda,erased,parsed,canonical,accepted⟩ := + PCSBCSNativeSourceOriginal.mixed_success_original_experiment + cap model ctx stack Q packet saved proofs B limit seed ro a familyCap success quiet + obtain ⟨seed0,bounded,seedState,depth,terminal,ordering,recorded,raws⟩ := + PCSBCSNativeCapturedTape.mixed_success_tape cap model ctx stack Q packet saved proofs B limit seed ro a success + have seedEq : seed0 = replay.initial := Option.some.inj (seedState.symm.trans initial) + subst seed0 + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket ctx stack B packetB + have messages : final.2.messages = packet.val.messages := rfl + have entry : final.1.val = RawWHIRKeys.entry ctx packet.val := rfl + have nativeEq := PCSBCSNativeSourceOriginal.nativeReplies_indexed original + (PCSBCSNativeSourceOriginal.sourceBase cap model ctx stack Q packet saved proofs B limit seed ro) + replay.initial.1 a.wire.tape replay.whir.replies proof parsed + have transport := replyTransport_of_canonical_decode cap model ctx stack Q packet saved proofs B limit seed ro + a success replay canonical final messages raws quiet clean + refine ⟨original,claims,replay,proof,bounded,reconstructed,caller,bound,terminal,initial,lambda, + erased,parsed,canonical,accepted,nativeEq,raws,?_,?_⟩ + · rw [nativeEq] + exact transport + · rw [nativeEq] + intro current member + exact captured_assembly cap model ctx stack Q packet saved proofs B limit seed ro a original claims caller + final current entry member (recorded current member) replay.initial.1 a.wire.tape replay.whir.replies + raws (transport current member) clean + +end Driver + +#print axioms phaseReference_of_roles +#print axioms trace_queryRoles +#print axioms strictPrefix_of_raws +#print axioms packets_query_prefix +#print axioms referenceLog_authentic +#print axioms next_log +#print axioms next_projection +#print axioms query_evidence +#print axioms mixed_success_query +#print axioms replyTransport_of_canonical_decode +#print axioms mixed_success_replyTransport +end Whir.PCSBCSNativeCapturedReplyTransport diff --git a/verification/whir/Whir/PCSBCSNativeCapturedRows.lean b/verification/whir/Whir/PCSBCSNativeCapturedRows.lean new file mode 100644 index 000000000..ff8d5c7be --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeCapturedRows.lean @@ -0,0 +1,87 @@ +import Whir.PCSBCSNativeRootRoles +import Whir.PCSBCSNativePacketVisit + +/-! Actual successful historical mixed source to every literal first-address +capture. Visitation and address membership are derived, not endpoint premises. +The retained bad alternative concerns opening against the earlier prefix; this +is not a uniform-primitive bound or a Fiat-Shamir extraction theorem. +-/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeCapturedRows +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open RawOracleCoupling PCSBCSChallengeOracle WHIRSourceChronology AnchoredPhysicalDriver +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache PCSBCSCapturedNativeReplyBridge +open PCSBCSCapturedSourceAcceptance PublicMerkleLog MerkleTransport +open MerkleTransport.Commitments + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) + (limit : WHIRPhysicalVerifier.sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +private noncomputable abbrev addresses := + PCSBCSCapturedSourceTransport.address (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length) + +private noncomputable abbrev program := + PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit + +private noncomputable abbrev table := PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro + +noncomputable def referenceLog (ref : Reference) : PublicLog := + sourceLog (addresses ctx Q packet B) ref + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) + +noncomputable def openingLog (opening : WHIRPhysicalVerifier.QueryOpening packet.val.profile) : PublicLog := + referenceLog cap model ctx stack Q packet saved proofs B limit seed ro + (PCSBCSCapturedIdealNativeAcceptance.openingReference ctx Q packet opening saved.shape.lanes) + +theorem mixed_success_captured_rows + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro).result.value = some a) : + ∀ opening ∈ a.wire.openings, + let log := openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening + AuthenticLog seed log ∧ + (opening.result.rows = WHIRPhysicalVerifier.atQueries + (WHIRPhysicalVerifier.frozenQueryOracle (hash seed) ⟨recordDomain (records log),[]⟩ + opening.root packet.val.profile opening.level.val saved.shape.lanes) + (WHIRPhysicalVerifier.queryIndices packet.val.profile opening.level opening.sample) ∨ + PublicMerkleBinding.OpenPrimitiveBad seed log opening.root opening.result.paths) := by + have self : packet ∈ RawOracleCoupling.Concrete.completion ctx Q packet := by + simp [RawOracleCoupling.Concrete.completion] + obtain ⟨bounded,recorded⟩ := PCSBCSNativePacketVisit.mixed_success_recorded cap model ctx stack Q + packet saved proofs B limit seed ro a success packet self + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let entered := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B packetB + (WHIRPhysicalVerifier.completion_profiles ctx Q packet packet self) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet packet self) + have visited : (.inl entered) ∈ ((Sampling.execute (table ctx Q packet B seed ro) + (program cap model ctx stack Q packet saved proofs B limit)).2.map Sigma.fst) := by + exact List.mem_map.mpr ⟨_,recorded,rfl⟩ + have mentioned := PCSBCSNativeRootRoles.mixed_success_reindexed_address cap model ctx stack Q + packet saved proofs B limit seed ro a success packetB rfl + intro opening member + have mentioned' : PCSBCSCapturedIdealNativeAcceptance.openingReference ctx Q packet opening saved.shape.lanes ∈ + addresses ctx Q packet B (.inl entered) := by + simpa only [addresses,PCSBCSCapturedIdealNativeAcceptance.table,entered,packetB] + using mentioned opening member + obtain ⟨_,_,_,_,f,captured,auth,_,rows⟩ := + PCSBCSCapturedIdealNativeAcceptance.mixed_success_captured_rows cap model ctx stack Q packet + saved proofs B limit seed ro a familyCap success opening member entered visited mentioned' + obtain ⟨events,found,frozen,_⟩ := PCSBCSSourceRootCapture.capture_provenance + (addresses ctx Q packet B) + (PCSBCSCapturedIdealNativeAcceptance.openingReference ctx Q packet opening saved.shape.lanes) + (program cap model ctx stack Q packet saved proofs B limit) (table ctx Q packet B seed ro) f captured + have log : openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening = f.queryPrefix := by + rw [frozen] + simp only [openingLog,referenceLog,sourceLog,found,Option.getD_some,freeze_prefix] + dsimp only + rw [log] + exact ⟨auth,rows⟩ +end Driver +#print axioms mixed_success_captured_rows +end Whir.PCSBCSNativeCapturedRows diff --git a/verification/whir/Whir/PCSBCSNativeCapturedTape.lean b/verification/whir/Whir/PCSBCSNativeCapturedTape.lean new file mode 100644 index 000000000..d213347ec --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeCapturedTape.lean @@ -0,0 +1,579 @@ +import Whir.PCSBCSNativeCapturedOracles +import Whir.PCSBCSNativePacketCodec +import Whir.AnchoredPhysicalPreparation + +/-! Literal full-packet source answers and the actual terminal native tape. +The unused suffix of each full output block is retained in the table; only the +checked contiguous-byte decoder projects it to a challenge. -/ +set_option autoImplicit false +set_option backward.isDefEq.respectTransparency false +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSNativeCapturedTape +open Concrete Protocol FiatShamirGame DuplexModeGame DuplexFraming +open PublicMerkleProgram WHIRSourceChronology WHIRPhysicalVerifier WHIRPhysicalReplay +open RawOracleCoupling.Concrete CausalProbability PCSBCSChallengeOracle +open PCSRoundByRoundTranscriptState AnchoredPhysicalDriver +open PCSBCSRestorationHazard + +private theorem record_initial_eq {p : ParameterBounds.Profile} (a b : WireState p) + (same : a.initial = b.initial) (q : Coordinate (ParameterBounds.config p)) + (x : StackWHIRReplay.Sample q) : + (recordSample a q x).initial = (recordSample b q x).initial := by + cases q <;> simp only [recordSample,same] + +private theorem install_initial {p : ParameterBounds.Profile} (state : WireState p) + (q : Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (first : q = .initial) : + ∃ seed, (recordSample state q x).initial = some seed ∧ + literalRaw seed.1 (set q state.tape (StackWHIRReplay.projectSample q x)) q = x := by + subst q + exact ⟨x,rfl,by simp only [literalRaw,get_set]; rfl⟩ + +private theorem install_later {p : ParameterBounds.Profile} (state : WireState p) + (seed : RingPCSGame.Prefix × E) (q : Coordinate (ParameterBounds.config p)) + (x : StackWHIRReplay.Sample q) (later : q ≠ .initial) : + literalRaw seed.1 (set q state.tape (StackWHIRReplay.projectSample q x)) q = x := by + cases q <;> simp_all only [ne_eq,not_true_eq_false,literalRaw,get_set,StackWHIRReplay.projectSample,id_eq] + +private theorem literal_set_ne {c : Config} (seed : RingPCSGame.Prefix) (tape : CausalGame.Tape c) + (q r : Coordinate c) (x : Sample q) (unequal : r ≠ q) : + literalRaw seed (set q tape x) r = literalRaw seed tape r := by + cases r <;> simp only [literalRaw,get_set_ne q _ tape x unequal] + +private theorem ideal_construction {R Seed State : Type} {B : Nat} + (sim : Simulator B Seed State) (ro : RawKey B → Digest32) (iv : Digest32) + (state : State) (program : Program R) (remaining : Nat) (limit : remaining ≤ B) + (counted : DuplexModeGame.Counts remaining program) : + ∀ q valid answer, (⟨.construction q valid,answer⟩ : Observation) ∈ + (runIdeal sim ro iv state program remaining limit counted).view.observations → + ∃ bounded : pathCost q ≤ B, answer = ro (constructionKey B iv q bounded) := by + induction program generalizing state remaining with + | done result => simp [runIdeal] + | ask query next ih => + cases query with + | primitive purpose input => + intro q valid answer member + simp only [runIdeal,DuplexModeGame.prepend,List.mem_cons] at member + rcases member with same | later + · cases same + · exact ih _ _ _ _ _ _ _ _ later + | construction coordinate admitted => + intro q valid answer member + simp only [runIdeal,DuplexModeGame.prepend,List.mem_cons] at member + rcases member with same | later + · cases same + exact ⟨counted.1.trans limit,rfl⟩ + · exact ih _ _ _ _ _ _ _ _ later + +private theorem readPacket_observed_aux {R : Type} {n : Nat} (request : Fin n → Query) + (next : (Fin n → Digest32) → Program R) (observations : List Observation) (result : R) + (run : Runs (WHIRModeProgram.readPacket n request next) observations result) : + ∃ raw suffix, Runs (next raw) suffix result ∧ + ∀ b, (⟨request b,raw b⟩ : Observation) ∈ observations := by + induction n generalizing observations with + | zero => exact ⟨Fin.elim0,observations,run,fun b => Fin.elim0 b⟩ + | succ n ih => + simp only [WHIRModeProgram.readPacket] at run + cases run with + | ask first rest => + obtain ⟨raw,suffix,last,observed⟩ := ih _ _ _ rest + refine ⟨Fin.cases first raw,suffix,last,?_⟩ + intro b + refine Fin.cases ?_ (fun i => ?_) b + · exact List.mem_cons_self + · exact List.mem_cons_of_mem _ (observed i) + +private theorem readPacket_observed {n : Nat} (request : Fin n → Query) + (raw : Fin n → Digest32) (observations : List Observation) + (run : Runs (WHIRModeProgram.readPacket n request Program.done) observations raw) : + ∀ b, (⟨request b,raw b⟩ : Observation) ∈ observations := by + obtain ⟨value,suffix,last,observed⟩ := readPacket_observed_aux request Program.done observations raw run + cases last + exact observed + +theorem readPackets_observed {cap : Nat} {R : Type} + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (p : ParameterBounds.Profile) (lanes : Nat) (proofs : Array MerkleTransport.PrunedMerklePaths) + (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ packet ∈ packets, packet.val.profile = p) (state : WireState p) + (next : WireState p → List (Sigma (GroupAnswer ctx Q)) → Source cap (Option R)) + (observations : List Observation) (result : R) + (run : Runs (erase (readPhysicalPackets ctx stack Q p lanes proofs none + packets profiles state next)) observations (some result)) : + ∃ final history suffix, Trace ctx stack Q p lanes proofs packets state final history ∧ + Runs (erase (next final history)) suffix (some result) ∧ + ∀ packet raw, (⟨.inl packet,raw⟩ : Sigma (GroupAnswer ctx Q)) ∈ history → + ∀ b, (⟨WHIRModeFinal.request ctx Q packet b,raw b⟩ : Observation) ∈ observations := by + induction packets generalizing state next observations with + | nil => exact ⟨state,[],observations,.nil state,run,by simp⟩ + | cons packet packets ih => + simp only [readPhysicalPackets] at run + cases parsed : absorbResponse state (packet.val.messages.headD ⟨[],none⟩) with + | none => simp only [parsed,erase] at run; cases run + | some value => + obtain ⟨absorbed,root⟩ := value + simp only [parsed] at run + split at run + · rename_i guards + rw [announce_erase,sourceLift_erase] at run + obtain ⟨before,nonce,after,whole,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases boundNonce : afterNonce absorbed nonce with + | none => simp only [boundNonce,erase] at continued; cases continued + | some bound => + simp only [boundNonce] at continued + split at continued + · rename_i accepted + rw [sourceLift_erase] at continued + obtain ⟨beforeRaw,raw,afterRaw,rawWhole,readRaw,read⟩ := (Runs.bind_iff _ _).mp continued + rw [sourceLift_erase] at read + obtain ⟨beforeOpen,opened,afterOpen,openWhole,opening,rest⟩ := (Runs.bind_iff _ _).mp read + cases opened with + | none => cases rest + | some checked => + obtain ⟨final,history,suffix,traced,last,observed⟩ := ih _ _ _ _ rest + refine ⟨final,⟨.inl packet,raw⟩::history,suffix, + .cons (profiles packet (by simp)) + (.run parsed guards.1 guards.2 boundNonce accepted opening) traced,last,?_⟩ + intro current answer member b + rcases List.mem_cons.mp member with same | older + · cases same + rw [whole,rawWhole] + exact List.mem_append_right _ (List.mem_append_left _ + (readPacket_observed _ _ _ (by rwa [readPacket_eq] at readRaw) b)) + · rw [whole,rawWhole,openWhole] + exact List.mem_append_right _ (List.mem_append_right _ + (List.mem_append_right _ (observed current answer older b))) + · cases continued + · cases run + +private theorem step_fields {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array MerkleTransport.PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p lanes proofs packet profile state raw out) : + out.tape = set (packetQuery ctx Q p packet profile) state.tape + (StackWHIRReplay.projectSample _ (packetSample ctx stack Q p packet profile raw)) ∧ + out.initial = (recordSample state (packetQuery ctx Q p packet profile) + (packetSample ctx stack Q p packet profile raw)).initial := by + cases step with + | run parsed size shape boundNonce accepted opened => + obtain ⟨_,absorbedTape,_,absorbedInitial⟩ := absorbResponse_rows _ _ _ _ parsed + obtain ⟨nonceTape,_,_,_,nonceInitial⟩ := afterNonce_fields _ _ _ boundNonce + obtain ⟨_,tape,_,initial,_,_⟩ := takeSample_fields _ _ _ _ _ _ _ opened + constructor + · dsimp only [withOutput] + rw [tape,recordSample_tape,nonceTape,absorbedTape] + · dsimp only [withOutput] + rw [initial] + exact record_initial_eq _ _ (nonceInitial.trans absorbedInitial) _ _ + +private theorem trace_packets {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array MerkleTransport.PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs packets state out history) : + ∀ packet raw, (⟨.inl packet,raw⟩ : Sigma (GroupAnswer ctx Q)) ∈ history → packet ∈ packets := by + induction trace with + | nil => simp + | cons profile step rest ih => + intro packet raw member + rcases List.mem_cons.mp member with same | older + · cases same; exact List.mem_cons_self + · exact List.mem_cons_of_mem _ (ih _ _ older) + +private theorem chain_lengths {ctx : RawWHIRKeys.Context} {Q : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + (chain : Chain ctx Q packet packets) : + ∀ current ∈ packets, current.val.messages.length ≤ packet.val.messages.length := by + induction chain with + | initial packet single => simp + | @next packet previous packets head prior messages statement profile ih => + intro current member + rcases List.mem_append.mp member with older | same + · have le := ih current older + simp only [messages,List.length_cons] + omega + · have equal := List.mem_singleton.mp same + subst current + exact Nat.le_refl _ + +theorem trace_literals {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array MerkleTransport.PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history} (root : Digest32) + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p lanes proofs packets (initialWireState p root) out history) : + ∃ seed, out.initial = some seed ∧ + ∀ current raw (_member : (⟨.inl current,raw⟩ : Sigma (GroupAnswer ctx Q)) ∈ history) + (profile : current.val.profile = p), + literalRaw seed.1 out.tape (packetQuery ctx Q p current profile) = + packetSample ctx stack Q p current profile raw := by + induction chain generalizing out history with + | initial packet single => + cases trace with + | cons profile step rest => + cases rest + have first := packetQuery_initial ctx Q p packet profile (by simp [single]) + obtain ⟨tape,initial⟩ := step_fields step + obtain ⟨seed,seedState,sample⟩ := install_initial _ _ _ first + refine ⟨seed,initial.trans seedState,?_⟩ + intro current raw member aligned + simp only [List.mem_cons,List.not_mem_nil,or_false] at member + cases member + rw [tape] + exact sample + | @next packet previous packets head prior messages statement profile ih => + obtain ⟨middle,before,after,hist,first,last⟩ := Trace.append_inv _ _ trace + cases last with + | cons aligned step rest => + cases rest + obtain ⟨seed,seedState,literals⟩ := ih first + have later : packetQuery ctx Q p packet aligned ≠ .initial := by + intro zero + have pos := packetQuery_position ctx Q p packet aligned + rw [zero] at pos + have positive := List.length_pos_iff.mpr previous.property.2.1 + simp only [messages,List.length_cons] at pos + simp [position,visibleCoordinates] at pos + omega + obtain ⟨tape,initial⟩ := step_fields step + have seedOut : out.initial = some seed := by + rw [initial,recordSample_noninitial _ _ _ later,seedState] + refine ⟨seed,seedOut,?_⟩ + intro current raw member currentProfile + rw [hist] at member + rcases List.mem_append.mp member with older | same + · have length := chain_lengths prior current (trace_packets first current raw older) + have unequal : packetQuery ctx Q p current currentProfile ≠ packetQuery ctx Q p packet aligned := by + intro equal + have eqpos := congrArg position equal + rw [packetQuery_position,packetQuery_position,messages,List.length_cons] at eqpos + have positive := List.length_pos_iff.mpr current.property.2.1 + omega + have unchanged : literalRaw seed.1 out.tape (packetQuery ctx Q p current currentProfile) = + literalRaw seed.1 middle.tape (packetQuery ctx Q p current currentProfile) := by + rw [tape] + exact literal_set_ne _ _ _ _ _ unequal + exact unchanged.trans (literals current raw older currentProfile) + · simp only [List.mem_singleton] at same + cases same + rw [tape] + exact install_later _ seed _ _ later + +theorem trace_answers {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} {lanes : Nat} {proofs : Array MerkleTransport.PrunedMerklePaths} + {packets : List (RawWHIRKeys.Packet ctx Q)} {state out : WireState p} {history} + (trace : Trace ctx stack Q p lanes proofs packets state out history) : + ∀ packet ∈ packets, ∃ raw, (⟨.inl packet,raw⟩ : Sigma (GroupAnswer ctx Q)) ∈ history := by + induction trace with + | nil => simp + | cons profile step rest ih => + intro packet member + rcases List.mem_cons.mp member with same | older + · subst packet + exact ⟨_,List.mem_cons_self⟩ + · obtain ⟨raw,member⟩ := ih packet older + exact ⟨raw,List.mem_cons_of_mem _ member⟩ + +theorem completion_data {ctx : RawWHIRKeys.Context} {Q B : Nat} + (a : RawWHIRKeys.Packet ctx Q) (b : RawWHIRKeys.Packet ctx B) (same : a.val = b.val) : + (completion ctx Q a).map Subtype.val = (completion ctx B b).map Subtype.val := by + simp only [completion,RawWHIRKeys.ancestors,List.map_append,List.map_singleton,List.map_ofFn] + simp only [RawWHIRKeys.dropPacket,same] + simp only [Function.comp_apply,Fin.val_cast] + rfl + +theorem entered_ext {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} + (a b : EnteredPacket p B iv boundary) (entry : a.1.val = b.1.val) + (messages : a.2.messages = b.2.messages) : a = b := by + have equal : a.1 = b.1 := Subtype.ext entry + cases a + cases b + cases equal + have equal := CanonicalPacket.messages_injective messages + cases equal + rfl + +theorem entered_query (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q B : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B) + {p : ParameterBounds.Profile} {entry : FramedHistory} + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) : + packetQuery ctx Q p packet profile = + (PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded) profile aligned).2.coord := by + cases profile + cases aligned + rfl + +theorem literal_cast {c : Config} (seed : RingPCSGame.Prefix) (tape : CausalGame.Tape c) + (q r : Coordinate c) (same : q = r) : + Eq.mp (congrArg PCSBCSRounds.Raw same) (literalRaw seed tape q) = literalRaw seed tape r := by + cases same + rfl + +theorem observed_grouped (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q B : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B) + {p : ParameterBounds.Profile} {entry : FramedHistory} + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (raw : GroupAnswer ctx Q (.inl packet)) + (answers : ∀ b : Fin (RawWHIRKeys.blocks ctx packet.val), + ∃ bound : pathCost (RawWHIRKeys.coordinate ctx packet.val b.val) ≤ B, + raw b = ro (constructionKey B ctx.iv (RawWHIRKeys.coordinate ctx packet.val b.val) bound)) : + let current := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded) profile aligned + grouped current.2.coord + ((EnteredPacket.partition (p := p) (Q := B) (iv := ctx.iv) (boundary := entry.frames.length)).split + (PublicCompressionCouplingMixed.oracle seed ro) (.inl current)) = + Eq.mp (congrArg PCSBCSRounds.Raw (entered_query ctx stack Q B packet bounded profile aligned)) + (packetSample ctx stack Q p packet profile raw) := by + cases profile + cases aligned + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let rawB : GroupAnswer ctx B (.inl packetB) := raw + have full : + (EnteredPacket.partition (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length)).split + (PublicCompressionCouplingMixed.oracle seed ro) + (.inl (PCSBCSNativePacketBridge.enteredPacket ctx stack B packetB)) = + PCSBCSNativePacketCodec.nativeFullBlocksEquiv ctx stack B packetB rawB := by + funext b + change ro ((PCSBCSNativePacketBridge.sourcePacket ctx stack B packetB).key b) = _ + rw [PCSBCSNativePacketBridge.sourcePacket_key,PCSBCSNativePacketCodec.nativeFullBlocksEquiv_apply] + obtain ⟨bound,equal⟩ := answers ⟨b.val,by + change b.val < RawWHIRKeys.blocks ctx packetB.val + rw [PCSBCSNativePacketBridge.packet_blocks_pcs ctx stack B packetB] + exact b.isLt⟩ + exact equal.symm + change grouped (PCSBCSNativePacketBridge.query ctx B packetB) + ((EnteredPacket.partition (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length)).split + (PublicCompressionCouplingMixed.oracle seed ro) + (.inl (PCSBCSNativePacketBridge.enteredPacket ctx stack B packetB))) = + WHIRRawReplay.decodePacket ctx stack B packetB rawB + rw [full,PCSBCSNativePacketCodec.decodePacket_eq_grouped] + +theorem done_eq {R : Type} {left right : R} {trace : List Observation} + (run : Runs (.done left) trace right) : left = right := by + cases run + rfl + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array MerkleTransport.PrunedMerklePaths) (B : Nat) + (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +/-- Actual source acceptance forces full native schedule length, including the +hidden terminal sample. No terminal coordinate or tape geometry is assumed. -/ +theorem mixed_success_depth (a : Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) : + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) := by + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution cap .fresh model ctx stack Q packet + saved proofs _ a run + exact AnchoredPhysicalPreparation.accepted_completed_depth a + (trace_completed saved.root (completion_chain ctx Q packet) trace) + +/-- Every whole packet is decoded from its actual independent raw construction +answers. This source fact needs no Merkle quietness or replay certificate. -/ +theorem mixed_success_literal_packets (a : Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) : + ∃ initial, a.wire.initial = some initial ∧ + ∀ current (member : current ∈ completion ctx Q packet), + ∃ bounded : pathCost (RawWHIRKeys.coordinate ctx current.val 0) ≤ B, + let entered := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (PCSBCSNativePacketVisit.packetAtBound ctx Q B current bounded) + (completion_profiles ctx Q packet current member) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet current member) + grouped entered.2.coord (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro (.inl entered)) = + literalRaw initial.1 a.wire.tape entered.2.coord := by + let view := AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨configured,same,before,after,request,whole,count,queries,parsed,physical⟩ := + AnchoredPhysicalExecution.verifySource_success cap .fresh model ctx stack Q packet saved proofs _ a run + obtain ⟨final,history,suffix,trace,last,observed⟩ := readPackets_observed ctx stack Q packet.val.profile + saved.shape.lanes proofs _ _ _ _ after a physical + obtain ⟨_,wireEq,historyEq⟩ := AnchoredPhysicalExecution.finish_success ctx Q cap packet saved configured + request final history _ a (done_eq last) + have trace' : Trace ctx stack Q packet.val.profile saved.shape.lanes proofs (completion ctx Q packet) + (initialWireState packet.val.profile saved.root) a.wire a.history := by + simpa only [← wireEq,← historyEq] using trace + obtain ⟨initial,initialState,literals⟩ := trace_literals saved.root (completion_chain ctx Q packet) trace' + refine ⟨initial,initialState,?_⟩ + intro current member + obtain ⟨raw,inHistory⟩ := trace_answers trace current member + have actual : ∀ b, (⟨WHIRModeFinal.request ctx Q current b,raw b⟩ : Observation) ∈ view.observations := by + intro b + rw [whole] + exact List.mem_append_right _ (observed current raw inHistory b) + have answers : ∀ b : Fin (RawWHIRKeys.blocks ctx current.val), + ∃ bound : pathCost (RawWHIRKeys.coordinate ctx current.val b.val) ≤ B, + raw b = ro (constructionKey B ctx.iv (RawWHIRKeys.coordinate ctx current.val b.val) bound) := by + intro b + have answer := ideal_construction (DuplexPublicSimulator.simulator B) ro ctx.iv ⟨seed,[]⟩ + (WHIRSourceChronology.compile (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + (sourceBudget ctx Q packet) limit + ((WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap .fresh model ctx stack Q packet saved proofs)) + _ _ (raw b) (by + simpa only [view,AnchoredMixedIdealSourceAcceptance.mixedView,PublicCompressionCouplingMixed.compile_actual, + WHIRModeFinal.request] + using actual b) + exact answer + obtain ⟨bounded,recorded⟩ := PCSBCSNativePacketVisit.mixed_success_recorded cap model ctx stack Q packet + saved proofs B limit seed ro a success current member + refine ⟨bounded,?_⟩ + have groupedEq := observed_grouped ctx stack Q B current bounded + (completion_profiles ctx Q packet current member) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet current member) seed ro raw answers + have literal := literals current raw (by simpa only [← historyEq] using inHistory) + (completion_profiles ctx Q packet current member) + have lifted := congrArg + (Eq.mp (congrArg PCSBCSRounds.Raw (entered_query ctx stack Q B current bounded + (completion_profiles ctx Q packet current member) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet current member)))) literal + have castEq := literal_cast initial.1 a.wire.tape _ _ + (entered_query ctx stack Q B current bounded + (completion_profiles ctx Q packet current member) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet current member)) + exact groupedEq.trans (lifted.symm.trans castEq) + +/-- Exact chronological completion, recorded whole packets, and literal raw +challenges, all derived from the fresh source run at its observed aggregate cap. -/ +theorem mixed_success_tape (a : Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) : + ∃ initial : RingPCSGame.Prefix × E, ∃ bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B, + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket ctx stack B packetB + a.wire.initial = some initial ∧ + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) ∧ + final.2.coord = lastCoordinate (ParameterBounds.config packet.val.profile) ∧ + PCSBCSNativePacketBridge.completionPackets ctx stack B packetB = + PCSBCSCapturedSourceStatePath.packets final ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + (⟨.inl current,PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro (.inl current)⟩ : + Sigma PCSBCSSourceRootCapture.Answer) ∈ + (TypedOracleCompiler.Sampling.execute (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) + (PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit)).2) ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + grouped current.2.coord (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro (.inl current)) = + literalRaw initial.1 a.wire.tape current.2.coord) := by + classical + obtain ⟨initial,initialState,literals⟩ := mixed_success_literal_packets cap model ctx stack Q packet + saved proofs B limit seed ro a success + have self : packet ∈ completion ctx Q packet := List.mem_append_right _ (List.mem_singleton_self _) + obtain ⟨bounded,_⟩ := PCSBCSNativePacketVisit.mixed_success_recorded cap model ctx stack Q packet saved + proofs B limit seed ro a success packet self + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket ctx stack B packetB + have depth := mixed_success_depth cap model ctx stack Q packet saved proofs B limit seed ro a success + have ordering := PCSBCSNativePacketBridge.completionPackets_eq_of_length ctx stack B packetB depth + have packetMember : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + ∃ native, ∃ member : native ∈ completion ctx Q packet, + ∃ bound : pathCost (RawWHIRKeys.coordinate ctx native.val 0) ≤ B, + current = PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (PCSBCSNativePacketVisit.packetAtBound ctx Q B native bound) + (completion_profiles ctx Q packet native member) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet native member) := by + intro current member + rw [← ordering] at member + obtain ⟨attached,_,equal⟩ := List.mem_map.mp member + have nativeMember : attached.val.val ∈ (completion ctx Q packet).map Subtype.val := by + rw [completion_data packet packetB rfl] + exact List.mem_map.mpr ⟨attached.val,attached.property,rfl⟩ + obtain ⟨native,member,same⟩ := List.mem_map.mp nativeMember + obtain ⟨bound,_⟩ := PCSBCSNativePacketVisit.mixed_success_recorded cap model ctx stack Q packet saved + proofs B limit seed ro a success native member + refine ⟨native,member,bound,?_⟩ + rw [← equal] + apply entered_ext + · rw [PCSBCSNativePacketBridge.enteredPacketAt_entry,PCSBCSNativePacketBridge.enteredPacketAt_entry] + rfl + · rw [PCSBCSNativePacketBridge.enteredPacketAt_messages,PCSBCSNativePacketBridge.enteredPacketAt_messages] + exact congrArg RawWHIRKeys.PacketData.messages same.symm + refine ⟨initial,bounded,initialState,depth, + PCSBCSNativePacketBridge.query_eq_last_of_length ctx B packetB depth,ordering,?_,?_⟩ + · intro current member + obtain ⟨native,nativeMem,bound,equal⟩ := packetMember current member + subst current + obtain ⟨bound',recorded⟩ := PCSBCSNativePacketVisit.mixed_success_recorded cap model ctx stack Q packet saved + proofs B limit seed ro a success native nativeMem + exact recorded + · intro current member + obtain ⟨native,nativeMem,bound,equal⟩ := packetMember current member + subst current + obtain ⟨bound',raw⟩ := literals native nativeMem + exact raw + +/-- The same actual Γ and full tape as the canonically restored causal replay. +Only actual-opening primitive bad-event exclusion is used for that replay; +the raw-table identity and terminal geometry were independently source-derived. -/ +theorem mixed_success_experiment_tape (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths) : + ∃ replay : StackWHIRReplay.Replay packet.val.profile cap, ∃ proof, + ∃ bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B, + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket ctx stack B packetB + replay.original = PCSBCSNativeOracleReplay.original a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) + replay.whir.replies = .ok proof ∧ + WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro))) + (PCSBCSNativeCapturedOracles.roots cap model ctx stack Q packet saved proofs B limit seed ro) + (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile a.history).tail⟩ = + some replay ∧ + CausalGame.experiment (PCSBCSNativeOracleReplay.input a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true ∧ + packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) ∧ + final.2.coord = lastCoordinate (ParameterBounds.config packet.val.profile) ∧ + PCSBCSNativePacketBridge.completionPackets ctx stack B packetB = + PCSBCSCapturedSourceStatePath.packets final ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + (⟨.inl current,PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro (.inl current)⟩ : + Sigma PCSBCSSourceRootCapture.Answer) ∈ + (TypedOracleCompiler.Sampling.execute (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) + (PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit)).2) ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + grouped current.2.coord (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro (.inl current)) = + literalRaw replay.initial.1 a.wire.tape current.2.coord) := by + obtain ⟨replay,proof,original,initial,lambda,replies,parsed,decoded,accepted⟩ := + PCSBCSNativeCapturedOracles.mixed_success_experiment cap model ctx stack Q packet saved proofs B limit + seed ro a familyCap success quiet + obtain ⟨sourceInitial,bounded,sourceSeed,depth,terminal,ordering,recorded,raws⟩ := + mixed_success_tape cap model ctx stack Q packet saved proofs B limit seed ro a success + have same : sourceInitial = replay.initial := Option.some.inj (sourceSeed.symm.trans initial) + subst sourceInitial + exact ⟨replay,proof,bounded,original,initial,lambda,replies,parsed,decoded,accepted,depth,terminal,ordering,recorded,raws⟩ + +end Driver +#print axioms mixed_success_depth +#print axioms mixed_success_literal_packets +#print axioms mixed_success_tape +#print axioms mixed_success_experiment_tape + + +end Whir.PCSBCSNativeCapturedTape diff --git a/verification/whir/Whir/PCSBCSNativeCompleteAlarm.lean b/verification/whir/Whir/PCSBCSNativeCompleteAlarm.lean new file mode 100644 index 000000000..a10140a05 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeCompleteAlarm.lean @@ -0,0 +1,105 @@ +import Whir.PCSBCSSourceRootAdmission +import Whir.PCSBCSNativePhysicalMerkleBad + +/-! Exact whole-trace primitive-event join. A real first mention supplies its +physical freeze and scanner admission; actual accepted native execution supplies +all opening plans. The shared alarm, not an extracted-row-mismatch converse, +therefore excludes the retained primitive opening event. Actual first-mention +coverage of every native reference remains an explicit source-chronology join. -/ +namespace Whir.PCSBCSNativeCompleteAlarm +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open PublicCompressionProgram PublicMerkleLog PCSBCSSourceRootReferences + +set_option autoImplicit false + +theorem firstMention_opening_quiet {R : Type} (p : ParameterBounds.Profile) + (B boundary : Nat) (registry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (ref : Reference) + (events : List (Sigma (PCSBCSSourceRootCapture.Answer + (p := p) (Q := B) (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)))) + (mentioned : PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)) ref + (PCSBCSNativePhysicalFreeze.allocationProgram (p := p) (boundary := boundary) program A limit counted) + (PCSBCSNativePhysicalFreeze.actualTable (p := p) (B := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) C) = some events) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) [] + (primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV program A counted) = false) + (output : List MerkleTransport.RawPath) + (bounds : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (hash C)), bytes.length < 2^56) + (plans : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (hash C)), + ∀ e ∈ plan C bytes, e ∈ primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV program A counted) : + ¬ PublicMerkleBinding.OpenPrimitiveBad C + (PCSBCSNativePhysicalFreeze.actualSourceLog (p := p) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) + C program A limit counted ref) ref.root output := by + intro bad + obtain ⟨frozen,registered,_⟩ := PCSBCSSourceRootAdmission.actual_firstMention_admitted + p B boundary registry C program A limit counted ref events mentioned quiet + have alarm := PublicMerkleProbability.opening_alarm C + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) + (PCSBCSSourcePrimitiveRootBudget.targets_grow p B boundary registry) + (primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV program A counted) + (primitiveLog_authentic C PCSBCSSourceCoordinateDecoder.seedIV program A counted) + ⟨frozen.before,frozen.after,_,ref.root,output,frozen.split,frozen.captured, + frozen.saturated,registered,bounds,plans,bad⟩ + rw [quiet] at alarm + cases alarm + + +section WholeNative +variable (cap : Nat) + (nativeRegistry : {r : WHIRPhysicalDriver.ProductionRegistry // + r.context.iv = PCSBCSSourceCoordinateDecoder.seedIV}) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input nativeRegistry.val.context Q)) + (a b : Nat) (attackerCounted : WHIRSourceChronology.Counts a attacker) + (nativeBudget : WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget nativeRegistry.val.context Q input.packet ≤ b) + (WHIRSourceChronology.erase attacker)) +local notation "whole" => PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q attacker +local notation "counted" => PCSBCSNativePhysicalFreeze.whole_counted + cap nativeRegistry.val Q attacker a b attackerCounted nativeBudget + +/-- The actual accepted native wire supplies all full opening plans. The only +remaining coverage input is the genuine first mention in the whole allocation, +not assumed saturation, raw equality, root admission or a primitive probability. -/ +theorem whole_native_opening_quiet (B boundary : Nat) (limit : a+b ≤ B) + (registry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (accepted : AnchoredPhysicalAfter.Accepted nativeRegistry.val.context Q cap) + (success : (runReal C nativeRegistry.val.context.iv whole).view.result.value = some accepted) + (opening : WHIRPhysicalVerifier.QueryOpening accepted.input.packet.val.profile) + (opened : opening ∈ accepted.native.wire.openings) + (ref : Reference) (root : ref.root = opening.root) + (events : List (Sigma (PCSBCSSourceRootCapture.Answer + (p := accepted.input.packet.val.profile) (Q := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)))) + (mentioned : PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (p := accepted.input.packet.val.profile) (Q := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)) ref + (PCSBCSNativePhysicalFreeze.allocationProgram (p := accepted.input.packet.val.profile) + (boundary := boundary) whole (a+b) limit counted) + (PCSBCSNativePhysicalFreeze.actualTable (p := accepted.input.packet.val.profile) (B := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) C) = some events) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets accepted.input.packet.val.profile B boundary registry) [] + (primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV whole (a+b) counted) = false) : + ¬ PublicMerkleBinding.OpenPrimitiveBad C + (PCSBCSNativePhysicalFreeze.actualSourceLog (p := accepted.input.packet.val.profile) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) + C whole (a+b) limit counted ref) opening.root opening.result.paths := by + have evaluated := PCSBCSNativePhysicalFreeze.counted_whole_success_evaluated + cap nativeRegistry.val Q attacker a b attackerCounted nativeBudget C accepted success opening opened + rw [← root] + apply firstMention_opening_quiet accepted.input.packet.val.profile B boundary registry C + whole (a+b) limit counted ref events mentioned quiet opening.result.paths + · intro path member bytes input + exact (evaluated path member bytes input).1 + · intro path member bytes input event present + simpa only [nativeRegistry.property] using (evaluated path member bytes input).2 event present +end WholeNative + +#print axioms firstMention_opening_quiet +#print axioms whole_native_opening_quiet +end Whir.PCSBCSNativeCompleteAlarm diff --git a/verification/whir/Whir/PCSBCSNativeIdealCallerOriginal.lean b/verification/whir/Whir/PCSBCSNativeIdealCallerOriginal.lean new file mode 100644 index 000000000..4ec23e9ee --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeIdealCallerOriginal.lean @@ -0,0 +1,103 @@ +import Whir.PCSBCSNativeCallerOriginal +import Whir.AnchoredMixedIdealSourceAcceptance +import Whir.PCSBCSIdealConstructionAnswers + +/-! Exact caller preparation from the actual ideal source execution. Earlier +caller outputs are the same bounded raw RO entries used by the grouped source +table, not deterministic compression answers or a supplied compatibility map. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeIdealCallerOriginal +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open WHIRCallerSupport WHIRSourceChronology WHIRPhysicalCaller AnchoredPhysicalDriver +open PCSBCSSourceCallerOriginal PCSBCSRestorationHazard PCSRoundByRoundTranscriptState +open PCSBCSCallerBinding RawOracleCoupling PCSBCSChallengeOracle + +variable {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) + +/-- The bounded source getter is exactly the same raw construction lookup. -/ +theorem split_answers (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (q : Coordinate) (bounded : pathCost q ≤ B) : + PCSBCSSourceCallerAnswers.answers ((part).split (PublicCompressionCouplingMixed.oracle seed ro)) q = + ro (constructionKey B iv q bounded) := by + rw [PCSBCSSourceCallerAnswers.answers_bounded _ _ bounded,Partition.join_split] + rfl + +section Caller +variable (cap : Nat) (model : ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (saved : AnchoredHeaderCodec.Record) (proofs : Array MerkleTransport.PrunedMerklePaths) + (B : Nat) (limit : WHIRPhysicalVerifier.sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +private abbrev view := AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q + packet saved proofs ctx.iv B limit seed ro + +private noncomputable abbrev sourceTable := + (EnteredPacket.partition (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length)).split + (PublicCompressionCouplingMixed.oracle seed ro) + +theorem fresh_original (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (view cap model ctx stack Q packet saved proofs B limit seed ro).result.value = some a) : + ∃ input : CallerInput packet.val.profile, + original packet.val.profile model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (sourceTable ctx Q packet B seed ro)) = some input ∧ + input.m = a.request.claims.count ∧ + ∀ root ring, OriginalClaimsChecker.input input.prepared root ring = + ⟨ParameterBounds.config packet.val.profile,saved.shape.lanes,root, + AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) saved + a.request.claims.family a.request.claims.points ring⟩ := by + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨caller,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + obtain ⟨before,after,splitTrace,_,queries,parsed⟩ := caller + obtain ⟨_,shape,_,_,_,_,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_success + cap .fresh model ctx stack Q packet saved proofs _ a run + have splitView : (view cap model ctx stack Q packet saved proofs B limit seed ro).observations = before ++ after := + splitTrace + have earlier : ∀ wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val), + latestAnswers before wanted = some + (PCSBCSSourceCallerAnswers.answers (sourceTable ctx Q packet B seed ro) wanted) := by + intro wanted prior + have queried : Query.construction wanted (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) ∈ + before.map Observation.query := by + rw [queries] + exact List.mem_map.mpr ⟨⟨wanted,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨o,member,equal⟩ := List.mem_map.mp queried + apply latestAnswers_consistent before wanted + (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) _ ⟨o,member,equal⟩ + intro observation member valid same + have present : observation ∈ + (view cap model ctx stack Q packet saved proofs B limit seed ro).observations := by + rw [splitView] + exact List.mem_append_left _ member + have actual : ∃ bounded : pathCost wanted ≤ B, + observation.answer = ro (constructionKey B ctx.iv wanted bounded) := by + have construction : (⟨.construction wanted valid,observation.answer⟩ : Observation) ∈ + (view cap model ctx stack Q packet saved proofs B limit seed ro).observations := by + cases observation + cases same + exact present + simp only [view,AnchoredMixedIdealSourceAcceptance.mixedView, + PublicCompressionCouplingMixed.compile_actual] at construction + exact PCSBCSIdealConstructionAnswers.construction_observations _ ro ctx.iv _ _ _ _ _ + wanted valid _ construction + obtain ⟨bounded,actual⟩ := actual + rw [split_answers seed ro wanted bounded] + exact actual + obtain ⟨input,reconstructed,count,statement⟩ := PCSBCSNativeCallerOriginal.request_original + cap packet.val.profile model saved a.configuration shape (RawWHIRKeys.entry ctx packet.val) + (latestAnswers before) a.request familyCap parsed + refine ⟨input,?_,count,statement⟩ + rw [← reconstructed] + apply original_prior_only + intro q member + rw [earlier q member] + rfl +end Caller +#print axioms split_answers +#print axioms fresh_original +end Whir.PCSBCSNativeIdealCallerOriginal diff --git a/verification/whir/Whir/PCSBCSNativeOracleReplay.lean b/verification/whir/Whir/PCSBCSNativeOracleReplay.lean new file mode 100644 index 000000000..080c66795 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeOracleReplay.lean @@ -0,0 +1,172 @@ +import Whir.AnchoredPhysicalKnowledgeAcceptance +import Whir.AnchoredPhysicalAcceptance + +/-! Literal anchored native replay with an arbitrary rectangular root getter. +The getter can be the first shape-address capture rather than the later +physical digest registry. Only actual queried-row agreement and array shapes +are required; no whole later/earlier oracle identity is introduced. +This module does not discharge those sampled-row hypotheses or prove FS soundness. +-/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeOracleReplay +open Concrete Protocol FiatShamirGame DuplexModeGame +open MerkleTransport WHIRPhysicalVerifier WHIRPhysicalReplay WHIRPhysicalSoundness +open PublicMerkleProgram AnchoredPhysicalDriver WHIRSourceChronology + +variable {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + {packet : RawWHIRKeys.Packet ctx Q} {saved : AnchoredHeaderCodec.Record} + +def original (a : Accepted ctx Q cap packet saved) (base : CausalGame.BaseOracle) : + WHIRFiatShamir.StackInitial packet.val.profile cap where + lanes := a.request.lanes + root := base + lane_bound := a.request.lane_bound + familyCount := a.request.claims.count + family := a.request.claims.family + family_bound := a.request.claims.family_bound + points := a.request.claims.points + claim_bound := a.request.claims.claim_bound + +noncomputable def input (a : Accepted ctx Q cap packet saved) (base : CausalGame.BaseOracle) + (seed : RingPCSGame.Prefix) : CausalGame.Public where + config := ParameterBounds.config packet.val.profile + lanes := saved.shape.lanes + root := base + claims := AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) saved + a.request.claims.family a.request.claims.points seed + +theorem decodeStack_rootShapes (p : ParameterBounds.Profile) (familyCap : Nat) + (catalog : StackWHIRReplay.Catalog p familyCap) (roots : WHIRReplay.Roots) + (rows : WHIRPhysicalHistory.Rows) (key : StackWHIRReplay.Key p) + (out : StackWHIRReplay.Replay p familyCap) + (parsed : WHIRPhysicalHistory.decodeStack p familyCap catalog roots rows key = some out) + (rectangular : ∀ digest level, oracleValid (roots digest level) + (ParameterBounds.length (ParameterBounds.config p) level) + (2^(ParameterBounds.config p).folds[level]!) = true) + (tape : CausalGame.Tape (ParameterBounds.config p)) (proof : Opening) + (accepted : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) out.whir.replies = .ok proof) : + WHIRNativeArithmetic.RootShapes (ParameterBounds.config p) proof := by + intro i bound hasNext next found + obtain ⟨digest,_,value⟩ := decodeStack_opening_nextOracle p familyCap catalog roots rows key + out parsed tape proof accepted ⟨i,bound⟩ hasNext + have equal := Option.some.inj (found.symm.trans value) + subst next + have shape := rectangular digest (i+1) + have dimensions := ((CausalBoundary.production_boundary_facts p ⟨i,bound⟩).2.2 hasNext).1 + change CausalGame.remaining (ParameterBounds.config p) (i+1) + + (ParameterBounds.config p).folds[i+1]! = CausalGame.remaining (ParameterBounds.config p) i at dimensions + have remaining : CausalGame.remaining (ParameterBounds.config p) (i+1) = + CausalGame.remaining (ParameterBounds.config p) i - (ParameterBounds.config p).folds[i+1]! := by omega + simpa only [ParameterBounds.length,remaining] using shape + +private theorem opening_unerase (c : Config) (ch : Challenges) + (replies : Array CausalGame.Reply) (erased : Opening) + (accepted : CausalGame.opening c ch (replies.map WHIRPhysicalErasure.eraseReply) = .ok erased) : + ∃ proof, CausalGame.opening c ch replies = .ok proof ∧ WHIRPhysicalErasure.eraseOracles proof = erased := by + rw [WHIRPhysicalErasure.opening_erase] at accepted + cases parsed : CausalGame.opening c ch replies with + | error message => simp [parsed,Except.map] at accepted + | ok proof => + simp [parsed,Except.map] at accepted + exact ⟨proof,rfl,accepted⟩ + +theorem verifySource_experiment (boundary : AnchoredPhysicalDriver.Boundary) + (model : WHIRCallerSupport.ProductionLayout) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (a : Accepted ctx Q cap packet saved) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet saved proofs)) + observations (some a)) + (base : CausalGame.BaseOracle) (roots : WHIRReplay.Roots) + (baseShape : oracleValid (CausalGame.liftRoot base) + (2^((ParameterBounds.config packet.val.profile).logN-(ParameterBounds.config packet.val.profile).folds[0]!+ + (ParameterBounds.config packet.val.profile).rates[0]!)) saved.shape.lanes = true) + (rectangular : ∀ digest level, oracleValid (roots digest level) + (ParameterBounds.length (ParameterBounds.config packet.val.profile) level) + (2^(ParameterBounds.config packet.val.profile).folds[level]!) = true) + (boundRows : WHIRPhysicalRoots.BoundRows base roots a.wire) : + ∃ replay : StackWHIRReplay.Replay packet.val.profile cap, ∃ proof, + replay.original = original a base ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) + replay.whir.replies = .ok proof ∧ + WHIRPhysicalHistory.decodeStack packet.val.profile cap (fun _ => some (original a base)) roots + (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile a.history).tail⟩ = + some replay ∧ + CausalGame.experiment (input a base replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨_,rootEq,lanesEq,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap boundary model ctx stack Q packet saved proofs observations a run + have trace' : Trace ctx stack Q packet.val.profile a.request.lanes proofs + (RawOracleCoupling.Concrete.completion ctx Q packet) + (initialWireState packet.val.profile a.request.root) a.wire a.history := by + simpa only [rootEq,lanesEq] using trace + let catalog : StackWHIRReplay.Catalog packet.val.profile cap := fun _ => some (original a base) + have found : catalog packet.val.statement = some (original a base) := rfl + have chain := WHIRPhysicalReplay.completion_chain ctx Q packet + have complete := trace_completed a.request.root chain trace' + obtain ⟨_,past,sample,erased,history,decoded,originalEq,initialSeed,_,tape,replies⟩ := + Completed.decodeStack packet a.wire a.history catalog (original a base) found complete + (AnchoredPhysicalKnowledgeAcceptance.replies_nonempty a) + have tail : (localHistory ctx stack Q packet.val.profile a.history).tail = past := by rw [history]; rfl + have full := decoded + change WHIRPhysicalHistory.decodeStack packet.val.profile cap catalog WHIRPhysicalErasure.zeroRoots + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ = some erased at full + rw [WHIRPhysicalErasure.decodeStack_zero packet.val.profile cap catalog roots + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩] at full + obtain ⟨replay,physical,erasedEq⟩ := Option.map_eq_some_iff.mp full + subst erased + change replay.original = original a base at originalEq + change a.wire.initial = some replay.initial at initialSeed + change (StackWHIRReplay.finish ⟨packet.val.statement,packet.val.messages,past⟩ replay sample).whir.tape = a.wire.tape at tape + change replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies at replies + have agreement := WHIRPhysicalRoots.trace_stackRowsAgree packet a.request.root catalog (original a base) + roots found chain trace' boundRows + rw [tail] at agreement + have ideal := WHIRPhysicalHistory.decodeStack_success packet.val.profile cap catalog roots + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ replay agreement physical + have lambda := StackWHIRReplay.decode_initial_lambda catalog roots + ⟨packet.val.statement,packet.val.messages,past⟩ replay ideal sample + rw [tape] at lambda + change a.wire.tape.1 = replay.initial.2 at lambda + obtain ⟨seed,nativeProof,seedFound,parsed,native⟩ := a.acceptance + have sameSeed : seed = replay.initial := Option.some.inj (seedFound.symm.trans initialSeed) + subst seed + rw [← replies] at parsed + obtain ⟨proof,parsedFull,erasedProof⟩ := opening_unerase _ _ replay.whir.replies nativeProof parsed + have nativeFull : AnchoredPhysicalAnchor.sourceVerify saved a.request.claims.family a.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) proof = .ok () := by + rw [← AnchoredPhysicalKnowledgeAcceptance.sourceVerify_erased,erasedProof] + exact native + have rootsShape := decodeStack_rootShapes packet.val.profile cap catalog roots + (fun i => a.wire.rows[i]!) ⟨packet.val.statement,packet.val.messages,past⟩ replay physical rectangular + a.wire.tape proof parsedFull + have authenticated := trace_authenticatedRows packet a.request.root base roots chain trace' boundRows + catalog replay (by rw [tail]; exact physical) proof parsedFull + have nativeShapes := AnchoredPhysicalDriver.accepted_nativeShapes a + have shapes := AnchoredPhysicalAcceptance.accepted_anchored_shapes a replay.initial.1 replay.initial.2 + have verified := AnchorPrefixRefinement.sourceVerify_refines saved a.request.claims.family a.request.claims.points + replay.initial.1 replay.initial.2 (ParameterBounds.config packet.val.profile) _ proof + (CausalGame.liftRoot base) a.configuration.1 a.configuration.2.1 a.configuration.2.2.1 + nativeShapes.1 (fun i => nativeShapes.2 _ (by simp)) shapes.2 baseShape rootsShape authenticated nativeFull + refine ⟨replay,proof,originalEq,initialSeed,lambda,replies,parsedFull, + (by simpa only [catalog,← tail] using physical),?_⟩ + apply WHIRPhysicalSoundness.experiment_indexed_accepts (input a base replay.initial.1) + a.wire.tape replay.whir.replies proof parsedFull + · exact shapes.1 + · change Protocol.verify (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) saved.shape.lanes + (CausalGame.liftRoot base) + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a base replay.initial.1).claims a.wire.tape.1).weight + (CausalGame.batchClaims (2^(ParameterBounds.config packet.val.profile).logN) + (input a base replay.initial.1).claims a.wire.tape.1).value proof = .ok () + rw [lambda] + exact verified + +#print axioms decodeStack_rootShapes +#print axioms verifySource_experiment +end Whir.PCSBCSNativeOracleReplay diff --git a/verification/whir/Whir/PCSBCSNativePacketBridge.lean b/verification/whir/Whir/PCSBCSNativePacketBridge.lean new file mode 100644 index 000000000..2cea18603 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativePacketBridge.lean @@ -0,0 +1,316 @@ +import Whir.WHIRPhysicalReplay +import Whir.PCSBCSCapturedSourceStatePath + +/-! Deterministic stack packet conversion. The native packet supplies admission, +caller framing and the path cap. No source-execution or acceptance certificate is +part of this interface. Completion alignment below is scoped to a terminal +native packet; a partial reader is not asserted to finish the schedule. -/ +set_option autoImplicit false +set_option backward.isDefEq.respectTransparency false +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSNativePacketBridge +open FiatShamirGame DuplexModeGame DuplexFraming CausalProbability +open PCSBCSChallengeOracle PCSBCSRounds WHIRHistory + +variable (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + +def query (packet : RawWHIRKeys.Packet ctx Q) := + WHIRPhysicalVerifier.packetQuery ctx Q packet.val.profile packet rfl + +def sourcePacket (packet : RawWHIRKeys.Packet ctx Q) : + SourcePacket packet.val.profile Q ctx.iv (RawWHIRKeys.entry ctx packet.val) + (query ctx Q packet) where + messages := packet.val.messages + nonempty := packet.property.2.1 + admitted := packet.property.2.2.1 + entryValid := RawWHIRKeys.packet_entryValid ctx Q packet + position_eq := (WHIRPhysicalReplay.packetQuery_position ctx Q _ packet rfl).symm + pathBound := by + intro block + have normal := WHIRHistoryKey.scheduled_normal _ _ packet.property.2.1 packet.property.2.2.1 + have bound := RawWHIRKeys.packet_pathBound ctx Q packet + rw [← RawWHIRKeys.pathCost_block ctx packet.val block.val] at bound + rw [RawWHIRKeys.coordinate_eq_outputKeyFrom ctx packet.val block.val normal] at bound + simpa only [RawWHIRKeys.width, stack] using bound + +def canonicalPacket (packet : RawWHIRKeys.Packet ctx Q) : + CanonicalPacket packet.val.profile Q ctx.iv (RawWHIRKeys.entry ctx packet.val) := + ⟨query ctx Q packet, sourcePacket ctx stack Q packet⟩ + +def enteredPacket (packet : RawWHIRKeys.Packet ctx Q) : + EnteredPacket packet.val.profile Q ctx.iv (RawWHIRKeys.entry ctx packet.val).frames.length := + ⟨⟨RawWHIRKeys.entry ctx packet.val, rfl⟩, canonicalPacket ctx stack Q packet⟩ + +/-- A common aggregate compiler cap is an explicit monotone reindex, not an +identification of the local packet cap with the verifier's aggregate cost. -/ +def reindex {Q' : Nat} (bounded : Q ≤ Q') (packet : RawWHIRKeys.Packet ctx Q) : + RawWHIRKeys.Packet ctx Q' := + ⟨packet.val, ⟨packet.property.1, packet.property.2.1, packet.property.2.2.1, + (RawWHIRKeys.packet_pathBound ctx Q packet).trans bounded, + RawWHIRKeys.packet_entryValid ctx Q packet, RawWHIRKeys.packet_entryLength ctx Q packet, + RawWHIRKeys.packet_callerOutputBound ctx Q packet⟩⟩ + +@[simp] theorem reindex_coordinate {Q' : Nat} (bounded : Q ≤ Q') + (packet : RawWHIRKeys.Packet ctx Q) (block : Nat) : + RawWHIRKeys.coordinate ctx (reindex ctx Q bounded packet).val block = + RawWHIRKeys.coordinate ctx packet.val block := rfl +/-- Both the reader's aggregate cost and the original packet path cap fit +here. In particular this does not assert `Q = sourceBudget`. -/ +def commonCap (packet : RawWHIRKeys.Packet ctx Q) : Nat := + max Q (WHIRPhysicalVerifier.sourceBudget ctx Q packet) + +def commonCapPacket (packet : RawWHIRKeys.Packet ctx Q) : + RawWHIRKeys.Packet ctx (commonCap ctx Q packet) := + reindex ctx Q (Nat.le_max_left _ _) packet + +theorem sourceBudget_le_commonCap (packet : RawWHIRKeys.Packet ctx Q) : + WHIRPhysicalVerifier.sourceBudget ctx Q packet ≤ commonCap ctx Q packet := + Nat.le_max_right _ _ + +theorem reindex_dropPacket {Q' : Nat} (bounded : Q ≤ Q') + (packet : RawWHIRKeys.Packet ctx Q) (n : Nat) + (nonempty : packet.val.messages.drop n ≠ []) : + reindex ctx Q bounded (RawWHIRKeys.dropPacket ctx Q packet n nonempty) = + RawWHIRKeys.dropPacket ctx Q' (reindex ctx Q bounded packet) n nonempty := + Subtype.ext rfl +theorem reindex_ancestors {Q' : Nat} (bounded : Q ≤ Q') + (packet : RawWHIRKeys.Packet ctx Q) : + RawWHIRKeys.ancestors ctx Q' (reindex ctx Q bounded packet) = + (RawWHIRKeys.ancestors ctx Q packet).map (reindex ctx Q bounded) := by + unfold RawWHIRKeys.ancestors + rw [List.map_ofFn] + apply congrArg List.ofFn + funext i + exact (reindex_dropPacket ctx Q bounded packet _ _).symm + +theorem reindex_completion {Q' : Nat} (bounded : Q ≤ Q') + (packet : RawWHIRKeys.Packet ctx Q) : + RawOracleCoupling.Concrete.completion ctx Q' (reindex ctx Q bounded packet) = + (RawOracleCoupling.Concrete.completion ctx Q packet).map (reindex ctx Q bounded) := by + simp only [RawOracleCoupling.Concrete.completion, List.map_append, List.map_singleton, + reindex_ancestors] + +theorem encode_reindex_expanded {Q' : Nat} (bounded : Q ≤ Q') + (packet : RawWHIRKeys.Packet ctx Q) (b : Fin (RawWHIRKeys.blocks ctx packet.val)) : + expandKey (RawWHIRKeys.encode ctx Q' ⟨reindex ctx Q bounded packet,b⟩) = + expandKey (RawWHIRKeys.encode ctx Q ⟨packet,b⟩) := by + unfold RawWHIRKeys.encode + simp only [expand_constructionKey, reindex_coordinate] + + + +/-- The drop is exactly the canonical predecessor at the same cap and literal +entry, including the domain, statement and all entry frames. -/ +theorem dropPacket_eq_predecessor (packet : RawWHIRKeys.Packet ctx Q) + (r : (canonicalPacket ctx stack Q packet).Earlier) : + canonicalPacket ctx stack Q (RawWHIRKeys.dropPacket ctx Q packet + (position (query ctx Q packet) - position r.val) + ((canonicalPacket ctx stack Q packet).prefixMessages_nonempty r)) = + (canonicalPacket ctx stack Q packet).predecessor r := by + apply CanonicalPacket.messages_injective + rfl + +/-- Every conversion keeps the literal native entry, not merely its digest. -/ +@[simp] theorem enteredPacket_entry (packet : RawWHIRKeys.Packet ctx Q) : + (enteredPacket ctx stack Q packet).1.val = RawWHIRKeys.entry ctx packet.val := rfl + +/-- Aligning proof indices changes no packet data. -/ +def enteredPacketAt {p : ParameterBounds.Profile} {entry : FramedHistory} + (packet : RawWHIRKeys.Packet ctx Q) + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) : + EnteredPacket p Q ctx.iv entry.frames.length := by + cases profile + cases aligned + exact enteredPacket ctx stack Q packet + +@[simp] theorem enteredPacketAt_messages {p : ParameterBounds.Profile} {entry : FramedHistory} + (packet : RawWHIRKeys.Packet ctx Q) + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) : + (enteredPacketAt ctx stack Q packet profile aligned).2.messages = packet.val.messages := by + cases profile + cases aligned + rfl + +@[simp] theorem enteredPacketAt_entry {p : ParameterBounds.Profile} {entry : FramedHistory} + (packet : RawWHIRKeys.Packet ctx Q) + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) : + (enteredPacketAt ctx stack Q packet profile aligned).1.val = entry := by + cases profile + cases aligned + rfl + +theorem completion_entries (packet : RawWHIRKeys.Packet ctx Q) : + ∀ a ∈ RawOracleCoupling.Concrete.completion ctx Q packet, + RawWHIRKeys.entry ctx a.val = RawWHIRKeys.entry ctx packet.val := by + intro a member + simp only [RawOracleCoupling.Concrete.completion, List.mem_append, List.mem_singleton] at member + rcases member with prior | same + · obtain ⟨i,rfl⟩ := List.mem_ofFn.mp prior + rfl + · subst a + rfl + +def completionPackets (packet : RawWHIRKeys.Packet ctx Q) : + List (EnteredPacket packet.val.profile Q ctx.iv + (RawWHIRKeys.entry ctx packet.val).frames.length) := + (RawOracleCoupling.Concrete.completion ctx Q packet).attach.map fun a => + enteredPacketAt ctx stack Q a.val + (WHIRPhysicalVerifier.completion_profiles ctx Q packet a.val a.property) + (completion_entries ctx Q packet a.val a.property) + +private theorem entered_ext {p : ParameterBounds.Profile} {entry : FramedHistory} + (a b : EnteredPacket p Q ctx.iv entry.frames.length) + (ae : a.1.val = entry) (be : b.1.val = entry) + (messages : a.2.messages = b.2.messages) : a = b := by + have same : a.1 = b.1 := Subtype.ext (ae.trans be.symm) + cases a with + | mk ea pa => + cases b with + | mk eb pb => + cases same + have eq := CanonicalPacket.messages_injective messages + cases eq + rfl + +/-- Actual terminal position suffices for exact canonical completion. The +native list is not replaced by an assumed StatePath or a supplied packet list. -/ +theorem completionPackets_eq (packet : RawWHIRKeys.Packet ctx Q) + (terminal : query ctx Q packet = + PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config packet.val.profile)) : + completionPackets ctx stack Q packet = + PCSBCSCapturedSourceStatePath.packets (enteredPacket ctx stack Q packet) := by + have slot := WHIRPhysicalReplay.packetQuery_position ctx Q _ packet rfl + change position (query ctx Q packet) = packet.val.messages.length-1 at slot + rw [terminal, PCSBCSCapturedSourceStatePath.lastCoordinate_position] at slot + have nonempty := List.length_pos_iff.mpr packet.property.2.1 + have depthPositive := WHIRHistory.position_lt_depth + (.initial : Coordinate (ParameterBounds.config packet.val.profile)) + have length : packet.val.messages.length = depth (ParameterBounds.config packet.val.profile) := by omega + apply List.ext_getElem + · simp only [completionPackets, List.length_map, List.length_attach, + RawOracleCoupling.Concrete.completion, List.length_append, List.length_singleton, + RawWHIRKeys.ancestors_length, PCSBCSCapturedSourceStatePath.packets, List.length_map] + change packet.val.messages.length-1+1 = depth _ + omega + · intro i hi hj + simp only [PCSBCSCapturedSourceStatePath.packets, List.length_map] at hj + simp only [completionPackets, PCSBCSCapturedSourceStatePath.packets, + List.getElem_map, List.getElem_attach] + apply entered_ext ctx Q (entry := RawWHIRKeys.entry ctx packet.val) + · exact enteredPacketAt_entry ctx stack Q _ _ _ + · exact congrArg Subtype.val (PCSBCSCapturedSourceStatePath.packetAt_entry _ _) + · rw [enteredPacketAt_messages] + have hpos := WHIRHistory.position_schedule_get + (ParameterBounds.config packet.val.profile) ⟨i,hj⟩ + change position ((schedule (ParameterBounds.config packet.val.profile))[i]'hj) = i at hpos + have hjdepth : i < depth (ParameterBounds.config packet.val.profile) := hj + rw [← length] at hjdepth + have nativeLength : (RawWHIRKeys.ancestors ctx Q packet).length = packet.val.messages.length-1 := + RawWHIRKeys.ancestors_length ctx Q packet + by_cases earlier : i < packet.val.messages.length-1 + · have before : position ((schedule (ParameterBounds.config packet.val.profile))[i]'hj) < + position (enteredPacket ctx stack Q packet).2.coord := by + change position ((schedule (ParameterBounds.config packet.val.profile))[i]'hj) < + position (query ctx Q packet) + rw [hpos] + have pos := WHIRPhysicalReplay.packetQuery_position ctx Q _ packet rfl + exact pos.symm ▸ earlier + have eq : PCSBCSCapturedSourceStatePath.packetAt (enteredPacket ctx stack Q packet) + ((schedule (ParameterBounds.config packet.val.profile))[i]'hj) = + (enteredPacket ctx stack Q packet).predecessor + ⟨(schedule (ParameterBounds.config packet.val.profile))[i]'hj,before⟩ := + dite_eq_left before + rw [eq] + change ((RawWHIRKeys.ancestors ctx Q packet ++ [packet])[i]'_).val.messages = + packet.val.messages.drop (position (query ctx Q packet) - + position ((schedule (ParameterBounds.config packet.val.profile))[i]'hj)) + rw [hpos] + have pos : position (query ctx Q packet) = packet.val.messages.length-1 := + WHIRPhysicalReplay.packetQuery_position ctx Q _ packet rfl + rw [pos] + rw [List.getElem_append_left (by omega)] + exact (RawWHIRKeys.ancestors_get ctx Q packet ⟨i,earlier⟩).2 + · have notBefore : ¬ position ((schedule (ParameterBounds.config packet.val.profile))[i]'hj) < + position (enteredPacket ctx stack Q packet).2.coord := by + change ¬ position ((schedule (ParameterBounds.config packet.val.profile))[i]'hj) < + position (query ctx Q packet) + rw [hpos] + have pos := WHIRPhysicalReplay.packetQuery_position ctx Q _ packet rfl + exact pos.symm ▸ earlier + have eq : PCSBCSCapturedSourceStatePath.packetAt (enteredPacket ctx stack Q packet) + ((schedule (ParameterBounds.config packet.val.profile))[i]'hj) = + enteredPacket ctx stack Q packet := dite_eq_right notBefore + rw [eq] + have atLast : i = (RawWHIRKeys.ancestors ctx Q packet).length := by + omega + change ((RawWHIRKeys.ancestors ctx Q packet ++ [packet])[i]'_).val.messages = packet.val.messages + rw [List.getElem_append_right (by omega)] + simp only [atLast, Nat.sub_self, List.getElem_cons_zero] + +theorem sourcePacket_coordinate (packet : RawWHIRKeys.Packet ctx Q) + (b : Fin (blocks (rawWidth (query ctx Q packet)))) : + (sourcePacket ctx stack Q packet).coordinate b = + RawWHIRKeys.coordinate ctx packet.val b.val := by + have normal := WHIRHistoryKey.scheduled_normal _ _ packet.property.2.1 packet.property.2.2.1 + rw [RawWHIRKeys.coordinate_eq_outputKeyFrom ctx packet.val b.val normal] + simp only [SourcePacket.coordinate, RawWHIRKeys.width, stack] + rfl + +theorem dropPacket_eq_enteredPredecessor (packet : RawWHIRKeys.Packet ctx Q) + (r : (enteredPacket ctx stack Q packet).Earlier) : + enteredPacket ctx stack Q (RawWHIRKeys.dropPacket ctx Q packet + (position (query ctx Q packet) - position r.val) + ((canonicalPacket ctx stack Q packet).prefixMessages_nonempty r)) = + (enteredPacket ctx stack Q packet).predecessor r := by + apply entered_ext ctx Q (entry := RawWHIRKeys.entry ctx packet.val) + · rfl + · rfl + · rfl + +/-- Terminality is derived from the native Pending length, so execution +inversion can use its completed depth without assuming a semantic StatePath. -/ +theorem query_eq_last_of_length (packet : RawWHIRKeys.Packet ctx Q) + (completed : packet.val.messages.length = depth (ParameterBounds.config packet.val.profile)) : + query ctx Q packet = PCSRoundByRoundTranscriptState.lastCoordinate + (ParameterBounds.config packet.val.profile) := by + apply CausalPrefix.position_injective + have pos : position (query ctx Q packet) = packet.val.messages.length-1 := + WHIRPhysicalReplay.packetQuery_position ctx Q _ packet rfl + rw [pos, completed, PCSBCSCapturedSourceStatePath.lastCoordinate_position] + +theorem completionPackets_eq_of_length (packet : RawWHIRKeys.Packet ctx Q) + (completed : packet.val.messages.length = depth (ParameterBounds.config packet.val.profile)) : + completionPackets ctx stack Q packet = + PCSBCSCapturedSourceStatePath.packets (enteredPacket ctx stack Q packet) := + completionPackets_eq ctx stack Q packet (query_eq_last_of_length ctx Q packet completed) + +include stack in +theorem packet_blocks_pcs (packet : RawWHIRKeys.Packet ctx Q) : + RawWHIRKeys.blocks ctx packet.val = blocks (rawWidth (query ctx Q packet)) := by + change (RawWHIRKeys.width ctx.mode packet.val.profile (packet.val.messages.length-1)+31)/32 = _ + simp only [RawWHIRKeys.width, stack] + have width := (sourcePacket ctx stack Q packet).width_eq + change WHIRHistoryKey.stackWidth (ParameterBounds.config packet.val.profile) + (packet.val.messages.length-1) = 24*rawWidth (query ctx Q packet) at width + rw [width] + rfl + +/-- Native partition and source packet addresses name the very same raw key. -/ +theorem sourcePacket_key (packet : RawWHIRKeys.Packet ctx Q) + (b : Fin (blocks (rawWidth (query ctx Q packet)))) : + (sourcePacket ctx stack Q packet).key b = + RawWHIRKeys.encode ctx Q ⟨packet,⟨b.val, by + rw [packet_blocks_pcs ctx stack Q packet] + exact b.isLt⟩⟩ := by + unfold SourcePacket.key RawWHIRKeys.encode + congr 1 + exact sourcePacket_coordinate ctx stack Q packet b + +#print axioms sourcePacket_key +#print axioms completionPackets_eq_of_length + + +#print axioms completionPackets_eq +#print axioms sourcePacket +#print axioms dropPacket_eq_predecessor +end Whir.PCSBCSNativePacketBridge diff --git a/verification/whir/Whir/PCSBCSNativePacketCodec.lean b/verification/whir/Whir/PCSBCSNativePacketCodec.lean new file mode 100644 index 000000000..589abd5b9 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativePacketCodec.lean @@ -0,0 +1,168 @@ +import Whir.PCSBCSNativePacketBridge +import Whir.WHIRRawReplay + +/-! Full native GroupAnswer blocks are cast by their literal block count, and +then decoded by the same contiguous byte cursor as PCS grouped answers. This is +pointwise equality, not an equality of distributions or of output-cache words. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option backward.isDefEq.respectTransparency false +set_option maxRecDepth 100000 +namespace Whir.PCSBCSNativePacketCodec +open Concrete Protocol CausalProbability CausalGame FiatShamirGame PCSBCSRounds +open PCSBCSChallengeOracle PCSBCSNativePacketBridge + +private theorem vectorBytes_slice (n : Nat) (v : Fin n → E) (i : Fin n) (j : Fin 24) : + vectorBytes n v ⟨24*i.val+j.val, by omega⟩ = ByteCodec.encodeE (v i) j := by + have hd : (24*i.val+j.val)/24 = i.val := by omega + have hm : (24*i.val+j.val)%24 = j.val := by omega + change ByteCodec.encodeE (v ⟨(24*i.val+j.val)/24, _⟩) + ⟨(24*i.val+j.val)%24, _⟩ = _ + congr 2 + · exact Fin.ext hd + +private theorem byte_at {n : Nat} (v : Fin n → Byte) (i : Nat) (hi : i < n) : + (List.ofFn v)[i]! = v ⟨i,hi⟩ := by + rw [getElem!_pos _ _ (by simpa using hi)] + exact List.getElem_ofFn _ +private theorem initial_map {c : Config} (x : Raw (.initial : Coordinate c)) (a : Fin 6) : + rawVector .initial x a.succ.castSucc = x.1.2 a := by + change Sum.elim (fun z : Fin 7 => + Sum.elim (fun _ : Fin 1 => x.1.1) x.1.2 (finSumFinEquiv.symm z)) + (fun _ : Fin 1 => x.2) (finSumFinEquiv.symm a.succ.castSucc) = _ + rw [finSumFinEquiv_symm_apply_castSucc] + simp only [Sum.elim_inl] + have h : a.succ = Fin.natAdd 1 a := Fin.ext (by simp [Nat.add_comm]) + rw [h, finSumFinEquiv_symm_apply_natAdd] + rfl + +private theorem query_chunk {c : Config} (i : Fin c.folds.size) + (x : Raw (.query i)) (a : Fin (queryChunks c i.val)) : + rawVector (.query i) x a.castSucc = x.1 a := by + change Sum.elim x.1 (fun _ : Fin 1 => x.2) (finSumFinEquiv.symm a.castSucc) = _ + rw [finSumFinEquiv_symm_apply_castSucc] + rfl + +private theorem query_lambda {c : Config} (i : Fin c.folds.size) (x : Raw (.query i)) : + rawVector (.query i) x (Fin.last _) = x.2 := by + change Sum.elim x.1 (fun _ : Fin 1 => x.2) (finSumFinEquiv.symm (Fin.last _)) = _ + rw [finSumFinEquiv_symm_last] + rfl + + +private theorem decodeSlice (n : Nat) (v : Fin n → E) (i : Fin n) : + WHIRFiatShamir.scalarCodec (fun j => + (List.ofFn (vectorBytes n v))[24*i.val+j.val]!) = v i := by + apply WHIRFiatShamir.scalarCodec.symm.injective + rw [Equiv.symm_apply_apply] + funext j + rw [byte_at _ (24*i.val+j.val) (by have := i.isLt; have := j.isLt; omega)] + exact vectorBytes_slice n v i j + +/-- Stream decoding inverts the literal PCS byte representation. -/ +theorem decodeBytes_vector {c : Config} (q : Coordinate c) (x : Raw q) : + StackWHIRCodec.decodeBytes q + (List.ofFn (vectorBytes (rawWidth q) (rawVector q x))) = x := by + cases q with + | initial => + simp only [StackWHIRCodec.decodeBytes, StackWHIRCodec.initialCodec, + Equiv.prodCongr_apply, Prod.map, StackWHIRCodec.initialSlices, rawWidth, WHIRHistory.stackScalarCount] + apply Prod.ext + · apply Prod.ext + · have h := decodeSlice 8 (rawVector (.initial : Coordinate c) x) 0 + rw [show rawVector (.initial : Coordinate c) x (0 : Fin 8) = x.1.1 from rfl] at h + exact h + · funext a + have h := decodeSlice 8 (rawVector (.initial : Coordinate c) x) a.succ.castSucc + rw [initial_map] at h + exact h + · have h := decodeSlice 8 (rawVector (.initial : Coordinate c) x) 7 + rw [show rawVector (.initial : Coordinate c) x (7 : Fin 8) = x.2 from rfl] at h + exact h + | fold i j => + simp only [StackWHIRCodec.decodeBytes, WHIRFiatShamir.codec, WHIRROM.slices, + rawWidth, WHIRHistory.stackScalarCount, WHIRHistory.scalarCount] + have h := decodeSlice 1 (rawVector (.fold i j) x) 0 + rw [show rawVector (.fold i j) x (0 : Fin 1) = x from rfl] at h + exact h + | ood i j => + simp only [StackWHIRCodec.decodeBytes, WHIRFiatShamir.codec, WHIRROM.slices, + rawWidth, WHIRHistory.stackScalarCount, WHIRHistory.scalarCount] + funext a + exact decodeSlice _ x a + | query i => + simp only [StackWHIRCodec.decodeBytes, WHIRFiatShamir.codec, WHIRROM.slices, + Equiv.prodCongr_apply, rawWidth, WHIRHistory.stackScalarCount, WHIRHistory.scalarCount] + apply Prod.ext + · funext a + have h := decodeSlice _ (rawVector (.query i) x) a.castSucc + rw [query_chunk] at h + exact h + · have h := decodeSlice _ (rawVector (.query i) x) (Fin.last _) + rw [query_lambda] at h + exact h + | tail j => + simp only [StackWHIRCodec.decodeBytes, WHIRFiatShamir.codec, WHIRROM.slices, + rawWidth, WHIRHistory.stackScalarCount, WHIRHistory.scalarCount] + have h := decodeSlice 1 (rawVector (.tail j) x) 0 + rw [show rawVector (.tail j) x (0 : Fin 1) = x from rfl] at h + exact h + +theorem blockCount_eq {c : Config} (q : Coordinate c) : + StackWHIRCodec.outputBlocks q = blocks (rawWidth q) := by + rw [StackWHIRCodec.outputBlocks_eq] + simp only [blocks, rawWidth, Nat.mul_comm] + +/-- A literal index cast retains every byte of every full output block. -/ +def fullBlocksEquiv {c : Config} (q : Coordinate c) : + (Fin (StackWHIRCodec.outputBlocks q) → Digest32) ≃ + (Fin (blocks (rawWidth q)) → Digest32) := + Equiv.arrowCongr (finCongr (blockCount_eq q)) (Equiv.refl Digest32) + +/-- The byte-level codec bridge covers initial, fold, OOD, query and tail +without discarding the high query bits or the last block's unused suffix. -/ +theorem blockDecode_eq_grouped {c : Config} (q : Coordinate c) + (raw : Fin (StackWHIRCodec.outputBlocks q) → Digest32) : + StackWHIRCodec.blockDecode q raw = grouped q (fullBlocksEquiv q raw) := by + rw [StackWHIRCodec.blockDecode_eq_bytes] + calc + _ = StackWHIRCodec.decodeBytes q + (List.ofFn (vectorBytes (rawWidth q) + (rawVector q (grouped q (fullBlocksEquiv q raw))))) := by + apply congrArg (StackWHIRCodec.decodeBytes q) + apply congrArg List.ofFn + funext j + rw [grouped_payload_bytes] + rfl + _ = _ := decodeBytes_vector q _ + +variable (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + +/-- Native grouped answers and PCS grouped answers differ only in their Fin +index proof. This equivalence, including its inverse, retains full blocks. -/ +def nativeFullBlocksEquiv (packet : RawWHIRKeys.Packet ctx Q) : + RawOracleCoupling.Concrete.GroupAnswer ctx Q (.inl packet) ≃ + (Fin (blocks (rawWidth (query ctx Q packet))) → Digest32) := + (WHIRRawReplay.packetEquiv ctx stack Q packet).trans + (fullBlocksEquiv (query ctx Q packet)) + +theorem nativeFullBlocksEquiv_apply (packet : RawWHIRKeys.Packet ctx Q) + (raw : RawOracleCoupling.Concrete.GroupAnswer ctx Q (.inl packet)) + (b : Fin (blocks (rawWidth (query ctx Q packet)))) : + nativeFullBlocksEquiv ctx stack Q packet raw b = + raw ⟨b.val, by + rw [WHIRRawReplay.packet_blocks ctx stack Q packet, blockCount_eq] + exact b.isLt⟩ := rfl + +/-- Pointwise equality for the actual native full-block answer, not a scalar +cache or an equality-in-distribution substitute. -/ +theorem decodePacket_eq_grouped (packet : RawWHIRKeys.Packet ctx Q) + (raw : RawOracleCoupling.Concrete.GroupAnswer ctx Q (.inl packet)) : + WHIRRawReplay.decodePacket ctx stack Q packet raw = + grouped (query ctx Q packet) (nativeFullBlocksEquiv ctx stack Q packet raw) := + blockDecode_eq_grouped (query ctx Q packet) (WHIRRawReplay.packetEquiv ctx stack Q packet raw) + +#print axioms blockDecode_eq_grouped +#print axioms decodePacket_eq_grouped + +end Whir.PCSBCSNativePacketCodec diff --git a/verification/whir/Whir/PCSBCSNativePacketCodecSmoke.lean b/verification/whir/Whir/PCSBCSNativePacketCodecSmoke.lean new file mode 100644 index 000000000..e6f7263f7 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativePacketCodecSmoke.lean @@ -0,0 +1,112 @@ +import Whir.PCSBCSNativePacketCodec +import Whir.DuplexCompression + +/-! Executable production logN=15/rate=3 native packet and codec smoke. A +syntactic prover history is admitted by the actual native ValidPacket predicate, +then its real completion is decoded from BLAKE2s duplex output blocks. This is +not an honest arithmetic opening fixture or a successful all-round reader. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativePacketCodecSmoke +open Concrete Protocol CausalProbability CausalGame FiatShamirGame DuplexModeGame +open PCSBCSRounds PCSBCSChallengeOracle PCSBCSNativePacketBridge PCSBCSNativePacketCodec +open DuplexFraming DuplexRefinement + +private def profile : ParameterBounds.Profile := (⟨0,by decide⟩,⟨2,by decide⟩) +private def frames : List Frame := [.absorb 0 [1,2,3,4,5]] +private def ctx : RawWHIRKeys.Context := + ⟨.stack, DuplexCompression.parameterIV, zeroDigest, + fun _ => some profile, fun _ => frames.length, 0⟩ + +/-- Concrete prover strings of the production schedule's exact scalar widths. +Their syntactic admission does not assert arithmetic or Merkle acceptance. -/ +private def pending (n : Fin (WHIRHistory.depth (ParameterBounds.config profile))) : WHIRHistory.Pending := + let c := ParameterBounds.config profile + let qs := WHIRHistory.schedule c + if n.val = 0 then WHIRHistoryKey.initialPending else + let previous := qs[n.val-1]'(lt_of_le_of_lt (Nat.sub_le n.val 1) n.isLt) + ⟨List.replicate (WHIRHistory.replyScalarCount previous) E.zero, + match qs[n.val]'n.isLt with | .query _ => some (0,E.zero) | _ => none⟩ + +private def data : RawWHIRKeys.PacketData := + ⟨zeroDigest, profile, (List.ofFn pending).reverse, frames⟩ +private def cap : Nat := pathCost (RawWHIRKeys.coordinate ctx data 0) + +private def check (ok : Bool) (message : String) : IO Unit := + unless ok do throw (IO.userError message) + +/-- Sharing the evaluated history is an executable optimization of the same +literal coordinate. It does not replace real primitive output by test data. -/ +private def outputBytes (packet : RawWHIRKeys.Packet ctx cap) : Array (Array Byte) := + let h := (RawWHIRKeys.coordinate ctx packet.val 0).history + let historyBytes := Array.ofFn (evalHistory DuplexCompression.compress ctx.iv h) + let cv : Digest32 := fun i => historyBytes[i.val]! + Array.ofFn fun b : Fin (RawWHIRKeys.blocks ctx packet.val) => + Array.ofFn (evalTerminal DuplexCompression.compress cv (.output b.val)) + +private theorem outputBytes_eq (packet : RawWHIRKeys.Packet ctx cap) + (b : Fin (RawWHIRKeys.blocks ctx packet.val)) (i : Fin 32) : + ((outputBytes packet)[b.val]!)[i.val]! = + evalCoordinate DuplexCompression.compress ctx.iv + (RawWHIRKeys.coordinate ctx packet.val b.val) i := by + simp [outputBytes, evalCoordinate, evalTerminal, RawWHIRKeys.coordinate] + +def smoke : IO Unit := do + IO.println "native/groupcodec: checking production logN=15/rate=3" + let c := ParameterBounds.config profile + check (c.logN == 15 && c.rates[0]! == 3) "production geometry changed" + if valid : RawWHIRKeys.ValidPacket ctx cap data then + let final : RawWHIRKeys.Packet ctx cap := ⟨data,valid⟩ + let packets := RawOracleCoupling.Concrete.completion ctx cap final + check (packets.length == (WHIRHistory.schedule c).length) + "native completion did not cover the production schedule" + check ((completionPackets ctx rfl cap final).length == packets.length) + "canonical completion lost a native packet" + IO.println s!"native/groupcodec: admitted {packets.length} production completion packets" + let mut queries := 0 + let mut coordinates := 0 + for packet in packets do + let pc := ParameterBounds.config packet.val.profile + let q := query ctx cap packet + let actual := outputBytes packet + let raw : RawOracleCoupling.Concrete.GroupAnswer ctx cap (.inl packet) := + fun b i => (actual[b.val]!)[i.val]! + let full := nativeFullBlocksEquiv ctx rfl cap packet raw + let native := WHIRRawReplay.decodePacket ctx rfl cap packet raw + let pcs := grouped q full + check (List.ofFn (rawVector q native) == List.ofFn (rawVector q pcs)) + "literal native/grouped scheduled codec mismatch" + check (List.ofFn ((nativeFullBlocksEquiv ctx rfl cap packet).symm full) == List.ofFn raw) + "native full-block index cast dropped output bytes" + check ((enteredPacket ctx rfl cap packet).1.val.frames == frames) + "literal caller-entry frames changed" + check (List.ofFn (vectorBytes (rawWidth q) (rawVector q pcs)) == + List.ofFn (fun i : Fin (rawWidth q*24) => + full ⟨i.val/32, by + change i.val/32 < blocks (rawWidth q) + have h := packet_length (rawWidth q) + have := i.isLt + omega⟩ + ⟨i.val%32,Nat.mod_lt _ (by decide)⟩)) "contiguous payload bytes differ" + match hq : q with + | .initial => + check (RawWHIRKeys.blocks ctx packet.val == 6) "initial is not six full blocks" + | .query i => + let native : Raw (.query i) := hq ▸ native + let pcs : Raw (.query i) := hq ▸ pcs + check ((List.ofFn pcs.1).any (fun e => e.toNat / 2^128 != 0)) + "real full query scalar did not exercise its upper limb" + check (Array.ofFn native.1 == Array.ofFn pcs.1 && native.2 == pcs.2) + "full query high bits or lambda changed" + check (deriveQueries (remaining pc i.val + pc.rates[i.val]!) pc.queries[i.val]! + (Array.ofFn native.1) == deriveQueries (remaining pc i.val + pc.rates[i.val]!) + pc.queries[i.val]! (Array.ofFn pcs.1)) "native query projection differs" + queries := queries+1 + | _ => pure () + coordinates := coordinates+1 + check (queries > 0) "production query geometry was not exercised" + IO.println s!"native/groupcodec PASS: production logN=15/rate=3; initial six full blocks; {coordinates} native completion packets, {queries} full-query/high-bit/lambda geometries" + else + throw (IO.userError "actual native production history failed admission") +end Whir.PCSBCSNativePacketCodecSmoke + +def main : IO Unit := Whir.PCSBCSNativePacketCodecSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSNativePacketVisit.lean b/verification/whir/Whir/PCSBCSNativePacketVisit.lean new file mode 100644 index 000000000..202c4de5f --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativePacketVisit.lean @@ -0,0 +1,212 @@ +import Whir.AnchoredPhysicalExecution +import Whir.PCSBCSMixedConstructionTrace +import Whir.PCSBCSNativePacketBridge +import Whir.PCSBCSCapturedIdealNativeAcceptance + +/-! Native packet visitation is obtained from successful source execution, +not from an assumed complete allocation cache. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativePacketVisit +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame +open WHIRPhysicalVerifier WHIRPhysicalReplay WHIRSourceChronology +open RawOracleCoupling.Concrete +open PublicMerkleProgram MerkleTransport MerkleTransport.Commitments + +private theorem readPacket_first {n : Nat} (positive : 0 < n) (request : Fin n → Query) + (raw : Fin n → Digest32) (observations : List Observation) + (run : Runs (WHIRModeProgram.readPacket n request Program.done) observations raw) : + ∃ answer, (⟨request ⟨0,positive⟩,answer⟩ : Observation) ∈ observations := by + cases n with + | zero => omega + | succ n => + simp only [WHIRModeProgram.readPacket] at run + cases run with + | ask answer rest => exact ⟨answer,List.mem_cons_self⟩ + +theorem readPhysicalPackets_queried {cap : Nat} {R : Type} (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (p : ParameterBounds.Profile) (lanes : Nat) + (proofs : Array PrunedMerklePaths) (packets : List (RawWHIRKeys.Packet ctx Q)) + (profiles : ∀ packet ∈ packets, packet.val.profile = p) (state : WireState p) + (next : WireState p → List (Sigma (GroupAnswer ctx Q)) → Source cap (Option R)) + (observations : List Observation) (result : R) + (run : Runs (erase (readPhysicalPackets ctx stack Q p lanes proofs none + packets profiles state next)) observations (some result)) : + ∀ packet ∈ packets, ∃ answer, + (⟨WHIRModeFinal.request ctx Q packet ⟨0,RawWHIRKeys.blocks_positive ctx packet.val⟩,answer⟩ : + Observation) ∈ observations := by + induction packets generalizing state next observations with + | nil => simp + | cons packet packets ih => + simp only [readPhysicalPackets] at run + cases parsed : absorbResponse state (packet.val.messages.headD ⟨[],none⟩) with + | none => simp only [parsed,erase] at run; cases run + | some value => + obtain ⟨absorbed,root⟩ := value + simp only [parsed] at run + split at run + · rw [announce_erase,sourceLift_erase] at run + obtain ⟨before,nonce,after,whole,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases boundNonce : afterNonce absorbed nonce with + | none => simp only [boundNonce,erase] at continued; cases continued + | some bound => + simp only [boundNonce] at continued + split at continued + · rw [sourceLift_erase] at continued + obtain ⟨beforeRaw,raw,afterRaw,rawWhole,readRaw,read⟩ := (Runs.bind_iff _ _).mp continued + rw [sourceLift_erase] at read + obtain ⟨beforeOpen,opened,afterOpen,openWhole,_,rest⟩ := (Runs.bind_iff _ _).mp read + cases opened with + | none => cases rest + | some checked => + intro current member + rcases List.mem_cons.mp member with same | later + · subst current + rw [readPacket_eq] at readRaw + obtain ⟨answer,queried⟩ := readPacket_first + (RawWHIRKeys.blocks_positive ctx packet.val) + (WHIRModeFinal.request ctx Q packet) raw beforeRaw readRaw + refine ⟨answer,?_⟩ + rw [whole,rawWhole] + exact List.mem_append_right _ (List.mem_append_left _ queried) + · obtain ⟨answer,queried⟩ := ih _ _ _ _ rest current later + refine ⟨answer,?_⟩ + rw [whole,rawWhole,openWhole] + exact List.mem_append_right _ + (List.mem_append_right _ (List.mem_append_right _ queried)) + · cases continued + · cases run + +theorem verifySource_queried (cap : Nat) (boundary : AnchoredPhysicalDriver.Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (saved : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (accepted : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (run : Runs (erase (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet saved proofs)) + observations (some accepted)) : + ∀ current ∈ completion ctx Q packet, ∃ answer, + (⟨WHIRModeFinal.request ctx Q current ⟨0,RawWHIRKeys.blocks_positive ctx current.val⟩,answer⟩ : + Observation) ∈ observations := by + obtain ⟨_,_,before,after,_,whole,_,_,_,physical⟩ := + AnchoredPhysicalExecution.verifySource_success cap boundary model ctx stack Q packet saved proofs + observations accepted run + intro current member + obtain ⟨answer,queried⟩ := readPhysicalPackets_queried ctx stack Q packet.val.profile + saved.shape.lanes proofs _ _ _ _ after accepted physical current member + refine ⟨answer,?_⟩ + rw [whole] + exact List.mem_append_right _ queried + +/-- Reindex by the actual observed key's proved bound, not by an assumed +inequality between the native admission cap and aggregate source budget. -/ +def packetAtBound (ctx : RawWHIRKeys.Context) (Q B : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B) : + RawWHIRKeys.Packet ctx B := + ⟨packet.val,⟨packet.property.1,packet.property.2.1,packet.property.2.2.1,bounded, + RawWHIRKeys.packet_entryValid ctx Q packet,RawWHIRKeys.packet_entryLength ctx Q packet, + RawWHIRKeys.packet_callerOutputBound ctx Q packet⟩⟩ + +theorem packetAtBound_first_coordinate (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q B : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B) + {p : ParameterBounds.Profile} {entry : FramedHistory} + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) : + let current := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (packetAtBound ctx Q B packet bounded) profile aligned + current.2.2.coordinate current.2.firstBlock = RawWHIRKeys.coordinate ctx packet.val 0 := by + cases profile + cases aligned + exact PCSBCSNativePacketBridge.sourcePacket_coordinate ctx stack B + (packetAtBound ctx Q B packet bounded) + (PCSBCSNativePacketBridge.canonicalPacket ctx stack B (packetAtBound ctx Q B packet bounded)).firstBlock + +theorem observed_packet_recorded {R : Type} (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q B : Nat) (packet : RawWHIRKeys.Packet ctx Q) {p : ParameterBounds.Profile} {entry : FramedHistory} + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (log : DuplexPublicSimulator.PublicLog) (program : Program R) + (remaining : Nat) (limit : remaining ≤ B) (counted : DuplexModeGame.Counts remaining program) + (answer : Digest32) + (member : (⟨WHIRModeFinal.request ctx Q packet ⟨0,RawWHIRKeys.blocks_positive ctx packet.val⟩,answer⟩ : + Observation) ∈ (runIdeal (DuplexPublicSimulator.simulator B) ro ctx.iv ⟨seed,log⟩ + program remaining limit counted).view.observations) : + ∃ bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B, + let current := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (packetAtBound ctx Q B packet bounded) profile aligned + let part := PCSBCSChallengeOracle.EnteredPacket.partition + (p := p) (Q := B) (iv := ctx.iv) (boundary := entry.frames.length) + (⟨.inl current,(part.split (PublicCompressionCouplingMixed.oracle seed ro)) (.inl current)⟩ : + Sigma (part.Answer (D := Digest32))) ∈ + (TypedOracleCompiler.Sampling.execute (part.split (PublicCompressionCouplingMixed.oracle seed ro)) + (PCSBCSChallengeOracle.Atomic.program part + (PublicCompressionCouplingMixed.compile B ctx.iv log program remaining limit counted))).2 := by + let coordinate := RawWHIRKeys.coordinate ctx packet.val 0 + have valid := RawWHIRKeys.coordinate_admissible ctx Q + ⟨packet,⟨0,RawWHIRKeys.blocks_positive ctx packet.val⟩⟩ + obtain ⟨bounded,_⟩ := PCSBCSMixedConstructionTrace.ideal_recorded seed ro ctx.iv log + program remaining limit counted coordinate valid answer member + refine ⟨bounded,?_⟩ + let current := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (packetAtBound ctx Q B packet bounded) profile aligned + let part := PCSBCSChallengeOracle.EnteredPacket.partition + (p := p) (Q := B) (iv := ctx.iv) (boundary := entry.frames.length) + apply PCSBCSMixedConstructionTrace.ideal_packet_recorded part seed ro ctx.iv log + program remaining limit counted coordinate valid bounded answer ⟨current,current.2.firstBlock⟩ member + have first := packetAtBound_first_coordinate ctx stack Q B packet bounded profile aligned + have key : current.2.2.key current.2.firstBlock = constructionKey B ctx.iv coordinate bounded := by + unfold PCSBCSChallengeOracle.SourcePacket.key + congr 1 + rw [← key] + exact PCSBCSChallengeOracle.EnteredPacket.recognize_block current current.2.firstBlock + +theorem mixed_success_recorded (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (accepted : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro).result.value = some accepted) : + ∀ current (member : current ∈ completion ctx Q packet), + ∃ bounded : pathCost (RawWHIRKeys.coordinate ctx current.val 0) ≤ B, + let entered := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B + (packetAtBound ctx Q B current bounded) + (completion_profiles ctx Q packet current member) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet current member) + (⟨.inl entered,(PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) (.inl entered)⟩ : + Sigma (PCSBCSSourceRootCapture.Answer)) ∈ + (TypedOracleCompiler.Sampling.execute + (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) + (PCSBCSCapturedIdealNativeAcceptance.allocationProgram + cap model ctx stack Q packet saved proofs B limit)).2 := by + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + intro current member + obtain ⟨answer,queried⟩ := verifySource_queried cap .fresh model ctx stack Q packet saved proofs + _ accepted run current member + have inIdeal : (⟨WHIRModeFinal.request ctx Q current + ⟨0,RawWHIRKeys.blocks_positive ctx current.val⟩,answer⟩ : Observation) ∈ + (runIdeal (DuplexPublicSimulator.simulator B) ro ctx.iv ⟨seed,[]⟩ + (WHIRSourceChronology.compile + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + (sourceBudget ctx Q packet) limit + ((WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap .fresh model ctx stack Q packet saved proofs))).view.observations := by + simpa only [AnchoredMixedIdealSourceAcceptance.mixedView,PublicCompressionCouplingMixed.compile_actual] + using queried + exact observed_packet_recorded ctx stack Q B current + (completion_profiles ctx Q packet current member) + (PCSBCSNativePacketBridge.completion_entries ctx Q packet current member) seed ro [] + (WHIRSourceChronology.compile + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + (sourceBudget ctx Q packet) limit + ((WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap .fresh model ctx stack Q packet saved proofs)) + answer inIdeal + +#print axioms readPhysicalPackets_queried +#print axioms verifySource_queried +#print axioms packetAtBound_first_coordinate +#print axioms observed_packet_recorded +#print axioms mixed_success_recorded +end Whir.PCSBCSNativePacketVisit diff --git a/verification/whir/Whir/PCSBCSNativePhysicalFreeze.lean b/verification/whir/Whir/PCSBCSNativePhysicalFreeze.lean new file mode 100644 index 000000000..109acb3d2 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativePhysicalFreeze.lean @@ -0,0 +1,590 @@ +import Whir.AnchoredPhysicalAfter +import Whir.PCSBCSNativePhysicalMerkleBad +import Whir.PCSBCSNativePublicCapture +import Whir.PCSBCSMerkleSeedProjection +import Whir.PCSBCSCapturedSourceTransport + +/-! Whole historical native executions retain the attacker's queries and the +actual first-address capture. Physical freezes may include the nonordinary +calls of the addressed raw response, but never add its answer to the capture. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSNativePhysicalFreeze +open Concrete FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open PublicMerkleLog PublicCompressionProgram +open MerkleTransport MerkleTransport.Commitments +open MerkleBinding +open PCSBCSNativePublicCapture PCSBCSConstructionReplayTrace + +section Whole +variable (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + +abbrev wholeProgram := WHIRSourceChronology.compile + (AnchoredPhysicalAfter.verifyAfter cap registry Q attacker) + +/-- The operational opening subrun comes from whole success, not a suffix +capture and not an assumed equality of the two simulator caches. -/ +theorem whole_success_observed (C : PrimitiveOracle) + (accepted : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = + some accepted) : + ∀ opening ∈ accepted.native.wire.openings, + WHIRPhysicalOpeningRuns.ObservedOpening accepted.input.record.shape.lanes accepted.input.proofs + (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.observations opening := by + have run := WHIRPhysicalCaller.real_source_runs C registry.context.iv + (AnchoredPhysicalAfter.verifyAfter cap registry Q attacker) + rw [WHIRSourceChronology.real_source_trace] at run + rw [success] at run + obtain ⟨input,before,after,native,split,_,nativeRun,equal⟩ := + AnchoredPhysicalAfter.native_segment cap registry Q attacker _ accepted run + cases equal + obtain ⟨_,_,_,_,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh (registry.packetModel Q input.packet) registry.context rfl Q + input.packet input.record input.proofs after native nativeRun + intro opening member + exact (observed opening member).mono (by + intro o present + rw [split] + exact List.mem_append_right _ present) + +theorem whole_success_evaluated (C : PrimitiveOracle) (A : Nat) + (counted : Counts A (wholeProgram cap registry Q attacker)) + (accepted : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = + some accepted) : + ∀ opening ∈ accepted.native.wire.openings, ∀ path ∈ opening.result.paths, + ∀ bytes ∈ path.opening.inputs (hashing (hash C)), bytes.length < 2^56 ∧ + ∀ event ∈ PublicMerkleLog.plan C bytes, + event ∈ primitiveLog C registry.context.iv (wholeProgram cap registry Q attacker) A counted := by + intro opening member + exact PCSBCSNativePhysicalMerkleBad.observed_complete_evaluated C registry.context.iv + (wholeProgram cap registry Q attacker) A counted opening + (whole_success_observed cap registry Q attacker C accepted success opening member) + +theorem whole_success_geometry (C : PrimitiveOracle) + (accepted : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = + some accepted) : + ∀ opening ∈ accepted.native.wire.openings, ∀ path ∈ opening.result.paths, ∃ row : List K, + row.length = (if opening.level.val = 0 then accepted.input.record.shape.lanes + else WHIRPhysicalVerifier.leafWords accepted.input.packet.val.profile opening.level.val) ∧ + path.leafData = leafImage 0 + (WHIRPhysicalVerifier.leafWords accepted.input.packet.val.profile opening.level.val) row ∧ + path.leafData.length = WHIRPhysicalVerifier.leafWords accepted.input.packet.val.profile opening.level.val ∧ + path.path.length = (ParameterBounds.length + (ParameterBounds.config accepted.input.packet.val.profile) opening.level.val).log2 ∧ + path.root (hash C) = opening.root := by + intro opening member + exact PCSBCSNativePhysicalMerkleBad.observed_complete_geometry C registry.context.iv + (wholeProgram cap registry Q attacker) opening + (whole_success_observed cap registry Q attacker C accepted success opening member) +end Whole + +/-- Duplicate-retaining physical calls, in execution order. -/ +def physicalTrace (C : PrimitiveOracle) (iv : Digest32) (seen : List Observation) : PublicLog := + seen.flatMap (fun o => queryTrace C iv o.query) + +theorem physicalTrace_actual {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (A : Nat) (counted : Counts A program) : + primitiveLog C iv program A counted = physicalTrace C iv (runReal C iv program).view.observations := by + induction program generalizing A with + | done => rfl + | ask q next ih => + rw [primitiveLog_ask,ih] + rfl + +abbrev RawEvent (B : Nat) := Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32) + +def drawLog {B : Nat} (events : List (RawEvent B)) : PublicLog := events.flatMap rawOrdinary + +/-- Cache coverage is membership, deliberately not list equality: repeats +remain in physicalTrace while a cached mixed query makes no seed draw. -/ +structure Covered (C : PrimitiveOracle) (cache seeds physical : PublicLog) : Prop where + authentic : AuthenticLog C cache + seeds_physical : ∀ e ∈ seeds, e ∈ physical + physical_seeds : ∀ n d, (n,d) ∈ physical → tag n = 0 → (n,d) ∈ seeds + cache_seeds : ∀ n d, (n,d) ∈ cache → tag n = 0 → (n,d) ∈ seeds + +private theorem step_covered (B : Nat) (C : PrimitiveOracle) (iv : Digest32) + (cache seeds physical : PublicLog) (covered : Covered C cache seeds physical) + (o : Observation) (answer : o.answer = realAnswer C iv o.query) : + Covered C (nextLog cache o) (drawLog (observationDraw B iv cache o) ++ seeds) + (physical ++ queryTrace C iv o.query) := by + rcases o with ⟨query,d⟩ + cases query with + | construction coordinate valid => + have noOrdinary : ∀ n e, (n,e) ∈ queryTrace C iv (.construction coordinate valid) → tag n ≠ 0 := by + intro n e member + have positive := PublicCompressionProgram.construction_tags C iv coordinate valid n e member + omega + have empty : drawLog (observationDraw B iv cache ⟨.construction coordinate valid,d⟩) = [] := by + simp only [observationDraw] + split <;> rfl + rw [empty,List.nil_append] + refine ⟨covered.authentic,?_,?_,covered.cache_seeds⟩ + · intro e member + exact List.mem_append_left _ (covered.seeds_physical e member) + · intro n e member ordinary + rcases List.mem_append.mp member with earlier | current + · exact covered.physical_seeds n e earlier ordinary + · exact False.elim (noOrdinary n e current ordinary) + | primitive purpose input => + change d = C input at answer + subst d + have trace : queryTrace C iv (.primitive purpose input) = [(input,C input)] := rfl + have auth : AuthenticLog C (nextLog cache ⟨.primitive purpose input,C input⟩) := by + intro n d member + rcases List.mem_cons.mp member with equal | old + · cases equal; rfl + · exact covered.authentic n d old + cases hit : DuplexPublicSimulator.lookup cache input with + | some d => + have same : d = C input := (covered.authentic input d (DuplexPublicSimulator.lookup_mem hit)).symm + have empty : drawLog (observationDraw B iv cache ⟨.primitive purpose input,C input⟩) = [] := by + simp [observationDraw,hit,drawLog] + rw [empty,List.nil_append,trace] + refine ⟨auth,?_,?_,?_⟩ + · intro e member + exact List.mem_append_left _ (covered.seeds_physical e member) + · intro n e member ordinary + rcases List.mem_append.mp member with earlier | current + · exact covered.physical_seeds n e earlier ordinary + · have equal := List.mem_singleton.mp current + cases equal + exact covered.cache_seeds input (C input) (same ▸ DuplexPublicSimulator.lookup_mem hit) ordinary + · intro n e member ordinary + rcases List.mem_cons.mp member with equal | earlier + · cases equal + exact covered.cache_seeds input (C input) (same ▸ DuplexPublicSimulator.lookup_mem hit) ordinary + · exact covered.cache_seeds n e earlier ordinary + | none => + cases key : DuplexPublicSimulator.privateKey B cache input with + | some raw => + have nonordinary : tag input ≠ 0 := by + intro ordinary + have empty := PCSBCSMerkleSeedProjection.privateKey_none B cache ordinary + rw [key] at empty + cases empty + have empty : drawLog (observationDraw B iv cache ⟨.primitive purpose input,C input⟩) = [] := by + simp [observationDraw,hit,key,drawLog,rawOrdinary] + rw [empty,List.nil_append,trace] + refine ⟨auth,?_,?_,?_⟩ + · intro e member + exact List.mem_append_left _ (covered.seeds_physical e member) + · intro n e member ordinary + rcases List.mem_append.mp member with earlier | current + · exact covered.physical_seeds n e earlier ordinary + · cases List.mem_singleton.mp current + exact False.elim (nonordinary ordinary) + · intro n e member ordinary + rcases List.mem_cons.mp member with equal | earlier + · cases equal + exact False.elim (nonordinary ordinary) + · exact covered.cache_seeds n e earlier ordinary + | none => + have draws : drawLog (observationDraw B iv cache ⟨.primitive purpose input,C input⟩) = + [(input,C input)] := by simp [observationDraw,hit,key,drawLog,rawOrdinary] + rw [draws,trace] + refine ⟨auth,?_,?_,?_⟩ + · intro e member + rcases List.mem_append.mp member with current | earlier + · exact List.mem_append_right _ current + · exact List.mem_append_left _ (covered.seeds_physical e earlier) + · intro n d member ordinary + rcases List.mem_append.mp member with earlier | current + · exact List.mem_append_right _ (covered.physical_seeds n d earlier ordinary) + · exact List.mem_append_left _ current + · intro n d member ordinary + rcases List.mem_cons.mp member with equal | earlier + · exact List.mem_append_left _ (List.mem_singleton.mpr equal) + · exact List.mem_append_right _ (covered.cache_seeds n d earlier ordinary) + +def captureFrom {B : Nat} (events : List (RawEvent B)) (prior : PublicLog) : PublicLog := + events.foldl (fun log event => rawOrdinary event ++ log) prior + +private theorem draws_cases (B : Nat) (iv : Digest32) (cache : PublicLog) (o : Observation) : + observationDraw B iv cache o = [] ∨ ∃ event, observationDraw B iv cache o = [event] := by + rcases o with ⟨query,d⟩ + cases query with + | primitive purpose input => + cases hit : DuplexPublicSimulator.lookup cache input with + | some d => exact Or.inl (by simp [observationDraw,hit]) + | none => + cases key : DuplexPublicSimulator.privateKey B cache input with + | none => exact Or.inr ⟨⟨.inl input,d⟩,by simp [observationDraw,hit,key]⟩ + | some raw => exact Or.inr ⟨⟨.inr raw,d⟩,by simp [observationDraw,hit,key]⟩ + | construction coordinate valid => + by_cases bound : pathCost coordinate ≤ B + · exact Or.inr ⟨⟨.inr (constructionKey B iv coordinate bound),d⟩,by simp [observationDraw,bound]⟩ + · exact Or.inl (by simp [observationDraw,bound]) + +private theorem cache_step_subset (C : PrimitiveOracle) (iv : Digest32) + (cache physical : PublicLog) (subset : ∀ e ∈ cache, e ∈ physical) + (o : Observation) (answer : o.answer = realAnswer C iv o.query) : + ∀ e ∈ nextLog cache o, e ∈ physical ++ queryTrace C iv o.query := by + rcases o with ⟨query,d⟩ + cases query with + | construction coordinate valid => + exact fun e member => List.mem_append_left _ (subset e member) + | primitive purpose input => + change d = C input at answer + subst d + intro e member + rcases List.mem_cons.mp member with equal | earlier + · exact List.mem_append_right _ (List.mem_singleton.mpr equal) + · exact List.mem_append_left _ (subset e earlier) + +/-- Low-level first-mention join. The current cache is the genuine recursively +updated whole cache; all its records have physical provenance before this ask. +An address decoder that never addresses seed keys freezes after the current +raw response's nonordinary physical calls. No trace split is an input. -/ +theorem firstPrefix_freeze {Root : Type} [DecidableEq Root] + (B : Nat) (C : PrimitiveOracle) (iv : Digest32) + (address : PublicCompressionCouplingMixed.Key B → List Root) (ref : Root) + (noSeed : ∀ input, ref ∉ address (.inl input)) + (seen : List Observation) (cache seeds physical : PublicLog) + (covered : Covered C cache seeds physical) + (cachePhysical : ∀ e ∈ cache, e ∈ physical) + (answers : ∀ o ∈ seen, o.answer = realAnswer C iv o.query) + (captured : List (RawEvent B)) + (found : firstPrefix address ref (mixedTrace B iv cache seen) = some captured) : + ∃ earlier current later currentCache event, + seen = earlier ++ current :: later ∧ + observationDraw B iv currentCache current = [event] ∧ + ref ∈ address event.1 ∧ + (∀ e ∈ currentCache, e ∈ physical ++ physicalTrace C iv earlier) ∧ + AuthenticLog C currentCache ∧ + (∀ e ∈ captureFrom captured seeds, + e ∈ physical ++ (physicalTrace C iv earlier ++ queryTrace C iv current.query)) ∧ + (∀ n d, (n,d) ∈ physical ++ (physicalTrace C iv earlier ++ queryTrace C iv current.query) → + tag n = 0 → (n,d) ∈ captureFrom captured seeds) := by + induction seen generalizing cache seeds physical captured with + | nil => simp [mixedTrace,firstPrefix] at found + | cons o rest ih => + have correct := answers o List.mem_cons_self + have updated := step_covered B C iv cache seeds physical covered o correct + have cacheUpdated := cache_step_subset C iv cache physical cachePhysical o correct + have restAnswers : ∀ x ∈ rest, x.answer = realAnswer C iv x.query := + fun x member => answers x (List.mem_cons_of_mem _ member) + rcases draws_cases B iv cache o with empty | ⟨event,single⟩ + · have nextFound : firstPrefix address ref (mixedTrace B iv (nextLog cache o) rest) = some captured := by + simpa only [mixedTrace,empty,List.nil_append] using found + have seedEqual : drawLog (observationDraw B iv cache o) ++ seeds = seeds := by + simp [empty,drawLog] + rw [seedEqual] at updated + obtain ⟨earlier,current,later,currentCache,event,split,draw,addressed,cacheSub,auth,sub,sat⟩ := + ih (nextLog cache o) seeds (physical ++ queryTrace C iv o.query) + updated cacheUpdated restAnswers captured nextFound + refine ⟨o :: earlier,current,later,currentCache,event,?_,draw,addressed,?_,auth,?_,?_⟩ + · simp only [split,List.cons_append] + · simpa only [physicalTrace,List.flatMap_cons,List.append_assoc] using cacheSub + · simpa only [physicalTrace,List.flatMap_cons,List.append_assoc] using sub + · simpa only [physicalTrace,List.flatMap_cons,List.append_assoc] using sat + · have first : firstPrefix address ref (event :: mixedTrace B iv (nextLog cache o) rest) = + some captured := by simpa only [mixedTrace,single,List.singleton_append] using found + by_cases addressed : ref ∈ address event.1 + · have prefixEmpty : captured = [] := by + simpa only [firstPrefix,addressed,↓reduceIte,Option.some.injEq] using first.symm + subst captured + have ordinaryEmpty : rawOrdinary event = [] := by + rcases event with ⟨key,d⟩ + cases key with + | inl input => exact False.elim (noSeed input addressed) + | inr raw => rfl + have seedEqual : drawLog (observationDraw B iv cache o) ++ seeds = seeds := by + simp [single,drawLog,ordinaryEmpty] + rw [seedEqual] at updated + refine ⟨[],o,rest,cache,event,rfl,single,addressed,?_,covered.authentic,?_,?_⟩ + · simpa only [physicalTrace,List.flatMap_nil,List.append_nil] using cachePhysical + · simpa only [captureFrom,List.foldl_nil,physicalTrace,List.flatMap_nil,List.nil_append] + using updated.seeds_physical + · simpa only [captureFrom,List.foldl_nil,physicalTrace,List.flatMap_nil,List.nil_append] + using updated.physical_seeds + · obtain ⟨tail,nextFound,equal⟩ := Option.map_eq_some_iff.mp + (by simpa only [firstPrefix,addressed,↓reduceIte] using first) + subst captured + have seedEqual : drawLog (observationDraw B iv cache o) ++ seeds = + rawOrdinary event ++ seeds := by simp [single,drawLog] + rw [seedEqual] at updated + obtain ⟨earlier,current,later,currentCache,hit,split,draw,addressed,cacheSub,auth,sub,sat⟩ := + ih (nextLog cache o) (rawOrdinary event ++ seeds) (physical ++ queryTrace C iv o.query) + updated cacheUpdated restAnswers tail nextFound + refine ⟨o :: earlier,current,later,currentCache,hit,?_,draw,addressed,?_,auth,?_,?_⟩ + · simp only [split,List.cons_append] + · simpa only [physicalTrace,List.flatMap_cons,List.append_assoc] using cacheSub + · simpa only [captureFrom,List.foldl_cons,physicalTrace,List.flatMap_cons,List.append_assoc] + using sub + · simpa only [captureFrom,List.foldl_cons,physicalTrace,List.flatMap_cons,List.append_assoc] + using sat + +/-- Position-sensitive boundary recovery retains the actual occurrence, even +when the same query has appeared earlier. -/ +theorem observations_boundary_at {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (earlier : List Observation) (current : Observation) + (later : List Observation) + (split : (runReal C iv program).view.observations = earlier ++ current :: later) : + ∃ next, AskBoundary C iv program (physicalTrace C iv earlier) current.query next := by + induction program generalizing earlier with + | done value => + have member : current ∈ (runReal C iv (.done value)).view.observations := by + rw [split] + exact List.mem_append_right _ List.mem_cons_self + cases member + | ask q next ih => + cases earlier with + | nil => + have equal : (⟨q,realAnswer C iv q⟩ : Observation) = current := + (List.cons.inj split).1 + cases equal + exact ⟨next,.here q next⟩ + | cons head rest => + have equal : (⟨q,realAnswer C iv q⟩ : Observation) = head := + (List.cons.inj split).1 + cases equal + obtain ⟨tail,reached⟩ := ih _ rest (List.cons.inj split).2 + exact ⟨tail,.step q next reached⟩ + +section Capture +variable {p : ParameterBounds.Profile} {B boundary : Nat} {iv : Digest32} +local notation "part" => PCSBCSChallengeOracle.EnteredPacket.partition + (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := B) (iv := iv) (boundary := boundary) + +theorem allocatedSeed_other (input : Node) : + ∃ other, allocatedKey (p := p) (B := B) (iv := iv) (boundary := boundary) (.inl input) = .inr other := by + have unrecognized : (part).recognize (.inl input) = none := by + cases found : (part).recognize (.inl input) with + | none => rfl + | some block => + have impossible := (part).encode_recognize _ block found + change Sum.inr _ = Sum.inl input at impossible + cases impossible + refine ⟨⟨.inl input,unrecognized⟩,?_⟩ + unfold allocatedKey + split + · rename_i block found + have impossible := found.symm.trans unrecognized + cases impossible + · rfl + +/-- Actual whole-program first capture has an exact physical freeze. The only +address precondition is the executable decoder's exclusion of nonpacket keys; +neither saturation nor inclusion nor a physical split is supplied. -/ +theorem source_firstMention_freeze {R : Type} (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (address : Keys → List PCSBCSSourceRootReferences.Reference) + (noOther : ∀ other, address (.inr other) = []) + (ref : PCSBCSSourceRootReferences.Reference) + (events : List (Sigma Answers)) + (mentioned : PCSBCSFirstRootDisclosure.firstMention address ref + (PCSBCSChallengeOracle.Atomic.program part + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)) + ((part).split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C))) = + some events) : + ∃ earlier current later cache event next, + (runReal C iv program).view.observations = earlier ++ current :: later ∧ + AskBoundary C iv program (physicalTrace C iv earlier) current.query next ∧ + observationDraw B iv cache current = [event] ∧ + ref ∈ address (allocatedKey event.1) ∧ + (∀ e ∈ cache, e ∈ physicalTrace C iv earlier) ∧ + AuthenticLog C cache ∧ + primitiveLog C iv program A counted = + (physicalTrace C iv earlier ++ queryTrace C iv current.query) ++ physicalTrace C iv later ∧ + (∀ e ∈ PCSBCSCapturedNativeReplyBridge.sourceLog address ref + (PCSBCSChallengeOracle.Atomic.program part + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)) + ((part).split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C))), + e ∈ physicalTrace C iv earlier ++ queryTrace C iv current.query) ∧ + (∀ n d, (n,d) ∈ physicalTrace C iv earlier ++ queryTrace C iv current.query → + tag n = 0 → (n,d) ∈ PCSBCSCapturedNativeReplyBridge.sourceLog address ref + (PCSBCSChallengeOracle.Atomic.program part + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)) + ((part).split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)))) := by + have realView : + Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted) = + (runReal C iv program).view := by + rw [PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C iv _ ⟨rfl,by simp⟩ _ _ limit _ + have atomicView := PCSBCSChallengeOracle.Atomic.eval_program part + ((part).split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C))) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted) + rw [RawOracleCoupling.Partition.join_split,realView] at atomicView + have prefixFound := publicPrefix_actual (p := p) (boundary := boundary) + C (WHIRRealSimulator.rawTable B C) program A limit counted address ref + dsimp only at prefixFound + rw [mentioned,atomicView] at prefixFound + obtain ⟨rawPrefix,rawFound,_⟩ := Option.map_eq_some_iff.mp prefixFound.symm + have publicFound : firstPrefix (fun raw => address (allocatedKey raw)) ref + (mixedTrace B iv [] (runReal C iv program).view.observations) = some rawPrefix := rawFound + have noSeed : ∀ input, ref ∉ address + (allocatedKey (p := p) (B := B) (iv := iv) (boundary := boundary) (.inl input)) := by + intro input + obtain ⟨other,equal⟩ := allocatedSeed_other (p := p) (B := B) (iv := iv) (boundary := boundary) input + rw [equal,noOther] + simp + obtain ⟨earlier,current,later,cache,event,split,draw,addressed,cacheSub,auth,sub,sat⟩ := + firstPrefix_freeze B C iv (fun raw => address (allocatedKey raw)) ref noSeed + (runReal C iv program).view.observations [] [] [] + ⟨by simp [AuthenticLog],by simp,by simp,by simp⟩ (by simp) + (fun o member => observation_answer C iv program o member) rawPrefix publicFound + obtain ⟨next,reached⟩ := observations_boundary_at C iv program earlier current later split + have logEqual := publicLog_actual (p := p) (boundary := boundary) + C (WHIRRealSimulator.rawTable B C) program A limit counted address ref + dsimp only at logEqual + rw [atomicView] at logEqual + have captureEqual : publicLog address ref (runReal C iv program).view = captureFrom rawPrefix [] := by + simp only [PCSBCSNativePublicCapture.publicLog,rawFound,Option.getD_some,captureFrom] + rw [captureEqual] at logEqual + refine ⟨earlier,current,later,cache,event,next,split,reached,draw,addressed,?_,auth,?_,?_,?_⟩ + · simpa only [List.nil_append] using cacheSub + · rw [physicalTrace_actual,split] + simp only [physicalTrace,List.flatMap_append,List.flatMap_cons,List.append_assoc] + · rw [logEqual] + simpa only [List.nil_append] using sub + · rw [logEqual] + simpa only [List.nil_append] using sat + +end Capture + +/-- Exactly the physical-prefix obligations of FrozenOpeningBad; root scanner +admission is a separate causal source theorem, not a field assumed here. -/ +structure PhysicalFreeze (trace oldLog : PublicLog) where + before : PublicLog + after : PublicLog + split : trace = before ++ after + captured : ∀ e ∈ oldLog, e ∈ before + saturated : ∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ oldLog + +section ActualAddress +variable {p : ParameterBounds.Profile} {B boundary : Nat} {iv : Digest32} + +noncomputable abbrev allocationProgram {R : Type} (program : Program R) (A : Nat) (limit : A ≤ B) + (counted : Counts A program) := + PCSBCSChallengeOracle.Atomic.program + (PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary)) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted) + +noncomputable abbrev actualTable (C : PrimitiveOracle) := + (PCSBCSChallengeOracle.EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary)).split + (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)) + +noncomputable abbrev actualSourceLog {R : Type} (C : PrimitiveOracle) (program : Program R) + (A : Nat) (limit : A ≤ B) (counted : Counts A program) (ref : PCSBCSSourceRootReferences.Reference) := + PCSBCSCapturedNativeReplyBridge.sourceLog + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) (iv := iv) (boundary := boundary)) ref + (allocationProgram (p := p) (boundary := boundary) program A limit counted) + (actualTable (p := p) (B := B) (iv := iv) (boundary := boundary) C) + +/-- Actual whole allocation execution has the same public view, including all +prequeries and repeats. This does not identify its private cache with a suffix. -/ +theorem allocationView_real {R : Type} (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) : + Sampling.eval (actualTable (p := p) (B := B) (iv := iv) (boundary := boundary) C) + (allocationProgram (p := p) (boundary := boundary) program A limit counted) = + (runReal C iv program).view := by + rw [PCSBCSChallengeOracle.Atomic.eval_program,RawOracleCoupling.Partition.join_split, + PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C iv _ ⟨rfl,by simp⟩ _ _ limit _ + +/-- Exact first-mentioned source capture from the complete actual public view. +The getter reads no verifier-only execution or assumed suffix cache. -/ +theorem actualSourceLog_public {R : Type} (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (ref : PCSBCSSourceRootReferences.Reference) : + actualSourceLog (p := p) (iv := iv) (boundary := boundary) C program A limit counted ref = + PCSBCSNativePublicCapture.publicLog + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) (iv := iv) (boundary := boundary)) + ref (runReal C iv program).view := by + have equality := publicLog_actual (p := p) (iv := iv) (boundary := boundary) + C (WHIRRealSimulator.rawTable B C) program A limit counted PCSBCSCapturedSourceTransport.address ref + dsimp only at equality + rw [allocationView_real (p := p) (boundary := boundary) C program A limit counted] at equality + exact equality + + +/-- Executable public byte-only address; no address-exclusion premise remains. -/ +theorem actual_firstMention_freeze {R : Type} (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (ref : PCSBCSSourceRootReferences.Reference) + (events : List (Sigma (PCSBCSSourceRootCapture.Answer + (p := p) (Q := B) (iv := iv) (boundary := boundary)))) + (mentioned : PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) (iv := iv) (boundary := boundary)) ref + (allocationProgram (p := p) (boundary := boundary) program A limit counted) + (actualTable (p := p) (B := B) (iv := iv) (boundary := boundary) C) = some events) : + Nonempty (PhysicalFreeze (primitiveLog C iv program A counted) + (actualSourceLog (p := p) (iv := iv) (boundary := boundary) C program A limit counted ref)) := by + obtain ⟨earlier,current,later,_,_,_,_,_,_,_,_,_,split,sub,sat⟩ := + source_firstMention_freeze (p := p) (boundary := boundary) C program A limit counted + PCSBCSCapturedSourceTransport.address (by intro other; rfl) ref events mentioned + exact ⟨⟨physicalTrace C iv earlier ++ queryTrace C iv current.query, + physicalTrace C iv later,split,sub,sat⟩⟩ +end ActualAddress + +section CountedWhole +variable (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + (a b : Nat) (attackerCounted : WHIRSourceChronology.Counts a attacker) + (budget : WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget registry.context Q input.packet ≤ b) + (WHIRSourceChronology.erase attacker)) + +include attackerCounted budget in +theorem whole_counted : Counts (a+b) (wholeProgram cap registry Q attacker) := + (WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalAfter.verifyAfter_counted cap registry Q attacker a b attackerCounted budget) + +/-- Whole-prefix freeze, with the actual counted attacker.bind allocation +program and the actual table. Arbitrary attacker asks are retained. -/ +theorem counted_whole_firstMention_freeze (p : ParameterBounds.Profile) + (B boundary : Nat) (limit : a+b ≤ B) + (C : PrimitiveOracle) (ref : PCSBCSSourceRootReferences.Reference) + (events : List (Sigma (PCSBCSSourceRootCapture.Answer + (p := p) (Q := B) (iv := registry.context.iv) (boundary := boundary)))) + (mentioned : PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) + (iv := registry.context.iv) (boundary := boundary)) ref + (allocationProgram (p := p) (boundary := boundary) (wholeProgram cap registry Q attacker) + (a+b) limit (whole_counted cap registry Q attacker a b attackerCounted budget)) + (actualTable (p := p) (B := B) (iv := registry.context.iv) (boundary := boundary) C) = + some events) : + Nonempty (PhysicalFreeze + (primitiveLog C registry.context.iv (wholeProgram cap registry Q attacker) (a+b) + (whole_counted cap registry Q attacker a b attackerCounted budget)) + (actualSourceLog (p := p) (iv := registry.context.iv) (boundary := boundary) C (wholeProgram cap registry Q attacker) + (a+b) limit (whole_counted cap registry Q attacker a b attackerCounted budget) ref)) := + actual_firstMention_freeze C _ _ _ _ ref events mentioned + +/-- All full zero-prefix plans, derived from actual whole success and actual +attacker/verifier source budgets, not assumed plan or suffix-capture facts. -/ +theorem counted_whole_success_evaluated (C : PrimitiveOracle) + (accepted : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = + some accepted) : + ∀ opening ∈ accepted.native.wire.openings, ∀ path ∈ opening.result.paths, + ∀ bytes ∈ path.opening.inputs (hashing (hash C)), bytes.length < 2^56 ∧ + ∀ event ∈ PublicMerkleLog.plan C bytes, + event ∈ primitiveLog C registry.context.iv (wholeProgram cap registry Q attacker) (a+b) + (whole_counted cap registry Q attacker a b attackerCounted budget) := + whole_success_evaluated cap registry Q attacker C (a+b) + (whole_counted cap registry Q attacker a b attackerCounted budget) accepted success +end CountedWhole + +#print axioms whole_success_observed +#print axioms whole_success_evaluated +#print axioms whole_success_geometry +#print axioms physicalTrace_actual +#print axioms firstPrefix_freeze +#print axioms source_firstMention_freeze +#print axioms actual_firstMention_freeze +#print axioms counted_whole_firstMention_freeze +#print axioms counted_whole_success_evaluated +#print axioms allocationView_real +#print axioms actualSourceLog_public + +end Whir.PCSBCSNativePhysicalFreeze diff --git a/verification/whir/Whir/PCSBCSNativePhysicalMerkleBad.lean b/verification/whir/Whir/PCSBCSNativePhysicalMerkleBad.lean new file mode 100644 index 000000000..c20a88ba1 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativePhysicalMerkleBad.lean @@ -0,0 +1,431 @@ +import Whir.PCSBCSNativeSourceFailure +import Whir.PCSBCSAtomicAllocationTrace +import Whir.PCSBCSConstructionReplayTrace +import Whir.WHIRRealSimulator +import Whir.PCSBCSActualMerkleBound + +/-! Historical pre-#607 native physical trace joins. The chosen real raw table +is a deterministic realization, not an independent random oracle. Every +retained opening plan is included in the complete source compression trace. +The global allocation-log collision is included in the very same causal alarm; +it must not be silently identified with a frozen extracted-row mismatch. +The first shape-address/scanner-admission join is deliberately not assumed. -/ +set_option autoImplicit false +set_option maxHeartbeats 1000000 +namespace Whir.PCSBCSNativePhysicalMerkleBad +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open RawOracleCoupling PCSBCSChallengeOracle PCSBCSSourceRootCapture +open PublicMerkleLog PublicCompressionProgram +open MerkleTransport MerkleTransport.Commitments +open MerkleBinding + +private theorem execute_mixed_map {B n : Nat} {R S : Type} + (oracle : PublicCompressionCouplingMixed.Key B → Digest32) (f : R → S) + (program : PublicCompressionCouplingMixed.Computation B R n) : + (Sampling.execute oracle (PublicCompressionCouplingMixed.Computation.map f program)).2 = + (Sampling.execute oracle program).2 := by + induction program with + | ret => rfl + | draw key next ih => simp only [PublicCompressionCouplingMixed.Computation.map,Sampling.execute,ih] + +/-- A fallback seed draw comes from an actual direct primitive observation. +This holds for arbitrary mixed raw answers and arbitrary initial public logs. -/ +theorem mixed_seed_origin {R : Type} (B : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (iv : Digest32) (log : PublicLog) + (program : Program R) (remaining : Nat) (limit : remaining ≤ B) + (counted : Counts remaining program) (n : Node) (d : Digest32) + (recorded : (⟨.inl n,d⟩ : Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) ∈ + (Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv log program remaining limit counted)).2) : + ∃ purpose, (⟨.primitive purpose n,d⟩ : Observation) ∈ + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv log program remaining limit counted)).observations := by + induction program generalizing log remaining with + | done value => simp [PublicCompressionCouplingMixed.compile,Sampling.execute] at recorded + | ask query next ih => + cases query with + | primitive purpose input => + simp only [PublicCompressionCouplingMixed.compile,Sampling.execute_pad,Sampling.execute_bind, + execute_mixed_map,List.mem_append] at recorded + rcases recorded with first | later + · unfold PublicCompressionCouplingMixed.primitiveCalls at first + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => simp [hit,Sampling.execute] at first + | none => + cases key : DuplexPublicSimulator.privateKey B log input with + | some raw => simp [hit,key,Sampling.execute] at first + | none => + simp only [hit,key,Sampling.execute,List.mem_cons,List.not_mem_nil,or_false] at first + cases first + refine ⟨purpose,?_⟩ + simp [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.primitiveCalls,hit,key, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe, + PublicCompressionCouplingMixed.oracle,Sampling.eval] + · obtain ⟨found,member⟩ := ih _ _ _ _ (counted.2 _) later + refine ⟨found,?_⟩ + simp only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe] + exact List.mem_cons_of_mem _ member + | construction coordinate valid => + simp only [PublicCompressionCouplingMixed.compile,Sampling.execute_pad,Sampling.execute, + execute_mixed_map,List.mem_cons] at recorded + rcases recorded with impossible | later + · cases impossible + · obtain ⟨purpose,member⟩ := ih _ log _ _ (counted.2 _) later + refine ⟨purpose,?_⟩ + simp only [PublicCompressionCouplingMixed.compile,Sampling.eval_pad,Sampling.eval, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe] + exact List.mem_cons_of_mem _ member + +section Allocation +variable {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) + +private theorem allocation_ordinary (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (raw : PublicCompressionCouplingMixed.Key B) (record : Node × Digest32) + (member : record ∈ ordinaryRecord + (PCSBCSAtomicAllocationTrace.allocation part + ((part).split (PublicCompressionCouplingMixed.oracle seed ro)) raw)) : + ∃ n, raw = .inl n ∧ record = (n,seed n) := by + cases raw with + | inl n => + unfold PCSBCSAtomicAllocationTrace.allocation at member + split at member + · rename_i block found + have impossible := (part).encode_recognize (.inl n) block found + cases impossible + · simp only [ordinaryRecord,Partition.split,PublicCompressionCouplingMixed.oracle,List.mem_singleton] at member + exact ⟨n,rfl,member⟩ + | inr key => + unfold PCSBCSAtomicAllocationTrace.allocation at member + split at member <;> simp [ordinaryRecord] at member + +private theorem execute_answers {Key R : Type} {n : Nat} (oracle : Key → Digest32) + (program : Sampling Key (fun _ => Digest32) R n) + (event : Sigma (fun _ : Key => Digest32)) + (member : event ∈ (Sampling.execute oracle program).2) : event.2 = oracle event.1 := by + induction program with + | ret => simp [Sampling.execute] at member + | draw key next ih => + rcases List.mem_cons.mp member with equal | later + · cases equal; rfl + · exact ih (oracle key) later + +/-- Ordinary grouped records have literal seed-draw provenance; atomic packet +allocation cannot fabricate a primitive hash record. -/ +theorem atomic_ordinary_origin {R : Type} {n : Nat} + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (program : Sampling (PublicCompressionCouplingMixed.Key B) (fun _ => Digest32) R n) + (record : Node × Digest32) + (member : record ∈ ordinaryPrefix (Sampling.execute + ((part).split (PublicCompressionCouplingMixed.oracle seed ro)) (Atomic.program part program)).2) : + (⟨.inl record.1,record.2⟩ : Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) ∈ + (Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) program).2 := by + rw [PCSBCSAtomicAllocationTrace.execute_program,Partition.join_split] at member + obtain ⟨event,present,ordinary⟩ := + (PCSBCSNativeCapturedLogs.ordinaryPrefix_membership _ record).mp member + obtain ⟨raw,rawPresent,same⟩ := List.mem_map.mp present + subst event + obtain ⟨input,equal,recordEqual⟩ := allocation_ordinary seed ro raw.1 record ordinary + have authentic : raw.2 = PublicCompressionCouplingMixed.oracle seed ro raw.1 := + execute_answers _ program raw rawPresent + have same : (⟨.inl record.1,record.2⟩ : Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) = raw := by + rcases raw with ⟨key,answer⟩ + dsimp only at equal authentic + subst key + subst record + change answer = seed input at authentic + cases authentic + rfl + exact same ▸ rawPresent +end Allocation + +/-- Whole attacker-plus-verifier programs are supported here, not just the +native suffix. The chosen raw table and every full-path call belong to the +same primitive C. No allocation/physical-trace identity is supplied. -/ +theorem mixed_atomic_ordinary_subset {p : ParameterBounds.Profile} {B boundary : Nat} + {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) : + let part := EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) + ∀ record ∈ ordinaryPrefix (Sampling.execute + (part.split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C))) + (Atomic.program part (PublicCompressionCouplingMixed.compile B iv [] program A limit counted))).2, + record ∈ primitiveLog C iv program A counted := by + dsimp only + intro record member + have raw := atomic_ordinary_origin C (WHIRRealSimulator.rawTable B C) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted) record member + obtain ⟨purpose,observed⟩ := mixed_seed_origin B C (WHIRRealSimulator.rawTable B C) + iv [] program A limit counted record.1 record.2 raw + have realView : + Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted) = + (runReal C iv program).view := by + rw [PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C iv _ ⟨rfl,by simp⟩ _ _ limit _ + rw [realView] at observed + have included := PCSBCSConstructionReplayTrace.observation_trace_membership C iv + program A counted _ observed + have answer := PCSBCSConstructionReplayTrace.observation_answer C iv program _ observed + change record.2 = C record.1 at answer + apply included record + change record ∈ [(record.1,C record.1)] + exact List.mem_singleton.mpr (Prod.ext rfl answer) + +/-- One shared monitor covers global ordinary-allocation collisions, including +collisions unrelated to any returned row. This is pointwise, not a probability +certificate or a converse to `extraction_bad_opening_bad`. -/ +theorem mixed_atomic_collision_alarm {p : ParameterBounds.Profile} {B boundary : Nat} + {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (roots : PublicMerkleProbability.RootPolicy) : + let part := EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) + OutputCollision (ordinaryPrefix (Sampling.execute + (part.split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C))) + (Atomic.program part (PublicCompressionCouplingMixed.compile B iv [] program A limit counted))).2) → + PublicMerkleProbability.traceAlarm roots [] (primitiveLog C iv program A counted) = true := by + dsimp only + intro bad + by_contra loud + have quiet := Bool.eq_false_iff.mpr loud + have collision := PublicMerkleProbability.collision_mono + (mixed_atomic_ordinary_subset (p := p) (boundary := boundary) C iv program A limit counted) bad + have clean := PublicMerkleProbability.traceAlarm_clean C roots [] _ + (by intro n d h; cases h) (primitiveLog_authentic C iv program A counted) + (by rintro ⟨a,b,d,h,_⟩; cases h) quiet + apply clean + apply PublicMerkleProbability.collision_mono _ collision + exact fun _ member => List.mem_append_left _ (List.mem_reverse.mpr member) + + +/-- Literal first-shape-address captures are physically observed records, even +for an enclosing attacker-plus-verifier program. This is not yet saturation of +the freeze boundary or scanner root admission. -/ +theorem sourceLog_physical_subset {p : ParameterBounds.Profile} {B boundary : Nat} + {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (address : PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) → + List PCSBCSSourceRootReferences.Reference) (ref : PCSBCSSourceRootReferences.Reference) : + let part := EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) + ∀ record ∈ PCSBCSCapturedNativeReplyBridge.sourceLog address ref + (Atomic.program part (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)) + (part.split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C))), + record ∈ primitiveLog C iv program A counted := by + dsimp only + intro record member + apply mixed_atomic_ordinary_subset (p := p) (boundary := boundary) C iv program A limit counted + exact PCSBCSNativeCapturedLogs.sourceLog_subset address ref _ _ record member + +/-- Excluding the one complete-trace causal alarm makes EVERY actual frozen +shape-address log clean. No per-reference union bound or row mismatch is used. -/ +theorem sourceLog_clean_of_alarm {p : ParameterBounds.Profile} {B boundary : Nat} + {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (address : PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) → + List PCSBCSSourceRootReferences.Reference) (ref : PCSBCSSourceRootReferences.Reference) + (roots : PublicMerkleProbability.RootPolicy) + (quiet : PublicMerkleProbability.traceAlarm roots [] (primitiveLog C iv program A counted) = false) : + let part := EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) + ¬ OutputCollision (PCSBCSCapturedNativeReplyBridge.sourceLog address ref + (Atomic.program part (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)) + (part.split (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)))) := by + dsimp only + intro bad + have global := PCSBCSNativeCapturedLogs.sourceLog_collision address ref _ _ bad + have alarm := mixed_atomic_collision_alarm (p := p) (boundary := boundary) + C iv program A limit counted roots global + rw [quiet] at alarm + cases alarm + +/-- A retained actual real opening's full ordinary plans are in the actual +complete program, even when that program has an adversarial prefix. -/ +theorem observed_complete_evaluated {p : ParameterBounds.Profile} {lanes : Nat} + {proofs : Array PrunedMerklePaths} {R : Type} + (C : PrimitiveOracle) (iv : Digest32) (program : Program R) + (A : Nat) (counted : Counts A program) (opening : WHIRPhysicalVerifier.QueryOpening p) + (observed : WHIRPhysicalOpeningRuns.ObservedOpening lanes proofs + (runReal C iv program).view.observations opening) : + ∀ path ∈ opening.result.paths, ∀ bytes ∈ path.opening.inputs (hashing (hash C)), + bytes.length < 2^56 ∧ ∀ event ∈ PublicMerkleLog.plan C bytes, + event ∈ primitiveLog C iv program A counted := by + have answers := fun o h => PCSBCSConstructionReplayTrace.observation_answer C iv program o h + intro path member bytes input + obtain ⟨bound,evaluated⟩ := WHIRPhysicalSoundness.observed_evaluated + observed C iv answers path member bytes input + refine ⟨bound,?_⟩ + intro event present + have actual := evaluated event present + have included := PCSBCSConstructionReplayTrace.observation_trace_membership C iv + program A counted _ actual + have answer := PCSBCSConstructionReplayTrace.observation_answer C iv program _ actual + change event.2 = C event.1 at answer + apply included event + change event ∈ [(event.1,C event.1)] + exact List.mem_singleton.mpr (Prod.ext rfl answer) + +/-- Fixed-height raw paths hash the FULL zero-prefixed leaf image, before any +source occupied-lane projection. The actual decoder and geometry are retained. -/ +theorem observed_complete_geometry {p : ParameterBounds.Profile} {lanes : Nat} + {proofs : Array PrunedMerklePaths} {R : Type} + (C : PrimitiveOracle) (iv : Digest32) (program : Program R) + (opening : WHIRPhysicalVerifier.QueryOpening p) + (observed : WHIRPhysicalOpeningRuns.ObservedOpening lanes proofs + (runReal C iv program).view.observations opening) : + ∀ path ∈ opening.result.paths, ∃ row : List K, + row.length = (if opening.level.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p opening.level.val) ∧ + path.leafData = leafImage 0 (WHIRPhysicalVerifier.leafWords p opening.level.val) row ∧ + path.leafData.length = WHIRPhysicalVerifier.leafWords p opening.level.val ∧ + path.path.length = (ParameterBounds.length (ParameterBounds.config p) opening.level.val).log2 ∧ + path.root (hash C) = opening.root := by + have answers := fun o h => PCSBCSConstructionReplayTrace.observation_answer C iv program o h + obtain ⟨proof,_,accepted,_⟩ := observed.real C iv answers + have opened := (WHIRPhysicalVerifier.openRows_real_accepted C iv proof opening.root + (ParameterBounds.length (ParameterBounds.config p) opening.level.val) + (WHIRPhysicalVerifier.queryIndices p opening.level opening.sample) + (if opening.level.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p opening.level.val) + (WHIRPhysicalVerifier.leafWords p opening.level.val) (opening.level.val == 0) + opening.result accepted).1 + have refined := open_refines _ _ _ _ _ _ _ _ opened + intro path member + obtain ⟨q,_,row,_,width,_,image,full,height,root⟩ := forall₂_mem_right refined member + exact ⟨row,width,image,full,height,root⟩ + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) + +abbrev completeProgram := WHIRSourceChronology.compile + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs) + +/-- All source, caller and verifier calls, charged at their actual full-path +source budget. The packet ancestry cap Q is not this compression budget. -/ +theorem actualCounts : Counts (WHIRPhysicalVerifier.sourceBudget ctx Q packet) + (completeProgram cap model ctx stack Q packet saved proofs) := + (WHIRSourceChronology.compile_counted _ _).mpr + (AnchoredPhysicalDriver.verifySource_counted cap .fresh model ctx stack Q packet saved proofs) + +def completeTrace (C : PrimitiveOracle) : PublicLog := + primitiveLog C ctx.iv (completeProgram cap model ctx stack Q packet saved proofs) + (WHIRPhysicalVerifier.sourceBudget ctx Q packet) + (actualCounts cap model ctx stack Q packet saved proofs) + +theorem completeTrace_authentic (C : PrimitiveOracle) : + AuthenticLog C (completeTrace cap model ctx stack Q packet saved proofs C) := + primitiveLog_authentic C _ _ _ _ + +variable (B : Nat) (limit : WHIRPhysicalVerifier.sourceBudget ctx Q packet ≤ B) + (C : PrimitiveOracle) + +/-- Chosen real table realization for the SAME actual complete source. -/ +theorem mixedView_real : + AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit C (WHIRRealSimulator.rawTable B C) = + (runReal C ctx.iv (completeProgram cap model ctx stack Q packet saved proofs)).view := by + unfold AnchoredMixedIdealSourceAcceptance.mixedView + rw [PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C ctx.iv _ ⟨rfl,by simp⟩ _ _ limit _ + +/-- Every actual allocation ordinary record belongs to the COMPLETE primitive +trace, including hidden construction calls and verifier compression calls. -/ +theorem wholeLog_subset : + ∀ record ∈ PCSBCSNativeCapturedLogs.wholeLog cap model ctx stack Q packet saved proofs B limit C + (WHIRRealSimulator.rawTable B C), + record ∈ completeTrace cap model ctx stack Q packet saved proofs C := by + intro record member + unfold PCSBCSNativeCapturedLogs.wholeLog PCSBCSCapturedIdealNativeAcceptance.allocationProgram + PCSBCSCapturedIdealNativeAcceptance.table at member + exact mixed_atomic_ordinary_subset (p := packet.val.profile) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length) C ctx.iv + (completeProgram cap model ctx stack Q packet saved proofs) _ limit + (actualCounts cap model ctx stack Q packet saved proofs) record member + +theorem wholeLog_collision + (bad : OutputCollision (PCSBCSNativeCapturedLogs.wholeLog cap model ctx stack Q packet saved proofs + B limit C (WHIRRealSimulator.rawTable B C))) : + OutputCollision (completeTrace cap model ctx stack Q packet saved proofs C) := + PublicMerkleProbability.collision_mono + (wholeLog_subset cap model ctx stack Q packet saved proofs B limit C) bad + +/-- The global clean case uses the SAME causal alarm as frozen openings, with no +extra union term. This does not assert a collision causes a row mismatch. -/ +theorem wholeLog_clean_of_alarm (roots : PublicMerkleProbability.RootPolicy) + (quiet : PublicMerkleProbability.traceAlarm roots [] + (completeTrace cap model ctx stack Q packet saved proofs C) = false) : + ¬ OutputCollision (PCSBCSNativeCapturedLogs.wholeLog cap model ctx stack Q packet saved proofs + B limit C (WHIRRealSimulator.rawTable B C)) := by + intro bad + have collision := wholeLog_collision cap model ctx stack Q packet saved proofs B limit C bad + have clean := PublicMerkleProbability.traceAlarm_clean C roots [] + (completeTrace cap model ctx stack Q packet saved proofs C) + (by intro n d h; cases h) + (completeTrace_authentic cap model ctx stack Q packet saved proofs C) + (by rintro ⟨a,b,d,h,_⟩; cases h) quiet + apply clean + apply PublicMerkleProbability.collision_mono _ collision + intro event member + exact List.mem_append_left _ (List.mem_reverse.mpr member) + +/-- Genuine retained opener subruns from the actual native success. -/ +theorem real_success_observed (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (runReal C ctx.iv (completeProgram cap model ctx stack Q packet saved proofs)).view.result.value = some a) : + ∀ opening ∈ a.wire.openings, + WHIRPhysicalOpeningRuns.ObservedOpening saved.shape.lanes proofs + (runReal C ctx.iv (completeProgram cap model ctx stack Q packet saved proofs)).view.observations opening := by + have run := WHIRPhysicalCaller.real_source_runs C ctx.iv + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs) + rw [WHIRSourceChronology.real_source_trace] at run + rw [success] at run + obtain ⟨_,_,_,_,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + exact observed + +/-- Actual success supplies ALL accepted opening hash plans and their strict +ordinary-tag bounds. Neither observed-plan nor trace-identity premises occur. -/ +theorem real_success_evaluated (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (runReal C ctx.iv (completeProgram cap model ctx stack Q packet saved proofs)).view.result.value = some a) : + ∀ opening ∈ a.wire.openings, ∀ path ∈ opening.result.paths, + ∀ bytes ∈ path.opening.inputs (hashing (hash C)), + bytes.length < 2^56 ∧ ∀ event ∈ PublicMerkleLog.plan C bytes, + event ∈ completeTrace cap model ctx stack Q packet saved proofs C := by + have observed := real_success_observed cap model ctx stack Q packet saved proofs C a success + intro opening member + exact observed_complete_evaluated C ctx.iv + (completeProgram cap model ctx stack Q packet saved proofs) _ + (actualCounts cap model ctx stack Q packet saved proofs) opening (observed opening member) + +theorem real_success_geometry (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (runReal C ctx.iv (completeProgram cap model ctx stack Q packet saved proofs)).view.result.value = some a) : + ∀ opening ∈ a.wire.openings, ∀ path ∈ opening.result.paths, ∃ row : List K, + row.length = (if opening.level.val = 0 then saved.shape.lanes + else WHIRPhysicalVerifier.leafWords packet.val.profile opening.level.val) ∧ + path.leafData = leafImage 0 (WHIRPhysicalVerifier.leafWords packet.val.profile opening.level.val) row ∧ + path.leafData.length = WHIRPhysicalVerifier.leafWords packet.val.profile opening.level.val ∧ + path.path.length = (ParameterBounds.length (ParameterBounds.config packet.val.profile) opening.level.val).log2 ∧ + path.root (hash C) = opening.root := by + intro opening member + exact observed_complete_geometry C ctx.iv + (completeProgram cap model ctx stack Q packet saved proofs) opening + (real_success_observed cap model ctx stack Q packet saved proofs C a success opening member) + +end Driver + +#print axioms mixed_seed_origin +#print axioms atomic_ordinary_origin +#print axioms mixed_atomic_ordinary_subset +#print axioms mixed_atomic_collision_alarm +#print axioms observed_complete_evaluated +#print axioms observed_complete_geometry +#print axioms sourceLog_physical_subset +#print axioms sourceLog_clean_of_alarm +#print axioms actualCounts +#print axioms mixedView_real +#print axioms wholeLog_subset +#print axioms wholeLog_collision +#print axioms wholeLog_clean_of_alarm +#print axioms real_success_observed +#print axioms real_success_geometry +#print axioms real_success_evaluated +end Whir.PCSBCSNativePhysicalMerkleBad diff --git a/verification/whir/Whir/PCSBCSNativePublicCapture.lean b/verification/whir/Whir/PCSBCSNativePublicCapture.lean new file mode 100644 index 000000000..75896a8e8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativePublicCapture.lean @@ -0,0 +1,622 @@ +import Whir.PCSBCSNativeSourceFailure +import Whir.PCSBCSNativeSourceTables +import Whir.PCSBCSAtomicAllocationTrace +import Whir.PCSBCSMerkleTableAuthenticity + +/-! Public reconstruction for the historical native source. Root admission reads +only public packet-entry bytes, including earlier fake-entry prequeries. Public +observations retain repeated queries; `mixedTrace` reconstructs the compiler's +actual raw draws with its first-answer seed-cache discipline. Original-caller +decoding still requires genuine caller-output observations. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSNativePublicCapture +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open RawOracleCoupling PCSBCSChallengeOracle PCSStateRestoration.Latent +open PublicMerkleLog PCSBCSSourceRootReferences PCSBCSCapturedNativeReplyBridge + +/-- Decode the actual mixed draw belonging to an observation. Cache hits make +no draw. The bound test is just the actual source construction-path budget. -/ +def observationDraw (B : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (o : Observation) : + List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) := + match o.query with + | .primitive _ input => + match DuplexPublicSimulator.lookup log input with + | some _ => [] + | none => + match DuplexPublicSimulator.privateKey B log input with + | some key => [⟨.inr key,o.answer⟩] + | none => [⟨.inl input,o.answer⟩] + | .construction coordinate _ => + if bound : pathCost coordinate ≤ B then + [⟨.inr (constructionKey B iv coordinate bound),o.answer⟩] + else [] + +def nextLog (log : DuplexPublicSimulator.PublicLog) (o : Observation) : + DuplexPublicSimulator.PublicLog := + match o.query with + | .primitive _ input => DuplexPublicSimulator.observe log input o.answer + | .construction _ _ => log + +/-- Chronological raw draws, not the duplicate-retaining observation list. -/ +def mixedTrace (B : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) : List Observation → + List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) + | [] => [] + | o :: rest => observationDraw B iv log o ++ mixedTrace B iv (nextLog log o) rest + +private theorem execute_map {B n : Nat} {R S : Type} + (table : PublicCompressionCouplingMixed.Key B → Digest32) (f : R → S) + (program : PublicCompressionCouplingMixed.Computation B R n) : + Sampling.execute table (PublicCompressionCouplingMixed.Computation.map f program) = + (f (Sampling.execute table program).1,(Sampling.execute table program).2) := by + induction program with + | ret => rfl + | draw key next ih => simp only [PublicCompressionCouplingMixed.Computation.map,Sampling.execute,ih] + +private theorem primitive_trace (B : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (purpose : Purpose) (input : Node) : + let program := PublicCompressionCouplingMixed.primitiveCalls B log input + let table := PublicCompressionCouplingMixed.oracle seed ro + (Sampling.execute table program).2 = observationDraw B iv log + ⟨.primitive purpose input,Sampling.eval table program |>.2⟩ ∧ + (Sampling.eval table program).1 = nextLog log + ⟨.primitive purpose input,Sampling.eval table program |>.2⟩ := by + cases hit : DuplexPublicSimulator.lookup log input with + | some answer => simp [PublicCompressionCouplingMixed.primitiveCalls,hit,Sampling.execute, + Sampling.eval,observationDraw,nextLog] + | none => + cases key : DuplexPublicSimulator.privateKey B log input <;> + simp [PublicCompressionCouplingMixed.primitiveCalls,hit,key,Sampling.execute, + Sampling.eval,observationDraw,nextLog] + +/-- The whole public view determines every raw draw, without a seed or RO +argument to the decoder. This is valid for arbitrary prequeries and repeats. -/ +theorem mixedTrace_actual {R : Type} (B : Nat) (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) : + (Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv log program remaining limit counted)).2 = + mixedTrace B iv log (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv log program remaining limit counted)).observations := by + induction program generalizing log remaining with + | done result => rfl + | ask query next ih => + cases query with + | primitive purpose input => + simp only [PublicCompressionCouplingMixed.compile,Sampling.execute_pad,Sampling.execute_bind, + execute_map,Sampling.eval_pad,Sampling.eval_bind, + PublicCompressionCouplingMixed.Computation.eval_map,DuplexRawProgram.observe,mixedTrace] + obtain ⟨trace,updated⟩ := primitive_trace B seed ro iv log purpose input + rw [trace,updated] + congr 1 + exact ih _ _ _ _ _ + | construction coordinate valid => + have bound : pathCost coordinate ≤ B := counted.1.trans limit + simp only [PublicCompressionCouplingMixed.compile,Sampling.execute_pad,Sampling.execute, + execute_map,Sampling.eval_pad,PublicCompressionCouplingMixed.Computation.eval_map, + Sampling.eval,DuplexRawProgram.observe,mixedTrace,observationDraw,nextLog, + dite_eq_left bound,List.singleton_append] + congr 1 + exact ih _ _ _ _ _ + +section First +universe u v w z +variable {Key : Type u} {Answer : Key → Type v} {Root : Type w} {R : Type z} + [DecidableEq Root] + +/-- First address mention in the chronological trace, excluding its answer. -/ +def firstPrefix (address : Key → List Root) (root : Root) : + List (Sigma Answer) → Option (List (Sigma Answer)) + | [] => none + | event :: rest => if root ∈ address event.1 then some [] + else (firstPrefix address root rest).map (event :: ·) + +theorem firstPrefix_execute (address : Key → List Root) (root : Root) + {n : Nat} (program : Sampling Key Answer R n) (table : Table Key Answer) : + PCSBCSFirstRootDisclosure.firstMention address root program table = + firstPrefix address root (Sampling.execute table program).2 := by + induction program with + | ret => rfl + | draw key next ih => simp only [PCSBCSFirstRootDisclosure.firstMention, + Sampling.execute,firstPrefix,ih] + +theorem firstPrefix_subset (address : Key → List Root) (root : Root) + (events before : List (Sigma Answer)) (found : firstPrefix address root events = some before) : + ∀ event ∈ before, event ∈ events := by + induction events generalizing before with + | nil => simp [firstPrefix] at found + | cons event rest ih => + simp only [firstPrefix] at found + split at found + · cases Option.some.inj found + simp + · obtain ⟨earlier,hprefix,equal⟩ := Option.map_eq_some_iff.mp found + subst before + intro item member + rcases List.mem_cons.mp member with equal | present + · exact List.mem_cons.mpr (Or.inl equal) + · exact List.mem_cons_of_mem _ (ih earlier hprefix item present) +end First + +section Allocation +variable {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer (p := p) (Q := B) (iv := iv) (boundary := boundary) + +/-- Only the key of a raw allocation is needed to locate its address mention. +A recognized packet's independently sampled full answer is never inspected. -/ +noncomputable def allocatedKey (raw : PublicCompressionCouplingMixed.Key B) : Keys := + match found : (part).recognize raw with + | some block => .inl block.1 + | none => .inr ⟨raw,found⟩ + +/-- Public chronological capture, with a public key-address decoder. This keeps +exact first mention, including a raw prequery before a later announcement. -/ +noncomputable def publicPrefix {R : Type} (address : Keys → List Reference) + (ref : Reference) (view : View R) : Option + (List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) := + firstPrefix (fun raw => address (allocatedKey raw)) ref (mixedTrace B iv [] view.observations) + +private theorem allocation_key (table : Table Keys Answers) + (raw : PublicCompressionCouplingMixed.Key B) : + (PCSBCSAtomicAllocationTrace.allocation (part) table raw).1 = allocatedKey raw := by + unfold PCSBCSAtomicAllocationTrace.allocation allocatedKey + split <;> split <;> simp_all + +private theorem firstPrefix_map (address : Keys → List Reference) (ref : Reference) + (table : Table Keys Answers) + (events : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) : + firstPrefix address ref (events.map (fun e => + PCSBCSAtomicAllocationTrace.allocation (part) table e.1)) = + (firstPrefix (fun raw => address (allocatedKey raw)) ref events).map + (List.map (fun e => PCSBCSAtomicAllocationTrace.allocation (part) table e.1)) := by + induction events with + | nil => rfl + | cons event rest ih => + simp only [List.map_cons,firstPrefix,allocation_key] + split + · rfl + · rw [ih] + simp only [Option.map_map,Function.comp_def,List.map_cons] + +/-- Exact prefix provenance for the actual atomic source. The full packet +trace need not equal the public trace: it has independent full-vector answers. +The capture *prefix* is exactly the public raw prefix's allocation map. -/ +theorem publicPrefix_actual {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (address : Keys → List Reference) (ref : Reference) : + let table := (part).split (PublicCompressionCouplingMixed.oracle seed ro) + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + PCSBCSFirstRootDisclosure.firstMention address ref source table = + (publicPrefix address ref (Sampling.eval table source)).map + (List.map (fun e => PCSBCSAtomicAllocationTrace.allocation (part) table e.1)) := by + dsimp only + rw [firstPrefix_execute,PCSBCSAtomicAllocationTrace.execute_program,Partition.join_split, + firstPrefix_map,mixedTrace_actual] + unfold publicPrefix + rw [Atomic.eval_program,Partition.join_split] + + +private theorem seed_unrecognized (input : Node) : + (part).recognize (.inl input) = none := by + cases found : (part).recognize (.inl input) with + | none => rfl + | some block => + have equal := (part).encode_recognize _ block found + change Sum.inr _ = Sum.inl input at equal + cases equal + +def rawOrdinary (event : Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) : + PublicLog := + match event.1 with + | .inl input => [(input,event.2)] + | .inr _ => [] + +noncomputable def publicLog {R : Type} (address : Keys → List Reference) + (ref : Reference) (view : View R) : PublicLog := + ((publicPrefix address ref view).getD []).foldl (fun log event => rawOrdinary event ++ log) [] + +private theorem allocation_ordinary (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (raw : PublicCompressionCouplingMixed.Key B) : + PCSBCSSourceRootCapture.ordinaryRecord + (PCSBCSAtomicAllocationTrace.allocation (part) + ((part).split (PublicCompressionCouplingMixed.oracle seed ro)) raw) = + rawOrdinary ⟨raw,PublicCompressionCouplingMixed.oracle seed ro raw⟩ := by + cases raw with + | inl input => + unfold PCSBCSAtomicAllocationTrace.allocation + split + · rename_i block found + have impossible := found.symm.trans (seed_unrecognized (p := p) (iv := iv) + (boundary := boundary) input) + cases impossible + · rfl + | inr key => + unfold PCSBCSAtomicAllocationTrace.allocation + split <;> rfl + +theorem execute_answers {Key : Type} {R : Type} {n : Nat} + (table : Key → Digest32) (program : Sampling Key (fun _ => Digest32) R n) : + ∀ event ∈ (Sampling.execute table program).2, event.2 = table event.1 := by + induction program with + | ret => simp [Sampling.execute] + | draw key next ih => + intro event member + rcases List.mem_cons.mp member with equal | present + · cases equal + rfl + · exact ih _ event present + +theorem ordinary_map (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (events : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) + (correct : ∀ event ∈ events, event.2 = PublicCompressionCouplingMixed.oracle seed ro event.1) + (prior : PublicLog) : + (events.map (fun e => PCSBCSAtomicAllocationTrace.allocation (part) + ((part).split (PublicCompressionCouplingMixed.oracle seed ro)) e.1)).foldl + (fun log event => PCSBCSSourceRootCapture.ordinaryRecord event ++ log) prior = + events.foldl (fun log event => rawOrdinary event ++ log) prior := by + induction events generalizing prior with + | nil => rfl + | cons event rest ih => + simp only [List.map_cons,List.foldl_cons,allocation_ordinary] + have equal : (⟨event.1,PublicCompressionCouplingMixed.oracle seed ro event.1⟩ : + Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) = event := + Sigma.ext rfl (by simpa using (correct event List.mem_cons_self).symm) + rw [equal] + exact ih (fun e member => correct e (List.mem_cons_of_mem _ member)) _ + +/-- Exact ordinary-log equality, not a conflation of deduplicated seed draws +with duplicate-retaining public observations. The public decoder has no table, +seed, full-packet completion, or private hash-oracle input. -/ +theorem publicLog_actual {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (address : Keys → List Reference) (ref : Reference) : + let table := (part).split (PublicCompressionCouplingMixed.oracle seed ro) + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + sourceLog address ref source table = publicLog address ref (Sampling.eval table source) := by + dsimp only + unfold sourceLog publicLog + rw [publicPrefix_actual] + cases found : publicPrefix address ref + (Sampling.eval ((part).split (PublicCompressionCouplingMixed.oracle seed ro)) + (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted))) with + | none => rfl + | some events => + simp only [Option.map_some,Option.getD_some,PCSBCSSourceRootCapture.ordinaryPrefix] + apply ordinary_map seed ro events _ [] + intro event member + have present := firstPrefix_subset _ ref _ events found event member + have trace := mixedTrace_actual B seed ro iv [] program remaining limit counted + rw [Atomic.eval_program,Partition.join_split] at present + rw [← trace] at present + exact execute_answers _ _ event present + +/-- All typed tables are covered, not just tables in a deterministic compression +family. The address decoder reads only public packet bytes. -/ +theorem publicLog_every_table {R : Type} (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (table : Table Keys Answers) (address : Keys → List Reference) (ref : Reference) : + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + sourceLog address ref source table = publicLog address ref (Sampling.eval table source) := by + obtain ⟨seed,ro,equal⟩ := PCSBCSNativeSourceTables.every_table table + rw [← equal] + exact publicLog_actual seed ro program remaining limit counted address ref + +/-- Public reconstruction uses full-width zero-prefix leaves and only then +strips the occupied suffix, via the existing `freeze` constructor. -/ +noncomputable def publicRoot {R : Type} (address : Keys → List Reference) + (ref : Reference) (view : View R) : CausalGame.BaseOracle := + (PCSBCSMerkleRootCache.freeze (publicLog address ref view) ref.root ref.shape).raw + +theorem publicRoot_actual {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (address : Keys → List Reference) (ref : Reference) + (clean : ¬ OutputCollision (publicLog address ref + (Sampling.eval ((part).split (PublicCompressionCouplingMixed.oracle seed ro)) + (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted))))) : + let table := (part).split (PublicCompressionCouplingMixed.oracle seed ro) + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + publicRoot address ref (Sampling.eval table source) = + PCSBCSCapturedSourceAcceptance.sourceRoot seed address ref source table := by + dsimp only + have equal := publicLog_actual seed ro program remaining limit counted address ref + have auth := PCSBCSMerkleSeedProjection.sourceLog_authentic seed ro address ref + (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) + unfold publicRoot PCSBCSCapturedSourceAcceptance.sourceRoot + rw [← equal] + exact (PCSBCSCapturedNativeReplyBridge.next_image_provenance seed _ ref auth + (equal ▸ clean)).2 + +/-- Two arbitrary typed tables with the same actual whole View have identical +ordinary capture logs for any fixed public address decoder. -/ +theorem publicLog_same_view {R : Type} (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (left right : Table Keys Answers) (address : Keys → List Reference) + (ref : Reference) + (same : Sampling.eval left (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) = + Sampling.eval right (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted))) : + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + sourceLog address ref source left = + sourceLog address ref source right := by + dsimp only + rw [publicLog_every_table,publicLog_every_table,same] + +theorem publicRoot_every_table {R : Type} (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (table : Table Keys Answers) (address : Keys → List Reference) (ref : Reference) + (clean : ¬ OutputCollision (publicLog address ref (Sampling.eval table + (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted))))) : + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + publicRoot address ref (Sampling.eval table source) = + PCSBCSCapturedSourceAcceptance.sourceRoot (PCSBCSMerkleTableAuthenticity.seed table) + address ref source table := by + dsimp only + have equal := publicLog_every_table program remaining limit counted table address ref + have auth := PCSBCSMerkleTableAuthenticity.sourceLog_authentic address ref + (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) table + unfold publicRoot PCSBCSCapturedSourceAcceptance.sourceRoot + rw [← equal] + exact (PCSBCSCapturedNativeReplyBridge.next_image_provenance _ _ ref auth + (equal ▸ clean)).2 + +/-- Literal sourceRoot independence across ANY two typed tables. Each seed is +its own table projection; no equality of seeds or roots is assumed. -/ +theorem sourceRoot_same_view {R : Type} (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (left right : Table Keys Answers) + (ref : Reference) + (same : Sampling.eval left (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) = + Sampling.eval right (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted))) + (clean : ¬ OutputCollision (publicLog (PCSBCSCapturedSourceTransport.address + (p := p) (Q := B) (iv := iv) (boundary := boundary)) + ref (Sampling.eval left (Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted))))) : + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + PCSBCSCapturedSourceAcceptance.sourceRoot (PCSBCSMerkleTableAuthenticity.seed left) + PCSBCSCapturedSourceTransport.address ref source left = + PCSBCSCapturedSourceAcceptance.sourceRoot (PCSBCSMerkleTableAuthenticity.seed right) + PCSBCSCapturedSourceTransport.address ref source right := by + dsimp only + rw [← publicRoot_every_table program remaining limit counted left _ ref clean] + have rightClean := clean + rw [same] at rightClean + rw [← publicRoot_every_table program remaining limit counted right _ ref rightClean,same] +end Allocation + +/-- Read the construction observations themselves, not a proposed public/eval +codec equality. Missing unqueried coordinates receive only an inert default. -/ +def publicAnswers {R : Type} (view : View R) (q : Coordinate) : Digest32 := + (WHIRPhysicalCaller.latestAnswers view.observations q).getD (fun _ => 0) + +def publicOriginal {R : Type} (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (view : View R) : Option (PCSBCSCallerBinding.CallerInput p) := + PCSBCSSourceCallerOriginal.original p layout saved entry (publicAnswers view) + +section WholeCaller +variable {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) + +/-- Public recovery of a coordinate actually queried anywhere in the WHOLE +source program. Repeated observations are consistent by actual raw RO execution, +not by an assumed public/evaluation codec equality. -/ +theorem publicAnswers_recorded {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (wanted : Coordinate) (valid : DuplexEncoding.Admissible wanted) (answer : Digest32) + (present : (⟨.construction wanted valid,answer⟩ : Observation) ∈ + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)).observations) : + publicAnswers (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) wanted = + PCSBCSSourceCallerAnswers.answers ((part).split + (PublicCompressionCouplingMixed.oracle seed ro)) wanted := by + let view := Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + have first := present + rw [PublicCompressionCouplingMixed.compile_actual] at first + obtain ⟨bounded,_⟩ := PCSBCSIdealConstructionAnswers.construction_observations + _ ro iv _ _ _ _ _ wanted valid answer first + have consistent : ∀ observation ∈ view.observations, ∀ proof, + observation.query = .construction wanted proof → + observation.answer = ro (constructionKey B iv wanted bounded) := by + intro observation member proof same + have construction : (⟨.construction wanted proof,observation.answer⟩ : Observation) ∈ + view.observations := by + cases observation + cases same + exact member + dsimp only [view] at construction + rw [PublicCompressionCouplingMixed.compile_actual] at construction + obtain ⟨bound,actual⟩ := PCSBCSIdealConstructionAnswers.construction_observations + _ ro iv _ _ _ _ _ wanted proof _ construction + exact actual + have found := WHIRPhysicalCaller.latestAnswers_consistent view.observations wanted valid + (ro (constructionKey B iv wanted bounded)) ⟨_,present,rfl⟩ consistent + rw [PCSBCSNativeIdealCallerOriginal.split_answers seed ro wanted bounded] + change (WHIRPhysicalCaller.latestAnswers view.observations wanted).getD (fun _ => 0) = _ + rw [found] + rfl + +/-- The only coverage premise is actual public construction-query membership, +which a native caller segment supplies. No decoded-original equality is assumed. -/ +theorem publicOriginal_recorded {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) + (queried : ∀ wanted ∈ WHIRCallerOutputs.callerOutputs entry, + ∃ valid answer, (⟨.construction wanted valid,answer⟩ : Observation) ∈ + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)).observations) : + publicOriginal p layout saved entry (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) = + PCSBCSSourceCallerOriginal.original p layout saved entry + (PCSBCSSourceCallerAnswers.answers ((part).split + (PublicCompressionCouplingMixed.oracle seed ro))) := by + unfold publicOriginal + apply PCSBCSSourceCallerOriginal.original_prior_only + intro wanted member + obtain ⟨valid,answer,present⟩ := queried wanted member + exact publicAnswers_recorded seed ro program remaining limit counted wanted valid answer present + +/-- Failure observer input is only the whole View and public source geometry. +It does not accept a seed, table, root accessor, or failure certificate. -/ +noncomputable def publicExtractionFailed {R : Type} + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) + (ref : Reference) (view : View R) : Prop := + ∃ original : PCSBCSCallerBinding.CallerInput p, + publicOriginal p layout saved entry view = some original ∧ + ¬ ∃ witness, + PCSRoundByRoundKnowledge.extract p original.lanes original.family original.points + original.anchorPoint original.anchorValue + (publicRoot (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) + (iv := iv) (boundary := boundary)) ref view) = some witness ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) original.lanes + (publicRoot (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) + (iv := iv) (boundary := boundary)) ref view) original.family original.points + original.anchorPoint original.anchorValue witness + +theorem publicExtractionFailed_actual {R : Type} (seed : DuplexPublicSimulator.Seed) + (ro : RawKey B → Digest32) (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (ref : Reference) + (queried : ∀ wanted ∈ WHIRCallerOutputs.callerOutputs entry, + ∃ valid answer, (⟨.construction wanted valid,answer⟩ : Observation) ∈ + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)).observations) + (clean : ¬ OutputCollision (publicLog (PCSBCSCapturedSourceTransport.address + (p := p) (Q := B) (iv := iv) (boundary := boundary)) ref + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)))) : + let table := (part).split (PublicCompressionCouplingMixed.oracle seed ro) + let source := Atomic.program (part) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + let view := Sampling.eval table source + publicExtractionFailed (p := p) (B := B) (iv := iv) (boundary := boundary) + layout saved entry ref view ↔ + ∃ original : PCSBCSCallerBinding.CallerInput p, + PCSBCSSourceCallerOriginal.original p layout saved entry + (PCSBCSSourceCallerAnswers.answers table) = some original ∧ + ¬ ∃ witness, + PCSRoundByRoundKnowledge.extract p original.lanes original.family original.points + original.anchorPoint original.anchorValue + (PCSBCSCapturedSourceAcceptance.sourceRoot seed PCSBCSCapturedSourceTransport.address ref source table) = some witness ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) original.lanes + (PCSBCSCapturedSourceAcceptance.sourceRoot seed PCSBCSCapturedSourceTransport.address ref source table) + original.family original.points original.anchorPoint original.anchorValue witness := by + dsimp only + have root := publicRoot_actual seed ro program remaining limit counted + PCSBCSCapturedSourceTransport.address ref + (by simpa only [Atomic.eval_program,Partition.join_split] using clean) + unfold publicExtractionFailed + rw [root] + simp only [Atomic.eval_program,Partition.join_split] + rw [publicOriginal_recorded seed ro program remaining limit counted layout saved entry queried] +end WholeCaller + +section NativeCaller +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array MerkleTransport.PrunedMerklePaths) (B : Nat) + (limit : WHIRPhysicalVerifier.sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +/-- Verifier-only specialization: successful actual fresh execution derives +public reconstruction of the independently decoded original. -/ +theorem native_publicOriginal + (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) : + publicOriginal packet.val.profile model.layout saved (RawWHIRKeys.entry ctx packet.val) + (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro) = + PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers + (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) := by + let view := AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro + let table := PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨caller,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + obtain ⟨before,after,splitTrace,_,queries,_⟩ := caller + unfold publicOriginal + apply PCSBCSSourceCallerOriginal.original_prior_only + intro wanted prior + have queried : Query.construction wanted (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) ∈ + before.map Observation.query := by + rw [queries] + exact List.mem_map.mpr ⟨⟨wanted,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨observation,present,same⟩ := List.mem_map.mp queried + have presentWhole : observation ∈ view.observations := by + rw [show view.observations = before ++ after from splitTrace] + exact List.mem_append_left _ present + have consistent : ∀ observation ∈ view.observations, ∀ valid, + observation.query = .construction wanted valid → + observation.answer = PCSBCSSourceCallerAnswers.answers table wanted := by + intro observed member valid same + have construction : (⟨.construction wanted valid,observed.answer⟩ : Observation) ∈ + view.observations := by + cases observed + cases same + exact member + simp only [view,AnchoredMixedIdealSourceAcceptance.mixedView, + PublicCompressionCouplingMixed.compile_actual] at construction + obtain ⟨bounded,actual⟩ := PCSBCSIdealConstructionAnswers.construction_observations + _ ro ctx.iv _ _ _ _ _ wanted valid _ construction + dsimp only [table,PCSBCSCapturedIdealNativeAcceptance.table] + rw [PCSBCSNativeIdealCallerOriginal.split_answers seed ro wanted bounded] + exact actual + have answer := WHIRPhysicalCaller.latestAnswers_consistent view.observations wanted + (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) + (PCSBCSSourceCallerAnswers.answers table wanted) ⟨observation,presentWhole,same⟩ consistent + change (WHIRPhysicalCaller.latestAnswers view.observations wanted).getD (fun _ => 0) = _ + rw [answer] + rfl +end NativeCaller +#print axioms mixedTrace_actual +#print axioms firstPrefix_execute +#print axioms publicPrefix_actual +#print axioms publicLog_actual +#print axioms publicLog_every_table +#print axioms publicLog_same_view +#print axioms publicRoot_actual +#print axioms publicRoot_every_table +#print axioms sourceRoot_same_view +#print axioms native_publicOriginal +#print axioms publicAnswers_recorded +#print axioms publicOriginal_recorded +#print axioms publicExtractionFailed_actual +end Whir.PCSBCSNativePublicCapture diff --git a/verification/whir/Whir/PCSBCSNativeRootRoles.lean b/verification/whir/Whir/PCSBCSNativeRootRoles.lean new file mode 100644 index 000000000..e87960bf5 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeRootRoles.lean @@ -0,0 +1,574 @@ +import Whir.AnchoredPhysicalExecution +import Whir.PCSBCSCapturedIdealNativeAcceptance + +/-! Exact historical native root roles. The invariant below is obtained from +successful physical transitions, including their scalar parser and nonce +interpreter; it is not a transport or Merkle-acceptance certificate. -/ +set_option autoImplicit false +set_option maxHeartbeats 1600000 +namespace Whir.PCSBCSNativeRootRoles +open Concrete Protocol FiatShamirGame DuplexModeGame WHIRHistory +open WHIRPhysicalVerifier WHIRPhysicalReplay PublicMerkleProgram +open MerkleTransport MerkleTransport.Commitments +open RawOracleCoupling.Concrete PCSBCSSourceRootReferences + +/-- Only final, nonterminal folds append native roots. -/ +def rootPhase {c : Config} : CausalProbability.Coordinate c → Option Nat + | .fold i j => if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size then some (i.val+1) else none + | _ => none + +def phaseCount (c : Config) : Nat → Nat + | 0 => 0 + | n+1 => phaseCount c n + (rootPhase (((schedule c)[n]?).getD .initial)).toList.length + +/- This finite source-configuration fact covers all 56 supported profiles. +At each next-root role the chronological append index is its native phase. -/ +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_root_order : ∀ p : ParameterBounds.Profile, + ∀ n : Fin (depth (ParameterBounds.config p)), + (rootPhase (((schedule (ParameterBounds.config p))[n.val]?).getD .initial)).all + (fun phase => decide (phaseCount (ParameterBounds.config p) n.val + 1 = phase)) = true := by + decide +kernel + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +theorem production_initial_remaining : ∀ p : ParameterBounds.Profile, + CausalGame.remaining (ParameterBounds.config p) 0 = + (ParameterBounds.config p).logN - (ParameterBounds.config p).folds[0]! := by + decide +kernel + +/-- Native root array indices carry the exact full-leaf shape, not merely the +occupied base-lane suffix. -/ +def nativeShape (p : ParameterBounds.Profile) (saved : AnchoredHeaderCodec.Record) (i : Nat) : + PCSBCSMerkleRootCache.Shape := + if i = 0 then initialShape saved.shape else phaseShape (ParameterBounds.config p) i + +def nativeReferences (p : ParameterBounds.Profile) (saved : AnchoredHeaderCodec.Record) + (roots : Array Digest32) : List Reference := + roots.toList.zipIdx.map fun (root,i) => ⟨root,nativeShape p saved i⟩ + +theorem nativeShape_opening (p : ParameterBounds.Profile) (saved : AnchoredHeaderCodec.Record) + (profile : profileShape p saved.shape) (i : Nat) : + nativeShape p saved i = + ⟨(ParameterBounds.length (ParameterBounds.config p) i).log2,leafWords p i, + if i = 0 then saved.shape.lanes else leafWords p i⟩ := by + by_cases zero : i = 0 + · subst i + rcases profile with ⟨hn,hb,hr⟩ + simp [nativeShape,initialShape,leafWords,ParameterBounds.length, + production_initial_remaining,hn,hb,hr] + · simp [nativeShape,zero,phaseShape,leafWords,ParameterBounds.length] + +theorem nativeReferences_push (p : ParameterBounds.Profile) (saved : AnchoredHeaderCodec.Record) + (roots : Array Digest32) (root : Digest32) : + nativeReferences p saved (roots.push root) = nativeReferences p saved roots ++ + [⟨root,nativeShape p saved roots.size⟩] := by + simp [nativeReferences,List.zipIdx_append] + +theorem nativeReferences_lookup (p : ParameterBounds.Profile) (saved : AnchoredHeaderCodec.Record) + (roots : Array Digest32) (i : Nat) (root : Digest32) (found : roots[i]? = some root) : + (⟨root,nativeShape p saved i⟩ : Reference) ∈ nativeReferences p saved roots := by + apply List.mem_map.mpr + refine ⟨(root,i),List.mk_mem_zipIdx_iff_getElem?.mpr ?_,rfl⟩ + simpa using found + +/-- The role check at chronological position n, with no suffix search. -/ +def roleAdmitted (c : Config) (n : Nat) (m : Pending) : Bool := + if n = 0 then true else + match rootPhase (((schedule c)[n-1]?).getD .initial) with + | none => true + | some phase => (parsePhase c (((schedule c)[n-1]?).getD .initial) m phase 2).isSome + +theorem phaseRoles_eq (c : Config) (messages : List Pending) : + phaseRolesAdmitted c messages = messages.reverse.zipIdx.all (fun (m,n) => roleAdmitted c n m) := by + unfold phaseRolesAdmitted + apply congrArg (fun f => messages.reverse.zipIdx.all f) + funext pair + rcases pair with ⟨m,n⟩ + dsimp only + unfold roleAdmitted + by_cases zero : n = 0 + · simp only [zero,ite_true] + · simp only [ite_eq_right zero] + cases (((schedule c)[n-1]?).getD .initial) <;> simp only [rootPhase] + case fold i j => split <;> rfl + +theorem phaseReferences_cons (c : Config) (m : Pending) (messages : List Pending) : + phaseReferences c (m::messages) = phaseReferences c messages ++ (phaseAt c messages.length m).toList := by + simp [phaseReferences,List.zipIdx_append] + cases h : phaseAt c messages.length m <;> simp [h] + +theorem phaseRoles_cons (c : Config) (m : Pending) (messages : List Pending) : + phaseRolesAdmitted c (m::messages) = (phaseRolesAdmitted c messages && roleAdmitted c messages.length m) := by + simp [phaseRoles_eq,List.zipIdx_append] + +/-- Successful scalar parsing forces four scalars and canonical root halves +at an eligible fold. Malformed replies and decode errors are not elided. -/ +theorem reply_fold_root {c : Config} (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) + (last : j.val+1 = c.folds[i.val]!) (later : i.val+1 < c.folds.size) + (m : Pending) (rows : Oracle) (reply : CausalGame.Reply) + (parsed : WHIRHistory.decodeReplyScalars (.fold i j) (fun _ => #[]) rows m.scalars = some reply) : + ∃ root, absorbedRoot (.fold i j) m.scalars = some root ∧ + parsePhase c (.fold i j) m (i.val+1) 2 = some ⟨root,phaseShape c (i.val+1)⟩ := by + rcases m with ⟨xs,nonce⟩ + cases xs with + | nil => simp [WHIRHistory.decodeReplyScalars] at parsed + | cons a xs => + cases xs with + | nil => simp [WHIRHistory.decodeReplyScalars] at parsed + | cons b xs => + cases xs with + | nil => simp [WHIRHistory.decodeReplyScalars,last,later] at parsed + | cons r xs => + cases xs with + | nil => simp [WHIRHistory.decodeReplyScalars,last,later] at parsed + | cons s xs => + cases xs with + | cons t xs => simp [WHIRHistory.decodeReplyScalars,last,later] at parsed + | nil => + cases decoded : ByteCodec.scalarsToHash (r,s) with + | none => simp [WHIRHistory.decodeReplyScalars,last,later,decoded] at parsed + | some root => + exact ⟨root,by simp [absorbedRoot,last,later,decoded], + by simp [parsePhase,last,later,parseRootScalars,decoded]⟩ + +/-- A proof-independent Option update avoids dependent elimination of the +successful parser equation when the array itself is rewritten. -/ +def appendRoot (roots : Array Digest32) : Option Digest32 → Array Digest32 + | none => roots + | some root => roots.push root + +/-- Root-array update, exact reference update and role admission from the +actual successful absorber, relative to its actual previous coordinate. -/ +theorem absorbResponse_roles {p : ParameterBounds.Profile} (state out : WireState p) + (m : Pending) (root : Option Digest32) (n : Nat) + (positive : 0 < n) + (previous : state.previous = some (((schedule (ParameterBounds.config p))[n-1]?).getD .initial)) + (ok : absorbResponse state m = some (out,root)) : + out.roots = appendRoot state.roots root ∧ + phaseAt (ParameterBounds.config p) n m = + (rootPhase (((schedule (ParameterBounds.config p))[n-1]?).getD .initial)).bind + (fun phase => root.map (fun d => ⟨d,phaseShape (ParameterBounds.config p) phase⟩)) ∧ + roleAdmitted (ParameterBounds.config p) n m = true ∧ + root.toList.length = + (rootPhase (((schedule (ParameterBounds.config p))[n-1]?).getD .initial)).toList.length := by + let q := (((schedule (ParameterBounds.config p))[n-1]?).getD .initial) + obtain ⟨reply,decoded,_⟩ := absorbResponse_some state out m root q previous ok + have actual : root = absorbedRoot q m.scalars := by + simp only [absorbResponse,previous] at ok + change (WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q m).bind _ = some (out,root) at ok + simp only [decoded,Option.bind_some,Option.some.injEq,Prod.mk.injEq] at ok + exact ok.2.symm + have roots : out.roots = appendRoot state.roots root := by + simp only [absorbResponse,previous] at ok + change (WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q m).bind _ = some (out,root) at ok + simp only [decoded,Option.bind_some,Option.some.injEq,Prod.mk.injEq] at ok + have equal := congrArg (fun s : WireState p => s.roots) ok.1 + change appendRoot state.roots (absorbedRoot q m.scalars) = out.roots at equal + exact equal.symm.trans (congrArg (appendRoot state.roots) actual.symm) + refine ⟨roots,?_,?_,?_⟩ + all_goals have nonzero : n ≠ 0 := by omega + all_goals change WHIRHistory.decodeReplyScalars q (fun _ => #[]) _ m.scalars = some reply at decoded + all_goals change state.previous = some q at previous + all_goals change root = absorbedRoot q m.scalars at actual + all_goals unfold q at * + all_goals cases coord : (((schedule (ParameterBounds.config p))[n-1]?).getD .initial) with + | initial => simp [phaseAt,roleAdmitted,nonzero,coord,rootPhase,actual,absorbedRoot] + | ood i j => simp [phaseAt,roleAdmitted,nonzero,coord,rootPhase,actual,absorbedRoot] + | query i => simp [phaseAt,roleAdmitted,nonzero,coord,rootPhase,actual,absorbedRoot] + | tail j => simp [phaseAt,roleAdmitted,nonzero,coord,rootPhase,actual,absorbedRoot] + | fold i j => + by_cases guard : j.val+1 = (ParameterBounds.config p).folds[i.val]! ∧ i.val+1 < (ParameterBounds.config p).folds.size + · obtain ⟨d,absorbed,parsed⟩ := reply_fold_root i j guard.1 guard.2 m _ reply + (by simpa only [coord] using decoded) + have equal : root = some d := actual.trans (by simpa only [coord] using absorbed) + simp [phaseAt,roleAdmitted,nonzero,coord,rootPhase,guard,equal,parsed] + · have noParse : parsePhase (ParameterBounds.config p) (.fold i j) m (i.val+1) 2 = none := by + simp only [parsePhase] + rw [ite_eq_right (by intro h; exact guard ⟨h.1,h.2.1⟩)] + have absent : rootPhase (.fold i j) = none := by simp only [rootPhase,ite_eq_right guard] + have noRoot : absorbedRoot (.fold i j) m.scalars = none := by simp only [absorbedRoot,ite_eq_right guard] + simp only [phaseAt,roleAdmitted,ite_eq_right nonzero,coord,absent,noParse,actual,noRoot, + Option.bind_none,Option.toList_none,List.length_nil] + +/-- Nonce binding and output caching cannot change the root array or openings. -/ +theorem afterNonce_roots {p : ParameterBounds.Profile} {ctx : RawWHIRKeys.Context} {Q : Nat} + {packet : RawWHIRKeys.Packet ctx Q} (state out : WireState p) + (nonce : WHIRPowProgram.Outcome ctx Q packet) (ok : afterNonce state nonce = some out) : + out.roots = state.roots ∧ out.openings = state.openings := by + unfold afterNonce at ok + split at ok + · cases Option.some.inj ok; exact ⟨rfl,rfl⟩ + · cases cached : state.outputCache with + | none => simp [cached] at ok + | some digest => + simp only [cached,Option.map_some,Option.some.injEq] at ok + subst out + exact ⟨rfl,rfl⟩ + +theorem absorbResponse_openings {p : ParameterBounds.Profile} (state out : WireState p) + (pending : Pending) (root : Option Digest32) (ok : absorbResponse state pending = some (out,root)) : + out.openings = state.openings := by + unfold absorbResponse at ok + cases previous : state.previous with + | none => + simp only [previous] at ok + split at ok + · cases Option.some.inj ok; rfl + · contradiction + | some q => + simp only [previous] at ok + change (WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending).bind _ = + some (out,root) at ok + cases parsed : WHIRPhysicalHistory.reply (fun _ _ => #[]) (fun i => state.rows[i]!) q pending with + | none => simp [parsed] at ok + | some response => + simp only [parsed,Option.bind_some,Option.some.injEq,Prod.mk.injEq] at ok + cases ok.1 + rfl + +def openingRole {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) + (opening : QueryOpening p) : Reference := + ⟨opening.root,nativeShape p saved opening.level.val⟩ + +theorem takeSample_roots {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (state out : WireState p) + (q : CausalProbability.Coordinate (ParameterBounds.config p)) (x : StackWHIRReplay.Sample q) + (trace : List Observation) (run : Runs (takeSample saved.shape.lanes proofs state q x) trace (some out)) + (prior : ∀ opening ∈ state.openings, openingRole saved opening ∈ nativeReferences p saved state.roots) : + out.roots = state.roots ∧ + ∀ opening ∈ out.openings, openingRole saved opening ∈ nativeReferences p saved out.roots := by + cases q with + | query i => + simp only [takeSample] at run + split at run + · cases hp : proofs[i.val]? <;> cases hr : state.roots[i.val]? + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run; cases run + · simp only [hp,hr] at run + obtain ⟨before,opened,after,_,_,continued⟩ := (Runs.bind_iff _ _).mp run + cases opened with + | none => cases continued + | some opened => + cases continued + refine ⟨rfl,?_⟩ + intro opening member + rcases List.mem_cons.mp member with equal | old + · subst opening + exact nativeReferences_lookup p saved state.roots i.val _ hr + · exact prior opening old + · cases run + | initial => cases run; exact ⟨rfl,prior⟩ + | fold i j => cases run; exact ⟨rfl,prior⟩ + | ood i j => cases run; exact ⟨rfl,prior⟩ + | tail j => cases run; exact ⟨rfl,prior⟩ + +/-- Actual raw roots, exact full reference geometry, every retained opening, +and canonical admission of every chronological root role. -/ +structure RootRoles {ctx : RawWHIRKeys.Context} {Q : Nat} {p : ParameterBounds.Profile} + (saved : AnchoredHeaderCodec.Record) (packet : RawWHIRKeys.Packet ctx Q) + (state : WireState p) : Prop where + count : state.roots.size = phaseCount (ParameterBounds.config p) (packet.val.messages.length-1) + 1 + references : nativeReferences p saved state.roots = + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) packet.val.messages + admitted : phaseRolesAdmitted (ParameterBounds.config p) packet.val.messages = true + openings : ∀ opening ∈ state.openings, openingRole saved opening ∈ nativeReferences p saved state.roots + +theorem RootRoles.roots {ctx : RawWHIRKeys.Context} {Q : Nat} {p : ParameterBounds.Profile} + {saved : AnchoredHeaderCodec.Record} {packet : RawWHIRKeys.Packet ctx Q} {state : WireState p} + (roles : RootRoles saved packet state) : + state.roots.toList = saved.root :: + (phaseReferences (ParameterBounds.config p) packet.val.messages).map Reference.root := by + have equal := congrArg (List.map Reference.root) roles.references + simpa [nativeReferences,List.map_map,Function.comp_def,List.zipIdx_map_fst] using equal + + +theorem step_sample_roles {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (step : Step ctx stack Q p saved.shape.lanes proofs packet profile state raw out) + (absorbedRoles : ∀ absorbed root, + absorbResponse state (packet.val.messages.headD ⟨[],none⟩) = some (absorbed,root) → + RootRoles saved packet absorbed) : + RootRoles saved packet out := by + cases step with + | run parsed size shape boundNonce accepted opened => + have roles := absorbedRoles _ _ parsed + obtain ⟨nonceRoots,nonceOpenings⟩ := afterNonce_roots _ _ _ boundNonce + obtain ⟨sampleRoots,sampleOpenings⟩ := takeSample_roots saved _ _ _ _ _ _ opened + (by rw [nonceOpenings,nonceRoots]; exact roles.openings) + refine ⟨?_,?_,roles.admitted,sampleOpenings⟩ + · dsimp only [withOutput] + rw [sampleRoots,nonceRoots] + exact roles.count + · dsimp only [withOutput] + rw [sampleRoots,nonceRoots] + exact roles.references + +theorem roles_initial {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} + (single : packet.val.messages = [WHIRHistoryKey.initialPending]) + (step : Step ctx stack Q p saved.shape.lanes proofs packet profile (initialWireState p saved.root) raw out) : + RootRoles saved packet out := by + apply step_sample_roles saved step + intro absorbed root parsed + simp only [single,List.headD_cons,WHIRHistoryKey.initialPending,initialWireState, + absorbResponse,List.isEmpty_nil,ite_true,Option.some.injEq,Prod.mk.injEq] at parsed + obtain ⟨rfl,rfl⟩ := parsed + constructor + · simp [single,phaseCount] + · simp [nativeReferences,nativeShape,single,phaseReferences,phaseAt] + · simp [single,phaseRoles_eq,roleAdmitted] + · simp + +theorem roles_next {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) {proofs : Array PrunedMerklePaths} + {packet priorPacket : RawWHIRKeys.Packet ctx Q} {profile : packet.val.profile = p} + {state out : WireState p} {raw : GroupAnswer ctx Q (.inl packet)} {history} + (m : Pending) (messages : packet.val.messages = m::priorPacket.val.messages) + (complete : Completed stack priorPacket state history) + (prior : RootRoles saved priorPacket state) + (step : Step ctx stack Q p saved.shape.lanes proofs packet profile state raw out) : + RootRoles saved packet out := by + obtain ⟨priorProfile,priorRaw,past,tape,seed,_,previous,_,_,_,_,_,_⟩ := complete + have positive : 0 < priorPacket.val.messages.length := List.length_pos_iff.mpr priorPacket.property.2.1 + have priorQuery : packetQuery ctx Q p priorPacket priorProfile = + (((schedule (ParameterBounds.config p))[priorPacket.val.messages.length-1]?).getD .initial) := by + rw [packetQuery_eq ctx Q p priorPacket priorProfile priorPacket.val.statement] + rfl + have scheduled : priorPacket.val.messages.length-1 < depth (ParameterBounds.config p) := by + have bounds := priorPacket.property.2.2.1 + simp only [WHIRHistory.scheduledAdmissible,Bool.and_eq_true] at bounds + have admissible := bounds.1 + unfold WHIRHistory.admissible at admissible + simp only [decide_eq_true_eq] at admissible + rw [priorProfile] at admissible + omega + apply step_sample_roles saved step + intro absorbed root parsed + rw [messages,List.headD_cons] at parsed + obtain ⟨roots,phase,admitted,length⟩ := absorbResponse_roles state absorbed m root + priorPacket.val.messages.length positive (previous.trans (congrArg some priorQuery)) parsed + have openingEq := absorbResponse_openings state absorbed m root parsed + have count : absorbed.roots.size = + phaseCount (ParameterBounds.config p) (packet.val.messages.length-1) + 1 := by + rw [roots,messages] + have successor : priorPacket.val.messages.length = (priorPacket.val.messages.length-1)+1 := by omega + simp only [List.length_cons,Nat.add_sub_cancel] + rw [successor,phaseCount,← length] + cases root <;> simp [appendRoot,prior.count] + have refs : nativeReferences p saved absorbed.roots = + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config p) packet.val.messages := by + rw [messages,phaseReferences_cons,phase,roots] + cases hphase : rootPhase (((schedule (ParameterBounds.config p))[priorPacket.val.messages.length-1]?).getD .initial) with + | none => + have empty : root = none := by cases root <;> simp_all + simp [empty,appendRoot,prior.references] + | some k => + have order := production_root_order p ⟨priorPacket.val.messages.length-1,scheduled⟩ + simp only [hphase,Option.all_some,decide_eq_true_eq] at order + cases root with + | none => simp [appendRoot,prior.references] + | some d => + have index : state.roots.size = k := prior.count.trans order + have nonzero : k ≠ 0 := by rw [← order]; omega + simp [appendRoot,nativeReferences_push,prior.references,index,nativeShape,nonzero,List.cons_append] + refine ⟨count,refs,?_,?_⟩ + · rw [messages,phaseRoles_cons,prior.admitted,admitted] + rfl + · intro opening member + rw [openingEq] at member + have earlier := prior.openings opening member + rw [roots] + cases root with + | none => exact earlier + | some d => rw [appendRoot,nativeReferences_push]; exact List.mem_append_left _ earlier + +/-- All phases are derived from the actual native completion trace. -/ +theorem trace_rootRoles {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q : Nat} + {p : ParameterBounds.Profile} (saved : AnchoredHeaderCodec.Record) {proofs : Array PrunedMerklePaths} + {packet : RawWHIRKeys.Packet ctx Q} {packets : List (RawWHIRKeys.Packet ctx Q)} + {out : WireState p} {history} + (chain : Chain ctx Q packet packets) + (trace : Trace ctx stack Q p saved.shape.lanes proofs packets (initialWireState p saved.root) out history) : + RootRoles saved packet out := by + induction chain generalizing out history with + | initial packet single => + cases trace with + | cons profile step rest => + cases rest + exact roles_initial saved single step + | next m prior messages statement profile ih => + obtain ⟨middle,before,after,hist,first,last⟩ := Trace.append_inv _ _ trace + cases last with + | cons finalProfile step rest => + cases rest + exact roles_next saved m messages (trace_completed saved.root prior first) (ih first) step + +theorem verifySource_rootRoles (cap : Nat) (boundary : AnchoredPhysicalDriver.Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (saved : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (run : Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet saved proofs)) observations (some a)) : + RootRoles saved packet a.wire := by + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap boundary model ctx stack Q packet saved proofs observations a run + exact trace_rootRoles saved (completion_chain ctx Q packet) trace + +/-- Exact opening references occur in the literal whole Pending role list. +No root-availability or queried-leaf-availability premise occurs here. -/ +theorem verifySource_opening_member (cap : Nat) (boundary : AnchoredPhysicalDriver.Boundary) + (model : WHIRCallerSupport.ProductionLayout) (ctx : RawWHIRKeys.Context) + (stack : ctx.mode = .stack) (Q : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (saved : AnchoredHeaderCodec.Record) (proofs : Array PrunedMerklePaths) + (observations : List Observation) (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (run : Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap boundary model ctx stack Q packet saved proofs)) observations (some a)) : + saved.Valid ∧ profileShape packet.val.profile saved.shape ∧ + phaseRolesAdmitted (ParameterBounds.config packet.val.profile) packet.val.messages = true ∧ + ∀ opening ∈ a.wire.openings, + PCSBCSCapturedIdealNativeAcceptance.openingReference ctx Q packet opening saved.shape.lanes ∈ + ⟨saved.root,initialShape saved.shape⟩ :: phaseReferences (ParameterBounds.config packet.val.profile) packet.val.messages := by + have roles := verifySource_rootRoles cap boundary model ctx stack Q packet saved proofs observations a run + have profile : profileShape packet.val.profile saved.shape := a.configuration.2 + refine ⟨a.configuration.1,profile,roles.admitted,?_⟩ + intro opening member + have present := roles.openings opening member + rw [roles.references] at present + simpa only [openingRole,nativeShape_opening packet.val.profile saved profile, + PCSBCSCapturedIdealNativeAcceptance.openingReference] using present + +/-- The literal source-table caller decoder is admitted by actual fresh-driver +success. Unlike original claim preparation, this parser fact needs no 2^64 +family-cap premise. Only actually queried caller coordinates are transported. -/ +theorem mixed_success_fresh_decode (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro).result.value = some a) : + ∃ claims, AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers + ((PCSBCSChallengeOracle.EnteredPacket.partition (p := packet.val.profile) + (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length)).split + (PublicCompressionCouplingMixed.oracle seed ro))) = some claims := by + let view := AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro + let answers := PCSBCSSourceCallerAnswers.answers + ((PCSBCSChallengeOracle.EnteredPacket.partition (p := packet.val.profile) + (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length)).split + (PublicCompressionCouplingMixed.oracle seed ro)) + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨⟨before,after,splitTrace,_,queries,parsed⟩,_,_,_,_⟩ := + AnchoredPhysicalExecution.verifySource_execution cap .fresh model ctx stack Q packet saved proofs _ a run + have splitView : view.observations = before ++ after := splitTrace + have earlier : ∀ wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry ctx packet.val), + WHIRPhysicalCaller.latestAnswers before wanted = some (answers wanted) := by + intro wanted prior + have queried : Query.construction wanted (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) ∈ + before.map Observation.query := by + rw [queries] + exact List.mem_map.mpr ⟨⟨wanted,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨o,member,equal⟩ := List.mem_map.mp queried + apply WHIRPhysicalCaller.latestAnswers_consistent before wanted + (RawWHIRKeys.callerOutput_admissible ctx Q packet wanted prior) _ ⟨o,member,equal⟩ + intro observation member valid same + have present : observation ∈ view.observations := by + rw [splitView] + exact List.mem_append_left _ member + have construction : (⟨.construction wanted valid,observation.answer⟩ : Observation) ∈ view.observations := by + cases observation + cases same + exact present + simp only [view,AnchoredMixedIdealSourceAcceptance.mixedView, + PublicCompressionCouplingMixed.compile_actual] at construction + obtain ⟨bounded,actual⟩ := PCSBCSIdealConstructionAnswers.construction_observations _ ro ctx.iv _ _ _ _ _ + wanted valid _ construction + dsimp only [answers] + rw [PCSBCSNativeIdealCallerOriginal.split_answers seed ro wanted bounded] + exact actual + obtain ⟨claims,caller,_,_,_⟩ := AnchoredPhysicalDriver.request_origin .fresh cap packet.val.profile + model.layout saved (RawWHIRKeys.entry ctx packet.val) (WHIRPhysicalCaller.latestAnswers before) a.request parsed + refine ⟨claims,?_⟩ + have tokens := WHIRCallerClaims.entryTokens_prior_only (RawWHIRKeys.entry ctx packet.val) + (fun q => (WHIRPhysicalCaller.latestAnswers before q).getD DuplexRefinement.zeroDigest) answers + (by intro q member; rw [earlier q member]; rfl) + simpa only [AnchoredPhysicalDriver.decodeCaller,AnchoredSourceFreshCaller.decode,tokens] using caller + +/-- An entered packet at the actual source cap B may be a reindexing of the +native Q packet: only literal entry and Pending equality are required. Parent +packet visitation supplies this packet using the observed path bound, without +Q ≤ B. Caller admission is derived from the actual mixed execution. -/ +theorem mixed_success_address_member (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro).result.value = some a) + (current : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv + (RawWHIRKeys.entry ctx packet.val).frames.length) + (entry : current.1.val = RawWHIRKeys.entry ctx packet.val) + (messages : current.2.messages = packet.val.messages) : + ∀ opening ∈ a.wire.openings, + PCSBCSCapturedIdealNativeAcceptance.openingReference ctx Q packet opening saved.shape.lanes ∈ + PCSBCSCapturedSourceTransport.address (.inl current) := by + obtain ⟨run,_,_⟩ := AnchoredMixedIdealSourceAcceptance.mixedView_runs + cap .fresh model ctx stack Q packet saved proofs ctx.iv B limit seed ro + rw [success] at run + obtain ⟨valid,profile,roles,member⟩ := verifySource_opening_member cap .fresh model ctx stack Q + packet saved proofs _ a run + obtain ⟨claims,caller⟩ := mixed_success_fresh_decode cap model ctx stack Q packet saved proofs + B limit seed ro a success + have admitted := PCSBCSCapturedSourceTransport.address_packet model.layout saved _ current + valid profile claims (by simpa only [entry] using caller) (by simpa only [messages] using roles) + rw [admitted,messages] + exact member + +/-- Conversion endpoint for `packetAtBound`: arbitrary source cap B, same +literal native packet data. No comparison of the native and source caps. -/ +theorem mixed_success_reindexed_address (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (a : AnchoredPhysicalDriver.Accepted ctx Q cap packet saved) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet + saved proofs ctx.iv B limit seed ro).result.value = some a) + (packetB : RawWHIRKeys.Packet ctx B) (same : packetB.val = packet.val) : + let current := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B packetB + (congrArg RawWHIRKeys.PacketData.profile same) (congrArg (RawWHIRKeys.entry ctx) same) + ∀ opening ∈ a.wire.openings, + PCSBCSCapturedIdealNativeAcceptance.openingReference ctx Q packet opening saved.shape.lanes ∈ + PCSBCSCapturedSourceTransport.address (.inl current) := by + apply mixed_success_address_member cap model ctx stack Q packet saved proofs B limit seed ro a success + · exact PCSBCSNativePacketBridge.enteredPacketAt_entry ctx stack B packetB _ _ + · rw [PCSBCSNativePacketBridge.enteredPacketAt_messages] + exact congrArg RawWHIRKeys.PacketData.messages same + +#print axioms production_root_order +#print axioms production_initial_remaining +#print axioms absorbResponse_roles +#print axioms nativeShape_opening +#print axioms RootRoles.roots +#print axioms trace_rootRoles +#print axioms verifySource_opening_member +#print axioms mixed_success_fresh_decode +#print axioms mixed_success_address_member +#print axioms mixed_success_reindexed_address + +end Whir.PCSBCSNativeRootRoles diff --git a/verification/whir/Whir/PCSBCSNativeSourceFailure.lean b/verification/whir/Whir/PCSBCSNativeSourceFailure.lean new file mode 100644 index 000000000..82aafa6af --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeSourceFailure.lean @@ -0,0 +1,91 @@ +import Whir.PCSBCSNativeCapturedReplyTransport +import Whir.PCSBCSNativeCapturedLogs +import Whir.PCSBCSAdaptiveSourceKnowledgeProbability + +/-! Actual fresh native success outside the retained primitive bad events +produces the existing adaptive source failure witness whenever the literal +original decoder's extractor fails. No observer refinement or accepted path is +assumed. The physical bad-event probability inclusion is a separate obligation. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeSourceFailure +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open MerkleTransport MerkleTransport.Commitments PublicMerkleLog +open WHIRPhysicalVerifier WHIRPhysicalReplay AnchoredPhysicalDriver +open PCSBCSSourceRootReferences PCSBCSCapturedSourceAcceptance PCSBCSCallerBinding + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) + (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +noncomputable def extractionFailed : Prop := + ∃ original : CallerInput packet.val.profile, + PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) = some original ∧ + ¬ ∃ witness, + PCSRoundByRoundKnowledge.extract packet.val.profile original.lanes original.family original.points + original.anchorPoint original.anchorValue + (PCSBCSNativeSourceOriginal.sourceBase cap model ctx stack Q packet saved proofs B limit seed ro) = some witness ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config packet.val.profile) original.lanes + (PCSBCSNativeSourceOriginal.sourceBase cap model ctx stack Q packet saved proofs B limit seed ro) + original.family original.points original.anchorPoint original.anchorValue witness + +theorem mixed_success_failed + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths) + (clean : ¬ OutputCollision (PCSBCSNativeCapturedLogs.wholeLog + cap model ctx stack Q packet saved proofs B limit seed ro)) + (failed : extractionFailed cap model ctx stack Q packet saved proofs B limit seed ro) : + PCSBCSAdaptiveSourceKnowledgeProbability.Failed model.layout + (PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit) + (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) := by + have cleanRefs := PCSBCSNativeCapturedLogs.referenceLog_clean + cap model ctx stack Q packet saved proofs B limit seed ro clean + obtain ⟨original,claims,replay,proof,bounded,reconstructed,caller,bound,terminal,initial,lambda, + erased,parsed,canonical,accepted,nativeEq,raws,transport,assembly⟩ := + PCSBCSNativeCapturedReplyTransport.mixed_success_replyTransport + cap model ctx stack Q packet saved proofs B limit seed ro a familyCap success quiet cleanRefs + obtain ⟨failedOriginal,failedDecoded,failedExtract⟩ := failed + have same : failedOriginal = original := Option.some.inj (failedDecoded.symm.trans reconstructed) + subst failedOriginal + obtain ⟨_,bounded',_,_,_,_,recorded,_⟩ := PCSBCSNativeCapturedTape.mixed_success_tape + cap model ctx stack Q packet saved proofs B limit seed ro a success + let final := PCSBCSNativePacketBridge.enteredPacket ctx stack B + (PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded) + let native : PCSBCSCapturedSourceProbability.FailureWitness model.layout saved + (PCSBCSSourceCallerAnswers.answers (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) + (PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit) + original (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) := { + primitive := seed + final := final + claims := claims + valid := a.configuration.1 + profile := a.configuration.2 + caller := caller + bound := bound + terminal := terminal + recorded := recorded + authentic := PCSBCSNativeCapturedLogs.referenceLog_authentic + cap model ctx stack Q packet saved proofs B limit seed ro ⟨saved.root,initialShape saved.shape⟩ + clean := cleanRefs ⟨saved.root,initialShape saved.shape⟩ + ring := replay.initial.1 + tape := a.wire.tape + strategy := fun _ => CausalStrategy.indexedStrategy replay.whir.replies + raws := raws + transport := transport + accepted := accepted + failed := failedExtract } + exact ⟨⟨saved,original,native,reconstructed⟩⟩ + +end Driver +#print axioms mixed_success_failed +end Whir.PCSBCSNativeSourceFailure diff --git a/verification/whir/Whir/PCSBCSNativeSourceOriginal.lean b/verification/whir/Whir/PCSBCSNativeSourceOriginal.lean new file mode 100644 index 000000000..5ee4f3c7f --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeSourceOriginal.lean @@ -0,0 +1,151 @@ +import Whir.PCSBCSNativeCapturedOracles +import Whir.PCSBCSNativeIdealCallerOriginal + +/-! Exact first-address Root0 and independently decoded original caller. +The accepted causal experiment is derived from the native source run with +captured getters; it does not assert current Rust or #607 correspondence. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeSourceOriginal +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open MerkleTransport MerkleTransport.Commitments PublicMerkleLog +open WHIRPhysicalVerifier WHIRPhysicalReplay AnchoredPhysicalDriver +open PCSBCSSourceRootReferences PCSBCSCapturedSourceAcceptance PCSBCSCallerBinding + +theorem nativeReplies_indexed {p : ParameterBounds.Profile} + (original : CallerInput p) (root : CausalGame.BaseOracle) (ring : RingPCSGame.Prefix) + (tape : CausalGame.Tape (ParameterBounds.config p)) (replies : Array CausalGame.Reply) (proof : Opening) + (parsed : CausalGame.opening (ParameterBounds.config p) + (CausalGame.challenges (ParameterBounds.config p) tape) replies = .ok proof) : + nativeReplies original root (fun _ => CausalStrategy.indexedStrategy replies) ring tape = replies := by + have equal := WHIRPhysicalSoundness.run_indexed_replies + (ExecutionShapes.Input p original.lanes root (OriginalClaimsChecker.input original.prepared root ring).claims) + tape replies proof parsed + simpa only [nativeReplies,PCSRoundByRoundTranscriptState.replies,Array.toArray_toList] using + congrArg List.toArray equal + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array PrunedMerklePaths) (B : Nat) + (limit : sourceBudget ctx Q packet ≤ B) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +noncomputable abbrev addresses := + PCSBCSCapturedSourceTransport.address (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length) + +noncomputable abbrev sourceBase := + sourceRoot seed (addresses ctx Q packet B) ⟨saved.root,initialShape saved.shape⟩ + (PCSBCSCapturedIdealNativeAcceptance.allocationProgram cap model ctx stack Q packet saved proofs B limit) + (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro) + +theorem base_eq_sourceRoot (profile : profileShape packet.val.profile saved.shape) : + PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro = + sourceBase cap model ctx stack Q packet saved proofs B limit seed ro := by + have shape := PCSBCSNativeRootRoles.nativeShape_opening packet.val.profile saved profile 0 + have length : 2^((ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2) = + ParameterBounds.length (ParameterBounds.config packet.val.profile) 0 := by + simp [ParameterBounds.length] + unfold PCSBCSNativeCapturedOracles.base sourceBase sourceRoot + have ref : (⟨saved.root,PCSBCSNativeRootRoles.nativeShape packet.val.profile saved 0⟩ : Reference) = + ⟨saved.root,initialShape saved.shape⟩ := rfl + change WHIRPhysicalRows.compactBaseOracle (hash seed) + ⟨recordDomain (records (PCSBCSNativeCapturedRows.referenceLog cap model ctx stack Q packet saved proofs B limit seed ro + ⟨saved.root,PCSBCSNativeRootRoles.nativeShape packet.val.profile saved 0⟩)),[]⟩ saved.root + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2 + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0) + (leafWords packet.val.profile 0) saved.shape.lanes = _ + rw [ref] + have shape' : initialShape saved.shape = + ⟨(ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2, + leafWords packet.val.profile 0,saved.shape.lanes⟩ := by + simpa only [PCSBCSNativeRootRoles.nativeShape,ite_true] using shape + simp only [shape',PCSBCSNativeCapturedRows.referenceLog,length] + +theorem original_bound (input : CallerInput packet.val.profile) + (reconstructed : PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) = some input) : + ∃ claims : AnchoredSourceCaller.Claims, + AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) = some claims ∧ + BoundOriginal input saved claims := by + obtain ⟨claims,fc,cc,prepared,decoded,recordEq,rootEq,_,rfl⟩ := + PCSBCSSourceCallerOriginal.original_exact packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) input reconstructed + refine ⟨claims,decoded,recordEq,rootEq,rfl,?_,rfl,rfl,rfl⟩ + exact List.ofFn_getElem + +theorem mixed_success_original_experiment + (a : Accepted ctx Q cap packet saved) (familyCap : cap ≤ 2^64) + (success : (AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro).result.value = some a) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSNativeCapturedRows.openingLog cap model ctx stack Q packet saved proofs B limit seed ro opening) + opening.root opening.result.paths) : + ∃ (input : CallerInput packet.val.profile) (claims : AnchoredSourceCaller.Claims) + (replay : StackWHIRReplay.Replay packet.val.profile cap) (proof : Opening), + PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) = some input ∧ + AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro)) = some claims ∧ + BoundOriginal input saved claims ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) + replay.whir.replies = .ok proof ∧ + WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro))) + (PCSBCSNativeCapturedOracles.roots cap model ctx stack Q packet saved proofs B limit seed ro) + (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile a.history).tail⟩ = + some replay ∧ + CausalGame.experiment + (OriginalClaimsChecker.input input.prepared + (sourceBase cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨input,reconstructed,_,statement⟩ := PCSBCSNativeIdealCallerOriginal.fresh_original + cap model ctx stack Q packet saved proofs B limit seed ro a familyCap success + obtain ⟨claims,decoded,bound⟩ := original_bound model ctx Q packet saved B seed ro input reconstructed + obtain ⟨replay,proof,_,initial,tape,replies,opening,canonical,accepted⟩ := + PCSBCSNativeCapturedOracles.mixed_success_experiment + cap model ctx stack Q packet saved proofs B limit seed ro a familyCap success quiet + have same := statement + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1 + change OriginalClaimsChecker.input input.prepared + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1 = + PCSBCSNativeOracleReplay.input a + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1 at same + have lanesEq : input.lanes = saved.shape.lanes := congrArg CausalGame.Public.lanes same + have claimsEq := congrArg CausalGame.Public.claims same + change (OriginalClaimsChecker.input input.prepared + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1).claims = + AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config packet.val.profile) saved + a.request.claims.family a.request.claims.points replay.initial.1 at claimsEq + have acceptedOriginal : CausalGame.experiment + (OriginalClaimsChecker.input input.prepared + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + change CausalGame.experiment + ⟨ParameterBounds.config packet.val.profile,input.lanes, + PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro, + (OriginalClaimsChecker.input input.prepared + (PCSBCSNativeCapturedOracles.base cap model ctx stack Q packet saved proofs B limit seed ro) replay.initial.1).claims⟩ + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true + rw [claimsEq,lanesEq] + exact accepted + rw [base_eq_sourceRoot cap model ctx stack Q packet saved proofs B limit seed ro a.configuration.2] at acceptedOriginal + exact ⟨input,claims,replay,proof,reconstructed,decoded,bound,initial,tape,replies,opening,canonical,acceptedOriginal⟩ + +end Driver +#print axioms base_eq_sourceRoot +#print axioms original_bound +#print axioms mixed_success_original_experiment +#print axioms nativeReplies_indexed +end Whir.PCSBCSNativeSourceOriginal diff --git a/verification/whir/Whir/PCSBCSNativeSourceTables.lean b/verification/whir/Whir/PCSBCSNativeSourceTables.lean new file mode 100644 index 000000000..661c517e7 --- /dev/null +++ b/verification/whir/Whir/PCSBCSNativeSourceTables.lean @@ -0,0 +1,54 @@ +import Whir.PCSBCSCapturedIdealNativeAcceptance + +/-! Every typed atomic table has exactly the mixed seed/raw interpretation +used by the actual native driver. This is an inverse of existing partitions, +not an independence assumption or a distribution replacement. -/ +set_option autoImplicit false +namespace Whir.PCSBCSNativeSourceTables +open Concrete FiatShamirGame DuplexModeGame TypedOracleCompiler RawOracleCoupling +open PCSBCSChallengeOracle TypedFiatShamirGame PCSStateRestoration.Latent + +variable {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer (p := p) (Q := B) (iv := iv) (boundary := boundary) + +theorem every_table (table : Table Keys Answers) : + ∃ (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32), + (part).split (PublicCompressionCouplingMixed.oracle seed ro) = table := by + let pair := PublicCompressionCouplingMixed.tableEquiv B ((part).join table) + refine ⟨pair.1,pair.2,?_⟩ + have joined : PublicCompressionCouplingMixed.oracle pair.1 pair.2 = (part).join table := + (PublicCompressionCouplingMixed.tableEquiv B).left_inv ((part).join table) + rw [joined] + exact (part).split_join table + +section Driver +variable (cap : Nat) (model : WHIRCallerSupport.ProductionLayout) + (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) (Q : Nat) + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + (proofs : Array MerkleTransport.PrunedMerklePaths) (B : Nat) + (limit : WHIRPhysicalVerifier.sourceBudget ctx Q packet ≤ B) + +theorem allocation_table + (table : Table + (PCSBCSSourceRootCapture.Key (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length)) + (PCSBCSSourceRootCapture.Answer (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := (RawWHIRKeys.entry ctx packet.val).frames.length))) : + ∃ (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32), + PCSBCSCapturedIdealNativeAcceptance.table ctx Q packet B seed ro = table ∧ + Sampling.eval table (PCSBCSCapturedIdealNativeAcceptance.allocationProgram + cap model ctx stack Q packet saved proofs B limit) = + AnchoredMixedIdealSourceAcceptance.mixedView cap .fresh model ctx stack Q packet saved proofs + ctx.iv B limit seed ro := by + obtain ⟨seed,ro,equal⟩ := every_table table + refine ⟨seed,ro,equal,?_⟩ + rw [← equal] + exact PCSBCSCapturedIdealNativeAcceptance.allocation_result + cap model ctx stack Q packet saved proofs B limit seed ro +end Driver + +#print axioms every_table +#print axioms allocation_table +end Whir.PCSBCSNativeSourceTables diff --git a/verification/whir/Whir/PCSBCSObservedPrimitiveExtension.lean b/verification/whir/Whir/PCSBCSObservedPrimitiveExtension.lean new file mode 100644 index 000000000..5b69f7fa8 --- /dev/null +++ b/verification/whir/Whir/PCSBCSObservedPrimitiveExtension.lean @@ -0,0 +1,113 @@ +import Whir.DuplexPublicSimulator +import Whir.AnchoredPrimitivePhysicalSnapshots +import Whir.WHIRSourceResolver + +/-! The observed primitive table extends the actual fallback seed on unobserved +inputs. This construction makes no uniformity claim for the extension and does +not identify independent construction answers with compression evaluations. -/ +set_option autoImplicit false +namespace Whir.PCSBCSObservedPrimitiveExtension +open Concrete FiatShamirGame DuplexFraming DuplexModeGame DuplexPublicSimulator + +def extension (seed : Seed) (log : PublicLog) : Node → Digest32 := + fun input => match lookup log input with + | some answer => answer + | none => seed input + +theorem extension_of_mem (seed : Seed) {log : PublicLog} + (functional : Functional log) {input : Node} {answer : Digest32} + (member : (input,answer) ∈ log) : extension seed log input = answer := by + obtain ⟨value,found⟩ := lookup_exists member + have same := functional input value answer (lookup_mem found) member + simp [extension,found,same] + +theorem primitive_in_finalLog (log : PublicLog) (observations : List Observation) + (purpose : Purpose) (input : Node) (answer : Digest32) + (member : (⟨.primitive purpose input,answer⟩ : Observation) ∈ observations) : + (input,answer) ∈ finalLog log observations := by + induction observations generalizing log with + | nil => simp at member + | cons observation rest ih => + rcases observation with ⟨query,value⟩ + rcases List.mem_cons.mp member with same | later + · cases same + exact finalLog_contains _ rest _ (List.mem_cons_self) + · cases query with + | primitive purpose node => exact ih _ later + | construction coordinate valid => exact ih _ later + +theorem finalLog_consistent (seed : Seed) (observations : List Observation) + (functional : Functional (finalLog [] observations)) : + ∀ observation ∈ observations, + match observation.query with + | .primitive _ input => + observation.answer = extension seed (finalLog [] observations) input + | _ => True := by + intro observation member + rcases observation with ⟨query,answer⟩ + cases query with + | primitive purpose input => + exact (extension_of_mem seed functional + (primitive_in_finalLog [] observations purpose input answer member)).symm + | construction coordinate valid => trivial + +theorem answer_in_observations {cap : Nat} (events : List (WHIRSourceChronology.Event cap)) + (query : Query) (answer : Digest32) + (member : WHIRSourceChronology.Event.answer query answer ∈ events) : + (⟨query,answer⟩ : Observation) ∈ WHIRSourceChronology.observations events := by + induction events with + | nil => simp at member + | cons event rest ih => + rcases List.mem_cons.mp member with same | later + · cases same + exact List.mem_cons_self + · cases event with + | answer query value => exact List.mem_cons_of_mem _ (ih later) + | commit root => exact ih later + | claims profile entry request => exact ih later + +/-- Every actual ideal source execution has its historical physical registry +invariant for the observed primitive extension. No consistency certificate for +the adversary's nonordinary primitive queries or construction replies is assumed. +The extension need not be uniform; this is not a Merkle security bound. -/ +theorem ideal_snapshot {Q cap : Nat} {R : Type} (seed : Seed) + (ro : RawKey Q → Digest32) (iv : Digest32) + (source : WHIRSourceChronology.Source cap R) (remaining : Nat) + (limit : remaining ≤ Q) (counted : WHIRSourceChronology.Counts remaining source) : + let execution := runIdeal (simulator Q) ro iv ((simulator Q).initial seed) + (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted) + WHIRPhysicalSnapshots.Invariant + (extension seed (finalLog [] execution.view.observations)) + (WHIRSourceObserver.replayTracked (CausalBindingState.empty cap) + execution.view.result.events) := by + let execution := runIdeal (simulator Q) ro iv ((simulator Q).initial seed) + (WHIRSourceChronology.compile source) remaining limit + ((WHIRSourceChronology.compile_counted source remaining).mpr counted) + change WHIRPhysicalSnapshots.Invariant + (extension seed (finalLog [] execution.view.observations)) + (WHIRSourceObserver.replayTracked (CausalBindingState.empty cap) execution.view.result.events) + apply AnchoredPrimitivePhysicalSnapshots.replayTracked_empty_invariant + intro event member + cases event with + | answer query answer => + cases query with + | primitive purpose input => + have observed : (⟨.primitive purpose input,answer⟩ : Observation) ∈ + execution.view.observations := by + rw [← WHIRSourceResolver.ideal_source_trace (simulator Q) ro iv + ((simulator Q).initial seed) source remaining limit counted] + exact answer_in_observations _ _ _ member + exact finalLog_consistent seed _ (finalLog_functional ro iv + ((simulator Q).initial seed) _ remaining limit _ + (by simp [simulator,Functional])) _ observed + | construction coordinate valid => trivial + | commit root => trivial + | claims profile entry request => trivial + +#print axioms extension_of_mem +#print axioms primitive_in_finalLog +#print axioms finalLog_consistent +#print axioms answer_in_observations +#print axioms ideal_snapshot +end Whir.PCSBCSObservedPrimitiveExtension diff --git a/verification/whir/Whir/PCSBCSPublicCallerAnswers.lean b/verification/whir/Whir/PCSBCSPublicCallerAnswers.lean new file mode 100644 index 000000000..14c899e79 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicCallerAnswers.lean @@ -0,0 +1,92 @@ +import Whir.PublicCompressionProgram + +/-! Caller challenge answers recovered only from a supplied earlier physical +compression log. No private primitive oracle, future log, or output-table getter +is evaluated by the decoder. Completeness is proved for literal construction +traces; relating such a trace to a particular source boundary remains explicit. -/ +set_option autoImplicit false +namespace Whir.PCSBCSPublicCallerAnswers +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler PublicCompressionProgram PublicMerkleLog + +/-- Replay one exact duplex plan using public cache lookups. Absence rejects. -/ +def replayFrom (log : PublicLog) (cv : Digest32) : + List DuplexEncoding.Instruction → Option Digest32 + | [] => some cv + | instruction :: rest => do + let answer ← PublicMerkleLog.lookup log ⟨cv,instruction.1,instruction.2,true⟩ + replayFrom log answer rest + +/-- The complete source coordinate determines its literal tagged input plan. -/ +def answer? (log : PublicLog) (iv : Digest32) (coordinate : Coordinate) : Option Digest32 := + replayFrom log iv (DuplexEncoding.plan coordinate) + +/-- Total scanner callbacks can use an inert default on a missing caller query. +This default is not authenticated or asserted to be a real caller answer. -/ +def answer (log : PublicLog) (iv : Digest32) (coordinate : Coordinate) : Digest32 := + (answer? log iv coordinate).getD (fun _ => 0) + +theorem replayFrom_sound (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (cv : Digest32) (plan : List DuplexEncoding.Instruction) + (result : Digest32) (accepted : replayFrom log cv plan = some result) : + evalPlan (compressionOf C) cv plan = result := by + induction plan generalizing cv with + | nil => simpa only [replayFrom,Option.some.injEq,evalPlan,List.foldl_nil] using accepted + | cons instruction rest ih => + simp only [replayFrom,Option.bind_eq_bind] at accepted + obtain ⟨value,found,next⟩ := Option.bind_eq_some_iff.mp accepted + have actual := auth _ _ (lookup_mem found) + change evalPlan (compressionOf C) (C ⟨cv,instruction.1,instruction.2,true⟩) rest = result + rw [actual] + exact ih value next + +theorem answer_sound (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (iv : Digest32) (coordinate : Coordinate) + (result : Digest32) (accepted : answer? log iv coordinate = some result) : + evalCoordinate (compressionOf C) iv coordinate = result := by + rw [← plan_evaluate] + exact replayFrom_sound C log auth iv _ result accepted + +/-- Every recorded plan node suffices, regardless of cache order or duplicates. -/ +theorem replayFrom_complete (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (cv : Digest32) (plan : List DuplexEncoding.Instruction) + (present : ∀ event ∈ toLog (Sampling.execute C (planCalls cv plan)).2, event ∈ log) : + replayFrom log cv plan = some (evalPlan (compressionOf C) cv plan) := by + induction plan generalizing cv with + | nil => rfl + | cons instruction rest ih => + have head := present (⟨cv,instruction.1,instruction.2,true⟩, + C ⟨cv,instruction.1,instruction.2,true⟩) (by simp [planCalls,Sampling.execute,toLog]) + have found := lookup_authentic_member C log auth head + simp only [replayFrom,found,Option.bind_eq_bind,Option.bind_some] + change replayFrom log (C ⟨cv,instruction.1,instruction.2,true⟩) rest = + some (evalPlan (compressionOf C) (C ⟨cv,instruction.1,instruction.2,true⟩) rest) + apply ih + intro event member + apply present event + simp only [planCalls,Sampling.execute,toLog,List.map_cons,List.mem_cons] + exact Or.inr member + +/-- A literal earlier complete construction trace yields its actual caller coin. +The decoder takes only that log, not the primitive oracle used in this theorem. -/ +theorem answer_from_recorded_construction (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (iv : Digest32) (coordinate : Coordinate) + (present : ∀ event ∈ toLog (Sampling.execute C + (planCalls iv (DuplexEncoding.plan coordinate))).2, event ∈ log) : + answer? log iv coordinate = some (evalCoordinate (compressionOf C) iv coordinate) := by + unfold answer? + rw [replayFrom_complete C log auth iv _ present,plan_evaluate] + +theorem answer_from_literal_trace (C : PrimitiveOracle) (iv : Digest32) + (coordinate : Coordinate) : + answer? (toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan coordinate))).2) + iv coordinate = some (evalCoordinate (compressionOf C) iv coordinate) := by + apply answer_from_recorded_construction C _ (execute_authentic C _) iv coordinate + exact fun _ member => member + +#print axioms replayFrom_sound +#print axioms answer_sound +#print axioms replayFrom_complete +#print axioms answer_from_recorded_construction +#print axioms answer_from_literal_trace +end Whir.PCSBCSPublicCallerAnswers diff --git a/verification/whir/Whir/PCSBCSPublicCallerAnswersCost.lean b/verification/whir/Whir/PCSBCSPublicCallerAnswersCost.lean new file mode 100644 index 000000000..fa0f945aa --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicCallerAnswersCost.lean @@ -0,0 +1,56 @@ +import Whir.PCSBCSPublicCallerAnswers +import Whir.MerkleQueryLogExtractionPublicCost + +/-! Actual reached primitive-record comparisons for public caller answer replay. +One comparison examines a fixed 32-byte CV, 64-byte block, counter and final bit. +This is a structural cost, not native CPU time or allocator certification. -/ +set_option autoImplicit false +namespace Whir.PCSBCSPublicCallerAnswers +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame PublicMerkleLog + +/-- Missing earlier nodes stop the same executable replay immediately. -/ +def replayFromCounted (log : PublicLog) (cv : Digest32) : + List DuplexEncoding.Instruction → Option Digest32 × Nat + | [] => (some cv,1) + | instruction :: rest => + let found := MerkleQueryLogExtraction.PublicCost.lookup log ⟨cv,instruction.1,instruction.2,true⟩ + match found.1 with + | none => (none,found.2+1) + | some result => + let later := replayFromCounted log result rest + (later.1,found.2+later.2+1) + +theorem replayFromCounted_value (log : PublicLog) (cv : Digest32) + (plan : List DuplexEncoding.Instruction) : + (replayFromCounted log cv plan).1 = replayFrom log cv plan := by + induction plan generalizing cv with + | nil => rfl + | cons instruction rest ih => + simp only [replayFromCounted,replayFrom, + MerkleQueryLogExtraction.PublicCost.lookup_value,Option.bind_eq_bind] + split + · rename_i found + simp only [found,Option.bind_none] + · rename_i result found + simpa only [found,Option.bind_some] using ih result + +theorem replayFromCounted_work (log : PublicLog) (cv : Digest32) + (plan : List DuplexEncoding.Instruction) : + (replayFromCounted log cv plan).2 ≤ plan.length*(log.length+1)+1 := by + induction plan generalizing cv with + | nil => simp only [replayFromCounted,List.length_nil,Nat.zero_mul,Nat.zero_add,le_refl] + | cons instruction rest ih => + have scan := MerkleQueryLogExtraction.PublicCost.lookup_steps log + ⟨cv,instruction.1,instruction.2,true⟩ + simp only [replayFromCounted] + split + · simp only [List.length_cons] + nlinarith + · rename_i result found + have later := ih result + simp only [List.length_cons] + nlinarith + +#print axioms replayFromCounted_value +#print axioms replayFromCounted_work +end Whir.PCSBCSPublicCallerAnswers diff --git a/verification/whir/Whir/PCSBCSPublicCallerAnswersSmoke.lean b/verification/whir/Whir/PCSBCSPublicCallerAnswersSmoke.lean new file mode 100644 index 000000000..3a3f469fa --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicCallerAnswersSmoke.lean @@ -0,0 +1,60 @@ +import Whir.PCSBCSPublicCallerAnswersCost + +namespace Whir.PCSBCSPublicCallerAnswersSmoke +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram PublicMerkleLog PCSBCSPublicCallerAnswers + +private def bytes (n : Nat) : List Byte := + (List.range n).map fun i => ⟨(13*i+7)%256,Nat.mod_lt _ (by decide)⟩ + +private def digest (salt : Nat) : Digest32 := fun i => + ⟨(17*i.val+salt)%256,Nat.mod_lt _ (by decide)⟩ + +private def recordPlan (cv : Digest32) : List DuplexEncoding.Instruction → PublicLog + | [] => [] + | instruction :: rest => + let node : Node := ⟨cv,instruction.1,instruction.2,true⟩ + let stored := Array.ofFn (blake2sOracle node) + let result : Digest32 := fun i => stored[i.val]'(by simp [stored]) + (node,result) :: recordPlan result rest + +private def check (label : String) (passed : Bool) : IO Unit := do + unless passed do throw (IO.userError (label ++ ": FAILED")) + +private def runCase (size block : Nat) : IO Unit := do + let coordinate : Coordinate := + ⟨⟨digest 1,digest 2,[.absorb 0 (bytes size)]⟩,.output block⟩ + let plan := DuplexEncoding.plan coordinate + let log := recordPlan DuplexCompression.parameterIV plan + let expected := log.getLast?.map Prod.snd + check "actual recorded caller digest" (answer? log DuplexCompression.parameterIV coordinate == expected) + check "reordered authentic cache" (answer? log.reverse DuplexCompression.parameterIV coordinate == expected) + check "missing terminal physical input rejects" ((answer? log.dropLast DuplexCompression.parameterIV coordinate).isNone) + check "missing seed input rejects" ((answer? log.tail DuplexCompression.parameterIV coordinate).isNone) + let counted := replayFromCounted log DuplexCompression.parameterIV plan + check "counted replay preserves real digest" (counted.1 == expected) + check "reached lookup comparisons" (counted.2 == plan.length*(plan.length+1)/2+plan.length+1) + let absent := replayFromCounted [] DuplexCompression.parameterIV plan + check "missing earlier prefix has no synthetic answer" (absent.1.isNone && absent.2 == 1) + check "wrong source domain rejects" ((answer? log DuplexCompression.parameterIV + {coordinate with history := {coordinate.history with domain := digest 3}}).isNone) + check "wrong output coordinate rejects" ((answer? log DuplexCompression.parameterIV + {coordinate with terminal := .output (block+1)}).isNone) + +private def smoke : IO Unit := do + for size in [0,1,24,64,65,128,129] do + runCase size 0 + runCase size 1 + let coordinate : Coordinate := ⟨⟨digest 1,digest 2,[]⟩,.output 0⟩ + let log := recordPlan DuplexCompression.parameterIV (DuplexEncoding.plan coordinate) + let wrong := digest 99 + match log with + | [] => throw (IO.userError "fixture produced no physical plan") + | (node,_)::rest => + check "inconsistent earlier cache cannot authenticate a caller stream" + ((answer? ((node,wrong)::rest) DuplexCompression.parameterIV coordinate).isNone) + IO.println "Real BLAKE2s public caller replay: complete/reordered, missing/foreign, counted bounds OK" + +end Whir.PCSBCSPublicCallerAnswersSmoke + +def main : IO Unit := Whir.PCSBCSPublicCallerAnswersSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSPublicCallerCompletion.lean b/verification/whir/Whir/PCSBCSPublicCallerCompletion.lean new file mode 100644 index 000000000..08128aad6 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicCallerCompletion.lean @@ -0,0 +1,327 @@ +import Whir.PCSBCSPublicCallerAnswers +import Whir.PCSBCSSourceCallerOriginal + +/-! Public caller completion executes missing literal construction plans through +`Sampling`, retaining every reached primitive observation in chronological order. +Existing answers and duplicate coordinates are replayed without oracle draws. +This is a deterministic reconstruction lemma, not a Fiat--Shamir security theorem +or a conversion to a newest-first, strictly-earlier source log. Integration must +still relate these real mode answers to the finite source table and establish +causality of the generated primitive queries at the selected source boundary. -/ +set_option autoImplicit false +namespace Whir.PCSBCSPublicCallerCompletion +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler PublicCompressionProgram PublicMerkleLog +open PCSBCSPublicCallerAnswers + +/-- Instrument an actual primitive computation, without changing its draws. -/ +def record {R : Type} {Q : Nat} : Computation R Q → Computation (R × PublicLog) Q + | .ret r => .ret (r,[]) + | .draw n next => .draw n (fun d => + mapResult (fun result => (result.1,(n,d) :: result.2)) (record (next d))) + +theorem record_execute {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) : + Sampling.execute C (record p) = + (((Sampling.execute C p).1,toLog (Sampling.execute C p).2), + (Sampling.execute C p).2) := by + induction p with + | ret => rfl + | draw n next ih => + simp only [record,Sampling.execute,execute_mapResult,ih,toLog,List.map_cons] + +@[simp] theorem record_eval {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) : + Sampling.eval C (record p) = + (Sampling.eval C p,toLog (Sampling.execute C p).2) := by + have h := congrArg Prod.fst (record_execute C p) + simpa only [Sampling.execute_value] using h + +/-- A structural cap computed from the literal requests, never supplied by a caller. -/ +@[reducible] def budget : List Coordinate → Nat + | [] => 0 + | q :: rest => (DuplexEncoding.plan q).length + budget rest + +theorem budget_sum (requests : List Coordinate) : + budget requests = (requests.map pathCost).sum := by + induction requests with + | nil => rfl + | cons q rest ih => simp only [budget,List.map_cons,List.sum_cons,pathCost,ih] + +/-- The cache grows only by observations made by the real primitive oracle. +A missing output executes the entire literal plan; it never evaluates a pure C +callback, invents a digest, or accepts an external completion certificate. -/ +def complete (iv : Digest32) (log : PublicLog) : + (requests : List Coordinate) → Computation PublicLog (budget requests) + | [] => .ret log + | q :: rest => + match answer? log iv q with + | some _ => Sampling.pad (by simp [budget]) (complete iv log rest) + | none => Sampling.bind (record (planCalls iv (DuplexEncoding.plan q))) + (fun observed => complete iv (log ++ observed.2) rest) + +/-- The returned log is exactly the old log followed by the actual reached +chronological trace. Padding the cap introduces no physical operation. -/ +theorem complete_log (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (requests : List Coordinate) : + (Sampling.execute C (complete iv log requests)).1 = + log ++ toLog (Sampling.execute C (complete iv log requests)).2 := by + induction requests generalizing log with + | nil => simp [complete,Sampling.execute,toLog] + | cons q rest ih => + simp only [complete] + split + · simpa only [Sampling.execute_pad] using ih log + · simp only [Sampling.execute_bind,record_eval,record_execute] + rw [ih] + simp only [toLog,List.map_append,List.append_assoc] + +/-- All generated records are authentic, independently of the initial cache. -/ +theorem generated_authentic (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (requests : List Coordinate) : + AuthenticLog C (toLog (Sampling.execute C (complete iv log requests)).2) := + execute_authentic C _ + +theorem complete_authentic (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (requests : List Coordinate) : + AuthenticLog C (Sampling.execute C (complete iv log requests)).1 := by + rw [complete_log] + intro n d member + rcases List.mem_append.mp member with old | fresh + · exact auth n d old + · exact generated_authentic C iv log requests n d fresh + +theorem complete_preserves (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (requests : List Coordinate) (event : Node × Digest32) + (member : event ∈ log) : + event ∈ (Sampling.execute C (complete iv log requests)).1 := by + rw [complete_log] + exact List.mem_append_left _ member + +/-- Authentic extension cannot change a successfully replayed public answer. -/ +theorem replayFrom_extension (C : PrimitiveOracle) (old new : PublicLog) + (auth : AuthenticLog C new) (contains : ∀ event ∈ old, event ∈ new) + (cv : Digest32) (plan : List DuplexEncoding.Instruction) (d : Digest32) + (accepted : replayFrom old cv plan = some d) : + replayFrom new cv plan = some d := by + induction plan generalizing cv with + | nil => exact accepted + | cons instruction rest ih => + simp only [replayFrom,Option.bind_eq_bind] at accepted + obtain ⟨value,found,later⟩ := Option.bind_eq_some_iff.mp accepted + have member := contains _ (lookup_mem found) + have actual := auth _ _ member + have present := lookup_authentic_member C new auth member + rw [actual] at present + simp only [replayFrom,present,Option.bind_eq_bind,Option.bind_some] + exact ih value later + +theorem answer_extension (C : PrimitiveOracle) (old new : PublicLog) + (auth : AuthenticLog C new) (contains : ∀ event ∈ old, event ∈ new) + (iv : Digest32) (q : Coordinate) (d : Digest32) + (accepted : answer? old iv q = some d) : answer? new iv q = some d := + replayFrom_extension C old new auth contains iv _ d accepted + +/-- Every requested getter actually succeeds and returns the real mode answer. +There is no hypothesis that an earlier output had already been queried. -/ +theorem complete_answers (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (requests : List Coordinate) : + ∀ q ∈ requests, answer? (Sampling.execute C (complete iv log requests)).1 iv q = + some (evalCoordinate (compressionOf C) iv q) := by + induction requests generalizing log with + | nil => simp + | cons q rest ih => + cases found : answer? log iv q with + | some d => + have actual := answer_sound C log auth iv q d found + simp only [complete,found,Sampling.execute_pad] + intro r member + rcases List.mem_cons.mp member with equal | member + · subst r + rw [actual] + exact answer_extension C log _ (complete_authentic C iv log auth rest) + (complete_preserves C iv log rest) iv q d found + · exact ih log auth r member + | none => + let trace := toLog (Sampling.execute C + (planCalls iv (DuplexEncoding.plan q))).2 + have extendedAuth : AuthenticLog C (log ++ trace) := by + intro n d member + rcases List.mem_append.mp member with old | fresh + · exact auth n d old + · exact execute_authentic C (planCalls iv (DuplexEncoding.plan q)) n d fresh + have accepted : answer? (log ++ trace) iv q = + some (evalCoordinate (compressionOf C) iv q) := by + apply answer_from_recorded_construction C _ extendedAuth iv q + exact fun event member => List.mem_append_right _ member + simp only [complete,found,Sampling.execute_bind,record_eval] + change ∀ r ∈ q :: rest, + answer? (Sampling.execute C (complete iv (log ++ trace) rest)).1 iv r = + some (evalCoordinate (compressionOf C) iv r) + intro r member + rcases List.mem_cons.mp member with equal | member + · subst r + exact answer_extension C (log ++ trace) _ + (complete_authentic C iv _ extendedAuth rest) + (complete_preserves C iv (log ++ trace) rest) iv q _ accepted + · exact ih (log ++ trace) extendedAuth r member + +/-- Count actual reached compression draws, not nominal fees. -/ +theorem complete_draws_le (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (requests : List Coordinate) : + (Sampling.execute C (complete iv log requests)).2.length ≤ + (requests.map pathCost).sum := by + simpa only [budget_sum] using + (Sampling.execute_runs C (complete iv log requests)).length_le + +/-- Exact operational accounting for a missing head request. -/ +theorem missing_draws (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (q : Coordinate) (rest : List Coordinate) (missing : answer? log iv q = none) : + (Sampling.execute C (complete iv log (q :: rest))).2.length = pathCost q + + (Sampling.execute C (complete iv + (log ++ toLog (Sampling.execute C (planCalls iv (DuplexEncoding.plan q))).2) + rest)).2.length := by + simp only [complete,missing,Sampling.execute_bind,record_eval,record_execute, + List.length_append,planCalls_count,pathCost] + +/-- Literal plans have both a seed and a terminal, even for empty histories. -/ +theorem pathCost_nonempty (q : Coordinate) : 2 ≤ pathCost q := by + simp [pathCost,DuplexEncoding.plan] + +/-- Absence cannot silently return a placeholder: it reaches at least the +literal seed and terminal draws before proceeding to the remaining requests. -/ +theorem missing_has_draws (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (q : Coordinate) (rest : List Coordinate) (missing : answer? log iv q = none) : + 2 ≤ (Sampling.execute C (complete iv log (q :: rest))).2.length := by + rw [missing_draws C iv log q rest missing] + have nonempty := pathCost_nonempty q + omega + +/-- An already observed answer is reused and costs no primitive draw. -/ +theorem reuse (C : PrimitiveOracle) (iv : Digest32) (log : PublicLog) + (q : Coordinate) (d : Digest32) (present : answer? log iv q = some d) : + Sampling.execute C (complete iv log [q]) = (log,[]) := by + simp [complete,present,Sampling.execute] + +/-- In particular, completing a previously requested duplicate is draw-free. -/ +theorem completed_reuse (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (requests : List Coordinate) + (q : Coordinate) (member : q ∈ requests) : + Sampling.execute C (complete iv + (Sampling.execute C (complete iv log requests)).1 [q]) = + ((Sampling.execute C (complete iv log requests)).1,[]) := + reuse C iv _ q _ (complete_answers C iv log auth requests q member) + +/-- Entry-level executable completion. No frame-validity or admissibility +assumption is needed for the literal evaluation/replay identity. -/ +def callerCompletion (iv : Digest32) (log : PublicLog) (entry : FramedHistory) : + Computation PublicLog (budget (WHIRCallerOutputs.callerOutputs entry)) := + complete iv log (WHIRCallerOutputs.callerOutputs entry) + +theorem callerCompletion_answers (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (entry : FramedHistory) : + ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, + answer? (Sampling.execute C (callerCompletion iv log entry)).1 iv q = + some (evalCoordinate (compressionOf C) iv q) := + complete_answers C iv log auth _ + +/-- Successful totality of every requested public getter. -/ +theorem callerCompletion_total (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (entry : FramedHistory) : + ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, + (answer? (Sampling.execute C (callerCompletion iv log entry)).1 iv q).isSome := by + intro q member + rw [callerCompletion_answers C iv log auth entry q member] + rfl + +/-- A total, fallback-free getter on precisely the requested finite domain. +This getter takes only the completed public log, never the primitive oracle. +The proof removes the impossible `none` branch; it supplies no digest. -/ +def callerGetter (iv : Digest32) (log : PublicLog) (entry : FramedHistory) + (available : ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, (answer? log iv q).isSome) + (q : {q : Coordinate // q ∈ WHIRCallerOutputs.callerOutputs entry}) : Digest32 := + (answer? log iv q.val).get (available q.val q.property) + +theorem callerGetter_correct (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (entry : FramedHistory) + (available : ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, (answer? log iv q).isSome) + (q : {q : Coordinate // q ∈ WHIRCallerOutputs.callerOutputs entry}) : + callerGetter iv log entry available q = evalCoordinate (compressionOf C) iv q.val := + (answer_sound C log auth iv q.val _ + (Option.some_get (available q.val q.property)).symm).symm + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +/-- Executable scanner callback. Every requested coordinate uses the actual +public getter, with no missing-answer fallback. The separate outside callback +is used only for coordinates the caller does not observe, never for absence. -/ +def callerAnswers (iv : Digest32) (log : PublicLog) (entry : FramedHistory) + (available : ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, (answer? log iv q).isSome) + (outside : Coordinate → Digest32) (q : Coordinate) : Digest32 := + if member : q ∈ WHIRCallerOutputs.callerOutputs entry then + callerGetter iv log entry available ⟨q,member⟩ + else outside q + +theorem callerAnswers_on (iv : Digest32) (log : PublicLog) (entry : FramedHistory) + (available : ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, (answer? log iv q).isSome) + (outside : Coordinate → Digest32) (q : Coordinate) + (member : q ∈ WHIRCallerOutputs.callerOutputs entry) : + callerAnswers iv log entry available outside q = + callerGetter iv log entry available ⟨q,member⟩ := by + simp only [callerAnswers,dite_eq_left member] + + +/-- The scanner may use any total extension of the actual finite getter. Its +values outside callerOutputs are irrelevant, including for parser failures. -/ +theorem original_completed (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (entry : FramedHistory) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (answers : Coordinate → Digest32) + (extendsGetter : ∀ q (member : q ∈ WHIRCallerOutputs.callerOutputs entry), + answers q = callerGetter iv (Sampling.execute C (callerCompletion iv log entry)).1 + entry (callerCompletion_total C iv log auth entry) ⟨q,member⟩) : + PCSBCSSourceCallerOriginal.original p layout saved entry answers = + PCSBCSSourceCallerOriginal.original p layout saved entry + (evalCoordinate (compressionOf C) iv) := by + apply PCSBCSSourceCallerOriginal.original_prior_only + intro q member + rw [extendsGetter q member] + exact callerGetter_correct C iv _ (complete_authentic C iv log auth _) + entry _ ⟨q,member⟩ + +/-- End-to-end original caller equality for the concrete public callback: +no extensional-answer premise or supplied completion digest is required. -/ +theorem original_resolved (C : PrimitiveOracle) (iv : Digest32) + (log : PublicLog) (auth : AuthenticLog C log) (entry : FramedHistory) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (outside : Coordinate → Digest32) : + PCSBCSSourceCallerOriginal.original p layout saved entry + (callerAnswers iv (Sampling.execute C (callerCompletion iv log entry)).1 + entry (callerCompletion_total C iv log auth entry) outside) = + PCSBCSSourceCallerOriginal.original p layout saved entry + (evalCoordinate (compressionOf C) iv) := by + apply original_completed C iv log auth entry p layout saved + intro q member + exact callerAnswers_on iv _ entry _ outside q member + + +#print axioms complete_log +#print axioms complete_authentic +#print axioms complete_answers +#print axioms complete_draws_le +#print axioms missing_draws +#print axioms missing_has_draws +#print axioms completed_reuse +#print axioms callerGetter_correct +#print axioms original_completed +#print axioms original_resolved +end Whir.PCSBCSPublicCallerCompletion diff --git a/verification/whir/Whir/PCSBCSPublicExtractor.lean b/verification/whir/Whir/PCSBCSPublicExtractor.lean new file mode 100644 index 000000000..5c75f9d3d --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicExtractor.lean @@ -0,0 +1,528 @@ +import Whir.PCSBCSNativePublicCapture +import Whir.PCSBCSSourcePrimitiveRootBudget +import Whir.PCSBCSSourceRootAdmission +import Whir.PCSBCSWholeSourceObserver + +/-! Executable public raw-key reference classification. The parser checks the +full physical key, public boundary, pending schedule and packet block range. +It does not enumerate the mathematical atomic packet carrier. -/ +set_option autoImplicit false +set_option backward.isDefEq.respectTransparency false +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSPublicExtractor +open Concrete Protocol FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache PCSBCSChallengeOracle + +private theorem parsed_output (p : ParameterBounds.Profile) (entry : FramedHistory) + (q : FiatShamirGame.Coordinate) (messages : List WHIRHistory.Pending) (block : Nat) + (parsed : parsePendingKey p entry q = some messages) (terminal : q.terminal = .output block) : + q = WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + entry messages block := by + obtain ⟨_,_,other,same⟩ := parsePendingKey_admitted p entry q messages parsed + have blocksSame : other = block := by + have h := congrArg FiatShamirGame.Coordinate.terminal same + simpa [WHIRCallerPrefix.outputKeyFrom,terminal] using h.symm + simpa [blocksSame] using same + +/-- The proofs are erased. Only the parsed history, schedule index and block are +materialized, rather than any finite enumeration of possible source packets. -/ +def fromDecoded (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) (boundary : Nat) + (key : RawKey B) (q : FiatShamirGame.Coordinate) + (decoded : PCSBCSSourceCoordinateDecoder.decode iv key = some q) + (entry : FramedHistory) (entryEq : entry = PCSBCSSourcePrimitiveRootBudget.entry q boundary) + (entryLength : entry.frames.length = boundary) + (messages : List WHIRHistory.Pending) (parsed : parsePendingKey p entry q = some messages) + (block : Nat) (terminal : q.terminal = .output block) + (blockBound : block < (WHIRHistoryKey.stackWidth (ParameterBounds.config p) + (messages.length-1)+31)/32) : + Sigma (EnteredPacket.Block (p := p) (Q := B) (iv := iv) (boundary := boundary)) := by + have nonempty := (parsePendingKey_admitted p entry q messages parsed).1 + have admitted := (parsePendingKey_admitted p entry q messages parsed).2.1 + have depthBound := WHIRHistory.scheduledAdmissible_depth (ParameterBounds.config p) messages admitted + have sizePositive : 0 < messages.length := List.length_pos_iff.mpr nonempty + have indexBound : messages.length-1 < WHIRHistory.depth (ParameterBounds.config p) := by omega + let coordinate := (WHIRHistory.schedule (ParameterBounds.config p))[messages.length-1]'indexBound + have positionEq : CausalProbability.position coordinate = messages.length-1 := + WHIRHistory.position_schedule_get (ParameterBounds.config p) ⟨messages.length-1,indexBound⟩ + have widthEq : WHIRHistoryKey.stackWidth (ParameterBounds.config p) (messages.length-1) = + 24*PCSBCSRounds.rawWidth coordinate := by + unfold WHIRHistoryKey.stackWidth + rw [← positionEq,WHIRHistory.schedule_get_position] + rfl + have same := parsed_output p entry q messages block parsed terminal + have entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f := by + intro f member + have valid := (PCSBCSSourceCoordinateDecoder.decode_iff iv key q).mp decoded |>.1 + apply valid.1 f + rw [entryEq] at member + exact List.mem_of_mem_take member + have paths : ∀ b : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth coordinate)), + pathCost (WHIRCallerPrefix.outputKeyFrom + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) entry messages b.val) ≤ B := by + intro b + have bound := PCSBCSSourceCoordinateDecoder.decode_pathBound decoded + rw [same] at bound + rw [WHIRCallerPrefix.pathCostFrom _ (WHIRHistoryKey.stackWidth_positive p) entry + (WHIRHistoryKey.scheduled_normal _ _ nonempty admitted) b.val] + rw [WHIRCallerPrefix.pathCostFrom _ (WHIRHistoryKey.stackWidth_positive p) entry + (WHIRHistoryKey.scheduled_normal _ _ nonempty admitted) block] at bound + exact bound + let source : SourcePacket p B iv entry coordinate := + ⟨messages,nonempty,admitted,entryValid,positionEq.symm,paths⟩ + let packet : EnteredPacket p B iv boundary := ⟨⟨entry,entryLength⟩,⟨coordinate,source⟩⟩ + have bounded : block < PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth coordinate) := by + rw [widthEq] at blockBound + simpa [PCSBCSChallengeOracle.blocks,Nat.mul_comm] using blockBound + exact ⟨packet,⟨block,bounded⟩⟩ + +/-- Decode once; fake output blocks outside the grouped packet cannot disclose +an atomic root even when the remaining pending bytes parse. -/ +def recognize (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : + Option (Sigma (EnteredPacket.Block (p := p) (Q := B) (iv := iv) (boundary := boundary))) := + match raw with + | .inl _ => none + | .inr key => + match decoded : PCSBCSSourceCoordinateDecoder.decode iv key with + | none => none + | some q => + let entry := PCSBCSSourcePrimitiveRootBudget.entry q boundary + if entryLength : entry.frames.length = boundary then + match parsed : parsePendingKey p entry q with + | none => none + | some messages => + match terminal : q.terminal with + | .output block => + if bound : block < (WHIRHistoryKey.stackWidth (ParameterBounds.config p) + (messages.length-1)+31)/32 then + some (fromDecoded p B iv boundary key q decoded entry rfl entryLength + messages parsed block terminal bound) + else none + | _ => none + else none + +section Parsed +variable (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) (boundary : Nat) + (key : RawKey B) (q : FiatShamirGame.Coordinate) + (decoded : PCSBCSSourceCoordinateDecoder.decode iv key = some q) + (entry : FramedHistory) (entryEq : entry = PCSBCSSourcePrimitiveRootBudget.entry q boundary) + (entryLength : entry.frames.length = boundary) + (messages : List WHIRHistory.Pending) (parsed : parsePendingKey p entry q = some messages) + (block : Nat) (terminal : q.terminal = .output block) + (blockBound : block < (WHIRHistoryKey.stackWidth (ParameterBounds.config p) + (messages.length-1)+31)/32) +local notation "position" => fromDecoded p B iv boundary key q decoded entry entryEq + entryLength messages parsed block terminal blockBound + +theorem fromDecoded_encode : EnteredPacket.encode position = .inr key := by + change Sum.inr (position.1.2.2.key position.2) = Sum.inr key + apply congrArg Sum.inr + apply PublicCompressionCouplingRecognition.expandKey_injective + dsimp only [fromDecoded,SourcePacket.key,SourcePacket.coordinate] + rw [expand_constructionKey,← parsed_output p entry q messages block parsed terminal] + exact ((PCSBCSSourceCoordinateDecoder.decode_iff iv key q).mp decoded).2.symm +end Parsed + +theorem recognize_sound (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) + (position : Sigma (EnteredPacket.Block (p := p) (Q := B) (iv := iv) (boundary := boundary))) + (found : recognize p B iv boundary raw = some position) : + EnteredPacket.encode position = raw := by + cases raw with + | inl input => simp [recognize] at found + | inr key => + simp only [recognize] at found + split at found + · contradiction + · + split at found + · split at found + · contradiction + · split at found + · split at found + · cases found + exact fromDecoded_encode _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + · contradiction + · contradiction + · contradiction + +theorem recognize_encode (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (packet : EnteredPacket p B iv boundary) + (block : EnteredPacket.Block packet) : + recognize p B iv boundary (EnteredPacket.encode ⟨packet,block⟩) = some ⟨packet,block⟩ := by + unfold EnteredPacket.Block at block + unfold CanonicalPacket.coord at block + have decoded : PCSBCSSourceCoordinateDecoder.decode iv (packet.2.2.key block) = + some (packet.2.2.coordinate block) := + PCSBCSSourceCoordinateDecoder.decode_constructionKey B iv + (packet.2.2.coordinate block) (packet.2.2.valid block) (packet.2.2.pathBound block) + have entryEq := PCSBCSSourceRootAdmission.packet_entry packet block + have parsed := parsePendingKey_roundtrip p packet.1.val packet.2.messages + packet.2.2.nonempty packet.2.2.admitted block.val + have blockBound : block.val < + (WHIRHistoryKey.stackWidth (ParameterBounds.config p) (packet.2.messages.length-1)+31)/32 := by + change block.val < (WHIRHistoryKey.stackWidth (ParameterBounds.config p) + (packet.2.2.messages.length-1)+31)/32 + rw [packet.2.2.width_eq] + exact block.isLt + have found : ∃ actual, recognize p B iv boundary + (EnteredPacket.encode ⟨packet,block⟩) = some actual := by + change ∃ actual, recognize p B iv boundary (.inr (packet.2.2.key block)) = some actual + simp only [recognize] + split + · rename_i missing + rw [decoded] at missing + cases missing + · rename_i coordinate foundCoordinate + have sameCoordinate := Option.some.inj (foundCoordinate.symm.trans decoded) + subst coordinate + have length : (PCSBCSSourcePrimitiveRootBudget.entry + (packet.2.2.coordinate block) boundary).frames.length = boundary := by + rw [entryEq] + exact packet.1.property + rw [dite_eq_left length] + have parsed' : parsePendingKey p + (PCSBCSSourcePrimitiveRootBudget.entry (packet.2.2.coordinate block) boundary) + (packet.2.2.coordinate block) = some packet.2.messages := by + rw [entryEq] + exact parsed + split + · rename_i missing + rw [parsed'] at missing + cases missing + · rename_i messages foundMessages + have sameMessages := Option.some.inj (foundMessages.symm.trans parsed') + subst messages + simp only [SourcePacket.coordinate,WHIRCallerPrefix.outputKeyFrom] + rw [dite_eq_left blockBound] + exact ⟨_,rfl⟩ + obtain ⟨actual,found⟩ := found + have equal : actual = ⟨packet,block⟩ := + EnteredPacket.encode_injective (recognize_sound p B iv boundary _ actual found) + simpa [equal] using found + +theorem recognize_partition (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : + recognize p B iv boundary raw = + (EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary)).recognize raw := by + cases found : recognize p B iv boundary raw with + | some position => + have encoded := recognize_sound p B iv boundary raw position found + rw [← encoded] + exact ((EnteredPacket.partition).recognize_encode position).symm + | none => + cases original : (EnteredPacket.partition (p := p) (Q := B) + (iv := iv) (boundary := boundary)).recognize raw with + | none => rfl + | some position => + have encoded := (EnteredPacket.partition).encode_recognize raw position original + change EnteredPacket.encode position = raw at encoded + have computed := recognize_encode p B iv boundary position.1 position.2 + rw [encoded,found] at computed + contradiction + +#print axioms fromDecoded_encode +#print axioms recognize_sound +#print axioms recognize_encode +#print axioms recognize_partition + +def packetReferences {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} + (packet : EnteredPacket p B iv boundary) : List Reference := + ((do + let saved ← PCSBCSSourceSavedRecordDecoder.decode p packet.1.val + if phaseRolesAdmitted (ParameterBounds.config p) packet.2.messages then + pure (⟨saved.root,initialShape saved.shape⟩ :: + phaseReferences (ParameterBounds.config p) packet.2.messages) + else none) : Option (List Reference)).getD [] + +theorem packetReferences_address {p : ParameterBounds.Profile} {B : Nat} + {iv : Digest32} {boundary : Nat} (packet : EnteredPacket p B iv boundary) : + packetReferences packet = PCSBCSCapturedSourceTransport.address + (p := p) (Q := B) (iv := iv) (boundary := boundary) (.inl packet) := by + unfold PCSBCSCapturedSourceTransport.address + PCSBCSSourcePrimitiveRootBudget.openingReferencesFromEntry packetReferences + have pending := parsePendingKey_roundtrip p packet.1.val packet.2.messages + packet.2.2.nonempty packet.2.2.admitted 0 + cases saved : PCSBCSSourceSavedRecordDecoder.decode p packet.1.val with + | none => simp [saved] + | some saved => + simp only [saved] + dsimp only [Bind.bind,Option.bind] + rw [pending] + +def rawReferences (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : List Reference := + match recognize p B iv boundary raw with + | none => [] + | some position => packetReferences position.1 + +theorem rawReferences_spec (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : + rawReferences p B iv boundary raw = PCSBCSCapturedSourceTransport.address + (p := p) (Q := B) (iv := iv) (boundary := boundary) + (PCSBCSNativePublicCapture.allocatedKey raw) := by + unfold rawReferences + cases found : recognize p B iv boundary raw with + | none => + dsimp only + have original : (EnteredPacket.partition (p := p) (Q := B) + (iv := iv) (boundary := boundary)).recognize raw = none := + (recognize_partition p B iv boundary raw).symm.trans found + unfold PCSBCSNativePublicCapture.allocatedKey + split + · rename_i position present + have impossible := original.symm.trans present + cases impossible + · rfl + | some position => + dsimp only + have original : (EnteredPacket.partition (p := p) (Q := B) + (iv := iv) (boundary := boundary)).recognize raw = some position := + (recognize_partition p B iv boundary raw).symm.trans found + unfold PCSBCSNativePublicCapture.allocatedKey + split + · rename_i actual present + have equal := Option.some.inj (present.symm.trans original) + subst actual + exact packetReferences_address position.1 + · rename_i missing + have impossible := original.symm.trans missing + cases impossible + +def capturedPrefix {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : + Option (List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) := + PCSBCSNativePublicCapture.firstPrefix (rawReferences p B iv boundary) ref + (PCSBCSNativePublicCapture.mixedTrace B iv [] view.observations) + +theorem prefix_spec {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : + capturedPrefix p B iv boundary ref view = + PCSBCSNativePublicCapture.publicPrefix + (p := p) (B := B) (iv := iv) (boundary := boundary) + PCSBCSCapturedSourceTransport.address ref view := by + unfold capturedPrefix PCSBCSNativePublicCapture.publicPrefix + congr 1 + funext raw + exact rawReferences_spec p B iv boundary raw + +def log {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : PublicMerkleLog.PublicLog := + ((capturedPrefix p B iv boundary ref view).getD []).foldl + (fun captured event => PCSBCSNativePublicCapture.rawOrdinary event ++ captured) [] + +theorem log_spec {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : + log p B iv boundary ref view = PCSBCSNativePublicCapture.publicLog + (p := p) (B := B) (iv := iv) (boundary := boundary) + PCSBCSCapturedSourceTransport.address ref view := by + simp only [log,PCSBCSNativePublicCapture.publicLog,prefix_spec] + +def root {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : CausalGame.BaseOracle := + (freeze (log p B iv boundary ref view) ref.root ref.shape).raw + +theorem root_spec {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : + root p B iv boundary ref view = PCSBCSNativePublicCapture.publicRoot + (p := p) (B := B) (iv := iv) (boundary := boundary) + PCSBCSCapturedSourceTransport.address ref view := by + simp only [root,PCSBCSNativePublicCapture.publicRoot,log_spec] + +def extractAt {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (original : PCSBCSCallerBinding.CallerInput p) + (ref : Reference) (view : View R) : + Option (CausalGame.Witness (ParameterBounds.config p) original.lanes) := + PCSRoundByRoundKnowledge.extract p original.lanes original.family original.points + original.anchorPoint original.anchorValue (root p B iv boundary ref view) + +abbrev Output (p : ParameterBounds.Profile) := + Sigma (fun original : PCSBCSCallerBinding.CallerInput p => + CausalGame.Witness (ParameterBounds.config p) original.lanes) + +/-- Recover the genuinely observed original statement, reconstruct its first +captured Root0, decode once and return only a word explaining all claims. +No oracle, hidden table, verifier tape, strategy or classical selector is read. -/ +def extract {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) : Option (Output p) := do + let original ← PCSBCSNativePublicCapture.publicOriginal p layout saved entry view + let witness ← extractAt p B iv boundary original ref view + pure ⟨original,witness⟩ + +theorem extractAt_output_explains {R : Type} (p : ParameterBounds.Profile) (B : Nat) + (iv : Digest32) (boundary : Nat) (original : PCSBCSCallerBinding.CallerInput p) + (ref : Reference) (view : View R) + (witness : CausalGame.Witness (ParameterBounds.config p) original.lanes) + (returned : extractAt p B iv boundary original ref view = some witness) : + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) original.lanes + (root p B iv boundary ref view) original.family original.points + original.anchorPoint original.anchorValue witness := + PCSRoundByRoundKnowledge.extract_output_explains p original.lanes original.family + original.points original.anchorPoint original.anchorValue _ witness returned + +theorem extract_output_explains {R : Type} (p : ParameterBounds.Profile) (B : Nat) + (iv : Digest32) (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) (output : Output p) + (returned : extract p B iv boundary layout saved entry ref view = some output) : + PCSBCSNativePublicCapture.publicOriginal p layout saved entry view = some output.1 ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) output.1.lanes + (root p B iv boundary ref view) output.1.family output.1.points + output.1.anchorPoint output.1.anchorValue output.2 := by + obtain ⟨original,decoded,result⟩ := Option.bind_eq_some_iff.mp returned + obtain ⟨witness,decodedWord,equal⟩ := Option.bind_eq_some_iff.mp result + have same : (⟨original,witness⟩ : Output p) = output := Option.some.inj equal + subst output + exact ⟨decoded,extractAt_output_explains p B iv boundary original ref view witness decodedWord⟩ + +theorem public_failure_iff_extractAt_none {R : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) (original : PCSBCSCallerBinding.CallerInput p) + (decoded : PCSBCSNativePublicCapture.publicOriginal p layout saved entry view = some original) : + PCSBCSNativePublicCapture.publicExtractionFailed + (p := p) (B := B) (iv := iv) (boundary := boundary) layout saved entry ref view ↔ + extractAt p B iv boundary original ref view = none := by + constructor + · rintro ⟨other,parsed,failed⟩ + have same := Option.some.inj (parsed.symm.trans decoded) + subst other + cases returned : extractAt p B iv boundary original ref view with + | none => rfl + | some witness => + have explains := extractAt_output_explains p B iv boundary original ref view witness returned + have returned' := returned + unfold extractAt at returned' + rw [root_spec] at returned' + rw [root_spec] at explains + exact False.elim (failed ⟨witness,returned',explains⟩) + · intro absent + refine ⟨original,decoded,?_⟩ + rintro ⟨witness,returned,_⟩ + rw [← root_spec] at returned + change extractAt p B iv boundary original ref view = some witness at returned + rw [absent] at returned + cases returned + +theorem public_failure_iff_extract_none {R : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) (original : PCSBCSCallerBinding.CallerInput p) + (decoded : PCSBCSNativePublicCapture.publicOriginal p layout saved entry view = some original) : + PCSBCSNativePublicCapture.publicExtractionFailed + (p := p) (B := B) (iv := iv) (boundary := boundary) layout saved entry ref view ↔ + extract p B iv boundary layout saved entry ref view = none := by + rw [public_failure_iff_extractAt_none p B iv boundary layout saved entry ref view original decoded] + simp only [extract,decoded] + dsimp only [Bind.bind,Option.bind,Pure.pure] + cases extractAt p B iv boundary original ref view <;> simp + +#print axioms rawReferences_spec +#print axioms prefix_spec +#print axioms log_spec +#print axioms root_spec +#print axioms extractAt_output_explains +#print axioms extract_output_explains +#print axioms public_failure_iff_extract_none + +/-- Failed original decoding is not a knowledge failure: the actual accepted +source separately derives successful original decoding. This flag counts +accepted, parsed originals for which the implemented decoder returns no word. -/ +def failureObserver (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) + (Q B : Nat) (view : PCSBCSWholeSourceObserver.WholeSourceView cap registry Q) : Bool := + match view.result.value with + | none => false + | some a => + let p := a.input.packet.val.profile + let entry := RawWHIRKeys.entry registry.context a.input.packet.val + let boundary := entry.frames.length + match PCSBCSNativePublicCapture.publicOriginal p + (registry.packetModel Q a.input.packet).layout a.input.record entry view with + | none => false + | some original => (extractAt p B registry.context.iv boundary original + ⟨a.input.record.root,initialShape a.input.record.shape⟩ view).isNone + +theorem failureObserver_true_iff (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) + (Q B : Nat) (view : PCSBCSWholeSourceObserver.WholeSourceView cap registry Q) : + failureObserver cap registry Q B view = true ↔ + PCSBCSWholeSourceObserver.PublicFailure cap registry Q B view := by + cases accepted : view.result.value with + | none => + simp [failureObserver,PCSBCSWholeSourceObserver.PublicFailure,accepted] + | some a => + simp only [failureObserver,accepted] + cases decoded : PCSBCSNativePublicCapture.publicOriginal a.input.packet.val.profile + (registry.packetModel Q a.input.packet).layout a.input.record + (RawWHIRKeys.entry registry.context a.input.packet.val) view with + | none => + simp [PCSBCSWholeSourceObserver.PublicFailure, + PCSBCSNativePublicCapture.publicExtractionFailed,accepted,decoded] + | some original => + have equivalent := public_failure_iff_extractAt_none a.input.packet.val.profile B + registry.context.iv (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length + (registry.packetModel Q a.input.packet).layout a.input.record + (RawWHIRKeys.entry registry.context a.input.packet.val) + ⟨a.input.record.root,initialShape a.input.record.shape⟩ view original decoded + simp only [PCSBCSWholeSourceObserver.PublicFailure,accepted,Option.some.injEq] + constructor + · intro empty + refine ⟨a,rfl,equivalent.mpr ?_⟩ + cases returned : extractAt a.input.packet.val.profile B registry.context.iv + (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length original + ⟨a.input.record.root,initialShape a.input.record.shape⟩ view with + | none => rfl + | some witness => simp [returned] at empty + · rintro ⟨other,equal,failed⟩ + subst other + have absent := equivalent.mp failed + rw [absent] + rfl + +theorem failureObserver_eq (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) + (Q B : Nat) : + failureObserver cap registry Q B = + PCSBCSWholeSourceObserver.failureObserver cap registry Q B := by + funext view + apply Bool.eq_iff_iff.mpr + rw [failureObserver_true_iff] + simp only [PCSBCSWholeSourceObserver.failureObserver,decide_eq_true_eq] + +#print axioms failureObserver_true_iff +#print axioms failureObserver_eq + +section Probability +variable {Coins : Type} [Fintype Coins] [Nonempty Coins] + (cap Q : Nat) + (nativeRegistry : {r : WHIRPhysicalDriver.ProductionRegistry // + r.context.iv = PCSBCSSourceCoordinateDecoder.seedIV}) + (attacker : Coins → WHIRSourceChronology.Source cap + (AnchoredPhysicalAfter.Input nativeRegistry.val.context Q)) + (B : Nat) + (counted : ∀ coins, Counts B (PCSBCSNativePhysicalFreeze.wholeProgram + cap nativeRegistry.val Q (attacker coins))) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) (boundary : Nat) + (sourceClass : ∀ coins, PCSBCSWholeSourceObserver.SourceClass + cap nativeRegistry.val Q p layout boundary (attacker coins)) + (rootRegistry : AnchoredHeaderRoots.Public) + +include counted sourceClass rootRegistry in +/-- The event is failure of this implemented public-view extractor, not a +caller-supplied failure certificate. This is the historical PCS-only ideal +compression experiment and its explicit aggregate source-work loss. -/ +theorem random_compression_failure_probability (familyCap : cap ≤ 2^64) : + realProbability nativeRegistry.val.context.iv + (fun coins => PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q (attacker coins)) + (failureObserver cap nativeRegistry.val Q B) ≤ + (B : ℚ)*((17/32 : ℚ)^56 + 1/2^78) + + min 1 ((2*(B : ℚ)^2-(B : ℚ))/2^256) + + ((B : ℚ)^3+3*(B : ℚ)^2-2*(B : ℚ))/2^256 := by + rw [failureObserver_eq] + exact PCSBCSWholeSourceObserver.explicit_failure_probability cap Q nativeRegistry + attacker B counted p layout boundary sourceClass rootRegistry familyCap +end Probability + +#print axioms random_compression_failure_probability + +end Whir.PCSBCSPublicExtractor diff --git a/verification/whir/Whir/PCSBCSPublicExtractorAnchor.lean b/verification/whir/Whir/PCSBCSPublicExtractorAnchor.lean new file mode 100644 index 000000000..79a7410f2 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicExtractorAnchor.lean @@ -0,0 +1,175 @@ +import Whir.PCSBCSPublicExtractor +import Whir.CommitmentAnchor + +/-! Literal first-capture stability and uniqueness of actual public extractor +outputs. A later public trace cannot replace an already captured Root0. The +anchor separation premise is explicit; its probability must come from causal +preanchor preparation, not an assumed native Fiat-Shamir security result. -/ +namespace Whir.PCSBCSPublicExtractorAnchor +open Concrete Protocol CausalGame FiatShamirGame DuplexFraming DuplexModeGame +open PublicMerkleLog PCSBCSSourceRootReferences PCSBCSPublicExtractor +set_option autoImplicit false + +private theorem firstPrefix_append {Key Root : Type} {Answer : Key → Type} + [DecidableEq Root] (address : Key → List Root) (r : Root) + (past later retained : List (Sigma Answer)) + (found : PCSBCSNativePublicCapture.firstPrefix address r past = some retained) : + PCSBCSNativePublicCapture.firstPrefix address r (past ++ later) = some retained := by + induction past generalizing retained with + | nil => simp [PCSBCSNativePublicCapture.firstPrefix] at found + | cons event rest ih => + by_cases hit : r ∈ address event.1 + · simpa [PCSBCSNativePublicCapture.firstPrefix,hit] using found + · simp only [PCSBCSNativePublicCapture.firstPrefix,hit,↓reduceIte] at found + obtain ⟨before,earlier,equal⟩ := Option.map_eq_some_iff.mp found + subst retained + simp only [List.cons_append,PCSBCSNativePublicCapture.firstPrefix,hit,↓reduceIte, + ih before earlier,Option.map_some] + +private theorem mixedTrace_append (B : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (past later : List Observation) : + PCSBCSNativePublicCapture.mixedTrace B iv log (past ++ later) = + PCSBCSNativePublicCapture.mixedTrace B iv log past ++ + PCSBCSNativePublicCapture.mixedTrace B iv + (past.foldl PCSBCSNativePublicCapture.nextLog log) later := by + induction past generalizing log with + | nil => simp [PCSBCSNativePublicCapture.mixedTrace] + | cons event rest ih => + simp only [List.cons_append,PCSBCSNativePublicCapture.mixedTrace,List.foldl_cons, + ih,List.append_assoc] + +/-- No later key, answer or acceptance result can change an existing first +capture. The current query's answer was never included in this strict prefix. -/ +theorem capturedPrefix_extension {R S : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) (ref : Reference) + (before : View R) (after : View S) (later : List Observation) + (extended : after.observations = before.observations ++ later) + (retained : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) + (found : capturedPrefix p B iv boundary ref before = some retained) : + capturedPrefix p B iv boundary ref after = some retained := by + unfold capturedPrefix at found ⊢ + rw [extended,mixedTrace_append] + exact firstPrefix_append _ _ _ _ _ found + +/-- The actual hash-before-projection Root0 getter remains immutable under any +public continuation once its first address mention has occurred. -/ +theorem root_extension {R S : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) (ref : Reference) + (before : View R) (after : View S) (later : List Observation) + (extended : after.observations = before.observations ++ later) + (retained : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) + (found : capturedPrefix p B iv boundary ref before = some retained) : + root p B iv boundary ref after = root p B iv boundary ref before := by + have same := capturedPrefix_extension p B iv boundary ref before after later extended retained found + simp only [root,PCSBCSPublicExtractor.log,found,same] + +/-- An actual returned word is in the selected list of the literal captured +root and retained anchor. This is not a classical-choice implementation. -/ +theorem extractAt_selected {R : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) + (original : PCSBCSCallerBinding.CallerInput p) (ref : Reference) (view : View R) + (point : Fin (ParameterBounds.config p).logN → E) + (pointEq : original.anchorPoint = Array.ofFn point) + (w : Witness (ParameterBounds.config p) original.lanes) + (returned : extractAt p B iv boundary original ref view = some w) : + w ∈ CommitmentAnchor.selected p original.lanes (root p B iv boundary ref view) + point original.anchorValue := by + have explains := extractAt_output_explains p B iv boundary original ref view w returned + apply Finset.mem_filter.mpr + exact ⟨explains.rootCandidate,by simpa only [pointEq] using explains.anchor⟩ + +/-- For arbitrary later original claims, an actual returned word equals every +candidate satisfying the same retained anchor of this captured commitment. -/ +theorem extractAt_equals_selected {R : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) + (original : PCSBCSCallerBinding.CallerInput p) (ref : Reference) (view : View R) + (point : Fin (ParameterBounds.config p).logN → E) + (pointEq : original.anchorPoint = Array.ofFn point) + (clean : ¬ CommitmentAnchor.Ambiguous p original.lanes + (root p B iv boundary ref view) point) + (w other : Witness (ParameterBounds.config p) original.lanes) + (returned : extractAt p B iv boundary original ref view = some w) + (selected : other ∈ CommitmentAnchor.selected p original.lanes + (root p B iv boundary ref view) point original.anchorValue) : w = other := by + exact Finset.card_le_one.mp (CommitmentAnchor.selected_unique p original.lanes + (root p B iv boundary ref view) point clean original.anchorValue) w + (extractAt_selected p B iv boundary original ref view point pointEq w returned) other selected + +/-- Two successful runs on a public trace and an arbitrary later continuation +return the same word for the immutable anchor. Frozen-root equality is derived +from literal first capture, not supplied as a matching certificate. -/ +theorem extractAt_same_word {R S : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) + (original : PCSBCSCallerBinding.CallerInput p) (ref : Reference) + (before : View R) (after : View S) (later : List Observation) + (extended : after.observations = before.observations ++ later) + (retained : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) + (found : capturedPrefix p B iv boundary ref before = some retained) + (point : Fin (ParameterBounds.config p).logN → E) + (pointEq : original.anchorPoint = Array.ofFn point) + (clean : ¬ CommitmentAnchor.Ambiguous p original.lanes + (root p B iv boundary ref before) point) + (w₁ w₂ : Witness (ParameterBounds.config p) original.lanes) + (returned₁ : extractAt p B iv boundary original ref before = some w₁) + (returned₂ : extractAt p B iv boundary original ref after = some w₂) : w₁ = w₂ := by + have first := extractAt_selected p B iv boundary original ref before point pointEq w₁ returned₁ + have second := extractAt_selected p B iv boundary original ref after point pointEq w₂ returned₂ + rw [root_extension p B iv boundary ref before after later extended retained found] at second + exact Finset.card_le_one.mp (CommitmentAnchor.selected_unique p original.lanes + (root p B iv boundary ref before) point clean original.anchorValue) w₁ first w₂ second + +private theorem selected_lane_transport (p : ParameterBounds.Profile) {lanes₁ lanes₂ : Nat} + (same : lanes₂ = lanes₁) (raw : BaseOracle) + (point : Fin (ParameterBounds.config p).logN → E) (value : E) + (w : Witness (ParameterBounds.config p) lanes₂) + (selected : w ∈ CommitmentAnchor.selected p lanes₂ raw point value) : + (same ▸ w) ∈ CommitmentAnchor.selected p lanes₁ raw point value := by + cases same + exact selected + +private theorem word_array_transport (p : ParameterBounds.Profile) {lanes₁ lanes₂ : Nat} + (same : lanes₂ = lanes₁) (w : Witness (ParameterBounds.config p) lanes₂) : + Array.ofFn (same ▸ w) = Array.ofFn w := by + cases same + rfl + +/-- All original families and later point claims may change. Only the immutable +commitment metadata is retained. The consumer-visible returned base-word arrays +are equal, without assuming a matching root, claim set or selected witness. -/ +theorem extractAt_changed_claims_same_word {R S : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) + (original₁ original₂ : PCSBCSCallerBinding.CallerInput p) (ref : Reference) + (sameLanes : original₂.lanes = original₁.lanes) + (samePoint : original₂.anchorPoint = original₁.anchorPoint) + (sameValue : original₂.anchorValue = original₁.anchorValue) + (before : View R) (after : View S) (later : List Observation) + (extended : after.observations = before.observations ++ later) + (retained : List (Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32))) + (found : capturedPrefix p B iv boundary ref before = some retained) + (point : Fin (ParameterBounds.config p).logN → E) + (pointEq : original₁.anchorPoint = Array.ofFn point) + (clean : ¬ CommitmentAnchor.Ambiguous p original₁.lanes + (root p B iv boundary ref before) point) + (w₁ : Witness (ParameterBounds.config p) original₁.lanes) + (w₂ : Witness (ParameterBounds.config p) original₂.lanes) + (returned₁ : extractAt p B iv boundary original₁ ref before = some w₁) + (returned₂ : extractAt p B iv boundary original₂ ref after = some w₂) : + Array.ofFn w₁ = Array.ofFn w₂ := by + have selected₂ := extractAt_selected p B iv boundary original₂ ref after point + (samePoint.trans pointEq) w₂ returned₂ + rw [root_extension p B iv boundary ref before after later extended retained found] at selected₂ + have transported := selected_lane_transport p sameLanes + (root p B iv boundary ref before) point original₂.anchorValue w₂ selected₂ + rw [sameValue] at transported + have same := extractAt_equals_selected p B iv boundary original₁ ref before point + pointEq clean w₁ (sameLanes ▸ w₂) returned₁ transported + exact (congrArg Array.ofFn same).trans (word_array_transport p sameLanes w₂) + +#print axioms extractAt_changed_claims_same_word + +#print axioms capturedPrefix_extension +#print axioms root_extension +#print axioms extractAt_selected +#print axioms extractAt_same_word +#print axioms extractAt_equals_selected +end Whir.PCSBCSPublicExtractorAnchor diff --git a/verification/whir/Whir/PCSBCSPublicExtractorCost.lean b/verification/whir/Whir/PCSBCSPublicExtractorCost.lean new file mode 100644 index 000000000..9da2fffc7 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicExtractorCost.lean @@ -0,0 +1,1054 @@ +import Whir.PCSBCSPublicExtractor +import Whir.PCSBCSPublicLogExtractorCost +import Whir.PCSBCSMerkleRootCacheCost +import Whir.PCSBCSSourceCallerOriginalCost + +/-! Value-connected accounting for the computed historical public extractor. +The units are immutable physical input access, fixed-width byte comparison, +logical scalar/Nat operations, list/array operations and the existing field +operation model. No bit-complexity claim about arbitrary Nat encodings is made. +Every observation, including failed, garbage, prequery and repeated records, is in the input. +The 49-bit cursor range is expanded into a constant coefficient, not a promise +about arbitrary natural-number encodings. No native CPU, allocator, prover or +compiled-source refinement claim is made. Proof witnesses are erased; no +mathematical packet carrier is enumerated. -/ +set_option autoImplicit false +set_option maxHeartbeats 4000000 +set_option maxRecDepth 10000 +set_option backward.isDefEq.respectTransparency false +namespace Whir.PCSBCSPublicExtractorCost +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame RawOracleCoupling +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache PCSBCSChallengeOracle +open PCSBCSPublicExtractor + +abbrev RawEvent (B : Nat) := Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32) + +/-- Both bounded lists are materialized. The quadratic surcharge also pays the +known `shortList` linked-list getters created by construction/privateKey; it +does not treat those generated functions as constant-time table callbacks. +External raw input keys, like finite digest/block byte readers, are immutable +physical input tables in the unit-primitive-access boundary. -/ +def decodeCount {B : Nat} (iv : Digest32) (key : RawKey B) : Option Coordinate × Nat := + let decoded := PCSBCSCoordinateCodecCost.decodeExtractedCount iv (expandKey key) + (decoded.1,decoded.2+8*(key.1.1.val+key.2.1.val)*(key.1.1.val+key.2.1.val+1)+2) + +theorem decodeCount_value {B : Nat} (iv : Digest32) (key : RawKey B) : + (decodeCount iv key).1 = PCSBCSSourceCoordinateDecoder.decode iv key := by + simp [decodeCount,PCSBCSCoordinateCodecCost.decodeExtractedCount_value, + PCSBCSSourceCoordinateDecoder.decode] + +def rawCodecPolynomial (K : Nat) : Nat := + PCSBCSPublicLogExtractorCost.codecReservation K+32*(K+1)*(K+1) + +theorem decodeCount_bound {B : Nat} (iv : Digest32) (key : RawKey B) (K : Nat) + (left : key.1.1.val ≤ K) (right : key.2.1.val ≤ K) : + (decodeCount iv key).2 ≤ rawCodecPolynomial K := by + have h := PCSBCSCoordinateCodecCost.decodeExtractedCount_bound iv (expandKey key) + (K+1) (by simpa [expandKey,expandShort] using (by omega : key.1.1.val ≤ K+1)) + (by simpa [expandKey,expandShort] using (by omega : key.2.1.val ≤ K+1)) + unfold decodeCount rawCodecPolynomial PCSBCSPublicLogExtractorCost.codecReservation + dsimp only + have length : key.1.1.val+key.2.1.val ≤ 2*K := by omega + have square := Nat.mul_le_mul length (Nat.add_le_add_right length 1) + nlinarith + +/-- Successful decoding relates physical key cells to the actual coordinate +path. This avoids pricing a short key at the external oracle budget B. -/ +theorem decoded_physical {B : Nat} {iv : Digest32} {key : RawKey B} {q : Coordinate} + (found : PCSBCSSourceCoordinateDecoder.decode iv key = some q) : + pathCost q = key.1.1.val := by + have same := (PCSBCSSourceCoordinateDecoder.decode_iff iv key q).mp found |>.2 + have lengths := congrArg (fun e : Extracted => e.message.length) same + simpa only [expandKey,expandShort,List.length_ofFn,(modeKey_lengths iv q).1] using lengths.symm + +/-- The same executable classifier, with one byte decode and one pending parse. +The dependent packet constructor reads the schedule once; proof derivations do +not execute. Length, take, block guards and materialization are reserved. -/ +def recognizeCount (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : + Option (Sigma (EnteredPacket.Block (p := p) (Q := B) (iv := iv) (boundary := boundary))) × Nat := + match raw with + | .inl _ => (none,1) + | .inr key => + let decoded := decodeCount iv key + match found : decoded.1 with + | none => (none,decoded.2+1) + | some q => + let entry := PCSBCSSourcePrimitiveRootBudget.entry q boundary + let entryWork := 3*q.history.frames.length+4 + if entryLength : entry.frames.length = boundary then + let pending := PCSBCSSourceReferenceParserCost.parsePendingKeyCount p entry q + match parsed : pending.1 with + | none => (none,decoded.2+entryWork+pending.2+1) + | some messages => + let tailWork := 4*PCSBCSSourceReferenceParserCost.scheduleWork (ParameterBounds.config p)+ + 3*messages.length+q.history.frames.length+16 + match terminal : q.terminal with + | .output block => + if bound : block < (WHIRHistoryKey.stackWidth (ParameterBounds.config p) + (messages.length-1)+31)/32 then + (some (fromDecoded p B iv boundary key q ((decodeCount_value iv key).symm.trans found) + entry rfl entryLength messages + ((PCSBCSSourceReferenceParserCost.parsePendingKeyCount_value p entry q).symm.trans parsed) + block terminal bound),decoded.2+entryWork+pending.2+tailWork) + else (none,decoded.2+entryWork+pending.2+tailWork) + | _ => (none,decoded.2+entryWork+pending.2+tailWork) + else (none,decoded.2+entryWork) + +attribute [local simp] decodeCount_value PCSBCSSourceReferenceParserCost.parsePendingKeyCount_value + +theorem recognizeCount_sound (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) + (position : Sigma (EnteredPacket.Block (p := p) (Q := B) (iv := iv) (boundary := boundary))) + (found : (recognizeCount p B iv boundary raw).1 = some position) : + EnteredPacket.encode position = raw := by + cases raw with + | inl input => simp [recognizeCount] at found + | inr key => + simp only [recognizeCount] at found + split at found + · contradiction + · split at found + · split at found + · contradiction + · split at found + · split at found + · cases found + exact fromDecoded_encode _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + · contradiction + · contradiction + · contradiction + +theorem recognizeCount_encode (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (packet : EnteredPacket p B iv boundary) (block : EnteredPacket.Block packet) : + (recognizeCount p B iv boundary (EnteredPacket.encode ⟨packet,block⟩)).1 = some ⟨packet,block⟩ := by + have decoded := PCSBCSSourceCoordinateDecoder.decode_constructionKey B iv + (packet.2.2.coordinate block) (packet.2.2.valid block) (packet.2.2.pathBound block) + have decoded' : (decodeCount iv (packet.2.2.key block)).1 = some (packet.2.2.coordinate block) := + (decodeCount_value iv _).trans decoded + have entryEq := PCSBCSSourceRootAdmission.packet_entry packet block + have parsed := parsePendingKey_roundtrip p packet.1.val packet.2.messages + packet.2.2.nonempty packet.2.2.admitted block.val + have bound : block.val < (WHIRHistoryKey.stackWidth (ParameterBounds.config p) + (packet.2.messages.length-1)+31)/32 := by + change block.val < (WHIRHistoryKey.stackWidth (ParameterBounds.config p) + (packet.2.2.messages.length-1)+31)/32 + rw [packet.2.2.width_eq] + exact block.isLt + have foundPacket : ∃ actual, (recognizeCount p B iv boundary (EnteredPacket.encode ⟨packet,block⟩)).1 = some actual := by + change ∃ actual, (recognizeCount p B iv boundary (.inr (packet.2.2.key block))).1 = some actual + simp only [recognizeCount] + split + · rename_i missing + rw [decoded'] at missing + cases missing + · rename_i q found + have same := Option.some.inj (found.symm.trans decoded') + subst q + have length : (PCSBCSSourcePrimitiveRootBudget.entry (packet.2.2.coordinate block) boundary).frames.length = + boundary := by rw [entryEq]; exact packet.1.property + rw [dite_eq_left length] + have pending : (PCSBCSSourceReferenceParserCost.parsePendingKeyCount p + (PCSBCSSourcePrimitiveRootBudget.entry (packet.2.2.coordinate block) boundary) + (packet.2.2.coordinate block)).1 = some packet.2.messages := by + rw [entryEq,PCSBCSSourceReferenceParserCost.parsePendingKeyCount_value] + exact parsed + split + · rename_i missing + rw [pending] at missing + cases missing + · rename_i messages present + have same := Option.some.inj (present.symm.trans pending) + subst messages + simp only [SourcePacket.coordinate,WHIRCallerPrefix.outputKeyFrom] + rw [dite_eq_left bound] + exact ⟨_,rfl⟩ + obtain ⟨actual,found⟩ := foundPacket + have same : actual = ⟨packet,block⟩ := + EnteredPacket.encode_injective (recognizeCount_sound p B iv boundary _ actual found) + simpa [same] using found + +theorem recognizeCount_value (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : + (recognizeCount p B iv boundary raw).1 = recognize p B iv boundary raw := by + cases found : (recognizeCount p B iv boundary raw).1 with + | some position => + have encoded := recognizeCount_sound p B iv boundary raw position found + rw [← encoded] + exact (recognize_encode p B iv boundary position.1 position.2).symm + | none => + cases other : recognize p B iv boundary raw with + | none => rfl + | some position => + have encoded := recognize_sound p B iv boundary raw position other + have present := recognizeCount_encode p B iv boundary position.1 position.2 + rw [encoded,found] at present + contradiction + +/-- Saved bytes and phase roles are decoded without reparsing pending bytes. -/ +def packetReferencesCount {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} + {boundary : Nat} (packet : EnteredPacket p B iv boundary) : List Reference × Nat := + let saved := PCSBCSSourceSavedRecordDecoderCost.decodeCount p packet.1.val + match saved.1 with + | none => ([],saved.2+1) + | some record => + (if phaseRolesAdmitted (ParameterBounds.config p) packet.2.messages then + ⟨record.root,initialShape record.shape⟩ :: phaseReferences (ParameterBounds.config p) packet.2.messages + else [],saved.2+PCSBCSSourceReferenceParserCost.phaseWork (ParameterBounds.config p) + packet.2.messages+3*record.shape.logBatch+4) + +theorem packetReferencesCount_value {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} + {boundary : Nat} (packet : EnteredPacket p B iv boundary) : + (packetReferencesCount packet).1 = packetReferences packet := by + simp only [packetReferencesCount,packetReferences,PCSBCSSourceSavedRecordDecoderCost.decodeCount_value] + cases PCSBCSSourceSavedRecordDecoder.decode p packet.1.val with + | none => rfl + | some record => + dsimp only [Bind.bind,Option.bind,Pure.pure] + split <;> rfl + +def rawReferencesCount (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : List Reference × Nat := + let classified := recognizeCount p B iv boundary raw + match classified.1 with + | none => ([],classified.2+1) + | some position => + let refs := packetReferencesCount position.1 + (refs.1,classified.2+refs.2+1) + +theorem rawReferencesCount_value (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : + (rawReferencesCount p B iv boundary raw).1 = rawReferences p B iv boundary raw := by + simp only [rawReferencesCount,rawReferences,recognizeCount_value] + cases recognize p B iv boundary raw <;> simp [packetReferencesCount_value] + +/-- Concrete classifier reservation in physical raw-key cells. -/ +def referencePolynomial (p : ParameterBounds.Profile) (W K : Nat) : Nat := + let P := PCSBCSRecoveredSourceVolume.recoveredFramePolynomial K + rawCodecPolynomial K+ + PCSBCSSourceReferencePolynomialBound.pendingKeyPolynomial (ParameterBounds.config p) W P+ + PCSBCSSourceSavedRecordDecoderCost.physicalPolynomial (65*K)+ + (P+1)*(98*PCSBCSSourceReferencePolynomialBound.configSize (ParameterBounds.config p)+4106)+ + 4*PCSBCSSourceReferenceParserCost.scheduleWork (ParameterBounds.config p)+8*P+256 + +theorem rawReferencesCount_bound (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) (W K : Nat) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (keyCap : ∀ key, raw = .inr key → key.1.1.val ≤ K ∧ key.2.1.val ≤ K) : + (rawReferencesCount p B iv boundary raw).2 ≤ referencePolynomial p W K := by + cases raw with + | inl input => simp [rawReferencesCount,recognizeCount,referencePolynomial] + | inr key => + obtain ⟨left,right⟩ := keyCap key rfl + have codec := decodeCount_bound iv key K left right + unfold rawReferencesCount + generalize output : recognizeCount p B iv boundary (.inr key) = result + unfold recognizeCount at output + dsimp only at output + split at output + · cases output + dsimp only + dsimp only [referencePolynomial] + omega + · rename_i q found + have decoded := (decodeCount_value iv key).symm.trans found + obtain ⟨valid,_⟩ := (PCSBCSSourceCoordinateDecoder.decode_iff iv key q).mp decoded + have physical : pathCost q ≤ K := by rw [decoded_physical decoded]; exact left + let P := PCSBCSRecoveredSourceVolume.recoveredFramePolynomial K + have wire : PCSBCSPublicLogParserCost.framesSize q.history.frames ≤ P := + PCSBCSRecoveredSourceVolume.coordinate_wire q valid K physical + have len := (PCSBCSPublicLogParserCost.framesSize_length q.history.frames).trans wire + have entryCap := (PCSBCSPublicLogParserCost.framesSize_take q.history.frames boundary).trans wire + have parser := PCSBCSSourceReferencePolynomialBound.parsePendingKeyCount_work p + (PCSBCSSourcePrimitiveRootBudget.entry q boundary) q W P width entryCap wire + have bytes := (PCSBCSPublicLogExtractorCost.bodyUnits_take q.history.frames boundary).trans + (PCSBCSSourceSavedRecordDecoderCost.coordinate_physical q valid K physical) + split at output + · split at output + · cases output + dsimp only + unfold referencePolynomial + dsimp only [P] at * + omega + · rename_i messages pending + have mass := PCSBCSSourceReferencePolynomialBound.parsePendingKeyCount_mass p + (PCSBCSSourcePrimitiveRootBudget.entry q boundary) q messages pending + have count := PCSBCSSourceReferencePolynomialBound.pendingMass_length messages + have phase := PCSBCSSourceReferencePolynomialBound.phaseWork_bound (ParameterBounds.config p) messages + have phaseCap : PCSBCSSourceReferenceParserCost.phaseWork (ParameterBounds.config p) messages ≤ + (P+1)*(98*PCSBCSSourceReferencePolynomialBound.configSize (ParameterBounds.config p)+4106)+8 := by + apply phase.trans + exact Nat.add_le_add_right (Nat.mul_le_mul_right _ (by omega)) _ + have savedWork := PCSBCSSourceSavedRecordDecoderCost.decodeCount_bound p + (PCSBCSSourcePrimitiveRootBudget.entry q boundary) + have savedCap : (PCSBCSSourceSavedRecordDecoderCost.decodeCount p + (PCSBCSSourcePrimitiveRootBudget.entry q boundary)).2 ≤ + PCSBCSSourceSavedRecordDecoderCost.physicalPolynomial (65*K) := by + apply savedWork.trans + unfold PCSBCSSourceSavedRecordDecoderCost.physicalPolynomial + change PCSBCSSourceSavedRecordDecoderCost.physicalSize + (PCSBCSSourcePrimitiveRootBudget.entry q boundary) ≤ 65*K at bytes + gcongr + split at output + · split at output + · cases output + dsimp only [packetReferencesCount,fromDecoded,CanonicalPacket.messages] + cases saved : (PCSBCSSourceSavedRecordDecoderCost.decodeCount p + (PCSBCSSourcePrimitiveRootBudget.entry q boundary)).1 with + | none => dsimp only; unfold referencePolynomial; dsimp only [P] at *; omega + | some record => + have accepted := (PCSBCSSourceSavedRecordDecoderCost.decodeCount_value p _).symm.trans saved + have shape := (PCSBCSSourceSavedRecordDecoder.decode_sound p _ record accepted).1 + have batch : record.shape.logBatch < 64 := lt_trans shape.1.1 shape.1.2.1 + dsimp only + unfold referencePolynomial + dsimp only [P] at * + omega + · cases output; dsimp only; unfold referencePolynomial; dsimp only [P] at *; omega + · cases output; dsimp only; unfold referencePolynomial; dsimp only [P] at *; omega + · cases output; dsimp only; unfold referencePolynomial; dsimp only [P] at *; omega + +/-- Construction-key materialization reserves the existing plan counter twice: +the source's pathCost guard encodes the coordinate, then constructionKey +encodes it again. Both mapped key lists and their length guards are included. +Cursor arithmetic is a word primitive, not an opaque encoder callback. -/ +def constructionReservation (q : Coordinate) : Nat := + 2*8192*(PCSBCSCoordinateCodecCost.bodyUnits q.history.frames+1)+ + 40*(PCSBCSCoordinateCodecCost.bodyUnits q.history.frames+2)+16 + +theorem constructionReservation_covers (iv : Digest32) (q : Coordinate) : + (PCSBCSCoordinateCodecCost.planCount q).2+ + (PCSBCSCoordinateCodecCost.modeKeyCount iv q).2+8*pathCost q+8 ≤ constructionReservation q := by + have work := PCSBCSCoordinateCodecCost.planCount_bound q + have size := PCSBCSCoordinateCodecCost.framesPlan_length q.history.frames + have length : (PCSBCSCoordinateCodecCost.planCount q).1.length = pathCost q := by + rw [PCSBCSCoordinateCodecCost.planCount_value] + rfl + have physical : pathCost q ≤ PCSBCSCoordinateCodecCost.bodyUnits q.history.frames+2 := by + simpa only [pathCost,DuplexEncoding.plan,List.length_cons,List.length_append,List.length_nil] + using (by omega : (q.history.frames.flatMap DuplexEncoding.framePlan).length+1+1 ≤ + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames+2) + unfold PCSBCSCoordinateCodecCost.modeKeyCount constructionReservation + dsimp only + rw [length] + omega + +def observationDrawCount (B : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (o : Observation) : List (RawEvent B) × Nat := + match o.query with + | .primitive _ input => + let hit := PCSBCSPublicLogExtractorCost.lookupCount log input + match hit.1 with + | some _ => ([],1024*hit.2+2) + | none => + let key := PCSBCSPublicLogExtractorCost.privateKeyCount B log input + (match key.1 with + | some raw => [⟨.inr raw,o.answer⟩] + | none => [⟨.inl input,o.answer⟩],1024*hit.2+key.2+4) + | .construction q _ => + if bound : pathCost q ≤ B then + ([⟨.inr (constructionKey B iv q bound),o.answer⟩],constructionReservation q) + else ([],constructionReservation q) + +theorem observationDrawCount_value (B : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (o : Observation) : + (observationDrawCount B iv log o).1 = PCSBCSNativePublicCapture.observationDraw B iv log o := by + cases o with + | mk query answer => + cases query with + | primitive purpose input => + simp only [observationDrawCount,PCSBCSNativePublicCapture.observationDraw, + PCSBCSPublicLogExtractorCost.lookupCount_value,PCSBCSPublicLogExtractorCost.privateKeyCount_value] + cases DuplexPublicSimulator.lookup log input <;> rfl + | construction q valid => simp only [observationDrawCount,PCSBCSNativePublicCapture.observationDraw]; split <;> rfl + +theorem observationDraw_length (B : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (o : Observation) : + (PCSBCSNativePublicCapture.observationDraw B iv log o).length ≤ 1 := by + cases o with + | mk query answer => + cases query with + | primitive purpose input => + simp only [PCSBCSNativePublicCapture.observationDraw] + split + · simp + · split <;> simp + | construction q valid => + simp only [PCSBCSNativePublicCapture.observationDraw]; split <;> simp + +def observationPolynomial (Q H : Nat) : Nat := + PCSBCSPublicLogExtractorCost.recognitionPolynomial Q+1024*Q+ + 2*8192*(H+1)+40*(H+2)+20 + +theorem observationDrawCount_bound (B : Nat) (iv : Digest32) + (log : DuplexPublicSimulator.PublicLog) (o : Observation) (Q H : Nat) + (logCap : log.length ≤ Q) + (historyCap : ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) : + (observationDrawCount B iv log o).2 ≤ observationPolynomial Q H := by + cases o with + | mk query answer => + cases query with + | primitive purpose input => + have scan := PCSBCSPublicLogExtractorCost.findCount_bound + (fun e : Node × Digest32 => decide (e.1 = input)) log + change (PCSBCSPublicLogExtractorCost.lookupCount log input).2 ≤ log.length at scan + have key := (PCSBCSPublicLogExtractorCost.privateKeyCount_bound B log input).trans + (PCSBCSPublicLogExtractorCost.recognitionPolynomial_mono logCap) + simp only [observationDrawCount] + split <;> dsimp only <;> unfold observationPolynomial <;> nlinarith + | construction q valid => + have h := historyCap q valid rfl + simp only [observationDrawCount] + split <;> dsimp only <;> unfold constructionReservation observationPolynomial <;> omega + +theorem nextLog_length (log : DuplexPublicSimulator.PublicLog) (o : Observation) : + (PCSBCSNativePublicCapture.nextLog log o).length ≤ log.length+1 := by + cases o with + | mk query answer => + cases query <;> simp [PCSBCSNativePublicCapture.nextLog,DuplexPublicSimulator.observe] + +def mixedTraceCount (B : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) : + List Observation → List (RawEvent B) × Nat + | [] => ([],1) + | o::rest => + let draw := observationDrawCount B iv log o + let later := mixedTraceCount B iv (PCSBCSNativePublicCapture.nextLog log o) rest + (draw.1++later.1,draw.2+later.2+draw.1.length+3) + +theorem mixedTraceCount_value (B : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (observations : List Observation) : + (mixedTraceCount B iv log observations).1 = PCSBCSNativePublicCapture.mixedTrace B iv log observations := by + induction observations generalizing log with + | nil => rfl + | cons o rest ih => + simp only [mixedTraceCount,PCSBCSNativePublicCapture.mixedTrace,observationDrawCount_value,ih] + +theorem mixedTrace_length (B : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (observations : List Observation) : + (PCSBCSNativePublicCapture.mixedTrace B iv log observations).length ≤ observations.length := by + induction observations generalizing log with + | nil => rfl + | cons o rest ih => + have draw := observationDraw_length B iv log o + have later := ih (PCSBCSNativePublicCapture.nextLog log o) + simp only [PCSBCSNativePublicCapture.mixedTrace,List.length_append,List.length_cons] + omega + +theorem mixedTraceCount_bound (B : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (observations : List Observation) (Q H : Nat) + (logCap : log.length+observations.length ≤ Q) + (historyCap : ∀ o ∈ observations, ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) : + (mixedTraceCount B iv log observations).2 ≤ + observations.length*(observationPolynomial Q H+4)+1 := by + induction observations generalizing log with + | nil => simp [mixedTraceCount] + | cons o rest ih => + have first := observationDrawCount_bound B iv log o Q H (by simp only [List.length_cons] at logCap; omega) + (historyCap o (by simp)) + have length := observationDraw_length B iv log o + rw [← observationDrawCount_value] at length + have next := nextLog_length log o + have later := ih (PCSBCSNativePublicCapture.nextLog log o) + (by simp only [List.length_cons] at logCap; omega) + (fun item member => historyCap item (List.mem_cons_of_mem o member)) + simp only [mixedTraceCount,List.length_cons] + nlinarith + +theorem rawReferencesCount_size (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (raw : PublicCompressionCouplingMixed.Key B) : + (rawReferencesCount p B iv boundary raw).1.length ≤ + (rawReferencesCount p B iv boundary raw).2 := by + unfold rawReferencesCount + dsimp only + split + · simp + · rename_i position present + unfold packetReferencesCount + dsimp only + split + · simp + · rename_i record saved + have phases : (phaseReferences (ParameterBounds.config p) position.1.2.messages).length ≤ + position.1.2.messages.length := by + unfold phaseReferences + exact (List.length_filterMap_le _ _).trans (by simp) + split + · dsimp only + simp only [List.length_cons] + unfold PCSBCSSourceReferenceParserCost.phaseWork + omega + · simp + +def firstPrefixCount (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) : List (RawEvent B) → Option (List (RawEvent B)) × Nat + | [] => (none,1) + | event::rest => + let refs := rawReferencesCount p B iv boundary event.1 + let work := refs.2+1024*refs.1.length+2 + if ref ∈ refs.1 then (some [],work) else + let later := firstPrefixCount p B iv boundary ref rest + (later.1.map (event::·),work+later.2+1) + +theorem firstPrefixCount_value (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (events : List (RawEvent B)) : + (firstPrefixCount p B iv boundary ref events).1 = + PCSBCSNativePublicCapture.firstPrefix (rawReferences p B iv boundary) ref events := by + induction events with + | nil => rfl + | cons event rest ih => + simp only [firstPrefixCount,PCSBCSNativePublicCapture.firstPrefix,rawReferencesCount_value] + split <;> simp [ih] + +theorem firstPrefixCount_length (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (events : List (RawEvent B)) : + ((firstPrefixCount p B iv boundary ref events).1.getD []).length ≤ events.length := by + induction events with + | nil => rfl + | cons event rest ih => + simp only [firstPrefixCount,List.length_cons] + split + · simp + · cases h : (firstPrefixCount p B iv boundary ref rest).1 <;> simp_all + +theorem firstPrefixCount_bound (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (events : List (RawEvent B)) (W K : Nat) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (keys : ∀ event ∈ events, ∀ key, event.1 = .inr key → + key.1.1.val ≤ K ∧ key.2.1.val ≤ K) : + (firstPrefixCount p B iv boundary ref events).2 ≤ + events.length*(1025*referencePolynomial p W K+3)+1 := by + induction events with + | nil => simp [firstPrefixCount] + | cons event rest ih => + have cost := rawReferencesCount_bound p B iv boundary event.1 W K width (keys event (by simp)) + have size := rawReferencesCount_size p B iv boundary event.1 + have later := ih (fun item member => keys item (List.mem_cons_of_mem event member)) + simp only [firstPrefixCount,List.length_cons] + split <;> dsimp only <;> nlinarith + +def ordinaryLogCount (B : Nat) : PublicMerkleLog.PublicLog → List (RawEvent B) → + PublicMerkleLog.PublicLog × Nat + | log,[] => (log,1) + | log,event::rest => + let later := ordinaryLogCount B (PCSBCSNativePublicCapture.rawOrdinary event++log) rest + (later.1,later.2+2) + +theorem ordinaryLogCount_value (B : Nat) (log : PublicMerkleLog.PublicLog) (events : List (RawEvent B)) : + (ordinaryLogCount B log events).1 = events.foldl + (fun captured event => PCSBCSNativePublicCapture.rawOrdinary event++captured) log := by + induction events generalizing log with + | nil => rfl + | cons event rest ih => exact ih _ + +theorem ordinaryLogCount_bound (B : Nat) (log : PublicMerkleLog.PublicLog) (events : List (RawEvent B)) : + (ordinaryLogCount B log events).2 = 2*events.length+1 ∧ + (ordinaryLogCount B log events).1.length ≤ log.length+events.length := by + induction events generalizing log with + | nil => simp [ordinaryLogCount] + | cons event rest ih => + have later := ih (PCSBCSNativePublicCapture.rawOrdinary event++log) + have first : (PCSBCSNativePublicCapture.rawOrdinary event).length ≤ 1 := by + unfold PCSBCSNativePublicCapture.rawOrdinary + split <;> simp + simp only [ordinaryLogCount,List.length_cons,List.length_append] at * + constructor <;> omega + +def logCount {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : PublicMerkleLog.PublicLog × Nat := + let trace := mixedTraceCount B iv [] view.observations + let before := firstPrefixCount p B iv boundary ref trace.1 + let captured := ordinaryLogCount B [] (before.1.getD []) + (captured.1,trace.2+before.2+captured.2+1) + +theorem logCount_value {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : + (logCount p B iv boundary ref view).1 = log p B iv boundary ref view := by + simp only [logCount,log,capturedPrefix,mixedTraceCount_value,firstPrefixCount_value,ordinaryLogCount_value] + +theorem logCount_length {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) : + (logCount p B iv boundary ref view).1.length ≤ view.observations.length := by + have output := (ordinaryLogCount_bound B [] ((firstPrefixCount p B iv boundary ref + (mixedTraceCount B iv [] view.observations).1).1.getD [])).2 + have before := firstPrefixCount_length p B iv boundary ref (mixedTraceCount B iv [] view.observations).1 + have trace := mixedTrace_length B iv [] view.observations + rw [← mixedTraceCount_value] at trace + simp only [List.length_nil,Nat.zero_add] at output + exact output.trans (before.trans trace) + +theorem constructionKey_sizes (B : Nat) (iv : Digest32) (q : Coordinate) (bound : pathCost q ≤ B) : + (constructionKey B iv q bound).1.1.val = pathCost q ∧ + (constructionKey B iv q bound).2.1.val = pathCost q := by + have same := expand_constructionKey B iv q bound + have left := congrArg (fun e : Extracted => e.message.length) same + have right := congrArg (fun e : Extracted => e.template.length) same + simpa only [expandKey,expandShort,List.length_ofFn,(modeKey_lengths iv q).1, + (modeKey_lengths iv q).2] using And.intro left right + +theorem pathCost_physical (q : Coordinate) : + pathCost q ≤ PCSBCSCoordinateCodecCost.bodyUnits q.history.frames+2 := by + have size := PCSBCSCoordinateCodecCost.framesPlan_length q.history.frames + simpa only [pathCost,DuplexEncoding.plan,List.length_cons,List.length_append,List.length_nil] + using (by omega : (q.history.frames.flatMap DuplexEncoding.framePlan).length+1+1 ≤ + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames+2) + +theorem observationDraw_keys (B : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (o : Observation) (Q H : Nat) (logCap : log.length ≤ Q) + (historyCap : ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) : + ∀ event ∈ PCSBCSNativePublicCapture.observationDraw B iv log o, ∀ key, event.1 = .inr key → + key.1.1.val ≤ Q+H+2 ∧ key.2.1.val ≤ Q+H+2 := by + cases o with + | mk query answer => + cases query with + | primitive purpose input => + simp only [PCSBCSNativePublicCapture.observationDraw] + split + · simp + · split + · rename_i raw found + have sizes := DuplexPublicSimulator.privateKey_lengths_log found + intro event member key equal + simp only [List.mem_singleton] at member + subst event + cases equal + constructor <;> omega + · intro event member key equal + simp only [List.mem_singleton] at member + subst event + cases equal + | construction q valid => + have volume := historyCap q valid rfl + have path := pathCost_physical q + simp only [PCSBCSNativePublicCapture.observationDraw] + split + · rename_i bound + intro event member key equal + simp only [List.mem_singleton] at member + subst event + cases equal + have sizes := constructionKey_sizes B iv q bound + constructor <;> omega + · simp + +theorem mixedTrace_keys (B : Nat) (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) + (observations : List Observation) (Q H : Nat) (logCap : log.length+observations.length ≤ Q) + (historyCap : ∀ o ∈ observations, ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) : + ∀ event ∈ PCSBCSNativePublicCapture.mixedTrace B iv log observations, ∀ key, event.1 = .inr key → + key.1.1.val ≤ Q+H+2 ∧ key.2.1.val ≤ Q+H+2 := by + induction observations generalizing log with + | nil => simp [PCSBCSNativePublicCapture.mixedTrace] + | cons o rest ih => + have first := observationDraw_keys B iv log o Q H (by simp only [List.length_cons] at logCap; omega) + (historyCap o (by simp)) + have next := nextLog_length log o + have later := ih (PCSBCSNativePublicCapture.nextLog log o) + (by simp only [List.length_cons] at logCap; omega) + (fun item member => historyCap item (List.mem_cons_of_mem o member)) + intro event member key equal + rcases List.mem_append.mp member with early | late + · exact first event early key equal + · exact later event late key equal + +def outerPolynomial (p : ParameterBounds.Profile) (Q H W : Nat) : Nat := + Q*(observationPolynomial Q H+1025*referencePolynomial p W (Q+H+2)+9)+4 + +theorem logCount_bound {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (ref : Reference) (view : View R) (Q H W : Nat) + (observationsCap : view.observations.length ≤ Q) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (historyCap : ∀ o ∈ view.observations, ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) : + (logCount p B iv boundary ref view).2 ≤ outerPolynomial p Q H W := by + have traceWork := mixedTraceCount_bound B iv [] view.observations Q H (by simpa using observationsCap) historyCap + have traceSize := mixedTrace_length B iv [] view.observations + have keys := mixedTrace_keys B iv [] view.observations Q H (by simpa using observationsCap) historyCap + rw [← mixedTraceCount_value] at traceSize keys + have prefixWork := firstPrefixCount_bound p B iv boundary ref + (mixedTraceCount B iv [] view.observations).1 W (Q+H+2) width keys + have prefixSize := firstPrefixCount_length p B iv boundary ref + (mixedTraceCount B iv [] view.observations).1 + have logWork := (ordinaryLogCount_bound B [] ((firstPrefixCount p B iv boundary ref + (mixedTraceCount B iv [] view.observations).1).1.getD [])).1 + unfold logCount outerPolynomial + dsimp only + nlinarith [Nat.mul_le_mul_right (observationPolynomial Q H+4) observationsCap, + Nat.mul_le_mul_right (1025*referencePolynomial p W (Q+H+2)+3) (traceSize.trans observationsCap)] + +/-- Full literal-coordinate equality is linear in physical history cells. +The two 32-byte headers and fixed terminals are included in the 1024 reserve. +Every observed construction is visited; primitive observations also cost one. -/ +def answerStepCount (wanted : Coordinate) (previous : Option Digest32) (o : Observation) : + Option Digest32 × Nat := + (WHIRPhysicalCaller.observeAt wanted previous o,match o.query with + | .primitive _ _ => 1 + | .construction q _ => 1024+2*PCSBCSCoordinateCodecCost.bodyUnits wanted.history.frames+ + 2*PCSBCSCoordinateCodecCost.bodyUnits q.history.frames) + +def answerLoopCount (wanted : Coordinate) : Option Digest32 → List Observation → Option Digest32 × Nat + | previous,[] => (previous,1) + | previous,o::rest => + let first := answerStepCount wanted previous o + let later := answerLoopCount wanted first.1 rest + (later.1,first.2+later.2+1) + +theorem answerLoopCount_value (wanted : Coordinate) (previous : Option Digest32) + (observations : List Observation) : + (answerLoopCount wanted previous observations).1 = + observations.foldl (WHIRPhysicalCaller.observeAt wanted) previous := by + induction observations generalizing previous with + | nil => rfl + | cons o rest ih => exact ih _ + +def publicAnswersCount {R : Type} (view : View R) (q : Coordinate) : Digest32 × Nat := + let found := answerLoopCount q none view.observations + (found.1.getD (fun _ => 0),found.2+1) + +theorem publicAnswersCount_value {R : Type} (view : View R) (q : Coordinate) : + (publicAnswersCount view q).1 = PCSBCSNativePublicCapture.publicAnswers view q := by + simp only [publicAnswersCount,PCSBCSNativePublicCapture.publicAnswers,answerLoopCount_value, + WHIRPhysicalCaller.latestAnswers,WHIRPhysicalCaller.observedAnswers] + +def answerPolynomial (Q J H : Nat) : Nat := Q*(1025+2*J+2*H)+2 + +theorem answerLoopCount_bound (wanted : Coordinate) (previous : Option Digest32) + (observations : List Observation) (J H : Nat) + (wantedCap : PCSBCSCoordinateCodecCost.bodyUnits wanted.history.frames ≤ J) + (historyCap : ∀ o ∈ observations, ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) : + (answerLoopCount wanted previous observations).2 ≤ observations.length*(1025+2*J+2*H)+1 := by + induction observations generalizing previous with + | nil => simp [answerLoopCount] + | cons o rest ih => + have step : (answerStepCount wanted previous o).2 ≤ 1024+2*J+2*H := by + cases o with + | mk query answer => + cases query with + | primitive purpose input => dsimp only [answerStepCount]; omega + | construction q valid => + have cap := historyCap ⟨.construction q valid,answer⟩ (by simp) q valid rfl + dsimp only [answerStepCount] + omega + have later := ih (answerStepCount wanted previous o).1 + (fun item member => historyCap item (List.mem_cons_of_mem o member)) + simp only [answerLoopCount,List.length_cons] + nlinarith + +theorem publicAnswersCount_bound {R : Type} (view : View R) (entry : FramedHistory) + (q : Coordinate) (Q J H : Nat) (observationsCap : view.observations.length ≤ Q) + (entryCap : PCSBCSCoordinateCodecCost.bodyUnits entry.frames ≤ J) + (member : q ∈ WHIRCallerOutputs.callerOutputs entry) + (historyCap : ∀ o ∈ view.observations, ∀ coordinate valid, o.query = .construction coordinate valid → + PCSBCSCoordinateCodecCost.bodyUnits coordinate.history.frames ≤ H) : + (publicAnswersCount view q).2 ≤ answerPolynomial Q J H := by + have prefixEq := (WHIRCallerOutputs.callerOutputs_strict_prefix entry q member).2.2.2 + have wantedCap : PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ J := by + rw [prefixEq] + exact (PCSBCSPublicLogExtractorCost.bodyUnits_take entry.frames _).trans entryCap + have work := answerLoopCount_bound q none view.observations J H wantedCap historyCap + have weighted := Nat.mul_le_mul_right (1025+2*J+2*H) observationsCap + unfold publicAnswersCount answerPolynomial + dsimp only + omega + +def extractAtCount {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (original : PCSBCSCallerBinding.CallerInput p) + (ref : Reference) (view : View R) (originalAccess : Nat) : + Option (CausalGame.Witness (ParameterBounds.config p) original.lanes) × Nat := + let captured := logCount p B iv boundary ref view + let frozen := PCSBCSPublicLogExtractorCost.freezeCount captured.1 ref.root ref.shape + let decoded := PCSRoundByRoundSource.countedRun p original.lanes original.family original.points + original.anchorPoint original.anchorValue frozen.1.raw + (decoded.1,captured.2+frozen.2+decoded.2*(original.m+1)*(originalAccess+1)) + +theorem extractAtCount_value {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (original : PCSBCSCallerBinding.CallerInput p) + (ref : Reference) (view : View R) (originalAccess : Nat) : + (extractAtCount p B iv boundary original ref view originalAccess).1 = + extractAt p B iv boundary original ref view := by + simp only [extractAtCount,extractAt,root,logCount_value, + PCSBCSPublicLogExtractorCost.freezeCount_value,PCSRoundByRoundSource.countedRun_value, + PCSRoundByRoundKnowledge.extract] + +def backendPolynomial (p : ParameterBounds.Profile) (Q H N L O W lanes M T originalAccess : Nat) : Nat := + outerPolynomial p Q H W+PCSBCSMerkleRootCache.operationBudget Q N L O+ + PCSRoundByRoundSource.resourcePolynomial + (SupportedCandidateExtraction.blockLength (ParameterBounds.config p)) + (SupportedCandidateExtraction.laneCount (ParameterBounds.config p)) lanes M T*(M+1)*(originalAccess+1) + +theorem extractAtCount_bound {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (original : PCSBCSCallerBinding.CallerInput p) + (ref : Reference) (view : View R) (originalAccess Q H N L O W : Nat) + (observationsCap : view.observations.length ≤ Q) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (historyCap : ∀ o ∈ view.observations, ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) + (rowsCap : 2^ref.shape.height ≤ N) (leafCap : ref.shape.leafWords ≤ L) + (occupiedCap : ref.shape.occupied ≤ O) (fits : ref.shape.occupied ≤ ref.shape.leafWords) : + (extractAtCount p B iv boundary original ref view originalAccess).2 ≤ + backendPolynomial p Q H N L O W original.lanes original.m original.points.size originalAccess := by + have outer := logCount_bound p B iv boundary ref view Q H W observationsCap width historyCap + have logCap := (logCount_length p B iv boundary ref view).trans observationsCap + have frozen := PCSBCSPublicLogExtractorCost.freezeCount_bound + (logCount p B iv boundary ref view).1 ref.root ref.shape Q N L O logCap rowsCap leafCap occupiedCap fits + have kernel := PCSRoundByRoundSource.countedRun_polynomial_cost p original.lanes original.family original.points + original.anchorPoint original.anchorValue + (PCSBCSPublicLogExtractorCost.freezeCount (logCount p B iv boundary ref view).1 ref.root ref.shape).1.raw + have weighted := Nat.mul_le_mul_right (originalAccess+1) (Nat.mul_le_mul_right (original.m+1) kernel) + unfold extractAtCount backendPolynomial + dsimp only + omega + +/-- Each actual byte-answer invocation pays a full latest-answer scan. No +unbounded answer callback is declared constant and no block-cache optimization +is substituted for the computed algorithm. `originalAccess` is an explicit +allowance for non-unit original-data accessors in addition to indexed-list work; +setting it to zero means immutable input-table primitive access, not CPU time. -/ +def publicOriginalCount {R : Type} (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) + (answerPrice originalAccess : Nat) : Option (PCSBCSCallerBinding.CallerInput p) × Nat := + let decoded := PCSBCSSourceCallerOriginalCost.originalCount p layout saved entry + (PCSBCSNativePublicCapture.publicAnswers view) getters + (decoded.1,decoded.2.2*(originalAccess+1)+decoded.2.1*answerPrice+1) + +theorem publicOriginalCount_value {R : Type} (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) + (answerPrice originalAccess : Nat) : + (publicOriginalCount p layout saved entry view getters answerPrice originalAccess).1 = + PCSBCSNativePublicCapture.publicOriginal p layout saved entry view := by + simp only [publicOriginalCount,PCSBCSNativePublicCapture.publicOriginal, + PCSBCSSourceCallerOriginalCost.originalCount_value] + +def originalDimensions {R : Type} (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (view : View R) : Nat × Nat := + PCSBCSSourceCallerOriginalCost.dimensions layout saved entry (PCSBCSNativePublicCapture.publicAnswers view) + +def originalGetterCharge {R : Type} (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) : Nat := + PCSBCSSourceCallerOriginalCost.getterCharge layout saved entry (PCSBCSNativePublicCapture.publicAnswers view) getters + +def frontPolynomial (p : ParameterBounds.Profile) (P S M T answerPrice originalAccess getterPrice : Nat) : Nat := + (PCSBCSSourceCallerOriginalCost.originalPolynomial p P S M T+getterPrice)*(originalAccess+1)+ + P*P*answerPrice+1 + +theorem publicOriginalCount_bound {R : Type} (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) + (answerPrice originalAccess P S : Nat) + (entryCap : PCSBCSPublicLogParserCost.framesSize entry.frames ≤ P) + (layoutCap : PCSBCSCallerPayloadCost.layoutVolume layout ≤ S) + (recordCap : PCSBCSCallerPayloadCost.recordPublicSize saved ≤ S) (tokensCap : P*P ≤ S) : + (publicOriginalCount p layout saved entry view getters answerPrice originalAccess).2 ≤ + frontPolynomial p P S (originalDimensions layout saved entry view).1 + (originalDimensions layout saved entry view).2 answerPrice originalAccess + (originalGetterCharge layout saved entry view getters) := by + obtain ⟨calls,work⟩ := PCSBCSSourceCallerOriginalCost.originalCount_bound p layout saved entry + (PCSBCSNativePublicCapture.publicAnswers view) getters P S entryCap layoutCap recordCap tokensCap + have weighted := Nat.mul_le_mul_right (originalAccess+1) work + have answers := Nat.mul_le_mul_right answerPrice calls + unfold publicOriginalCount frontPolynomial originalDimensions originalGetterCharge + dsimp only + omega + +def extractCount {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) + (answerPrice originalAccess : Nat) : Option (Output p) × Nat := + let original := publicOriginalCount p layout saved entry view getters answerPrice originalAccess + match original.1 with + | none => (none,original.2+1) + | some input => + let witness := extractAtCount p B iv boundary input ref view originalAccess + (witness.1.map (fun w => ⟨input,w⟩),original.2+witness.2+1) + +theorem extractCount_value {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) + (answerPrice originalAccess : Nat) : + (extractCount p B iv boundary layout saved entry ref view getters answerPrice originalAccess).1 = + extract p B iv boundary layout saved entry ref view := by + simp only [extractCount,PCSBCSPublicExtractor.extract,publicOriginalCount_value] + cases PCSBCSNativePublicCapture.publicOriginal p layout saved entry view with + | none => rfl + | some input => + simp only [extractAtCount_value] + dsimp only [Bind.bind,Option.bind] + cases extractAt p B iv boundary input ref view <;> rfl + +def fullPolynomial (p : ParameterBounds.Profile) + (Q H J P S N L O W lanes M T originalAccess getterPrice : Nat) : Nat := + frontPolynomial p P S M T (answerPolynomial Q J H) originalAccess getterPrice+ + backendPolynomial p Q H N L O W lanes M T originalAccess+1 + +/-- Full computed algorithm, including caller decode/preparation failures and +all physical observations. Only input volumes, target geometry and explicit +source-accessor prices are hypotheses; there is no knowledge/soundness premise. -/ +theorem extractCount_bound {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) + (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) + (originalAccess Q H J P S N L O W : Nat) + (observationsCap : view.observations.length ≤ Q) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (historyCap : ∀ o ∈ view.observations, ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ H) + (entryCap : PCSBCSPublicLogParserCost.framesSize entry.frames ≤ P) + (layoutCap : PCSBCSCallerPayloadCost.layoutVolume layout ≤ S) + (recordCap : PCSBCSCallerPayloadCost.recordPublicSize saved ≤ S) (tokensCap : P*P ≤ S) + (rowsCap : 2^ref.shape.height ≤ N) (leafCap : ref.shape.leafWords ≤ L) + (occupiedCap : ref.shape.occupied ≤ O) (fits : ref.shape.occupied ≤ ref.shape.leafWords) : + (extractCount p B iv boundary layout saved entry ref view getters + (answerPolynomial Q J H) originalAccess).2 ≤ + fullPolynomial p Q H J P S N L O W saved.shape.lanes + (originalDimensions layout saved entry view).1 (originalDimensions layout saved entry view).2 + originalAccess (originalGetterCharge layout saved entry view getters) := by + have front := publicOriginalCount_bound p layout saved entry view getters + (answerPolynomial Q J H) originalAccess P S entryCap layoutCap recordCap tokensCap + unfold extractCount + dsimp only + cases present : (publicOriginalCount p layout saved entry view getters + (answerPolynomial Q J H) originalAccess).1 with + | none => dsimp only; unfold fullPolynomial; omega + | some input => + have shape := PCSBCSSourceCallerOriginalCost.originalCount_dimensions p layout saved entry + (PCSBCSNativePublicCapture.publicAnswers view) getters input present + have backend := extractAtCount_bound p B iv boundary input ref view originalAccess Q H N L O W + observationsCap width historyCap rowsCap leafCap occupiedCap fits + have dimensionEq : originalDimensions layout saved entry view = (input.m,input.points.size) := shape.2 + have families := congrArg Prod.fst dimensionEq + have points := congrArg Prod.snd dimensionEq + dsimp only at families points + have backendEq : backendPolynomial p Q H N L O W input.lanes input.m input.points.size originalAccess = + backendPolynomial p Q H N L O W saved.shape.lanes + (originalDimensions layout saved entry view).1 (originalDimensions layout saved entry view).2 + originalAccess := by rw [shape.1,← families,← points] + rw [backendEq] at backend + dsimp only + unfold fullPolynomial + omega + +def observationHistorySize (o : Observation) : Nat := + match o.query with + | .primitive _ _ => 0 + | .construction q _ => PCSBCSCoordinateCodecCost.bodyUnits q.history.frames + +/-- Literal frame slots and payload bytes, with every repeat represented. +Primitive node inputs are fixed-width and are charged by observation length. -/ +def physicalHistorySize (observations : List Observation) : Nat := + (observations.map observationHistorySize).sum + +theorem physicalHistorySize_cap (observations : List Observation) : + ∀ o ∈ observations, ∀ q valid, o.query = .construction q valid → + PCSBCSCoordinateCodecCost.bodyUnits q.history.frames ≤ physicalHistorySize observations := by + intro o member q valid equal + have h : observationHistorySize o ≤ physicalHistorySize observations := + List.le_sum_of_mem (List.mem_map.mpr ⟨o,member,rfl⟩) + simpa only [observationHistorySize,equal] using h + +def callerFrameReservation (entry : FramedHistory) : Nat := + (2^49+1)*PCSBCSCoordinateCodecCost.bodyUnits entry.frames + +def callerInputSize (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) : Nat := + PCSBCSCallerPayloadCost.layoutVolume layout+PCSBCSCallerPayloadCost.recordPublicSize saved+ + callerFrameReservation entry*callerFrameReservation entry+1 + +/-- A closed polynomial in literal observation/key/history volume, declared +root rows/leaf words/occupied lanes, reached original family/point data and +explicit callback prices. The fixed profile's Gao degree-seven polynomial is +included, not assumed. Metadata-only dimensions do not replace actual N. +The dependent claims dimensions and getter trace are proof-side input metrics, +not additional decoder executions. -/ +def physicalPolynomial {R : Type} (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (ref : Reference) (view : View R) + (getters : PCSBCSCallerPayloadCost.OutputCosts) (originalAccess : Nat) : Nat := + fullPolynomial p view.observations.length (physicalHistorySize view.observations) + (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) (callerFrameReservation entry) + (callerInputSize layout saved entry) (2^ref.shape.height) ref.shape.leafWords ref.shape.occupied + (2^49) saved.shape.lanes + (originalDimensions layout saved entry view).1 (originalDimensions layout saved entry view).2 + originalAccess (originalGetterCharge layout saved entry view getters) + +/-- Whole computed public-view algorithm, not the previous public-log +extractor. FrameValid is the input codec's fixed cursor domain (49 bits), not +verifier acceptance; without this domain the actual caller decoder expands +numeric cursors and the separate numeric-volume theorem remains applicable. +Occupied ≤ leafWords is declared target geometry, not authentic availability. +All source CPU/context/root/pending getters retain their explicit prices. +Answers are scanned once per actual byte callback, including missing answers. -/ +theorem extractCount_physical_polynomial {R : Type} (p : ParameterBounds.Profile) + (B : Nat) (iv : Digest32) (boundary : Nat) (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (ref : Reference) (view : View R) (getters : PCSBCSCallerPayloadCost.OutputCosts) + (originalAccess : Nat) (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) + (fits : ref.shape.occupied ≤ ref.shape.leafWords) : + (extractCount p B iv boundary layout saved entry ref view getters + (answerPolynomial view.observations.length (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) + (physicalHistorySize view.observations)) originalAccess).1 = + extract p B iv boundary layout saved entry ref view ∧ + (extractCount p B iv boundary layout saved entry ref view getters + (answerPolynomial view.observations.length (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) + (physicalHistorySize view.observations)) originalAccess).2 ≤ + physicalPolynomial p layout saved entry ref view getters originalAccess ∧ + (∀ q ∈ WHIRCallerOutputs.callerOutputs entry, + (publicAnswersCount view q).1 = PCSBCSNativePublicCapture.publicAnswers view q ∧ + (publicAnswersCount view q).2 ≤ + answerPolynomial view.observations.length (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) + (physicalHistorySize view.observations)) := by + have entryCap : PCSBCSPublicLogParserCost.framesSize entry.frames ≤ callerFrameReservation entry := + PCSBCSRecoveredSourceVolume.framesSize_valid entry.frames entryValid + have historyCap := physicalHistorySize_cap view.observations + refine ⟨extractCount_value p B iv boundary layout saved entry ref view getters _ originalAccess,?_,?_⟩ + · exact extractCount_bound p B iv boundary layout saved entry ref view getters originalAccess + view.observations.length (physicalHistorySize view.observations) + (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) (callerFrameReservation entry) + (callerInputSize layout saved entry) (2^ref.shape.height) ref.shape.leafWords ref.shape.occupied + (2^49) le_rfl (fun n => Nat.le_of_lt (WHIRHistoryKey.stackWidth_bounded p n)) + historyCap entryCap (by unfold callerInputSize; omega) (by unfold callerInputSize; omega) + (by unfold callerInputSize; omega) le_rfl le_rfl le_rfl fits + · intro q member + exact ⟨publicAnswersCount_value view q, + publicAnswersCount_bound view entry q view.observations.length + (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) (physicalHistorySize view.observations) + le_rfl le_rfl member historyCap⟩ + +/-- All supported profiles, with an exact whole-algorithm value equation and +a physical-input polynomial; the axiom audit below uses only the standard +three kernel axioms, without any supplied algorithm-cost premise. -/ +theorem extract_polynomial_cost {R : Type} (p : ParameterBounds.Profile) (B : Nat) (iv : Digest32) (boundary : Nat) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (entry : FramedHistory) (ref : Reference) (view : View R) + (getters : PCSBCSCallerPayloadCost.OutputCosts) (originalAccess : Nat) + (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) + (fits : ref.shape.occupied ≤ ref.shape.leafWords) : + (extractCount p B iv boundary layout saved entry ref view getters + (answerPolynomial view.observations.length (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) + (physicalHistorySize view.observations)) originalAccess).1 = + extract p B iv boundary layout saved entry ref view ∧ + (extractCount p B iv boundary layout saved entry ref view getters + (answerPolynomial view.observations.length (PCSBCSCoordinateCodecCost.bodyUnits entry.frames) + (physicalHistorySize view.observations)) originalAccess).2 ≤ + physicalPolynomial p layout saved entry ref view getters originalAccess := by + have checked := extractCount_physical_polynomial p B iv boundary layout saved entry ref view + getters originalAccess entryValid fits + exact ⟨checked.1,checked.2.1⟩ + +#print axioms recognizeCount_value +#print axioms rawReferencesCount_bound +#print axioms mixedTraceCount_value +#print axioms mixedTraceCount_bound +#print axioms logCount_value +#print axioms publicAnswersCount_value +#print axioms extractCount_value +#print axioms extractCount_physical_polynomial +#print axioms extract_polynomial_cost + +end Whir.PCSBCSPublicExtractorCost diff --git a/verification/whir/Whir/PCSBCSPublicExtractorSmoke.lean b/verification/whir/Whir/PCSBCSPublicExtractorSmoke.lean new file mode 100644 index 000000000..8d95b51b1 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicExtractorSmoke.lean @@ -0,0 +1,99 @@ +-- This compiled regression exercises the public extractor and real BLAKE2s. +-- It does not assert accepted Rust-verifier execution or universal compiler refinement. +import Whir.PCSBCSPublicExtractor +import Whir.PublicMerkleProgram +import Whir.AnchoredSourceFreshCaller +open Whir Concrete Protocol FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicMerkleLog AnchoredHeaderCodec WHIRCallerRegistry WHIRCallerShape WHIRCallerClaims +set_option autoImplicit false +private def p : ParameterBounds.Profile := (⟨0,by decide⟩,⟨0,by decide⟩) +private def digest (n : Nat) : Digest32 := + fun i => ⟨(n / 256^i.val)%256,Nat.mod_lt _ (by decide)⟩ +private def layout : WHIRCallerClaims.CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ +private def zeroToken : WHIRCallerShape.EventShape → CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) +private def require (condition : Bool) (label : String) : IO Unit := do + unless condition do throw (IO.userError label) + IO.println s!"public extractor: {label}" + (← IO.getStdout).flush +private def observation (q : Coordinate) : Option Observation := + if valid : DuplexEncoding.Admissible q then + withCoordinate (compressionOf blake2sOracle) PCSBCSSourceCoordinateDecoder.seedIV q + fun answer => some ⟨.construction q valid,answer⟩ + else none + +def main : IO Unit := do + IO.println "public extractor: entering main" + (← IO.getStdout).flush + let smallDomain := ConcreteRowExtraction.domain 2 (by decide) + let mixed : Vector E smallDomain.n := Vector.ofFn fun i => smallDomain.val[i.val]! + let linear := ConcreteRowExtraction.countedExtractRow 1 1 (by decide) mixed + require (linear.1 == some #[0,1]) "mixed zero/nonzero row recovered the linear base word" + let config := ParameterBounds.config p + let shape := AnchoredSourceCaller.shape layout + let fullWords := List.replicate (2^shape.logBatch) (0 : K) + let leafBytes := ByteCodec.wordsBytes fullWords + let mut records := plan blake2sOracle leafBytes + let some (_,root) := records.getLast? | throw (IO.userError "empty leaf primitive plan") + let mut current := root + IO.println "public extractor: leaf primitive plan materialized" + (← IO.getStdout).flush + for _ in [: (PCSBCSSourceRootReferences.initialShape shape).height] do + let bytes := List.ofFn (ByteCodec.pairBytes (current,current)) + let nodes := plan blake2sOracle bytes + let some (_,root) := nodes.getLast? | throw (IO.userError "empty node primitive plan") + current := root + records := nodes ++ records + IO.println "public extractor: physical Merkle image materialized" + (← IO.getStdout).flush + let saved : Record := ⟨shape,current,⟨digest 41,fun _=>none,0,true,0,0⟩, + List.replicate config.logN 0,0⟩ + require (decide saved.Valid) "supported immutable shape" + let payload := ((WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout)).map zeroToken + let entry := tokenHistory (digest 11) (digest 13) + (payload ++ (openingScalars saved).map CallerToken.sent) + let opening := WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth config) + entry [WHIRHistoryKey.initialPending] 1 + let fake := {opening with terminal := .output 100} + let ordinary := records.reverse.map fun (n,d) => + (⟨.primitive .verification n,d⟩ : Observation) + let caller := (WHIRCallerOutputs.callerOutputs entry).filterMap observation + let some openingObservation := observation opening | throw (IO.userError "invalid opening coordinate") + let some fakeObservation := observation fake | throw (IO.userError "invalid fake coordinate") + let view : View Unit := {observations := ordinary ++ caller ++ [fakeObservation,openingObservation],result := ()} + IO.println "public extractor: caller observations materialized" + (← IO.getStdout).flush + let B := 4096 + let ref : PCSBCSSourceRootReferences.Reference := + ⟨saved.root,PCSBCSSourceRootReferences.initialShape saved.shape⟩ + let some original := PCSBCSNativePublicCapture.publicOriginal p layout saved entry view + | throw (IO.userError "public original did not parse") + require (original.lanes == 16 && original.m == 1 && original.points.isEmpty) "literal original statement recovered" + let rawFake : PublicCompressionCouplingMixed.Key B ← + if bound : pathCost fake ≤ B then + pure (.inr (constructionKey B PCSBCSSourceCoordinateDecoder.seedIV fake bound)) + else throw (IO.userError "source path exceeds the smoke budget") + require ((PCSBCSPublicExtractor.rawReferences p B PCSBCSSourceCoordinateDecoder.seedIV + entry.frames.length rawFake).isEmpty) "out-of-packet block cannot trigger first-root capture" + let some captured := PCSBCSPublicExtractor.capturedPrefix p B PCSBCSSourceCoordinateDecoder.seedIV + entry.frames.length ref view | throw (IO.userError "initial root not captured") + require (captured.any (fun event => decide (event.1 = rawFake))) "genuine first mention follows fake prequery" + let raw := PCSBCSPublicExtractor.root p B PCSBCSSourceCoordinateDecoder.seedIV + entry.frames.length ref view + require (raw.size == 2^ref.shape.height && raw.all (fun row=>row == Array.replicate shape.lanes 0)) + "full zero-prefix leaves decoded before compacting" + IO.println "public extractor: starting production-profile Gao/original decoder" + (← IO.getStdout).flush + let result := PCSBCSPublicExtractor.extract p B PCSBCSSourceCoordinateDecoder.seedIV + entry.frames.length layout saved entry ref view + let some output := result | throw (IO.userError "supported zero word not extracted") + require ((Array.ofFn output.2).all (fun word=>word == 0)) "production-profile word extracted from public view" + let changedFamily := fun i => {original.family i with slices := fun _ => 1} + require ((PCSRoundByRoundKnowledge.extract p original.lanes changedFamily original.points + original.anchorPoint original.anchorValue raw).isNone) + "false original family rejected without batching coins" + IO.println "public extractor runtime PASS (actual BLAKE2s, fixed raw-key packet range, live caller observation decoding, production profile, compact occupied suffix, full word and false original)" + (← IO.getStdout).flush diff --git a/verification/whir/Whir/PCSBCSPublicLogExtractor.lean b/verification/whir/Whir/PCSBCSPublicLogExtractor.lean index caabd29e2..d116162f5 100644 --- a/verification/whir/Whir/PCSBCSPublicLogExtractor.lean +++ b/verification/whir/Whir/PCSBCSPublicLogExtractor.lean @@ -10,38 +10,40 @@ namespace Whir.PCSBCSPublicLogExtractor open Concrete Protocol FiatShamirGame DuplexFraming DuplexPublicSimulator open PCSBCSMerkleRootCache PCSBCSSourceRootReferences -variable (p : ParameterBounds.Profile) (Q : Nat) - (layout : PublicLog → Node → WHIRCallerClaims.CallerLayout) - (savedAt : PublicLog → Node → AnchoredHeaderCodec.Record) - (entry : PublicLog → Node → FramedHistory) - (answers : PublicLog → Node → FiatShamirGame.Coordinate → Digest32) - (headers : PublicLog → Node → AnchoredHeaderRoots.Public) +variable (p : ParameterBounds.Profile) (Q boundary : Nat) + (registry : AnchoredHeaderRoots.Public) (target : AnchoredHeaderCodec.Record) -def selectPrefix : PublicLog → Option PublicLog +/-- Materialize the target's digest/geometry address once, outside the loop. -/ +def selectPrefixLoop (wanted : CacheKey) : PublicLog → Option PublicLog | [] => none | (input,_) :: queryPrefix => - match selectPrefix queryPrefix with + match selectPrefixLoop wanted queryPrefix with | some captured => some captured | none => - if (PCSBCSSourcePrimitiveRootBudget.references p Q layout savedAt entry answers headers + if (PCSBCSSourcePrimitiveRootBudget.references p Q boundary registry queryPrefix input).any (fun ref => decide - (cacheKey ref.root ref.shape = cacheKey target.root (initialShape target.shape))) then + (cacheKey ref.root ref.shape = wanted)) then some queryPrefix else none +def selectPrefix (log : PublicLog) : Option PublicLog := + selectPrefixLoop p Q boundary registry + (cacheKey target.root (initialShape target.shape)) log + /-- Later primitive queries cannot replace the already captured prefix or supply new preimages to the initial word extraction. -/ theorem selectPrefix_preserves (log captured : PublicLog) (input : Node) (digest : Digest32) - (known : selectPrefix p Q layout savedAt entry answers headers target log = some captured) : - selectPrefix p Q layout savedAt entry answers headers target ((input,digest)::log) = + (known : selectPrefix p Q boundary registry target log = some captured) : + selectPrefix p Q boundary registry target ((input,digest)::log) = some captured := by - simp only [selectPrefix,known] + simp only [selectPrefix] at known ⊢ + simp only [selectPrefixLoop,known] def extract {m : Nat} (lanes : Nat) (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) : Option (CausalGame.Witness (ParameterBounds.config p) lanes) := do - let captured ← selectPrefix p Q layout savedAt entry answers headers target log + let captured ← selectPrefix p Q boundary registry target log PCSBCSPublicRootExtractor.extract p lanes family points anchorPoint anchorValue captured target /-- Every actual returned word explains every original claim and the anchor. @@ -49,9 +51,9 @@ No collision assumption or final success-probability premise is used here. -/ theorem output_explains {m : Nat} (lanes : Nat) (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) (w : CausalGame.Witness (ParameterBounds.config p) lanes) - (returned : extract p Q layout savedAt entry answers headers target lanes family points + (returned : extract p Q boundary registry target lanes family points anchorPoint anchorValue log = some w) : - ∃ captured, selectPrefix p Q layout savedAt entry answers headers target log = some captured ∧ + ∃ captured, selectPrefix p Q boundary registry target log = some captured ∧ PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) lanes (freeze captured target.root (initialShape target.shape)).raw family points anchorPoint anchorValue w := by diff --git a/verification/whir/Whir/PCSBCSPublicLogExtractorCost.lean b/verification/whir/Whir/PCSBCSPublicLogExtractorCost.lean new file mode 100644 index 000000000..e1afdaa02 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicLogExtractorCost.lean @@ -0,0 +1,1141 @@ +import Whir.PCSBCSPublicLogExtractor +import Whir.PCSRoundByRoundSourceDecoderCost +import Whir.PCSBCSCoordinateCodecCost +import Whir.PCSBCSPublicLogParserCost +import Whir.PCSBCSSourceReferencePolynomialBound +import Whir.PCSBCSSourceSavedRecordDecoderCost +import Whir.PCSBCSRecoveredSourceVolume + +/-! PCS-only resource accounting. The predecessor relation is a LINEAR chain; +its fuel is the physical prefix length, not a recursively expanded construction +ledger. Counts below distinguish fixed-size comparisons, parser reservations, +public shape-lookup invocations and immutable retained words. Charges are +not wall-clock time or compiler instructions. The literal saved-record decoder +pays its checked physical-volume polynomial; no caller metadata is supplied. No Fiat-Shamir endpoint or concrete-hash security bound is asserted. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +namespace Whir.PCSBCSPublicLogExtractorCost +open Concrete Protocol FiatShamirGame DuplexFraming DuplexRefinement DuplexModeGame +open DuplexPublicSimulator PCSBCSMerkleRootCache PCSBCSSourceRootReferences +open SupportedCandidateExtraction +attribute [local irreducible] ParameterBounds.config + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +/-- One predicate evaluation per visited record, with early stopping. -/ +def findCount {α : Type} (test : α → Bool) : List α → Option α × Nat + | [] => (none,0) + | x::xs => if test x then (some x,1) else + let later := findCount test xs + (later.1,later.2+1) + +theorem findCount_value {α : Type} (test : α → Bool) (xs : List α) : + (findCount test xs).1 = xs.find? test := by + induction xs with + | nil => rfl + | cons x xs ih => simp only [findCount,List.find?_cons]; split <;> simp_all + +theorem findCount_bound {α : Type} (test : α → Bool) (xs : List α) : + (findCount test xs).2 ≤ xs.length := by + induction xs with + | nil => rfl + | cons x xs ih => simp only [findCount,List.length_cons]; split <;> simp only [] <;> omega + +def lookupCount (log : PublicLog) (input : Node) : Option Digest32 × Nat := + let found := findCount (fun e => decide (e.1 = input)) log + (found.1.map Prod.snd,found.2) + +def predecessorCount (log : PublicLog) (cv : Digest32) : Option Node × Nat := + let found := findCount (fun e => decide (e.2 = cv)) log + (found.1.map Prod.fst,found.2) + +theorem lookupCount_value (log : PublicLog) (input : Node) : + (lookupCount log input).1 = lookup log input := by + simp [lookupCount,lookup,findCount_value] + +theorem predecessorCount_value (log : PublicLog) (cv : Digest32) : + (predecessorCount log cv).1 = predecessor log cv := by + simp [predecessorCount,predecessor,findCount_value] + +/-- Each predecessor comparison is expanded into 512 fixed-width byte/index +operations. Seed/internal role checks reserve 1024 such operations. There is +exactly one recursive child, never a binary reconstruction ledger. -/ +def extendCount (log : PublicLog) : Nat → Digest32 → Option (List Node) × Nat + | 0,_ => (none,1) + | fuel+1,cv => + let previous := predecessorCount log cv + match previous.1 with + | none => (none,512*previous.2+1024) + | some n => + if isSeed n then (some [n],512*previous.2+1024) + else if isInternal n then + let rest := extendCount log fuel n.cv + (rest.1.map (n::·),512*previous.2+1024+rest.2) + else (none,512*previous.2+1024) + +theorem extendCount_value (log : PublicLog) (fuel : Nat) (cv : Digest32) : + (extendCount log fuel cv).1 = extend log fuel cv := by + induction fuel generalizing cv with + | zero => rfl + | succ fuel ih => + simp only [extendCount,extend] + rw [predecessorCount_value] + cases h : predecessor log cv with + | none => rfl + | some n => + dsimp only + split + · rfl + · split <;> simp [ih] + +theorem extendCount_bound (log : PublicLog) (fuel : Nat) (cv : Digest32) : + (extendCount log fuel cv).2 ≤ fuel*(512*log.length+1024)+1 := by + induction fuel generalizing cv with + | zero => simp [extendCount] + | succ fuel ih => + have scan := findCount_bound (fun e : Node × Digest32 => decide (e.2 = cv)) log + change (predecessorCount log cv).2 ≤ log.length at scan + simp only [extendCount] + cases (predecessorCount log cv).1 with + | none => simp only []; nlinarith + | some n => + dsimp only + split + · simp only []; nlinarith + · split + · have later := ih n.cv; simp only []; nlinarith + · nlinarith + +def recognizedCount (log : PublicLog) (input : Node) : Option (List Node) × Nat := + if isTerminal input then + let body := extendCount log log.length input.cv + (body.1.map (input::·),body.2+log.length+1024) + else (none,1) + +theorem recognizedCount_value (log : PublicLog) (input : Node) : + (recognizedCount log input).1 = recognized log input := by + simp only [recognizedCount,recognized]; split <;> simp [extendCount_value] + +/-- Mapping both payload/template lists, their length guards, and short-list +construction are reserved linearly in the actual recognized length. -/ +def privateKeyCount (Q : Nat) (log : PublicLog) (input : Node) : Option (RawKey Q) × Nat := + let repeated := lookupCount log input + if repeated.1.isSome then (none,1024*repeated.2+1) else + let tree := recognizedCount log input + match tree.1 with + | none => (none,1024*repeated.2+tree.2+1) + | some ns => + (if h : ns.length ≤ Q then + some (restrictKey Q ⟨ns.map payload,ns.map (fun n => (n.tweak,n.last))⟩ + (by simpa using h) (by simpa using h)) else none, + 1024*repeated.2+tree.2+8*ns.length+4) + +theorem privateKeyCount_value (Q : Nat) (log : PublicLog) (input : Node) : + (privateKeyCount Q log input).1 = privateKey Q log input := by + simp only [privateKeyCount,privateKey,lookupCount_value,recognizedCount_value] + split + · rfl + · cases recognized log input <;> rfl + +def recognitionPolynomial (Q : Nat) : Nat := Q*(512*Q+1024)+1040*Q+2048 + +theorem privateKeyCount_bound (Q : Nat) (log : PublicLog) (input : Node) : + (privateKeyCount Q log input).2 ≤ recognitionPolynomial log.length := by + have scan := findCount_bound (fun e : Node × Digest32 => decide (e.1 = input)) log + change (lookupCount log input).2 ≤ log.length at scan + have chain := extendCount_bound log log.length input.cv + have roles : (recognizedCount log input).2 ≤ log.length*(512*log.length+1024)+log.length+1025 := by + unfold recognizedCount + split + · simp only []; omega + · simp only []; omega + unfold privateKeyCount + dsimp only + split + · simp only []; unfold recognitionPolynomial; omega + · cases h : (recognizedCount log input).1 with + | none => simp only []; unfold recognitionPolynomial; omega + | some ns => + have size := (recognized_sound (recognizedCount_value log input ▸ h)).2 + simp only [] + unfold recognitionPolynomial + omega + +/-- Proven bound for concrete byte parsing, plan reconstruction and whole-key +equality, plus materialization of both bounded raw-key lists. -/ +def codecReservation (Q : Nat) : Nat := + PCSBCSCoordinateCodecCost.extractedPolynomial (Q+1)+16*(Q+1)+2 + +def recoverCount (Q : Nat) (iv : Digest32) (log : PublicLog) (input : Node) : + Option Coordinate × Nat := + let raw := privateKeyCount Q log input + match raw.1 with + | none => (none,raw.2) + | some key => + let decoded := PCSBCSCoordinateCodecCost.decodeExtractedCount iv (expandKey key) + (decoded.1,raw.2+decoded.2+8*(key.1.1.val+key.2.1.val)+2) + +theorem recoverCount_value (Q : Nat) (iv : Digest32) (log : PublicLog) (input : Node) : + (recoverCount Q iv log input).1 = PCSBCSSourceCoordinateDecoder.recover Q iv log input := by + simp only [recoverCount,privateKeyCount_value,PCSBCSSourceCoordinateDecoder.recover] + cases privateKey Q log input <;> + simp only [PCSBCSCoordinateCodecCost.decodeExtractedCount_value, + Option.bind_none,Option.bind_some,PCSBCSSourceCoordinateDecoder.decode] + +theorem recoverCount_bound (Q : Nat) (iv : Digest32) (log : PublicLog) (input : Node) : + (recoverCount Q iv log input).2 ≤ + recognitionPolynomial log.length + codecReservation log.length := by + have rawBound := privateKeyCount_bound Q log input + unfold recoverCount + dsimp only + cases h : (privateKeyCount Q log input).1 with + | none => unfold codecReservation; dsimp only; omega + | some key => + have sizes := privateKey_lengths_log (privateKeyCount_value Q log input ▸ h) + have decodeBound := PCSBCSCoordinateCodecCost.decodeExtractedCount_bound iv (expandKey key) + (log.length+1) (by simpa [expandKey,expandShort] using sizes.1) + (by simpa [expandKey,expandShort] using sizes.2) + unfold codecReservation + dsimp only + omega + +theorem recognitionPolynomial_mono {a b : Nat} (cap : a ≤ b) : + recognitionPolynomial a ≤ recognitionPolynomial b := by + unfold recognitionPolynomial + nlinarith [Nat.mul_le_mul cap cap] + +theorem codecReservation_mono {a b : Nat} (cap : a ≤ b) : + codecReservation a ≤ codecReservation b := by + have shifted : a+3 ≤ b+3 := Nat.add_le_add_right cap 3 + unfold codecReservation PCSBCSCoordinateCodecCost.extractedPolynomial + nlinarith [Nat.mul_le_mul shifted shifted] + +/-- Physical Q, not the recursive source-construction path ledger: at most Q +predecessor stages, each scanning at most Q fixed-size public nodes. -/ +theorem recoverCount_physical_bound (Q : Nat) (iv : Digest32) + (log : PublicLog) (input : Node) (queryCap : log.length ≤ Q) : + (recoverCount Q iv log input).2 ≤ recognitionPolynomial Q+codecReservation Q := + (recoverCount_bound Q iv log input).trans + (Nat.add_le_add (recognitionPolynomial_mono queryCap) (codecReservation_mono queryCap)) + +/-- The only scanner callback is the fixed public registry's shape lookup. +Original-input allowances price the separate full-root backend, not scanning. -/ +structure MetadataCosts where + shape : Nat + originalFamily : Nat + originalSlice : Nat + +structure Calls where + shape : Nat := 0 + deriving Repr + +def Calls.add (a b : Calls) : Calls := ⟨a.shape+b.shape⟩ +def Calls.cost (a : Calls) (c : MetadataCosts) : Nat := a.shape*c.shape + +theorem Calls.add_cost (a b : Calls) (cost : MetadataCosts) : + (a.add b).cost cost = a.cost cost+b.cost cost := by + simp only [Calls.add,Calls.cost] + ring + +variable (p : ParameterBounds.Profile) (Q boundary : Nat) + (registry : AnchoredHeaderRoots.Public) (target : AnchoredHeaderCodec.Record) + +/-- Exact outer header decoding: concrete suffix/scalar parsing and fixed-word +header checks. The nested shapes getter is called only after its domain guard. -/ +def headerCount (registry : AnchoredHeaderRoots.Public) (history : FramedHistory) : + Option AnchoredHeaderRoots.Header × Nat × Nat := + if history.domain = registry.domain then + match registry.shapes history.statement with + | none => (none,1026,1) + | some shape => + let shapeCost := PCSBCSCallerPayloadCost.shapeValidWork shape + if shape.Valid then + match history.frames.getLast? with + | some (.absorb _ bytes) => + if 120 ≤ bytes.length then + let scalars := PCSBCSPublicLogParserCost.parseExactCount 5 (bytes.drop (bytes.length-120)) + match scalars.1 with + | none => (none,scalars.2+3*bytes.length+history.frames.length+shapeCost+1032,1) + | some values => + ((AnchoredHeaderCodec.parseHeader shape values).map + (fun root => ⟨history.statement,shape,root⟩), + scalars.2+PCSBCSCallerPayloadCost.headerWork shape values+ + 3*bytes.length+history.frames.length+shapeCost+1544,1) + else (none,2*bytes.length+history.frames.length+shapeCost+1032,1) + | _ => (none,history.frames.length+shapeCost+1030,1) + else (none,shapeCost+1028,1) + else (none,1024,0) + +theorem headerCount_value (registry : AnchoredHeaderRoots.Public) (history : FramedHistory) : + (headerCount registry history).1 = AnchoredHeaderRoots.fromHistory registry history := by + unfold headerCount AnchoredHeaderRoots.fromHistory + split + · cases registry.shapes history.statement with + | none => rfl + | some shape => + dsimp only + split + · cases history.frames.getLast? with + | none => rfl + | some frame => + cases frame with + | nonce previous bits nonce => rfl + | absorb previous bytes => + dsimp only + split + · rw [PCSBCSPublicLogParserCost.parseExactCount_value] + cases WHIRHistory.parseExact 5 (bytes.drop (bytes.length-120)) <;> rfl + · rfl + · rfl + · rfl + +theorem shapeValidWork_fixed (shape : AnchoredHeaderCodec.Shape) : + PCSBCSCallerPayloadCost.shapeValidWork shape ≤ 256 := by + unfold PCSBCSCallerPayloadCost.shapeValidWork + repeat' first | omega | split + +def headerPolynomial (P : Nat) : Nat := 10000+4*P + +theorem headerCount_bound (registry : AnchoredHeaderRoots.Public) (history : FramedHistory) : + (headerCount registry history).2.1 ≤ + headerPolynomial (PCSBCSPublicLogParserCost.framesSize history.frames) ∧ + (headerCount registry history).2.2 ≤ 1 := by + have count := PCSBCSPublicLogParserCost.framesSize_length history.frames + unfold headerCount + split + · cases shapeAt : registry.shapes history.statement with + | none => simp only [headerPolynomial]; omega + | some shape => + have shapeBound := shapeValidWork_fixed shape + dsimp only + split + · cases last : history.frames.getLast? with + | none => dsimp only; unfold headerPolynomial; constructor <;> omega + | some frame => + cases frame with + | nonce previous bits nonce => + dsimp only + unfold headerPolynomial + constructor <;> omega + | absorb previous bytes => + have member := List.mem_of_getLast? last + have size : PCSBCSPublicLogParserCost.frameSize (.absorb previous bytes) ≤ + PCSBCSPublicLogParserCost.framesSize history.frames := by + unfold PCSBCSPublicLogParserCost.framesSize + exact List.le_sum_of_mem (List.mem_map.mpr ⟨.absorb previous bytes,member,rfl⟩) + simp only [PCSBCSPublicLogParserCost.frameSize] at size + dsimp only + split + · have suffixSize : (bytes.drop (bytes.length-120)).length ≤ 120 := by + simp only [List.length_drop] + omega + have scalarBound := PCSBCSPublicLogParserCost.parseExactCount_bound 5 + (bytes.drop (bytes.length-120)) + have scalarCap : (PCSBCSPublicLogParserCost.parseExactCount 5 + (bytes.drop (bytes.length-120))).2 ≤ 6866 := by omega + cases parsed : (PCSBCSPublicLogParserCost.parseExactCount 5 + (bytes.drop (bytes.length-120))).1 with + | none => + try dsimp only + unfold headerPolynomial + constructor <;> omega + | some values => + have headerBound := PCSBCSCallerPayloadCost.headerWork_le shape values + try dsimp only + unfold headerPolynomial + constructor <;> omega + · try dsimp only + unfold headerPolynomial + constructor <;> omega + · dsimp only; unfold headerPolynomial; constructor <;> omega + · simp only [headerPolynomial]; omega + + +/-- Count the actual saved decoder and scheduled-key parser. The saved +record is neither supplied nor reconstructed by an opaque callback. The shape +exponent charge is explicit; supported valid records have logBatch < 64. -/ +def openingReferencesCount (key : Coordinate) : Option (List Reference) × Nat := + let callerEntry := PCSBCSSourcePrimitiveRootBudget.entry key boundary + let entryWork := callerEntry.frames.length+1 + let saved := PCSBCSSourceSavedRecordDecoderCost.decodeCount p callerEntry + match saved.1 with + | none => (none,entryWork+saved.2+1) + | some record => + let pending := PCSBCSSourceReferenceParserCost.parsePendingKeyCount p callerEntry key + match pending.1 with + | none => (none,entryWork+saved.2+pending.2+1) + | some messages => + (if phaseRolesAdmitted (ParameterBounds.config p) messages then + some (⟨record.root,initialShape record.shape⟩ :: + phaseReferences (ParameterBounds.config p) messages) + else none, + entryWork+saved.2+pending.2+PCSBCSSourceReferenceParserCost.phaseWork + (ParameterBounds.config p) messages+3*record.shape.logBatch+4) + +theorem openingReferencesCount_value (key : Coordinate) : + (openingReferencesCount p boundary key).1 = + PCSBCSSourcePrimitiveRootBudget.openingReferences p boundary key := by + unfold openingReferencesCount PCSBCSSourcePrimitiveRootBudget.openingReferences + PCSBCSSourcePrimitiveRootBudget.openingReferencesFromEntry + dsimp only + rw [PCSBCSSourceSavedRecordDecoderCost.decodeCount_value] + cases PCSBCSSourceSavedRecordDecoder.decode p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) with + | none => rfl + | some saved => + dsimp only [Bind.bind,Option.bind] + simp only [PCSBCSSourceReferenceParserCost.parsePendingKeyCount_value] + cases parsePendingKey p (PCSBCSSourcePrimitiveRootBudget.entry key boundary) key <;> rfl + +/-- P+1 pays the shared entry take. 204 is the phase counter's eight-unit tail +plus 3*64+4 for initial-shape construction, not a caller-work reserve. -/ +def openingReferencePolynomial (profile : ParameterBounds.Profile) (W P S : Nat) : Nat := + PCSBCSSourceSavedRecordDecoderCost.physicalPolynomial S+ + PCSBCSSourceReferencePolynomialBound.pendingKeyPolynomial (ParameterBounds.config profile) W P+ + (P+1)*(98*PCSBCSSourceReferencePolynomialBound.configSize (ParameterBounds.config profile)+4106)+P+205 + +theorem openingReferencesCount_bound (key : Coordinate) (W P S : Nat) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (keyCap : PCSBCSPublicLogParserCost.framesSize key.history.frames ≤ P) + (physicalCap : PCSBCSSourceSavedRecordDecoderCost.physicalSize + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) ≤ S) : + (openingReferencesCount p boundary key).2 ≤ openingReferencePolynomial p W P S := by + have entryCap : PCSBCSPublicLogParserCost.framesSize + (PCSBCSSourcePrimitiveRootBudget.entry key boundary).frames ≤ P := + (PCSBCSPublicLogParserCost.framesSize_take _ _).trans keyCap + have entryLength : (PCSBCSSourcePrimitiveRootBudget.entry key boundary).frames.length ≤ P := + (PCSBCSPublicLogParserCost.framesSize_length _).trans entryCap + have savedBound := PCSBCSSourceSavedRecordDecoderCost.decodeCount_bound p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) + have savedCap : (PCSBCSSourceSavedRecordDecoderCost.decodeCount p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary)).2 ≤ + PCSBCSSourceSavedRecordDecoderCost.physicalPolynomial S := by + apply savedBound.trans + unfold PCSBCSSourceSavedRecordDecoderCost.physicalPolynomial + gcongr + have pendingCap := PCSBCSSourceReferencePolynomialBound.parsePendingKeyCount_work p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) key W P width entryCap keyCap + unfold openingReferencesCount + dsimp only + cases decoded : (PCSBCSSourceSavedRecordDecoderCost.decodeCount p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary)).1 with + | none => simp only []; unfold openingReferencePolynomial; omega + | some saved => + have accepted : PCSBCSSourceSavedRecordDecoder.decode p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) = some saved := by + rw [← PCSBCSSourceSavedRecordDecoderCost.decodeCount_value,decoded] + have valid := (PCSBCSSourceSavedRecordDecoder.decode_sound p _ saved accepted).1 + have batch : saved.shape.logBatch < 64 := lt_trans valid.1.1 valid.1.2.1 + dsimp only + cases pending : (PCSBCSSourceReferenceParserCost.parsePendingKeyCount p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) key).1 with + | none => simp only []; unfold openingReferencePolynomial; omega + | some messages => + have mass := PCSBCSSourceReferencePolynomialBound.parsePendingKeyCount_mass p + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) key messages pending + have phase := PCSBCSSourceReferencePolynomialBound.phaseWork_bound + (ParameterBounds.config p) messages + have phaseCap : PCSBCSSourceReferenceParserCost.phaseWork (ParameterBounds.config p) messages ≤ + (P+1)*(98*PCSBCSSourceReferencePolynomialBound.configSize (ParameterBounds.config p)+4106)+8 := by + apply phase.trans + apply Nat.add_le_add_right + exact Nat.mul_le_mul_right _ (by omega) + simp only [] + unfold openingReferencePolynomial + omega + +/-- Header parsing and materializing its cache shape are separate computations: +the latter performs the initial full-image width exponent once. -/ +def headerShapeWork : Option AnchoredHeaderRoots.Header → Nat + | none => 1 + | some header => 3*header.shape.logBatch+4 + +theorem headerShapeWork_bound (headers : AnchoredHeaderRoots.Public) (history : FramedHistory) : + headerShapeWork (headerCount headers history).1 ≤ 196 := by + cases parsed : (headerCount headers history).1 with + | none => simp [headerShapeWork] + | some header => + have accepted : AnchoredHeaderRoots.fromHistory headers history = some header := by + rw [← headerCount_value,parsed] + have valid := (AnchoredHeaderRoots.fromHistory_valid headers history header accepted).2.2.2 + have batch : header.shape.logBatch < 64 := lt_trans valid.1 valid.2.1 + simp only [headerShapeWork] + omega + +/-- One recovery, independent anchor decoding, then optional saved-opening +recovery. Shared entry take and both opening/anchor cache shapes are charged. -/ +def referencesCount (_cost : MetadataCosts) (log : PublicLog) (input : Node) : + List Reference × Nat × Calls := + let recovered := recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV log input + match recovered.1 with + | none => ([],recovered.2,{}) + | some key => + let anchored := + match key.terminal with + | .output _ => + let decoded := headerCount registry key.history + ((decoded.1.map + (fun h : AnchoredHeaderRoots.Header => [(⟨h.root,initialShape h.shape⟩ : Reference)])).getD [], + decoded.2.1+headerShapeWork decoded.1,decoded.2.2) + | _ => ([],1,0) + let parsed := openingReferencesCount p boundary key + (anchored.1 ++ parsed.1.getD [], + recovered.2+anchored.2.1+parsed.2+anchored.1.length+1, + ⟨anchored.2.2⟩) + +theorem referencesCount_value (cost : MetadataCosts) (log : PublicLog) (input : Node) : + (referencesCount p Q boundary registry cost log input).1 = + PCSBCSSourcePrimitiveRootBudget.references p Q boundary registry log input := by + unfold referencesCount PCSBCSSourcePrimitiveRootBudget.references + dsimp only + rw [recoverCount_value] + cases PCSBCSSourceCoordinateDecoder.recover Q PCSBCSSourceCoordinateDecoder.seedIV log input with + | none => rfl + | some key => + dsimp only + simp only [openingReferencesCount_value,Option.map_some,Option.getD_some] + unfold PCSBCSSourcePrimitiveRootBudget.anchorReferences + cases key.terminal <;> try rfl + simp only [headerCount_value] + cases AnchoredHeaderRoots.fromHistory registry key.history <;> rfl + +theorem referencesCount_callback_cost (cost : MetadataCosts) (log : PublicLog) (input : Node) : + (referencesCount p Q boundary registry cost log input).2.2.cost cost ≤ cost.shape := by + unfold referencesCount + dsimp only + cases (recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV log input).1 with + | none => simp [Calls.cost] + | some key => + have shapeCap := (headerCount_bound registry key.history).2 + dsimp only [Calls.cost] + cases key.terminal <;> dsimp only + all_goals nlinarith [Nat.mul_le_mul_right cost.shape shapeCap] + +def sourceReferencePolynomial (profile : ParameterBounds.Profile) (queries W P S : Nat) : Nat := + recognitionPolynomial queries+codecReservation queries+headerPolynomial P+ + openingReferencePolynomial profile W P S+198 + +theorem referencesCount_polynomial (cost : MetadataCosts) (log : PublicLog) (input : Node) + (W P S : Nat) (queryCap : log.length ≤ Q) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (keyCaps : ∀ key, (recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV log input).1 = some key → + PCSBCSPublicLogParserCost.framesSize key.history.frames ≤ P) + (physicalCaps : ∀ key, (recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV log input).1 = some key → + PCSBCSSourceSavedRecordDecoderCost.physicalSize + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) ≤ S) : + (referencesCount p Q boundary registry cost log input).2.1 ≤ + sourceReferencePolynomial p Q W P S := by + have recoveredCap := recoverCount_physical_bound Q PCSBCSSourceCoordinateDecoder.seedIV log input queryCap + unfold referencesCount + dsimp only + cases recovered : (recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV log input).1 with + | none => simp only []; unfold sourceReferencePolynomial; omega + | some key => + have keyCap := keyCaps key recovered + have openingCap := openingReferencesCount_bound p boundary key W P S width keyCap + (physicalCaps key recovered) + have headerCap := (headerCount_bound registry key.history).1 + have headerShapeCap := headerShapeWork_bound registry key.history + have headerWorkCap : (headerCount registry key.history).2.1 ≤ headerPolynomial P := by + unfold headerPolynomial at headerCap ⊢ + omega + have anchorLength : (((headerCount registry key.history).1.map + (fun h : AnchoredHeaderRoots.Header => [(⟨h.root,initialShape h.shape⟩ : Reference)])).getD []).length ≤ 1 := by + cases (headerCount registry key.history).1 <;> simp + dsimp only + cases key.terminal <;> dsimp only [List.length] <;> + unfold sourceReferencePolynomial headerPolynomial at * <;> omega + +#print axioms openingReferencesCount_value +#print axioms openingReferencesCount_bound +#print axioms referencesCount_polynomial + +structure Selection where + value : Option PublicLog + operations : Nat + callbacks : Calls + referencesEvaluated : Nat + targetComparisons : Nat + +/-- The target CV/height/full-width/occupied key is materialized once. Every +visited reference comparison reserves 2048 byte/index/equality operations. +After the first capture, later records perform only one recursion visit. -/ +def selectPrefixLoop (cost : MetadataCosts) (wanted : CacheKey) : PublicLog → Selection + | [] => ⟨none,1,{},0,0⟩ + | (input,_)::log => + let prior := selectPrefixLoop cost wanted log + match prior.value with + | some captured => {prior with value := some captured,operations := prior.operations+1} + | none => + let refs := referencesCount p Q boundary registry cost log input + let found := findCount (fun ref => decide (cacheKey ref.root ref.shape = wanted)) refs.1 + ⟨if found.1.isSome then some log else none, + prior.operations+refs.2.1+2048*found.2+1, + Calls.add prior.callbacks refs.2.2,prior.referencesEvaluated+1, + prior.targetComparisons+found.2⟩ + +def selectPrefixCount (cost : MetadataCosts) (log : PublicLog) : Selection := + let selected := selectPrefixLoop p Q boundary registry cost + (cacheKey target.root (initialShape target.shape)) log + {selected with operations := selected.operations+256+3*target.shape.logBatch} + +theorem findCount_isSome {α : Type} (test : α → Bool) (xs : List α) : + (findCount test xs).1.isSome = xs.any test := by + induction xs with + | nil => rfl + | cons x xs ih => + simp only [findCount,List.any_cons] + split <;> simp_all + +theorem selectPrefixLoop_value (cost : MetadataCosts) (wanted : CacheKey) (log : PublicLog) : + (selectPrefixLoop p Q boundary registry cost wanted log).value = + PCSBCSPublicLogExtractor.selectPrefixLoop p Q boundary registry wanted log := by + induction log with + | nil => rfl + | cons record log ih => + rcases record with ⟨input,digest⟩ + simp only [selectPrefixLoop,PCSBCSPublicLogExtractor.selectPrefixLoop,ih] + cases PCSBCSPublicLogExtractor.selectPrefixLoop p Q boundary registry wanted log with + | some captured => rfl + | none => simp only [findCount_isSome,referencesCount_value] + +theorem selectPrefixCount_value (cost : MetadataCosts) (log : PublicLog) : + (selectPrefixCount p Q boundary registry target cost log).value = + PCSBCSPublicLogExtractor.selectPrefix p Q boundary registry target log := by + exact selectPrefixLoop_value p Q boundary registry cost + (cacheKey target.root (initialShape target.shape)) log + +theorem selectPrefixLoop_calls (cost : MetadataCosts) (wanted : CacheKey) (log : PublicLog) : + (selectPrefixLoop p Q boundary registry cost wanted log).referencesEvaluated ≤ log.length := by + induction log with + | nil => simp [selectPrefixLoop] + | cons record log ih => + rcases record with ⟨input,digest⟩ + simp only [selectPrefixLoop,List.length_cons] + split <;> dsimp only <;> omega + +theorem selectPrefixCount_calls (cost : MetadataCosts) (log : PublicLog) : + (selectPrefixCount p Q boundary registry target cost log).referencesEvaluated ≤ log.length := by + exact selectPrefixLoop_calls p Q boundary registry cost _ log + +/-- Exact source predicate visits, independently of key caching. A costly +target digest closure in the original uncached source selector is evaluated +at every visited target predicate, not merely once per root or log record. -/ +theorem selectPrefixLoop_comparisons (cost : MetadataCosts) (wanted : CacheKey) + (log : PublicLog) (queryCap : log.length ≤ Q) : + (selectPrefixLoop p Q boundary registry cost wanted log).targetComparisons ≤ + log.length*(Q+1) := by + induction log with + | nil => simp [selectPrefixLoop] + | cons record log ih => + rcases record with ⟨input,digest⟩ + have prefixCap : log.length ≤ Q := by simp only [List.length_cons] at queryCap; omega + have prior := ih prefixCap + have refsCap := PCSBCSSourcePrimitiveRootBudget.references_le p Q boundary registry log input + have visits := findCount_bound (fun ref : Reference => decide (cacheKey ref.root ref.shape = wanted)) + (referencesCount p Q boundary registry cost log input).1 + rw [referencesCount_value] at visits + have visitedCap : + (findCount (fun ref : Reference => decide (cacheKey ref.root ref.shape = wanted)) + (referencesCount p Q boundary registry cost log input).1).2 ≤ Q+1 := by + rw [referencesCount_value] + omega + simp only [selectPrefixLoop,List.length_cons] + split <;> dsimp only <;> nlinarith + +/-- Explicit extra price for an arbitrary target Digest32 closure. Both actual +and counted selectors cache the key once. After capture the counted freeze +also reads the root for its input-volume pass, in addition to the freeze key. -/ +def targetDigestReadReservation (selected : Selection) : Nat := + 1+(if selected.value.isSome then 2 else 0) + +def targetDigestSurcharge (selected : Selection) (price : Fin 32 → Nat) : Nat := + targetDigestReadReservation selected*(List.ofFn price).sum + +theorem targetDigestSurcharge_bound (cost : MetadataCosts) (log : PublicLog) + (price : Fin 32 → Nat) : + targetDigestSurcharge + (selectPrefixCount p Q boundary registry target cost log) price ≤ + 3*(List.ofFn price).sum := by + unfold targetDigestSurcharge + apply Nat.mul_le_mul_right + unfold targetDigestReadReservation + split <;> omega + + +theorem selectPrefixLoop_callback_cost (cost : MetadataCosts) (wanted : CacheKey) + (log : PublicLog) : + (selectPrefixLoop p Q boundary registry cost wanted log).callbacks.cost cost ≤ + log.length*cost.shape := by + induction log with + | nil => simp [selectPrefixLoop,Calls.cost] + | cons record log ih => + rcases record with ⟨input,digest⟩ + have prior := ih + have current := referencesCount_callback_cost p Q boundary registry cost log input + simp only [selectPrefixLoop,List.length_cons] + split + · dsimp only; nlinarith + · dsimp only; rw [Calls.add_cost]; nlinarith + +theorem selectPrefixCount_callback_cost (cost : MetadataCosts) (log : PublicLog) + : + (selectPrefixCount p Q boundary registry target cost log).callbacks.cost cost ≤ + log.length*cost.shape := by + exact selectPrefixLoop_callback_cost p Q boundary registry cost _ log + + +/-- Composition only: the concrete parser polynomial below discharges the +per-reference cap. This lemma never accepts a replacement parser or oracle. -/ +theorem selectPrefixLoop_operations (cost : MetadataCosts) (wanted : CacheKey) + (log : PublicLog) (B : Nat) (queryCap : log.length ≤ Q) + (referenceCap : ∀ queryPrefix input, queryPrefix.length ≤ Q → + (referencesCount p Q boundary registry cost queryPrefix input).2.1 ≤ B) : + (selectPrefixLoop p Q boundary registry cost wanted log).operations ≤ + log.length*(B+2048*(Q+1)+1)+1 := by + induction log with + | nil => simp [selectPrefixLoop] + | cons record log ih => + rcases record with ⟨input,digest⟩ + have prefixCap : log.length ≤ Q := by simp only [List.length_cons] at queryCap; omega + have prior := ih prefixCap + have parser := referenceCap log input prefixCap + have refsCap := PCSBCSSourcePrimitiveRootBudget.references_le p Q boundary registry log input + have findCap := findCount_bound (fun ref : Reference => decide (cacheKey ref.root ref.shape = wanted)) + (referencesCount p Q boundary registry cost log input).1 + rw [referencesCount_value] at findCap + have actualFindCap : + (findCount (fun ref : Reference => decide (cacheKey ref.root ref.shape = wanted)) + (referencesCount p Q boundary registry cost log input).1).2 ≤ Q+1 := by + rw [referencesCount_value] + omega + simp only [selectPrefixLoop,List.length_cons] + split <;> dsimp only <;> nlinarith + +theorem selectPrefixCount_operations (cost : MetadataCosts) (log : PublicLog) (B : Nat) + (queryCap : log.length ≤ Q) + (referenceCap : ∀ queryPrefix input, queryPrefix.length ≤ Q → + (referencesCount p Q boundary registry cost queryPrefix input).2.1 ≤ B) : + (selectPrefixCount p Q boundary registry target cost log).operations ≤ + log.length*(B+2048*(Q+1)+1)+1+256+3*target.shape.logBatch := by + have bound := selectPrefixLoop_operations p Q boundary registry cost + (cacheKey target.root (initialShape target.shape)) log B queryCap referenceCap + change (selectPrefixLoop p Q boundary registry cost + (cacheKey target.root (initialShape target.shape)) log).operations+256+3*target.shape.logBatch ≤ _ + omega + + +open MerkleQueryLogExtraction PCSBCSMerkleQueryLog PCSBCSMerkleLeafImages + +/-- One replay/preimage index and one fused full-image/suffix table. The +counter projections reuse their values; no second sourceCells is executed. -/ +def freezeCount (log : PublicLog) (root : Digest32) (shape : Shape) : Frozen × Nat := + let replayed := MerkleQueryLogExtraction.PublicCost.recordsFrom log log + let indexed := countedBuild replayed.1 + let cells := countedCells canonicalCodec indexed.1 shape.leafWords shape.occupied + (defaultCell shape.leafWords shape.occupied) shape.height root #[] + let compact := compactTable cells.1 + let images := ((cells.1.toList.map (fun cell => cell.image.size)).sum) + let words := ((compact.toList.map Array.size).sum) + (⟨shape,log,cells.1,compact⟩, + 2+replayed.2+indexed.2+cells.2+inputByteVolume canonicalCodec indexed.1 shape.height root+ + 2*cells.1.size+2*images+words) + +theorem replayedRecords_value (log : PublicLog) : + (MerkleQueryLogExtraction.PublicCost.recordsFrom log log).1 = + PublicMerkleLog.records log := by + rw [MerkleQueryLogExtraction.PublicCost.recordsFrom_value] + rfl + +theorem freezeCount_value (log : PublicLog) (root : Digest32) (shape : Shape) : + (freezeCount log root shape).1 = freeze log root shape := by + simp only [freezeCount,replayedRecords_value,countedBuild_value,countedCells_value, + freeze,sourceCells] + +theorem freezeCount_charge (log : PublicLog) (root : Digest32) (shape : Shape) : + (freezeCount log root shape).2 = + operationCharge (∅ : Registry) ⟨log,root,shape⟩ := by + simp only [freezeCount,replayedRecords_value,countedBuild_value,countedCells_value, + operationCharge,Std.ExtHashMap.getElem?_empty,sourceCells,imageSlots,compactSlots, + imageTable,Array.toList_map,List.map_map,Function.comp_def] + +theorem freezeCount_bound (log : PublicLog) (root : Digest32) (shape : Shape) + (Q N L O : Nat) (queryCap : log.length ≤ Q) (rowCap : 2^shape.height ≤ N) + (leafCap : shape.leafWords ≤ L) (occupiedCap : shape.occupied ≤ O) + (fits : shape.occupied ≤ shape.leafWords) : + (freezeCount log root shape).2 ≤ operationBudget Q N L O := by + rw [freezeCount_charge] + exact (announcement_charges (∅ : Registry) ⟨log,root,shape⟩ Q N L O + queryCap rowCap leafCap occupiedCap fits).1 + +/-- Actual retained image and compact field-word slots; unavailable cells and +bad padding remain status-bearing cells, not authenticated zero leaves. -/ +theorem freezeCount_retained (log : PublicLog) (root : Digest32) (shape : Shape) + (Q N L O : Nat) (queryCap : log.length ≤ Q) (rowCap : 2^shape.height ≤ N) + (leafCap : shape.leafWords ≤ L) (occupiedCap : shape.occupied ≤ O) + (fits : shape.occupied ≤ shape.leafWords) : + ((imageTable (freezeCount log root shape).1.cells).toList.map Array.size).sum+ + (((freezeCount log root shape).1.raw).toList.map Array.size).sum ≤ N*(L+O) ∧ + (freezeCount log root shape).1.cells.size ≤ N ∧ + (freezeCount log root shape).1.queryPrefix.length ≤ Q := by + rw [freezeCount_value] + have charges := announcement_charges (∅ : Registry) ⟨log,root,shape⟩ Q N L O + queryCap rowCap leafCap occupiedCap fits + simpa only [wordCharge,cellCharge,prefixCharge,Std.ExtHashMap.getElem?_empty, + imageSlots,compactSlots,freeze] using + And.intro charges.2.2.1 (And.intro charges.2.2.2.1 charges.2.2.2.2) + +#print axioms freezeCount_bound +#print axioms freezeCount_retained + +/-- The actual full-root helper, with one counted freeze and one counted Gao/ +original-statement run. The raw field-operation counter is kept separate from +opaque original-accessor prices. -/ +def rootCount {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) + (saved : AnchoredHeaderCodec.Record) : + Option (CausalGame.Witness (ParameterBounds.config profile) lanes) × Nat × Nat := + let frozen := freezeCount log saved.root (initialShape saved.shape) + let decoded := PCSRoundByRoundSource.countedRun profile lanes family points + anchorPoint anchorValue frozen.1.raw + (decoded.1,frozen.2,decoded.2) + +theorem rootCount_value {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) + (saved : AnchoredHeaderCodec.Record) : + (rootCount profile lanes family points anchorPoint anchorValue log saved).1 = + PCSBCSPublicRootExtractor.extract profile lanes family points anchorPoint anchorValue log saved := by + simp only [rootCount,PCSRoundByRoundSource.countedRun_value,freezeCount_value, + PCSBCSPublicRootExtractor.extract] + +theorem rootCount_bound {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) + (saved : AnchoredHeaderCodec.Record) (queries N L O : Nat) + (queryCap : log.length ≤ queries) + (rowsCap : 2^(initialShape saved.shape).height ≤ N) + (leafCap : (initialShape saved.shape).leafWords ≤ L) + (occupiedCap : (initialShape saved.shape).occupied ≤ O) + (fits : (initialShape saved.shape).occupied ≤ (initialShape saved.shape).leafWords) : + (rootCount profile lanes family points anchorPoint anchorValue log saved).2.1+ + (rootCount profile lanes family points anchorPoint anchorValue log saved).2.2 ≤ + operationBudget queries N L O + + PCSRoundByRoundSource.resourcePolynomial (blockLength (ParameterBounds.config profile)) + (laneCount (ParameterBounds.config profile)) lanes m points.size := by + exact Nat.add_le_add (freezeCount_bound log saved.root (initialShape saved.shape) + queries N L O queryCap rowsCap leafCap occupiedCap fits) + (PCSRoundByRoundSource.countedRun_polynomial_cost profile lanes family points + anchorPoint anchorValue (freezeCount log saved.root (initialShape saved.shape)).1.raw) + +/-- Preserve the existing kernel's raw field-operation/resource counter, before +the separate Merkle source-operation charge and opaque getter allowances. -/ +theorem rootCount_kernel_bound {m : Nat} (profile : ParameterBounds.Profile) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) + (saved : AnchoredHeaderCodec.Record) : + (rootCount profile lanes family points anchorPoint anchorValue log saved).2.2 ≤ + PCSRoundByRoundSource.resourcePolynomial (blockLength (ParameterBounds.config profile)) + (laneCount (ParameterBounds.config profile)) lanes m points.size := by + exact PCSRoundByRoundSource.countedRun_polynomial_cost profile lanes family points + anchorPoint anchorValue (freezeCount log saved.root (initialShape saved.shape)).1.raw + +#print axioms rootCount_value +#print axioms rootCount_bound +#print axioms rootCount_kernel_bound + +/-- One selected full table and one full-root Gao/original-claim helper. Merkle +freeze is executed once; kernel backends are executed once each. -/ +def extractCount {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) : + Option (CausalGame.Witness (ParameterBounds.config p) lanes) × Selection × Nat := + let selected := selectPrefixCount p Q boundary registry target cost log + match selected.value with + | none => (none,selected,0) + | some captured => + let decoded := rootCount p lanes family points anchorPoint anchorValue captured target + (decoded.1,selected,decoded.2.1+decoded.2.2) + +theorem extractCount_value {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) : + (extractCount p Q boundary registry target cost lanes family points anchorPoint anchorValue log).1 = + PCSBCSPublicLogExtractor.extract p Q boundary registry target lanes family points anchorPoint anchorValue log := by + unfold extractCount PCSBCSPublicLogExtractor.extract + dsimp only + rw [selectPrefixCount_value] + cases PCSBCSPublicLogExtractor.selectPrefix p Q boundary registry target log with + | none => rfl + | some captured => + exact rootCount_value p lanes family points anchorPoint anchorValue captured target + +theorem selectPrefixLoop_prefix (cost : MetadataCosts) (wanted : CacheKey) + (log captured : PublicLog) + (known : (selectPrefixLoop p Q boundary registry cost wanted log).value = some captured) : + captured.length ≤ log.length := by + induction log generalizing captured with + | nil => simp [selectPrefixLoop] at known + | cons record log ih => + rcases record with ⟨input,digest⟩ + simp only [selectPrefixLoop] at known + cases prior : (selectPrefixLoop p Q boundary registry cost wanted log).value with + | some previous => + simp only [prior,Option.some.injEq] at known + subst captured + exact (ih previous prior).trans (by simp) + | none => + simp only [prior] at known + split at known + · have equal := Option.some.inj known + subst captured + simp + · cases known + +theorem selectPrefixCount_prefix (cost : MetadataCosts) (log captured : PublicLog) + (known : (selectPrefixCount p Q boundary registry target cost log).value = some captured) : + captured.length ≤ log.length := by + exact selectPrefixLoop_prefix p Q boundary registry cost _ log captured known + +def backendPolynomial (p : ParameterBounds.Profile) (Q N L O lanes families points : Nat) : Nat := + PCSBCSMerkleRootCache.operationBudget Q N L O+ + PCSRoundByRoundSource.resourcePolynomial (blockLength (ParameterBounds.config p)) + (laneCount (ParameterBounds.config p)) lanes families points + +/-- One physical-prefix preindex, one full padded image/suffix table and one +full-root Gao/original-statement helper. Decoder nodes and full lanes are the +literal production geometry; N/L/O cap the declared target tree geometry. -/ +theorem extractCount_backend_bound {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) (N L O : Nat) + (queryCap : log.length ≤ Q) + (rowsCap : 2^(initialShape target.shape).height ≤ N) + (leafCap : (initialShape target.shape).leafWords ≤ L) + (occupiedCap : (initialShape target.shape).occupied ≤ O) + (fits : (initialShape target.shape).occupied ≤ (initialShape target.shape).leafWords) : + (extractCount p Q boundary registry target cost lanes family points anchorPoint anchorValue log).2.2 ≤ + backendPolynomial p Q N L O lanes m points.size := by + unfold extractCount + dsimp only + cases selected : (selectPrefixCount p Q boundary registry target cost log).value with + | none => exact Nat.zero_le _ + | some captured => + have prefixCap := (selectPrefixCount_prefix p Q boundary registry target cost + log captured selected).trans queryCap + exact rootCount_bound p lanes family points anchorPoint anchorValue captured target + Q N L O prefixCap rowsCap leafCap occupiedCap fits + +/-- The sole selected root table retains at most N*(L+O) field words, N +status-bearing cells and Q public-record references. This is NOT a dense-Gao +workspace, native-closure or total peak-memory certificate. Neither image +availability nor valid padding is assumed. -/ +theorem selectedTable_retained (cost : MetadataCosts) (log captured : PublicLog) + (N L O : Nat) (queryCap : log.length ≤ Q) + (selected : (selectPrefixCount p Q boundary registry target cost log).value = + some captured) + (rowsCap : 2^(initialShape target.shape).height ≤ N) + (leafCap : (initialShape target.shape).leafWords ≤ L) + (occupiedCap : (initialShape target.shape).occupied ≤ O) + (fits : (initialShape target.shape).occupied ≤ (initialShape target.shape).leafWords) : + ((imageTable (freezeCount captured target.root (initialShape target.shape)).1.cells).toList.map Array.size).sum+ + ((freezeCount captured target.root (initialShape target.shape)).1.raw.toList.map Array.size).sum ≤ N*(L+O) ∧ + (freezeCount captured target.root (initialShape target.shape)).1.cells.size ≤ N ∧ + (freezeCount captured target.root (initialShape target.shape)).1.queryPrefix.length ≤ Q := + freezeCount_retained captured target.root (initialShape target.shape) Q N L O + ((selectPrefixCount_prefix p Q boundary registry target cost + log captured selected).trans queryCap) rowsCap leafCap occupiedCap fits + +/-- The kernel's raw counter is preserved. Every backend logical unit is +additionally charged at BOTH supplied original-accessor prices, including +malformed original shape rejection. This deliberately conservative allowance +is not an exact getter-call count, CPU timing, or dense-Gao peak-memory bound. +Public-log/target/frame/header bytes are declared immutable input tables in +the base model; arbitrary costly digest closures need a separate surcharge. -/ +def originalAccessorAllowance (rawBackend : Nat) (cost : MetadataCosts) : Nat := + rawBackend*(cost.originalFamily+cost.originalSlice) + +def totalCharge {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) : Nat := + let result := extractCount p Q boundary registry target cost + lanes family points anchorPoint anchorValue log + result.2.1.operations+result.2.1.callbacks.cost cost+ + result.2.2+originalAccessorAllowance result.2.2 cost + +theorem originalAccessorAllowance_bound (raw bound : Nat) (cost : MetadataCosts) + (cap : raw ≤ bound) : + raw+originalAccessorAllowance raw cost ≤ + bound*(1+cost.originalFamily+cost.originalSlice) := by + unfold originalAccessorAllowance + nlinarith [Nat.mul_le_mul_right (cost.originalFamily+cost.originalSlice) cap] + +theorem extractCount_selection {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) : + (extractCount p Q boundary registry target cost lanes family points + anchorPoint anchorValue log).2.1 = + selectPrefixCount p Q boundary registry target cost log := by + unfold extractCount + dsimp only + split <;> rfl + +/-- Missing capture never constructs a leaf table or invokes the decoder. A +captured table can separately contain unavailable cells or invalid padding. -/ +theorem extractCount_missing {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) + (missing : (selectPrefixCount p Q boundary registry target cost log).value = none) : + (extractCount p Q boundary registry target cost lanes family points + anchorPoint anchorValue log).1 = none ∧ + (extractCount p Q boundary registry target cost lanes family points + anchorPoint anchorValue log).2.2 = 0 := by + simp [extractCount,missing] + +/-- Algebraic composition of reached internal source work, exact outer callback +prices and the separately preserved weighted kernel model. `B` bounds the REAL +counted references function, not a replacement parser, recovery oracle or +security hypothesis. This lemma by itself is not a public-input-size endpoint. -/ +def compositionPolynomial (profile : ParameterBounds.Profile) + (queries N L O lanes families points B batch : Nat) (cost : MetadataCosts) : Nat := + queries*(B+2048*(queries+1)+1)+257+3*batch+ + queries*cost.shape+ + backendPolynomial profile queries N L O lanes families points* + (1+cost.originalFamily+cost.originalSlice) + +theorem totalCharge_composition {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) (N L O B : Nat) + (queryCap : log.length ≤ Q) + (referenceCap : ∀ queryPrefix input, queryPrefix.length ≤ Q → + (referencesCount p Q boundary registry cost queryPrefix input).2.1 ≤ B) + (rowsCap : 2^(initialShape target.shape).height ≤ N) + (leafCap : (initialShape target.shape).leafWords ≤ L) + (occupiedCap : (initialShape target.shape).occupied ≤ O) + (fits : (initialShape target.shape).occupied ≤ (initialShape target.shape).leafWords) : + totalCharge p Q boundary registry target cost lanes family points + anchorPoint anchorValue log ≤ + compositionPolynomial p Q N L O lanes m points.size B target.shape.logBatch cost := by + have internal := selectPrefixCount_operations p Q boundary registry + target cost log B queryCap referenceCap + have metadata := selectPrefixCount_callback_cost p Q boundary registry + target cost log + have backend := extractCount_backend_bound p Q boundary registry + target cost lanes family points anchorPoint anchorValue log N L O queryCap + rowsCap leafCap occupiedCap fits + have weighted := originalAccessorAllowance_bound _ _ cost backend + have sourceCap := Nat.mul_le_mul_right (B+2048*(Q+1)+1) queryCap + have metadataCap := Nat.mul_le_mul_right cost.shape queryCap + unfold totalCharge compositionPolynomial + simp only [extractCount_selection] + omega + +#print axioms totalCharge_composition + +/-- Public-volume endpoint: P measures decoded chronological frame/cursor +volume and S the physical entry bytes/slots. No layout, saved record, caller +answer closure or caller-work reserve is a scanner input or cost premise. -/ +theorem totalCharge_public_polynomial {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) + (N L O W P S : Nat) (queryCap : log.length ≤ Q) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (keyCaps : ∀ queryPrefix input key, queryPrefix.length ≤ Q → + (recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input).1 = some key → + PCSBCSPublicLogParserCost.framesSize key.history.frames ≤ P) + (physicalCaps : ∀ queryPrefix input key, queryPrefix.length ≤ Q → + (recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input).1 = some key → + PCSBCSSourceSavedRecordDecoderCost.physicalSize + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) ≤ S) + (rowsCap : 2^(initialShape target.shape).height ≤ N) + (leafCap : (initialShape target.shape).leafWords ≤ L) + (occupiedCap : (initialShape target.shape).occupied ≤ O) + (fits : (initialShape target.shape).occupied ≤ (initialShape target.shape).leafWords) : + totalCharge p Q boundary registry target cost lanes family points anchorPoint anchorValue log ≤ + compositionPolynomial p Q N L O lanes m points.size + (sourceReferencePolynomial p Q W P S) target.shape.logBatch cost := by + apply totalCharge_composition p Q boundary registry target cost lanes family points + anchorPoint anchorValue log N L O (sourceReferencePolynomial p Q W P S) queryCap + · intro queryPrefix input prefixCap + exact referencesCount_polynomial p Q boundary registry cost queryPrefix input W P S + prefixCap width (fun key recovered => keyCaps queryPrefix input key prefixCap recovered) + (fun key recovered => physicalCaps queryPrefix input key prefixCap recovered) + · exact rowsCap + · exact leafCap + · exact occupiedCap + · exact fits + +theorem bodyUnits_take (frames : List Frame) (n : Nat) : + PCSBCSCoordinateCodecCost.bodyUnits (frames.take n) ≤ + PCSBCSCoordinateCodecCost.bodyUnits frames := by + induction frames generalizing n with + | nil => simp [PCSBCSCoordinateCodecCost.bodyUnits] + | cons frame frames ih => + cases n with + | zero => simp [PCSBCSCoordinateCodecCost.bodyUnits] + | succ n => + simpa only [List.take_succ_cons,PCSBCSCoordinateCodecCost.bodyUnits,List.map_cons, + List.sum_cons] using Nat.add_le_add_left (ih n) (PCSBCSCoordinateCodecCost.frameUnits frame) + +theorem recoveredEntry_physical {log : PublicLog} {input : Node} {key : Coordinate} + (recovered : (recoverCount Q PCSBCSSourceCoordinateDecoder.seedIV log input).1 = some key) : + PCSBCSSourceSavedRecordDecoderCost.physicalSize + (PCSBCSSourcePrimitiveRootBudget.entry key boundary) ≤ 65*Q := by + rw [recoverCount_value] at recovered + obtain ⟨_,_,_,_,_,_,valid,budget⟩ := PCSBCSSourceCoordinateDecoder.recover_sound recovered + exact (bodyUnits_take key.history.frames boundary).trans + (PCSBCSSourceSavedRecordDecoderCost.coordinate_physical key valid Q budget) + +/-- Closed physical-Q endpoint, including the literal 2*S^2+2550*S+30100 +saved decoder at S=65*Q. Numeric cursor volume is derived separately from the +source's admitted 49-bit cursor range; it is not substituted for physical bytes. -/ +def physicalCompositionPolynomial (profile : ParameterBounds.Profile) + (queries N L O lanes families points W batch : Nat) (cost : MetadataCosts) : Nat := + compositionPolynomial profile queries N L O lanes families points + (sourceReferencePolynomial profile queries W + (PCSBCSRecoveredSourceVolume.recoveredFramePolynomial queries) (65*queries)) batch cost + +theorem totalCharge_physical_polynomial {m : Nat} (cost : MetadataCosts) (lanes : Nat) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (anchorPoint : Array E) (anchorValue : E) (log : PublicLog) + (N L O W : Nat) (queryCap : log.length ≤ Q) + (width : ∀ n, WHIRHistoryKey.stackWidth (ParameterBounds.config p) n ≤ W) + (rowsCap : 2^(initialShape target.shape).height ≤ N) + (leafCap : (initialShape target.shape).leafWords ≤ L) + (occupiedCap : (initialShape target.shape).occupied ≤ O) + (fits : (initialShape target.shape).occupied ≤ (initialShape target.shape).leafWords) : + totalCharge p Q boundary registry target cost lanes family points anchorPoint anchorValue log ≤ + physicalCompositionPolynomial p Q N L O lanes m points.size W target.shape.logBatch cost := by + apply totalCharge_public_polynomial p Q boundary registry target cost lanes family points + anchorPoint anchorValue log N L O W + (PCSBCSRecoveredSourceVolume.recoveredFramePolynomial Q) (65*Q) queryCap width + · intro queryPrefix input key _ recovered + rw [recoverCount_value] at recovered + exact PCSBCSRecoveredSourceVolume.recover_wire recovered + · intro queryPrefix input key _ recovered + exact recoveredEntry_physical Q boundary recovered + · exact rowsCap + · exact leafCap + · exact occupiedCap + · exact fits + +#print axioms totalCharge_public_polynomial +#print axioms recoveredEntry_physical +#print axioms totalCharge_physical_polynomial +#print axioms extractCount_backend_bound +#print axioms extendCount_bound +#print axioms privateKeyCount_bound +#print axioms recoverCount_value +#print axioms selectPrefixCount_value +#print axioms selectPrefixCount_operations +#print axioms extractCount_value +end Whir.PCSBCSPublicLogExtractorCost diff --git a/verification/whir/Whir/PCSBCSPublicLogExtractorCostSmoke.lean b/verification/whir/Whir/PCSBCSPublicLogExtractorCostSmoke.lean new file mode 100644 index 000000000..f17097697 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicLogExtractorCostSmoke.lean @@ -0,0 +1,172 @@ +import Whir.PCSBCSPublicLogExtractorCost + +/-! Scoped execution checks use actual BLAKE2s. They exercise the concrete +source interpreter and frozen image statuses, not a mocked security game. -/ +namespace Whir.PCSBCSPublicLogExtractorCostSmoke +open Whir Concrete Protocol FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicMerkleLog AnchoredHeaderCodec PCSBCSPublicLogExtractorCost + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +private def digest (n : Nat) : Digest32 := + fun i => ⟨(n / 256^i.val)%256,Nat.mod_lt _ (by decide)⟩ + +private def publicPath (cv : Digest32) (log : PublicLog) : + List DuplexEncoding.Instruction → Option (PublicLog × Node) + | [] => none + | [(block,tweak)] => some (log,⟨cv,block,tweak,true⟩) + | (block,tweak)::next::rest => + let input : Node := ⟨cv,block,tweak,true⟩ + let stored := Array.ofFn (blake2sOracle input) + let answer : Digest32 := fun i => stored[i.val]'(by simp [stored]) + publicPath answer (Whir.DuplexPublicSimulator.observe log input answer) (next::rest) + +private def require (condition : Bool) (message : String) : IO Unit := + unless condition do throw (IO.userError message) + +private def p : ParameterBounds.Profile := (⟨0,by decide⟩,⟨0,by decide⟩) +private def prices : MetadataCosts := + { shape := 31, originalFamily := 53, originalSlice := 59 } + +private def imageView (frozen : PCSBCSMerkleRootCache.Frozen) := + frozen.cells.map fun cell => (cell.image,cell.compact,cell.available,cell.paddingValid) + +private def tree (words : List (List K)) : Digest32 × PublicLog := + let bytes := words.map ByteCodec.wordsBytes + let leaves := bytes.map hashBlake2s + let left := List.ofFn (ByteCodec.pairBytes (leaves[0]!,leaves[1]!)) + let right := List.ofFn (ByteCodec.pairBytes (leaves[2]!,leaves[3]!)) + let top := List.ofFn (ByteCodec.pairBytes (hashBlake2s left,hashBlake2s right)) + (hashBlake2s top,(bytes.map (plan blake2sOracle)).flatten ++ + plan blake2sOracle left ++ plan blake2sOracle right ++ plan blake2sOracle top) + +def smoke : IO Unit := do + let words : List (List K) := [[0,3],[0,5],[0,7],[0,11]] + let bytes := words.map ByteCodec.wordsBytes + let leaves := bytes.map hashBlake2s + let left := List.ofFn (ByteCodec.pairBytes (leaves[0]!,leaves[1]!)) + let right := List.ofFn (ByteCodec.pairBytes (leaves[2]!,leaves[3]!)) + let top := List.ofFn (ByteCodec.pairBytes (hashBlake2s left,hashBlake2s right)) + let root := hashBlake2s top + let incomplete := ((bytes.drop 1).map (plan blake2sOracle)).flatten ++ + plan blake2sOracle left ++ plan blake2sOracle right ++ plan blake2sOracle top + let shape : Shape := ⟨2,1,1,1⟩ + let imageShape := PCSBCSSourceRootReferences.initialShape shape + let domain := digest 7 + let statement := digest 9 + let iv := PCSBCSSourceCoordinateDecoder.seedIV + let history : FramedHistory := ⟨domain,statement, + [.absorb 0 (WHIRHistory.scalarBytes (headerScalars shape root))]⟩ + let key : Coordinate := ⟨history,.output 0⟩ + let some (capturedPrefix,input) := publicPath iv incomplete (DuplexEncoding.plan key) + | throw (IO.userError "empty actual source path") + let target : Record := ⟨shape,root,⟨digest 41,fun _ => none,0,true,0,0⟩,[0,0],0⟩ + let registry := + (⟨iv,domain,fun s => if s = statement then some shape else none⟩ : AnchoredHeaderRoots.Public) + let received := Whir.DuplexPublicSimulator.observe capturedPrefix input (blake2sOracle input) + let changed := Whir.DuplexPublicSimulator.observe capturedPrefix input (digest 123) + let later := plan blake2sOracle bytes[0]! ++ received + let foreign := {target with root := digest 42} + let recovery := recoverCount 64 iv capturedPrefix input + require (decide (recovery.1 = PCSBCSSourceCoordinateDecoder.recover 64 iv capturedPrefix input)) + "counted recovery differs from actual linear decoder" + for (name,selectedTarget,log) in [("captured",target,received),("tampered",target,changed), + ("future",target,later),("missing",foreign,received)] do + let extracted := extractCount p 64 0 registry selectedTarget prices + 1 (fun j : Fin 0 => nomatch j) #[] #[] 0 log + let counted := extracted.2.1 + let actual := PCSBCSPublicLogExtractor.selectPrefix p 64 0 registry selectedTarget log + require (decide (counted.value = actual)) (name ++ " selection erasure") + if name == "missing" then + require counted.value.isNone "missing capture invented" + else + require (decide (counted.value = some capturedPrefix)) (name ++ " first prefix changed") + let uncounted := PCSBCSPublicLogExtractor.extract p 64 0 registry selectedTarget + 1 (fun j : Fin 0 => nomatch j) #[] #[] 0 log + require (extracted.1.isSome == uncounted.isSome) (name ++ " extraction erasure") + let allowance := originalAccessorAllowance extracted.2.2 prices + let outerCharge := counted.callbacks.cost prices + let declaredCharge := counted.operations+outerCharge+extracted.2.2+allowance + IO.println s!"{name}: scanner_source_operations={counted.operations}, public_shape_lookup_calls={repr counted.callbacks}, public_shape_lookup_charge={outerCharge}, raw_backend_units={extracted.2.2}, original_input_allowance={allowance}, declared_logical_total={declaredCharge}" + let decoded := rootCount p 1 (fun j : Fin 0 => nomatch j) #[] #[] 0 capturedPrefix target + let uncountedRoot := PCSBCSPublicRootExtractor.extract p 1 (fun j : Fin 0 => nomatch j) + #[] #[] 0 capturedPrefix target + require (decoded.1.isSome == uncountedRoot.isSome) "one-freeze full-root helper erasure" + require decoded.1.isNone "tiny tree unexpectedly fits production profile" + let header := headerCount registry history + require header.1.isSome "valid BLAKE2s root header rejected" + require (header.1.isSome == + (AnchoredHeaderRoots.fromHistory registry history).isSome) "header parser erasure" + let brokenHistory := {history with frames := [.absorb 0 ([⟨1,by decide⟩] : List Byte)]} + let brokenHeader := headerCount registry brokenHistory + require brokenHeader.1.isNone "bad public header padding accepted" + require (brokenHeader.1.isSome == + (AnchoredHeaderRoots.fromHistory registry brokenHistory).isSome) "bad header parser erasure" + IO.println s!"full_root_freeze_source_operations={decoded.2.1}; raw_kernel_field_resource_operations={decoded.2.2}; header_source_operations={header.2.1}; shapes_invocations={header.2.2}; rejected_header_operations={brokenHeader.2.1}" + let opening := openingReferencesCount p 0 key + require (decide (opening.1 = PCSBCSSourcePrimitiveRootBudget.openingReferences p 0 key)) + "literal public-opening scanner erasure" + require opening.1.isNone "header-only history invented a saved opening" + let frozen := freezeCount capturedPrefix root imageShape + let actualFrozen := PCSBCSMerkleRootCache.freeze capturedPrefix root imageShape + require (imageView frozen.1 == imageView actualFrozen) "counted frozen cells differ" + require (((frozen.1.cells[0]?).map (fun c => c.available)) == some false && + ((frozen.1.cells[1]?).map (fun c => c.available)) == some true) + "unavailable captured cell confused with missing capture" + let bad := tree [[1,3],[0,5],[0,7],[0,11]] + let badFrozen := freezeCount bad.2 bad.1 imageShape + require (imageView badFrozen.1 == imageView (PCSBCSMerkleRootCache.freeze bad.2 bad.1 imageShape)) + "bad-padding freeze erasure" + require (((badFrozen.1.cells[0]?).map (fun c => c.available)) == some true && + ((badFrozen.1.cells[0]?).map (fun c => c.paddingValid)) == some false) + "available bad padding silently became authenticated zero or unavailable" + let config := ParameterBounds.config p + let decodedShape : Shape := ⟨config.logN,config.folds[0]!,config.rates[0]!,1⟩ + let decodedTarget : Record := + ⟨decodedShape,root,⟨digest 41,fun _ => none,0,true,0,0⟩, + List.replicate config.logN 0,0⟩ + let decodedEntry := WHIRHistory.encodeHistory + ⟨domain,statement,[.absorb 0 (openingScalars decodedTarget)]⟩ + let openingKey := WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth config) + decodedEntry [WHIRHistoryKey.initialPending] 0 + let some (openingPrefix,openingInput) := publicPath iv incomplete (DuplexEncoding.plan openingKey) + | throw (IO.userError "empty literal saved-opening path") + let boundary := decodedEntry.frames.length + let openingCount := openingReferencesCount p boundary openingKey + require (decide (openingCount.1 = + PCSBCSSourcePrimitiveRootBudget.openingReferences p boundary openingKey)) + "accepted literal opening erasure" + require (openingCount.1.isSome) "valid literal saved opening rejected" + let refsCount := referencesCount p 64 boundary registry prices openingPrefix openingInput + require (decide (refsCount.1 = PCSBCSSourcePrimitiveRootBudget.references p 64 boundary + registry openingPrefix openingInput)) "public-byte reference scanner erasure" + require (refsCount.1.length == 1 && refsCount.1.all (fun r => decide + (r = ⟨root,PCSBCSSourceRootReferences.initialShape decodedShape⟩))) + "public scanner invented a root or shape" + let openingLog := Whir.DuplexPublicSimulator.observe openingPrefix openingInput + (blake2sOracle openingInput) + let selectedOpening := selectPrefixCount p 64 boundary registry decodedTarget prices openingLog + require (decide (selectedOpening.value = + PCSBCSPublicLogExtractor.selectPrefix p 64 boundary registry decodedTarget openingLog)) + "decoded opening selector erasure" + require (selectedOpening.value == some openingPrefix) "literal opening capture included its reply" + let W := 1024 + let P := PCSBCSPublicLogParserCost.framesSize openingKey.history.frames + let S := PCSBCSSourceSavedRecordDecoderCost.physicalSize decodedEntry + require (decide (openingCount.2 ≤ openingReferencePolynomial p W P S)) + "literal opening decoder cost exceeded public-volume polynomial" + IO.println s!"literal_opening_operations={openingCount.2}; physical_saved_entry={S}; saved_decoder_polynomial={PCSBCSSourceSavedRecordDecoderCost.physicalPolynomial S}; opening_reference_bound={openingReferencePolynomial p W P S}" + IO.println "counted PCS public-log smoke PASS (real BLAKE2s; public-byte scanner; missing/captured/tampered; unavailable versus bad padding; no FS endpoint)" + +end Whir.PCSBCSPublicLogExtractorCostSmoke + +def main : IO Unit := Whir.PCSBCSPublicLogExtractorCostSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean b/verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean index c15eafdf8..b15a20be0 100644 --- a/verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean +++ b/verification/whir/Whir/PCSBCSPublicLogExtractorSmoke.lean @@ -23,9 +23,6 @@ private def require (condition : Bool) (message : String) : IO Unit := unless condition do throw (IO.userError message) private def p : ParameterBounds.Profile := (⟨0,by decide⟩,⟨0,by decide⟩) -private def layout : WHIRCallerClaims.CallerLayout := - .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 15,.committed (2^15) 0],⟨0,6,7⟩,1⟩ - def smoke : IO Unit := do let words : List (List K) := [[0,3],[0,5],[0,7],[0,11]] let bytes := words.map ByteCodec.wordsBytes @@ -48,27 +45,20 @@ def smoke : IO Unit := do | throw (IO.userError "empty anchored public source path") let target : Record := ⟨shape,root,⟨digest 41,fun _ => none,0,true,0,0⟩,[0,0],0⟩ require (decide target.Valid) "invalid local immutable target" - let layouts := fun (_ : PublicLog) (_ : Node) => layout - let records := fun (_ : PublicLog) (_ : Node) => target - let entries := fun (_ : PublicLog) (_ : Node) => (⟨domain,statement,[]⟩ : FramedHistory) - let answers := fun (_ : PublicLog) (_ : Node) (_ : FiatShamirGame.Coordinate) => digest 0 - let headers := fun (_ : PublicLog) (_ : Node) => + let registry := (⟨iv,domain,fun s => if s = statement then some shape else none⟩ : AnchoredHeaderRoots.Public) - let refs := PCSBCSSourcePrimitiveRootBudget.references p 64 layouts records entries answers - headers queryPrefix input + let refs := PCSBCSSourcePrimitiveRootBudget.references p 64 0 registry queryPrefix input let childKey := {key with terminal := .output 1} let some (childPrefix,childInput) := publicPath iv incomplete (DuplexEncoding.plan childKey) | throw (IO.userError "empty child-block source path") let childLog := Whir.DuplexPublicSimulator.observe childPrefix childInput (blake2sOracle childInput) - require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers - headers target childLog) == some childPrefix) + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 0 registry target childLog) == some childPrefix) "later point block did not capture the root before its own first disclosure" require (refs.length == 1 && refs.all (fun r => decide (r = ⟨root,PCSBCSSourceRootReferences.initialShape shape⟩))) "actual commitment key did not select its complete-image address" let received := Whir.DuplexPublicSimulator.observe queryPrefix input (blake2sOracle input) - let some captured := PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers - headers target received | throw (IO.userError "public anchor root was not captured") + let some captured := PCSBCSPublicLogExtractor.selectPrefix p 64 0 registry target received | throw (IO.userError "public anchor root was not captured") require (decide (captured = queryPrefix)) "capture included its challenge answer" let first := Whir.PCSBCSMerkleRootCache.freeze captured root (PCSBCSSourceRootReferences.initialShape shape) require (((first.cells[0]?).map (fun cell => cell.available)) == some false && @@ -76,20 +66,39 @@ def smoke : IO Unit := do "missing prefix image was authenticated or an available sibling was lost" let later := plan blake2sOracle bytes[0]! ++ received let changed := Whir.DuplexPublicSimulator.observe queryPrefix input (digest 123) - require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers - headers target later) == some captured) + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 0 registry target later) == some captured) "later image queries replaced the first captured prefix" - require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers - headers target changed) == some captured) + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 0 registry target changed) == some captured) "current whole answer changed the captured metadata" - let some stable := PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers - headers target later | throw (IO.userError "later log lost an existing capture") + let some stable := PCSBCSPublicLogExtractor.selectPrefix p 64 0 registry target later | throw (IO.userError "later log lost an existing capture") require (((((Whir.PCSBCSMerkleRootCache.freeze stable root (PCSBCSSourceRootReferences.initialShape shape)).cells[0]?).map (fun cell => cell.available))) == some false) "future leaf preimage entered the straight-line extraction table" let foreign := { target with root := digest 42 } - require ((PCSBCSPublicLogExtractor.selectPrefix p 64 layouts records entries answers - headers foreign received).isNone) "unmentioned target root was invented" + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 0 registry foreign received).isNone) "unmentioned target root was invented" + let config := ParameterBounds.config p + let decodedShape : Shape := ⟨config.logN,config.folds[0]!,config.rates[0]!,1⟩ + let decodedTarget : Record := + ⟨decodedShape,root,⟨digest 41,fun _ => none,0,true,0,0⟩, + List.replicate config.logN 0,0⟩ + require (decide decodedTarget.Valid) "invalid supported opening fixture" + let decodedEntry := WHIRHistory.encodeHistory + ⟨domain,statement,[.absorb 0 (openingScalars decodedTarget)]⟩ + let openingKey := WHIRCallerPrefix.outputKeyFrom (WHIRHistoryKey.stackWidth config) + decodedEntry [WHIRHistoryKey.initialPending] 0 + let some (openingPrefix,openingInput) := publicPath iv incomplete (DuplexEncoding.plan openingKey) + | throw (IO.userError "empty literal saved-opening path") + let openingRefs := PCSBCSSourcePrimitiveRootBudget.references p 64 decodedEntry.frames.length + registry openingPrefix openingInput + require (openingRefs.length == 1 && openingRefs.all (fun r => decide + (r = ⟨root,PCSBCSSourceRootReferences.initialShape decodedShape⟩))) + "literal saved opening failed conservative role recovery" + let openingLog := Whir.DuplexPublicSimulator.observe openingPrefix openingInput + (blake2sOracle openingInput) + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 decodedEntry.frames.length registry + decodedTarget openingLog) == some openingPrefix) "decoded saved opening not captured before reply" + require ((PCSBCSPublicLogExtractor.selectPrefix p 64 decodedEntry.frames.length registry + target openingLog).isNone) "equal roots at different shapes shared a cache address" IO.println "public-log extractor smoke PASS (real BLAKE2s, anchored address, before-answer capture, unavailable status, future/current independence)" end Whir.PCSBCSPublicLogExtractorSmoke diff --git a/verification/whir/Whir/PCSBCSPublicLogParserCost.lean b/verification/whir/Whir/PCSBCSPublicLogParserCost.lean new file mode 100644 index 000000000..14f08dd62 --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicLogParserCost.lean @@ -0,0 +1,901 @@ +import Whir.PCSBCSSourceRootReferences + +/-! Concrete list/byte/scalar parser instrumentation. Fixed 24-byte scalar +loads and extension-field decoding are charged by a bounded fixed-size unit; +list length, suffix traversal, result constructors, and failure paths are +charged explicitly. This module performs no fresh challenge or hash query. -/ +set_option autoImplicit false +namespace Whir.PCSBCSPublicLogParserCost +open Concrete FiatShamirGame WHIRHistory WHIRHistoryKey + +def parseScalarsCount : Nat → List Byte → Option (List E × List Byte) × Nat + | 0,bs => (some ([],bs),1) + | n+1,bs => + if h : 24 ≤ bs.length then + let x := ByteCodec.decodeE (fun i => bs[i.val]'(by omega)) + let later := parseScalarsCount n (bs.drop 24) + (later.1.map (fun p => (x::p.1,p.2)),bs.length+1024+later.2) + else (none,bs.length+1) + +theorem parseScalarsCount_value (n : Nat) (bs : List Byte) : + (parseScalarsCount n bs).1 = parseScalars n bs := by + induction n generalizing bs with + | zero => rfl + | succ n ih => simp only [parseScalarsCount,parseScalars]; split <;> simp [ih] + +theorem parseScalarsCount_bound (n : Nat) (bs : List Byte) : + (parseScalarsCount n bs).2 ≤ (n+1)*(bs.length+1024)+1 := by + induction n generalizing bs with + | zero => simp [parseScalarsCount] + | succ n ih => + simp only [parseScalarsCount] + split + · have later := ih (bs.drop 24) + simp only [List.length_drop] at later + simp only [] + have smaller : bs.length-24 ≤ bs.length := Nat.sub_le _ _ + nlinarith + · simp only []; nlinarith + +def parseExactCount (n : Nat) (bs : List Byte) : Option (List E) × Nat := + let parsed := parseScalarsCount n bs + (parsed.1.bind (fun p => if p.2 = [] then some p.1 else none),parsed.2+1) + +theorem parseExactCount_value (n : Nat) (bs : List Byte) : + (parseExactCount n bs).1 = parseExact n bs := by + simp only [parseExactCount,parseScalarsCount_value,parseExact] + rfl + +theorem parseExactCount_bound (n : Nat) (bs : List Byte) : + (parseExactCount n bs).2 ≤ (n+1)*(bs.length+1024)+2 := by + have bound := parseScalarsCount_bound n bs + simpa only [parseExactCount] using Nat.add_le_add_right bound 1 + +/-- Public size includes frame slots, payload bytes and consumed-output byte +counts. The latter need not be bounded by the compression-chain length. -/ +def frameSize : Frame → Nat + | .absorb consumed bytes => consumed+bytes.length+1 + | .nonce consumed _ _ => consumed+25 + +def framesSize (frames : List Frame) : Nat := (frames.map frameSize).sum + +def parseStepsCount : List Frame → Option (List Pending) × Nat + | [] => (some [],1) + | .absorb _ bytes :: .nonce _ bits nonce :: rest => + let xs := parseExactCount (bytes.length/24) bytes + match xs.1 with + | none => (none,bytes.length+xs.2+1) + | some scalars => + let later := parseStepsCount rest + (later.1.map (⟨scalars,some (bits,ByteCodec.decodeE nonce)⟩::·), + bytes.length+xs.2+later.2+1024) + | .absorb _ bytes :: rest => + let xs := parseExactCount (bytes.length/24) bytes + match xs.1 with + | none => (none,bytes.length+xs.2+1) + | some scalars => + let later := parseStepsCount rest + (later.1.map (⟨scalars,none⟩::·),bytes.length+xs.2+later.2+1) + | _ => (none,1) + +theorem parseStepsCount_value (frames : List Frame) : + (parseStepsCount frames).1 = parseSteps frames := by + induction frames using (measure List.length).wf.induction with + | h frames ih => + cases frames with + | nil => rfl + | cons f rest => + have restEq := ih rest (by exact Nat.lt_succ_self _) + cases f with + | nonce consumed bits nonce => rfl + | absorb consumed bytes => + cases rest with + | nil => + simp only [parseStepsCount,parseSteps,parseExactCount_value] + cases parseExact (bytes.length/24) bytes <;> rfl + | cons next tail => + have tailEq := ih tail (by exact Nat.lt_add_of_pos_right (by decide : 0 < 2)) + cases next <;> + simp only [parseStepsCount,parseSteps,parseExactCount_value] <;> + cases parseExact (bytes.length/24) bytes <;> + simp_all <;> exact Option.map_eq_bind + +/-- A sum of literal per-frame scalar-input charges, independent of successful +parse depth. All failures pay only the actually visited stopping prefix. -/ +def stepsBudget : List Frame → Nat + | [] => 1 + | .absorb _ bytes :: rest => + bytes.length+(bytes.length/24+1)*(bytes.length+1024)+1026+stepsBudget rest + | .nonce _ _ _ :: rest => 1026+stepsBudget rest + +theorem parseStepsCount_bound (frames : List Frame) : + (parseStepsCount frames).2 ≤ stepsBudget frames := by + induction frames using (measure List.length).wf.induction with + | h frames ih => + cases frames with + | nil => rfl + | cons f rest => + have restCap := ih rest (by exact Nat.lt_succ_self _) + cases f with + | nonce consumed bits nonce => simp only [parseStepsCount,stepsBudget]; omega + | absorb consumed bytes => + have scalar := parseExactCount_bound (bytes.length/24) bytes + cases rest with + | nil => + simp only [parseStepsCount] + cases (parseExactCount (bytes.length/24) bytes).1 <;> + simp only [stepsBudget] <;> omega + | cons next tail => + have tailCap := ih tail (by exact Nat.lt_add_of_pos_right (by decide : 0 < 2)) + cases next <;> simp only [parseStepsCount] <;> + cases (parseExactCount (bytes.length/24) bytes).1 <;> + simp only [stepsBudget] <;> simp only [stepsBudget] at restCap <;> omega + +theorem stepsBudget_polynomial (frames : List Frame) : + stepsBudget frames ≤ (framesSize frames+1)*(framesSize frames+2050)+1 := by + induction frames with + | nil => simp [stepsBudget,framesSize] + | cons f rest ih => + have nonnegative : 0 ≤ framesSize rest := Nat.zero_le _ + cases f with + | absorb consumed bytes => + have divBound : bytes.length/24 ≤ bytes.length := Nat.div_le_self _ _ + simp only [stepsBudget,framesSize,List.map_cons,List.sum_cons,frameSize] at * + nlinarith + | nonce consumed bits nonce => + simp only [stepsBudget,framesSize,List.map_cons,List.sum_cons,frameSize] at * + nlinarith + +open DuplexRefinement WHIRCallerClaims WHIRCallerShape + +def modelMass (m : Model) : Nat := m.run.length+m.history.frames.length + +def closeRunCount (m : Model) : Model × Nat := + if m.run = [] then (m,1) + else (closeRun m,m.history.frames.length+3) + +theorem closeRunCount_value (m : Model) : (closeRunCount m).1 = closeRun m := by + unfold closeRunCount closeRun + split <;> rfl + +theorem closeRun_mass (m : Model) : modelMass (closeRun m) ≤ modelMass m := by + unfold closeRun modelMass + split + · rfl + · simp only [List.length_nil,List.length_append,List.length_singleton] + have nonempty : 0 < m.run.length := by + cases h : m.run with + | nil => contradiction + | cons b bs => simp + omega + +theorem closeRunCount_bound (m : Model) : (closeRunCount m).2 ≤ modelMass m+3 := by + unfold closeRunCount modelMass + split <;> dsimp only <;> omega + +def operationCount (m : Model) : Operation → Model × Nat + | .absorb bs => (modelAbsorb m bs,m.run.length+bs.length+8) + | .squeeze n => + if n = 0 then (m,1) else + let closed := closeRunCount m + ({closed.1 with consumed := m.consumed+n},closed.2+3) + | .nonce bits value => + let closed := closeRunCount m + ({history := {closed.1.history with frames := + closed.1.history.frames++[.nonce closed.1.consumed bits value]}}, + closed.2+closed.1.history.frames.length+3) + +theorem operationCount_value (m : Model) (op : Operation) : + (operationCount m op).1 = applyOperation m op := by + cases op with + | absorb bs => rfl + | squeeze n => simp only [operationCount,applyOperation,modelSqueeze,closeRunCount_value]; split <;> rfl + | nonce bits value => simp only [operationCount,applyOperation,modelNonce,closeRunCount_value] + +def tokenModelCount (m : Model) (t : CallerToken) : Model × Nat := + let stepped := operationCount m (tokenOperation t) + (stepped.1,stepped.2+900) + +theorem tokenModelCount_mass (m : Model) (t : CallerToken) : + modelMass (tokenModelCount m t).1 ≤ modelMass m+24 := by + have closed := closeRun_mass m + cases t with + | sent value => + simp only [tokenModelCount,tokenOperation,operationCount,modelAbsorb] + split + · omega + · simp only [modelMass,List.length_append,scalarBytes_length,List.length_cons,List.length_nil] + omega + | draw value => + simp only [tokenModelCount,tokenOperation,operationCount] + rw [closeRunCount_value] + exact closed.trans (by omega) + | nonce bits value => + simp only [tokenModelCount,tokenOperation,operationCount,closeRunCount_value,modelMass, + List.length_nil,List.length_append,List.length_singleton] at * + omega + +theorem tokenModelCount_bound (m : Model) (t : CallerToken) : + (tokenModelCount m t).2 ≤ 2*modelMass m+950 := by + have closeCost := closeRunCount_bound m + have closed := closeRun_mass m + have frames : (closeRun m).history.frames.length ≤ modelMass m := by + exact (Nat.le_add_left _ _).trans closed + cases t with + | sent value => + have runCap : m.run.length ≤ modelMass m := Nat.le_add_right _ _ + simp only [tokenModelCount,tokenOperation,operationCount,WHIRHistory.scalarBytes_length,List.length_cons,List.length_nil] + omega + | draw value => + simp only [tokenModelCount,tokenOperation,operationCount] + norm_num only at * + simp only [ite_false] + omega + | nonce bits value => + simp only [tokenModelCount,tokenOperation,operationCount] + rw [closeRunCount_value] + omega + +def tokenModelsCount : Model → List CallerToken → Model × Nat + | m,[] => (m,1) + | m,t::rest => + let step := tokenModelCount m t + let later := tokenModelsCount step.1 rest + (later.1,step.2+later.2+1) + +theorem tokenModelsCount_value (m : Model) (ts : List CallerToken) : + (tokenModelsCount m ts).1 = runOperations m (ts.map tokenOperation) := by + induction ts generalizing m with + | nil => rfl + | cons t ts ih => + simp only [tokenModelsCount,runOperations,List.map_cons,List.foldl_cons,ih,tokenModelCount,operationCount_value] + +theorem tokenModelsCount_mass (m : Model) (ts : List CallerToken) : + modelMass (tokenModelsCount m ts).1 ≤ modelMass m+24*ts.length := by + induction ts generalizing m with + | nil => simp [tokenModelsCount] + | cons t ts ih => + have first := tokenModelCount_mass m t + have later := ih (tokenModelCount m t).1 + simp only [tokenModelsCount,List.length_cons] + omega + +theorem tokenModelsCount_bound (m : Model) (ts : List CallerToken) : + (tokenModelsCount m ts).2 ≤ (ts.length+1)*(2*modelMass m+48*ts.length+952) := by + induction ts generalizing m with + | nil => simp [tokenModelsCount] + | cons t ts ih => + have first := tokenModelCount_bound m t + have mass := tokenModelCount_mass m t + have later := ih (tokenModelCount m t).1 + simp only [tokenModelsCount,List.length_cons] + nlinarith + +def tokenHistoryCount (domain statement : Digest32) (ts : List CallerToken) : FramedHistory × Nat := + let built := tokenModelsCount (seedModel domain statement) ts + let closed := closeRunCount built.1 + (closed.1.history,built.2+closed.2) + +theorem tokenHistoryCount_value (domain statement : Digest32) (ts : List CallerToken) : + (tokenHistoryCount domain statement ts).1 = tokenHistory domain statement ts := by + simp only [tokenHistoryCount,tokenHistory,closeRunCount_value,tokenModelsCount_value] + +theorem tokenHistoryCount_bound (domain statement : Digest32) (ts : List CallerToken) : + (tokenHistoryCount domain statement ts).2 ≤ (ts.length+1)*(48*ts.length+1000) := by + have build := tokenModelsCount_bound (seedModel domain statement) ts + have mass := tokenModelsCount_mass (seedModel domain statement) ts + have closeCost := closeRunCount_bound (tokenModelsCount (seedModel domain statement) ts).1 + simp only [modelMass,seedModel,List.length_nil] at build mass closeCost + unfold tokenHistoryCount + dsimp only + simp only [seedModel] + nlinarith + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +open WHIRCallerOutputs + +def outputsFromCount (e : FramedHistory) (pre : List Frame) : + List Frame → List Coordinate × Nat + | [] => ([],1) + | f::rest => + let blocks := (List.range (outputBlocks (previousConsumed f))).map + (fun block => (⟨{e with frames := pre},.output block⟩ : Coordinate)) + let later := outputsFromCount e (pre++[f]) rest + (blocks++later.1,later.2+pre.length+8*blocks.length+8) + +theorem outputsFromCount_value (e : FramedHistory) (pre fs : List Frame) : + (outputsFromCount e pre fs).1 = outputsFrom e pre fs := by + induction fs generalizing pre with + | nil => rfl + | cons f fs ih => simp only [outputsFromCount,outputsFrom,ih] + +/-- Whole compared history volumes conservatively charge equality even when +lengths differ. The domain and statement occupy 64 fixed bytes. -/ +def coordinateEqWork (a b : Coordinate) : Nat := + 1024+framesSize a.history.frames+framesSize b.history.frames + +def memberCount (q : Coordinate) : List Coordinate → Bool × Nat + | [] => (false,1) + | x::xs => + if q = x then (true,coordinateEqWork q x+1) + else + let later := memberCount q xs + (later.1,coordinateEqWork q x+later.2+1) + +theorem memberCount_value (q : Coordinate) (xs : List Coordinate) : + (memberCount q xs).1 = decide (q ∈ xs) := by + induction xs with + | nil => rfl + | cons x xs ih => simp only [memberCount,List.mem_cons]; split <;> simp_all + +/-- The answer callback is called ONCE PER BYTE, as in the real source; no +unit-cost or block-cache assumption is introduced. Tuple counts are invocation +counts, whereas membership/work counters are separate concrete operations. -/ +def byteReplyCount (e : FramedHistory) (answers : Coordinate → Digest32) + (history : FramedHistory) (j : Nat) : Byte × Nat × Nat := + let q : Coordinate := ⟨history,.output (j/32)⟩ + let outputs := outputsFromCount e [] e.frames + let admitted := memberCount q outputs.1 + (if admitted.1 then + (answers q ⟨j%32,Nat.mod_lt _ (by decide)⟩,1,outputs.2+admitted.2+8) + else (zeroDigest ⟨j%32,Nat.mod_lt _ (by decide)⟩,0,outputs.2+admitted.2+8)) + +def recoveredBytesCount (e : FramedHistory) (answers : Coordinate → Digest32) + (history : FramedHistory) (n : Nat) : List Byte × Nat × Nat := + let entries := List.ofFn fun i : Fin n => byteReplyCount e answers history i.val + (entries.map Prod.fst,(entries.map (fun x => x.2.1)).sum, + (entries.map (fun x => x.2.2)).sum+3*n+1) + +theorem recoveredBytesCount_value (e : FramedHistory) (answers : Coordinate → Digest32) + (history : FramedHistory) (n : Nat) : + (recoveredBytesCount e answers history n).1 = + recoveredBytes (priorAnswers e answers) history 0 n := by + simp only [recoveredBytesCount,byteReplyCount,recoveredBytes,List.map_ofFn,Nat.zero_add] + congr 1 + funext i + simp only [outputsFromCount_value,callerOutputs,memberCount_value,priorAnswers] + dsimp only [Function.comp_apply] + split <;> simp_all + +/-- Scalar decoding executes only after the real divisibility guard. -/ +def tokensFromFrameCount (f : Frame) (output : List Byte) : Option (List CallerToken) × Nat := + let n := previousConsumed f + if n%24 ≠ 0 then (none,2) else + let draws := parseExactCount (n/24) output + match draws.1 with + | none => (none,draws.2+2) + | some xs => + match f with + | .absorb _ bytes => + let sent := parseExactCount (bytes.length/24) bytes + (sent.1.map (fun ys => xs.map CallerToken.draw++ys.map CallerToken.sent), + draws.2+sent.2+3*xs.length+3*(bytes.length/24)+4) + | .nonce _ bits value => + (some (xs.map CallerToken.draw++[.nonce bits value]),draws.2+3*xs.length+4) + +theorem tokensFromFrameCount_value (f : Frame) (output : List Byte) : + (tokensFromFrameCount f output).1 = tokensFromFrame f output := by + simp only [tokensFromFrameCount,tokensFromFrame] + split + · rfl + · rw [parseExactCount_value] + cases parseExact (previousConsumed f/24) output with + | none => rfl + | some xs => + cases f with + | absorb consumed bytes => + simp only [parseExactCount_value] + cases parseExact (bytes.length/24) bytes <;> rfl + | nonce consumed bits value => rfl + +def frameTokensCount (e : FramedHistory) (answers : Coordinate → Digest32) (i : Nat) (f : Frame) : + Option (List CallerToken) × Nat × Nat := + let bytes := recoveredBytesCount e answers {e with frames := e.frames.take i} (previousConsumed f) + let tokens := tokensFromFrameCount f bytes.1 + (tokens.1,bytes.2.1,bytes.2.2+tokens.2+min i e.frames.length+3) + +theorem frameTokensCount_value (e : FramedHistory) (answers : Coordinate → Digest32) + (i : Nat) (f : Frame) : (frameTokensCount e answers i f).1 = frameTokens e answers i f := by + simp only [frameTokensCount,tokensFromFrameCount_value,recoveredBytesCount_value,frameTokens] + +theorem frameSize_positive (f : Frame) : 1 ≤ frameSize f := by + cases f <;> simp [frameSize] + +theorem framesSize_length (fs : List Frame) : fs.length ≤ framesSize fs := by + induction fs with + | nil => rfl + | cons f fs ih => + have first := frameSize_positive f + simp only [framesSize,List.map_cons,List.sum_cons,List.length_cons] at * + omega + +theorem framesSize_take (fs : List Frame) (n : Nat) : + framesSize (fs.take n) ≤ framesSize fs := by + induction fs generalizing n with + | nil => simp [framesSize] + | cons f fs ih => + cases n with + | zero => simp [framesSize] + | succ n => + simpa only [List.take_succ_cons,framesSize,List.map_cons,List.sum_cons] using + Nat.add_le_add_left (ih n) (frameSize f) + +theorem outputBlocks_frameSize (f : Frame) : + outputBlocks (previousConsumed f) ≤ frameSize f := by + cases f <;> simp only [outputBlocks,previousConsumed,frameSize] <;> omega + +theorem callerOutputCount_bound (fs : List Frame) : callerOutputCount fs ≤ framesSize fs := by + induction fs with + | nil => rfl + | cons f fs ih => + have first := outputBlocks_frameSize f + simp only [callerOutputCount,framesSize,List.map_cons,List.sum_cons] at * + omega + +theorem outputsFromCount_bound (e : FramedHistory) (pre fs : List Frame) : + (outputsFromCount e pre fs).2 ≤ 32*(pre.length+framesSize fs+fs.length+1)*(pre.length+framesSize fs+fs.length+1) := by + induction fs generalizing pre with + | nil => simp only [outputsFromCount,framesSize,List.map_nil,List.sum_nil,List.length_nil]; nlinarith + | cons f fs ih => + have later := ih (pre++[f]) + have blocks := outputBlocks_frameSize f + have positive := frameSize_positive f + let S := pre.length+framesSize fs+fs.length+2 + have cross : S ≤ frameSize f*S := Nat.le_mul_of_pos_left _ positive + have widthCross : frameSize f ≤ frameSize f*S := + Nat.le_mul_of_pos_right _ (by unfold S; omega) + have prefixCap : pre.length+8 ≤ S+8 := by unfold S; omega + have stepCap : pre.length+8*outputBlocks (previousConsumed f)+8 ≤ 32*frameSize f*S := by + nlinarith + have laterCap : (outputsFromCount e (pre++[f]) fs).2 ≤ 32*S*S := by + convert later using 1 + simp only [S,List.length_append,List.length_cons,List.length_nil] + ring + have sumCap := Nat.add_le_add laterCap stepCap + have expansion : 32*S*S+32*frameSize f*S ≤ 32*(S+frameSize f)*(S+frameSize f) := by + nlinarith + have combined := sumCap.trans expansion + simp only [outputsFromCount,List.length_map,List.length_range] + calc + _ = (outputsFromCount e (pre++[f]) fs).2 + + (pre.length+8*outputBlocks (previousConsumed f)+8) := by ring + _ ≤ 32*(S+frameSize f)*(S+frameSize f) := combined + _ = _ := by simp only [S,framesSize,List.map_cons,List.sum_cons,List.length_cons]; ring + +theorem memberCount_bound (q : Coordinate) (xs : List Coordinate) (P : Nat) + (qCap : framesSize q.history.frames ≤ P) + (xsCap : ∀ x ∈ xs, framesSize x.history.frames ≤ P) : + (memberCount q xs).2 ≤ xs.length*(1025+2*P)+1 := by + induction xs with + | nil => simp [memberCount] + | cons x xs ih => + have xCap := xsCap x (by simp) + have later := ih (fun y hy => xsCap y (by simp [hy])) + have eqCap : coordinateEqWork q x ≤ 1024+2*P := by unfold coordinateEqWork; omega + simp only [memberCount,List.length_cons] + split <;> dsimp only <;> nlinarith + +theorem callerOutputs_frame_bound (e : FramedHistory) (q : Coordinate) + (member : q ∈ callerOutputs e) : framesSize q.history.frames ≤ framesSize e.frames := by + obtain ⟨pre,f,suffix,block,split,bound,rfl⟩ := callerOutputs_mem e q member + rw [split] + unfold framesSize + simp only [List.map_append,List.sum_append,List.map_cons,List.sum_cons] + omega + +theorem recoveredBytesCount_length (e : FramedHistory) (answers : Coordinate → Digest32) + (history : FramedHistory) (n : Nat) : (recoveredBytesCount e answers history n).1.length = n := by + simp [recoveredBytesCount] + +theorem parseScalars_length (n : Nat) (bs : List Byte) (xs : List E) (tail : List Byte) + (parsed : parseScalars n bs = some (xs,tail)) : xs.length = n := by + induction n generalizing bs xs tail with + | zero => cases parsed; rfl + | succ n ih => + simp only [parseScalars] at parsed + split at parsed + · cases h : parseScalars n (bs.drop 24) with + | none => simp [h] at parsed + | some value => + rcases value with ⟨ys,rest⟩ + simp only [h,Option.map_some,Option.some.injEq] at parsed + obtain ⟨rfl,rfl⟩ := parsed + simp only [List.length_cons,ih _ _ _ h] + · contradiction + +theorem parseExact_length (n : Nat) (bs : List Byte) (xs : List E) + (parsed : parseExact n bs = some xs) : xs.length = n := by + unfold parseExact at parsed + cases h : parseScalars n bs with + | none => simp [h] at parsed + | some value => + rcases value with ⟨ys,rest⟩ + simp only [h] at parsed + change (if rest = [] then some ys else none) = some xs at parsed + split at parsed + · cases parsed; exact parseScalars_length _ _ _ _ h + · contradiction + +def byteLookupPolynomial (P : Nat) : Nat := + 32*(2*P+1)*(2*P+1)+P*(1025+2*P)+9 + +theorem byteReplyCount_bound (e : FramedHistory) (answers : Coordinate → Digest32) + (history : FramedHistory) (j P : Nat) + (entryCap : framesSize e.frames ≤ P) (historyCap : framesSize history.frames ≤ P) : + (byteReplyCount e answers history j).2.1 ≤ 1 ∧ + (byteReplyCount e answers history j).2.2 ≤ byteLookupPolynomial P := by + have outputCount := callerOutputCount_bound e.frames + have outputWork := outputsFromCount_bound e [] e.frames + have frameCount := framesSize_length e.frames + have members := memberCount_bound (⟨history,.output (j/32)⟩ : Coordinate) + (outputsFromCount e [] e.frames).1 P historyCap (by + intro q member + rw [outputsFromCount_value] at member + exact (callerOutputs_frame_bound e q member).trans entryCap) + have membersCap : + (memberCount (⟨history,.output (j/32)⟩ : Coordinate) (outputsFromCount e [] e.frames).1).2 ≤ + P*(1025+2*P)+1 := by + apply members.trans + rw [outputsFromCount_value,outputsFrom_length] + gcongr + exact outputCount.trans entryCap + have construction : + (outputsFromCount e [] e.frames).2 ≤ 32*(2*P+1)*(2*P+1) := by + apply outputWork.trans + simp only [List.length_nil] + gcongr + all_goals omega + unfold byteReplyCount + dsimp only + split <;> dsimp only <;> constructor + · omega + · unfold byteLookupPolynomial; nlinarith + · omega + · unfold byteLookupPolynomial; nlinarith + +theorem recoveredBytesCount_bound (e : FramedHistory) (answers : Coordinate → Digest32) + (history : FramedHistory) (n P : Nat) + (entryCap : framesSize e.frames ≤ P) (historyCap : framesSize history.frames ≤ P) : + (recoveredBytesCount e answers history n).2.1 ≤ n ∧ + (recoveredBytesCount e answers history n).2.2 ≤ n*(byteLookupPolynomial P+3)+1 := by + have callCap := List.sum_le_length_nsmul + ((List.ofFn (fun i : Fin n => byteReplyCount e answers history i.val)).map (fun x => x.2.1)) 1 (by + intro value member + obtain ⟨x,inside,rfl⟩ := List.mem_map.mp member + obtain ⟨i,rfl⟩ := List.mem_ofFn.mp inside + exact (byteReplyCount_bound e answers history i.val P entryCap historyCap).1) + have workCap := List.sum_le_length_nsmul + ((List.ofFn (fun i : Fin n => byteReplyCount e answers history i.val)).map (fun x => x.2.2)) + (byteLookupPolynomial P) (by + intro value member + obtain ⟨x,inside,rfl⟩ := List.mem_map.mp member + obtain ⟨i,rfl⟩ := List.mem_ofFn.mp inside + exact (byteReplyCount_bound e answers history i.val P entryCap historyCap).2) + simp only [List.length_map,List.length_ofFn,smul_eq_mul,Nat.mul_one] at callCap workCap + unfold recoveredBytesCount + dsimp only + constructor + · exact callCap + · nlinarith + +theorem tokensFromFrameCount_bound (f : Frame) (output : List Byte) (P : Nat) + (frameCap : frameSize f ≤ P) (outputCap : output.length ≤ P) : + (tokensFromFrameCount f output).2 ≤ 2*(P+1)*(P+1024)+6*P+8 := by + have consumed : previousConsumed f ≤ P := by cases f <;> simp only [previousConsumed,frameSize] at * <;> omega + have division : previousConsumed f/24 ≤ P := (Nat.div_le_self _ _).trans consumed + have draws := parseExactCount_bound (previousConsumed f/24) output + have drawsCap : (parseExactCount (previousConsumed f/24) output).2 ≤ (P+1)*(P+1024)+2 := by + apply draws.trans + gcongr + unfold tokensFromFrameCount + dsimp only + split + · omega + · cases h : (parseExactCount (previousConsumed f/24) output).1 with + | none => nlinarith + | some xs => + have xsSize := parseExact_length _ _ _ (parseExactCount_value _ _ ▸ h) + cases f with + | nonce consumed bits value => simp only []; simp only [previousConsumed] at *; nlinarith + | absorb consumed bytes => + have bytesCap : bytes.length ≤ P := by simp only [frameSize] at frameCap; omega + have sent := parseExactCount_bound (bytes.length/24) bytes + have sentCap : (parseExactCount (bytes.length/24) bytes).2 ≤ (P+1)*(P+1024)+2 := by + apply sent.trans + gcongr + exact (Nat.div_le_self _ _).trans bytesCap + simp only [] + simp only [previousConsumed] at * + have sentCount : bytes.length/24 ≤ P := (Nat.div_le_self _ _).trans bytesCap + nlinarith + +def frameParserPolynomial (P : Nat) : Nat := + P*(byteLookupPolynomial P+3)+2*(P+1)*(P+1024)+7*P+12 + +theorem frameTokensCount_bound (e : FramedHistory) (answers : Coordinate → Digest32) + (i : Nat) (f : Frame) (P : Nat) + (entryCap : framesSize e.frames ≤ P) (frameCap : frameSize f ≤ P) : + (frameTokensCount e answers i f).2.1 ≤ P ∧ + (frameTokensCount e answers i f).2.2 ≤ frameParserPolynomial P := by + have historyCap : framesSize (e.frames.take i) ≤ P := (framesSize_take _ _).trans entryCap + have bytes := recoveredBytesCount_bound e answers {e with frames := e.frames.take i} + (previousConsumed f) P entryCap historyCap + have consumed : previousConsumed f ≤ P := by cases f <;> simp only [previousConsumed,frameSize] at * <;> omega + have scalar := tokensFromFrameCount_bound f + (recoveredBytesCount e answers {e with frames := e.frames.take i} (previousConsumed f)).1 P + frameCap (by rw [recoveredBytesCount_length]; exact consumed) + have prefixCap : min i e.frames.length ≤ P := (Nat.min_le_right _ _).trans + ((framesSize_length _).trans entryCap) + unfold frameTokensCount frameParserPolynomial + dsimp only + constructor + · omega + · nlinarith + +def tokenFramesCount (e : FramedHistory) (answers : Coordinate → Digest32) : + List (Frame × Nat) → Option (List (List CallerToken)) × Nat × Nat + | [] => (some [],0,1) + | (f,i)::rest => + let first := frameTokensCount e answers i f + match first.1 with + | none => (none,first.2.1,first.2.2+2) + | some tokens => + let later := tokenFramesCount e answers rest + (later.1.map (tokens::·),first.2.1+later.2.1,first.2.2+later.2.2+3) + +theorem tokenFramesCount_value (e : FramedHistory) (answers : Coordinate → Digest32) + (fs : List (Frame × Nat)) : + (tokenFramesCount e answers fs).1 = + fs.mapM (fun (f,i) => frameTokens e answers i f) := by + induction fs with + | nil => rfl + | cons pair fs ih => + rcases pair with ⟨f,i⟩ + simp only [tokenFramesCount,List.mapM_cons,frameTokensCount_value] + cases frameTokens e answers i f <;> simp [ih,Option.map_eq_bind] + +def entryTokensCount (e : FramedHistory) (answers : Coordinate → Digest32) : + Option (List CallerToken) × Nat × Nat := + let frames := tokenFramesCount e answers e.frames.zipIdx + match frames.1 with + | none => (none,frames.2.1,frames.2.2+2*e.frames.length+2) + | some blocks => + let tokens := blocks.flatten + let rebuilt := tokenHistoryCount e.domain e.statement tokens + (if rebuilt.1 = e then some tokens else none, + frames.2.1,frames.2.2+2*e.frames.length+blocks.length+tokens.length+ + rebuilt.2+1024+framesSize rebuilt.1.frames+framesSize e.frames+4) + +theorem entryTokensCount_value (e : FramedHistory) (answers : Coordinate → Digest32) : + (entryTokensCount e answers).1 = entryTokens e answers := by + simp only [entryTokensCount,entryTokens,tokenFramesCount_value] + cases e.frames.zipIdx.mapM (fun (f,i) => frameTokens e answers i f) with + | none => rfl + | some blocks => simp only [tokenHistoryCount_value]; rfl + +/-- Include historical payloads and encoded consumed cursors, not only frame +slots. This bounds the complete rejected reconstruction as well as successes. -/ +def modelWireSize (m : Model) : Nat := + framesSize m.history.frames+m.run.length+m.previous+m.consumed + +theorem closeRun_wire (m : Model) : + modelWireSize (closeRun m) ≤ modelWireSize m+1 := by + unfold closeRun modelWireSize + split + · omega + · simp only [framesSize,List.map_append,List.sum_append,List.map_cons,List.map_nil, + List.sum_cons,List.sum_nil,frameSize,List.length_nil] + omega + +theorem tokenModelCount_wire (m : Model) (t : CallerToken) : + modelWireSize (tokenModelCount m t).1 ≤ modelWireSize m+26 := by + have closed := closeRun_wire m + have cursor : (closeRun m).consumed = m.consumed := by + unfold closeRun + split <;> rfl + cases t with + | sent value => + simp only [tokenModelCount,tokenOperation,operationCount,modelAbsorb] + split + · omega + · unfold modelWireSize + simp only [List.length_append,scalarBytes_length,List.length_cons,List.length_nil] + split <;> omega + | draw value => + simp only [tokenModelCount,tokenOperation,operationCount] + norm_num only + simp only [ite_false,closeRunCount_value,modelWireSize] at * + omega + | nonce bits value => + simp only [tokenModelCount,tokenOperation,operationCount,closeRunCount_value,modelWireSize, + framesSize,List.map_append,List.sum_append,List.map_cons,List.map_nil, + List.sum_cons,List.sum_nil,frameSize,List.length_nil] at * + omega + +theorem tokenModelsCount_wire (m : Model) (ts : List CallerToken) : + modelWireSize (tokenModelsCount m ts).1 ≤ modelWireSize m+26*ts.length := by + induction ts generalizing m with + | nil => simp [tokenModelsCount] + | cons t ts ih => + have first := tokenModelCount_wire m t + have later := ih (tokenModelCount m t).1 + simp only [tokenModelsCount,List.length_cons] + omega + +theorem tokenHistoryCount_size (domain statement : Digest32) (ts : List CallerToken) : + framesSize (tokenHistoryCount domain statement ts).1.frames ≤ 26*ts.length+1 := by + have built := tokenModelsCount_wire (seedModel domain statement) ts + have closed := closeRun_wire (tokenModelsCount (seedModel domain statement) ts).1 + unfold tokenHistoryCount + dsimp only + rw [closeRunCount_value] + simp only [modelWireSize] at closed + have emptySize : framesSize ([] : List Frame) = 0 := rfl + simp only [modelWireSize,seedModel,emptySize,List.length_nil] at built + simp only [seedModel] at closed ⊢ + omega + +theorem tokensFromFrame_length (f : Frame) (output : List Byte) (ts : List CallerToken) + (returned : tokensFromFrame f output = some ts) : ts.length ≤ frameSize f := by + cases f with + | nonce consumed bits value => + simp only [tokensFromFrame,previousConsumed] at returned + by_cases guard : consumed%24 ≠ 0 + · simp [guard] at returned + · simp only [guard,↓reduceIte] at returned + cases h : parseExact (consumed/24) output with + | none => simp [h] at returned + | some xs => + have size := parseExact_length _ _ _ h + simp only [h] at returned + change some (xs.map CallerToken.draw++[.nonce bits value]) = some ts at returned + cases returned + simp only [List.length_append,List.length_map,List.length_cons,List.length_nil,frameSize] + omega + | absorb consumed bytes => + simp only [tokensFromFrame,previousConsumed] at returned + by_cases guard : consumed%24 ≠ 0 + · simp [guard] at returned + · simp only [guard,↓reduceIte] at returned + cases h : parseExact (consumed/24) output with + | none => simp [h] at returned + | some xs => + have drawSize := parseExact_length _ _ _ h + simp only [h] at returned + cases hs : parseExact (bytes.length/24) bytes with + | none => simp [hs] at returned + | some ys => + have sentSize := parseExact_length _ _ _ hs + simp only [hs] at returned + change some (xs.map CallerToken.draw++ys.map CallerToken.sent) = some ts at returned + cases returned + simp only [List.length_append,List.length_map,frameSize] + omega + +theorem tokenFramesCount_bounds (e : FramedHistory) (answers : Coordinate → Digest32) + (fs : List (Frame × Nat)) (P : Nat) (entryCap : framesSize e.frames ≤ P) + (frameCaps : ∀ fi ∈ fs, frameSize fi.1 ≤ P) : + (tokenFramesCount e answers fs).2.1 ≤ fs.length*P ∧ + (tokenFramesCount e answers fs).2.2 ≤ fs.length*(frameParserPolynomial P+3)+1 := by + induction fs with + | nil => simp [tokenFramesCount] + | cons fi fs ih => + rcases fi with ⟨f,i⟩ + have first := frameTokensCount_bound e answers i f P entryCap (frameCaps (f,i) (by simp)) + have later := ih (fun fi hi => frameCaps fi (by simp [hi])) + simp only [tokenFramesCount,List.length_cons] + cases (frameTokensCount e answers i f).1 <;> dsimp only <;> constructor <;> nlinarith + +theorem tokenFramesCount_lengths (e : FramedHistory) (answers : Coordinate → Digest32) + (fs : List (Frame × Nat)) (P : Nat) + (frameCaps : ∀ fi ∈ fs, frameSize fi.1 ≤ P) + (blocks : List (List CallerToken)) (returned : (tokenFramesCount e answers fs).1 = some blocks) : + blocks.length = fs.length ∧ blocks.flatten.length ≤ fs.length*P := by + induction fs generalizing blocks with + | nil => cases returned; simp + | cons fi fs ih => + rcases fi with ⟨f,i⟩ + simp only [tokenFramesCount] at returned + cases h : (frameTokensCount e answers i f).1 with + | none => simp [h] at returned + | some ts => + have first := (tokensFromFrame_length f _ ts (by + have r : tokensFromFrame f + (recoveredBytesCount e answers {e with frames := e.frames.take i} (previousConsumed f)).1 = some ts := by + simpa only [frameTokensCount,tokensFromFrameCount_value] using h + exact r)).trans (frameCaps (f,i) (by simp)) + simp only [h] at returned + cases hb : (tokenFramesCount e answers fs).1 with + | none => simp [hb] at returned + | some rest => + simp only [hb,Option.map_some,Option.some.injEq] at returned + subst blocks + have later := ih (fun fi hi => frameCaps fi (by simp [hi])) rest hb + simp only [List.length_cons,List.flatten_cons,List.length_append] + constructor <;> nlinarith + +def entryParserPolynomial (P : Nat) : Nat := + P*(frameParserPolynomial P+3)+(P*P+1)*(48*(P*P)+1000)+28*P*P+4*P+1030 + +theorem entryTokensCount_bound (e : FramedHistory) (answers : Coordinate → Digest32) (P : Nat) + (entryCap : framesSize e.frames ≤ P) : + (entryTokensCount e answers).2.1 ≤ P*P ∧ + (entryTokensCount e answers).2.2 ≤ entryParserPolynomial P := by + have count := (framesSize_length e.frames).trans entryCap + have caps : ∀ fi ∈ e.frames.zipIdx, frameSize fi.1 ≤ P := by + intro fi member + have atFrame := List.mem_zipIdx_iff_getElem?.mp member + have inside : fi.1 ∈ e.frames := List.mem_of_getElem? atFrame + have sumCap : frameSize fi.1 ≤ framesSize e.frames := by + unfold framesSize + exact List.le_sum_of_mem (List.mem_map.mpr ⟨fi.1,inside,rfl⟩) + exact sumCap.trans entryCap + have frames := tokenFramesCount_bounds e answers e.frames.zipIdx P entryCap caps + simp only [List.length_zipIdx] at frames + unfold entryTokensCount + dsimp only + cases h : (tokenFramesCount e answers e.frames.zipIdx).1 with + | none => unfold entryParserPolynomial; constructor <;> nlinarith + | some blocks => + have sizes := tokenFramesCount_lengths e answers e.frames.zipIdx P caps blocks h + simp only [List.length_zipIdx] at sizes + have tokenCap : blocks.flatten.length ≤ P*P := sizes.2.trans (Nat.mul_le_mul_right _ count) + have rebuilding := tokenHistoryCount_bound e.domain e.statement blocks.flatten + have rebuildCap : (tokenHistoryCount e.domain e.statement blocks.flatten).2 ≤ + (P*P+1)*(48*(P*P)+1000) := by apply rebuilding.trans; gcongr + have wireCap := tokenHistoryCount_size e.domain e.statement blocks.flatten + unfold entryParserPolynomial + constructor <;> nlinarith + +theorem entryTokensCount_length (e : FramedHistory) (answers : Coordinate → Digest32) + (P : Nat) (entryCap : framesSize e.frames ≤ P) (tokens : List CallerToken) + (returned : (entryTokensCount e answers).1 = some tokens) : tokens.length ≤ P*P := by + have count := (framesSize_length e.frames).trans entryCap + have caps : ∀ fi ∈ e.frames.zipIdx, frameSize fi.1 ≤ P := by + intro fi member + have atFrame := List.mem_zipIdx_iff_getElem?.mp member + have inside : fi.1 ∈ e.frames := List.mem_of_getElem? atFrame + have sumCap : frameSize fi.1 ≤ framesSize e.frames := by + unfold framesSize + exact List.le_sum_of_mem (List.mem_map.mpr ⟨fi.1,inside,rfl⟩) + exact sumCap.trans entryCap + unfold entryTokensCount at returned + dsimp only at returned + cases frames : (tokenFramesCount e answers e.frames.zipIdx).1 with + | none => simp only [frames] at returned; cases returned + | some blocks => + have sizes := tokenFramesCount_lengths e answers e.frames.zipIdx P caps blocks frames + simp only [List.length_zipIdx] at sizes + have tokenCap := sizes.2.trans (Nat.mul_le_mul_right P count) + simp only [frames] at returned + split at returned + · cases returned + exact tokenCap + · cases returned + +#print axioms entryTokensCount_length + +#print axioms entryTokensCount_bound + +#print axioms entryTokensCount_value + +#print axioms frameTokensCount_value + +#print axioms tokenHistoryCount_value +#print axioms tokenHistoryCount_bound + +#print axioms parseScalarsCount_value +#print axioms parseStepsCount_value +#print axioms parseStepsCount_bound +#print axioms stepsBudget_polynomial +end Whir.PCSBCSPublicLogParserCost diff --git a/verification/whir/Whir/PCSBCSPublicPrimitiveOpening.lean b/verification/whir/Whir/PCSBCSPublicPrimitiveOpening.lean new file mode 100644 index 000000000..231754a3f --- /dev/null +++ b/verification/whir/Whir/PCSBCSPublicPrimitiveOpening.lean @@ -0,0 +1,342 @@ +import Whir.PCSBCSWholeNativeCaptureTransport +import Whir.PCSBCSNativePublicCapture +import Whir.PCSBCSObservedPrimitiveExtension + +/-! Finite public refinement of every retained historical native opening. +The zero extension is used only on observed inputs; unobserved oracle values +may differ arbitrarily. No global seed equality or cryptographic exclusion is +an assumption of the refinement. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSPublicPrimitiveOpening +open Concrete Protocol FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open RawOracleCoupling PCSBCSChallengeOracle PublicMerkleLog +open MerkleTransport WHIRPhysicalVerifier PCSBCSSourceRootReferences +open PCSBCSCapturedNativeReplyBridge +open PCSStateRestoration.Latent + +/-- A genuinely public finite oracle, with a fixed zero fallback. -/ +def publicSeed {R : Type} (view : View R) : PrimitiveOracle := + PCSBCSObservedPrimitiveExtension.extension (fun _ => DuplexRefinement.zeroDigest) + (DuplexPublicSimulator.finalLog [] view.observations) + +noncomputable def publicOrdinaryLog {R : Type} (B : Nat) (iv : Digest32) + (view : View R) : PublicLog := + (PCSBCSNativePublicCapture.mixedTrace B iv [] view.observations).foldl + (fun log event => PCSBCSNativePublicCapture.rawOrdinary event ++ log) [] + +/-- The decoder is the literal-byte constant-address decoder, not caller +answers or a private registry. Profile and entry boundary are current metadata. -/ +noncomputable def publicBadOpening {R : Type} (B : Nat) (iv : Digest32) + {p : ParameterBounds.Profile} {boundary : Nat} (ref : Reference) + (view : View R) (opening : QueryOpening p) : Prop := + PublicMerkleBinding.OpenPrimitiveBad (publicSeed view) + (PCSBCSNativePublicCapture.publicLog + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) (iv := iv) + (boundary := boundary)) ref view) opening.root opening.result.paths +theorem planFrom_authentic (C : PrimitiveOracle) (cv : Digest32) (count : Nat) + (bs : List (List Byte)) : AuthenticLog C (planFrom C cv count bs) := by + induction bs generalizing cv count with + | nil => intro n d member; simp [planFrom] at member + | cons b rest ih => + cases rest with + | nil => + intro n d member + obtain ⟨rfl,rfl⟩ := Prod.mk.inj (List.mem_singleton.mp member) + rfl + | cons next rest => + intro n d member + rcases List.mem_cons.mp member with equal | later + · obtain ⟨rfl,rfl⟩ := Prod.mk.inj equal + rfl + · exact ih _ _ n d later + + +/-- Agreement on just one finite adaptive compression plan suffices. -/ +theorem planFrom_locality (C D : PrimitiveOracle) (cv : Digest32) (count : Nat) + (bs : List (List Byte)) + (agree : ∀ e ∈ planFrom C cv count bs, D e.1 = C e.1) : + planFrom D cv count bs = planFrom C cv count bs ∧ + run (fun n => some (D n)) cv count bs = run (fun n => some (C n)) cv count bs := by + induction bs generalizing cv count with + | nil => exact ⟨rfl,rfl⟩ + | cons b rest ih => + cases rest with + | nil => + have equal := agree _ (List.mem_cons_self : + (node cv count b true,C (node cv count b true)) ∈ planFrom C cv count [b]) + constructor <;> simp only [planFrom,run,equal] + | cons next rest => + have equal := agree _ (List.mem_cons_self : + (node cv count b false,C (node cv count b false)) ∈ planFrom C cv count (b :: next :: rest)) + obtain ⟨plans,runs⟩ := ih (C (node cv count b false)) (count+b.length) + (fun e member => agree e (List.mem_cons_of_mem _ member)) + constructor + · simp only [planFrom,equal,plans] + · simpa only [run,equal,Option.bind_eq_bind,Option.bind_some] using runs + +theorem hash_plan_locality (C D : PrimitiveOracle) (bytes : List Byte) + (agree : ∀ e ∈ plan C bytes, D e.1 = C e.1) : + hash D bytes = hash C bytes ∧ plan D bytes = plan C bytes := by + obtain ⟨plans,runs⟩ := planFrom_locality C D DuplexCompression.parameterIV 0 (chunks bytes) agree + exact ⟨congrArg (fun result => result.getD DuplexCompression.parameterIV) runs,plans⟩ + +/-- Hash equality is required only for the inputs of this particular path. -/ +theorem opening_locality (C D : PrimitiveOracle) {q : List Bool} + (opening : MerkleBinding.Opening (List K) Digest32 q) + (agree : ∀ bytes ∈ opening.inputs (hashing (hash C)), hash D bytes = hash C bytes) : + opening.digest (hashing (hash D)) = opening.digest (hashing (hash C)) ∧ + opening.inputs (hashing (hash D)) = opening.inputs (hashing (hash C)) := by + induction opening with + | leaf row => + exact ⟨agree _ (by simp [MerkleBinding.Opening.inputs,hashing]),rfl⟩ + | node side sibling child ih => + obtain ⟨digest,inputs⟩ := ih (fun bytes member => agree bytes (Finset.mem_insert_of_mem member)) + constructor + · simp only [MerkleBinding.Opening.digest] + rw [digest] + exact agree _ (Finset.mem_insert_self _ _) + · simp only [MerkleBinding.Opening.inputs] + rw [digest,inputs] + rfl + +/-- Targets depend on the pair codec and public recorded domain, not the hash. -/ +theorem target_locality (C D : PrimitiveOracle) (table : Finset (List Byte)) + (root digest : Digest32) : + MerkleBinding.Target (hashing (hash D)) table root digest ↔ + MerkleBinding.Target (hashing (hash C)) table root digest := Iff.rfl + +theorem freshTarget_locality (C D : PrimitiveOracle) (oldLog : PublicLog) + (target : Digest32) (bytes : List Byte) + (agree : ∀ e ∈ plan C bytes, D e.1 = C e.1) : + FreshTarget D oldLog target (plan D bytes) ↔ FreshTarget C oldLog target (plan C bytes) := by + have plans := (hash_plan_locality C D bytes agree).2 + rw [plans] + constructor + · rintro ⟨n,present,absent,hit⟩ + have equal := agree (n,D n) present + exact ⟨n,by simpa only [equal] using present,absent,by simpa only [equal] using hit⟩ + · rintro ⟨n,present,absent,hit⟩ + have equal := agree (n,C n) present + exact ⟨n,by simpa only [equal] using present,absent,by simpa only [equal] using hit⟩ + +theorem openPrimitiveBad_locality (C D : PrimitiveOracle) (oldLog : PublicLog) + (root : Digest32) (paths : List RawPath) + (agree : ∀ path ∈ paths, ∀ bytes ∈ path.opening.inputs (hashing (hash C)), + ∀ e ∈ plan C bytes, D e.1 = C e.1) : + PublicMerkleBinding.OpenPrimitiveBad D oldLog root paths ↔ + PublicMerkleBinding.OpenPrimitiveBad C oldLog root paths := by + have inputs : ∀ path ∈ paths, + path.opening.inputs (hashing (hash D)) = path.opening.inputs (hashing (hash C)) := by + intro path member + exact (opening_locality C D path.opening + (fun bytes present => (hash_plan_locality C D bytes (agree path member bytes present)).1)).2 + unfold PublicMerkleBinding.OpenPrimitiveBad PublicMerkleBinding.PrimitiveFreshHit + apply or_congr Iff.rfl + apply exists_congr + intro path + apply and_congr_right + intro member + rw [inputs path member] + apply exists_congr + intro bytes + apply and_congr_right + intro present + have agreement := agree path member bytes present + rw [(hash_plan_locality C D bytes agreement).1] + exact and_congr (target_locality C D _ _ _) (freshTarget_locality C D oldLog _ bytes agreement) + +section Generic +variable {R : Type} {p : ParameterBounds.Profile} {B : Nat} {iv : Digest32} {boundary : Nat} + (seed : PrimitiveOracle) (ro : RawKey B → Digest32) (program : Program R) + (remaining : Nat) (limit : remaining ≤ B) (counted : Counts remaining program) +local notation "part" => EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary) +local notation "source" => (Atomic.program part + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) +local notation "table" => Partition.split part (PublicCompressionCouplingMixed.oracle seed ro) + +theorem publicSeed_observed : + ∀ purpose input answer, + (⟨.primitive purpose input,answer⟩ : Observation) ∈ + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)).observations → + publicSeed (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted)) input = answer := by + intro purpose input answer member + apply PCSBCSObservedPrimitiveExtension.extension_of_mem + · rw [PublicCompressionCouplingMixed.compile_actual] + exact DuplexPublicSimulator.finalLog_functional ro iv ⟨seed,[]⟩ program remaining limit counted + (by simp [DuplexPublicSimulator.Functional]) + · exact PCSBCSObservedPrimitiveExtension.primitive_in_finalLog [] _ purpose input answer member + +theorem publicOrdinaryLog_actual : + publicOrdinaryLog B iv (Sampling.eval table source) = + PCSBCSSourceRootCapture.ordinaryPrefix (Sampling.execute table source).2 := by + rw [Atomic.eval_program,Partition.join_split] + unfold publicOrdinaryLog PCSBCSSourceRootCapture.ordinaryPrefix + rw [← PCSBCSNativePublicCapture.mixedTrace_actual B seed ro iv [] program remaining limit counted, + PCSBCSAtomicAllocationTrace.execute_program,Partition.join_split] + symm + exact PCSBCSNativePublicCapture.ordinary_map seed ro _ + (PCSBCSNativePublicCapture.execute_answers _ _) [] + +/-- Every captured old record is also an authentic record for the public +extension. Even nonzero-tag fallback draws have actual observation provenance. -/ +theorem publicSeed_sourceLog_authentic + (address : PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) → List Reference) + (ref : Reference) : + AuthenticLog (publicSeed (Sampling.eval table source)) (sourceLog address ref source table) := by + intro input answer member + have whole := PCSBCSNativeCapturedLogs.sourceLog_subset address ref source table _ member + have raw := PCSBCSNativePhysicalMerkleBad.atomic_ordinary_origin seed ro _ (input,answer) whole + obtain ⟨purpose,observed⟩ := PCSBCSNativePhysicalMerkleBad.mixed_seed_origin + B seed ro iv [] program remaining limit counted input answer raw + rw [Atomic.eval_program,Partition.join_split] + exact publicSeed_observed seed ro program remaining limit counted purpose input answer observed + +/-- The public whole-log reconstruction covers every typed table, not just +tables from a constrained seed family. -/ +theorem publicOrdinaryLog_every_table + (typed : Table (PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary)) + PCSBCSSourceRootCapture.Answer) : + publicOrdinaryLog B iv (Sampling.eval typed source) = + PCSBCSSourceRootCapture.ordinaryPrefix (Sampling.execute typed source).2 := by + obtain ⟨arbitrarySeed,arbitraryRO,equal⟩ := PCSBCSNativeSourceTables.every_table typed + rw [← equal] + exact publicOrdinaryLog_actual arbitrarySeed arbitraryRO program remaining limit counted + +theorem publicSeed_sourceLog_authentic_every_table + (typed : Table (PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary)) + PCSBCSSourceRootCapture.Answer) + (address : PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) → List Reference) + (ref : Reference) : + AuthenticLog (publicSeed (Sampling.eval typed source)) (sourceLog address ref source typed) := by + obtain ⟨arbitrarySeed,arbitraryRO,equal⟩ := PCSBCSNativeSourceTables.every_table typed + rw [← equal] + exact publicSeed_sourceLog_authentic arbitrarySeed arbitraryRO program remaining limit counted address ref + +/-- Public first-reference logs are subsets of the public whole ordinary log, +including prequeries, repeated queries, and independently answered packets. -/ +theorem publicLog_subset_every_table + (typed : Table (PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary)) + PCSBCSSourceRootCapture.Answer) + (address : PCSBCSSourceRootCapture.Key (p := p) (Q := B) (iv := iv) (boundary := boundary) → List Reference) + (ref : Reference) : + ∀ record ∈ PCSBCSNativePublicCapture.publicLog address ref (Sampling.eval typed source), + record ∈ publicOrdinaryLog B iv (Sampling.eval typed source) := by + rw [← PCSBCSNativePublicCapture.publicLog_every_table program remaining limit counted typed address ref, + publicOrdinaryLog_every_table program remaining limit counted typed] + exact PCSBCSNativeCapturedLogs.sourceLog_subset address ref source typed + +end Generic + +section Whole +variable (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + (A B : Nat) (limit : A ≤ B) + (counted : Counts A (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker)) + (seed : PrimitiveOracle) (ro : RawKey B → Digest32) + +/-- Accepted native syntax supplies every ordinary path plan in the complete +mixed-source view, including any arbitrary attacker prefix. -/ +theorem mixed_success_evaluated (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) + (opening : QueryOpening a.input.packet.val.profile) (member : opening ∈ a.native.wire.openings) : + ∀ path ∈ opening.result.paths, ∀ bytes ∈ path.opening.inputs (hashing (hash seed)), + bytes.length < 2^56 ∧ ∀ event ∈ plan seed bytes, + (⟨.primitive .verification event.1,event.2⟩ : Observation) ∈ + (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro).observations := by + obtain ⟨before,after,split,_,run,consistent⟩ := PCSBCSWholeNativePacketCoverage.mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨_,_,_,_,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh (registry.packetModel Q a.input.packet) registry.context rfl Q + a.input.packet a.input.record a.input.proofs after a.native run + obtain ⟨proof,_,accepted,covered⟩ := AnchoredIdealPhysicalAcceptance.observed_real + (observed opening member) seed registry.context.iv consistent + intro path present bytes input + obtain ⟨bound,evaluated⟩ := WHIRPhysicalSoundness.openQuery_evaluated seed registry.context.iv + a.input.packet.val.profile opening.level a.input.record.shape.lanes proof opening.root opening.sample + opening.result accepted path present bytes input + refine ⟨bound,?_⟩ + intro event queried + rw [split] + exact List.mem_append_right _ (covered _ (evaluated event queried)) + +theorem mixed_success_publicBadOpening_iff + (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) + (opening : QueryOpening a.input.packet.val.profile) (member : opening ∈ a.native.wire.openings) : + publicBadOpening B registry.context.iv + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (PCSBCSNativeRootRoles.openingRole a.input.record opening) + (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro) opening ↔ + PublicMerkleBinding.OpenPrimitiveBad seed + (PCSBCSWholeNativeCaptureTransport.wholeOpeningLog cap registry Q attacker A B limit counted seed ro a opening) + opening.root opening.result.paths := by + let program := PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker + have logs := PCSBCSNativePublicCapture.publicLog_actual (p := a.input.packet.val.profile) + (iv := registry.context.iv) (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + seed ro program A limit counted PCSBCSCapturedSourceTransport.address + (PCSBCSNativeRootRoles.openingRole a.input.record opening) + dsimp only at logs + rw [Atomic.eval_program,Partition.join_split] at logs + change PublicMerkleBinding.OpenPrimitiveBad _ _ _ _ ↔ _ + rw [← logs] + apply openPrimitiveBad_locality + intro path present bytes input event queried + have observed := (mixed_success_evaluated cap registry Q attacker A B limit counted seed ro + a success opening member path present bytes input).2 event queried + have answer := publicSeed_observed seed ro program A limit counted .verification event.1 event.2 observed + have authentic : event.2 = seed event.1 := by + exact (planFrom_authentic seed _ _ _ event.1 event.2 queried).symm + exact answer.trans authentic + +theorem wholeOrdinaryLog_actual (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) : + publicOrdinaryLog B registry.context.iv + (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro) = + PCSBCSSourceRootCapture.ordinaryPrefix + (Sampling.execute + (PCSBCSWholeNativePacketCoverage.mixedTable (p := a.input.packet.val.profile) + (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) seed ro) + (PCSBCSWholeNativeCaptureTransport.wholeAllocation cap registry Q attacker A B limit counted a)).2 := by + have logs := publicOrdinaryLog_actual (p := a.input.packet.val.profile) (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + seed ro (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker) A limit counted + rw [Atomic.eval_program,Partition.join_split] at logs + exact logs + +/-- Cleanliness of the one public whole log implies cleanliness at all first +reference captures, without a separate per-reference hypothesis. -/ +theorem wholeReferenceLog_clean (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (clean : ¬ OutputCollision (publicOrdinaryLog B registry.context.iv + (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro))) : + ∀ ref, ¬ OutputCollision + (PCSBCSWholeNativeCaptureTransport.wholeReferenceLog cap registry Q attacker A B limit counted seed ro a ref) := by + have logs := publicOrdinaryLog_actual (p := a.input.packet.val.profile) (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + seed ro (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker) A limit counted + rw [Atomic.eval_program,Partition.join_split] at logs + rw [logs] at clean + intro ref collision + exact clean (PCSBCSNativeCapturedLogs.sourceLog_collision _ ref _ _ collision) + +end Whole +#print axioms planFrom_locality +#print axioms hash_plan_locality +#print axioms opening_locality +#print axioms target_locality +#print axioms freshTarget_locality +#print axioms openPrimitiveBad_locality +#print axioms publicSeed_observed +#print axioms publicOrdinaryLog_actual +#print axioms publicSeed_sourceLog_authentic +#print axioms mixed_success_evaluated +#print axioms mixed_success_publicBadOpening_iff +#print axioms wholeReferenceLog_clean +#print axioms planFrom_authentic +#print axioms publicOrdinaryLog_every_table +#print axioms publicSeed_sourceLog_authentic_every_table +#print axioms publicLog_subset_every_table +#print axioms wholeOrdinaryLog_actual +end Whir.PCSBCSPublicPrimitiveOpening diff --git a/verification/whir/Whir/PCSBCSRecoveredSourceVolume.lean b/verification/whir/Whir/PCSBCSRecoveredSourceVolume.lean new file mode 100644 index 000000000..e91265e0f --- /dev/null +++ b/verification/whir/Whir/PCSBCSRecoveredSourceVolume.lean @@ -0,0 +1,60 @@ +import Whir.PCSBCSCoordinateCodecCost +import Whir.PCSBCSPublicLogParserCost + +/-! A successful actual public-log coordinate recovery derives its wire-volume +cap from the same physical compression budget. Numeric cursor values contribute +by value and their admitted 49-bit range is kept explicit. No source-work +certificate or bound on an arbitrary metadata callback is used. -/ +set_option autoImplicit false +namespace Whir.PCSBCSRecoveredSourceVolume +open FiatShamirGame DuplexFraming DuplexEncoding DuplexPublicSimulator +open PCSBCSCoordinateCodecCost PCSBCSPublicLogParserCost + +def recoveredFramePolynomial (Q : Nat) : Nat := (2^49+1)*(65*Q) + +theorem frameSize_valid (frame : Frame) (valid : FrameValid frame) : + frameSize frame ≤ (2^49+1)*frameUnits frame := by + cases frame <;> simp only [FrameValid] at valid <;> + simp only [frameSize,frameUnits] <;> nlinarith + +theorem framesSize_valid (frames : List Frame) + (valid : ∀ frame ∈ frames, FrameValid frame) : + framesSize frames ≤ (2^49+1)*bodyUnits frames := by + induction frames with + | nil => simp [framesSize,bodyUnits] + | cons frame rest ih => + have first := frameSize_valid frame (valid frame (by simp)) + have later := ih (fun f member => valid f (by simp [member])) + simp only [framesSize,bodyUnits,List.map_cons,List.sum_cons] at * + nlinarith + +theorem coordinate_wire (q : Coordinate) (valid : Admissible q) (Q : Nat) + (physical : pathCost q ≤ Q) : + framesSize q.history.frames ≤ recoveredFramePolynomial Q := by + have decoded : decode (plan q) = some q := decode_plan q valid + have parsed : parse (plan q) = some q := by + unfold decode at decoded + cases found : parse (plan q) with + | none => simp [found] at decoded + | some candidate => + simp only [found] at decoded + split at decoded + · cases decoded; rfl + · contradiction + have units := parse_units (plan q) q parsed + have volume := framesSize_valid q.history.frames valid.1 + change (plan q).length ≤ Q at physical + unfold recoveredFramePolynomial + nlinarith + +theorem recover_wire {Q : Nat} {iv : Digest32} {log : PublicLog} {input : Node} + {q : Coordinate} (recovered : PCSBCSSourceCoordinateDecoder.recover Q iv log input = some q) : + framesSize q.history.frames ≤ recoveredFramePolynomial Q := by + obtain ⟨_,_,_,_,_,_,valid,physical⟩ := PCSBCSSourceCoordinateDecoder.recover_sound recovered + exact coordinate_wire q valid Q physical + +#print axioms frameSize_valid +#print axioms framesSize_valid +#print axioms coordinate_wire +#print axioms recover_wire +end Whir.PCSBCSRecoveredSourceVolume diff --git a/verification/whir/Whir/PCSBCSRestorationErasure.lean b/verification/whir/Whir/PCSBCSRestorationErasure.lean new file mode 100644 index 000000000..cb34212cb --- /dev/null +++ b/verification/whir/Whir/PCSBCSRestorationErasure.lean @@ -0,0 +1,42 @@ +import Whir.PCSBCSRestorationTrace + +/-! Incoming literal metadata is invariant under its own draw and every future coordinate. This is a strict-prefix fact, not an assertion that actual raw source keys already identify those coordinates. -/ +namespace Whir.PCSBCSRestorationHazard +open Concrete Protocol CausalGame CausalProbability CausalExecution +open PCSRoundByRoundTranscriptState PublicTrace + +set_option autoImplicit false + + theorem incomingTrace_set_unobserved {c : Config} (ring : RingPCSGame.Prefix) (t : Tape c) + (answers : Array Reply) (q r : Coordinate c) (value : Sample r) + (unobserved : position q ≤ position r) : + incomingTrace ring (set r t value) answers q = incomingTrace ring t answers q := by + classical + unfold incomingTrace + congr 1 + funext s + split_ifs with observed + · have different : s ≠ r := by + intro same + subst s + omega + rw [get_set_ne r s t value different] + · rfl + + theorem incomingTrace_initial_ring_independent {c : Config} (left right : RingPCSGame.Prefix) + (t : Tape c) (answers : Array Reply) : + incomingTrace left t answers (.initial : Coordinate c) = incomingTrace right t answers .initial := by + rfl + + theorem incomingData_set_unobserved (p : ParameterBounds.Profile) (root : BaseOracle) + (ring : RingPCSGame.Prefix) (t : Tape (ParameterBounds.config p)) (answers : Array Reply) + (q r : Coordinate (ParameterBounds.config p)) (value : Sample r) + (unobserved : position q ≤ position r) : + incomingData p root ring (set r t value) answers q = incomingData p root ring t answers q := by + unfold incomingData + rw [incomingTrace_set_unobserved ring t answers q r value unobserved] + +#print axioms incomingTrace_set_unobserved +#print axioms incomingTrace_initial_ring_independent +#print axioms incomingData_set_unobserved +end Whir.PCSBCSRestorationHazard diff --git a/verification/whir/Whir/PCSBCSSourceCallerAnswers.lean b/verification/whir/Whir/PCSBCSSourceCallerAnswers.lean new file mode 100644 index 000000000..d87cf7eaa --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCallerAnswers.lean @@ -0,0 +1,210 @@ +import Whir.PCSBCSCapturedSourceTransport + +/-! Finite literal-source caller answers at a fixed public frame boundary. +Bounded coordinates read the joined mixed partition table. Outside the physical +path budget both resolvers use the same inert zero digest; this completion is +not an actual source output. Every caller output of every entered packet is +admitted and physically bounded, and lies outside ALL entered packet fibers. +Thus the original caller decoder depends only on erased other values, including +when the selected full packet is replaced. Public root addresses instead read +only packet-entry bytes; they need no caller-answer independence premise. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceCallerAnswers +open Concrete Protocol CausalGame CausalProbability WHIRHistory PCSBCSRounds +open FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling TypedFiatShamirGame +open PCSBCSChallengeOracle PCSBCSSourceRootReferences +open PCSStateRestoration.Latent + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Actual finite-source lookup on bounded coordinates, with an explicitly inert +completion outside Q. No actual-output assertion is made outside Q. -/ +noncomputable def answers (table : Table Keys Answers) + (coordinate : FiatShamirGame.Coordinate) : Digest32 := + if bound : pathCost coordinate ≤ Q then + (part).join table (.inr (constructionKey Q iv coordinate bound)) + else fun _ => 0 + +/-- Denotational resolver from erased values only. The selected packet's full +answer, including unused bytes, is not an input and is never read. -/ +noncomputable def answersFromOther (current : EnteredPacket p Q iv boundary) + (other : current.OtherValues) : FiatShamirGame.Coordinate → Digest32 := + answers (PCSBCSSourceRootCapture.otherTable current other) + +theorem answers_bounded (table : Table Keys Answers) + (coordinate : FiatShamirGame.Coordinate) (bound : pathCost coordinate ≤ Q) : + answers table coordinate = (part).join table + (.inr (constructionKey Q iv coordinate bound)) := by + simp only [answers, dite_eq_left bound] + +theorem answers_outside (table : Table Keys Answers) + (coordinate : FiatShamirGame.Coordinate) (outside : ¬ pathCost coordinate ≤ Q) : + answers table coordinate = (fun _ => 0) := by + simp only [answers, dite_eq_right outside] + +/-- Strict caller history is shorter than the common entry boundary; every +encoded entered source history contains at least that boundary many frames. -/ +theorem caller_output_recognize_none (entry : FramedHistory) + (entryBoundary : entry.frames.length = boundary) + (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) + (coordinate : FiatShamirGame.Coordinate) + (member : coordinate ∈ WHIRCallerOutputs.callerOutputs entry) + (bound : pathCost coordinate ≤ Q) : + (part).recognize (.inr (constructionKey Q iv coordinate bound)) = none := by + cases hit : (part).recognize (.inr (constructionKey Q iv coordinate bound)) with + | none => rfl + | some block => + have encoded := (part).encode_recognize _ block hit + have keys : block.1.2.2.key block.2 = constructionKey Q iv coordinate bound := + Sum.inr.inj encoded + have same := constructionKey_injective Q iv (block.1.2.2.valid block.2) + (WHIRCallerOutputs.callerOutputs_admissible entry entryValid coordinate member) + (block.1.2.2.pathBound block.2) bound keys + have histories := congrArg FiatShamirGame.Coordinate.history same + unfold SourcePacket.coordinate at histories + rw [WHIRCallerPrefix.outputKeyFrom_history _ (WHIRHistoryKey.stackWidth_positive p) + block.1.1.val (WHIRHistoryKey.scheduled_normal _ _ + block.1.2.2.nonempty block.1.2.2.admitted)] at histories + have lengths := congrArg (fun h : FramedHistory => h.frames.length) histories + have strict := (WHIRCallerOutputs.callerOutputs_strict_prefix entry coordinate member).2.2.1 + have sourceBoundary := block.1.1.property + simp only [List.length_append] at lengths + omega + +/-- The entered packet's physical cap bounds every caller output; no extra +caller-bound promise is needed for the entered-packet endpoint. -/ +theorem caller_output_bounded (packet : EnteredPacket p Q iv boundary) + (coordinate : FiatShamirGame.Coordinate) + (member : coordinate ∈ WHIRCallerOutputs.callerOutputs packet.1.val) : + pathCost coordinate ≤ Q := by + have earlier := WHIRCallerOutputs.callerOutputs_extended_pathCost_le packet.1.val + coordinate member (WHIRHistoryKey.canonicalFrames + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) packet.2.messages) + (.output packet.2.firstBlock.val) + have bounded := packet.2.2.pathBound packet.2.firstBlock + change pathCost ⟨(WHIRCallerPrefix.outputKeyFrom + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) packet.1.val + packet.2.messages packet.2.firstBlock.val).history, + .output packet.2.firstBlock.val⟩ ≤ Q at bounded + simp only [CanonicalPacket.messages] at earlier bounded + rw [WHIRCallerPrefix.outputKeyFrom_history _ (WHIRHistoryKey.stackWidth_positive p) + packet.1.val (WHIRHistoryKey.scheduled_normal _ _ + packet.2.2.nonempty packet.2.2.admitted)] at bounded + exact earlier.trans bounded + +/-- Explicit validity and physical-bound hypotheses make this an actual finite +source-table answer, not the inert outside-budget completion. -/ +theorem caller_output_actual (packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (coordinate : FiatShamirGame.Coordinate) + (member : coordinate ∈ WHIRCallerOutputs.callerOutputs packet.1.val) : + DuplexEncoding.Admissible coordinate ∧ + ∃ bound : pathCost coordinate ≤ Q, + answers table coordinate = (part).join table + (.inr (constructionKey Q iv coordinate bound)) ∧ + (part).recognize (.inr (constructionKey Q iv coordinate bound)) = none := by + have bound := caller_output_bounded packet coordinate member + exact ⟨WHIRCallerOutputs.callerOutputs_admissible _ packet.2.2.entryValid _ member, + bound, answers_bounded table coordinate bound, + caller_output_recognize_none _ packet.1.property packet.2.2.entryValid _ member bound⟩ + +/-- General-entry equality. If no physical bound is supplied, outside-budget +coordinates agree ONLY because both sides share the inert completion. -/ +theorem caller_outputs_other_entry (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (entry : FramedHistory) + (entryBoundary : entry.frames.length = boundary) + (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) + (coordinate : FiatShamirGame.Coordinate) + (member : coordinate ∈ WHIRCallerOutputs.callerOutputs entry) : + answersFromOther current (fun key => table key.val) coordinate = answers table coordinate := by + classical + unfold answersFromOther + by_cases bound : pathCost coordinate ≤ Q + · rw [answers_bounded _ _ bound, answers_bounded _ _ bound] + have missed := caller_output_recognize_none (p := p) (iv := iv) + entry entryBoundary entryValid coordinate member bound + unfold Partition.join + split + · next block hit => + have impossible : some block = none := hit.symm.trans missed + cases impossible + · simp [PCSBCSSourceRootCapture.otherTable] + · rw [answers_outside _ _ bound, answers_outside _ _ bound] + +/-- This covers caller outputs of ANY entered packet, not just current. All +these coordinates have actual admitted/bounded answers by caller_output_actual. -/ +theorem caller_outputs_other (current packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (coordinate : FiatShamirGame.Coordinate) + (member : coordinate ∈ WHIRCallerOutputs.callerOutputs packet.1.val) : + answersFromOther current (fun key => table key.val) coordinate = answers table coordinate := + caller_outputs_other_entry current table packet.1.val packet.1.property + packet.2.2.entryValid coordinate member + +theorem decode_other_entry (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (entry : FramedHistory) + (entryBoundary : entry.frames.length = boundary) + (entryValid : ∀ f ∈ entry.frames, DuplexEncoding.FrameValid f) : + AnchoredSourceFreshCaller.decode layout saved entry + (answersFromOther current (fun key => table key.val)) = + AnchoredSourceFreshCaller.decode layout saved entry (answers table) := by + unfold AnchoredSourceFreshCaller.decode + rw [WHIRCallerClaims.entryTokens_prior_only entry _ _ + (caller_outputs_other_entry current table entry entryBoundary entryValid)] + +theorem decode_other (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (current packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) : + AnchoredSourceFreshCaller.decode layout saved packet.1.val + (answersFromOther current (fun key => table key.val)) = + AnchoredSourceFreshCaller.decode layout saved packet.1.val (answers table) := + decode_other_entry layout saved current table packet.1.val packet.1.property packet.2.2.entryValid + +/-- Updating the selected full packet leaves the erased resolver unchanged at +EVERY coordinate, including its explicitly inert outside-budget completion. -/ +theorem answersFromOther_update_current (current : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (full : EnteredPacket.Block current → Digest32) : + answersFromOther current (fun key => (Function.update table (.inl current) full) key.val) = + answersFromOther current (fun key => table key.val) := by + classical + apply congrArg (answersFromOther current) + funext key + simp [key.property] + +theorem caller_outputs_update_current (current packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (full : EnteredPacket.Block current → Digest32) + (coordinate : FiatShamirGame.Coordinate) + (member : coordinate ∈ WHIRCallerOutputs.callerOutputs packet.1.val) : + answers (Function.update table (.inl current) full) coordinate = answers table coordinate := by + rw [← caller_outputs_other current packet _ coordinate member, + answersFromOther_update_current, caller_outputs_other current packet table coordinate member] + +theorem decode_update_current (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (current packet : EnteredPacket p Q iv boundary) + (table : Table Keys Answers) (full : EnteredPacket.Block current → Digest32) : + AnchoredSourceFreshCaller.decode layout saved packet.1.val + (answers (Function.update table (.inl current) full)) = + AnchoredSourceFreshCaller.decode layout saved packet.1.val (answers table) := by + rw [← decode_other layout saved current packet _, answersFromOther_update_current, + decode_other layout saved current packet table] + +#print axioms answers +#print axioms answersFromOther +#print axioms answers_bounded +#print axioms answers_outside +#print axioms caller_output_recognize_none +#print axioms caller_output_bounded +#print axioms caller_output_actual +#print axioms caller_outputs_other_entry +#print axioms caller_outputs_other +#print axioms decode_other_entry +#print axioms decode_other +#print axioms answersFromOther_update_current +#print axioms caller_outputs_update_current +#print axioms decode_update_current +end Whir.PCSBCSSourceCallerAnswers diff --git a/verification/whir/Whir/PCSBCSSourceCallerOriginal.lean b/verification/whir/Whir/PCSBCSSourceCallerOriginal.lean new file mode 100644 index 000000000..ea79c8dc0 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCallerOriginal.lean @@ -0,0 +1,106 @@ +import Whir.AnchoredSourceFreshCaller +import Whir.PCSBCSCallerBinding + +/-! Original caller inputs are constructed from the actual fresh source decoder. +The two cardinality guards delimit the proof model, not production validation. +Preparation uses the existing executable original-claims checker, including the +independently saved anchor; no claim truth or hash security is asserted. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceCallerOriginal +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec +open PCSBCSCallerBinding + +/-- The exact indexed family returned by the source payload parser. -/ +def indexedFamily (claims : AnchoredSourceCaller.Claims) : + Fin claims.caller.families.length → RingPCSGame.FamilyClaim := + fun j => claims.caller.families[j] + +/-- Decode the actual framed source, check the proof-model domain, and run the +existing preparation algorithm on its original claims and saved anchor. -/ +def original (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) : Option (CallerInput p) := do + let claims ← AnchoredSourceFreshCaller.decode layout saved entry answers + if familyCap : claims.caller.families.length ≤ 2^64 then + if claimCap : claims.caller.points.size + 2 ≤ 2^64 then do + let prepared ← OriginalClaimsChecker.prepare (ParameterBounds.config p) saved.shape.lanes + (indexedFamily claims) claims.caller.points saved.point.toArray saved.value + pure ⟨saved.shape.lanes,claims.caller.families.length,indexedFamily claims, + claims.caller.points,saved.point.toArray,saved.value,prepared,familyCap,claimCap⟩ + else none + else none + +/-- Success identifies the exact constructor record, not merely an extensionally +matching family callback, and exposes the actual preparation result. -/ +theorem original_exact (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (input : CallerInput p) + (accepted : original p layout saved entry answers = some input) : + ∃ (claims : AnchoredSourceCaller.Claims) + (familyCap : claims.caller.families.length ≤ 2^64) + (claimCap : claims.caller.points.size + 2 ≤ 2^64) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config p) saved.shape.lanes + claims.caller.families.length (indexedFamily claims) claims.caller.points + saved.point.toArray saved.value), + AnchoredSourceFreshCaller.decode layout saved entry answers = some claims ∧ + claims.record = saved ∧ claims.caller.root = saved.root ∧ + OriginalClaimsChecker.prepare (ParameterBounds.config p) saved.shape.lanes + (indexedFamily claims) claims.caller.points saved.point.toArray saved.value = some prepared ∧ + input = ⟨saved.shape.lanes,claims.caller.families.length,indexedFamily claims, + claims.caller.points,saved.point.toArray,saved.value,prepared,familyCap,claimCap⟩ := by + unfold original at accepted + obtain ⟨claims,decoded,continued⟩ := Option.bind_eq_some_iff.mp accepted + split at continued + next familyCap => + split at continued + next claimCap => + obtain ⟨prepared,preparedEq,result⟩ := Option.bind_eq_some_iff.mp continued + obtain ⟨recordEq,rootEq⟩ := AnchoredSourceFreshCaller.decode_retained + layout saved entry answers claims decoded + exact ⟨claims,familyCap,claimCap,prepared,decoded,recordEq,rootEq,preparedEq, + (Option.some.inj result).symm⟩ + next => cases continued + next => cases continued + +/-- All caller-bound fields are literal source/saved fields. -/ +theorem original_bound (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (input : CallerInput p) + (accepted : original p layout saved entry answers = some input) : + input.lanes = saved.shape.lanes ∧ input.anchorPoint = saved.point.toArray ∧ + input.anchorValue = saved.value ∧ + ∃ claims : AnchoredSourceCaller.Claims, + AnchoredSourceFreshCaller.decode layout saved entry answers = some claims ∧ + claims.record = saved ∧ claims.caller.root = saved.root ∧ + ∃ h : input.m = claims.caller.families.length, + input.family = (fun j => indexedFamily claims (Fin.cast h j)) ∧ + input.points = claims.caller.points := by + obtain ⟨claims,fc,cc,prepared,decoded,recordEq,rootEq,_,rfl⟩ := + original_exact p layout saved entry answers input accepted + exact ⟨rfl,rfl,rfl,claims,decoded,recordEq,rootEq,rfl,rfl,rfl⟩ + +/-- The returned dependent prepared value is the result of the existing +algorithm on the returned caller fields, not a proof-only clone. -/ +theorem original_prepared (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (input : CallerInput p) + (accepted : original p layout saved entry answers = some input) : + OriginalClaimsChecker.prepare (ParameterBounds.config p) input.lanes input.family input.points + input.anchorPoint input.anchorValue = some input.prepared := by + obtain ⟨claims,fc,cc,prepared,_,_,_,preparedEq,rfl⟩ := + original_exact p layout saved entry answers input accepted + exact preparedEq + +/-- Equality holds for the complete dependent constructor result, including +failures, when only unobserved source answers change. -/ +theorem original_prior_only (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (a b : Coordinate → Digest32) + (agree : ∀ q ∈ WHIRCallerOutputs.callerOutputs entry, a q = b q) : + original p layout saved entry a = original p layout saved entry b := by + have decoded : AnchoredSourceFreshCaller.decode layout saved entry a = + AnchoredSourceFreshCaller.decode layout saved entry b := by + simp only [AnchoredSourceFreshCaller.decode, + entryTokens_prior_only entry a b agree] + simp only [original,decoded] + +#print axioms original_exact +#print axioms original_bound +#print axioms original_prepared +#print axioms original_prior_only +end Whir.PCSBCSSourceCallerOriginal diff --git a/verification/whir/Whir/PCSBCSSourceCallerOriginalCost.lean b/verification/whir/Whir/PCSBCSSourceCallerOriginalCost.lean new file mode 100644 index 000000000..3e2f133e1 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCallerOriginalCost.lean @@ -0,0 +1,155 @@ +import Whir.PCSBCSSourceCallerOriginal +import Whir.PCSBCSCallerSourcePolynomialBound +import Whir.PCSBCSPublicLogParserCost +import Whir.CountedCandidateCheckOriginalResources + +/-! Accounting for the exact fresh caller decoder and original preparation. +Answer calls are counted per recovered byte, not per block. Opaque saved-record +and CPU output accessors retain their explicit OutputCosts. Indexed family +lookup traverses its actual list; the preparation charge includes this scan. +The units are physical immutable input access and logical source/field work, +not external callback CPU time or native compiler instructions. -/ +set_option autoImplicit false +set_option maxHeartbeats 4000000 +namespace Whir.PCSBCSSourceCallerOriginalCost +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec +open PCSBCSCallerPayloadCost +open PCSBCSSourceCallerOriginal PCSBCSCallerBinding + +/-- Preserve the actual decoded claims, answer-access count and parser work. -/ +def decodeCount (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) (cost : OutputCosts) : + Option AnchoredSourceCaller.Claims × Nat × Nat := + let tokens := PCSBCSPublicLogParserCost.entryTokensCount entry answers + match tokens.1 with + | none => (none,tokens.2.1,tokens.2.2+1) + | some ts => + let parsed := freshInterpret layout saved cost ts + (parsed.value,tokens.2.1,tokens.2.2+parsed.work+1) + +theorem decodeCount_value (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) (cost : OutputCosts) : + (decodeCount layout saved entry answers cost).1 = + AnchoredSourceFreshCaller.decode layout saved entry answers := by + simp only [decodeCount,AnchoredSourceFreshCaller.decode, + PCSBCSPublicLogParserCost.entryTokensCount_value] + cases entryTokens entry answers <;> simp [freshInterpret_erasure] + +/-- Reached claims dimensions are public-data sizes, also when preparation +fails. No output or soundness condition is used to discard malformed input. -/ +def dimensions (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) : Nat × Nat := + match AnchoredSourceFreshCaller.decode layout saved entry answers with + | none => (0,0) + | some claims => (claims.caller.families.length,claims.caller.points.size) + +def originalCount (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (cost : OutputCosts) : + Option (CallerInput p) × Nat × Nat := + let parsed := decodeCount layout saved entry answers cost + match parsed.1 with + | none => (none,parsed.2.1,parsed.2.2+1) + | some claims => + if familyCap : claims.caller.families.length ≤ 2^64 then + if claimCap : claims.caller.points.size+2 ≤ 2^64 then + let prepared := OriginalClaimsChecker.countedPrepare (ParameterBounds.config p) saved.shape.lanes + (indexedFamily claims) claims.caller.points saved.point.toArray saved.value + (prepared.1.map (fun value => + ⟨saved.shape.lanes,claims.caller.families.length,indexedFamily claims, + claims.caller.points,saved.point.toArray,saved.value,value,familyCap,claimCap⟩), + parsed.2.1,parsed.2.2+prepared.2.total*(claims.caller.families.length+1)+4) + else (none,parsed.2.1,parsed.2.2+4) + else (none,parsed.2.1,parsed.2.2+4) + +theorem originalCount_value (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (cost : OutputCosts) : + (originalCount p layout saved entry answers cost).1 = original p layout saved entry answers := by + simp only [originalCount,original,decodeCount_value] + cases AnchoredSourceFreshCaller.decode layout saved entry answers with + | none => rfl + | some claims => + dsimp only [Bind.bind,Option.bind] + split + · split + · simp only [OriginalClaimsChecker.countedPrepare_value] + cases OriginalClaimsChecker.prepare (ParameterBounds.config p) saved.shape.lanes + (indexedFamily claims) claims.caller.points saved.point.toArray saved.value <;> rfl + · rfl + · rfl + +/-- Callback prices are exact reached getter traces. They are not a constant +cost hypothesis on an arbitrary source getter. -/ +def getterCharge (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) (cost : OutputCosts) : Nat := + match PCSBCSPublicLogParserCost.entryTokensCount entry answers |>.1 with + | none => 0 + | some tokens => (freshInterpretGetterTrace layout saved tokens).price cost + +def parserPolynomial (P S : Nat) : Nat := + PCSBCSPublicLogParserCost.entryParserPolynomial P+freshInterpretWorkPolynomial S+1 + +theorem decodeCount_bound (layout : CallerLayout) (saved : Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) (cost : OutputCosts) (P S : Nat) + (entryCap : PCSBCSPublicLogParserCost.framesSize entry.frames ≤ P) + (layoutCap : layoutVolume layout ≤ S) (recordCap : recordPublicSize saved ≤ S) + (tokensCap : P*P ≤ S) : + (decodeCount layout saved entry answers cost).2.1 ≤ P*P ∧ + (decodeCount layout saved entry answers cost).2.2 ≤ + parserPolynomial P S+getterCharge layout saved entry answers cost := by + obtain ⟨calls,work⟩ := PCSBCSPublicLogParserCost.entryTokensCount_bound entry answers P entryCap + unfold decodeCount getterCharge + dsimp only + cases tokens : (PCSBCSPublicLogParserCost.entryTokensCount entry answers).1 with + | none => dsimp only; unfold parserPolynomial; constructor <;> omega + | some ts => + have length := (PCSBCSPublicLogParserCost.entryTokensCount_length entry answers P entryCap ts tokens).trans tokensCap + have caller := freshInterpret_work_polynomial layout saved cost ts S layoutCap recordCap length + dsimp only + unfold parserPolynomial + constructor <;> omega + +def originalPolynomial (p : ParameterBounds.Profile) (P S M T : Nat) : Nat := + parserPolynomial P S+ + OriginalClaimsChecker.preparationPolynomial (2^(ParameterBounds.config p).logN) M T*(M+1)+4 + +theorem originalCount_bound (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (cost : OutputCosts) (P S : Nat) + (entryCap : PCSBCSPublicLogParserCost.framesSize entry.frames ≤ P) + (layoutCap : layoutVolume layout ≤ S) (recordCap : recordPublicSize saved ≤ S) + (tokensCap : P*P ≤ S) : + (originalCount p layout saved entry answers cost).2.1 ≤ P*P ∧ + (originalCount p layout saved entry answers cost).2.2 ≤ + originalPolynomial p P S (dimensions layout saved entry answers).1 + (dimensions layout saved entry answers).2+getterCharge layout saved entry answers cost := by + obtain ⟨calls,work⟩ := decodeCount_bound layout saved entry answers cost P S + entryCap layoutCap recordCap tokensCap + unfold originalCount + dsimp only + cases parsed : (decodeCount layout saved entry answers cost).1 with + | none => dsimp only; unfold originalPolynomial; constructor <;> omega + | some claims => + have actual := (decodeCount_value layout saved entry answers cost).symm.trans parsed + have prep := OriginalClaimsChecker.countedPrepare_total (ParameterBounds.config p) saved.shape.lanes + (indexedFamily claims) claims.caller.points saved.point.toArray saved.value + have weighted := Nat.mul_le_mul_right (claims.caller.families.length+1) prep + simp only [dimensions,actual,originalPolynomial] + split + · split + · dsimp only; constructor <;> omega + · dsimp only; constructor <;> omega + · dsimp only; constructor <;> omega + +theorem originalCount_dimensions (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (cost : OutputCosts) + (input : CallerInput p) (returned : (originalCount p layout saved entry answers cost).1 = some input) : + input.lanes = saved.shape.lanes ∧ + dimensions layout saved entry answers = (input.m,input.points.size) := by + have actual := (originalCount_value p layout saved entry answers cost).symm.trans returned + obtain ⟨claims,fc,cc,prepared,decoded,_,_,_,same⟩ := + PCSBCSSourceCallerOriginal.original_exact p layout saved entry answers input actual + subst input + simp [dimensions,decoded] + +#print axioms originalCount_value +#print axioms originalCount_bound +end Whir.PCSBCSSourceCallerOriginalCost diff --git a/verification/whir/Whir/PCSBCSSourceCallerOriginalSmoke.lean b/verification/whir/Whir/PCSBCSSourceCallerOriginalSmoke.lean new file mode 100644 index 000000000..74c311650 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCallerOriginalSmoke.lean @@ -0,0 +1,129 @@ +import Whir.PCSBCSSourceCallerOriginal + +/-! Executable tests of the real source decoder and original preparation on the +lowest production profile. Zero prior-output bytes are explicit parser fixture +coins, not a claim of honest algebraic acceptance or deployed hash outputs. +Public fixture definitions also support the captured-source integration smoke. -/ +namespace Whir.PCSBCSSourceCallerOriginalSmoke +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec +open PCSBCSSourceCallerOriginal + +-- Keep the executable canonical E dictionary used by caller payload smokes. +local instance : Add E := ⟨E.add⟩ +local instance : Mul E := ⟨E.mul⟩ +local instance : Zero E := ⟨E.zero⟩ +local instance : One E := ⟨E.one⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +/-- logN=15, rate=1, read through the real production configuration. -/ +def p : ParameterBounds.Profile := ⟨⟨0,by decide⟩,⟨0,by decide⟩⟩ + +def layout : CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ + +private def digest (n : Nat) : Digest32 := + fun i => ⟨(n / 256^i.val) % 256,Nat.mod_lt _ (by decide)⟩ + +/-- The saved anchor is independent of the fresh all-zero payload draws. -/ +def saved : Record := + ⟨AnchoredSourceCaller.shape layout,digest 17, + ⟨digest 19,(fun _ => none),0,true,0,0⟩, + E.ofK 3 :: List.replicate 14 0,E.ofK 23⟩ + +private def zeroToken : WHIRCallerShape.EventShape → CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) + +def payloadTokens : List CallerToken := + ((WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout)).map zeroToken + +def tokens : List CallerToken := + payloadTokens ++ (openingScalars saved).map CallerToken.sent + +def entry : FramedHistory := tokenHistory (digest 11) (digest 13) tokens + +def answers : Coordinate → Digest32 := fun _ => digest 0 + +def originalInput : Option (PCSBCSCallerBinding.CallerInput p) := + original p layout saved entry answers + +private def require (label : String) (ok : Bool) : IO Unit := do + unless ok do throw (IO.userError s!"source-original smoke failed: {label}") + IO.println s!"source-original: {label}" + +/-- A two-word family at the last aligned occupied region. -/ +def boundaryFamily : Fin 1 → RingPCSGame.FamilyClaim := + fun _ => ⟨8190,#[0],fun bit => E.ofK (UInt64.ofNat (bit.val + 1))⟩ + +def boundaryPoints : Array RingPCSGame.PointClaim := + #[.point 8190 #[0] (E.ofK 31),.strided 8188 1 1 #[0] (E.ofK 37)] + +/-- Exercise preparation, not a source copy or a proof-only prepared value. -/ +def smoke : IO Unit := do + require "lowest real production profile and saved occupied prefix" + ((ParameterBounds.config p).logN == 15 && (ParameterBounds.config p).folds[0]! == 6 && + (ParameterBounds.config p).rates[0]! == 1 && saved.shape.lanes == 16 && decide saved.Valid) + let decoded ← match AnchoredSourceFreshCaller.decode layout saved entry answers with + | none => throw (IO.userError "actual framed source decode rejected") + | some claims => pure claims + require "actual decoder retains saved record/root and emits original family" + (decide (decoded.record = saved ∧ decoded.caller.root = saved.root) && + decoded.caller.families.length == 1 && decoded.caller.points.size == 0) + let input ← match originalInput with + | none => throw (IO.userError "actual source original preparation rejected") + | some input => pure input + require "returned caller has exact saved lanes and independent literal anchor" + (input.lanes == 16 && input.m == 1 && input.points.size == 0 && + input.anchorPoint == saved.point.toArray && input.anchorValue == saved.value && + (if h : 0 < input.m then + input.anchorPoint[0]! != (input.family ⟨0,h⟩).point[0]! else false)) + require "actual preparation materializes source family and saved anchor tables" + (input.prepared.familyWeights.size == 1 && input.prepared.familyWeights[0]!.size == 32768 && + input.prepared.familyTargets[0]!.size == 64 && input.prepared.anchorTable.size == 32768 && + input.prepared.anchorClaim.weight.size == 32768 && + input.prepared.anchorClaim.value == saved.value && input.prepared.basisCache.size == 64 && + input.prepared.anchorTable[1]! == E.ofK 3 && input.prepared.anchorClaim.weight[8192]! == 0) + let prepared ← match OriginalClaimsChecker.prepare (ParameterBounds.config p) saved.shape.lanes + boundaryFamily boundaryPoints saved.point.toArray saved.value with + | none => throw (IO.userError "valid plain/strided end-boundary original preparation rejected") + | some prepared => pure prepared + require "plain and strided last-region boundaries accepted and targets preserved" + ((prepared.familyWeights[0]!)[8190]! == 1 && (prepared.familyWeights[0]!)[8192]! == 0 && + (prepared.familyTargets[0]!)[63]! == E.ofK 64 && prepared.pointClaims.size == 2 && + prepared.pointClaims[0]!.weight[8190]! == 1 && + prepared.pointClaims[1]!.weight[8189]! == 1 && + prepared.pointClaims[1]!.weight[8188]! == 0 && + prepared.pointClaims[0]!.value == E.ofK 31 && prepared.pointClaims[1]!.value == E.ofK 37) + let badFamily : Fin 1 → RingPCSGame.FamilyClaim := + fun j => {boundaryFamily j with offset := 8191} + require "misaligned original family rejected by existing prepare" + (OriginalClaimsChecker.prepare (ParameterBounds.config p) 16 badFamily boundaryPoints + saved.point.toArray saved.value).isNone + let badPoints : List RingPCSGame.PointClaim := + [.point 8191 #[0] 0,.point 8192 #[0] 0, + .point 0 (Array.replicate 16 0) 0, + .strided 8188 2 1 #[0] 0,.strided 8190 1 1 #[0] 0, + .strided 8192 1 1 #[0] 0,.strided 0 0 15 #[0] 0] + for claim in badPoints do + require "invalid plain/strided alignment, span, slot or dimension rejected" + (OriginalClaimsChecker.prepare (ParameterBounds.config p) 16 boundaryFamily #[claim] + saved.point.toArray saved.value).isNone + require "saved anchor dimension checked independently" + (OriginalClaimsChecker.prepare (ParameterBounds.config p) 16 boundaryFamily boundaryPoints + #[E.ofK 3] saved.value).isNone + require "zero and excess lanes rejected" + ((OriginalClaimsChecker.prepare (ParameterBounds.config p) 0 boundaryFamily boundaryPoints + saved.point.toArray saved.value).isNone && + (OriginalClaimsChecker.prepare (ParameterBounds.config p) 65 boundaryFamily boundaryPoints + saved.point.toArray saved.value).isNone) + let changed := {saved with value := E.ofK 24} + let changedEntry := tokenHistory (digest 11) (digest 13) + (payloadTokens ++ (openingScalars changed).map CallerToken.sent) + require "actual constructor rejects changed saved binding frame" + (original p layout saved changedEntry answers).isNone + IO.println "source-original: actual decode/prepare and original guard regressions passed" + +end Whir.PCSBCSSourceCallerOriginalSmoke + +def main : IO Unit := Whir.PCSBCSSourceCallerOriginalSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceCallerSnapshot.lean b/verification/whir/Whir/PCSBCSSourceCallerSnapshot.lean new file mode 100644 index 000000000..f032d4e9a --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceCallerSnapshot.lean @@ -0,0 +1,201 @@ +import Whir.PCSBCSSourceRootCapture +import Whir.PCSBCSSourceReplyInversionIncoming +import Whir.PCSBCSSourcePacketTape +import Whir.PCSBCSCallerBinding +import Whir.PCSBCSSourceFrozenReplies + +/-! Literal source snapshot assembly. The caller statement is a separately bound +input, never a truth premise. Root images come from first-mention capture; the +reply inverse consumes only strict Pending prefixes and checked frozen accesses. +The accepting-source transport and adjacent packet identities remain separate +obligations, rather than fields of this constructor. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceCallerSnapshot +open Concrete Protocol CausalGame CausalProbability FiatShamirGame +open PCSBCSChallengeOracle PCSBCSCallerBinding PCSBCSSourceReplyInversion +open PCSBCSMerkleRootCache PCSBCSSourceRootReferences + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} + + +open Classical PCSStateRestoration.Latent TypedOracleCompiler TypedFiatShamirGame +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) + +/-- Only shapes literally addressed by the current source packet can enter its +snapshot. This excludes a root first mentioned after the current answer. -/ +noncomputable def capturedRegistry {R : Type} {n : Nat} + (address : Keys → List Reference) (program : Sampling Keys Answers R n) + (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) : + PCSBCSSourceFrozenAccessor.Captures := + fun reference => if reference ∈ address (.inl current) then + PCSBCSSourceRootCapture.captureOther address current reference program other else none + +/-- At every enabled shape the erased packet reconstruction is the actual +first-mention capture, not an independently supplied oracle. -/ +theorem capturedRegistry_actual {R : Type} {n : Nat} + (address : Keys → List Reference) (program : Sampling Keys Answers R n) + (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) : + capturedRegistry address program current (fun other => table other.val) = + fun reference => if reference ∈ address (.inl current) then + PCSBCSSourceRootCapture.capture address reference program table else none := by + funext reference + by_cases mentioned : reference ∈ address (.inl current) + · simp only [capturedRegistry,mentioned,↓reduceIte] + exact PCSBCSSourceRootCapture.captureOther_table address current reference mentioned program table + · simp only [capturedRegistry,mentioned,↓reduceIte] + +/-- Every successful packet accessor uses the same first-disclosure capture for +a shared complete shape address, even when its strict prefix is longer. -/ +theorem capturedRegistry_shared {R : Type} {n : Nat} + (address : Keys → List Reference) (program : Sampling Keys Answers R n) + (first second : EnteredPacket p Q iv boundary) (table : Table Keys Answers) + (reference : Reference) + (firstMentions : reference ∈ address (.inl first)) + (secondMentions : reference ∈ address (.inl second)) : + capturedRegistry address program first (fun other => table other.val) reference = + capturedRegistry address program second (fun other => table other.val) reference := by + rw [capturedRegistry_actual,capturedRegistry_actual] + simp only [firstMentions,secondMentions,↓reduceIte] + +/-- Presence in one packet registry cannot be substituted for address +membership in another. Both gates must hold before sharing a captured root. -/ +theorem capturedRegistry_enabled {R : Type} {n : Nat} + (address : Keys → List Reference) (program : Sampling Keys Answers R n) + (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) + (reference : Reference) (mentions : reference ∈ address (.inl current)) : + capturedRegistry address program current (fun other => table other.val) reference = + PCSBCSSourceRootCapture.capture address reference program table := by + rw [capturedRegistry_actual] + simp only [mentions,↓reduceIte] + +/-- A missing first-mention capture rejects, rather than fabricating a zero root. +A present partial capture still retains every cell's explicit availability. -/ +noncomputable def fromCapture {R : Type} {n : Nat} + (address : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (input : CallerInput p) + (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) : + Option (CallerData p) := do + let registry := capturedRegistry address program current other + let root ← registry ref + let answers ← PCSBCSSourceFrozenReplies.replies current.2.coord saved registry + current.2.messages (PCSBCSSourcePacketTape.strictPrefix current other) + pure ⟨input, PCSBCSRestorationHazard.incomingData p root.raw + (PCSBCSSourcePacketTape.ringPrefix current other) + (PCSBCSSourcePacketTape.tape current other) answers current.2.coord⟩ + +/-- Concrete partial-registry assembly retains the independently bound caller, +not a caller reconstructed from the current oracle answer. -/ +theorem captured_original_preserved {R : Type} {n : Nat} + (address : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (input : CallerInput p) + (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) + (data : CallerData p) + (assembled : fromCapture address ref program input saved current other = some data) : + data.original = input := by + unfold fromCapture at assembled + obtain ⟨root,_,continued⟩ := Option.bind_eq_some_iff.mp assembled + obtain ⟨answers,_,equal⟩ := Option.bind_eq_some_iff.mp continued + cases Option.some.inj equal + rfl + +/-- A successful snapshot's root is the actual captured compact image. -/ +theorem captured_root_provenance {R : Type} {n : Nat} + (address : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (input : CallerInput p) + (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) + (data : CallerData p) + (assembled : fromCapture address ref program input saved current other = some data) : + ∃ root, ref ∈ address (.inl current) ∧ + PCSBCSSourceRootCapture.captureOther address current ref program other = some root ∧ + data.observed.root = root.raw := by + unfold fromCapture at assembled + obtain ⟨root,captured,continued⟩ := Option.bind_eq_some_iff.mp assembled + obtain ⟨answers,_,equal⟩ := Option.bind_eq_some_iff.mp continued + cases Option.some.inj equal + by_cases mentioned : ref ∈ address (.inl current) + · exact ⟨root,mentioned,by simpa only [capturedRegistry,mentioned,↓reduceIte] using captured,rfl⟩ + · simp only [capturedRegistry,mentioned,↓reduceIte] at captured + cases captured + +#print axioms captured_original_preserved +#print axioms captured_root_provenance +#print axioms capturedRegistry_actual +#print axioms capturedRegistry_shared +#print axioms capturedRegistry_enabled + +/-- Only checked earlier-coordinate inverses enter the incoming public state, +at the same array index as the source Pending parser. -/ +theorem captured_reply_preserved {R : Type} {count : Nat} + (address : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R count) (input : CallerInput p) + (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (other : current.OtherValues) + (data : CallerData p) + (assembled : fromCapture address ref program input saved current other = some data) + (n : Nat) (earlier : n < position current.2.coord) : + data.observed.trace.answers[n]! = + ((PCSBCSSourceFrozenAccessor.inverseAt current.2.coord saved + (capturedRegistry address program current other) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current other) n).map Inverted.reply).getD default := by + unfold fromCapture at assembled + obtain ⟨root,_,continued⟩ := Option.bind_eq_some_iff.mp assembled + obtain ⟨answers,parsed,equal⟩ := Option.bind_eq_some_iff.mp continued + cases Option.some.inj equal + rw [PCSBCSSourceFrozenReplies.replies_index current.2.coord saved + (capturedRegistry address program current other) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current other) answers parsed n earlier] + change (PCSRoundByRoundTranscriptState.priorAnswers answers (position current.2.coord))[n]! = + answers[n]?.getD default + rw [PCSRoundByRoundTranscriptState.priorAnswers_get answers (position current.2.coord) n earlier] + rw [getElem!_def] + cases answers[n]? <;> rfl + +#print axioms captured_reply_preserved + +/-- Numerical rectangularity follows from the indexed padded capture even when +some images are unavailable. It is not a promise of authenticated availability. -/ +theorem frozen_full_root (log : DuplexPublicSimulator.PublicLog) (digest : Digest32) + (shape : PCSBCSMerkleRootCache.Shape) (lanes : Nat) + (fits : shape.occupied ≤ shape.leafWords) + (height : shape.height = (ParameterBounds.config p).logN - + (ParameterBounds.config p).folds[0]! + (ParameterBounds.config p).rates[0]!) + (occupied : shape.occupied = lanes) : + PCSRoundByRoundSource.FullRoot (ParameterBounds.config p) lanes + (freeze log digest shape).raw := by + have rectangular := freeze_shape log digest shape fits + constructor + · simpa only [SupportedCandidateExtraction.blockLength,height] using rectangular.1 + · intro i + exact (rectangular.2 _ (Array.getElem_mem_toList i.isLt)).trans occupied + +#print axioms frozen_full_root + +/-- Every bit of the selected full packet is absent from this constructor's +source inputs, not merely the challenge bytes consumed by the verifier. -/ +theorem captured_snapshot_answer_independent {R : Type} {n : Nat} + (address : Keys → List Reference) (ref : Reference) + (program : Sampling Keys Answers R n) (input : CallerInput p) + (saved : AnchoredHeaderCodec.Record) + (current : EnteredPacket p Q iv boundary) (table : Table Keys Answers) + (full : Fin (PCSBCSChallengeOracle.blocks + (PCSBCSRounds.rawWidth current.2.coord)) → Digest32) : + fromCapture address ref program input saved current + (fun other => (Function.update table (.inl current) full) other.val) = + fromCapture address ref program input saved current + (fun other => table other.val) := by + have same : (fun other : {key : Keys // key ≠ .inl current} => + (Function.update table (.inl current) full) other.val) = + (fun other : {key : Keys // key ≠ .inl current} => table other.val) := by + funext other + simp only [Function.update_of_ne other.property] + rw [same] + +#print axioms captured_snapshot_answer_independent + +end Whir.PCSBCSSourceCallerSnapshot diff --git a/verification/whir/Whir/PCSBCSSourceFrozenAccessor.lean b/verification/whir/Whir/PCSBCSSourceFrozenAccessor.lean new file mode 100644 index 000000000..ce46b51e2 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceFrozenAccessor.lean @@ -0,0 +1,303 @@ +import Whir.PCSBCSSourceRootReferences +import Whir.PCSBCSFrozenOracleRows +import Whir.PCSBCSSourcePacketTape +import Whir.PCSBCSSourceReplyInversion + +/-! Checked source access, not authentication. The registry is captured under +its four-field Reference by the parent. Unavailable captured cells remain ghost +zeros with explicit status; a missing capture is never totalized into a root. +Remaining integration hypotheses, exactly: +* the saved Record is the immutable caller binding and config is the source config; +* each supplied capture is frozen at its actual first shape-address mention, with + CV binding to that Reference and actual ordinary primitive-prefix provenance; +* Pending metadata is the admitted SourcePacket prefix and the supplied Prefix + is reconstructed from its literal strict predecessor source-packet answers; +* accepted opening transport implies the selected captured rows/path relation + outside OpeningBad; unavailable zeros and valid padding alone do NOT imply it; +* equality to an unnormalized semantic reply additionally requires the existing + canonicalReply compatibility hypothesis (scalar equality proves only quotient + equality). Physical-log identification remains the parent's coupling task. +No final security bound, all-leaf availability or Fiat-Shamir endpoint is assumed. +Only fields read by decodeReplyScalars are supplied to its established inverse. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceFrozenAccessor +open Concrete Protocol CausalGame CausalProbability WHIRHistory FiatShamirGame +open AnchoredHeaderCodec PCSBCSMerkleRootCache PCSBCSMerkleLeafImages +open PCSBCSSourceRootReferences PCSBCSSourceReplyInversion + +abbrev Captures := Reference → Option Frozen + +def sameShape (a b : PCSBCSMerkleRootCache.Shape) : Bool := + a.height == b.height && a.leafWords == b.leafWords && a.occupied == b.occupied + +/-- Check saved storage without silently repairing a corrupted image or table. +Bad padding is represented faithfully here, including in unqueried next rows. -/ +def cellValid (s : PCSBCSMerkleRootCache.Shape) (cell : ImageCell) : Bool := Id.run do + if s.occupied > s.leafWords || cell.image.size != s.leafWords || + cell.compact.size != s.occupied then return false + let padding := s.leafWords-s.occupied + for n in [:s.occupied] do + if cell.compact[n]! != cell.image[padding+n]! then return false + if cell.available then + let mut valid := true + for n in [:padding] do + if cell.image[n]! != 0 then + valid := false + break + return cell.paddingValid == valid + else + return cell.image.all (· == 0) && !cell.paddingValid + +def structurallyValid (ref : Reference) (f : Frozen) : Bool := + sameShape f.shape ref.shape && decide (ref.shape.occupied ≤ ref.shape.leafWords) && + f.cells.size == 2^ref.shape.height && f.raw.size == f.cells.size && + (Id.run do + for n in [:f.cells.size] do + match f.cells[n]? with + | none => return false + | some cell => + if !(cellValid ref.shape cell && f.raw[n]? == some cell.compact) then return false + return true) + +def lookup (registry : Captures) (ref : Reference) : Option Frozen := do + let f ← registry ref + if structurallyValid ref f then some f else none + +/-- The saved initial frame and literal scheduled phase-root roles are reused; +no search for equal digest values or arbitrary scalar offsets occurs. -/ +def phaseReference (c : Config) (saved : Record) (messages : List Pending) + (phase : Nat) : Option Reference := + if phase = 0 then + if saved.shape.logN = c.logN ∧ saved.shape.logBatch = c.folds[0]! ∧ + saved.shape.logRate = c.rates[0]! then + parseInitial saved (openingScalars saved) 3 + else none + else if phaseRolesAdmitted c messages then do + let ref ← (phaseReferences c messages)[phase-1]? + if sameShape ref.shape (phaseShape c phase) then some ref else none + else none + +structure Status where + available : Bool + paddingValid : Bool + deriving BEq, Repr, Inhabited + +def status (cell : ImageCell) : Status := ⟨cell.available,cell.paddingValid⟩ + +structure Selected where + queries : Array Nat + rows : Oracle + cells : Array ImageCell + +/-- Checked traversal keeps duplicates in exactly the derived order. A captured +unavailable cell is admissible ghost data, but available nonzero padding rejects. +Its availability remains explicit and cannot be used as authenticity evidence. -/ +def selectPhase (phase : Nat) (f : Frozen) (queries : Array Nat) : Option Selected := do + let oracle ← PCSBCSFrozenOracleRows.frozenOracle phase f + let rows ← PCSBCSFrozenOracleRows.queryRows oracle queries + let cells ← queries.mapM (fun n => f.cells[n]?) + if cells.all (fun cell => !cell.available || cell.paddingValid) then + some ⟨queries,rows,cells⟩ + else none + +structure Access where + rows : Oracle := #[] + next : Oracle := #[] + queries : Array Nat := #[] + selectedStatus : Array Status := #[] + nextStatus : Array Status := #[] + +def oracles {c : Config} (a : Access) : FrozenOracles c := + ⟨fun _ => a.rows,fun _ _ => a.next⟩ + +/-- Construction is per strict earlier coordinate. Unused decoder branches are +inert; no decoder branch needing a capture can reach those inert values. -/ +def build {c : Config} (current : Coordinate c) (saved : Record) + (registry : Captures) (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (q : Coordinate c) (m : Pending) : Option Access := + if earlier : position q < position current then + match q with + | .query i => do + let priorMessages := (messages.reverse.take (position (.query i : Coordinate c)+1)).reverse + let ref ← phaseReference c saved priorMessages i.val + let f ← lookup registry ref + let raw := past (.query i) earlier + let queries ← deriveQueries (remaining c i.val+c.rates[i.val]!) c.queries[i.val]! + (Array.ofFn raw.1) + let selected ← selectPhase i.val f queries + pure ⟨selected.rows,#[],queries,selected.cells.map status,#[]⟩ + | .fold i j => + if j.val+1 = c.folds[i.val]! ∧ i.val+1 < c.folds.size then do + let ref ← parsePhase c (.fold i j) m (i.val+1) 2 + let f ← lookup registry ref + let next ← PCSBCSFrozenOracleRows.frozenOracle (i.val+1) f + pure ⟨#[],next,#[],#[],f.cells.map status⟩ + else some {} + | _ => some {} + else none + +/-- Each needed partial lookup is validated BEFORE the total inverse is called. -/ +def inverseAt {c : Config} (current : Coordinate c) (saved : Record) + (registry : Captures) (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (n : Nat) : Option Inverted := do + let q ← (schedule c)[n]? + let m ← messages.reverse[n+1]? + let a ← build current saved registry messages past q m + inverse (oracles a) q (stage q) m + +/-- Actual SourcePacket Pending prefixes are used unchanged. -/ +def packetInverseAt {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {entry : FramedHistory} {current : Coordinate (ParameterBounds.config p)} + (packet : PCSBCSChallengeOracle.SourcePacket p Q iv entry current) + (saved : Record) (registry : Captures) (past : WHIRFiatShamir.Prefix current) + (n : Nat) : Option Inverted := + inverseAt current saved registry packet.messages past n + + theorem lookup_missing (registry : Captures) (ref : Reference) + (missing : registry ref = none) : lookup registry ref = none := by + simp [lookup,missing] + + theorem lookup_malformed (registry : Captures) (ref : Reference) (f : Frozen) + (captured : registry ref = some f) (bad : structurallyValid ref f = false) : + lookup registry ref = none := by simp [lookup,captured,bad] + + theorem build_not_earlier {c : Config} (current q : Coordinate c) (saved : Record) + (registry : Captures) (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (m : Pending) (late : ¬ position q < position current) : + build current saved registry messages past q m = none := by simp [build,late] + + theorem selectPhase_order (phase : Nat) (f : Frozen) (qs : Array Nat) (s : Selected) + (selected : selectPhase phase f qs = some s) : + s.queries = qs ∧ ∃ oracle, + PCSBCSFrozenOracleRows.frozenOracle phase f = some oracle ∧ + s.rows.size = qs.size ∧ + ∀ i : Fin qs.size, s.rows[i.val]! = oracle[qs[i]]! := by + unfold selectPhase at selected + cases ho : PCSBCSFrozenOracleRows.frozenOracle phase f with + | none => simp [ho] at selected + | some oracle => + simp only [ho] at selected + dsimp only [Bind.bind,Option.bind] at selected + cases hr : PCSBCSFrozenOracleRows.queryRows oracle qs with + | none => simp [hr] at selected + | some rows => + simp only [hr] at selected + cases hc : qs.mapM (fun n => f.cells[n]?) with + | none => simp [hc] at selected + | some cells => + simp only [hc] at selected + change (if cells.all (fun cell => !cell.available || cell.paddingValid) then + some (⟨qs,rows,cells⟩ : Selected) else none) = some s at selected + split at selected + next => + cases Option.some.inj selected + exact ⟨rfl,oracle,rfl,PCSBCSFrozenOracleRows.queryRows_spec oracle rows qs hr⟩ + next => contradiction + + theorem selectPhase_bad_index (phase : Nat) (f : Frozen) (qs : Array Nat) + (bad : qs.mapM (fun n => f.cells[n]?) = none) : selectPhase phase f qs = none := by + unfold selectPhase + cases PCSBCSFrozenOracleRows.frozenOracle phase f <;> dsimp only [Bind.bind,Option.bind] + case some oracle => + cases PCSBCSFrozenOracleRows.queryRows oracle qs <;> simp [bad] + + theorem inverseAt_integration {c : Config} (current : Coordinate c) (saved : Record) + (registry : Captures) (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (n : Nat) (q : Coordinate c) (m : Pending) (a : Access) + (coordinate : (schedule c)[n]? = some q) (message : messages.reverse[n+1]? = some m) + (constructed : build current saved registry messages past q m = some a) : + inverseAt current saved registry messages past n = inverse (oracles a) q (stage q) m := by + simp [inverseAt,coordinate,message,constructed] + +/-- Whole current answers can change arbitrarily: the constructor receives only +captured registry, immutable Pending metadata and the strict predecessor prefix. -/ + theorem whole_current_invariance {c : Config} (current : Coordinate c) (saved : Record) + (left right : Captures) (messages : List Pending) + (past future : WHIRFiatShamir.Prefix current) (n : Nat) + (registrySame : left = right) (prefixSame : ∀ q h, past q h = future q h) : + inverseAt current saved left messages past n = inverseAt current saved right messages future n := by + have same : past = future := by funext q h; exact prefixSame q h + rw [registrySame,same] + + theorem selectPhase_bad_padding (phase : Nat) (f : Frozen) (qs : Array Nat) + (cells : Array ImageCell) (selected : qs.mapM (fun n => f.cells[n]?) = some cells) + (bad : cells.all (fun cell => !cell.available || cell.paddingValid) = false) : + selectPhase phase f qs = none := by + unfold selectPhase + cases PCSBCSFrozenOracleRows.frozenOracle phase f <;> dsimp only [Bind.bind,Option.bind] + case some oracle => + cases PCSBCSFrozenOracleRows.queryRows oracle qs <;> dsimp only [Bind.bind,Option.bind] + case some rows => + rw [selected] + change (if cells.all (fun cell => !cell.available || cell.paddingValid) then + some (⟨qs,rows,cells⟩ : Selected) else none) = none + rw [bad] + rfl + +open Classical in +/-- Literal whole-packet replacement, including unused bytes, specializes the +strict-tape reconstruction theorem with the fixed captured registry. -/ +theorem inverseAt_update_current {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} + {boundary : Nat} (current : PCSBCSChallengeOracle.EnteredPacket p Q iv boundary) + (saved : Record) (registry : Captures) (n : Nat) + (table : PCSBCSSourcePacketTape.Table (p := p) (Q := Q) (iv := iv) (boundary := boundary)) + (full : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth current.2.coord)) → Digest32) : + inverseAt current.2.coord saved registry current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current + (fun k => Function.update table (.inl current) full k.val)) n = + inverseAt current.2.coord saved registry current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun k => table k.val)) n := by + exact PCSBCSSourcePacketTape.reconstruction_update_current current + (fun past => inverseAt current.2.coord saved registry current.2.messages + (PCSBCSSourcePacketTape.projectedPrefix past) n) table full + +theorem build_query {c : Config} (current : Coordinate c) (saved : Record) + (registry : Captures) (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (i : Fin c.folds.size) (m : Pending) + (earlier : position (.query i : Coordinate c) < position current) + (ref : Reference) (f : Frozen) (qs : Array Nat) (s : Selected) + (reference : phaseReference c saved + (messages.reverse.take (position (.query i : Coordinate c)+1)).reverse i.val = some ref) + (captured : lookup registry ref = some f) + (derived : deriveQueries (remaining c i.val+c.rates[i.val]!) c.queries[i.val]! + (Array.ofFn (past (.query i) earlier).1) = some qs) + (selected : selectPhase i.val f qs = some s) : + build current saved registry messages past (.query i) m = + some ⟨s.rows,#[],qs,s.cells.map status,#[]⟩ := by + simp [build,earlier,reference,captured,derived,selected] + +theorem build_fold_next {c : Config} (current : Coordinate c) (saved : Record) + (registry : Captures) (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) (m : Pending) + (earlier : position (.fold i j : Coordinate c) < position current) + (last : j.val+1 = c.folds[i.val]!) (later : i.val+1 < c.folds.size) + (ref : Reference) (f : Frozen) (next : Oracle) + (reference : parsePhase c (.fold i j) m (i.val+1) 2 = some ref) + (captured : lookup registry ref = some f) + (decoded : PCSBCSFrozenOracleRows.frozenOracle (i.val+1) f = some next) : + build current saved registry messages past (.fold i j) m = + some ⟨#[],next,#[],#[],f.cells.map status⟩ := by + simp [build,earlier,last,later,reference,captured,decoded] + +theorem inverseAt_late {c : Config} (current q : Coordinate c) (saved : Record) + (registry : Captures) (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (n : Nat) (coordinate : (schedule c)[n]? = some q) + (late : ¬ position q < position current) : + inverseAt current saved registry messages past n = none := by + unfold inverseAt + rw [coordinate] + cases messages.reverse[n+1]? <;> simp [build,late] + +#print axioms lookup_missing +#print axioms lookup_malformed +#print axioms build_not_earlier +#print axioms selectPhase_order +#print axioms selectPhase_bad_index +#print axioms inverseAt_integration +#print axioms whole_current_invariance +#print axioms selectPhase_bad_padding +#print axioms inverseAt_update_current +#print axioms build_query +#print axioms build_fold_next +#print axioms inverseAt_late +end Whir.PCSBCSSourceFrozenAccessor diff --git a/verification/whir/Whir/PCSBCSSourceFrozenAccessorSmoke.lean b/verification/whir/Whir/PCSBCSSourceFrozenAccessorSmoke.lean new file mode 100644 index 000000000..2a0e8d085 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceFrozenAccessorSmoke.lean @@ -0,0 +1,161 @@ +import Whir.PCSBCSSourceFrozenAccessor + +/-! Toy geometry, actual BLAKE2s primitive records, frozen reconstruction, +source codecs/deriveQueries and checked reply inverse. Tampered copies exercise +local rejection/status handling, not a mocked security experiment. This is not +an accepted-path authenticity theorem or Fiat-Shamir endpoint. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceFrozenAccessorSmoke +open Concrete Protocol CausalGame CausalProbability WHIRHistory FiatShamirGame +open AnchoredHeaderCodec PCSBCSMerkleRootCache PCSBCSMerkleLeafImages +open PCSBCSSourceRootReferences PCSBCSSourceFrozenAccessor +open DuplexModeGame PublicMerkleLog + +def toy : Config := ⟨3,#[1,1],#[1,1],#[3,3],#[0,0]⟩ +def digest (n : Nat) : Digest32 := fun i => ⟨(n / 256^i.val)%256,Nat.mod_lt _ (by decide)⟩ +def recordedTree (extension : Bool) (missing : Option Nat) : + Nat → Nat → Digest32 × DuplexPublicSimulator.PublicLog + | 0, start => + let words : List K := if extension then + [UInt64.ofNat (100+start),200,300,400,500,600] + else [0,UInt64.ofNat (10+start)] + let bytes := ByteCodec.wordsBytes words + (hashBlake2s bytes,if missing == some start then [] else plan blake2sOracle bytes) + | height+1, start => + let left := recordedTree extension missing height start + let right := recordedTree extension missing height (start+2^height) + let bytes := List.ofFn (ByteCodec.pairBytes (left.1,right.1)) + (hashBlake2s bytes,left.2 ++ right.2 ++ plan blake2sOracle bytes) + +def firstTree := recordedTree false none 3 0 +def nextTree := recordedTree true none 2 0 +def saved : Record := + ⟨⟨3,1,1,1⟩,firstTree.1,⟨digest 0,fun _ => none,0,true,0,0⟩,[0,0,0],0⟩ +def firstRef : Reference := ⟨saved.root,initialShape saved.shape⟩ +def nextRef : Reference := ⟨nextTree.1,phaseShape toy 1⟩ +def rootFrozen : Frozen := freeze firstTree.2 firstRef.root firstRef.shape +def nextFrozen : Frozen := freeze nextTree.2 nextRef.root nextRef.shape +def initialCells : Array ImageCell := rootFrozen.cells +def registry : Captures := fun ref => + if ref = firstRef then some rootFrozen else if ref = nextRef then some nextFrozen else none + +def query : Coordinate toy := .query ⟨0,by decide⟩ +def boundary : Coordinate toy := .fold ⟨0,by decide⟩ ⟨0,by decide⟩ +def current : Coordinate toy := .query ⟨1,by decide⟩ +def tape : Tape toy := + (coordinates toy).symm fun q => match q with + | .query _ => (fun _ => (⟨219,20,21⟩ : E),0) + | _ => 0 +def past : WHIRFiatShamir.Prefix current := WHIRFiatShamir.Prefix.ofTape current tape + +def fields (q : Coordinate toy) : List E := + match q with + | .fold i j => [0,0] ++ if j.val+1 = toy.folds[i.val]! then + if i.val+1 < toy.folds.size then rootScalars nextRef.root + else List.replicate (2^remaining toy i.val) 0 + else [] + | .ood _ _ => [0,0,0] + | _ => [0,0] +def messages : List Pending := + ((List.range (position current+1)).map fun n => + (⟨if n = 0 then [] else fields (((schedule toy)[n-1]?).getD .initial), + match ((schedule toy)[n]?).getD .initial with + | .query _ => some (0,0) + | _ => none⟩ : Pending)).reverse + +def check (label : String) (ok : Bool) : IO Unit := do + unless ok do throw (IO.userError s!"frozen accessor: {label}") + IO.println s!"frozen accessor PASS: {label}" + +def smoke : IO Unit := do + check "immutable saved record and admitted source Pending prefix" + (decide saved.Valid && scheduledAdmissible toy messages) + check "query derivation reads all three E limbs, not only the base limb" + (deriveQueries 64 3 #[⟨3,7,11⟩] == some #[3,2^63+7,11]) + let a ← match build current saved registry messages past query ⟨[0,0],none⟩ with + | none => throw (IO.userError "query construction rejected") + | some a => pure a + IO.println s!"derived query order {a.queries.toList}" + check "derived repeated order [3,7,3], not full oracle and not current Raw" + (a.queries == #[3,7,3] && a.rows == #[#[E.ofK 13],#[E.ofK 17],#[E.ofK 13]]) + check "padded initial images retain compact live suffix only" + (a.rows.all (fun row => row.size == 1) && a.selectedStatus.all + (fun s => s.available && s.paddingValid)) + match inverseAt current saved registry messages past (position query) with + | some r => match r.reply with + | .query rows _ => check "source reply inverse integrates compact query rows" (rows == a.rows) + | _ => throw (IO.userError "query inverse tag") + | none => throw (IO.userError "query source inverse rejected") + let folded ← match inverseAt current saved registry messages past (position boundary) with + | some r => pure r + | none => throw (IO.userError "fold source inverse rejected") + match folded.reply with + | .fold _ (some next) residual => + check "announced next CV uses full next-phase E extension oracle" + (next.size == 4 && next[0]! == #[⟨100,200,300⟩,⟨400,500,600⟩] && residual.isEmpty) + | _ => throw (IO.userError "fold inverse normalization") + let tail : Coordinate toy := .tail ⟨0,by decide⟩ + let laterPast := WHIRFiatShamir.Prefix.ofTape tail tape + let laterMessages := (⟨[0,0],none⟩ : Pending) :: messages + let extension ← match build tail saved registry laterMessages laterPast current ⟨[0,0],none⟩ with + | some a => pure a + | none => throw (IO.userError "later-phase query construction rejected") + check "later-phase compact query rows decode consecutive E triples with repeated order" + (extension.queries == #[1,2,1] && extension.rows == + #[#[⟨101,200,300⟩,⟨400,500,600⟩],#[⟨102,200,300⟩,⟨400,500,600⟩], + #[⟨101,200,300⟩,⟨400,500,600⟩]]) + let missingNextTree := recordedTree true (some 0) 2 0 + let unavailableNext := freeze missingNextTree.2 nextRef.root nextRef.shape + let ghostNext ← match build current saved + (fun ref => if ref = nextRef then some unavailableNext else registry ref) + messages past boundary ⟨fields boundary,none⟩ with + | some a => pure a + | none => throw (IO.userError "unavailable full next oracle rejected") + check "full next oracle retains unavailable zero cells and explicit status" + (ghostNext.next[0]! == #[0,0] && ghostNext.nextStatus[0]! == ⟨false,false⟩) + check "missing initial capture rejects" + (build current saved (fun _ => none) messages past query ⟨[0,0],none⟩).isNone + check "missing announced next capture rejects" + (inverseAt current saved (fun ref => if ref = firstRef then some rootFrozen else none) + messages past (position boundary)).isNone + check "current and future query index rejects" + ((inverseAt current saved registry messages past (position current)).isNone && + (inverseAt current saved registry messages past 100).isNone) + let badCell := leafCell 2 1 [1,13] + let badCells := initialCells.set! 3 badCell + let badRoot : Frozen := ⟨firstRef.shape,[],badCells,compactTable badCells⟩ + check "selected invalid padding rejects instead of authenticated zero" + (build current saved (fun ref => if ref = firstRef then some badRoot else registry ref) + messages past query ⟨[0,0],none⟩).isNone + let unqueriedCells := initialCells.set! 0 (leafCell 2 1 [1,10]) + let unqueriedBad : Frozen := ⟨firstRef.shape,[],unqueriedCells,compactTable unqueriedCells⟩ + check "unqueried bad padding does not globally reject a ghost root" + (build current saved (fun ref => if ref = firstRef then some unqueriedBad else registry ref) + messages past query ⟨[0,0],none⟩).isSome + let missingFirstTree := recordedTree false (some 3) 3 0 + let partialRoot := freeze missingFirstTree.2 firstRef.root firstRef.shape + let ghostRows ← match build current saved + (fun ref => if ref = firstRef then some partialRoot else registry ref) + messages past query ⟨[0,0],none⟩ with + | none => throw (IO.userError "captured unavailable cell rejected") + | some a => pure a + check "captured unavailable repeated cells remain explicitly unauthenticated ghost zeros" + (ghostRows.rows == #[#[0],#[E.ofK 17],#[0]] && + ghostRows.selectedStatus == #[⟨false,false⟩,⟨true,true⟩,⟨false,false⟩]) + check "bad query lookup index rejects" (selectPhase 0 rootFrozen #[8]).isNone + check "malformed stored geometry rejects" + (lookup (fun _ => some {rootFrozen with raw := #[]}) firstRef).isNone + check "malformed extension limb count rejects" + (PCSBCSFrozenOracleRows.extensionOracle #[#[1,2]]).isNone + check "noncanonical announced digest rejects" + (build current saved registry messages past boundary ⟨[0,0,⟨0,0,1⟩,0],none⟩).isNone + let otherTape := CausalProbability.set current tape (fun _ => ⟨99,98,97⟩,E.ofK 96) + let otherPast := WHIRFiatShamir.Prefix.ofTape current otherTape + let same ← match build current saved registry messages otherPast query ⟨[0,0],none⟩ with + | none => throw (IO.userError "whole-current replacement rejected") + | some a => pure a + check "whole current query replacement leaves predecessor-derived rows unchanged" + (same.rows == a.rows && same.queries == a.queries) +end Whir.PCSBCSSourceFrozenAccessorSmoke + +def main : IO Unit := Whir.PCSBCSSourceFrozenAccessorSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceFrozenAccessorStructural.lean b/verification/whir/Whir/PCSBCSSourceFrozenAccessorStructural.lean new file mode 100644 index 000000000..5cfb22d60 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceFrozenAccessorStructural.lean @@ -0,0 +1,404 @@ +import Whir.PCSBCSSourceFrozenAccessor + +/-! Storage validity of the actual source freeze, independently of root honesty, +leaf availability, and padding acceptance. Ghost defaults remain unavailable. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceFrozenAccessorStructural +open Concrete FiatShamirGame PCSBCSMerkleRootCache PCSBCSMerkleLeafImages +open PCSBCSSourceRootReferences PCSBCSSourceFrozenAccessor +open PublicMerkleLog + +private instance : Inhabited ImageCell := ⟨defaultCell 0 0⟩ + +private theorem forIn_yields {α β : Type} (xs : List α) (b : β) + (f : α → β → Id (ForInStep β)) + (good : ∀ x ∈ xs, f x b = pure (.yield b)) : + forIn xs b f = (pure b : Id β) := by + induction xs with + | nil => rfl + | cons x xs ih => + rw [List.forIn_cons,good x (by simp)] + simp only [pure_bind] + exact ih (fun y hy => good y (by simp [hy])) + +private theorem scan_all (xs : List Nat) (p : Nat → Bool) (initial : Bool) : + (forIn xs initial (fun n valid => + if (!p n) = true then pure (.done false) else pure (.yield valid)) : Id Bool) = + if xs.all p then initial else false := by + induction xs with + | nil => rfl + | cons n xs ih => + rw [List.forIn_cons] + cases hp : p n with + | false => simp only [hp,Bool.not_false,↓reduceIte,pure_bind,List.all_cons,Bool.false_and]; rfl + | true => + simp only [hp,Bool.not_true,Bool.false_eq_true,↓reduceIte,pure_bind,List.all_cons,Bool.true_and] + exact ih + +private theorem zeroPrefix_iff (n : Nat) (row : List K) (bound : n ≤ row.length) : + zeroPrefix n row = true ↔ ∀ i < n, row[i]! = 0 := by + induction n generalizing row with + | zero => simp [zeroPrefix] + | succ n ih => + cases row with + | nil => simp at bound + | cons x xs => + have hn : n ≤ xs.length := by simpa using bound + rw [zeroPrefix,Bool.and_eq_true,beq_iff_eq,ih xs hn] + constructor + · rintro ⟨hx,hs⟩ i hi + cases i with + | zero => simpa using hx + | succ i => simpa using hs i (by omega) + · intro h + refine ⟨by simpa using h 0 (by omega),?_⟩ + intro i hi + simpa using h (i+1) (by omega) + +/-- The early-break imperative check is exactly the recursive source padding +check, not a supplied padding-validity certificate. -/ +theorem padding_loop_eq_zeroPrefix (image : Array K) (padding : Nat) + (bound : padding ≤ image.size) : + (forIn [:padding] true (fun n valid => + if (image[n]! != 0) = true then pure (.done false) else pure (.yield valid)) : Id Bool) = + zeroPrefix padding image.toList := by + simp only [Std.Legacy.Range.forIn_eq_forIn_range',Std.Legacy.Range.size, + Nat.sub_zero,Nat.add_sub_cancel,Nat.div_one,← List.range_eq_range'] + change (forIn (List.range padding) true (fun n valid => + if (!(image[n]! == 0)) = true then pure (.done false) else pure (.yield valid)) : Id Bool) = _ + rw [scan_all] + change (if (List.range padding).all (fun n => image[n]! == 0) then true else false) = _ + have boolIte (b : Bool) : (if b then true else false) = b := by cases b <;> rfl + rw [boolIte] + apply Bool.eq_iff_iff.mpr + rw [List.all_eq_true,zeroPrefix_iff padding image.toList (by simpa using bound)] + simp only [List.mem_range,beq_iff_eq] + have same (i : Nat) (hi : i < padding) : image.toList[i]! = image[i]! := by + rw [getElem!_pos image.toList i (by simp; omega),getElem!_pos image i (by omega)] + rfl + constructor + · intro h i hi; rw [same i hi]; exact h i hi + · intro h i hi; rw [← same i hi]; exact h i hi + +private theorem cellValid_of_fields (s : Shape) (cell : ImageCell) + (fits : s.occupied ≤ s.leafWords) + (imageSize : cell.image.size = s.leafWords) + (compactSize : cell.compact.size = s.occupied) + (suffix : ∀ n < s.occupied, cell.compact[n]! = cell.image[s.leafWords-s.occupied+n]!) + (available : cell.available = true → + cell.paddingValid = zeroPrefix (s.leafWords-s.occupied) cell.image.toList) + (missing : cell.available = false → cell.image.all (· == 0) = true ∧ + cell.paddingValid = false) : cellValid s cell = true := by + unfold cellValid + have guard : (decide (s.occupied > s.leafWords) || cell.image.size != s.leafWords || + cell.compact.size != s.occupied) = false := by simp [show ¬ s.occupied > s.leafWords by omega,imageSize,compactSize] + rw [guard] + simp only [Bool.false_eq_true,↓reduceIte] + have loop : (forIn [:s.occupied] (none, ()) (fun n (_ : Option Bool × Unit) => + if (cell.compact[n]! != cell.image[s.leafWords-s.occupied+n]!) = true then + pure (.done (some false, ())) else pure (.yield (none, ()))) : Id (Option Bool × Unit)) = + pure (none, ()) := by + simp only [Std.Legacy.Range.forIn_eq_forIn_range',Std.Legacy.Range.size, + Nat.sub_zero,Nat.add_sub_cancel,Nat.div_one,← List.range_eq_range'] + apply forIn_yields + intro n hn + have same := suffix n (List.mem_range.mp hn) + simp [same] + rw [loop] + simp only [pure_bind] + cases ha : cell.available with + | false => + simp only [Bool.false_eq_true,↓reduceIte] + change Bool.and (cell.image.all (· == 0)) (Bool.not cell.paddingValid) = true + simp only [(missing ha).1,(missing ha).2,Bool.not_false,Bool.and_self] + | true => + rw [padding_loop_eq_zeroPrefix cell.image (s.leafWords-s.occupied) (by omega)] + change (cell.paddingValid == zeroPrefix (s.leafWords-s.occupied) cell.image.toList) = true + simp only [available ha,beq_self_eq_true] + +/-- Defaults have rectangular zero storage but neither availability nor padding +authentication. In particular structural validity does not upgrade their status. -/ +theorem defaultCell_valid (s : Shape) (fits : s.occupied ≤ s.leafWords) : + cellValid s (defaultCell s.leafWords s.occupied) = true := by + apply cellValid_of_fields s _ fits + · simp [defaultCell] + · simp only [defaultCell,Array.size_replicate] + omega + · intro n hn + have compact : s.leafWords-(s.leafWords-s.occupied) = s.occupied := by omega + simp [defaultCell,compact,getElem!_pos,hn,show s.leafWords-s.occupied+n < s.leafWords by omega] + · simp [defaultCell] + · intro _ + refine ⟨?_,rfl⟩ + change (Array.replicate s.leafWords (0 : K)).all (· == 0) = true + rw [Array.all_eq_true] + intro n hn + simp + +theorem leafCell_valid (s : Shape) (fits : s.occupied ≤ s.leafWords) (row : List K) : + cellValid s (leafCell s.leafWords s.occupied row) = true := by + unfold leafCell + split + next width => + apply cellValid_of_fields s _ fits + · simpa using width + · simp only [List.size_toArray,List.length_drop,width] + omega + · intro n hn + have dropped : n < (row.drop (s.leafWords-s.occupied)).length := by + simp only [List.length_drop,width]; omega + have full : s.leafWords-s.occupied+n < row.length := by omega + rw [getElem!_pos (row.drop (s.leafWords-s.occupied)).toArray n (by simpa using dropped), + getElem!_pos row.toArray (s.leafWords-s.occupied+n) (by simpa using full)] + simp only [List.getElem_toArray,List.getElem_drop] + · simp [fits] + · simp + next => exact defaultCell_valid s fits + +private theorem cellsSpec_valid (s : Shape) (fits : s.occupied ≤ s.leafWords) + (height : Nat) (tree : MerkleQueryLogExtraction.Tree) : + ∀ cell ∈ cellsSpec s.leafWords s.occupied height tree, cellValid s cell = true := by + induction height generalizing tree with + | zero => + cases tree with + | absent => simpa [cellsSpec] using defaultCell_valid s fits + | leaf row => simpa [cellsSpec] using leafCell_valid s fits row + | branch l r => simpa [cellsSpec] using defaultCell_valid s fits + | succ h ih => + cases tree with + | absent => simpa [cellsSpec] using defaultCell_valid s fits + | leaf row => simpa [cellsSpec] using defaultCell_valid s fits + | branch l r => + intro cell member + rcases List.mem_append.mp member with hl | hr + · exact ih l cell hl + · exact ih r cell hr + +theorem sourceCells_valid (log : PublicLog) (root : Digest32) (s : Shape) + (fits : s.occupied ≤ s.leafWords) : + ∀ cell ∈ (sourceCells log root s.height s.leafWords s.occupied).toList, + cellValid s cell = true := by + rw [sourceCells_spec] + exact cellsSpec_valid s fits s.height _ + +theorem freeze_raw (log : PublicLog) (root : Digest32) (s : Shape) : + (freeze log root s).raw = compactTable (freeze log root s).cells := rfl + +/-- No height bound, honest-root premise, all-leaf availability, or all-padding +validity is required by these Nat-indexed storage checks. -/ +theorem freeze_structurallyValid (log : PublicLog) (ref : Reference) + (fits : ref.shape.occupied ≤ ref.shape.leafWords) : + structurallyValid ref (freeze log ref.root ref.shape) = true := by + change structurallyValid ref + ⟨ref.shape,log,sourceCells log ref.root ref.shape.height ref.shape.leafWords ref.shape.occupied, + compactTable (sourceCells log ref.root ref.shape.height ref.shape.leafWords ref.shape.occupied)⟩ = true + unfold structurallyValid + dsimp +instances only [sameShape,compactTable] + simp +instances only [beq_self_eq_true,Bool.true_and,decide_eq_true fits,sourceCells_size,Array.size_map] + simp only [Std.Legacy.Range.forIn_eq_forIn_range',Std.Legacy.Range.size, + Nat.sub_zero,Nat.add_sub_cancel,Nat.div_one,← List.range_eq_range'] + rw [forIn_yields] + · rfl + · intro n hn + have inside : n < (sourceCells log ref.root ref.shape.height ref.shape.leafWords ref.shape.occupied).size := by + simpa only [sourceCells_size,List.mem_range] using hn + rw [Array.getElem?_eq_getElem inside] + have valid := sourceCells_valid log ref.root ref.shape fits + ((sourceCells log ref.root ref.shape.height ref.shape.leafWords ref.shape.occupied)[n]) + (Array.mem_toList_iff.mpr (Array.getElem_mem inside)) + simp [valid,Array.getElem?_map,Array.getElem?_eq_getElem inside] + +theorem lookup_freeze (registry : Captures) (log : PublicLog) (ref : Reference) + (fits : ref.shape.occupied ≤ ref.shape.leafWords) + (captured : registry ref = some (freeze log ref.root ref.shape)) : + lookup registry ref = some (freeze log ref.root ref.shape) := by + simp [PCSBCSSourceFrozenAccessor.lookup,captured,freeze_structurallyValid log ref fits] + +theorem freeze_shape_exact (log : PublicLog) (root : Digest32) (s : Shape) + (fits : s.occupied ≤ s.leafWords) : + (freeze log root s).cells.size = 2^s.height ∧ + (freeze log root s).raw.size = (freeze log root s).cells.size ∧ + ∀ row ∈ (freeze log root s).raw.toList, row.size = s.occupied := by + have shape := PCSBCSMerkleRootCache.freeze_shape log root s fits + exact ⟨sourceCells_size log root s.height s.leafWords s.occupied, + by simpa only [freeze,sourceCells_size] using shape.1,shape.2⟩ + +theorem freeze_raw_eq_source_suffixes (log : PublicLog) (root : Digest32) (s : Shape) : + (freeze log root s).raw = + (PCSBCSMerkleQueryLog.rawRoot0 log root s.height s.leafWords).map + (fun image => (image.toList.drop (s.leafWords-s.occupied)).toArray) := + compactTable_eq_drop log root s.height s.leafWords s.occupied + +theorem freeze_unfitting_rejects (log : PublicLog) (ref : Reference) + (unfitting : ¬ ref.shape.occupied ≤ ref.shape.leafWords) : + structurallyValid ref (freeze log ref.root ref.shape) = false := by + simp [structurallyValid,unfitting] + +theorem defaultCell_status (leafWords occupied : Nat) : + (defaultCell leafWords occupied).available = false ∧ + (defaultCell leafWords occupied).paddingValid = false := ⟨rfl,rfl⟩ + +private theorem cellsSpec_unavailable (s : Shape) (height : Nat) + (tree : MerkleQueryLogExtraction.Tree) : + ∀ cell ∈ cellsSpec s.leafWords s.occupied height tree, + cell.available = false → cell = defaultCell s.leafWords s.occupied := by + induction height generalizing tree with + | zero => + cases tree with + | absent => simp [cellsSpec] + | branch l r => simp [cellsSpec] + | leaf row => + intro cell member unavailable + simp only [cellsSpec,List.mem_singleton] at member + subst cell + unfold leafCell at * + split at unavailable + · contradiction + · rename_i wrongWidth + simp only [ite_eq_right wrongWidth] + | succ h ih => + cases tree with + | absent => simp [cellsSpec] + | leaf row => simp [cellsSpec] + | branch l r => + intro cell member unavailable + rcases List.mem_append.mp member with hl | hr + · exact ih l cell hl unavailable + · exact ih r cell hr unavailable + +/-- An absent or malformed reconstructed leaf is the literal default, not an +available zero leaf or an authenticated padding image. -/ +theorem freeze_unavailable_default (log : PublicLog) (root : Digest32) (s : Shape) + (cell : ImageCell) (member : cell ∈ (freeze log root s).cells.toList) + (unavailable : cell.available = false) : + cell = defaultCell s.leafWords s.occupied := by + change cell ∈ (sourceCells log root s.height s.leafWords s.occupied).toList at member + rw [sourceCells_spec] at member + exact cellsSpec_unavailable s s.height _ cell member unavailable + +private theorem array_mapM_some {α β : Type} (xs : Array α) + (f : α → Option β) (g : α → β) (same : ∀ x ∈ xs, f x = some (g x)) : + xs.mapM f = some (xs.map g) := by + rw [Array.mapM_eq_mapM_toList] + have listSame : xs.toList.mapM f = some (xs.toList.map g) := by + have general (ys : List α) (good : ∀ x ∈ ys, f x = some (g x)) : + ys.mapM f = some (ys.map g) := by + induction ys with + | nil => rfl + | cons x ys ih => + simp only [List.mapM_cons,good x (by simp),List.map_cons] + rw [ih (fun y hy => good y (by simp [hy]))] + rfl + exact general xs.toList (fun x hx => same x (Array.mem_toList_iff.mp hx)) + rw [listSame] + change some (xs.toList.map g).toArray = some (xs.map g) + congr 1 + apply Array.toList_inj.mp + simp + +open Protocol CausalGame PCSBCSFrozenOracleRows + +/-- The only phase codec condition is base phase or a multiple of three live +words for extension limbs. Neither availability nor padding is a codec premise. -/ +theorem frozenOracle_freeze (log : PublicLog) (root : Digest32) (s : Shape) + (fits : s.occupied ≤ s.leafWords) (phase : Nat) + (codecShape : phase = 0 ∨ s.occupied % 3 = 0) : + ∃ oracle, frozenOracle phase (freeze log root s) = some oracle ∧ + oracle.size = (freeze log root s).cells.size := by + by_cases base : phase = 0 + · refine ⟨liftRoot (freeze log root s).raw,by simp [frozenOracle,base],?_⟩ + simpa only [liftRoot,Array.size_map] using (freeze_shape_exact log root s fits).2.1 + · have divisible : s.occupied % 3 = 0 := codecShape.resolve_left base + let decode := fun words : Array K => Array.ofFn fun i : Fin (words.size/3) => + (⟨words[3*i.val]!,words[3*i.val+1]!,words[3*i.val+2]!⟩ : E) + have decoded : (freeze log root s).raw.mapM extensionRow = + some ((freeze log root s).raw.map decode) := by + apply array_mapM_some + intro row member + have width := (freeze_shape_exact log root s fits).2.2 row (Array.mem_toList_iff.mpr member) + simp only [extensionRow,width,divisible,↓reduceIte] + rfl + refine ⟨(freeze log root s).raw.map decode,?_,?_⟩ + · simp only [frozenOracle,base,↓reduceIte,extensionOracle,decoded] + · simpa only [Array.size_map] using (freeze_shape_exact log root s fits).2.1 + +/-- Once the actual phase codec succeeds, checked selection rejects exactly a +queried available cell whose padding flag is false. Unavailable cells succeed +as ghost data. Bounds and representation are local source geometry, not root +honesty or transport authentication. -/ +theorem selectPhase_flags (phase : Nat) (f : Frozen) (qs : Array Nat) + (oracle : Oracle) (decoded : frozenOracle phase f = some oracle) + (size : oracle.size = f.cells.size) (bounds : ∀ n ∈ qs, n < f.cells.size) : + (selectPhase phase f qs).isSome = + qs.all (fun n => !f.cells[n]!.available || f.cells[n]!.paddingValid) := by + have rows : queryRows oracle qs = some (qs.map (fun n => oracle[n]!)) := by + apply array_mapM_some + intro n hn + have inside : n < oracle.size := by rw [size]; exact bounds n hn + simp [Array.getElem?_eq_getElem inside,getElem!_pos oracle n inside] + have cells : qs.mapM (fun n => f.cells[n]?) = some (qs.map (fun n => f.cells[n]!)) := by + apply array_mapM_some + intro n hn + simp [Array.getElem?_eq_getElem (bounds n hn),getElem!_pos f.cells n (bounds n hn)] + unfold selectPhase + rw [decoded] + dsimp only [Bind.bind,Option.bind] + rw [rows] + dsimp only [Bind.bind,Option.bind] + rw [cells] + dsimp only [Bind.bind,Option.bind] + have flags : (qs.map (fun n => f.cells[n]!)).all + (fun cell => !cell.available || cell.paddingValid) = + qs.all (fun n => !f.cells[n]!.available || f.cells[n]!.paddingValid) := by + simp only [← Array.all_toList,Array.toList_map,List.all_map] + rfl + rw [flags] + cases qs.all (fun n => !f.cells[n]!.available || f.cells[n]!.paddingValid) <;> rfl + +theorem selectPhase_freeze_flags (log : PublicLog) (root : Digest32) (s : Shape) + (fits : s.occupied ≤ s.leafWords) (phase : Nat) (codecShape : phase = 0 ∨ s.occupied % 3 = 0) + (qs : Array Nat) (bounds : ∀ n ∈ qs, n < 2^s.height) : + (selectPhase phase (freeze log root s) qs).isSome = + qs.all (fun n => !(freeze log root s).cells[n]!.available || + (freeze log root s).cells[n]!.paddingValid) := by + obtain ⟨oracle,decoded,size⟩ := frozenOracle_freeze log root s fits phase codecShape + apply selectPhase_flags phase _ qs oracle decoded size + simpa only [freeze,sourceCells_size] using bounds + +theorem selectPhase_freeze_success_iff (log : PublicLog) (root : Digest32) (s : Shape) + (fits : s.occupied ≤ s.leafWords) (phase : Nat) (codecShape : phase = 0 ∨ s.occupied % 3 = 0) + (qs : Array Nat) (bounds : ∀ n ∈ qs, n < 2^s.height) : + (selectPhase phase (freeze log root s) qs).isSome = true ↔ + ∀ n ∈ qs, (freeze log root s).cells[n]!.available = true → + (freeze log root s).cells[n]!.paddingValid = true := by + rw [selectPhase_freeze_flags log root s fits phase codecShape qs bounds,Array.all_eq_true'] + constructor + · intro h n hn available + have flag := h n hn + simpa only [available,Bool.not_true,Bool.false_or] using flag + · intro h n hn + cases available : (freeze log root s).cells[n]!.available with + | false => simp only [Bool.not_false,Bool.true_or] + | true => simp only [Bool.not_true,Bool.false_or,h n hn available] + +theorem selectPhase_freeze_reject_iff (log : PublicLog) (root : Digest32) (s : Shape) + (fits : s.occupied ≤ s.leafWords) (phase : Nat) (codecShape : phase = 0 ∨ s.occupied % 3 = 0) + (qs : Array Nat) (bounds : ∀ n ∈ qs, n < 2^s.height) : + selectPhase phase (freeze log root s) qs = none ↔ + ∃ n ∈ qs, (freeze log root s).cells[n]!.available = true ∧ + (freeze log root s).cells[n]!.paddingValid = false := by + rw [← Option.isNone_iff_eq_none,← Option.isSome_eq_false_iff, + selectPhase_freeze_flags log root s fits phase codecShape qs bounds, + Array.all_eq_false'] + simp + +#print axioms padding_loop_eq_zeroPrefix +#print axioms defaultCell_valid +#print axioms leafCell_valid +#print axioms freeze_structurallyValid +#print axioms lookup_freeze +#print axioms freeze_unavailable_default +#print axioms frozenOracle_freeze +#print axioms selectPhase_freeze_success_iff +#print axioms selectPhase_freeze_reject_iff +end Whir.PCSBCSSourceFrozenAccessorStructural diff --git a/verification/whir/Whir/PCSBCSSourceFrozenAccessorStructuralSmoke.lean b/verification/whir/Whir/PCSBCSSourceFrozenAccessorStructuralSmoke.lean new file mode 100644 index 000000000..fa98e4e53 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceFrozenAccessorStructuralSmoke.lean @@ -0,0 +1,104 @@ +import Whir.PCSBCSSourceFrozenAccessorStructural + +/-! Real BLAKE2s records are frozen unchanged. Invalid padding is produced by +hashed source images, never by mutating the frozen registry after extraction. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceFrozenAccessorStructuralSmoke +open Concrete Protocol CausalGame FiatShamirGame PCSBCSMerkleRootCache +open PCSBCSMerkleLeafImages PCSBCSSourceRootReferences PCSBCSSourceFrozenAccessor +open DuplexModeGame PublicMerkleLog + +private def recordedTree (extension : Bool) (missing badPadding malformed : Option Nat) : + Nat → Nat → Digest32 × DuplexPublicSimulator.PublicLog + | 0, start => + let padding : K := if badPadding == some start then 9 else 0 + let live : K := UInt64.ofNat (10+start) + let words : List K := if malformed == some start then [44] else + if extension then [padding,live,20,30] else [padding,live] + let bytes := ByteCodec.wordsBytes words + (hashBlake2s bytes,if missing == some start then [] else plan blake2sOracle bytes) + | height+1, start => + let left := recordedTree extension missing badPadding malformed height start + let right := recordedTree extension missing badPadding malformed height (start+2^height) + let bytes := List.ofFn (ByteCodec.pairBytes (left.1,right.1)) + (hashBlake2s bytes,left.2 ++ right.2 ++ plan blake2sOracle bytes) + +private def check (label : String) (ok : Bool) : IO Unit := do + unless ok do throw (IO.userError s!"source freeze structural: {label}") + IO.println s!"source freeze structural PASS: {label}" + +private def inspect (f : Frozen) (index : Nat) : Option Status := f.cells[index]?.map status + +private def requireSelection (phase : Nat) (f : Frozen) (qs : Array Nat) : IO Selected := + match selectPhase phase f qs with + | none => throw (IO.userError "source freeze structural: selection unexpectedly rejected") + | some result => pure result + +def smoke : IO Unit := do + let s : Shape := ⟨1,2,1⟩ + let padded := recordedTree false none none none 1 0 + let ref : Reference := ⟨padded.1,s⟩ + let f := freeze padded.2 ref.root ref.shape + check "actual padded source freeze passes structural and registry lookup checks" + (structurallyValid ref f && (PCSBCSSourceFrozenAccessor.lookup (fun _ => some f) ref).isSome) + check "source compact images preserve literal suffixes and rectangular sizes" + (f.cells.size == 2 && f.raw == #[#[10],#[11]] && + f.raw == compactTable f.cells && f.raw.all (fun row => row.size == 1)) + let selected ← requireSelection 0 f #[1,0,1] + check "padded repeated query traversal retains source order and flags" + (selected.rows == #[#[E.ofK 11],#[E.ofK 10],#[E.ofK 11]] && + selected.cells.map status == #[⟨true,true⟩,⟨true,true⟩,⟨true,true⟩]) + let partialTree := recordedTree false (some 1) none none 1 0 + let partialRef : Reference := ⟨partialTree.1,s⟩ + let partialFrozen := freeze partialTree.2 partialRef.root s + check "actual missing leaf passes structural lookup without upgrading ghost status" + (structurallyValid partialRef partialFrozen && + (PCSBCSSourceFrozenAccessor.lookup (fun _ => some partialFrozen) partialRef).isSome && + inspect partialFrozen 1 == some ⟨false,false⟩ && partialFrozen.raw[1]! == #[0]) + let ghost ← requireSelection 0 partialFrozen #[1,0,1] + check "selected unavailable duplicates remain zero and explicitly unauthenticated" + (ghost.rows == #[#[0],#[E.ofK 10],#[0]] && + ghost.cells.map status == #[⟨false,false⟩,⟨true,true⟩,⟨false,false⟩]) + let bad := recordedTree false none (some 0) none 1 0 + let badRef : Reference := ⟨bad.1,s⟩ + let badFrozen := freeze bad.2 badRef.root s + check "real hashed invalid padding remains structurally valid source storage" + (structurallyValid badRef badFrozen && + (PCSBCSSourceFrozenAccessor.lookup (fun _ => some badFrozen) badRef).isSome && + inspect badFrozen 0 == some ⟨true,false⟩ && badFrozen.raw[0]! == #[10]) + check "only selected available bad padding rejects" + ((selectPhase 0 badFrozen #[1,0,1]).isNone && (selectPhase 0 badFrozen #[1,1]).isSome) + let malformed := recordedTree false none none (some 0) 1 0 + let malformedRef : Reference := ⟨malformed.1,s⟩ + let malformedFrozen := freeze malformed.2 malformedRef.root s + check "real wrong-width source leaf becomes rectangular explicitly unavailable default" + (structurallyValid malformedRef malformedFrozen && + inspect malformedFrozen 0 == some ⟨false,false⟩ && malformedFrozen.raw[0]! == #[0] && + (selectPhase 0 malformedFrozen #[0,1]).isSome) + let absent := freeze [] padded.1 s + check "wholly absent root is structural ghost storage rather than authenticated data" + (structurallyValid ref absent && absent.raw == #[#[0],#[0]] && + inspect absent 0 == some ⟨false,false⟩ && inspect absent 1 == some ⟨false,false⟩ && + (selectPhase 0 absent #[0,1]).isSome) + check "queried out-of-range index rejects" (selectPhase 0 f #[2]).isNone + let extension := recordedTree true (some 1) (some 0) none 1 0 + let extensionShape : Shape := ⟨1,4,3⟩ + let extensionRef : Reference := ⟨extension.1,extensionShape⟩ + let extensionFrozen := freeze extension.2 extensionRef.root extensionShape + check "extension source freeze accepts coexistence of invalid padding and missing cells" + (structurallyValid extensionRef extensionFrozen && extensionFrozen.raw == #[#[10,20,30],#[0,0,0]]) + let extensionGhost ← requireSelection 1 extensionFrozen #[1,1] + check "extension unavailable words decode into zero E with explicit ghost flags" + (extensionGhost.rows == #[#[0],#[0]] && + extensionGhost.cells.map status == #[⟨false,false⟩,⟨false,false⟩] && + (selectPhase 1 extensionFrozen #[0]).isNone) + let unfit : Reference := ⟨padded.1,⟨1,2,3⟩⟩ + check "occupied width exceeding image width is genuinely rejected" + (!structurallyValid unfit (freeze padded.2 unfit.root unfit.shape)) + let noPadding : Reference := ⟨padded.1,⟨1,2,2⟩⟩ + check "zero-length padding and fully occupied source image pass construction checks" + (structurallyValid noPadding (freeze padded.2 noPadding.root noPadding.shape)) + +end Whir.PCSBCSSourceFrozenAccessorStructuralSmoke + +def main : IO Unit := Whir.PCSBCSSourceFrozenAccessorStructuralSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceFrozenReplies.lean b/verification/whir/Whir/PCSBCSSourceFrozenReplies.lean new file mode 100644 index 000000000..406a92d2f --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceFrozenReplies.lean @@ -0,0 +1,151 @@ +import Whir.PCSBCSSourceFrozenAccessor + +/-! Full strict source prefixes use a separately validated accessor for each +query/root role. Chronological Pending storage and schedule arrays are built +once; there is no current/future reply padding and no oracle warming. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceFrozenReplies +open Concrete Protocol CausalGame CausalProbability WHIRHistory FiatShamirGame +open PCSBCSSourceReplyInversion PCSBCSSourceFrozenAccessor AnchoredHeaderCodec + +variable {c : Config} + +def inverseIndexed (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (stages : Array (Coordinate c)) (chronological : Array Pending) (n : Nat) : + Option Inverted := do + let q ← stages[n]? + let m ← chronological[n+1]? + let accessor ← build current saved registry messages past q m + inverse (oracles accessor) q (stage q) m + +def collect (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (stages : Array (Coordinate c)) (chronological : Array Pending) : + Nat → Nat → Array Reply → Option (Array Reply) + | 0, _, out => some out + | count+1, n, out => do + let reply ← inverseIndexed current saved registry messages past stages chronological n + collect current saved registry messages past stages chronological count (n+1) (out.push reply.reply) + +def replies (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) : Option (Array Reply) := + collect current saved registry messages past (schedule c).toArray messages.reverse.toArray + (position current) 0 #[] + +/-- The cached-array inverse is literally the validated source accessor path. -/ +theorem inverseIndexed_eq (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) (n : Nat) : + inverseIndexed current saved registry messages past (schedule c).toArray + messages.reverse.toArray n = + PCSBCSSourceFrozenAccessor.inverseAt current saved registry messages past n := by + simp only [inverseIndexed,PCSBCSSourceFrozenAccessor.inverseAt,List.getElem?_toArray] + +/-- A malformed earlier reply fails the actual whole-prefix constructor. -/ +theorem collect_rejects_first (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (stages : Array (Coordinate c)) (chronological : Array Pending) (count n : Nat) + (out : Array Reply) + (missing : inverseIndexed current saved registry messages past stages chronological n = none) : + collect current saved registry messages past stages chronological (count+1) n out = none := by + simp only [collect,missing] + rfl + +/-- Successful assembly retains exactly the requested earlier reply count. -/ +theorem collect_size (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (stages : Array (Coordinate c)) (chronological : Array Pending) (count n : Nat) + (out result : Array Reply) + (collected : collect current saved registry messages past stages chronological count n out = some result) : + result.size = out.size+count := by + induction count generalizing n out with + | zero => cases Option.some.inj collected; omega + | succ count ih => + simp only [collect] at collected + obtain ⟨reply,_,rest⟩ := Option.bind_eq_some_iff.mp collected + have size := ih (n+1) (out.push reply.reply) rest + simp only [Array.size_push] at size + omega + +theorem replies_size (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (result : Array Reply) (parsed : replies current saved registry messages past = some result) : + result.size = position current := by + have size := collect_size current saved registry messages past (schedule c).toArray + messages.reverse.toArray (position current) 0 #[] result parsed + simpa only [Array.size_empty,Nat.zero_add] using size + +/-- Assembly never replaces an already retained reply. -/ +theorem collect_preserves (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (stages : Array (Coordinate c)) (chronological : Array Pending) (count n : Nat) + (out result : Array Reply) + (parsed : collect current saved registry messages past stages chronological count n out = some result) + (j : Nat) (earlier : j < out.size) : result[j]? = out[j]? := by + induction count generalizing n out result with + | zero => + simp only [collect] at parsed + cases Option.some.inj parsed + rfl + | succ count ih => + cases hi : inverseIndexed current saved registry messages past stages chronological n with + | none => simp [collect,hi] at parsed + | some reply => + have continued : collect current saved registry messages past stages chronological count + (n+1) (out.push reply.reply) = some result := by + simpa [collect,hi] using parsed + have indexBound : j < (out.push reply.reply).size := by + simp only [Array.size_push] + omega + rw [ih (n+1) (out.push reply.reply) result continued indexBound] + simp [Array.getElem?_push,Nat.ne_of_lt earlier] + +/-- Every appended reply is the checked inverse at its chronological protocol +index, including repeated query positions. -/ +theorem collect_index (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (stages : Array (Coordinate c)) (chronological : Array Pending) (count n : Nat) + (out result : Array Reply) + (parsed : collect current saved registry messages past stages chronological count n out = some result) + (j : Nat) (earlier : j < count) : + (inverseIndexed current saved registry messages past stages chronological (n+j)).map Inverted.reply = + result[out.size+j]? := by + induction count generalizing n out result j with + | zero => omega + | succ count ih => + cases hi : inverseIndexed current saved registry messages past stages chronological n with + | none => simp [collect,hi] at parsed + | some reply => + have continued : collect current saved registry messages past stages chronological count + (n+1) (out.push reply.reply) = some result := by + simpa [collect,hi] using parsed + cases j with + | zero => + simp only [Nat.add_zero,hi,Option.map_some] + rw [collect_preserves current saved registry messages past stages chronological count + (n+1) (out.push reply.reply) result continued out.size (by simp)] + simp + | succ j => + have before : j < count := by omega + simpa only [Array.size_push,Nat.add_assoc,Nat.add_comm,Nat.add_left_comm] using + ih (n+1) (out.push reply.reply) result continued j before + +theorem replies_index (current : Coordinate c) (saved : Record) (registry : Captures) + (messages : List Pending) (past : WHIRFiatShamir.Prefix current) + (result : Array Reply) (parsed : replies current saved registry messages past = some result) + (j : Nat) (earlier : j < position current) : + (PCSBCSSourceFrozenAccessor.inverseAt current saved registry messages past j).map Inverted.reply = + result[j]? := by + have index := collect_index current saved registry messages past (schedule c).toArray + messages.reverse.toArray (position current) 0 #[] result parsed j earlier + simpa only [Array.size_empty,Nat.zero_add,inverseIndexed_eq] using index + +#print axioms collect_preserves +#print axioms collect_index +#print axioms replies_index + +#print axioms inverseIndexed_eq +#print axioms collect_rejects_first +#print axioms collect_size +#print axioms replies_size +end Whir.PCSBCSSourceFrozenReplies diff --git a/verification/whir/Whir/PCSBCSSourceFrozenRepliesSmoke.lean b/verification/whir/Whir/PCSBCSSourceFrozenRepliesSmoke.lean new file mode 100644 index 000000000..f13b101d3 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceFrozenRepliesSmoke.lean @@ -0,0 +1,40 @@ +import Whir.PCSBCSSourceFrozenReplies +import Whir.PCSBCSSourceFrozenAccessorSmoke + +set_option autoImplicit false +namespace Whir.PCSBCSSourceFrozenRepliesSmoke +open Concrete Protocol CausalGame CausalProbability WHIRHistory +open PCSBCSSourceFrozenAccessorSmoke + +def smoke : IO Unit := do + let answers ← match PCSBCSSourceFrozenReplies.replies current saved registry messages past with + | none => throw (IO.userError "checked chronological prefix rejected") + | some answers => pure answers + check "checked assembly covers exactly the strict earlier protocol prefix" + (answers.size == position current) + match answers[position query]? with + | some (.query rows _) => + check "assembly retains repeated source query order" + (rows == #[#[E.ofK 13],#[E.ofK 17],#[E.ofK 13]]) + | _ => throw (IO.userError "assembled query position/tag") + match answers[position boundary]? with + | some (.fold _ (some next) residual) => + check "assembly retains full announced next oracle" + (next[0]! == #[⟨100,200,300⟩,⟨400,500,600⟩] && residual.isEmpty) + | _ => throw (IO.userError "assembled boundary position/tag") + check "assembly rejects a missing referenced capture" + (PCSBCSSourceFrozenReplies.replies current saved (fun _ => none) messages past).isNone + let replacedTape := CausalProbability.set current tape (fun _ => ⟨99,98,97⟩,E.ofK 96) + let replacedPast := WHIRFiatShamir.Prefix.ofTape current replacedTape + let changed ← match PCSBCSSourceFrozenReplies.replies current saved registry messages replacedPast with + | none => throw (IO.userError "whole current replacement rejected prefix") + | some answers => pure answers + match changed[position query]? with + | some (.query rows _) => + check "whole current packet cannot warm predecessor queries" + (rows == #[#[E.ofK 13],#[E.ofK 17],#[E.ofK 13]]) + | _ => throw (IO.userError "replacement query position/tag") + +end Whir.PCSBCSSourceFrozenRepliesSmoke + +#eval Whir.PCSBCSSourceFrozenRepliesSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceKnowledgeComposition.lean b/verification/whir/Whir/PCSBCSSourceKnowledgeComposition.lean new file mode 100644 index 000000000..bdb472306 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceKnowledgeComposition.lean @@ -0,0 +1,107 @@ +import Whir.PCSBCSSourceKnowledgeGame +import Whir.PCSBCSActualMerkleBound +import Whir.PublicCompressionProgram +import Whir.WHIRObservableSecurity + +/-! Composition for the literal full-path source query budget. Native/source +refinement and the event reduction are explicit codec/trace obligations, not +assumed soundness or a supplied bad-event probability. The Merkle probability +is derived from the actual physical compiler with its causal target scanner. +This is a conditional PCS-only random-compression endpoint, not deployed +BLAKE2s knowledge security or a whole-system numerical security level. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceKnowledgeComposition +open Concrete FiatShamirGame DuplexModeGame DuplexFraming DuplexPublicSimulator +open TypedOracleCompiler PublicCompressionProgram PCSBCSMerkleQueryLog +open PCSBCSSourceKnowledgeGame + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +variable (registry : AnchoredHeaderRoots.Public) + +noncomputable def merkleProbability {Coins R : Type} [Fintype Coins] + (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) : ℚ := + average fun coins => average fun C : PrimitiveOracle => + if PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p Q boundary registry) [] + (PublicCompressionProgram.primitiveLog C iv (adversary coins) Q (counted coins)) then 1 else 0 + +theorem merkle_probability_bound {Coins R : Type} [Fintype Coins] [Nonempty Coins] + (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) : + merkleProbability (p := p) (iv := iv) (boundary := boundary) registry + adversary counted ≤ ((Q : ℚ)^3+3*(Q : ℚ)^2-2*(Q : ℚ))/2^256 := by + unfold merkleProbability + have each (coins : Coins) := PublicMerkleProbability.random_compression_bound + (PCSBCSSourcePrimitiveRootBudget.targets p Q boundary registry) Q (Q*(Q+1)) + (PCSBCSSourcePrimitiveRootBudget.targets_cap p Q boundary registry) + (PublicCompressionProgram.compile iv (adversary coins) Q (counted coins)) + simp only [PublicMerkleProbability.alarm_trace] at each + have bound := average_mono each + rw [average_const,PCSBCSActualMerkleBound.exact_merkle_loss] at bound + exact bound + +/-- A pointwise reduction to the shared primitive alarm on the complete physical +trace, including collisions unrelated to a frozen opening and all verifier calls. -/ +def Reduction {Coins R : Type} (adversary : Coins → Program R) + (counted : ∀ coins, Counts Q (adversary coins)) + (failure good : View R → Bool) : Prop := + ∀ C coins, failure (runReal C iv (adversary coins)).view = true → + good (runReal C iv (adversary coins)).view = true ∨ + PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p Q boundary registry) [] + (PublicCompressionProgram.primitiveLog C iv (adversary coins) Q (counted coins)) = true + +private theorem real_union_bound {Coins R : Type} [Fintype Coins] [Nonempty Coins] + (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) + (failure good : View R → Bool) + (reduction : Reduction (p := p) (iv := iv) (boundary := boundary) registry + adversary counted failure good) : + realProbability iv adversary failure ≤ realProbability iv adversary good + + merkleProbability (p := p) (iv := iv) (boundary := boundary) registry + adversary counted := by + classical + unfold realProbability + rw [distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins)), + distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins))] + simp only [WHIRObservableSecurity.average_product] + rw [RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins), + RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins)] + unfold merkleProbability + rw [← average_add] + apply average_mono + intro coins + rw [← average_add] + apply average_mono + intro C + by_cases failed : failure (runReal C iv (adversary coins)).view = true + · rcases reduction C coins failed with raw | merkle + · simp only [failed,raw,↓reduceIte] + split <;> norm_num + · simp only [failed,merkle,↓reduceIte] + split <;> norm_num + · simp only [failed,Bool.false_eq_true,↓reduceIte] + split <;> split <;> norm_num + +/-- Explicit separate q56 RBR, 256-bit coupling, and 256-bit Merkle terms. +Refinement must be proved for the actual supported source observer before this +can be read as verifier acceptance/extraction failure. -/ +theorem random_compression_failure_probability {Coins R : Type} + [Fintype Coins] [Nonempty Coins] (layout : WHIRCallerClaims.CallerLayout) + (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) + (failure good : View R → Bool) + (refines : ∀ coins, ObserverRefines (p := p) (iv := iv) (boundary := boundary) + layout (adversary coins) (counted coins) good) + (reduction : Reduction (p := p) (iv := iv) (boundary := boundary) registry + adversary counted failure good) : + realProbability iv adversary failure ≤ + (Q : ℚ)*PCSRoundByRoundKnowledge.rbrError + duplexModeLoss Q + + ((Q : ℚ)^3+3*(Q : ℚ)^2-2*(Q : ℚ))/2^256 := by + have union := real_union_bound registry + adversary counted failure good reduction + have raw := random_compression_observer_probability layout adversary counted good refines + have merkle := merkle_probability_bound (p := p) (iv := iv) (boundary := boundary) + registry adversary counted + linarith + +#print axioms merkle_probability_bound +#print axioms random_compression_failure_probability +end Whir.PCSBCSSourceKnowledgeComposition diff --git a/verification/whir/Whir/PCSBCSSourceKnowledgeGame.lean b/verification/whir/Whir/PCSBCSSourceKnowledgeGame.lean new file mode 100644 index 000000000..d23d79199 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceKnowledgeGame.lean @@ -0,0 +1,145 @@ +import Whir.PCSBCSAdaptiveSourceKnowledgeProbability + +/-! Exact PCS-only source compiler instantiation. Counts Q is the existing +aggregate source-work budget: ordinary primitive calls cost one, and each +construction request costs its complete compression path. No equality with a +smaller distinct cached native-compression count is asserted. +An observer endpoint exposes literal native/source witness refinement; it does +not turn that code-refinement obligation into a cryptographic or probability +assumption. The additive RBR source relation is proved, and the only transfer +loss here is the checked 256-bit duplex mode term. Merkle bad events, arbitrary +Rust inputs, concrete BLAKE2s security and whole-system knowledge are separate. -/ +set_option autoImplicit false +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSSourceKnowledgeGame +open Concrete FiatShamirGame DuplexModeGame TypedOracleCompiler RawOracleCoupling +open PCSBCSChallengeOracle PCSStateRestoration.Latent + +variable {p : ParameterBounds.Profile} {Q : Nat} {iv : Digest32} {boundary : Nat} +local notation "part" => EnteredPacket.partition + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Keys" => PCSBCSSourceRootCapture.Key + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +local notation "Answers" => PCSBCSSourceRootCapture.Answer + (p := p) (Q := Q) (iv := iv) (boundary := boundary) +noncomputable local instance (key : Keys) : Fintype (Answers key) := + Restoration.instFintypeAnswer p Q iv boundary key + +/-- Same indexed source program used by the checked whole-public-view mode +coupling, with one grouped packet allocation at its first physical disclosure. +Its index is Q, not Q times the number of protocol rounds. -/ +noncomputable def source {R : Type} (program : Program R) (counted : Counts Q program) : + Sampling Keys Answers (View R) Q := + Atomic.program (part) (PublicCompressionCouplingMixed.compile Q iv [] program Q (by rfl) counted) + +open Classical in +theorem source_failure_probability {R : Type} + (layout : WHIRCallerClaims.CallerLayout) + (program : Program R) (counted : Counts Q program) : + Soundness.uniformProb (Finset.univ.filter fun table : Table Keys Answers => + PCSBCSAdaptiveSourceKnowledgeProbability.Failed layout (source program counted) table) ≤ + (Q : ℚ) * PCSRoundByRoundKnowledge.rbrError := + PCSBCSAdaptiveSourceKnowledgeProbability.failure_probability layout (source program counted) + +private theorem average_indicator {T : Type} [Fintype T] (test : T → Bool) : + average (fun t => if test t then (1 : ℚ) else 0) = + Soundness.uniformProb (Finset.univ.filter fun t => test t = true) := by + classical + simp only [average,Soundness.uniformProb,Finset.card_filter,Nat.cast_sum, + Nat.cast_ite,Nat.cast_one,Nat.cast_zero] + +/-- Explicit source semantics contract for a whole-view observer. It requires +actual native acceptance, actual extraction failure, independently bound +original preparation and literal native codec/primitive evidence, not a +StatePath, compatible snapshot, bad-probability certificate or soundness premise. +This contract must be discharged for the selected verifier's supported source +inputs before interpreting the observer as deployed acceptance/extraction. -/ +def ObserverRefines {R : Type} + (layout : WHIRCallerClaims.CallerLayout) + (program : Program R) (counted : Counts Q program) (observe : View R → Bool) : Prop := + ∀ table : Table Keys Answers, observe (Sampling.eval table (source program counted)) = true → + PCSBCSAdaptiveSourceKnowledgeProbability.Failed layout (source program counted) table + +open Classical in +theorem source_observer_probability {R : Type} + (layout : WHIRCallerClaims.CallerLayout) + (program : Program R) (counted : Counts Q program) (observe : View R → Bool) + (refines : ObserverRefines (p := p) (iv := iv) (boundary := boundary) + layout program counted observe) : + average (fun table : Table Keys Answers => + if observe (Sampling.eval table (source program counted)) then (1 : ℚ) else 0) ≤ + (Q : ℚ) * PCSRoundByRoundKnowledge.rbrError := by + rw [average_indicator] + have subset : (Finset.univ.filter fun table : Table Keys Answers => + observe (Sampling.eval table (source program counted)) = true) ⊆ + (Finset.univ.filter (PCSBCSAdaptiveSourceKnowledgeProbability.Failed layout + (source program counted))) := by + intro table member + exact Finset.mem_filter.mpr ⟨Finset.mem_univ _,refines table (Finset.mem_filter.mp member).2⟩ + have monotone : Soundness.uniformProb (Finset.univ.filter fun table : Table Keys Answers => + observe (Sampling.eval table (source program counted)) = true) ≤ + Soundness.uniformProb (Finset.univ.filter fun table : Table Keys Answers => + PCSBCSAdaptiveSourceKnowledgeProbability.Failed layout (source program counted) table) := by + unfold Soundness.uniformProb + apply div_le_div_of_nonneg_right + · exact_mod_cast Finset.card_le_card subset + · positivity + exact monotone.trans (source_failure_probability layout program counted) + +open Classical in +/-- Actual atomic whole-public-view experiment. Native/source refinement is +explicit for each adversarial coin choice; there is no extra round-query factor. -/ +theorem atomic_observer_probability {AdvCoins R : Type} + [Fintype AdvCoins] [Nonempty AdvCoins] + (layout : WHIRCallerClaims.CallerLayout) + (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) + (observe : View R → Bool) + (refines : ∀ a, ObserverRefines (p := p) (iv := iv) (boundary := boundary) + layout (adversary a) (counted a) observe) : + atomicIdealProbability (part) iv adversary counted observe ≤ + (Q : ℚ) * PCSRoundByRoundKnowledge.rbrError := by + unfold atomicIdealProbability + have each (a : AdvCoins) : + Sampling.expectation (fun result => if observe result.1 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (source (p := p) (iv := iv) (boundary := boundary) + (adversary a) (counted a)) (fun _ => none)) ≤ + (Q : ℚ) * PCSRoundByRoundKnowledge.rbrError := by + have tableMemo := RawOracleCoupling.empty_table_eq_memo + (source (p := p) (iv := iv) (boundary := boundary) (adversary a) (counted a)) + (fun view => if observe view then (1 : ℚ) else 0) + rw [← tableMemo] + exact source_observer_probability layout (adversary a) (counted a) observe (refines a) + have summed := average_mono each + rw [average_const] at summed + convert summed using 1 + congr 1 + funext a + unfold source + congr 2 <;> exact Subsingleton.elim _ _ + +open Classical in +/-- Transfer of an explicitly refined PCS source observer to random compression. +This bounds the good native-source event only: the omitted Merkle bad events +must still be included before claiming an overall PCS knowledge theorem. It +is not concrete BLAKE2s security, universal Rust refinement or whole-system knowledge. -/ +theorem random_compression_observer_probability {AdvCoins R : Type} + [Fintype AdvCoins] [Nonempty AdvCoins] + (layout : WHIRCallerClaims.CallerLayout) + (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) + (observe : View R → Bool) + (refines : ∀ a, ObserverRefines (p := p) (iv := iv) (boundary := boundary) + layout (adversary a) (counted a) observe) : + realProbability iv adversary observe ≤ + (Q : ℚ) * PCSRoundByRoundKnowledge.rbrError + duplexModeLoss Q := by + have coupling := entered_source_atomic_game_bound p Q iv boundary adversary counted observe + have deviation := (abs_le.mp coupling).2 + have ideal := atomic_observer_probability layout adversary counted observe refines + linarith + +#print axioms atomic_observer_probability +#print axioms random_compression_observer_probability + +#print axioms source_failure_probability +#print axioms source_observer_probability +end Whir.PCSBCSSourceKnowledgeGame diff --git a/verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean b/verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean index d436f1140..c4e699ed6 100644 --- a/verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean +++ b/verification/whir/Whir/PCSBCSSourcePrimitiveRootBudget.lean @@ -1,83 +1,149 @@ import Whir.PCSBCSSourceRootReferencesBudget import Whir.PCSBCSSourceCoordinateDecoderSource +import Whir.PCSBCSSourceSavedRecordProvenance import Whir.AnchoredHeaderRoots -/-! A public terminal costs one compression query, not its complete ancestry. -This actual-log scanner includes anchored commitment headers and opening roles, -using the conservative Q*(Q+1) target cap. Shared ancestry is not re-charged. -/ +/-! Public-byte-only reference recovery. A terminal query pays one physical +query, not its ancestry, so the conservative target cap is Q*(Q+1). -/ set_option autoImplicit false namespace Whir.PCSBCSSourcePrimitiveRootBudget open Concrete Protocol FiatShamirGame DuplexPublicSimulator DuplexFraming open PCSBCSMerkleRootCache PCSBCSSourceRootReferences -variable (p : ParameterBounds.Profile) (Q : Nat) - (layout : PublicLog → Node → WHIRCallerClaims.CallerLayout) - (saved : PublicLog → Node → AnchoredHeaderCodec.Record) - (entry : PublicLog → Node → FramedHistory) - (answers : PublicLog → Node → FiatShamirGame.Coordinate → Digest32) - (headers : PublicLog → Node → AnchoredHeaderRoots.Public) - -/-- Commitment-point output blocks register the verifier-selected full image -shape before their reply. The context CV is never treated as a tree root. -/ -def anchorReferences (queryPrefix : PublicLog) (input : Node) - (key : FiatShamirGame.Coordinate) : List Reference := +variable (p : ParameterBounds.Profile) (Q boundary : Nat) + (registry : AnchoredHeaderRoots.Public) + +/-- The boundary counts chronological frames, not newest-first log records. -/ +def entry (key : Coordinate) (boundary : Nat) : FramedHistory := + {key.history with frames := key.history.frames.take boundary} + +/-- Anchors use the fixed public registry even when opening decoding fails. -/ +def anchorReferences (key : Coordinate) : List Reference := match key.terminal with | .output _ => - match AnchoredHeaderRoots.fromHistory (headers queryPrefix input) key.history with + match AnchoredHeaderRoots.fromHistory registry key.history with | none => [] | some header => [⟨header.root,initialShape header.shape⟩] | _ => [] -theorem anchorReferences_length (queryPrefix : PublicLog) (input : Node) - (key : FiatShamirGame.Coordinate) : - (anchorReferences headers queryPrefix input key).length ≤ 1 := by +theorem anchorReferences_length (key : Coordinate) : + (anchorReferences registry key).length ≤ 1 := by unfold anchorReferences cases key.terminal <;> try simp split <;> simp -/-- Ordinary public inputs and their strictly earlier log, with one source-key -inversion, no history oracle and no future records. Every shape is retained. -/ +/-- Conservative opening admission needs no caller layout or answer getter. +Every root and shape is decoded or selected by the actual source role parser. -/ +def openingReferencesFromEntry (callerEntry : FramedHistory) (key : Coordinate) : Option (List Reference) := do + let saved ← PCSBCSSourceSavedRecordDecoder.decode p callerEntry + let messages ← parsePendingKey p callerEntry key + if phaseRolesAdmitted (ParameterBounds.config p) messages then + pure (⟨saved.root,initialShape saved.shape⟩ :: + phaseReferences (ParameterBounds.config p) messages) + else none + +def openingReferences (key : Coordinate) : Option (List Reference) := + openingReferencesFromEntry p (entry key boundary) key + +theorem openingReferences_bound (key : Coordinate) (refs : List Reference) + (accepted : openingReferences p boundary key = some refs) : + refs.length ≤ pathCost key := by + unfold openingReferences openingReferencesFromEntry at accepted + cases saved : PCSBCSSourceSavedRecordDecoder.decode p (entry key boundary) with + | none => simp [saved] at accepted + | some record => + simp only [saved] at accepted + dsimp only [Bind.bind,Option.bind] at accepted + cases pending : parsePendingKey p (entry key boundary) key with + | none => simp [pending] at accepted + | some messages => + simp only [pending] at accepted + dsimp only [Bind.bind,Option.bind,Pure.pure] at accepted + split at accepted + · cases accepted + obtain ⟨nonempty,admitted,block,same⟩ := + parsePendingKey_admitted p (entry key boundary) key messages pending + rw [same] + simpa only [List.length_cons,Nat.add_comm] using + complete_path_reference_bound p (entry key boundary) messages nonempty admitted block + · contradiction + +/-- Native acceptance itself supplies saved-record provenance; no record-equality +or metadata reconstruction premise is needed. -/ +theorem openingReferencesFromEntry_native (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (answers : Coordinate → Digest32) + (callerEntry : FramedHistory) (key : Coordinate) (refs : List Reference) + (accepted : parseReferences p layout saved callerEntry answers key = some refs) : + openingReferencesFromEntry p callerEntry key = some refs := by + obtain ⟨valid,profile,claims,messages,caller,pending,roles,same⟩ := + parseReferences_admitted p layout saved callerEntry answers key refs accepted + have decoded := PCSBCSSourceSavedRecordProvenance.decode_saved_profileShape p layout saved + callerEntry answers claims caller valid profile + simp only [openingReferencesFromEntry,decoded] + dsimp only [Bind.bind,Option.bind] + simp only [pending] + dsimp only [Bind.bind,Option.bind,Pure.pure] + rw [ite_eq_left roles] + exact congrArg some same.symm + +theorem openingReferences_native (layout : WHIRCallerClaims.CallerLayout) + (saved : AnchoredHeaderCodec.Record) (answers : Coordinate → Digest32) + (key : Coordinate) (refs : List Reference) + (accepted : parseReferences p layout saved (entry key boundary) answers key = some refs) : + openingReferences p boundary key = some refs := + openingReferencesFromEntry_native p layout saved answers (entry key boundary) key refs accepted + +/-- Only the strictly earlier newest-first public log and the actual input are +read. Recovered histories retain their chronological frame ordering. -/ def references (queryPrefix : PublicLog) (input : Node) : List Reference := ((PCSBCSSourceCoordinateDecoder.recover Q PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input).map - (fun key => anchorReferences headers queryPrefix input key ++ - (parseReferences p (layout queryPrefix input) (saved queryPrefix input) - (entry queryPrefix input) (answers queryPrefix input) key).getD [])).getD [] + (fun key => anchorReferences registry key ++ + (openingReferences p boundary key).getD [])).getD [] + +theorem references_native (queryPrefix : PublicLog) (input : Node) (key : Coordinate) + (recovered : PCSBCSSourceCoordinateDecoder.recover Q + PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input = some key) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (answers : Coordinate → Digest32) (refs : List Reference) + (accepted : parseReferences p layout saved (entry key boundary) answers key = some refs) : + ∀ ref ∈ refs, ref ∈ references p Q boundary registry queryPrefix input := by + have parsed := openingReferences_native p boundary layout saved answers key refs accepted + simp only [references,recovered,Option.map_some,Option.getD_some,parsed] + intro ref member + exact List.mem_append_right _ member theorem references_le (queryPrefix : PublicLog) (input : Node) : - (references p Q layout saved entry answers headers queryPrefix input).length ≤ Q+1 := by + (references p Q boundary registry queryPrefix input).length ≤ Q+1 := by unfold references cases recovered : PCSBCSSourceCoordinateDecoder.recover Q PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input with | none => simp | some key => simp only [Option.map_some,Option.getD_some,List.length_append] - have anchor := anchorReferences_length headers queryPrefix input key - have opening : ((parseReferences p (layout queryPrefix input) (saved queryPrefix input) - (entry queryPrefix input) (answers queryPrefix input) key).getD []).length ≤ Q := by - cases parsed : parseReferences p (layout queryPrefix input) (saved queryPrefix input) - (entry queryPrefix input) (answers queryPrefix input) key with + have anchor := anchorReferences_length registry key + have opening : ((openingReferences p boundary key).getD []).length ≤ Q := by + cases parsed : openingReferences p boundary key with | none => simp | some refs => simp only [Option.getD_some] obtain ⟨_,_,_,_,_,_,_,cost⟩ := PCSBCSSourceCoordinateDecoder.recover_sound recovered - exact (parsed_reference_bound p (layout queryPrefix input) (saved queryPrefix input) - (entry queryPrefix input) (answers queryPrefix input) key refs parsed).trans cost + exact (openingReferences_bound p boundary key refs parsed).trans cost omega -/-- Newest records are stored first. The accumulator avoids repeatedly copying -older announcements and captures each exact prefix at its primitive request. -/ +/-- Newest records are stored first; announcements are accumulated oldest first +and each captures the exact prefix before its primitive reply. -/ def scanAux : PublicLog → List Announcement → List Announcement | [], acc => acc | (input,_) :: queryPrefix, acc => scanAux queryPrefix (announcements queryPrefix - (references p Q layout saved entry answers headers queryPrefix input) ++ acc) + (references p Q boundary registry queryPrefix input) ++ acc) def scan (log : PublicLog) : List Announcement := - scanAux p Q layout saved entry answers headers log [] + scanAux p Q boundary registry log [] theorem scanAux_append (log : PublicLog) (left right : List Announcement) : - scanAux p Q layout saved entry answers headers log (left ++ right) = - scanAux p Q layout saved entry answers headers log left ++ right := by + scanAux p Q boundary registry log (left ++ right) = + scanAux p Q boundary registry log left ++ right := by induction log generalizing left with | nil => rfl | cons record queryPrefix ih => @@ -85,41 +151,39 @@ theorem scanAux_append (log : PublicLog) (left right : List Announcement) : simp only [scanAux,← List.append_assoc,ih] theorem scan_cons (input : Node) (digest : Digest32) (queryPrefix : PublicLog) : - scan p Q layout saved entry answers headers ((input,digest)::queryPrefix) = - scan p Q layout saved entry answers headers queryPrefix ++ - announcements queryPrefix (references p Q layout saved entry answers headers queryPrefix input) := by + scan p Q boundary registry ((input,digest)::queryPrefix) = + scan p Q boundary registry queryPrefix ++ + announcements queryPrefix (references p Q boundary registry queryPrefix input) := by simpa only [scan,scanAux,List.nil_append,List.append_nil] using - scanAux_append p Q layout saved entry answers headers queryPrefix [] - (announcements queryPrefix (references p Q layout saved entry answers headers queryPrefix input)) + scanAux_append p Q boundary registry queryPrefix [] + (announcements queryPrefix (references p Q boundary registry queryPrefix input)) theorem scan_length (log : PublicLog) : - (scan p Q layout saved entry answers headers log).length ≤ log.length*(Q+1) := by + (scan p Q boundary registry log).length ≤ log.length*(Q+1) := by induction log with | nil => simp [scan,scanAux] | cons record queryPrefix ih => rcases record with ⟨input,digest⟩ - have bound := references_le p Q layout saved entry answers headers queryPrefix input + have bound := references_le p Q boundary registry queryPrefix input simp only [scan_cons,List.length_append,announcements,List.length_map,List.length_cons] rw [Nat.succ_mul] omega -/-- Shared physical queries bound the actual public log. No Q+1 target cap or -one-opening-root-per-terminal premise is used. Adaptive anchors are included. -/ -theorem register_scan (registry : Registry) (log : PublicLog) (budget : log.length ≤ Q) : - (registerAll registry (scan p Q layout saved entry answers headers log)).size ≤ - registry.size + Q*(Q+1) := by - have entries := registerAll_size_le registry (scan p Q layout saved entry answers headers log) - have count := scan_length p Q layout saved entry answers headers log - have cost : log.length*(Q+1) ≤ Q*(Q+1) := Nat.mul_le_mul_right (Q+1) budget +theorem register_scan (cache : Registry) (log : PublicLog) (budget : log.length ≤ Q) : + (registerAll cache (scan p Q boundary registry log)).size ≤ + cache.size + Q*(Q+1) := by + have entries := registerAll_size_le cache (scan p Q boundary registry log) + have count := scan_length p Q boundary registry log + have cost := Nat.mul_le_mul_right (Q+1) budget omega -/-- Digest targets come from classified shape references, not a registry that -conflates equal digests at different verifier-fixed shapes. -/ +/-- Shape addresses remain distinct in the announcement/cache table. Only the +probability event projects those addresses to digest targets. -/ def targets (log : PublicLog) : Finset Digest32 := - ((scan p Q layout saved entry answers headers log).map (fun a => a.root)).toFinset + ((scan p Q boundary registry log).map (fun a => a.root)).toFinset theorem targets_grow : PublicMerkleProbability.RootsGrow - (targets p Q layout saved entry answers headers) := by + (targets p Q boundary registry) := by intro history record root member simp only [targets,List.mem_toFinset,List.mem_map] at member ⊢ obtain ⟨announcement,inOld,same⟩ := member @@ -128,15 +192,17 @@ theorem targets_grow : PublicMerkleProbability.RootsGrow exact ⟨announcement,List.mem_append_left _ inOld,same⟩ theorem targets_cap (log : PublicLog) (budget : log.length ≤ Q) : - (targets p Q layout saved entry answers headers log).card ≤ Q*(Q+1) := by + (targets p Q boundary registry log).card ≤ Q*(Q+1) := by have finite := List.toFinset_card_le - ((scan p Q layout saved entry answers headers log).map (fun a => a.root)) - have count := scan_length p Q layout saved entry answers headers log - have cost : log.length*(Q+1) ≤ Q*(Q+1) := Nat.mul_le_mul_right (Q+1) budget + ((scan p Q boundary registry log).map (fun a => a.root)) + have count := scan_length p Q boundary registry log + have cost := Nat.mul_le_mul_right (Q+1) budget simp only [List.length_map] at finite exact finite.trans (count.trans cost) -#print axioms anchorReferences_length +#print axioms openingReferences_native +#print axioms openingReferencesFromEntry_native +#print axioms references_native #print axioms references_le #print axioms scan_length #print axioms register_scan diff --git a/verification/whir/Whir/PCSBCSSourcePublicMetadata.lean b/verification/whir/Whir/PCSBCSSourcePublicMetadata.lean new file mode 100644 index 000000000..61e6a4a0a --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourcePublicMetadata.lean @@ -0,0 +1,125 @@ +import Whir.PCSBCSSourceCoordinateDecoderSource +import Whir.PCSBCSSourceSavedRecordProvenance +import Whir.PCSBCSPublicCallerCompletion + +/-! Source metadata is recovered from the actual primitive input and its public +prefix. Original caller reconstruction completes missing earlier outputs with +real compression draws before using a public-only finite getter. Invalid or +incomplete public metadata returns `none`, never a manufactured record. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourcePublicMetadata +open Concrete FiatShamirGame DuplexFraming DuplexPublicSimulator +open PublicCompressionProgram PCSBCSPublicCallerCompletion +open DuplexRefinement DuplexModeGame TypedOracleCompiler RawOracleCoupling + +structure Metadata where + coordinate : Coordinate + saved : AnchoredHeaderCodec.Record + +/-- The boundary is public source geometry, not supplied saved-header data. -/ +def entry (boundary : Nat) (coordinate : Coordinate) : FramedHistory := + { coordinate.history with frames := coordinate.history.frames.take boundary } + +def recover (p : ParameterBounds.Profile) (Q boundary : Nat) + (queryPrefix : PublicLog) (input : Node) : Option Metadata := do + let coordinate ← PCSBCSSourceCoordinateDecoder.recover Q + PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input + let saved ← PCSBCSSourceSavedRecordDecoder.decode p (entry boundary coordinate) + return ⟨coordinate,saved⟩ + +theorem recover_sound (p : ParameterBounds.Profile) (Q boundary : Nat) + (queryPrefix : PublicLog) (input : Node) (metadata : Metadata) + (accepted : recover p Q boundary queryPrefix input = some metadata) : + PCSBCSSourceCoordinateDecoder.recover Q + PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input = some metadata.coordinate ∧ + PCSBCSSourceSavedRecordDecoder.decode p (entry boundary metadata.coordinate) = + some metadata.saved ∧ metadata.saved.Valid ∧ + PCSBCSSourceSavedRecordDecoder.Compatible p metadata.saved := by + unfold recover at accepted + cases decoded : PCSBCSSourceCoordinateDecoder.recover Q + PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input with + | none => simp [decoded] at accepted + | some coordinate => + simp only [decoded,Option.bind_eq_bind,Option.bind_some] at accepted + cases saved : PCSBCSSourceSavedRecordDecoder.decode p (entry boundary coordinate) with + | none => simp [saved] at accepted + | some record => + simp only [saved,Option.bind_some] at accepted + change some (⟨coordinate,record⟩ : Metadata) = some metadata at accepted + have equal := Option.some.inj accepted + cases equal + have sound := PCSBCSSourceSavedRecordDecoder.decode_sound p + (entry boundary coordinate) record saved + exact ⟨rfl,saved,sound.1,sound.2.1⟩ + +/-- A recovered coordinate and successful actual native caller parse determine +all saved fields. Saved metadata is not fixed before random-table sampling. -/ +theorem recover_native (p : ParameterBounds.Profile) (Q boundary : Nat) + (queryPrefix : PublicLog) (input : Node) (coordinate : Coordinate) + (layout : WHIRCallerClaims.CallerLayout) (saved : AnchoredHeaderCodec.Record) + (answers : Coordinate → Digest32) (claims : AnchoredSourceCaller.Claims) + (decoded : PCSBCSSourceCoordinateDecoder.recover Q + PCSBCSSourceCoordinateDecoder.seedIV queryPrefix input = some coordinate) + (accepted : AnchoredSourceFreshCaller.decode layout saved + (entry boundary coordinate) answers = some claims) + (valid : saved.Valid) (profile : PCSBCSSourceSavedRecordDecoder.Compatible p saved) : + recover p Q boundary queryPrefix input = some ⟨coordinate,saved⟩ := by + have found := PCSBCSSourceSavedRecordProvenance.decode_saved p layout saved + (entry boundary coordinate) answers claims accepted valid profile + simp only [recover,decoded,Option.bind_eq_bind,Option.bind_some,found] + rfl + +/-- A finite executable availability check justifies the public-only getter. +The outside callback is never used for a caller-observed coordinate. -/ +def resolveOriginal (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (iv : Digest32) (boundary : Nat) (metadata : Metadata) (log : PublicLog) + (outside : Coordinate → Digest32) : Option (PCSBCSCallerBinding.CallerInput p) := + let originalEntry := entry boundary metadata.coordinate + if ready : (WHIRCallerOutputs.callerOutputs originalEntry).all + (fun q => (PCSBCSPublicCallerAnswers.answer? log iv q).isSome) = true then + PCSBCSSourceCallerOriginal.original p layout metadata.saved originalEntry + (callerAnswers iv log originalEntry (List.all_eq_true.mp ready) outside) + else none + +def originalCompletion (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (iv : Digest32) (boundary : Nat) (metadata : Metadata) (log : PublicLog) + (outside : Coordinate → Digest32) : + Computation (Option (PCSBCSCallerBinding.CallerInput p)) + (budget (WHIRCallerOutputs.callerOutputs (entry boundary metadata.coordinate))) := + mapResult (fun completed => resolveOriginal p layout iv boundary metadata completed outside) + (callerCompletion iv log (entry boundary metadata.coordinate)) + +theorem originalCompletion_exact (C : PrimitiveOracle) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (iv : Digest32) (boundary : Nat) + (metadata : Metadata) (log : PublicLog) (auth : PublicMerkleLog.AuthenticLog C log) + (outside : Coordinate → Digest32) : + Sampling.eval C (originalCompletion p layout iv boundary metadata log outside) = + PCSBCSSourceCallerOriginal.original p layout metadata.saved + (entry boundary metadata.coordinate) (evalCoordinate (compressionOf C) iv) := by + let originalEntry := entry boundary metadata.coordinate + have available := callerCompletion_total C iv log auth originalEntry + have ready : (WHIRCallerOutputs.callerOutputs originalEntry).all + (fun q => (PCSBCSPublicCallerAnswers.answer? + (Sampling.execute C (callerCompletion iv log originalEntry)).1 iv q).isSome) = true := + List.all_eq_true.mpr available + simp only [originalCompletion,eval_mapResult] + rw [← Sampling.execute_value] + change resolveOriginal p layout iv boundary metadata + (Sampling.execute C (callerCompletion iv log originalEntry)).1 outside = _ + simp only [resolveOriginal,show entry boundary metadata.coordinate = originalEntry from rfl, + ready,↓reduceDIte] + exact original_resolved C iv log auth originalEntry p layout metadata.saved outside + +theorem originalCompletion_draws_le (C : PrimitiveOracle) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (iv : Digest32) (boundary : Nat) + (metadata : Metadata) (log : PublicLog) (outside : Coordinate → Digest32) : + (Sampling.execute C (originalCompletion p layout iv boundary metadata log outside)).2.length ≤ + ((WHIRCallerOutputs.callerOutputs (entry boundary metadata.coordinate)).map pathCost).sum := by + simp only [originalCompletion,execute_mapResult] + exact complete_draws_le C iv log _ + +#print axioms recover_sound +#print axioms recover_native +#print axioms originalCompletion_exact +#print axioms originalCompletion_draws_le +end Whir.PCSBCSSourcePublicMetadata diff --git a/verification/whir/Whir/PCSBCSSourcePublicMetadataSmoke.lean b/verification/whir/Whir/PCSBCSSourcePublicMetadataSmoke.lean new file mode 100644 index 000000000..0eae2d225 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourcePublicMetadataSmoke.lean @@ -0,0 +1,83 @@ +import Whir.PCSBCSSourcePublicMetadata +import Whir.PCSBCSConstructionReplayTrace + +namespace Whir.PCSBCSSourcePublicMetadataSmoke +open Whir Concrete Protocol FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open DuplexPublicSimulator RawOracleCoupling PublicCompressionProgram +open PCSBCSPublicCallerCompletion +open TypedOracleCompiler + +local instance : CommRing E := FieldModel.instCommRingE +local instance : Zero E := ⟨E.zero⟩ +local instance : One E := ⟨E.one⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +private def p : ParameterBounds.Profile := ⟨⟨0,by decide⟩,⟨0,by decide⟩⟩ +private def layout : WHIRCallerClaims.CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ +private def digest (salt : Nat) : Digest32 := fun i => + ⟨(17*i.val+salt)%256,Nat.mod_lt _ (by decide)⟩ +private def saved : AnchoredHeaderCodec.Record := + ⟨AnchoredSourceCaller.shape layout,digest 17,⟨digest 19,(fun _ => none),0,true,0,0⟩, + E.ofK 3 :: List.replicate 14 0,E.ofK 23⟩ +private def zeroToken : WHIRCallerShape.EventShape → WHIRCallerClaims.CallerToken + | .absorb _ => .sent 0 + | .squeeze _ => .draw 0 + | .nonce bits => .nonce bits (ByteCodec.encodeNat 24 0) +private def entryFor (record : AnchoredHeaderCodec.Record) : FramedHistory := + WHIRCallerClaims.tokenHistory (digest 11) (digest 13) + (((WHIRCallerClaims.callerShape layout).drop (WHIRCallerClaims.rootScalarCount layout)).map + zeroToken ++ (AnchoredHeaderCodec.openingScalars record).map WHIRCallerClaims.CallerToken.sent) + +private def publicPath (cv : Digest32) (log : PublicLog) : + List DuplexEncoding.Instruction → Option (PublicLog × Node) + | [] => none + | [(block,tweak)] => some (log,⟨cv,block,tweak,true⟩) + | (block,tweak) :: next :: rest => + let node : Node := ⟨cv,block,tweak,true⟩ + let stored := Array.ofFn (blake2sOracle node) + let answer : Digest32 := fun i => stored[i.val]'(by simp [stored]) + publicPath answer (DuplexPublicSimulator.observe log node answer) (next::rest) + +private def require (label : String) (ok : Bool) : IO Unit := do + unless ok do throw (IO.userError s!"public metadata completion: {label}") + IO.println s!"public metadata completion PASS: {label}" + +def smoke : IO Unit := do + let originalEntry := entryFor saved + let coordinate : Coordinate := ⟨originalEntry,.output 1⟩ + let iv := PCSBCSSourceCoordinateDecoder.seedIV + let Q := pathCost coordinate + let some (prefixLog,input) := publicPath iv [] (DuplexEncoding.plan coordinate) + | throw (IO.userError "actual source path absent") + let some metadata := PCSBCSSourcePublicMetadata.recover p Q originalEntry.frames.length prefixLog input + | throw (IO.userError "actual primitive source metadata rejected") + require "physical source inversion recovers every saved field, not a supplied header" + (AnchoredHeaderCodec.openingScalars metadata.saved == AnchoredHeaderCodec.openingScalars saved) + require "missing ancestral source record rejects metadata rather than fabricating a record" + ((PCSBCSSourcePublicMetadata.recover p Q originalEntry.frames.length [] input).isNone) + let outputs := WHIRCallerOutputs.callerOutputs originalEntry + require "fixture has earlier caller outputs absent from the public source prefix" + (outputs.any fun q => (PCSBCSPublicCallerAnswers.answer? prefixLog iv q).isNone) + let completed := Sampling.execute blake2sOracle (callerCompletion iv prefixLog originalEntry) + require "completion executes real compression plans for missing earlier outputs" + (completed.2.length ≥ 2 && outputs.all fun q => + (PCSBCSPublicCallerAnswers.answer? completed.1 iv q).isSome) + let duplicate := Sampling.execute blake2sOracle (callerCompletion iv completed.1 originalEntry) + require "repeated earlier outputs are served from the recorded public cache" + (duplicate.2.isEmpty) + let some original := Sampling.eval blake2sOracle + (PCSBCSSourcePublicMetadata.originalCompletion p layout iv originalEntry.frames.length + metadata prefixLog (fun _ => digest 199)) + | throw (IO.userError "real completed original caller rejected") + require "original reconstruction retains the public anchor and occupied lane geometry" + (original.lanes == saved.shape.lanes && original.anchorPoint == saved.point.toArray && + original.anchorValue == saved.value) + require "an incomplete getter cache rejects, even when an outside callback exists" + ((PCSBCSSourcePublicMetadata.resolveOriginal p layout iv originalEntry.frames.length + metadata prefixLog (fun _ => digest 199)).isNone) + IO.println s!"public metadata completion: {outputs.length} earlier outputs, {completed.2.length} real draws" + +end Whir.PCSBCSSourcePublicMetadataSmoke + +def main : IO Unit := Whir.PCSBCSSourcePublicMetadataSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceReferenceParserCost.lean b/verification/whir/Whir/PCSBCSSourceReferenceParserCost.lean new file mode 100644 index 000000000..08eaae732 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceReferenceParserCost.lean @@ -0,0 +1,296 @@ +import Whir.PCSBCSPublicLogParserCost +import Whir.PCSBCSCallerPayloadCost + +/-! Actual scheduled opening-role parser instrumentation. Charges include +public schedule construction/indexing, scalar encoding, ghost-model framing, +whole-history equality and every checked phase role. No parser cost oracle is +an input. CpuLayout.output remains an explicitly costed metadata getter. -/ +set_option autoImplicit false +namespace Whir.PCSBCSSourceReferenceParserCost +open Concrete Protocol FiatShamirGame DuplexRefinement WHIRHistory WHIRHistoryKey +open WHIRCallerClaims PCSBCSSourceRootReferences PCSBCSPublicLogParserCost + +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + +/-- The schedule is finite public geometry. List constructors, all per-phase +array reads, both fold sums and the invisible tail are included. This volume +charge deliberately includes failed indices, not only accepted coordinates. -/ +def scheduleWork (c : Config) : Nat := + 32*(c.folds.size+(schedule c).length+c.logN+1) + +def scalarCountWork (c : Config) : Nat := 32*(c.folds.size+c.logN+1) + +def stackWidthCount (c : Config) (n : Nat) : Nat × Nat := + (stackWidth c n,scheduleWork c+min n (schedule c).length+scalarCountWork c+8) + +/-- The protocol recurrence materializes scalar bytes, not a hash. -/ +def pendingModelCount (m : Model) (p : Pending) : Model × Nat := + let bytes := scalarBytes p.scalars + let absorbed := operationCount m (.absorb bytes) + match p.nonce with + | none => (absorbed.1,absorbed.2+900*p.scalars.length+2) + | some (bits,nonce) => + let ground := operationCount absorbed.1 (.nonce bits (ByteCodec.encodeE nonce)) + (ground.1,absorbed.2+ground.2+900*(p.scalars.length+1)+2) + +theorem pendingModelCount_value (m : Model) (p : Pending) : + (pendingModelCount m p).1 = pendingModel m p := by + simp only [pendingModelCount,pendingModel,operationCount_value,WHIRCallerShape.applyOperation] + cases p.nonce <;> rfl + +def completedModelCount (c : Config) (domain statement : Digest32) : List Pending → Model × Nat + | [] => (⟨⟨domain,statement,[]⟩,[],0,0⟩,1) + | p::ps => + let previous := completedModelCount c domain statement ps + let absorbed := pendingModelCount previous.1 p + let width := stackWidthCount c ps.length + let output := operationCount absorbed.1 (.squeeze width.1) + (output.1,previous.2+absorbed.2+width.2+output.2+ps.length+4) + +theorem completedModelCount_value (c : Config) (domain statement : Digest32) (ps : List Pending) : + (completedModelCount c domain statement ps).1 = completedModel (stackWidth c) domain statement ps := by + induction ps with + | nil => rfl + | cons p ps ih => + simp only [completedModelCount,completedModel,operationCount_value, + WHIRCallerShape.applyOperation,pendingModelCount_value,ih,stackWidthCount] + +def beforeModelCount (c : Config) (domain statement : Digest32) : List Pending → Model × Nat + | [] => completedModelCount c domain statement [] + | p::ps => + let previous := completedModelCount c domain statement ps + let absorbed := pendingModelCount previous.1 p + (absorbed.1,previous.2+absorbed.2+1) + +theorem beforeModelCount_value (c : Config) (domain statement : Digest32) (ps : List Pending) : + (beforeModelCount c domain statement ps).1 = beforeModel (stackWidth c) domain statement ps := by + cases ps <;> simp only [beforeModelCount,beforeModel,completedModelCount_value,pendingModelCount_value] + +def outputKeyCount (c : Config) (entry : FramedHistory) (ps : List Pending) (block : Nat) : Coordinate × Nat := + let before := beforeModelCount c entry.domain entry.statement ps + let prefixed := WHIRCallerPrefix.prepend entry.frames before.1 + let closed := closeRunCount prefixed + (⟨closed.1.history,.output block⟩,before.2+closed.2+entry.frames.length+4) + +theorem outputKeyCount_value (c : Config) (entry : FramedHistory) (ps : List Pending) (block : Nat) : + (outputKeyCount c entry ps block).1 = WHIRCallerPrefix.outputKeyFrom (stackWidth c) entry ps block := by + simp only [outputKeyCount,WHIRCallerPrefix.outputKeyFrom,WHIRCallerPrefix.beforeModelFrom, + closeRunCount_value,beforeModelCount_value] + +/-- Reverse/zipIdx, two schedule constructions per visited position, two list +indices, scalar-list length, reply geometry and nonce checks. A full stopping- +prefix reservation is charged even if Bool.all rejects an earlier position. -/ +def scheduleGuardWork (c : Config) (messages : List Pending) : Nat := + messages.length*(2*scheduleWork c+2*(schedule c).length+scalarCountWork c+32)+ + ((messages.map (fun m => m.scalars.length)).sum)+4*messages.length+scheduleWork c+8 + +/-- Both the root-pair scalar codec and the complete phase-position lookup are +included, along with reverse/zip/filter/all list construction. -/ +def phaseWork (c : Config) (messages : List Pending) : Nat := + messages.length*(2*scheduleWork c+2*(schedule c).length+scalarCountWork c+4096)+ + 2*((messages.map (fun m => m.scalars.length)).sum)+8*messages.length+8 + +/-- The complete literal output key, including the initial unabsorbed Pending, +is reconstructed once and checked against all framed input bytes. -/ +def parsePendingKeyCount (p : ParameterBounds.Profile) (entry : FramedHistory) (key : Coordinate) : + Option (List Pending) × Nat := + let steps := parseStepsCount (key.history.frames.drop entry.frames.length) + match steps.1 with + | none => (none,steps.2+entry.frames.length+min entry.frames.length key.history.frames.length+2) + | some chronological => + let messages := chronological.reverse++[initialPending] + match key.terminal with + | .output block => + let rebuilt := outputKeyCount (ParameterBounds.config p) entry messages block + (if scheduledAdmissible (ParameterBounds.config p) messages = true ∧ key = rebuilt.1 + then some messages else none, + steps.2+entry.frames.length+min entry.frames.length key.history.frames.length+ + 3*chronological.length+scheduleGuardWork (ParameterBounds.config p) messages+ + rebuilt.2+coordinateEqWork key rebuilt.1+4) + | _ => (none,steps.2+entry.frames.length+min entry.frames.length key.history.frames.length+3*chronological.length+4) + +theorem parsePendingKeyCount_value (p : ParameterBounds.Profile) (entry : FramedHistory) (key : Coordinate) : + (parsePendingKeyCount p entry key).1 = parsePendingKey p entry key := by + simp only [parsePendingKeyCount,parsePendingKey,parseStepsCount_value] + cases parseSteps (key.history.frames.drop entry.frames.length) with + | none => rfl + | some chronological => + cases key.terminal <;> simp only [outputKeyCount_value] <;> rfl + +/-- Exactly the ascending, short-circuit finite validity getter loop. Costs +are per evaluation of Context.pending, not part of savedAt materialization. -/ +def pendingValidityCount (context : AnchoredHeaderCodec.Context) + (cost : PCSBCSCallerPayloadCost.OutputCosts) : List (Fin 8) → Bool × List (Fin 8) × Nat + | [] => (true,[],1) + | i::is => + let ok := (context.pending i).isSome == decide (i.val < (context.pendingBytes+7)/8) + if ok then + let later := pendingValidityCount context cost is + (later.1,i::later.2.1,cost.pending i+later.2.2+8) + else (false,[i],cost.pending i+8) + +theorem pendingValidityCount_value (context : AnchoredHeaderCodec.Context) + (cost : PCSBCSCallerPayloadCost.OutputCosts) (indices : List (Fin 8)) : + (pendingValidityCount context cost indices).1 = + indices.all (fun i => (context.pending i).isSome == + decide (i.val < (context.pendingBytes+7)/8)) := by + induction indices with + | nil => rfl + | cons i is ih => + simp only [pendingValidityCount,List.all_cons] + split <;> simp_all + +/-- The trace records the actual reached indices and is independent of prices. -/ +theorem pendingValidityCount_trace (context : AnchoredHeaderCodec.Context) + (a b : PCSBCSCallerPayloadCost.OutputCosts) (indices : List (Fin 8)) : + (pendingValidityCount context a indices).2.1 = + (pendingValidityCount context b indices).2.1 := by + induction indices with + | nil => rfl + | cons i is ih => + simp only [pendingValidityCount] + split <;> simp_all + +theorem pendingValidityCount_price_exact (context : AnchoredHeaderCodec.Context) + (cost : PCSBCSCallerPayloadCost.OutputCosts) (indices : List (Fin 8)) : + (pendingValidityCount context cost indices).2.2 = + (pendingValidityCount context PCSBCSCallerPayloadCost.OutputCosts.zero indices).2.2+ + (((pendingValidityCount context cost indices).2.1).map cost.pending).sum := by + induction indices with + | nil => rfl + | cons i is ih => + simp only [pendingValidityCount] + split + · dsimp only + simp only [List.map_cons,List.sum_cons,PCSBCSCallerPayloadCost.OutputCosts.zero] at ih ⊢ + omega + · simp [PCSBCSCallerPayloadCost.OutputCosts.zero,Nat.add_comm] + +def recordValidityCount (saved : AnchoredHeaderCodec.Record) + (cost : PCSBCSCallerPayloadCost.OutputCosts) : Bool × List (Fin 8) × Nat := + if saved.shape.Valid then + if saved.context.pendingBytes ≤ 64 then + let slots := pendingValidityCount saved.context cost (List.ofFn (fun i : Fin 8 => i)) + (slots.1 && decide (saved.point.length = saved.shape.logN), + slots.2.1,slots.2.2+saved.point.length+PCSBCSCallerPayloadCost.shapeValidWork saved.shape+8) + else (false,[],PCSBCSCallerPayloadCost.shapeValidWork saved.shape+4) + else (false,[],PCSBCSCallerPayloadCost.shapeValidWork saved.shape+2) + +theorem recordValidityCount_value (saved : AnchoredHeaderCodec.Record) + (cost : PCSBCSCallerPayloadCost.OutputCosts) : + (recordValidityCount saved cost).1 = true ↔ saved.Valid := by + unfold recordValidityCount AnchoredHeaderCodec.Record.Valid AnchoredHeaderCodec.Context.Valid + split + · split + · simp only [pendingValidityCount_value,Bool.and_eq_true,decide_eq_true_eq, + List.all_eq_true,List.forall_mem_ofFn_iff] + simp_all + · simp_all + · simp_all + +/-- Counted caller+scheduled source parser. Opening guards and fixed-size saved +record validation are charged explicitly; failed captures return none, never +an authenticated default word. -/ +def parseReferencesCount (p : ParameterBounds.Profile) (layout : CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) (answers : Coordinate → Digest32) + (key : Coordinate) (outputCosts : PCSBCSCallerPayloadCost.OutputCosts) : + Option (List Reference) × Nat × Nat := + let valid := recordValidityCount saved outputCosts + if valid.1 = true ∧ profileShape p saved.shape then + let tokens := PCSBCSPublicLogParserCost.entryTokensCount entry answers + match tokens.1 with + | none => (none,tokens.2.1,tokens.2.2+valid.2.2+128) + | some ts => + let caller := PCSBCSCallerPayloadCost.freshInterpret layout saved outputCosts ts + match caller.value with + | none => (none,tokens.2.1,tokens.2.2+caller.work+valid.2.2+128) + | some _ => + let pending := parsePendingKeyCount p entry key + match pending.1 with + | none => (none,tokens.2.1,tokens.2.2+caller.work+pending.2+valid.2.2+128) + | some messages => + (if phaseRolesAdmitted (ParameterBounds.config p) messages then + some (⟨saved.root,initialShape saved.shape⟩::phaseReferences (ParameterBounds.config p) messages) + else none, + tokens.2.1,tokens.2.2+caller.work+pending.2+phaseWork (ParameterBounds.config p) messages+valid.2.2+128) + else (none,0,valid.2.2+128) + +theorem parseReferencesCount_value (p : ParameterBounds.Profile) (layout : CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) (answers : Coordinate → Digest32) + (key : Coordinate) (outputCosts : PCSBCSCallerPayloadCost.OutputCosts) : + (parseReferencesCount p layout saved entry answers key outputCosts).1 = + parseReferences p layout saved entry answers key := by + simp only [parseReferencesCount,parseReferences,recordValidityCount_value] + split + · simp only [PCSBCSPublicLogParserCost.entryTokensCount_value,AnchoredSourceFreshCaller.decode] + cases WHIRCallerClaims.entryTokens entry answers with + | none => rfl + | some tokens => + dsimp only [Bind.bind,Option.bind] + rw [PCSBCSCallerPayloadCost.freshInterpret_erasure] + cases AnchoredSourceFreshCaller.interpret layout saved tokens with + | none => rfl + | some claims => + rw [parsePendingKeyCount_value] + cases parsePendingKey p entry key <;> rfl + · rfl + +theorem pendingValidityCount_calls (context : AnchoredHeaderCodec.Context) + (cost : PCSBCSCallerPayloadCost.OutputCosts) (indices : List (Fin 8)) : + (pendingValidityCount context cost indices).2.1.length ≤ indices.length := by + induction indices with + | nil => simp [pendingValidityCount] + | cons i indices ih => + simp only [pendingValidityCount,List.length_cons] + split <;> dsimp only <;> simp only [List.length_cons,List.length_nil] <;> omega + +theorem recordValidityCount_calls (saved : AnchoredHeaderCodec.Record) + (cost : PCSBCSCallerPayloadCost.OutputCosts) : + (recordValidityCount saved cost).2.1.length ≤ 8 := by + have bound := pendingValidityCount_calls saved.context cost (List.ofFn (fun i : Fin 8 => i)) + simp only [List.length_ofFn] at bound + unfold recordValidityCount + split + · split + · exact bound + · simp + · simp + +/-- Exact per-byte answer count; source guards can suppress it but cannot +replace it by one callback per block. The metadata price is supplied outside +the internal parser-operation counter. -/ +theorem parseReferencesCount_answerCalls (p : ParameterBounds.Profile) (layout : CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) (answers : Coordinate → Digest32) + (key : Coordinate) (cost : PCSBCSCallerPayloadCost.OutputCosts) (P : Nat) + (entryCap : framesSize entry.frames ≤ P) : + (parseReferencesCount p layout saved entry answers key cost).2.1 ≤ P*P := by + have bound := (PCSBCSPublicLogParserCost.entryTokensCount_bound entry answers P entryCap).1 + unfold parseReferencesCount + dsimp only + split + · split + · exact bound + · try dsimp only + split + · exact bound + · try dsimp only + split <;> exact bound + · exact Nat.zero_le _ + + +#print axioms recordValidityCount_value +#print axioms parseReferencesCount_value + +#print axioms pendingModelCount_value +#print axioms completedModelCount_value +#print axioms outputKeyCount_value +#print axioms parsePendingKeyCount_value +end Whir.PCSBCSSourceReferenceParserCost diff --git a/verification/whir/Whir/PCSBCSSourceReferencePolynomialBound.lean b/verification/whir/Whir/PCSBCSSourceReferencePolynomialBound.lean new file mode 100644 index 000000000..eccb04ff3 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceReferencePolynomialBound.lean @@ -0,0 +1,495 @@ +import Whir.PCSBCSSourceReferenceParserCost + +/-! Polynomial resource bounds for the literal scheduled-key reconstruction. +The volumes count scalar packets, framed payload bytes, and both ghost cursors; +the fresh-caller component remains its actual reached work. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSSourceReferencePolynomialBound +open Concrete Protocol FiatShamirGame DuplexRefinement WHIRHistory WHIRHistoryKey +open WHIRCallerClaims PCSBCSSourceRootReferences PCSBCSPublicLogParserCost +open PCSBCSSourceReferenceParserCost + + def configSize (c : Config) : Nat := c.folds.size+(schedule c).length+c.logN+1 + def pendingMass (ps : List Pending) : Nat := (ps.map (fun p => p.scalars.length+1)).sum + + theorem pendingMass_length (ps : List Pending) : ps.length ≤ pendingMass ps := by + induction ps with + | nil => simp [pendingMass] + | cons p ps ih => simp only [pendingMass,List.map_cons,List.sum_cons,List.length_cons] at *; omega + + theorem pendingMass_scalars (ps : List Pending) : + (ps.map (fun p => p.scalars.length)).sum ≤ pendingMass ps := by + induction ps with + | nil => simp [pendingMass] + | cons p ps ih => simp only [pendingMass,List.map_cons,List.sum_cons] at *; omega + + theorem modelMass_le_wire (m : Model) : modelMass m ≤ modelWireSize m := by + have h := framesSize_length m.history.frames + unfold modelMass modelWireSize + omega + + theorem absorb_wire (m : Model) (bs : List Byte) : + modelWireSize (modelAbsorb m bs) ≤ modelWireSize m+bs.length := by + unfold modelAbsorb + split + · omega + · simp only [modelWireSize,List.length_append] + split <;> omega + + theorem operation_squeeze_wire (m : Model) (n : Nat) : + modelWireSize (operationCount m (.squeeze n)).1 ≤ modelWireSize m+n+1 := by + have h := closeRun_wire m + have cursor : (closeRun m).consumed = m.consumed := by unfold closeRun; split <;> rfl + simp only [operationCount] + split + · dsimp only; omega + · simp only [closeRunCount_value,modelWireSize] at * + omega + + theorem operation_squeeze_work (m : Model) (n : Nat) : + (operationCount m (.squeeze n)).2 ≤ modelWireSize m+6 := by + have h := (closeRunCount_bound m).trans (Nat.add_le_add_right (modelMass_le_wire m) 3) + simp only [operationCount] + split <;> dsimp only <;> omega + + theorem operation_nonce_wire (m : Model) (bits : Nat) (nonce : Scalar24) : + modelWireSize (operationCount m (.nonce bits nonce)).1 ≤ modelWireSize m+26 := by + have h := closeRun_wire m + simp only [operationCount,closeRunCount_value,modelWireSize,framesSize,List.map_append, + List.sum_append,List.map_cons,List.map_nil,List.sum_cons,List.sum_nil,frameSize,List.length_nil] at * + omega + + theorem operation_nonce_work (m : Model) (bits : Nat) (nonce : Scalar24) : + (operationCount m (.nonce bits nonce)).2 ≤ 2*modelWireSize m+6 := by + have h := (closeRunCount_bound m).trans (Nat.add_le_add_right (modelMass_le_wire m) 3) + have closed := closeRun_mass m + have wire := modelMass_le_wire m + have frames : (closeRun m).history.frames.length ≤ modelWireSize m := by unfold modelMass at closed wire; omega + simp only [operationCount,closeRunCount_value] + omega + + theorem pendingModelCount_wire (m : Model) (p : Pending) : + modelWireSize (pendingModelCount m p).1 ≤ modelWireSize m+26*(p.scalars.length+1) := by + have absorb := absorb_wire m (scalarBytes p.scalars) + simp only [scalarBytes_length] at absorb + unfold pendingModelCount + cases h : p.nonce with + | none => simp only [operationCount]; omega + | some pair => + rcases pair with ⟨bits,nonce⟩ + have ground := operation_nonce_wire (modelAbsorb m (scalarBytes p.scalars)) bits (ByteCodec.encodeE nonce) + simp only [operationCount] at ground ⊢ + omega + + theorem pendingModelCount_work (m : Model) (p : Pending) : + (pendingModelCount m p).2 ≤ 3*modelWireSize m+1000*(p.scalars.length+1) := by + have run : m.run.length ≤ modelWireSize m := by unfold modelWireSize; omega + have absorb := absorb_wire m (scalarBytes p.scalars) + simp only [scalarBytes_length] at absorb + unfold pendingModelCount + cases h : p.nonce with + | none => simp only [operationCount,scalarBytes_length]; omega + | some pair => + rcases pair with ⟨bits,nonce⟩ + have ground := operation_nonce_work (modelAbsorb m (scalarBytes p.scalars)) bits (ByteCodec.encodeE nonce) + simp only [operationCount,scalarBytes_length] at * + omega + + theorem stackWidthCount_work (c : Config) (n : Nat) : + (stackWidthCount c n).2 ≤ 65*configSize c+8 := by + simp only [stackWidthCount,scheduleWork,scalarCountWork,configSize] + have h := Nat.min_le_right n (schedule c).length + omega + + theorem completedModelCount_wire (c : Config) (domain statement : Digest32) + (ps : List Pending) (W : Nat) (width : ∀ n, stackWidth c n ≤ W) : + modelWireSize (completedModelCount c domain statement ps).1 ≤ pendingMass ps*(W+27) := by + induction ps with + | nil => simp [completedModelCount,modelWireSize,framesSize,pendingMass] + | cons p ps ih => + have pending := pendingModelCount_wire (completedModelCount c domain statement ps).1 p + have squeezed := operation_squeeze_wire (pendingModelCount (completedModelCount c domain statement ps).1 p).1 + (stackWidth c ps.length) + have w := width ps.length + simp only [completedModelCount,stackWidthCount,pendingMass,List.map_cons,List.sum_cons] at * + nlinarith + + def modelWorkPolynomial (c : Config) (W b : Nat) : Nat := + (b+1)*(b+1)*(8*(W+27)+65*configSize c+1200) + + theorem modelWorkPolynomial_step (c : Config) (W a b : Nat) (positive : 1 ≤ a) : + modelWorkPolynomial c W b+5*b*(W+27)+1026*a+65*configSize c+18 ≤ + modelWorkPolynomial c W (a+b) := by + let A := 8*(W+27)+65*configSize c+1200 + have coefficient : 5*(W+27) ≤ A := by unfold A; omega + have fixed : 65*configSize c+18 ≤ A := by unfold A; omega + have scalar : 1026 ≤ A := by unfold A; omega + have hb := Nat.mul_le_mul_left b coefficient + have ha := Nat.mul_le_mul_left a scalar + have ab : b ≤ a*b := by simpa only [one_mul] using Nat.mul_le_mul_right b positive + have aa : 1 ≤ a*a := by nlinarith only [positive] + have factors : b+a+1 ≤ a*a+2*a*b+2*a := by nlinarith only [ab,aa,positive] + have increment := Nat.mul_le_mul_right A factors + have rest := Nat.add_le_add (Nat.add_le_add hb ha) fixed + have restBound : 5*b*(W+27)+1026*a+65*configSize c+18 ≤ (b+a+1)*A := by + convert rest using 1 <;> ring + calc + _ ≤ (b+1)*(b+1)*A+(b+a+1)*A := by + convert Nat.add_le_add_left restBound ((b+1)*(b+1)*A) using 1 + dsimp only [modelWorkPolynomial,A] + ring + _ ≤ (b+1)*(b+1)*A+(a*a+2*a*b+2*a)*A := Nat.add_le_add_left increment _ + _ = _ := by unfold modelWorkPolynomial A; ring + + theorem completedModelCount_work (c : Config) (domain statement : Digest32) + (ps : List Pending) (W : Nat) (width : ∀ n, stackWidth c n ≤ W) : + (completedModelCount c domain statement ps).2 ≤ modelWorkPolynomial c W (pendingMass ps) := by + induction ps with + | nil => simp [completedModelCount,modelWorkPolynomial,pendingMass] + | cons p ps ih => + have wire := completedModelCount_wire c domain statement ps W width + have pending := pendingModelCount_work (completedModelCount c domain statement ps).1 p + have pendingWire := pendingModelCount_wire (completedModelCount c domain statement ps).1 p + have squeezed := operation_squeeze_work (pendingModelCount (completedModelCount c domain statement ps).1 p).1 + (stackWidth c ps.length) + have stack := stackWidthCount_work c ps.length + have len := pendingMass_length ps + have lengthCharge : ps.length ≤ pendingMass ps*(W+27) := by nlinarith + have step := modelWorkPolynomial_step c W (p.scalars.length+1) (pendingMass ps) (by omega) + simp only [completedModelCount,stackWidthCount,pendingMass,List.map_cons,List.sum_cons,modelWorkPolynomial] at * + nlinarith + + theorem beforeModelCount_wire (c : Config) (domain statement : Digest32) + (ps : List Pending) (W : Nat) (width : ∀ n, stackWidth c n ≤ W) : + modelWireSize (beforeModelCount c domain statement ps).1 ≤ pendingMass ps*(W+27) := by + cases ps with + | nil => simp [beforeModelCount,completedModelCount,modelWireSize,framesSize,pendingMass] + | cons p ps => + have h := completedModelCount_wire c domain statement ps W width + have k := pendingModelCount_wire (completedModelCount c domain statement ps).1 p + simp only [beforeModelCount,pendingMass,List.map_cons,List.sum_cons] at * + nlinarith + + theorem beforeModelCount_work (c : Config) (domain statement : Digest32) + (ps : List Pending) (W : Nat) (width : ∀ n, stackWidth c n ≤ W) : + (beforeModelCount c domain statement ps).2 ≤ modelWorkPolynomial c W (pendingMass ps) := by + cases ps with + | nil => exact completedModelCount_work c domain statement [] W width + | cons p ps => + have h := completedModelCount_work c domain statement ps W width + have wire := completedModelCount_wire c domain statement ps W width + have k := pendingModelCount_work (completedModelCount c domain statement ps).1 p + have step := modelWorkPolynomial_step c W (p.scalars.length+1) (pendingMass ps) (by omega) + simp only [beforeModelCount,pendingMass,List.map_cons,List.sum_cons,modelWorkPolynomial] at * + nlinarith + + theorem prepend_wire (frames : List Frame) (m : Model) : + modelWireSize (WHIRCallerPrefix.prepend frames m) = framesSize frames+modelWireSize m := by + simp only [WHIRCallerPrefix.prepend,modelWireSize,framesSize,List.map_append,List.sum_append] + omega + + theorem outputKeyCount_wire (c : Config) (entry : FramedHistory) (ps : List Pending) + (block W : Nat) (width : ∀ n, stackWidth c n ≤ W) : + framesSize (outputKeyCount c entry ps block).1.history.frames ≤ + framesSize entry.frames+pendingMass ps*(W+27)+1 := by + have before := beforeModelCount_wire c entry.domain entry.statement ps W width + have close := closeRun_wire (WHIRCallerPrefix.prepend entry.frames (beforeModelCount c entry.domain entry.statement ps).1) + rw [prepend_wire] at close + simp only [outputKeyCount,closeRunCount_value] + unfold modelWireSize at before close + omega + + theorem outputKeyCount_work (c : Config) (entry : FramedHistory) (ps : List Pending) + (block W : Nat) (width : ∀ n, stackWidth c n ≤ W) : + (outputKeyCount c entry ps block).2 ≤ modelWorkPolynomial c W (pendingMass ps)+ + 2*framesSize entry.frames+pendingMass ps*(W+27)+7 := by + have before := beforeModelCount_work c entry.domain entry.statement ps W width + have wire := beforeModelCount_wire c entry.domain entry.statement ps W width + have close := closeRunCount_bound (WHIRCallerPrefix.prepend entry.frames (beforeModelCount c entry.domain entry.statement ps).1) + have mass := modelMass_le_wire (WHIRCallerPrefix.prepend entry.frames (beforeModelCount c entry.domain entry.statement ps).1) + rw [prepend_wire] at mass + have len := framesSize_length entry.frames + simp only [outputKeyCount] + omega + + theorem scheduleGuardWork_bound (c : Config) (ps : List Pending) : + scheduleGuardWork c ps ≤ pendingMass ps*(98*configSize c+37)+32*configSize c+8 := by + have len := pendingMass_length ps + have scalars := pendingMass_scalars ps + unfold scheduleGuardWork scheduleWork scalarCountWork configSize + nlinarith + + theorem phaseWork_bound (c : Config) (ps : List Pending) : + phaseWork c ps ≤ pendingMass ps*(98*configSize c+4106)+8 := by + have len := pendingMass_length ps + have scalars := pendingMass_scalars ps + unfold phaseWork scheduleWork scalarCountWork configSize + nlinarith + + theorem framesSize_drop (fs : List Frame) (n : Nat) : + framesSize (fs.drop n) ≤ framesSize fs := by + induction fs generalizing n with + | nil => simp [framesSize] + | cons f fs ih => + cases n with + | zero => rfl + | succ n => + have h := ih n + simp only [List.drop_succ_cons,framesSize,List.map_cons,List.sum_cons] at h ⊢ + omega + + theorem parseSteps_mass (fs : List Frame) (ps : List Pending) + (parsed : parseSteps fs = some ps) : pendingMass ps ≤ framesSize fs := by + induction fs using (measure List.length).wf.induction generalizing ps with + | h fs ih => + cases fs with + | nil => simp [parseSteps] at parsed; subst ps; simp [pendingMass,framesSize] + | cons f rest => + have restIH := ih rest (by exact Nat.lt_succ_self _) + cases f with + | nonce consumed bits nonce => simp [parseSteps] at parsed + | absorb consumed bytes => + cases rest with + | nil => + simp only [parseSteps] at parsed + cases hs : parseExact (bytes.length/24) bytes with + | none => simp [hs] at parsed + | some xs => + have hx := parseExact_length _ _ _ hs + simp only [hs] at parsed + cases parsed + have hd := Nat.div_le_self bytes.length 24 + simp only [pendingMass,framesSize,List.map_cons,List.map_nil,List.sum_cons,List.sum_nil,frameSize] + omega + | cons next tail => + have tailIH := ih tail (by exact Nat.lt_add_of_pos_right (by decide : 0 < 2)) + cases next with + | nonce nextConsumed bits nonce => + rw [parseSteps] at parsed + cases hs : parseExact (bytes.length/24) bytes with + | none => simp [hs] at parsed + | some xs => + have hx := parseExact_length _ _ _ hs + cases hm : parseSteps tail with + | none => simp [hs,hm] at parsed + | some ms => + simp only [hs,hm] at parsed + cases parsed + have cap := tailIH ms hm + have hd := Nat.div_le_self bytes.length 24 + simp only [pendingMass,framesSize,List.map_cons,List.sum_cons,frameSize] at * + omega + | absorb nextConsumed nextBytes => + rw [parseSteps] at parsed + case x_1 => simp + cases hs : parseExact (bytes.length/24) bytes with + | none => simp [hs] at parsed + | some xs => + have hx := parseExact_length _ _ _ hs + cases hm : parseSteps (.absorb nextConsumed nextBytes::tail) with + | none => simp [hs,hm] at parsed + | some ms => + simp only [hs,hm] at parsed + cases parsed + have cap := restIH ms hm + have hd := Nat.div_le_self bytes.length 24 + simp only [pendingMass,framesSize,List.map_cons,List.sum_cons,frameSize] at * + omega + + theorem pendingValidityCount_work (context : AnchoredHeaderCodec.Context) + (cost : PCSBCSCallerPayloadCost.OutputCosts) (indices : List (Fin 8)) : + (pendingValidityCount context cost indices).2.2 ≤ + (indices.map cost.pending).sum+8*indices.length+1 := by + induction indices with + | nil => simp [pendingValidityCount] + | cons i is ih => + simp only [pendingValidityCount] + split <;> simp only [List.map_cons,List.sum_cons,List.length_cons] <;> omega + + theorem recordValidityCount_work (saved : AnchoredHeaderCodec.Record) + (cost : PCSBCSCallerPayloadCost.OutputCosts) : + (recordValidityCount saved cost).2.2 ≤ (List.ofFn cost.pending).sum+ + saved.point.length+3*saved.shape.logBatch+97 := by + have pending := pendingValidityCount_work saved.context cost (List.ofFn (fun i : Fin 8 => i)) + have shape := PCSBCSCallerPayloadCost.shapeValidWork_le saved.shape + simp only [List.length_ofFn,List.map_ofFn,Function.comp_def] at pending + change (pendingValidityCount saved.context cost (List.ofFn (fun i : Fin 8 => i))).2.2 ≤ + (List.ofFn cost.pending).sum+65 at pending + unfold recordValidityCount + split + · split <;> dsimp only <;> omega + · dsimp only; omega + + theorem recordValidityCount_work_reached (saved : AnchoredHeaderCodec.Record) + (cost : PCSBCSCallerPayloadCost.OutputCosts) : + (recordValidityCount saved cost).2.2 ≤ + (((recordValidityCount saved cost).2.1).map cost.pending).sum+ + saved.point.length+3*saved.shape.logBatch+97 := by + have zeroWork := pendingValidityCount_work saved.context + PCSBCSCallerPayloadCost.OutputCosts.zero (List.ofFn (fun i : Fin 8 => i)) + have zeroCap : (pendingValidityCount saved.context PCSBCSCallerPayloadCost.OutputCosts.zero + (List.ofFn (fun i : Fin 8 => i))).2.2 ≤ 65 := by + simpa [PCSBCSCallerPayloadCost.OutputCosts.zero] using zeroWork + have prices := pendingValidityCount_price_exact saved.context cost (List.ofFn (fun i : Fin 8 => i)) + have shape := PCSBCSCallerPayloadCost.shapeValidWork_le saved.shape + unfold recordValidityCount + split + · split + · dsimp only; omega + · simp only [List.map_nil,List.sum_nil]; omega + · simp only [List.map_nil,List.sum_nil]; omega + + def pendingKeyPolynomial (c : Config) (W P : Nat) : Nat := + (P+1)*(P+2050)+modelWorkPolynomial c W (P+1)+ + 2*(P+1)*(W+27)+(P+1)*(98*configSize c+37)+32*configSize c+ + 10*P+1050 + + theorem parsePendingKeyCount_work (p : ParameterBounds.Profile) (entry : FramedHistory) + (key : Coordinate) (W P : Nat) + (width : ∀ n, stackWidth (ParameterBounds.config p) n ≤ W) + (entryCap : framesSize entry.frames ≤ P) (keyCap : framesSize key.history.frames ≤ P) : + (parsePendingKeyCount p entry key).2 ≤ pendingKeyPolynomial (ParameterBounds.config p) W P := by + let fs := key.history.frames.drop entry.frames.length + have fsCap := (framesSize_drop key.history.frames entry.frames.length).trans keyCap + have steps := (parseStepsCount_bound fs).trans (stepsBudget_polynomial fs) + have stepsCap : (parseStepsCount fs).2 ≤ (P+1)*(P+2050)+1 := by + apply steps.trans + gcongr + have entryLen := (framesSize_length entry.frames).trans entryCap + dsimp only [fs] at stepsCap + have minCap : min entry.frames.length key.history.frames.length ≤ P := + (Nat.min_le_left _ _).trans entryLen + unfold parsePendingKeyCount + cases hs : (parseStepsCount fs).1 with + | none => simp only [fs] at hs; simp only [hs]; unfold pendingKeyPolynomial; omega + | some chronological => + have parsed : parseSteps fs = some chronological := by rw [← parseStepsCount_value,hs] + have mass := (parseSteps_mass fs chronological parsed).trans fsCap + let messages := chronological.reverse++[initialPending] + have messagesMass : pendingMass messages ≤ P+1 := by + simpa only [messages,pendingMass,List.map_append,List.sum_append,List.map_reverse,List.sum_reverse, + List.map_cons,List.map_nil,List.sum_cons,List.sum_nil,initialPending,List.length_nil, + Nat.zero_add,Nat.add_zero] using Nat.add_le_add_right mass 1 + have chronoLen := (pendingMass_length chronological).trans mass + have guard := scheduleGuardWork_bound (ParameterBounds.config p) messages + have modelCap : modelWorkPolynomial (ParameterBounds.config p) W (pendingMass messages) ≤ + modelWorkPolynomial (ParameterBounds.config p) W (P+1) := by unfold modelWorkPolynomial; gcongr + have guardCap : scheduleGuardWork (ParameterBounds.config p) messages ≤ + (P+1)*(98*configSize (ParameterBounds.config p)+37)+32*configSize (ParameterBounds.config p)+8 := by + apply guard.trans + gcongr + have cursorCap : pendingMass messages*(W+27) ≤ (P+1)*(W+27) := by gcongr + simp only [fs] at hs + simp only [hs] + cases key.terminal <;> simp only [] + all_goals try (unfold pendingKeyPolynomial; omega) + rename_i block + have r := outputKeyCount_work (ParameterBounds.config p) entry messages block W width + have wire := outputKeyCount_wire (ParameterBounds.config p) entry messages block W width + unfold coordinateEqWork pendingKeyPolynomial + change _ ≤ _ + dsimp only [messages] at r wire guardCap modelCap cursorCap + nlinarith only [entryCap,keyCap,entryLen,minCap,stepsCap,chronoLen,r,wire,guardCap,modelCap,cursorCap] + + theorem parsePendingKeyCount_mass (p : ParameterBounds.Profile) (entry : FramedHistory) + (key : Coordinate) (messages : List Pending) + (returned : (parsePendingKeyCount p entry key).1 = some messages) : + pendingMass messages ≤ framesSize key.history.frames+1 := by + unfold parsePendingKeyCount at returned + cases hs : (parseStepsCount (key.history.frames.drop entry.frames.length)).1 with + | none => simp [hs] at returned + | some chronological => + have parsed : parseSteps (key.history.frames.drop entry.frames.length) = some chronological := by + rw [← parseStepsCount_value,hs] + have h := (parseSteps_mass _ _ parsed).trans (framesSize_drop key.history.frames entry.frames.length) + simp only [hs] at returned + cases terminal : key.terminal with + | commitment _ => simp [terminal] at returned + | powBase _ _ => simp [terminal] at returned + | output block => + simp only [terminal] at returned + split at returned + · have same := Option.some.inj returned + subst messages + simpa only [pendingMass,List.map_append,List.sum_append,List.map_reverse,List.sum_reverse, + List.map_cons,List.map_nil,List.sum_cons,List.sum_nil,initialPending,List.length_nil, + Nat.zero_add,Nat.add_zero] using Nat.add_le_add_right h 1 + · contradiction + + /-- The exact caller work is exposed, not a source-work certificate. -/ + def reachedCallerWork (p : ParameterBounds.Profile) (layout : CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) + (answers : Coordinate → Digest32) (cost : PCSBCSCallerPayloadCost.OutputCosts) : Nat := + if (recordValidityCount saved cost).1 = true ∧ profileShape p saved.shape then + match (entryTokensCount entry answers).1 with + | none => 0 + | some ts => (PCSBCSCallerPayloadCost.freshInterpret layout saved cost ts).work + else 0 + + theorem parseReferencesCount_work_of_reached (p : ParameterBounds.Profile) (layout : CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) (answers : Coordinate → Digest32) + (key : Coordinate) (cost : PCSBCSCallerPayloadCost.OutputCosts) + (ts : List CallerToken) (messages : List Pending) + (valid : (recordValidityCount saved cost).1 = true ∧ profileShape p saved.shape) + (tokens : (entryTokensCount entry answers).1 = some ts) + (caller : (PCSBCSCallerPayloadCost.freshInterpret layout saved cost ts).value.isSome = true) + (pending : (parsePendingKeyCount p entry key).1 = some messages) : + (parseReferencesCount p layout saved entry answers key cost).2.2 = + (entryTokensCount entry answers).2.2+ + (PCSBCSCallerPayloadCost.freshInterpret layout saved cost ts).work+ + (parsePendingKeyCount p entry key).2+phaseWork (ParameterBounds.config p) messages+ + (recordValidityCount saved cost).2.2+128 := by + cases hc : (PCSBCSCallerPayloadCost.freshInterpret layout saved cost ts).value with + | none => simp [hc] at caller + | some claims => simp only [parseReferencesCount,ite_eq_left valid,tokens,hc,pending] + + theorem parseReferencesCount_work (p : ParameterBounds.Profile) (layout : CallerLayout) + (saved : AnchoredHeaderCodec.Record) (entry : FramedHistory) (answers : Coordinate → Digest32) + (key : Coordinate) (cost : PCSBCSCallerPayloadCost.OutputCosts) (W P : Nat) + (width : ∀ n, stackWidth (ParameterBounds.config p) n ≤ W) + (entryCap : framesSize entry.frames ≤ P) (keyCap : framesSize key.history.frames ≤ P) + (pointCap : saved.point.length ≤ P) (batchCap : saved.shape.logBatch ≤ P) : + (parseReferencesCount p layout saved entry answers key cost).2.2 ≤ + entryParserPolynomial P+reachedCallerWork p layout saved entry answers cost+ + pendingKeyPolynomial (ParameterBounds.config p) W P+ + (P+1)*(98*configSize (ParameterBounds.config p)+4106)+ + (List.ofFn cost.pending).sum+4*P+233 := by + have valid := recordValidityCount_work saved cost + have tokens := (entryTokensCount_bound entry answers P entryCap).2 + have pending := parsePendingKeyCount_work p entry key W P width entryCap keyCap + by_cases gate : (recordValidityCount saved cost).1 = true ∧ profileShape p saved.shape + · simp only [parseReferencesCount,reachedCallerWork,ite_eq_left gate] + cases ht : (entryTokensCount entry answers).1 with + | none => dsimp only; omega + | some ts => + dsimp only + cases hc : (PCSBCSCallerPayloadCost.freshInterpret layout saved cost ts).value with + | none => dsimp only; omega + | some claims => + dsimp only + cases hp : (parsePendingKeyCount p entry key).1 with + | none => dsimp only; omega + | some messages => + dsimp only + have mass := (parsePendingKeyCount_mass p entry key messages hp).trans (Nat.add_le_add_right keyCap 1) + have phase := phaseWork_bound (ParameterBounds.config p) messages + have phaseCap : phaseWork (ParameterBounds.config p) messages ≤ + (P+1)*(98*configSize (ParameterBounds.config p)+4106)+8 := by + apply phase.trans + gcongr + omega + · simp only [parseReferencesCount,reachedCallerWork,ite_eq_right gate] + omega + +#print axioms completedModelCount_work +#print axioms outputKeyCount_wire +#print axioms parseSteps_mass +#print axioms parsePendingKeyCount_work +#print axioms recordValidityCount_work +#print axioms recordValidityCount_work_reached +#print axioms parseReferencesCount_work_of_reached +#print axioms parseReferencesCount_work + +end Whir.PCSBCSSourceReferencePolynomialBound diff --git a/verification/whir/Whir/PCSBCSSourceReferencePolynomialSmoke.lean b/verification/whir/Whir/PCSBCSSourceReferencePolynomialSmoke.lean new file mode 100644 index 000000000..1c6cc1dfa --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceReferencePolynomialSmoke.lean @@ -0,0 +1,48 @@ +import Whir.PCSBCSSourceReferencePolynomialBound + +namespace Whir.PCSBCSSourceReferencePolynomialSmoke +open Concrete Protocol FiatShamirGame DuplexRefinement WHIRHistory WHIRHistoryKey +open PCSBCSPublicLogParserCost PCSBCSSourceReferenceParserCost +open PCSBCSSourceReferencePolynomialBound + +private def require (b : Bool) (message : String) : IO Unit := + unless b do throw (IO.userError message) + + def smoke : IO Unit := do + let p : ParameterBounds.Profile := (⟨0,by decide⟩,⟨0,by decide⟩) + let c := ParameterBounds.config p + let entry : FramedHistory := ⟨zeroDigest,zeroDigest,[]⟩ + let initial := outputKeyCount c entry [initialPending] 0 + let accepted := parsePendingKeyCount p entry initial.1 + require (accepted.1.isSome && initial.2 == 17 && accepted.2 > initial.2) + "initial scheduled key did not succeed with its exact reconstruction charge" + let rejected := parsePendingKeyCount p entry { initial.1 with terminal := .commitment 0 } + require (rejected.1.isNone && rejected.2 == 5 && rejected.2 < accepted.2) + "terminal rejection did not stop before scheduled reconstruction" + let malformed : Coordinate := ⟨{entry with frames := [.nonce 0 1 (ByteCodec.encodeE (E.ofK 0))]},.output 0⟩ + let bad := parsePendingKeyCount p entry malformed + require (bad.1.isNone && bad.2 > 0) "nonce-only rejection lost its parser charge" + let packets : List Pending := + [⟨[E.ofK 0,E.ofK 1],some (3,E.ofK 2)⟩,⟨[E.ofK 3],none⟩,initialPending] + let built := completedModelCount c zeroDigest zeroDigest packets + let before := beforeModelCount c zeroDigest zeroDigest packets + let output := outputKeyCount c entry packets 0 + require (pendingMass packets == 6 && built.2 > before.2 && output.2 > before.2) + "scalar packets, nonce, or final framing were omitted" + require (modelWireSize built.1 ≥ framesSize built.1.history.frames && built.2 > 2700) + "literal scalar encoding or model byte/cursor mass was not charged" + let costs : PCSBCSCallerPayloadCost.OutputCosts := + { call := fun _ => 0, pending := fun i => i.val+10, + rootByte := fun _ => 0, contextByte := fun _ => 0 } + let saved : AnchoredHeaderCodec.Record := + ⟨⟨2,1,1,1⟩,zeroDigest,⟨zeroDigest,fun _ => none,0,true,0,0⟩,[E.ofK 0,E.ofK 0],E.ofK 0⟩ + let valid := recordValidityCount saved costs + require (valid.1 && valid.2.1.length == 8 && valid.2.2 == 210) + "successful validity check omitted pending getter calls" + let invalid := recordValidityCount {saved with context := {saved.context with pending := fun _ => some 0}} costs + require (!invalid.1 && invalid.2.1.length == 1 && invalid.2.2 == 55) + "pending validity rejection did not short-circuit" + IO.println "source reference polynomial recurrence smoke PASS (success/rejection, scalar packets, nonce, frame/cursor volumes, explicit pending getters)" +end Whir.PCSBCSSourceReferencePolynomialSmoke + +def main : IO Unit := Whir.PCSBCSSourceReferencePolynomialSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceRootAdmission.lean b/verification/whir/Whir/PCSBCSSourceRootAdmission.lean new file mode 100644 index 000000000..3f531146d --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceRootAdmission.lean @@ -0,0 +1,587 @@ +import Whir.PCSBCSCapturedSourceTransport +import Whir.PCSBCSConstructionReplayTrace +import Whir.PublicCompressionCouplingCache +import Whir.WHIRRealSimulator +import Whir.PCSBCSNativePhysicalFreeze + +/-! Actual historical pre-#607 source-root scanner admission. The scanner uses +its fixed all-query budget B and the source entry boundary. Earlier direct +queries, guessed chaining values, and repeats are retained. Quietness is the +same complete physical primitive alarm (including its CV late-link targets), +not an additional cryptographic event. A construction freeze may be taken +AFTER the current raw response's nonordinary full path; those calls do not +change the ordinary captured log. -/ +set_option autoImplicit false +set_option maxHeartbeats 1000000 +namespace Whir.PCSBCSSourceRootAdmission +open Concrete Protocol FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open TypedOracleCompiler PublicCompressionProgram PublicMerkleLog +open PCSBCSConstructionReplayTrace PCSBCSSourceRootReferences +open PublicCompressionCouplingRecognition + +private theorem body_mono {small large : DuplexPublicSimulator.PublicLog} + (sub : ∀ e ∈ small, e ∈ large) {cv : Digest32} {ns : List Node} + (body : DuplexPublicSimulator.PublicBody small cv ns) : + DuplexPublicSimulator.PublicBody large cv ns := by + induction body with + | seed member seed => exact .seed (sub _ member) seed + | step member internal child ih => exact .step (sub _ member) internal ih + +private theorem functional_of_auth (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) : DuplexPublicSimulator.Functional log := by + intro n a b ha hb + exact (auth n a ha).symm.trans (auth n b hb) + +private theorem simulator_lookup_eq (log : PublicLog) (n : Node) : + DuplexPublicSimulator.lookup log n = PublicMerkleLog.lookup log n := by + induction log with + | nil => rfl + | cons record log ih => + rcases record with ⟨m,d⟩ + by_cases same : n = m + · simp [DuplexPublicSimulator.lookup,PublicMerkleLog.lookup,List.find?,same] + · have other : m ≠ n := Ne.symm same + simp [DuplexPublicSimulator.lookup,PublicMerkleLog.lookup,List.find?,same,other] at ih ⊢ + exact ih + +/-- Successful extraction of the admitted literal source name fixes every +seed CV and the entire instruction plan, not merely a proposed coordinate. -/ +theorem sourceShape_of_extracted (iv : Digest32) (ns : List Node) (q : Coordinate) + (complete : Complete ns) (valid : DuplexEncoding.Admissible q) + (extracted : extract ns = some (modeKey iv q)) : + PCSBCSSourceCoordinateDecoder.SourceShape iv ns q := by + have fields : (⟨ns.map payload,ns.map (fun n => (n.tweak,n.last))⟩ : Extracted) = + modeKey iv q := by + exact Option.some.inj (by simpa only [extract,(complete?_correct ns).mpr complete, + ite_eq_left] using extracted) + have messages := congrArg Extracted.message fields + have anchored : Anchored iv ns := by + intro n member seed + have present : payload n ∈ (modeKey iv q).message := by + rw [← messages] + exact List.mem_map.mpr ⟨n,member,rfl⟩ + unfold modeKey keyFromPlan at present + obtain ⟨instruction,_,same⟩ := List.mem_map.mp present + have value := congrArg Prod.fst same + simp only [payload,ite_eq_left seed] at value + split at value + · exact (Option.some.inj value).symm + · cases value + have plan := extract_plan ns complete + rw [extracted] at plan + simp only [Option.map_some,PCSBCSSourceCoordinateDecoder.extractedPlan_modeKey, + Option.some.injEq] at plan + exact ⟨complete,anchored,valid,plan.symm⟩ + +/-- Recover at the first physical occurrence, not necessarily at the current +(repeated) terminal. Erasing a later fresh record uses the alarm's CV targets; +erasing a repeat uses its earlier literal record. Thus an arbitrary terminal +prequery is not excluded or hidden from an observer. -/ +theorem first_recovery (C : PrimitiveOracle) (roots : PublicMerkleProbability.RootPolicy) + (B : Nat) (log : PublicLog) (auth : AuthenticLog C log) + (quiet : PublicMerkleProbability.traceAlarm roots [] log.reverse = false) + (budget : log.length ≤ B) (input : Node) (rest : List Node) + (terminal : isTerminal input) + (body : DuplexPublicSimulator.PublicBody log input.cv rest) + (present : (input,C input) ∈ log) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) + (extracted : extract (input::rest) = some (modeKey PCSBCSSourceCoordinateDecoder.seedIV q)) : + ∃ newer older, log = newer ++ (input,C input)::older ∧ + PCSBCSSourceCoordinateDecoder.recover B PCSBCSSourceCoordinateDecoder.seedIV older input = some q := by + induction log with + | nil => cases present + | cons record log ih => + rcases record with ⟨n,d⟩ + have answer := auth n d List.mem_cons_self + subst d + have oldAuth : AuthenticLog C log := fun n d h => auth n d (List.mem_cons_of_mem _ h) + have oldBudget : log.length ≤ B := by simp only [List.length_cons] at budget; omega + have parts := quiet + rw [List.reverse_cons,PublicMerkleProbability.traceAlarm_append] at parts + simp only [Bool.or_eq_false_iff,List.reverse_reverse,List.append_nil, + PublicMerkleProbability.traceAlarm,Bool.or_false,decide_eq_false_iff_not] at parts + have oldQuiet := parts.1 + have safe := parts.2 + cases hit : PublicMerkleLog.lookup log n with + | some d => + have old := PublicMerkleLog.lookup_mem hit + have same := oldAuth n d old + rw [← same] at old + have oldBody := PublicCompressionCouplingRecognition.PublicBody.erase_repeat old body + have oldPresent : (input,C input) ∈ log := by + rcases List.mem_cons.mp present with equal | member + · cases equal; exact old + · exact member + obtain ⟨newer,older,equal,recovered⟩ := ih oldAuth oldQuiet oldBudget oldBody oldPresent + exact ⟨(n,C n)::newer,older,by simp only [List.cons_append,equal],recovered⟩ + | none => + by_cases same : n = input + · subst n + have oldBody := PublicCompressionCouplingRecognition.PublicBody.erase_terminal terminal body + have clean : ¬ DuplexPublicSimulator.OutputCollision log := by + have h := PublicMerkleProbability.traceAlarm_clean C roots [] log.reverse + (by intro n d h; cases h) + (fun n d h => oldAuth n d (List.mem_reverse.mp h)) + (by rintro ⟨a,b,d,h,_⟩; cases h) oldQuiet + simp only [List.reverse_reverse,List.append_nil] at h + exact fun ⟨a,b,d,ha,hb,ne⟩ => h ⟨a,b,d,ha,hb,ne⟩ + have recognized := DuplexPublicSimulator.recognized_complete + (functional_of_auth C log oldAuth) clean terminal oldBody + obtain ⟨key,found,keyExtracted⟩ := DuplexPublicSimulator.privateKey_of_recognized + (by simpa only [simulator_lookup_eq] using hit) recognized budget + have keySame : expandKey key = modeKey PCSBCSSourceCoordinateDecoder.seedIV q := + Option.some.inj (keyExtracted.symm.trans extracted) + exact ⟨[],log,rfl,PCSBCSSourceCoordinateDecoder.recover_of_modeKey found valid keySame⟩ + · have oldPresent : (input,C input) ∈ log := by + rcases List.mem_cons.mp present with equal | member + · exact False.elim (same (congrArg Prod.fst equal).symm) + · exact member + have avoid : ∀ m d, (m,d) ∈ log → C n ≠ m.cv := by + intro m d member equal + apply safe + refine ⟨hit,?_⟩ + apply Finset.mem_union_right + apply Finset.mem_union_right + rw [equal] + exact List.mem_toFinset.mpr (List.mem_map.mpr ⟨(m,d),member,rfl⟩) + have oldBody := PublicCompressionCouplingRecognition.PublicBody.erase_record body avoid + (avoid input (C input) oldPresent) + obtain ⟨newer,older,equal,recovered⟩ := ih oldAuth oldQuiet oldBudget oldBody oldPresent + exact ⟨(n,C n)::newer,older,by simp only [List.cons_append,equal],recovered⟩ + +private theorem targets_append (p : ParameterBounds.Profile) (B boundary : Nat) + (registry : AnchoredHeaderRoots.Public) (newer older : PublicLog) : + PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry older ⊆ + PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry (newer++older) := by + induction newer with + | nil => exact fun _ h => h + | cons record newer ih => + exact fun _ h => PCSBCSSourcePrimitiveRootBudget.targets_grow p B boundary registry _ _ (ih h) + +/-- Public native role parsing is sufficient: no root-membership or recovered +coordinate is assumed. This inner lemma consumes physical tree provenance; +its actual-source endpoints below produce that provenance from compilation. -/ +theorem tree_target (p : ParameterBounds.Profile) (B boundary : Nat) + (registry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) [] log.reverse = false) + (budget : log.length ≤ B) (input : Node) (rest : List Node) + (terminal : isTerminal input) (body : DuplexPublicSimulator.PublicBody log input.cv rest) + (present : (input,C input) ∈ log) (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (extracted : extract (input::rest) = some (modeKey PCSBCSSourceCoordinateDecoder.seedIV q)) + (refs : List Reference) + (parsed : PCSBCSSourcePrimitiveRootBudget.openingReferences p boundary q = some refs) + (ref : Reference) (member : ref ∈ refs) : + ref.root ∈ PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry log := by + obtain ⟨newer,older,equal,recovered⟩ := first_recovery C _ B log auth quiet budget + input rest terminal body present q valid extracted + have reference : ref ∈ PCSBCSSourcePrimitiveRootBudget.references p B boundary registry older input := by + simp only [PCSBCSSourcePrimitiveRootBudget.references,recovered,Option.map_some, + Option.getD_some,parsed] + exact List.mem_append_right _ member + have announced : ref.root ∈ PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry + ((input,C input)::older) := by + simp only [PCSBCSSourcePrimitiveRootBudget.targets,List.mem_toFinset,List.mem_map, + PCSBCSSourcePrimitiveRootBudget.scan_cons] + refine ⟨⟨older,ref.root,ref.shape⟩,List.mem_append_right _ ?_,rfl⟩ + exact List.mem_map.mpr ⟨ref,reference,rfl⟩ + rw [equal] + exact targets_append p B boundary registry newer _ announced + +private def planTrace (C : PrimitiveOracle) (cv : Digest32) + (instructions : List DuplexEncoding.Instruction) : PublicLog := + toLog (Sampling.execute C (planCalls cv instructions)).2 + +private theorem planCalls_append_trace (C : PrimitiveOracle) (cv : Digest32) + (left right : List DuplexEncoding.Instruction) : + planTrace C cv (left++right) = + planTrace C cv left ++ + planTrace C (evalPlan (compressionOf C) cv left) right := by + induction left generalizing cv with + | nil => rfl + | cons instruction left ih => + simpa only [planTrace,List.cons_append,planCalls,Sampling.execute,toLog,List.map_cons, + evalPlan,List.foldl_cons,List.cons_append,compressionOf] using congrArg + (fun log => (⟨cv,instruction.1,instruction.2,true⟩, + C ⟨cv,instruction.1,instruction.2,true⟩)::log) (ih _) + +private theorem tree_plan (C : PrimitiveOracle) (iv : Digest32) {cv : Digest32} + {ns : List Node} (tree : Tree (compressionOf C) cv ns) (anchored : Anchored iv ns) : + evalPlan (compressionOf C) iv (rawPlan ns) = cv ∧ + planTrace C iv (rawPlan ns) = + (ns.map (fun n => (n,C n))).reverse := by + induction tree with + | seed n seed => + have initial := anchored n List.mem_cons_self seed + have last : n.last = true := seed.2 + have canonical : (⟨iv,n.block,n.tweak,true⟩ : Node) = n := by + cases n + simp_all only + constructor + · simp only [rawPlan,List.reverse_cons,List.reverse_nil,List.nil_append, + List.map_cons,List.map_nil,evalPlan,List.foldl_cons,List.foldl_nil,compressionOf] + rw [canonical] + rfl + · simp only [rawPlan,List.reverse_singleton,List.map_cons,List.map_nil] + simp only [planTrace,planCalls,Sampling.execute,toLog,List.map_cons,List.map_nil] + rw [canonical] + | step n ns internal child ih => + have oldAnchor : Anchored iv ns := fun m hm hs => anchored m (List.mem_cons_of_mem _ hm) hs + have previous := ih oldAnchor + have last : n.last = true := internal.2 + have plan : rawPlan (n::ns) = rawPlan ns ++ [(n.block,n.tweak)] := by + simp only [rawPlan,List.reverse_cons,List.map_append,List.map_singleton] + rw [plan] + constructor + · rw [evalPlan,List.foldl_append] + change evalPlan (compressionOf C) (evalPlan (compressionOf C) iv (rawPlan ns)) + [(n.block,n.tweak)] = nodeValue (compressionOf C) n + rw [previous.1] + simp only [evalPlan,List.foldl_cons,List.foldl_nil,nodeValue,compressionOf,last] + · rw [planCalls_append_trace,previous.1,previous.2] + have canonical : (⟨n.cv,n.block,n.tweak,true⟩ : Node) = n := by + cases n + simp_all only + simp only [planTrace,planCalls,Sampling.execute,toLog,List.map_cons,List.map_nil,List.reverse_cons] + rw [canonical] + +/-- The complete literal construction contributes its terminal and every body +record, including when all inputs have already been queried. -/ +theorem construction_body (C : PrimitiveOracle) (iv : Digest32) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (log : PublicLog) + (present : ∀ e ∈ queryTrace C iv (.construction q valid), e ∈ log) : + let t := traceHistory (compressionOf C) iv q.history + DuplexPublicSimulator.PublicBody log t.state.cv t.nodes ∧ + (terminalNode t.state.cv q.terminal,C (terminalNode t.state.cv q.terminal)) ∈ log := by + dsimp only + have tree := (traceHistory_valid (compressionOf C) iv q.history valid.1).1 + have trace : queryTrace C iv (.construction q valid) = + ((coordinateTree (compressionOf C) iv q).map (fun n => (n,C n))).reverse := by + change planTrace C iv (DuplexEncoding.plan q) = _ + rw [← coordinateTree_plan (compressionOf C) iv q] + unfold coordinateTree rawPlan + rw [List.reverse_cons,List.map_append,List.map_singleton,planCalls_append_trace] + have bodyPlan := tree_plan C iv tree (traceHistory_anchored (compressionOf C) iv q.history valid.1) + unfold rawPlan at bodyPlan + rw [bodyPlan.1,bodyPlan.2] + have last : (terminalNode (traceHistory (compressionOf C) iv q.history).state.cv q.terminal).last = true := + (terminal_node _ _).2 + cases q.terminal <;> + simp [planTrace,planCalls,Sampling.execute,toLog,terminalNode,List.reverse_cons] + have nodes : ∀ n ∈ coordinateTree (compressionOf C) iv q, (n,C n) ∈ log := by + intro n member + apply present + rw [trace] + exact List.mem_reverse.mpr (List.mem_map.mpr ⟨n,member,rfl⟩) + constructor + · have convert : ∀ {cv : Digest32} {ns : List Node}, + Tree (compressionOf C) cv ns → + (∀ n ∈ ns, (n,C n) ∈ log) → DuplexPublicSimulator.PublicBody log cv ns := by + intro cv ns tree + induction tree with + | seed n seed => intro recorded; exact .seed (recorded n List.mem_cons_self) seed + | step n ns internal child ih => + intro recorded + exact .step (recorded n List.mem_cons_self) internal + (ih (fun m hm => recorded m (List.mem_cons_of_mem _ hm))) + exact convert tree (fun n hn => nodes n (List.mem_cons_of_mem _ hn)) + · exact nodes _ List.mem_cons_self + +/-- The public boundary recovers the admitted packet's actual live entry for +every continuation block; B is the whole budget, not this packet's ancestry. -/ +theorem packet_entry {p : ParameterBounds.Profile} {B boundary : Nat} {iv : Digest32} + (packet : PCSBCSChallengeOracle.EnteredPacket p B iv boundary) + (block : PCSBCSChallengeOracle.EnteredPacket.Block packet) : + PCSBCSSourcePrimitiveRootBudget.entry (packet.2.2.coordinate block) boundary = packet.1.val := by + have history := WHIRCallerPrefix.outputKeyFrom_history _ + (WHIRHistoryKey.stackWidth_positive p) packet.1.val + (WHIRHistoryKey.scheduled_normal _ _ packet.2.2.nonempty packet.2.2.admitted) block.val + unfold PCSBCSSourcePrimitiveRootBudget.entry PCSBCSChallengeOracle.SourcePacket.coordinate + rw [history] + have take : (packet.1.val.frames ++ WHIRHistoryKey.canonicalFrames + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) packet.2.messages).take boundary = + packet.1.val.frames := by + exact (congrArg (fun n => (packet.1.val.frames ++ WHIRHistoryKey.canonicalFrames + (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) packet.2.messages).take n) + packet.1.property).symm.trans List.take_left + change {packet.1.val with frames := (packet.1.val.frames ++ + WHIRHistoryKey.canonicalFrames (WHIRHistoryKey.stackWidth (ParameterBounds.config p)) + packet.2.messages).take boundary} = packet.1.val + rw [take] + +theorem packet_openingReferences {p : ParameterBounds.Profile} {B boundary : Nat} + (packet : PCSBCSChallengeOracle.EnteredPacket p B PCSBCSSourceCoordinateDecoder.seedIV boundary) + (block : PCSBCSChallengeOracle.EnteredPacket.Block packet) : + (PCSBCSSourcePrimitiveRootBudget.openingReferences p boundary + (packet.2.2.coordinate block)).getD [] = + PCSBCSCapturedSourceTransport.address (.inl packet) := by + unfold PCSBCSSourcePrimitiveRootBudget.openingReferences + rw [packet_entry] + have pending := parsePendingKey_roundtrip p packet.1.val packet.2.messages + packet.2.2.nonempty packet.2.2.admitted block.val + have first := parsePendingKey_roundtrip p packet.1.val packet.2.messages + packet.2.2.nonempty packet.2.2.admitted 0 + dsimp only [PCSBCSChallengeOracle.CanonicalPacket.messages] at pending first + simp only [PCSBCSCapturedSourceTransport.address, + PCSBCSSourcePrimitiveRootBudget.openingReferencesFromEntry, + PCSBCSChallengeOracle.SourcePacket.coordinate, + PCSBCSChallengeOracle.CanonicalPacket.messages,pending,first] + +/-- An actual mixed raw draw and its public byte-only address determine a +literal admitted source coordinate. In the primitive branch, recognition and +public-body provenance are obtained from the compiler's actual privateKey; +in the construction branch they are obtained from its complete physical path. -/ +theorem draw_admission (p : ParameterBounds.Profile) (B boundary : Nat) + (registry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (earlier cache : PublicLog) (current : Observation) + (event : PCSBCSNativePhysicalFreeze.RawEvent B) + (cacheSub : ∀ e ∈ cache, e ∈ earlier) + (auth : AuthenticLog C (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query)) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) [] + (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query) = false) + (budget : (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query).length ≤ B) + (draw : PCSBCSNativePublicCapture.observationDraw B PCSBCSSourceCoordinateDecoder.seedIV cache current = [event]) + (ref : Reference) + (mentioned : ref ∈ PCSBCSCapturedSourceTransport.address + (PCSBCSNativePublicCapture.allocatedKey (p := p) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) event.1)) : + ∃ (packet : PCSBCSChallengeOracle.EnteredPacket p B PCSBCSSourceCoordinateDecoder.seedIV boundary) + (block : PCSBCSChallengeOracle.EnteredPacket.Block packet), + event.1 = .inr (packet.2.2.key block) ∧ + ref.root ∈ PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry + (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query).reverse ∧ + ∃ input newer older, + (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query).reverse = + newer ++ (input,C input)::older ∧ + PCSBCSSourceCoordinateDecoder.recover B PCSBCSSourceCoordinateDecoder.seedIV older input = + some (packet.2.2.coordinate block) := by + classical + let part := PCSBCSChallengeOracle.EnteredPacket.partition + (p := p) (Q := B) (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) + unfold PCSBCSNativePublicCapture.allocatedKey at mentioned + split at mentioned + next source found => + have raw := part.encode_recognize event.1 source found + change Sum.inr (source.1.2.2.key source.2) = event.1 at raw + have addressed : ref ∈ PCSBCSCapturedSourceTransport.address (.inl source.1) := mentioned + have role := packet_openingReferences source.1 source.2 + cases parsed : PCSBCSSourcePrimitiveRootBudget.openingReferences p boundary + (source.1.2.2.coordinate source.2) with + | none => simp only [parsed,Option.getD_none] at role; rw [← role] at addressed; cases addressed + | some refs => + have member : ref ∈ refs := by + rw [← role] at addressed + simpa only [parsed,Option.getD_some] using addressed + have prefixAuth : AuthenticLog C + (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query).reverse := + fun n d h => auth n d (List.mem_reverse.mp h) + have prefixQuiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) [] + ((earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query).reverse).reverse = false := by + simpa only [List.reverse_reverse] using quiet + have prefixBudget : (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query).reverse.length ≤ B := by + simpa only [List.length_reverse] using budget + rcases current with ⟨query,d⟩ + cases query with + | primitive purpose input => + unfold PCSBCSNativePublicCapture.observationDraw at draw + cases hit : DuplexPublicSimulator.lookup cache input with + | some old => simp [hit] at draw + | none => + cases key : DuplexPublicSimulator.privateKey B cache input with + | none => + simp only [hit,key,List.singleton_inj] at draw + have impossible := congrArg Sigma.fst draw + rw [← raw] at impossible + cases impossible + | some actual => + simp only [hit,key,List.singleton_inj] at draw + have keys : actual = source.1.2.2.key source.2 := + Sum.inr.inj ((congrArg Sigma.fst draw).trans raw.symm) + obtain ⟨nodes,recognized,complete,extracted⟩ := DuplexPublicSimulator.privateKey_sound key + obtain ⟨rest,rfl,body⟩ := DuplexPublicSimulator.recognized_publicBody recognized + have terminal : isTerminal input := by + obtain ⟨n,ns,equal,terminal,_⟩ := complete + cases equal + exact terminal + have publicBody : DuplexPublicSimulator.PublicBody + (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV (.primitive purpose input)).reverse + input.cv rest := body_mono + (fun e he => List.mem_reverse.mpr (List.mem_append_left _ (cacheSub e he))) body + have recorded : (input,C input) ∈ + (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV (.primitive purpose input)).reverse := by + exact List.mem_reverse.mpr (List.mem_append_right _ List.mem_cons_self) + have sourceExtract : extract (input::rest) = + some (modeKey PCSBCSSourceCoordinateDecoder.seedIV (source.1.2.2.coordinate source.2)) := by + rw [keys] at extracted + exact extracted.trans (congrArg some (expand_constructionKey B + PCSBCSSourceCoordinateDecoder.seedIV (source.1.2.2.coordinate source.2) + (source.1.2.2.pathBound source.2))) + have shape := sourceShape_of_extracted PCSBCSSourceCoordinateDecoder.seedIV + (input::rest) (source.1.2.2.coordinate source.2) complete (source.1.2.2.valid source.2) sourceExtract + have target := tree_target p B boundary registry C _ prefixAuth prefixQuiet prefixBudget + input rest terminal publicBody recorded _ shape.2.2.1 + sourceExtract refs parsed ref member + obtain ⟨newer,older,equal,recovered⟩ := first_recovery C _ B _ prefixAuth prefixQuiet prefixBudget + input rest terminal publicBody recorded _ shape.2.2.1 sourceExtract + exact ⟨source.1,source.2,raw.symm,target,input,newer,older,equal,recovered⟩ + | construction coordinate valid => + change (if bound : pathCost coordinate ≤ B then + [⟨.inr (constructionKey B PCSBCSSourceCoordinateDecoder.seedIV coordinate bound),d⟩] + else []) = [event] at draw + split at draw + next bound => + have keys : constructionKey B PCSBCSSourceCoordinateDecoder.seedIV coordinate bound = + source.1.2.2.key source.2 := + Sum.inr.inj ((congrArg Sigma.fst (List.singleton_inj.mp draw)).trans raw.symm) + have same : coordinate = source.1.2.2.coordinate source.2 := + constructionKey_injective B PCSBCSSourceCoordinateDecoder.seedIV valid + (source.1.2.2.valid source.2) bound (source.1.2.2.pathBound source.2) keys + cases same + obtain ⟨body,recorded⟩ := construction_body C PCSBCSSourceCoordinateDecoder.seedIV + (source.1.2.2.coordinate source.2) (source.1.2.2.valid source.2) + (earlier ++ queryTrace C PCSBCSSourceCoordinateDecoder.seedIV + (.construction (source.1.2.2.coordinate source.2) valid)).reverse + (fun e he => List.mem_reverse.mpr (List.mem_append_right _ he)) + have cv : (terminalNode + (traceHistory (compressionOf C) PCSBCSSourceCoordinateDecoder.seedIV + (source.1.2.2.coordinate source.2).history).state.cv + (source.1.2.2.coordinate source.2).terminal).cv = + (traceHistory (compressionOf C) PCSBCSSourceCoordinateDecoder.seedIV + (source.1.2.2.coordinate source.2).history).state.cv := by + cases (source.1.2.2.coordinate source.2).terminal <;> rfl + rw [← cv] at body + have terminal := terminal_node + (traceHistory (compressionOf C) PCSBCSSourceCoordinateDecoder.seedIV + (source.1.2.2.coordinate source.2).history).state.cv + (source.1.2.2.coordinate source.2).terminal + have extracted := coordinateTree_key (compressionOf C) PCSBCSSourceCoordinateDecoder.seedIV + (source.1.2.2.coordinate source.2) (source.1.2.2.valid source.2) + have shape := PCSBCSSourceCoordinateDecoder.coordinateTree_sourceShape + (compressionOf C) PCSBCSSourceCoordinateDecoder.seedIV + (source.1.2.2.coordinate source.2) (source.1.2.2.valid source.2) + have target := tree_target p B boundary registry C _ prefixAuth prefixQuiet prefixBudget + _ _ terminal body recorded _ shape.2.2.1 extracted refs parsed ref member + obtain ⟨newer,older,equal,recovered⟩ := first_recovery C _ B _ prefixAuth prefixQuiet prefixBudget + _ _ terminal body recorded _ shape.2.2.1 extracted + exact ⟨source.1,source.2,raw.symm,target,_,newer,older,equal,recovered⟩ + next => simp at draw + next => simp only [PCSBCSCapturedSourceTransport.address,List.not_mem_nil] at mentioned + +/-- Actual complete first-mention endpoint. All low-level provenance and freeze +conditions come from the whole fixed compiler and actual table; only its +Counts/source admission, fixed PARAM_IV, and the SAME global alarm are used. +No recovered key, recognized tree, root target, or observer exclusion is a +precondition. -/ +theorem actual_firstMention_admitted {R : Type} (p : ParameterBounds.Profile) + (B boundary : Nat) (registry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (ref : Reference) + (events : List (Sigma (PCSBCSSourceRootCapture.Answer + (p := p) (Q := B) (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)))) + (mentioned : PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)) ref + (PCSBCSNativePhysicalFreeze.allocationProgram (p := p) (boundary := boundary) program A limit counted) + (PCSBCSNativePhysicalFreeze.actualTable (p := p) (B := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) C) = some events) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) [] + (primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV program A counted) = false) : + ∃ frozen : PCSBCSNativePhysicalFreeze.PhysicalFreeze + (primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV program A counted) + (PCSBCSNativePhysicalFreeze.actualSourceLog (p := p) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) C program A limit counted ref), + ref.root ∈ PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry frozen.before.reverse ∧ + ∃ (packet : PCSBCSChallengeOracle.EnteredPacket p B PCSBCSSourceCoordinateDecoder.seedIV boundary) + (block : PCSBCSChallengeOracle.EnteredPacket.Block packet) (input : Node) (newer older : PublicLog), + frozen.before.reverse = newer ++ (input,C input)::older ∧ + PCSBCSSourceCoordinateDecoder.recover B PCSBCSSourceCoordinateDecoder.seedIV older input = + some (packet.2.2.coordinate block) := by + obtain ⟨earlier,current,later,cache,event,next,observations,reached,draw,addressed,cacheSub, + cacheAuth,split,sub,saturated⟩ := + PCSBCSNativePhysicalFreeze.source_firstMention_freeze (p := p) (boundary := boundary) + C program A limit counted PCSBCSCapturedSourceTransport.address (by intro other; rfl) + ref events mentioned + have auth : AuthenticLog C (PCSBCSNativePhysicalFreeze.physicalTrace C + PCSBCSSourceCoordinateDecoder.seedIV earlier ++ + queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query) := by + intro n d member + apply primitiveLog_authentic C PCSBCSSourceCoordinateDecoder.seedIV program A counted n d + rw [split] + exact List.mem_append_left _ member + have prefixQuiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) [] + (PCSBCSNativePhysicalFreeze.physicalTrace C PCSBCSSourceCoordinateDecoder.seedIV earlier ++ + queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query) = false := by + rw [split,PublicMerkleProbability.traceAlarm_append] at quiet + exact (Bool.or_eq_false_iff.mp quiet).1 + have prefixBudget : (PCSBCSNativePhysicalFreeze.physicalTrace C + PCSBCSSourceCoordinateDecoder.seedIV earlier ++ + queryTrace C PCSBCSSourceCoordinateDecoder.seedIV current.query).length ≤ B := by + have bound := primitiveLog_length C PCSBCSSourceCoordinateDecoder.seedIV program A counted + rw [split,List.length_append] at bound + omega + obtain ⟨packet,block,_,target,input,newer,older,equal,recovered⟩ := + draw_admission p B boundary registry C _ cache current event cacheSub auth prefixQuiet prefixBudget + draw ref addressed + exact ⟨⟨_,_,split,sub,saturated⟩,target,packet,block,input,newer,older,equal,recovered⟩ + +section CountedWhole +variable (cap : Nat) + (nativeRegistry : {r : WHIRPhysicalDriver.ProductionRegistry // + r.context.iv = PCSBCSSourceCoordinateDecoder.seedIV}) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap + (AnchoredPhysicalAfter.Input nativeRegistry.val.context Q)) + (a b : Nat) (attackerCounted : WHIRSourceChronology.Counts a attacker) + (nativeBudget : WHIRSourceBackfill.AllResults + (fun input => WHIRPhysicalVerifier.sourceBudget nativeRegistry.val.context Q input.packet ≤ b) + (WHIRSourceChronology.erase attacker)) +local notation "whole" => PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q attacker +local notation "counted" => PCSBCSNativePhysicalFreeze.whole_counted + cap nativeRegistry.val Q attacker a b attackerCounted nativeBudget + +/-- Arbitrary attacker Source operations precede the native program. The +attacker Counts and reachable native sourceBudget check derive the WHOLE +Counts certificate; Q remains the native packet bound, B the scanner cap. -/ +theorem counted_whole_firstMention_admitted (p : ParameterBounds.Profile) (B boundary : Nat) + (registry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) (limit : a+b ≤ B) + (ref : Reference) + (events : List (Sigma (PCSBCSSourceRootCapture.Answer + (p := p) (Q := B) (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)))) + (mentioned : PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary)) ref + (PCSBCSNativePhysicalFreeze.allocationProgram (p := p) (boundary := boundary) + whole (a+b) limit counted) + (PCSBCSNativePhysicalFreeze.actualTable (p := p) (B := B) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) C) = some events) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry) [] + (primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV whole (a+b) counted) = false) : + ∃ frozen : PCSBCSNativePhysicalFreeze.PhysicalFreeze + (primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV whole (a+b) counted) + (PCSBCSNativePhysicalFreeze.actualSourceLog (p := p) + (iv := PCSBCSSourceCoordinateDecoder.seedIV) (boundary := boundary) + C whole (a+b) limit counted ref), + ref.root ∈ PCSBCSSourcePrimitiveRootBudget.targets p B boundary registry frozen.before.reverse ∧ + ∃ (packet : PCSBCSChallengeOracle.EnteredPacket p B PCSBCSSourceCoordinateDecoder.seedIV boundary) + (block : PCSBCSChallengeOracle.EnteredPacket.Block packet) (input : Node) (newer older : PublicLog), + frozen.before.reverse = newer ++ (input,C input)::older ∧ + PCSBCSSourceCoordinateDecoder.recover B PCSBCSSourceCoordinateDecoder.seedIV older input = + some (packet.2.2.coordinate block) := + actual_firstMention_admitted p B boundary registry C whole (a+b) limit counted ref events mentioned quiet +end CountedWhole + +#print axioms sourceShape_of_extracted +#print axioms first_recovery +#print axioms construction_body +#print axioms packet_entry +#print axioms packet_openingReferences +#print axioms draw_admission +#print axioms actual_firstMention_admitted +#print axioms counted_whole_firstMention_admitted + +end Whir.PCSBCSSourceRootAdmission diff --git a/verification/whir/Whir/PCSBCSSourceSavedRecordDecoder.lean b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoder.lean new file mode 100644 index 000000000..c66d74810 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoder.lean @@ -0,0 +1,307 @@ +import Whir.AnchoredSourceFreshCaller + +/-! Literal saved-record recovery for the frozen PR600 source at `12eea88c`, +through the existing hand-port `AnchoredHeaderCodec`. The only external selection +input is a supported production profile; roots, contexts, lanes, points and +values are decoded, not supplied. The byte boundary is the existing +`WHIRHistory.parseFrames`, not a new token serialization. Native caller success +must establish that its literal final sent run ends in the saved opening; this +module proves byte-parser and complete record recovery, not that native-refinement +obligation or deployed universal observer refinement. -/ +namespace Whir.PCSBCSSourceSavedRecordDecoder +open Concrete FiatShamirGame AnchoredHeaderCodec + +set_option maxHeartbeats 0 +set_option maxRecDepth 10000 + +def Compatible (p : ParameterBounds.Profile) (r : Record) : Prop := + r.shape.logN = (ParameterBounds.config p).logN ∧ + r.shape.logBatch = (ParameterBounds.config p).folds[0]! ∧ + r.shape.logRate = (ParameterBounds.config p).rates[0]! + +instance (p : ParameterBounds.Profile) (r : Record) : Decidable (Compatible p r) := + inferInstanceAs (Decidable (_ ∧ _ ∧ _)) + +def words (packs : List E) : List K := packs.flatMap fun x => [x.c0,x.c1,x.c2] + +theorem words_length (packs : List E) : (words packs).length = 3*packs.length := by + induction packs with + | nil => rfl + | cons x xs ih => + simp only [words,List.flatMap_cons,List.length_append,List.length_cons, + List.length_nil] at * + omega + +def pending (n : Nat) (packs : List E) : Fin 8 → Option K := fun i => + if i.val < (n+7)/8 then some ((words packs)[i.val]?.getD 0) else none + +theorem pending_recovery (c : Context) (h : c.Valid) : + pending c.pendingBytes (pendingPacks c) = c.pending := by + funext i + have hn := h.1 + have hi := h.2 i + generalize he : c.pendingBytes = n at * + interval_cases n <;> fin_cases i <;> + simp_all [pending,words,pendingPacks,List.range_succ] <;> + cases hx : c.pending _ <;> simp_all + +theorem halves_recovery (d : Digest32) : + ByteCodec.scalarHalves ((ByteCodec.hashToScalars d).1, + (ByteCodec.hashToScalars d).2) = d := by + have h := ByteCodec.scalarsToHash_hashToScalars d + simpa [ByteCodec.scalarsToHash,ByteCodec.hashToScalars] using h + +theorem first_recovery (b : Bool) : ((if b then (1 : K) else 0) == 1) = b := by + cases b <;> decide + +def reconstruct : List E → Option Record + | _marker :: shape :: lanes :: a :: b :: cv0 :: cv1 :: metadata :: squeezed :: tail => + let n := metadata.c0.toNat + some { shape := ⟨shape.c0.toNat,shape.c1.toNat,shape.c2.toNat,lanes.c0.toNat⟩ + root := ByteCodec.scalarHalves (a,b) + context := { cv := ByteCodec.scalarHalves (cv0,cv1) + pending := pending n tail + pendingBytes := n + first := metadata.c1 == 1 + previous := metadata.c2 + squeezed := squeezed.c0 } + point := (tail.drop ((n+23)/24)).dropLast + value := tail.getLast?.getD 0 } + | _ => none + +theorem pending_prefix (n : Nat) (packs rest : List E) + (h : (n+7)/8 ≤ 3*packs.length) : + pending n (packs ++ rest) = pending n packs := by + funext i + unfold pending + split + · rename_i hi + have hw := words_length packs + have bound : i.val < (words packs).length := by rw [hw]; omega + simp only [words,List.flatMap_append] at * + rw [List.getElem?_append_left bound] + · rfl + +theorem reconstruct_opening (r : Record) (h : r.Valid) : + reconstruct (openingScalars r) = some r := by + have hs := h.1 + have hb : r.context.pendingBytes < 2^64 := by have := h.2.1.1; omega + have hn : r.shape.logN < 2^64 := by have := hs.2.1; omega + have ht : r.shape.logBatch < 2^64 := by have := hs.1; have := hs.2.1; omega + have hr : r.shape.logRate < 2^64 := by have := hs.2.2.2.1; omega + have hl : r.shape.lanes < 2^64 := by + have batchBound : r.shape.logBatch < 64 := Nat.lt_trans hs.1 hs.2.1 + have hp : 2^r.shape.logBatch < 2^64 := Nat.pow_lt_pow_right (by decide) batchBound + have := hs.2.2.2.2.2 + omega + have lengths : (pendingPacks r.context).length = (r.context.pendingBytes+23)/24 := by + simp [pendingPacks] + have cap : (r.context.pendingBytes+7)/8 ≤ 3*(pendingPacks r.context).length := by + rw [lengths]; omega + simp only [openingScalars,List.cons_append,List.nil_append,reconstruct, + shapeScalar,lanesScalar,UInt64.toNat_ofNat',Nat.mod_eq_of_lt hn, + Nat.mod_eq_of_lt ht,Nat.mod_eq_of_lt hr,Nat.mod_eq_of_lt hl,Nat.mod_eq_of_lt hb, + List.append_assoc] + rw [pending_prefix _ _ _ cap,pending_recovery _ h.2.1] + rw [← lengths,List.drop_left] + simp only [List.dropLast_concat,List.getLast?_append,List.getLast?_singleton, + Option.some_or,Option.getD_some,halves_recovery] + rw [first_recovery] + +def parse (p : ParameterBounds.Profile) (xs : List E) : Option Record := + (reconstruct xs).bind fun r => + if r.Valid ∧ Compatible p r ∧ openingScalars r = xs then some r else none + +theorem parse_opening (p : ParameterBounds.Profile) (r : Record) + (h : r.Valid) (hp : Compatible p r) : parse p (openingScalars r) = some r := by + simp [parse,reconstruct_opening r h,h,hp] + +theorem parse_sound (p : ParameterBounds.Profile) (xs : List E) (r : Record) + (h : parse p xs = some r) : r.Valid ∧ Compatible p r ∧ openingScalars r = xs := by + unfold parse at h + cases he : reconstruct xs with + | none => simp [he] at h + | some s => + simp only [he,Option.bind_some] at h + split at h + · rename_i guard; cases h; exact guard + · contradiction + +theorem opening_injective (r s : Record) (hr : r.Valid) (hs : s.Valid) + (h : openingScalars r = openingScalars s) : r = s := by + have := congrArg reconstruct h + simpa [reconstruct_opening r hr,reconstruct_opening s hs] using this + +theorem shape_not_marker (s : Shape) (h : s.Valid) : shapeScalar s ≠ openingMarker := by + intro he + have hh := congrArg E.c0 he + have hn : (UInt64.ofNat s.logN).toNat = s.logN := by + rw [UInt64.toNat_ofNat',Nat.mod_eq_of_lt (by have := h.2.1; omega)] + have := congrArg UInt64.toNat hh + simp only [shapeScalar,openingMarker] at this + rw [hn] at this + have := h.2.1 + norm_num at * + omega + +theorem lanes_not_marker (s : Shape) : lanesScalar s ≠ openingMarker := by + intro he + have := congrArg E.c1 he + norm_num [lanesScalar,openingMarker] at this + +theorem rate_nonzero (s : Shape) (h : s.Valid) : (shapeScalar s).c2 ≠ 0 := by + intro he + have hn : (UInt64.ofNat s.logRate).toNat = s.logRate := by + rw [UInt64.toNat_ofNat',Nat.mod_eq_of_lt (by have := h.2.2.2.1; omega)] + have := congrArg UInt64.toNat he + simp only [shapeScalar] at this + rw [hn] at this + have := h.2.2.1 + norm_num at * + omega + +/-- There is no valid opening starting one, two or three scalars into another. +At offset three the root's second half, not its first, rules out the shape. -/ +theorem shifted_opening_impossible (r s : Record) (hr : r.Valid) (hs : s.Valid) + (d : Nat) (hd : 1 ≤ d ∧ d ≤ 3) : + (openingScalars r).drop d ≠ openingScalars s := by + obtain ⟨hd0,hd1⟩ := hd + interval_cases d + · intro he + have hh := congrArg List.head? he + simp [openingScalars] at hh + exact shape_not_marker r.shape hr.1 hh + · intro he + have hh := congrArg List.head? he + simp [openingScalars] at hh + exact lanes_not_marker r.shape hh + · intro he + have hh := congrArg (fun xs : List E => xs[1]?) he + simp [openingScalars] at hh + have hc := congrArg E.c2 hh + simp [ByteCodec.hashToScalars] at hc + exact rate_nonzero s.shape hs.1 hc.symm + +/-- Supported-profile openings have lengths in a four-element interval. -/ +theorem opening_length_band (p : ParameterBounds.Profile) (r : Record) + (h : r.Valid) (hp : Compatible p r) : + 10+(ParameterBounds.config p).logN ≤ (openingScalars r).length ∧ + (openingScalars r).length ≤ 13+(ParameterBounds.config p).logN := by + rw [openingScalars_valid_length r h,hp.1] + have := h.2.1.1 + omega + +theorem suffix_unique (p : ParameterBounds.Profile) (xs : List E) (r s : Record) + (hr : r.Valid) (hs : s.Valid) (pr : Compatible p r) (ps : Compatible p s) + (ar : List.IsSuffix (openingScalars r) xs) + (as' : List.IsSuffix (openingScalars s) xs) : r = s := by + have br := opening_length_band p r hr pr + have bs := opening_length_band p s hs ps + have comparable := List.suffix_or_suffix_of_suffix ar as' + rcases comparable with h | h + · obtain ⟨pre,he⟩ := h + have hl := congrArg List.length he + simp only [List.length_append] at hl + have hd : pre.length ≤ 3 := by omega + have drop : (openingScalars s).drop pre.length = openingScalars r := by + rw [← he,List.drop_left] + by_cases hz : pre.length = 0 + · simp only [hz,List.drop_zero] at drop + exact opening_injective r s hr hs drop.symm + · exact False.elim (shifted_opening_impossible s r hs hr pre.length ⟨by omega,hd⟩ drop) + · obtain ⟨pre,he⟩ := h + have hl := congrArg List.length he + simp only [List.length_append] at hl + have hd : pre.length ≤ 3 := by omega + have drop : (openingScalars r).drop pre.length = openingScalars s := by + rw [← he,List.drop_left] + by_cases hz : pre.length = 0 + · simp only [hz,List.drop_zero] at drop + exact opening_injective r s hr hs drop + · exact False.elim (shifted_opening_impossible r s hr hs pre.length ⟨by omega,hd⟩ drop) + +def decodeScalars (p : ParameterBounds.Profile) (xs : List E) : Option Record := + (List.range 4).findSome? fun n => + parse p (xs.drop (xs.length-(10+(ParameterBounds.config p).logN+n))) + +theorem decodeScalars_recovery (p : ParameterBounds.Profile) (r : Record) + (h : r.Valid) (hp : Compatible p r) (pre : List E) : + decodeScalars p (pre ++ openingScalars r) = some r := by + let n := (r.context.pendingBytes+23)/24 + have hn : n < 4 := by dsimp [n]; have := h.2.1.1; omega + have len : (openingScalars r).length = 10+(ParameterBounds.config p).logN+n := by + rw [openingScalars_valid_length r h,hp.1] + have hit : parse p ((pre ++ openingScalars r).drop + ((pre ++ openingScalars r).length-(10+(ParameterBounds.config p).logN+n))) = some r := by + simp only [List.length_append,← len,Nat.add_sub_cancel_right,List.drop_left] + exact parse_opening p r h hp + have nonempty : (decodeScalars p (pre ++ openingScalars r)).isSome := by + unfold decodeScalars + rw [List.findSome?_isSome_iff] + exact ⟨n,List.mem_range.mpr hn,by rw [hit]; rfl⟩ + cases he : decodeScalars p (pre ++ openingScalars r) with + | none => simp [he] at nonempty + | some s => + obtain ⟨i,hi,accepted⟩ := List.exists_of_findSome?_eq_some he + have sound := parse_sound p _ s accepted + have suffix : List.IsSuffix (openingScalars s) (pre ++ openingScalars r) := by + rw [sound.2.2] + exact List.drop_suffix _ _ + have same := suffix_unique p _ r s h sound.1 hp sound.2.1 ⟨pre,rfl⟩ suffix + rw [same] + +/-- Literal contiguous sent run. A consumed squeeze or nonce separates runs; +zero-consumption empty absorb frames do not hide the preceding saved header. -/ +def extendRun (run : List E) : WHIRHistory.SemanticFrame → List E + | .absorb previous xs => if previous = 0 then run ++ xs else xs + | .nonce _ _ _ => [] + +def literalRun (entry : FramedHistory) : Option (List E) := + (WHIRHistory.parseFrames entry.frames).map (fun frames => frames.foldl extendRun []) + +def decode (p : ParameterBounds.Profile) (entry : FramedHistory) : Option Record := + (literalRun entry).bind (decodeScalars p) + +theorem decode_literal_run (p : ParameterBounds.Profile) (entry : FramedHistory) + (r : Record) (h : r.Valid) (hp : Compatible p r) (pre : List E) + (literal : literalRun entry = some (pre ++ openingScalars r)) : + decode p entry = some r := by + simp only [decode,literal,Option.bind_some] + exact decodeScalars_recovery p r h hp pre + +theorem decode_sound (p : ParameterBounds.Profile) (entry : FramedHistory) (r : Record) + (accepted : decode p entry = some r) : + r.Valid ∧ Compatible p r ∧ + ∃ run, literalRun entry = some run ∧ List.IsSuffix (openingScalars r) run := by + unfold decode at accepted + cases he : literalRun entry with + | none => simp [he] at accepted + | some run => + simp only [he,Option.bind_some] at accepted + obtain ⟨i,hi,parsed⟩ := List.exists_of_findSome?_eq_some accepted + have sound := parse_sound p _ r parsed + refine ⟨sound.1,sound.2.1,run,rfl,?_⟩ + rw [sound.2.2] + exact List.drop_suffix _ _ + + +/-- Exact byte-framing provenance, allowing arbitrary earlier real frames and +arbitrary adaptive sent scalars preceding the saved header in the final run. -/ +theorem decode_source_entry (p : ParameterBounds.Profile) (r : Record) + (h : r.Valid) (hp : Compatible p r) (domain statement : Digest32) + (frames : List WHIRHistory.SemanticFrame) (previous : Nat) (pre : List E) : + decode p (WHIRHistory.encodeHistory ⟨domain,statement, + frames ++ [.absorb previous (pre ++ openingScalars r)]⟩) = some r := by + simp only [decode,literalRun,WHIRHistory.encodeHistory,WHIRHistory.frames_roundtrip, + Option.map_some,Option.bind_some,List.foldl_append,List.foldl_cons,List.foldl_nil, + extendRun] + by_cases hz : previous = 0 + · simp only [hz,↓reduceIte] + rw [← List.append_assoc] + exact decodeScalars_recovery p r h hp _ + · simp only [hz,↓reduceIte] + exact decodeScalars_recovery p r h hp _ + +#print axioms decode_source_entry +#print axioms suffix_unique +end Whir.PCSBCSSourceSavedRecordDecoder diff --git a/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCost.lean b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCost.lean new file mode 100644 index 000000000..aaa15cb0e --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCost.lean @@ -0,0 +1,536 @@ +import Whir.PCSBCSSourceSavedRecordDecoder +import Whir.PCSBCSRecoveredSourceVolume + +/-! Structural work of the literal saved-record decoder. Units are list cells, +word/guard operations, and bounded fixed-width byte codecs, not CPU cycles or +allocator guarantees. The scalar byte loader is the existing checked counter. +The frame parser below is `WHIRHistory.parseFrames`, not `parseSteps` (which +merges nonce frames). Failed branches do not pay for later frames/candidates. +Digest codecs use a fixed 1024-unit charge. Equality inspects precisely the +reached scalar prefix. Pending closures are charged when forced, including +rebuilding `words tail` on each live access; no arbitrary closure certificate +or caller-word reserve is assumed. -/ +set_option autoImplicit false +set_option maxRecDepth 10000 +namespace Whir.PCSBCSSourceSavedRecordDecoderCost +open Concrete FiatShamirGame AnchoredHeaderCodec PCSBCSSourceSavedRecordDecoder +open PCSBCSPublicLogParserCost PCSBCSCoordinateCodecCost +open DuplexFraming DuplexPublicSimulator + +/-- Physical frame slots and payload bytes; numeric consumed cursors are not +expanded by this decoder. Nonces contribute their actual fixed 24-byte payload. -/ +def physicalSize (entry : FramedHistory) : Nat := bodyUnits entry.frames + +def parseFrameCount : Frame → Option WHIRHistory.SemanticFrame × Nat + | .absorb previous bytes => + let parsed := parseExactCount (bytes.length/24) bytes + (parsed.1.map (.absorb previous),bytes.length+parsed.2+1) + | .nonce previous bits bytes => + (some (.nonce previous bits (ByteCodec.decodeE bytes)),1024) + +theorem parseFrameCount_value (f : Frame) : + (parseFrameCount f).1 = WHIRHistory.parseFrame f := by + cases f <;> simp [parseFrameCount,WHIRHistory.parseFrame,parseExactCount_value] + +def parseFramesCount : List Frame → Option (List WHIRHistory.SemanticFrame) × Nat + | [] => (some [],1) + | f::fs => + let first := parseFrameCount f + match first.1 with + | none => (none,first.2+1) + | some x => + let later := parseFramesCount fs + (later.1.map (x::·),first.2+later.2+1) + +theorem parseFramesCount_value (fs : List Frame) : + (parseFramesCount fs).1 = WHIRHistory.parseFrames fs := by + induction fs with + | nil => rfl + | cons f fs ih => + simp only [parseFramesCount,WHIRHistory.parseFrames,parseFrameCount_value] + cases WHIRHistory.parseFrame f <;> simp [ih,Option.map_eq_bind] + +theorem parseFrameCount_bound (f : Frame) : + (parseFrameCount f).2 ≤ frameUnits f*(frameUnits f+2050) := by + cases f with + | absorb previous bytes => + have h := parseExactCount_bound (bytes.length/24) bytes + have d := Nat.div_le_self bytes.length 24 + simp only [parseFrameCount,frameUnits] + nlinarith + | nonce previous bits bytes => simp [parseFrameCount,frameUnits] + +theorem parseFramesCount_bound (fs : List Frame) : + (parseFramesCount fs).2 ≤ (bodyUnits fs+1)*(bodyUnits fs+2052) := by + induction fs with + | nil => simp [parseFramesCount,bodyUnits] + | cons f fs ih => + have hf := parseFrameCount_bound f + have positive : 1 ≤ frameUnits f := by cases f <;> simp [frameUnits] + have cross := Nat.zero_le (frameUnits f*bodyUnits fs) + simp only [parseFramesCount] + cases (parseFrameCount f).1 <;> dsimp only <;> + simp only [bodyUnits,List.map_cons,List.sum_cons] at * <;> nlinarith + +def semanticUnits : WHIRHistory.SemanticFrame → Nat + | .absorb _ xs => xs.length+1 + | .nonce _ _ _ => 1 + +def semanticSize (fs : List WHIRHistory.SemanticFrame) : Nat := + (fs.map semanticUnits).sum + +theorem parseScalars_length (n : Nat) (bs : List Byte) (xs : List E) (rest : List Byte) + (h : WHIRHistory.parseScalars n bs = some (xs,rest)) : xs.length = n := by + induction n generalizing bs xs rest with + | zero => simp only [WHIRHistory.parseScalars,Option.some.injEq,Prod.mk.injEq] at h; rcases h with ⟨rfl,rfl⟩; rfl + | succ n ih => + simp only [WHIRHistory.parseScalars] at h + split at h + · cases he : WHIRHistory.parseScalars n (bs.drop 24) with + | none => simp [he] at h + | some pair => + rcases pair with ⟨ys,tail⟩ + simp [he] at h + rcases h with ⟨rfl,rfl⟩ + simp only [List.length_cons,ih _ _ _ he] + · contradiction + +theorem parseExact_length (n : Nat) (bs : List Byte) (xs : List E) + (h : WHIRHistory.parseExact n bs = some xs) : xs.length = n := by + unfold WHIRHistory.parseExact at h + cases he : WHIRHistory.parseScalars n bs with + | none => simp [he] at h + | some pair => + rcases pair with ⟨ys,tail⟩ + simp only [he,bind,Option.bind] at h + split at h + · cases h; exact parseScalars_length n bs xs tail he + · contradiction + +theorem parseFrame_units (f : Frame) (x : WHIRHistory.SemanticFrame) + (h : WHIRHistory.parseFrame f = some x) : semanticUnits x ≤ frameUnits f := by + cases f with + | nonce previous bits bytes => cases h; simp [semanticUnits,frameUnits] + | absorb previous bytes => + simp only [WHIRHistory.parseFrame] at h + cases he : WHIRHistory.parseExact (bytes.length/24) bytes with + | none => simp [he] at h + | some xs => + simp only [he,Option.map_some,Option.some.injEq] at h + subst x + have len := parseExact_length _ _ _ he + simp only [semanticUnits,frameUnits,len] + omega + +theorem parseFrames_units (fs : List Frame) (xs : List WHIRHistory.SemanticFrame) + (h : WHIRHistory.parseFrames fs = some xs) : semanticSize xs ≤ bodyUnits fs := by + induction fs generalizing xs with + | nil => cases h; simp [semanticSize,bodyUnits] + | cons f fs ih => + simp only [WHIRHistory.parseFrames] at h + cases hf : WHIRHistory.parseFrame f with + | none => simp [hf] at h + | some x => + cases ht : WHIRHistory.parseFrames fs with + | none => simp [hf,ht] at h + | some tail => + simp [hf,ht] at h + subst xs + have first := parseFrame_units f x hf + have later := ih tail ht + simp only [semanticSize,bodyUnits,List.map_cons,List.sum_cons] at * + omega + +def extendRunCount (run : List E) : WHIRHistory.SemanticFrame → List E × Nat + | .absorb previous xs => + if previous = 0 then (run++xs,run.length+2) else (xs,2) + | .nonce _ _ _ => ([],1) + +theorem extendRunCount_value (run : List E) (f : WHIRHistory.SemanticFrame) : + (extendRunCount run f).1 = extendRun run f := by + cases f <;> simp only [extendRunCount,extendRun]; split <;> rfl + +def runCount : List E → List WHIRHistory.SemanticFrame → List E × Nat + | run,[] => (run,1) + | run,f::fs => + let first := extendRunCount run f + let later := runCount first.1 fs + (later.1,first.2+later.2+1) + +theorem runCount_value (run : List E) (fs : List WHIRHistory.SemanticFrame) : + (runCount run fs).1 = fs.foldl extendRun run := by + induction fs generalizing run with + | nil => rfl + | cons f fs ih => simp only [runCount,List.foldl_cons,ih,extendRunCount_value] + +theorem extendRunCount_size (run : List E) (f : WHIRHistory.SemanticFrame) : + (extendRunCount run f).1.length ≤ run.length+semanticUnits f ∧ + (extendRunCount run f).2 ≤ run.length+2 := by + cases f <;> simp only [extendRunCount,semanticUnits] + · split <;> simp only [List.length_append] <;> constructor <;> omega + · simp + +theorem runCount_bound (run : List E) (fs : List WHIRHistory.SemanticFrame) : + (runCount run fs).1.length ≤ run.length+semanticSize fs ∧ + (runCount run fs).2 ≤ (semanticSize fs+1)*(run.length+semanticSize fs+4) := by + induction fs generalizing run with + | nil => simp [runCount,semanticSize] + | cons f fs ih => + have first := extendRunCount_size run f + have later := ih (extendRunCount run f).1 + have positive : 1 ≤ semanticUnits f := by cases f <;> simp [semanticUnits] + simp only [runCount,semanticSize,List.map_cons,List.sum_cons] at * + constructor + · omega + · have monotone : ((List.map semanticUnits fs).sum+1) * + ((extendRunCount run f).1.length+(List.map semanticUnits fs).sum+4) ≤ + ((List.map semanticUnits fs).sum+1) * + (run.length+semanticUnits f+(List.map semanticUnits fs).sum+4) := + Nat.mul_le_mul_left _ (by omega) + have mulRun : run.length ≤ semanticUnits f*run.length := by + simpa using Nat.mul_le_mul_right run.length positive + nlinarith [first.2,later.2,Nat.mul_self_le_mul_self positive] + +/-- Equality charges one scalar comparison and one constructor test per +visited cell, and stops at the first unequal scalar or list constructor. -/ +def equalCount : List E → List E → Bool × Nat + | [],[] => (true,1) + | x::xs,y::ys => + if x = y then + let later := equalCount xs ys + (later.1,later.2+2) + else (false,2) + | _,_ => (false,1) + +theorem equalCount_value (xs ys : List E) : + (equalCount xs ys).1 = decide (xs = ys) := by + induction xs generalizing ys with + | nil => cases ys <;> rfl + | cons x xs ih => + cases ys with + | nil => rfl + | cons y ys => + simp only [equalCount] + split <;> simp_all + +theorem equalCount_bound (xs ys : List E) : + (equalCount xs ys).2 ≤ 2*xs.length+1 := by + induction xs generalizing ys with + | nil => cases ys <;> simp [equalCount] + | cons x xs ih => + cases ys with + | nil => simp [equalCount] + | cons y ys => + have later := ih ys + simp only [equalCount,List.length_cons] + split <;> dsimp only <;> omega + +/-- Cost of evaluating a reconstructed pending word. A live word rebuilds +all of `words tail`, then traverses at most eight words; a dead word only +checks its index. The full flatMap is deliberately not treated as cached. -/ +def pendingAccessCharge (n tailLength index : Nat) : Nat := + if index < (n+7)/8 then 6*tailLength+index+4 else 1 + +def contextCharge (n tailLength : Nat) : Nat := + if n ≤ 64 then + 1 + ((List.range 8).map (fun i => pendingAccessCharge n tailLength i+2)).sum + else 1 + +theorem pendingAccessCharge_bound (n t i : Nat) (hi : i < 8) : + pendingAccessCharge n t i ≤ 6*t+12 := by + unfold pendingAccessCharge; split <;> omega + +theorem contextCharge_bound (n t : Nat) : contextCharge n t ≤ 48*t+113 := by + unfold contextCharge + split + · have sumBound : ((List.range 8).map (fun i => pendingAccessCharge n t i+2)).sum ≤ 8*(6*t+14) := by + apply List.sum_le_length_nsmul + intro x hx + obtain ⟨i,hi,rfl⟩ := List.mem_map.mp hx + have bound := pendingAccessCharge_bound n t i (List.mem_range.mp hi) + omega + omega + · omega + +/-- Short-circuit shape guards; exponentiation is reached only after +logBatch < logN < 64, so at most 63 multiplications. -/ +def shapeCharge (s : Shape) : Nat := + if s.logBatch < s.logN then + if s.logN < 64 then + if 1 ≤ s.logRate then + if s.logN-s.logBatch+s.logRate < 64 then + if 1 ≤ s.lanes then 6+s.logBatch else 5 + else 4 + else 3 + else 2 + else 1 + +theorem shapeCharge_bound (s : Shape) : shapeCharge s ≤ 69 := by + unfold shapeCharge + repeat' first | omega | split + +def validCharge (r : Record) (tailLength : Nat) : Nat := + shapeCharge r.shape + + if r.shape.Valid then + contextCharge r.context.pendingBytes tailLength + + if r.context.Valid then r.point.length+1 else 0 + else 0 + +def compatibleCharge (p : ParameterBounds.Profile) (r : Record) : Nat := + if r.shape.logN = (ParameterBounds.config p).logN then + if r.shape.logBatch = (ParameterBounds.config p).folds[0]! then 3 else 2 + else 1 + +theorem compatibleCharge_bound (p : ParameterBounds.Profile) (r : Record) : + compatibleCharge p r ≤ 3 := by + unfold compatibleCharge + repeat' first | omega | split + +/-- Reconstruct pays its nine constructor tests, both fixed digest codecs, +point drop/dropLast and last-element scan. It does not force pending words. -/ +def reconstructCharge : List E → Nat + | _ :: _ :: _ :: _ :: _ :: _ :: _ :: metadata :: _ :: tail => + 2058 + min ((metadata.c0.toNat+23)/24) tail.length + + (tail.drop ((metadata.c0.toNat+23)/24)).length + tail.length + | xs => xs.length+1 + +theorem reconstructCharge_bound (xs : List E) : + reconstructCharge xs ≤ 2058+3*xs.length := by + unfold reconstructCharge + split + · rename_i marker shape lanes a b cv0 cv1 metadata squeezed tail + simp only [List.length_cons,List.length_drop] + have bound := Nat.min_le_right ((metadata.c0.toNat+23)/24) tail.length + omega + · omega + +/-- Opening construction is reached only after Valid: ≤3 packs, ≤8 live +words, each possibly rebuilding the literal tail; digest/metadata work is +fixed-width, and the point is copied by the actual concatenations. -/ +def packCharge (n t i : Nat) : Nat := + 6 + pendingAccessCharge n t (3*i%8) + + (if 3*i+1 < (n+7)/8 then pendingAccessCharge n t ((3*i+1)%8) else 0) + + (if 3*i+2 < (n+7)/8 then pendingAccessCharge n t ((3*i+2)%8) else 0) + +theorem packCharge_bound (n t i : Nat) : packCharge n t i ≤ 18*t+42 := by + have a := pendingAccessCharge_bound n t (3*i%8) (Nat.mod_lt _ (by decide)) + have b := pendingAccessCharge_bound n t ((3*i+1)%8) (Nat.mod_lt _ (by decide)) + have c := pendingAccessCharge_bound n t ((3*i+2)%8) (Nat.mod_lt _ (by decide)) + unfold packCharge + split <;> split <;> omega + +def openingCharge (r : Record) (tailLength : Nat) : Nat := + 4096 + ((List.range ((r.context.pendingBytes+23)/24)).map + (packCharge r.context.pendingBytes tailLength)).sum + 2*r.point.length + +theorem openingCharge_bound (r : Record) (t : Nat) (valid : r.Valid) : + openingCharge r t ≤ 4222+54*t+2*r.point.length := by + have count : (r.context.pendingBytes+23)/24 ≤ 3 := by + have := valid.2.1.1 + omega + have sumBound : ((List.range ((r.context.pendingBytes+23)/24)).map + (packCharge r.context.pendingBytes t)).sum ≤ + ((r.context.pendingBytes+23)/24)*(18*t+42) := by + have h := List.sum_le_length_nsmul + ((List.range ((r.context.pendingBytes+23)/24)).map + (packCharge r.context.pendingBytes t)) (18*t+42) (by + intro x hx + obtain ⟨i,_,rfl⟩ := List.mem_map.mp hx + exact packCharge_bound _ _ _) + simpa only [List.length_map,List.length_range,smul_eq_mul] using h + have cap := Nat.mul_le_mul_right (18*t+42) count + unfold openingCharge + omega + +def parseCount (p : ParameterBounds.Profile) (xs : List E) : Option Record × Nat := + let initial := reconstructCharge xs + match reconstruct xs with + | none => (none,initial+1) + | some r => + let metadata := initial+validCharge r (xs.length-9)+1 + if r.Valid then + let profile := metadata+compatibleCharge p r+1 + if Compatible p r then + let opening := openingScalars r + let compared := equalCount opening xs + (if compared.1 then some r else none, + profile+openingCharge r (xs.length-9)+compared.2+1) + else (none,profile) + else (none,metadata) + +theorem parseCount_value (p : ParameterBounds.Profile) (xs : List E) : + (parseCount p xs).1 = parse p xs := by + simp only [parseCount,parse] + cases reconstruct xs with + | none => rfl + | some r => + simp only [Option.bind_some] + by_cases hv : r.Valid <;> by_cases hp : Compatible p r <;> + simp [hv,hp,equalCount_value] + +theorem reconstruct_point_bound (xs : List E) (r : Record) + (h : reconstruct xs = some r) : r.point.length ≤ xs.length := by + unfold reconstruct at h + split at h + · cases h + simp only [List.length_dropLast,List.length_drop,List.length_cons] + omega + · contradiction + +theorem parseCount_bound (p : ParameterBounds.Profile) (xs : List E) : + (parseCount p xs).2 ≤ 120*xs.length+7000 := by + have initial := reconstructCharge_bound xs + unfold parseCount + cases hr : reconstruct xs with + | none => dsimp only; omega + | some r => + have point := reconstruct_point_bound xs r hr + have shape := shapeCharge_bound r.shape + have context := contextCharge_bound r.context.pendingBytes (xs.length-9) + have vc : validCharge r (xs.length-9) ≤ 49*xs.length+183 := by + unfold validCharge + split + · split <;> omega + · omega + have profile := compatibleCharge_bound p r + dsimp only + split + · rename_i hv + split + · have pendingBound := hv.2.1.1 + have pointLength := hv.2.2 + have openingLength := openingScalars_valid_length r hv + have eqCost := equalCount_bound (openingScalars r) xs + have openingCost := openingCharge_bound r (xs.length-9) hv + omega + · dsimp only; omega + · dsimp only; omega + +/-- Same four candidates and same early successful exit as findSome?. Each +reached candidate separately pays the real full `xs.length` scan and drop. -/ +def candidatesCount (p : ParameterBounds.Profile) (xs : List E) : + List Nat → Option Record × Nat + | [] => (none,1) + | i::is => + let dropped := xs.drop (xs.length-(10+(ParameterBounds.config p).logN+i)) + let tried := parseCount p dropped + let traversal := xs.length + (xs.length-(10+(ParameterBounds.config p).logN+i)) + 4 + match tried.1 with + | some r => (some r,traversal+tried.2+1) + | none => + let later := candidatesCount p xs is + (later.1,traversal+tried.2+later.2+1) + +theorem candidatesCount_value (p : ParameterBounds.Profile) (xs : List E) (is : List Nat) : + (candidatesCount p xs is).1 = is.findSome? (fun i => + parse p (xs.drop (xs.length-(10+(ParameterBounds.config p).logN+i)))) := by + induction is with + | nil => rfl + | cons i is ih => + simp only [candidatesCount,List.findSome?_cons,parseCount_value] + cases parse p (xs.drop (xs.length-(10+(ParameterBounds.config p).logN+i))) <;> simp [ih] + +theorem candidatesCount_bound (p : ParameterBounds.Profile) (xs : List E) (is : List Nat) : + (candidatesCount p xs is).2 ≤ is.length*(122*xs.length+7005)+1 := by + induction is with + | nil => simp [candidatesCount] + | cons i is ih => + have tried := parseCount_bound p (xs.drop (xs.length-(10+(ParameterBounds.config p).logN+i))) + have dropBound : (xs.drop (xs.length-(10+(ParameterBounds.config p).logN+i))).length ≤ xs.length := + by simp only [List.length_drop]; omega + have triedCap : (parseCount p (xs.drop (xs.length-(10+(ParameterBounds.config p).logN+i)))).2 ≤ + 120*xs.length+7000 := tried.trans (by omega) + have traversalCap := Nat.sub_le xs.length (10+(ParameterBounds.config p).logN+i) + simp only [candidatesCount,List.length_cons] + cases (parseCount p (xs.drop (xs.length-(10+(ParameterBounds.config p).logN+i)))).1 <;> + dsimp only <;> nlinarith + +def decodeCount (p : ParameterBounds.Profile) (entry : FramedHistory) : Option Record × Nat := + let parsed := parseFramesCount entry.frames + match parsed.1 with + | none => (none,parsed.2+1) + | some fs => + let run := runCount [] fs + let decoded := candidatesCount p run.1 (List.range 4) + (decoded.1,parsed.2+run.2+decoded.2+2) + +theorem decodeCount_value (p : ParameterBounds.Profile) (entry : FramedHistory) : + (decodeCount p entry).1 = decode p entry := by + simp only [decodeCount,decode,literalRun,parseFramesCount_value] + cases WHIRHistory.parseFrames entry.frames <;> + simp [runCount_value,candidatesCount_value,decodeScalars] + +/-- Polynomial in actual physical input volume, including all rejecting inputs. -/ +def physicalPolynomial (n : Nat) : Nat := 2*n*n+2550*n+30100 + +theorem decodeCount_bound (p : ParameterBounds.Profile) (entry : FramedHistory) : + (decodeCount p entry).2 ≤ physicalPolynomial (physicalSize entry) := by + have parser := parseFramesCount_bound entry.frames + unfold decodeCount + cases hp : (parseFramesCount entry.frames).1 with + | none => simp only [hp]; unfold physicalPolynomial physicalSize; nlinarith + | some fs => + have parsed : WHIRHistory.parseFrames entry.frames = some fs := by + rw [← parseFramesCount_value,hp] + have volume := parseFrames_units entry.frames fs parsed + have run := runCount_bound [] fs + have candidate := candidatesCount_bound p (runCount [] fs).1 (List.range 4) + simp only [List.length_nil,List.length_range,zero_add] at run candidate + simp only [hp] + unfold physicalPolynomial physicalSize + nlinarith + +/-- Standard three axioms only; exact value erasure and resource bound together. -/ +theorem erasure_resource (p : ParameterBounds.Profile) (entry : FramedHistory) : + (decodeCount p entry).1 = decode p entry ∧ + (decodeCount p entry).2 ≤ physicalPolynomial (physicalSize entry) := + ⟨decodeCount_value p entry,decodeCount_bound p entry⟩ + +/-- A genuine coordinate-path charge bounds bytes/frames via the checked +canonical parser volume lemma; cursor magnitudes are not needed here. -/ +theorem coordinate_physical (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (Q : Nat) (bound : pathCost q ≤ Q) : + physicalSize q.history ≤ 65*Q := by + have volume := parse_units (DuplexEncoding.plan q) q (DuplexEncoding.parse_plan q valid) + change (DuplexEncoding.plan q).length ≤ Q at bound + unfold physicalSize + omega + +def queryPolynomial (Q : Nat) : Nat := physicalPolynomial (65*Q) + +theorem decodeCount_query_bound (p : ParameterBounds.Profile) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (Q : Nat) (bound : pathCost q ≤ Q) : + (decodeCount p q.history).2 ≤ queryPolynomial Q := by + have physical := decodeCount_bound p q.history + have volume := coordinate_physical q valid Q bound + unfold queryPolynomial physicalPolynomial at * + nlinarith + +theorem decodeCount_recovered_bound {Q : Nat} {iv : Digest32} + {log : PublicLog} {input : Node} {q : Coordinate} + (p : ParameterBounds.Profile) + (recovered : PCSBCSSourceCoordinateDecoder.recover Q iv log input = some q) : + (decodeCount p q.history).2 ≤ queryPolynomial Q := by + obtain ⟨_,_,_,_,_,_,valid,physical⟩ := PCSBCSSourceCoordinateDecoder.recover_sound recovered + exact decodeCount_query_bound p q valid Q physical +theorem supported_logN : ∀ p : ParameterBounds.Profile, + (ParameterBounds.config p).logN ≤ 28 := by + decide +kernel + +/-- Supported accepted records fit the physical metadata caps used above. -/ +theorem accepted_shape_caps (p : ParameterBounds.Profile) (entry : FramedHistory) + (r : Record) (accepted : decode p entry = some r) : + r.shape.logN ≤ 28 ∧ r.context.pendingBytes ≤ 64 ∧ + (pendingPacks r.context).length ≤ 3 ∧ (r.context.pendingBytes+7)/8 ≤ 8 := by + have sound := decode_sound p entry r accepted + have logCap := supported_logN p + have bytes := sound.1.2.1.1 + rw [← sound.2.1.1] at logCap + simp only [pendingPacks,List.length_map,List.length_range] + omega + +#print axioms erasure_resource +#print axioms decodeCount_query_bound +#print axioms decodeCount_recovered_bound +end Whir.PCSBCSSourceSavedRecordDecoderCost diff --git a/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCostSmoke.lean b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCostSmoke.lean new file mode 100644 index 000000000..b75f43aa4 --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderCostSmoke.lean @@ -0,0 +1,122 @@ +import Whir.PCSBCSSourceSavedRecordDecoderCost + +/-! Deterministic executable fixtures for exact decoder erasure and reached +structural charges. Native execution is separate from the kernel proofs. -/ +namespace Whir.PCSBCSSourceSavedRecordDecoderCostSmoke +open Concrete FiatShamirGame AnchoredHeaderCodec PCSBCSSourceSavedRecordDecoder +open PCSBCSSourceSavedRecordDecoderCost + +private def profile : ParameterBounds.Profile := (⟨0,by decide⟩,⟨0,by decide⟩) +private def digest (n : Nat) : Digest32 := fun i => + ⟨(n+i.val)%256,Nat.mod_lt _ (by decide)⟩ +private def saved (n : Nat) : Record := + let c := ParameterBounds.config profile + { shape := ⟨c.logN,c.folds[0]!,c.rates[0]!,1⟩ + root := digest 17 + context := { cv := digest 33 + pending := fun i => if i.val < (n+7)/8 then + some (UInt64.ofNat (101+i.val)) else none + pendingBytes := n + first := true + previous := 7 + squeezed := 11 } + point := (List.range c.logN).map (fun i => E.ofK (UInt64.ofNat i)) + value := E.ofK 313 } +private def entry (xs : List E) : FramedHistory := + WHIRHistory.encodeHistory ⟨digest 5,digest 9, + [.absorb 0 [E.ofK 88],.nonce 24 0 0,.absorb 24 [E.ofK 90], + .absorb 0 ([E.ofK 91,E.ofK 92] ++ xs),.absorb 0 []]⟩ +private def require (label : String) (passed : Bool) : IO Unit := do + unless passed do throw (IO.userError s!"saved-record cost smoke failed: {label}") + IO.println s!"saved-record cost: {label}" +private def check (label : String) (h : FramedHistory) : IO Unit := do + let counted := decodeCount profile h + require s!"{label}: exact byte decoder erasure" + (decide (counted.1 = decode profile h)) + require s!"{label}: physical polynomial" + (counted.2 ≤ physicalPolynomial (physicalSize h)) + IO.println s!"saved-record cost: {label} physical={physicalSize h} charge={counted.2}" + +/-- Charge for the reached metadata and profile guards, before opening work. -/ +private def beforeOpening (xs : List E) (r : Record) : Nat := + reconstructCharge xs + validCharge r (xs.length-9) + 1 + + compatibleCharge profile r + 1 + +def smoke : IO Unit := do + for n in [0,1,8,9,24,25,48,49,64] do + let r := saved n + let xs := openingScalars r + let h := entry xs + check s!"positive pending bytes={n}" h + require s!"positive full record bytes={n}" (decide ((decodeCount profile h).1 = some r)) + let parsed := parseCount profile xs + require s!"positive exact parse charge bytes={n}" + (parsed.2 == beforeOpening xs r + openingCharge r (xs.length-9) + 2*xs.length+2) + require s!"positive pending caps bytes={n}" + ((pendingPacks r.context).length ≤ 3 && (r.context.pendingBytes+7)/8 ≤ 8) + let malformed : Frame := .absorb 0 [⟨1,by decide⟩] + let early : FramedHistory := ⟨digest 5,digest 9,[malformed]⟩ + check "early malformed bytes" early + require "early error charge is exactly six" ((decodeCount profile early).1.isNone && (decodeCount profile early).2 == 6) + let ignored : Frame := WHIRHistory.encodeFrame (.absorb 0 (openingScalars (saved 64))) + let earlyWithIgnored := {early with frames := [malformed,ignored]} + check "early error skips later large frame" earlyWithIgnored + require "unreached frame costs nothing" ((decodeCount profile earlyWithIgnored).2 == 6) + let empty : FramedHistory := ⟨digest 5,digest 9,[]⟩ + check "short reconstruction all four candidates" empty + require "empty entry exact four-candidate charge" ((decodeCount profile empty).1.isNone && (decodeCount profile empty).2 == 33) + let earlier := WHIRHistory.encodeFrame (.absorb 0 [E.ofK 88]) + let afterPrefix := {early with frames := [earlier,malformed,ignored]} + check "frame error after successful prefix" afterPrefix + require "successful prefix and reached malformed frame exact charge" + ((decodeCount profile afterPrefix).1.isNone && (decodeCount profile afterPrefix).2 == 1082) + let remainder := {early with frames := + [.absorb 0 (WHIRHistory.scalarBytes [E.ofK 88] ++ [⟨1,by decide⟩]),ignored]} + check "scalar decoded before nonempty remainder error" remainder + require "nonempty byte remainder exact reached charge" + ((decodeCount profile remainder).1.isNone && (decodeCount profile remainder).2 == 1079) + let xs := openingScalars (saved 25) + let mid := xs.mapIdx (fun i x => if i = 7 then ⟨65,x.c1,x.c2⟩ else x) + check "mid invalid pending metadata" (entry mid) + require "mid metadata rejects" (parseCount profile mid).1.isNone + match reconstruct mid with + | none => throw (IO.userError "mid reconstruction unexpectedly absent") + | some r => + require "mid stops before profile/opening/equality" + ((parseCount profile mid).2 == reconstructCharge mid + validCharge r (mid.length-9)+1) + let mismatch := xs.mapIdx (fun i x => if i = 0 then 0 else x) + check "late exact-opening marker mismatch" (entry mismatch) + require "late mismatch rejects" (parseCount profile mismatch).1.isNone + match reconstruct mismatch with + | none => throw (IO.userError "late reconstruction unexpectedly absent") + | some r => + require "late first scalar mismatch costs exactly two" + ((equalCount (openingScalars r) mismatch).2 == 2) + require "late reached opening and prefix comparison charge" + ((parseCount profile mismatch).2 == beforeOpening mismatch r + openingCharge r (mismatch.length-9)+3) + let tailMismatch := xs.mapIdx (fun i x => if i = 8 then ⟨x.c0,1,x.c2⟩ else x) + check "late ninth scalar padding mismatch" (entry tailMismatch) + match reconstruct tailMismatch with + | none => throw (IO.userError "padding reconstruction unexpectedly absent") + | some r => + require "ninth scalar mismatch charges reached nine cells" + ((equalCount (openingScalars r) tailMismatch).2 == 18) + require "ninth scalar mismatch exact full reached charge" + ((parseCount profile tailMismatch).1.isNone && + (parseCount profile tailMismatch).2 == beforeOpening tailMismatch r + openingCharge r (tailMismatch.length-9)+19) + let wrongProfile := xs.mapIdx (fun i x => if i = 1 then ⟨x.c0,x.c1,2⟩ else x) + check "mid supported profile comparison mismatch" (entry wrongProfile) + match reconstruct wrongProfile with + | none => throw (IO.userError "profile reconstruction unexpectedly absent") + | some r => + require "profile mismatch stops before exact opening" + ((parseCount profile wrongProfile).1.isNone && + (parseCount profile wrongProfile).2 == beforeOpening wrongProfile r) + let interrupted := {entry xs with frames := (entry xs).frames ++ + [WHIRHistory.encodeFrame (.nonce 0 0 0)]} + check "nonce clears literal final run" interrupted + require "nonce separator rejects saved suffix" (decodeCount profile interrupted).1.isNone + +end Whir.PCSBCSSourceSavedRecordDecoderCostSmoke + +def main : IO Unit := Whir.PCSBCSSourceSavedRecordDecoderCostSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderSmoke.lean b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderSmoke.lean new file mode 100644 index 000000000..095d784af --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceSavedRecordDecoderSmoke.lean @@ -0,0 +1,63 @@ +import Whir.PCSBCSSourceSavedRecordDecoder + +/-! Executable fixtures exercise actual source frame bytes. These are decoder +fixtures, not valid algebraic WHIR proofs or a native-verifier refinement. -/ +namespace Whir.PCSBCSSourceSavedRecordDecoderSmoke +open Concrete FiatShamirGame AnchoredHeaderCodec PCSBCSSourceSavedRecordDecoder + +private def profile : ParameterBounds.Profile := (⟨0,by decide⟩,⟨0,by decide⟩) +private def digest (n : Nat) : Digest32 := fun i => + ⟨(n+i.val)%256,Nat.mod_lt _ (by decide)⟩ +private def saved (n lanes : Nat) : Record := + let c := ParameterBounds.config profile + { shape := ⟨c.logN,c.folds[0]!,c.rates[0]!,lanes⟩ + root := digest (n+17) + context := { cv := digest (n+33) + pending := fun i => if i.val < (n+7)/8 then + some (UInt64.ofNat (101+i.val)) else none + pendingBytes := n + first := n%2 == 0 + previous := UInt64.ofNat (n+7) + squeezed := UInt64.ofNat (n+11) } + point := (List.range c.logN).map (fun i => E.ofK (UInt64.ofNat (i+n))) + value := E.ofK (UInt64.ofNat (n+313)) } +private def entry (xs : List E) : FramedHistory := + WHIRHistory.encodeHistory ⟨digest 5,digest 9, + [.absorb 0 [E.ofK 88],.nonce 24 0 0,.absorb 24 [E.ofK 90], + .absorb 0 ([E.ofK 91,E.ofK 92] ++ xs)]⟩ +private def require (label : String) (passed : Bool) : IO Unit := do + unless passed do throw (IO.userError s!"saved-record decoder smoke failed: {label}") + IO.println s!"saved-record decoder: {label}" + +def smoke : IO Unit := do + for n in [0,1,8,9,24,25,48,49,64] do + for lanes in [1,2] do + let r := saved n lanes + require s!"valid adaptive metadata bytes={n} lanes={lanes}" (decide r.Valid) + require s!"profile compatibility bytes={n} lanes={lanes}" (decide (Compatible profile r)) + require s!"full record byte recovery bytes={n} lanes={lanes}" + (decide (decode profile (entry (openingScalars r)) = some r)) + let r := saved 25 2 + let xs := openingScalars r + require "wrong marker rejected" (parse profile (xs.mapIdx (fun i x => if i = 0 then 0 else x))).isNone + require "wrong shape rejected" (parse profile (xs.mapIdx (fun i x => if i = 1 then 0 else x))).isNone + require "zero lanes rejected" (parse profile (xs.mapIdx (fun i x => if i = 2 then 0 else x))).isNone + require "root padding rejected" (parse profile (xs.mapIdx (fun i x => + if i = 4 then ⟨x.c0,x.c1,1⟩ else x))).isNone + require "metadata boolean rejected" (parse profile (xs.mapIdx (fun i x => + if i = 7 then ⟨x.c0,2,x.c2⟩ else x))).isNone + require "pending padding rejected" (parse profile (xs.mapIdx (fun i x => + if i = 10 then ⟨x.c0,x.c1,1⟩ else x))).isNone + require "truncated suffix rejected" (parse profile xs.dropLast).isNone + require "extra suffix rejected" (parse profile (xs ++ [0])).isNone + for d in [1,2,3] do + require s!"suffix shift {d} cannot be another saved opening" (parse profile (xs.drop d)).isNone + let malformed : FramedHistory := ⟨digest 5,digest 9,[.absorb 0 [⟨1,by decide⟩]]⟩ + require "non-scalar-aligned byte frame rejected" (decode profile malformed).isNone + let emptyTail := {entry xs with frames := (entry xs).frames ++ [.absorb 0 []]} + require "empty zero-consumption tail retains literal run" + (decide (decode profile emptyTail = some r)) + +end Whir.PCSBCSSourceSavedRecordDecoderSmoke + +def main : IO Unit := Whir.PCSBCSSourceSavedRecordDecoderSmoke.smoke diff --git a/verification/whir/Whir/PCSBCSSourceSavedRecordProvenance.lean b/verification/whir/Whir/PCSBCSSourceSavedRecordProvenance.lean new file mode 100644 index 000000000..24a2cdb9a --- /dev/null +++ b/verification/whir/Whir/PCSBCSSourceSavedRecordProvenance.lean @@ -0,0 +1,319 @@ +import Whir.PCSBCSSourceSavedRecordDecoder +import Whir.PCSBCSSourceRootReferences + +/-! Saved-record provenance from the actual fresh caller parser. Successful +payload operations consume a prefix of their input; the checked binding consumes +exactly the complete opening. The canonical-history guard then identifies the +literal bytes with the semantic lift of those operations. No literal suffix, +native framing normalization, or parser-success certificate is an extra input. +This is a theorem about the existing source projection, not universal Rust +observer refinement. -/ +namespace Whir.PCSBCSSourceSavedRecordProvenance +open Concrete FiatShamirGame WHIRCallerClaims AnchoredHeaderCodec +open WHIRHistory PCSBCSSourceSavedRecordDecoder + +set_option maxHeartbeats 0 +set_option maxRecDepth 10000 + +/-- A parser never creates, reorders, or restores remaining input tokens. -/ +def ConsumesPrefix {A : Type} (parser : CallerParser A) : Prop := + ∀ tokens value rest, parser tokens = some (value,rest) → List.IsSuffix rest tokens + +theorem consumes_pure {A : Type} (value : A) : ConsumesPrefix (pure value) := by + intro tokens result rest accepted + change some (value,tokens) = some (result,rest) at accepted + cases Option.some.inj accepted + exact ⟨[],rfl⟩ + +theorem consumes_failure {A : Type} : ConsumesPrefix (fun _ => (none : Option (A × List CallerToken))) := by + intro tokens value rest accepted + contradiction + +theorem consumes_bind {A B : Type} (parser : CallerParser A) (next : A → CallerParser B) + (first : ConsumesPrefix parser) (last : ∀ value, ConsumesPrefix (next value)) : + ConsumesPrefix (parser >>= next) := by + intro tokens value rest accepted + obtain ⟨middle,remaining,hfirst,hlast⟩ := parser_bind_inv parser next tokens rest value accepted + exact (last middle remaining value rest hlast).trans (first tokens middle remaining hfirst) + +theorem consumes_forIn {A B : Type} (xs : List A) (initial : B) + (body : A → B → CallerParser (ForInStep B)) + (step : ∀ x value, ConsumesPrefix (body x value)) : + ConsumesPrefix (forIn xs initial body) := by + induction xs generalizing initial with + | nil => exact consumes_pure initial + | cons x xs ih => + rw [List.forIn_cons] + apply consumes_bind _ _ (step x initial) + intro out + cases out with + | done value => exact consumes_pure value + | yield value => exact ih value + +theorem consumes_mapM {A B : Type} (xs : List A) (f : A → CallerParser B) + (step : ∀ x, ConsumesPrefix (f x)) : ConsumesPrefix (xs.mapM f) := by + induction xs with + | nil => exact consumes_pure [] + | cons x xs ih => + rw [List.mapM_cons] + apply consumes_bind _ _ (step x) + intro value + apply consumes_bind _ _ ih + intro rest + exact consumes_pure (value :: rest) + +theorem consumes_readScalar : ConsumesPrefix readScalar := by + intro tokens value rest accepted + cases tokens with + | nil => cases accepted + | cons token tail => + cases token <;> simp only [readScalar] at accepted <;> try contradiction + cases Option.some.inj accepted + exact ⟨[.sent value],rfl⟩ + +theorem consumes_drawScalar : ConsumesPrefix drawScalar := by + intro tokens value rest accepted + cases tokens with + | nil => cases accepted + | cons token tail => + cases token <;> simp only [drawScalar] at accepted <;> try contradiction + cases Option.some.inj accepted + exact ⟨[.draw value],rfl⟩ + +theorem consumes_check (ok : Bool) : ConsumesPrefix (check ok) := by + cases ok + · exact consumes_failure + · exact consumes_pure () + +theorem consumes_nonce (bits : Nat) : ConsumesPrefix (nonce bits) := by + intro tokens value rest accepted + cases tokens with + | nil => cases accepted + | cons token tail => + cases token with + | sent => cases accepted + | draw => cases accepted + | nonce actual bytes => + simp only [nonce] at accepted + split at accepted + · cases Option.some.inj accepted + exact ⟨[.nonce actual bytes],rfl⟩ + · contradiction + +theorem consumes_readScalars (n : Nat) : ConsumesPrefix (readScalars n) := by + induction n with + | zero => exact consumes_pure [] + | succ n ih => + apply consumes_bind _ _ consumes_readScalar + intro value + apply consumes_bind _ _ ih + intro rest + exact consumes_pure (value :: rest) + +theorem consumes_drawScalars (n : Nat) : ConsumesPrefix (drawScalars n) := by + induction n with + | zero => exact consumes_pure [] + | succ n ih => + apply consumes_bind _ _ consumes_drawScalar + intro value + apply consumes_bind _ _ ih + intro rest + exact consumes_pure (value :: rest) + +/-- Structural closure for the actual source loops and their pure branch code. -/ +macro "consume_source" "[" rules:Lean.Parser.Tactic.SolveByElim.arg,* "]" : tactic => `(tactic| + repeat' first + | solve_by_elim (config := {maxDepth := 1}) only [$rules,*] + | exact consumes_pure _ + | exact consumes_failure + | exact consumes_readScalar + | exact consumes_drawScalar + | exact consumes_readScalars _ + | exact consumes_drawScalars _ + | exact consumes_check _ + | exact consumes_nonce _ + | (refine consumes_bind _ _ ?_ (fun value => ?_)) + | (refine consumes_forIn _ _ _ (fun x value => ?_)) + | (refine consumes_mapM _ _ (fun x => ?_)) + | (dsimp +zetaHave only; split) + | split) + +theorem consumes_gkrPoint (mu : Nat) : ConsumesPrefix (gkrPoint mu) := by + unfold gkrPoint + consume_source [] + +theorem consumes_busClaims (layout : BusLayout) : ConsumesPrefix (busClaims layout) := by + unfold busClaims + consume_source [consumes_gkrPoint] + +theorem consumes_receiveTable (layout : AirLayout) (point : List E) : + ConsumesPrefix (receiveTable layout point) := by + unfold receiveTable + consume_source [] + +theorem consumes_constraintClaims (layouts : List AirLayout) (point : List E) : + ConsumesPrefix (constraintClaims layouts point) := by + unfold constraintClaims + consume_source [consumes_receiveTable] + +theorem consumes_flockClaims (layouts : List FlockLayout) : ConsumesPrefix (flockClaims layouts) := by + unfold flockClaims + consume_source [] + +theorem consumes_settledClaims (tables : List CpuTableLayout) (point : List E) : + ConsumesPrefix (settledClaims tables point) := by + unfold settledClaims + consume_source [] + +theorem consumes_recPayload (layout : RecLayout) : ConsumesPrefix (recPayload layout) := by + unfold recPayload + consume_source [consumes_busClaims,consumes_constraintClaims,consumes_flockClaims] + exact consumes_busClaims _ + +theorem consumes_cpuPayload (layout : CpuLayout) : ConsumesPrefix (cpuPayload layout) := by + unfold cpuPayload + consume_source [consumes_busClaims,consumes_settledClaims,consumes_constraintClaims,consumes_flockClaims] + exact consumes_busClaims _ + +theorem consumes_payload (layout : CallerLayout) : ConsumesPrefix (AnchoredSourceCaller.payload layout) := by + cases layout with + | cpu layout => exact consumes_cpuPayload layout + | recursion layout => exact consumes_recPayload layout + +theorem readScalars_prefix (n : Nat) (tokens rest : List CallerToken) (values : List E) + (accepted : readScalars n tokens = some (values,rest)) : + tokens = values.map CallerToken.sent ++ rest := by + induction n generalizing tokens values with + | zero => + change some ([],tokens) = some (values,rest) at accepted + cases Option.some.inj accepted + rfl + | succ n ih => + obtain ⟨value,middle,head,tail⟩ := parser_bind_inv _ _ _ _ _ accepted + obtain ⟨xs,remaining,body,finished⟩ := parser_bind_inv _ _ _ _ _ tail + change some (value :: xs,remaining) = some (values,rest) at finished + cases Option.some.inj finished + cases tokens with + | nil => cases head + | cons token tail => + cases token <;> simp only [readScalar] at head <;> try contradiction + cases Option.some.inj head + simp only [List.map_cons,List.cons_append] + rw [ih _ _ body] + +theorem binding_prefix (saved : Record) (tokens rest : List CallerToken) (value : Unit) + (accepted : AnchoredSourceCaller.binding saved tokens = some (value,rest)) : + tokens = (openingScalars saved).map CallerToken.sent ++ rest := by + obtain ⟨frame,middle,read,checked⟩ := parser_bind_inv _ _ _ _ _ accepted + have equal : frame = openingScalars saved := by + by_contra different + simp [check,different] at checked + subst frame + have remaining : middle = rest := by + simp only [check,beq_self_eq_true,↓reduceIte] at checked + change some ((),middle) = some (value,rest) at checked + exact congrArg Prod.snd (Option.some.inj checked) + rw [← remaining] + exact readScalars_prefix _ _ _ _ read + +/-- Actual payload consumption plus literal binding, not a free success certificate. -/ +theorem sourceClaims_suffix (layout : CallerLayout) (saved : Record) + (tokens : List CallerToken) (claims : AnchoredSourceCaller.Claims) + (accepted : AnchoredSourceFreshCaller.sourceClaims layout saved tokens = some (claims,[])) : + ∃ preTokens, tokens = preTokens ++ (openingScalars saved).map CallerToken.sent := by + obtain ⟨payload,middle,parsed,tail⟩ := parser_bind_inv _ _ _ _ _ accepted + obtain ⟨bound,remaining,binding,finished⟩ := parser_bind_inv _ _ _ _ _ tail + change some (_,remaining) = some (claims,[]) at finished + have empty : remaining = [] := congrArg Prod.snd (Option.some.inj finished) + have suffix := binding_prefix saved middle remaining bound binding + rw [empty,List.append_nil] at suffix + obtain ⟨preTokens,eq⟩ := consumes_payload layout tokens payload middle parsed + exact ⟨preTokens,by rw [← eq,suffix]⟩ + +/-- Lift every caller operation, including literal nonce bytes, to the existing +semantic model. The codec inverse is total, so no extra nonce condition occurs. -/ +def tokenEvent : CallerToken → WHIRHistory.Event + | .sent x => .observe [x] + | .draw _ => .squeeze 24 + | .nonce bits value => .nonce bits (ByteCodec.decodeE value) + +theorem tokenEvent_model (m : DuplexRefinement.Model) (token : CallerToken) : + modelEvent m (tokenEvent token) = WHIRCallerShape.applyOperation m (tokenOperation token) := by + cases token <;> simp [tokenEvent,modelEvent,tokenOperation,WHIRCallerShape.applyOperation, + ByteCodec.encodeE_decodeE] + +def runSemantic (m : SemanticModel) (tokens : List CallerToken) : SemanticModel := + tokens.foldl (fun m token => semanticEvent m (tokenEvent token)) m + +theorem runSemantic_encode (m : SemanticModel) (tokens : List CallerToken) : + encodeModel (runSemantic m tokens) = + WHIRCallerShape.runOperations (encodeModel m) (tokens.map tokenOperation) := by + induction tokens generalizing m with + | nil => rfl + | cons token tokens ih => + simp only [runSemantic,List.foldl_cons,List.map_cons,WHIRCallerShape.runOperations] + rw [← runSemantic,ih,semanticEvent_encode,tokenEvent_model] + rfl + +/-- The canonical-history guard, rather than a native-normalization assumption, +identifies the final contiguous scalar run. Adjacent earlier sent scalars are +retained as an arbitrary prefix. -/ +theorem literalRun_sent_suffix (domain statement : Digest32) (preTokens : List CallerToken) + (values : List E) (nonempty : values ≠ []) : + ∃ pre, literalRun (tokenHistory domain statement (preTokens ++ values.map CallerToken.sent)) = + some (pre ++ values) := by + let seed : SemanticModel := ⟨⟨domain,statement,[]⟩,[],0,0⟩ + let model := runSemantic seed preTokens + have lift : WHIRCallerShape.runOperations (WHIRCallerShape.seedModel domain statement) + (preTokens.map tokenOperation) = encodeModel model := (runSemantic_encode seed preTokens).symm + have framed : tokenHistory domain statement (preTokens ++ values.map CallerToken.sent) = + encodeHistory (closeSemantic (semanticEvent model (.observe values))).history := by + unfold tokenHistory + rw [List.map_append,runOperations_append,run_sent_tokens,lift] + change (DuplexRefinement.closeRun (modelEvent (encodeModel model) (.observe values))).history = _ + rw [← semanticEvent_encode,← closeSemantic_encode] + rfl + have runNonempty : model.run ++ values ≠ [] := by simp [nonempty] + rw [framed] + simp only [literalRun,encodeHistory,frames_roundtrip,Option.map_some, + semanticEvent,nonempty,↓reduceIte,closeSemantic,runNonempty,List.foldl_append, + List.foldl_cons,List.foldl_nil,extendRun] + by_cases hz : (if model.consumed = 0 then model.previous else model.consumed) = 0 + · simp only [hz,↓reduceIte] + exact ⟨model.history.frames.foldl extendRun [] ++ model.run,by simp only [List.append_assoc]⟩ + · simp only [hz,↓reduceIte] + exact ⟨model.run,rfl⟩ + +theorem profileShape_compatible (p : ParameterBounds.Profile) (saved : Record) + (profile : PCSBCSSourceRootReferences.profileShape p saved.shape) : Compatible p saved := profile + +/-- End-to-end exact recovery from successful actual source decoding. Only the +source's existing record validity/profile guards are needed. -/ +theorem decode_saved (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (claims : AnchoredSourceCaller.Claims) + (accepted : AnchoredSourceFreshCaller.decode layout saved entry answers = some claims) + (valid : saved.Valid) (profile : Compatible p saved) : + PCSBCSSourceSavedRecordDecoder.decode p entry = some saved := by + obtain ⟨tokens,parsed,_,source⟩ := AnchoredSourceFreshCaller.decode_exact layout saved entry answers claims accepted + obtain ⟨preTokens,suffix⟩ := sourceClaims_suffix layout saved tokens claims source + have history := entryTokens_history entry answers tokens parsed + rw [suffix] at history + have nonempty : openingScalars saved ≠ [] := by simp [openingScalars] + obtain ⟨pre,literal⟩ := literalRun_sent_suffix entry.domain entry.statement preTokens (openingScalars saved) nonempty + rw [history] at literal + exact decode_literal_run p entry saved valid profile pre literal + +/-- Endpoint using exactly the profile predicate of the source reference parser. -/ +theorem decode_saved_profileShape (p : ParameterBounds.Profile) (layout : CallerLayout) (saved : Record) + (entry : FramedHistory) (answers : Coordinate → Digest32) (claims : AnchoredSourceCaller.Claims) + (accepted : AnchoredSourceFreshCaller.decode layout saved entry answers = some claims) + (valid : saved.Valid) (profile : PCSBCSSourceRootReferences.profileShape p saved.shape) : + PCSBCSSourceSavedRecordDecoder.decode p entry = some saved := + decode_saved p layout saved entry answers claims accepted valid (profileShape_compatible p saved profile) + +#print axioms consumes_payload +#print axioms sourceClaims_suffix +#print axioms literalRun_sent_suffix +#print axioms decode_saved +#print axioms decode_saved_profileShape +end Whir.PCSBCSSourceSavedRecordProvenance diff --git a/verification/whir/Whir/PCSBCSWholeNativeCaptureTransport.lean b/verification/whir/Whir/PCSBCSWholeNativeCaptureTransport.lean new file mode 100644 index 000000000..75744e2ac --- /dev/null +++ b/verification/whir/Whir/PCSBCSWholeNativeCaptureTransport.lean @@ -0,0 +1,924 @@ +import Whir.PCSBCSNativeCapturedReplyTransport +import Whir.PCSBCSWholeNativePacketCoverage +import Whir.PCSBCSNativeCompleteAlarm +import Whir.PCSBCSNativePhysicalFreeze + +/-! Whole historical first-address captures. Every getter below uses the actual +allocation program, retaining arbitrary earlier ordinary and construction asks. +Native replay and strict reply transport use this same capture, not a fresh +verifier cache. Per-opening exclusions are low-level mixed-experiment premises; +the complete-alarm module discharges them for the actual real execution. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 100000 +namespace Whir.PCSBCSWholeNativeCaptureTransport +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open MerkleTransport MerkleTransport.Commitments PublicMerkleLog +open WHIRPhysicalVerifier WHIRPhysicalReplay AnchoredPhysicalDriver +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache +open PCSBCSCapturedNativeReplyBridge PCSBCSCapturedNativePhaseQuery +open PCSBCSSourceFrozenAccessor PCSBCSFrozenOracleRows +open PCSBCSNativeCapturedReplyTransport +open PCSBCSCapturedSourceAcceptance + +section Capture +variable {ctx : RawWHIRKeys.Context} {stack : ctx.mode = .stack} {Q cap : Nat} + (packet : RawWHIRKeys.Packet ctx Q) (saved : AnchoredHeaderCodec.Record) + {B boundary : Nat} {R : Type} {count : Nat} + (program : Sampling + (PCSBCSSourceRootCapture.Key (p := packet.val.profile) (Q := B) (iv := ctx.iv) (boundary := boundary)) + PCSBCSSourceRootCapture.Answer R count) + (seed : PrimitiveOracle) (ro : RawKey B → Digest32) + +noncomputable abbrev addresses := + PCSBCSCapturedSourceTransport.address (p := packet.val.profile) (Q := B) (iv := ctx.iv) + (boundary := boundary) +noncomputable abbrev table := + (PCSBCSChallengeOracle.EnteredPacket.partition (p := packet.val.profile) (Q := B) + (iv := ctx.iv) (boundary := boundary)).split (PublicCompressionCouplingMixed.oracle seed ro) +noncomputable def referenceLog (ref : Reference) : PublicLog := + sourceLog (addresses packet) ref program (table packet seed ro) +noncomputable def openingLog (opening : QueryOpening packet.val.profile) : PublicLog := + referenceLog packet program seed ro (PCSBCSNativeRootRoles.openingRole saved opening) +noncomputable def logFor (root : Digest32) (level : Nat) : PublicLog := + referenceLog packet program seed ro ⟨root,PCSBCSNativeRootRoles.nativeShape packet.val.profile saved level⟩ + +noncomputable def base : CausalGame.BaseOracle := + WHIRPhysicalRows.compactBaseOracle (hash seed) + ⟨recordDomain (records (logFor packet saved program seed ro saved.root 0)),[]⟩ + saved.root (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2 + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0) + (leafWords packet.val.profile 0) saved.shape.lanes + +noncomputable def roots : WHIRReplay.Roots := fun root level => + frozenQueryOracle (hash seed) + ⟨recordDomain (records (logFor packet saved program seed ro root level)),[]⟩ + root packet.val.profile level (2^(ParameterBounds.config packet.val.profile).folds[0]!) + +theorem roots_rectangular (root : Digest32) (level : Nat) : + oracleValid (roots packet saved program seed ro root level) + (ParameterBounds.length (ParameterBounds.config packet.val.profile) level) + (2^(ParameterBounds.config packet.val.profile).folds[level]!) = true := by + have shape := frozenQueryOracle_valid (hash seed) + ⟨recordDomain (records (logFor packet saved program seed ro root level)),[]⟩ + root packet.val.profile level (2^(ParameterBounds.config packet.val.profile).folds[0]!) (by rfl) + by_cases zero : level = 0 + · simpa only [roots,zero,ite_true] using shape + · simpa only [roots,ite_eq_right zero] using shape + +theorem base_valid (fits : saved.shape.lanes ≤ 2^(ParameterBounds.config packet.val.profile).folds[0]!) : + oracleValid (CausalGame.liftRoot (base packet saved program seed ro)) + (2^((ParameterBounds.config packet.val.profile).logN-(ParameterBounds.config packet.val.profile).folds[0]!+ + (ParameterBounds.config packet.val.profile).rates[0]!)) saved.shape.lanes = true := by + have shape := WHIRPhysicalVerifier.compactBaseOracle_valid (hash seed) + ⟨recordDomain (records (logFor packet saved program seed ro saved.root 0)),[]⟩ + saved.root (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2 + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0) + (2^(ParameterBounds.config packet.val.profile).folds[0]!) saved.shape.lanes fits + simpa only [base,leafWords,ite_true,ParameterBounds.length, + PCSBCSNativeRootRoles.production_initial_remaining] using shape + +theorem opening_log (opening : QueryOpening packet.val.profile) : + openingLog packet saved program seed ro opening = + logFor packet saved program seed ro opening.root opening.level.val := rfl + +theorem referenceLog_authentic (ref : Reference) : + AuthenticLog seed (referenceLog packet program seed ro ref) := + PCSBCSMerkleSeedProjection.sourceLog_authentic seed ro (addresses packet) ref program + + +/-- Every selected native row binds to its actual whole first-mention log. -/ +theorem native_boundRows (model : WHIRCallerSupport.ProductionLayout) + (proofs : Array PrunedMerklePaths) (observations : List Observation) + (a : Accepted ctx Q cap packet saved) + (run : PublicMerkleProgram.Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + observations (some a)) + (consistent : AnchoredIdealPhysicalAcceptance.PrimitiveConsistent seed observations) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed (openingLog packet saved program seed ro opening) + opening.root opening.result.paths) : + WHIRPhysicalRoots.BoundRows (base packet saved program seed ro) + (roots packet saved program seed ro) a.wire := by + obtain ⟨_,_,_,trace,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs observations a run + intro opening member + obtain ⟨proof,_,accepted,_⟩ := AnchoredIdealPhysicalAcceptance.observed_real + (observed opening member) seed ctx.iv consistent + let log := openingLog packet saved program seed ro opening + have auth : AuthenticLog seed log := referenceLog_authentic packet program seed ro _ + have good := (WHIRPhysicalVerifier.openQuery_binding seed ctx.iv log auth + ⟨recordDomain (records log),[]⟩ rfl packet.val.profile opening.level saved.shape.lanes + proof opening.root opening.sample opening.result accepted).resolve_right (quiet opening member) + dsimp only [log] at good + rw [opening_log packet saved program seed ro opening] at good + by_cases zero : opening.level.val = 0 + · have rootEq := PCSBCSNativeCapturedOracles.verifySource_initial_root + cap model ctx stack Q packet saved proofs a observations run opening member zero + simpa only [zero,rootEq,ite_true,base,frozenQueryOracle] using good + · simpa only [roots,frozenQueryOracle,ite_eq_right zero] using good + +theorem native_experiment (model : WHIRCallerSupport.ProductionLayout) + (proofs : Array PrunedMerklePaths) (observations : List Observation) + (a : Accepted ctx Q cap packet saved) + (run : PublicMerkleProgram.Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + observations (some a)) + (consistent : AnchoredIdealPhysicalAcceptance.PrimitiveConsistent seed observations) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed (openingLog packet saved program seed ro opening) + opening.root opening.result.paths) : + ∃ replay : StackWHIRReplay.Replay packet.val.profile cap, ∃ proof, + replay.original = PCSBCSNativeOracleReplay.original a (base packet saved program seed ro) ∧ + a.wire.initial = some replay.initial ∧ a.wire.tape.1 = replay.initial.2 ∧ + replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies ∧ + CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) + replay.whir.replies = .ok proof ∧ + WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a (base packet saved program seed ro))) + (roots packet saved program seed ro) (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile a.history).tail⟩ = + some replay ∧ + CausalGame.experiment (PCSBCSNativeOracleReplay.input a + (base packet saved program seed ro) replay.initial.1) + (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true := by + obtain ⟨_,_,lanesEq,_,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs observations a run + have fits : saved.shape.lanes ≤ 2^(ParameterBounds.config packet.val.profile).folds[0]! := by + rw [← lanesEq] + exact a.request.lane_bound + exact PCSBCSNativeOracleReplay.verifySource_experiment .fresh model proofs observations a run + (base packet saved program seed ro) (roots packet saved program seed ro) + (base_valid packet saved program seed ro fits) + (roots_rectangular packet saved program seed ro) + (native_boundRows packet saved program seed ro model proofs observations a run consistent quiet) + +/-- Parsed next roles have exactly the shape used by the captured root getter. -/ +theorem next_log (i : Fin (ParameterBounds.config packet.val.profile).folds.size) + (j : Fin (ParameterBounds.config packet.val.profile).folds[i.val]!) + (m : WHIRHistory.Pending) (ref : Reference) + (parsed : parsePhase (ParameterBounds.config packet.val.profile) (.fold i j) m (i.val+1) 2 = some ref) : + referenceLog packet program seed ro ref = + logFor packet saved program seed ro + ref.root (i.val+1) := by + have shape := (parsePhase_admitted _ _ _ _ _ _ parsed).2.2.2 + unfold logFor + congr 1 + cases ref + congr 1 + +/-- The full next table is the projection of the same literal captured prefix. +No later whole-cache equality is present, even as an intermediate hypothesis. -/ +theorem next_projection (i : Fin (ParameterBounds.config packet.val.profile).folds.size) + (j : Fin (ParameterBounds.config packet.val.profile).folds[i.val]!) + (m : WHIRHistory.Pending) (ref : Reference) + (parsed : parsePhase (ParameterBounds.config packet.val.profile) (.fold i j) m (i.val+1) 2 = some ref) + (clean : ¬ OutputCollision (referenceLog packet program seed ro ref)) : + extensionOracle (WHIRPhysicalRows.compactBaseOracle (hash seed) + ⟨recordDomain (records (referenceLog packet program seed ro ref)),[]⟩ + ref.root ref.shape.height (2^ref.shape.height) + ref.shape.leafWords ref.shape.occupied) = + some (roots packet saved program seed ro + ref.root (i.val+1)) := by + have projection := (parsed_next_projection seed + (referenceLog packet program seed ro ref) + packet.val.profile i j m ref parsed + (referenceLog_authentic packet program seed ro ref) clean).1 + rw [next_log packet saved program seed ro i j m ref parsed] at projection ⊢ + simpa only [roots, frozenQueryOracle, Nat.add_eq_zero_iff, + Nat.one_ne_zero, and_false, ↓reduceIte] using projection + +theorem native_query + (a : Accepted ctx Q cap packet saved) + (model : WHIRCallerSupport.ProductionLayout) (proofs : Array PrunedMerklePaths) + (observations : List Observation) + (run : PublicMerkleProgram.Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + observations (some a)) + (consistent : AnchoredIdealPhysicalAcceptance.PrimitiveConsistent seed observations) + (final current : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv + boundary) + (messages : final.2.messages = packet.val.messages) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) + (ring : RingPCSGame.Prefix) + (raws : ∀ sourcePacket ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped sourcePacket.2.coord + ((table packet seed ro) (.inl sourcePacket)) = + PCSBCSRestorationHazard.literalRaw ring a.wire.tape sourcePacket.2.coord) + (opening : QueryOpening packet.val.profile) (opened : opening ∈ a.wire.openings) + (earlier : CausalProbability.position (.query opening.level : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) < + CausalProbability.position current.2.coord) + (m : WHIRHistory.Pending) (digest : Digest32) (introMessage : Message E) : + SourceEvidence (addresses packet) + program (table packet seed ro) + seed current.2.coord saved current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table packet seed ro) key.val)) + m digest (.query opening.level) (.query opening.result.rows introMessage) ∨ + PublicMerkleBinding.OpenPrimitiveBad seed + (openingLog packet saved program seed ro opening) + opening.root opening.result.paths := by + obtain ⟨_,_,lanesEq,trace,observed⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + have chain := completion_chain ctx Q packet + have reference := (trace_queryRoles saved a.configuration.1 a.configuration.2 chain trace opening opened).2 + have earlierPrefix := packets_query_prefix final current member (.query opening.level) earlier + rw [← messages,← earlierPrefix] at reference + have sample := (WHIRPhysicalRoots.trace_samples saved.root chain trace opening opened).2 + have past := strictPrefix_of_raws final current member (table packet seed ro) ring a.wire.tape raws + have sampleAt : PCSBCSSourcePacketTape.strictPrefix current + (fun key => (table packet seed ro) key.val) (.query opening.level) earlier = + opening.sample := by + rw [past] + exact sample + obtain ⟨proof,_,accepted,_⟩ := AnchoredIdealPhysicalAcceptance.observed_real + (observed opening opened) seed ctx.iv consistent + have fits : saved.shape.lanes ≤ 2^(ParameterBounds.config packet.val.profile).folds[0]! := by + rw [← lanesEq] + exact a.request.lane_bound + have evidence := source_query_of_native (addresses packet) program (table packet seed ro) + seed current.2.coord saved current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table packet seed ro) key.val)) + m digest opening.level introMessage earlier (PCSBCSNativeRootRoles.openingRole saved opening) + reference (referenceLog_authentic packet program seed ro _) fits proof opening.result + (by simpa only [sampleAt,PCSBCSNativeRootRoles.openingRole] using accepted) + exact evidence + +theorem source_of_parser + (current : CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) + (messages : List WHIRHistory.Pending) (past : WHIRFiatShamir.Prefix current) + (q : CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) + (m : WHIRHistory.Pending) (native : CausalGame.Reply) (rows : WHIRPhysicalHistory.Rows) + (earlier : CausalProbability.position q < CausalProbability.position current) + (parsed : WHIRPhysicalHistory.reply + (roots packet saved program seed ro) + rows q m = some native) + (clean : ∀ ref, ¬ OutputCollision + (referenceLog packet program seed ro ref)) + (queries : ∀ (i : Fin (ParameterBounds.config packet.val.profile).folds.size) (introMessage : Message E), + CausalProbability.position (.query i : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) < + CausalProbability.position current → + SourceEvidence (addresses packet) + program (table packet seed ro) + seed current saved messages past m DuplexRefinement.zeroDigest (.query i) (.query (rows i.val) introMessage)) : + ∃ digest, WHIRHistory.replyScalars q digest native = some m.scalars ∧ + SourceEvidence (addresses packet) + program (table packet seed ro) + seed current saved messages past m digest q native := by + cases q with + | initial => + obtain ⟨message,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + exact ⟨DuplexRefinement.zeroDigest,congrArg some (decodeMessage_fields _ _ decoded).symm,.initial message⟩ + | tail j => + obtain ⟨message,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + exact ⟨DuplexRefinement.zeroDigest,congrArg some (decodeMessage_fields _ _ decoded).symm,.tail j message⟩ + | query i => + obtain ⟨message,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + exact ⟨DuplexRefinement.zeroDigest,congrArg some (decodeMessage_fields _ _ decoded).symm, + queries i message earlier⟩ + | ood i j => + cases m with + | mk scalars nonce => + cases scalars with + | nil => cases parsed + | cons value rest => + cases rest with + | nil => cases parsed + | cons a rest => + cases rest with + | nil => cases parsed + | cons b rest => + cases rest with + | cons c rest => cases parsed + | nil => + cases Option.some.inj parsed + exact ⟨DuplexRefinement.zeroDigest,rfl,.ood i j ⟨value,⟨a,b⟩⟩⟩ + | fold i j => + cases m with + | mk scalars nonce => + cases scalars with + | nil => cases parsed + | cons a rest => + cases rest with + | nil => cases parsed + | cons b rest => + by_cases last : j.val+1 = (ParameterBounds.config packet.val.profile).folds[i.val]! + · by_cases later : i.val+1 < (ParameterBounds.config packet.val.profile).folds.size + · cases rest with + | nil => simp [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last,later] at parsed + | cons r rest => + cases rest with + | nil => simp [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last,later] at parsed + | cons s rest => + cases rest with + | cons extra rest => + simp [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last,later] at parsed + | nil => + simp only [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars, + last,↓reduceIte,later] at parsed + obtain ⟨digest,decoded,equal⟩ := Option.map_eq_some_iff.mp parsed + subst native + let ref : Reference := ⟨digest,phaseShape (ParameterBounds.config packet.val.profile) (i.val+1)⟩ + have reference : parsePhase (ParameterBounds.config packet.val.profile) (.fold i j) + ⟨[a,b,r,s],nonce⟩ (i.val+1) 2 = some ref := by + simp [parsePhase,last,later,parseRootScalars,decoded,ref] + have auth := referenceLog_authentic packet program seed ro ref + have projection := next_projection packet saved program seed ro + i j ⟨[a,b,r,s],nonce⟩ ref reference (clean ref) + have pair := ByteCodec.hashToScalars_scalarsToHash (r,s) digest decoded + refine ⟨digest,?_,?_⟩ + · simp only [WHIRHistory.replyScalars,last,↓reduceIte,WHIRHistory.boundaryScalars, + later,WHIRHistory.messageScalars,WHIRHistory.rootScalars,pair] + rfl + · exact .next i j ⟨a,b⟩ _ last later ref + (referenceLog packet program seed ro ref) + reference rfl (Nat.le_refl _) auth (clean ref) projection + · simp only [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars,last, + ↓reduceIte,ite_eq_right later] at parsed + split at parsed + · rename_i width + cases Option.some.inj parsed + refine ⟨DuplexRefinement.zeroDigest,?_,.terminal i j ⟨a,b⟩ rest.toArray last later ?_⟩ + · simp [WHIRHistory.replyScalars,last,WHIRHistory.boundaryScalars,later, + WHIRHistory.messageScalars] + · simpa only [List.size_toArray] using width + · cases parsed + · simp only [WHIRPhysicalHistory.reply,WHIRHistory.decodeReplyScalars, + ite_eq_right last] at parsed + split at parsed + · rename_i empty + subst rest + cases Option.some.inj parsed + exact ⟨DuplexRefinement.zeroDigest,by simp only [WHIRHistory.replyScalars, + ite_eq_right last,WHIRHistory.messageScalars,List.append_nil],.middle i j ⟨a,b⟩ last⟩ + · cases parsed + +theorem native_replyTransport_of_decode + (a : Accepted ctx Q cap packet saved) + (model : WHIRCallerSupport.ProductionLayout) (proofs : Array PrunedMerklePaths) + (observations : List Observation) + (run : PublicMerkleProgram.Runs (WHIRSourceChronology.erase + (AnchoredPhysicalDriver.verifySource cap .fresh model ctx stack Q packet saved proofs)) + observations (some a)) + (consistent : AnchoredIdealPhysicalAcceptance.PrimitiveConsistent seed observations) + (replay : StackWHIRReplay.Replay packet.val.profile cap) + (decoded : WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a + (base packet saved program seed ro))) + (roots packet saved program seed ro) + (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages, + (localHistory ctx stack Q packet.val.profile a.history).tail⟩ = some replay) + (final : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv + boundary) + (messages : final.2.messages = packet.val.messages) + (raws : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped current.2.coord ((table packet seed ro) (.inl current)) = + PCSBCSRestorationHazard.literalRaw replay.initial.1 a.wire.tape current.2.coord) + (quiet : ∀ opening ∈ a.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (openingLog packet saved program seed ro opening) + opening.root opening.result.paths) + (clean : ∀ ref, ¬ OutputCollision + (referenceLog packet program seed ro ref)) : + ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSCapturedSourceAcceptance.ReplyTransport (addresses packet) + program (table packet seed ro) + seed saved current replay.whir.replies := by + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution + cap .fresh model ctx stack Q packet saved proofs _ a run + have chain := completion_chain ctx Q packet + let original := PCSBCSNativeOracleReplay.original a + (base packet saved program seed ro) + obtain ⟨initial,_,rest⟩ := Option.bind_eq_some_iff.mp decoded + obtain ⟨whir,parsedWhir,equal⟩ := Option.bind_eq_some_iff.mp rest + have equal : (⟨original,initial,whir⟩ : StackWHIRReplay.Replay packet.val.profile cap) = replay := + Option.some.inj equal + have whirEq : whir = replay.whir := congrArg StackWHIRReplay.Replay.whir equal + have parsed := parses_of_decode packet.val.profile (StackWHIRReplay.localCatalog original initial) + (roots packet saved program seed ro) + (fun i => a.wire.rows[i]!) packet.val.statement packet.val.messages + ((localHistory ctx stack Q packet.val.profile a.history).tail.map StackWHIRReplay.projectEntry) + replay.whir (by + rw [← whirEq] + exact parsedWhir) + have size : replay.whir.replies.size = CausalProbability.position final.2.coord := by + rw [parsed.size,← messages,PCSBCSChallengeOracle.CanonicalPacket.messages_length final.2] + omega + intro current member j earlier + have bound : j < replay.whir.replies.size := by + rw [size] + exact Nat.lt_of_lt_of_le earlier (packets_position_le final current member) + obtain ⟨q,m,previous,sample,scheduled,atMessage,atReply,inAncestors⟩ := parsed.replyAt j bound + have qPosition := PCSBCSCapturedSourceAcceptance.schedule_coordinate_position j q scheduled + have prior : CausalProbability.position q < CausalProbability.position current.2.coord := by + rw [qPosition] + exact earlier + have currentMessage : current.2.messages.reverse[j+1]? = some m := by + rw [packets_message_at final current member j earlier,messages] + exact atMessage + obtain ⟨digest,scalars,evidence⟩ := source_of_parser packet saved program seed ro + current.2.coord current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table packet seed ro) key.val)) + q m replay.whir.replies[j]! (fun i => a.wire.rows[i]!) prior atReply clean (by + intro i introMessage earlierQuery + have queryBound : CausalProbability.position (.query i : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile)) < replay.whir.replies.size := by + rw [size] + exact Nat.lt_of_lt_of_le earlierQuery (packets_position_le final current member) + obtain ⟨coordinate,message,old,x,atCoordinate,_,_,inPast⟩ := + parsed.replyAt (CausalProbability.position (.query i : + CausalProbability.Coordinate (ParameterBounds.config packet.val.profile))) queryBound + have same : coordinate = .query i := Option.some.inj + (atCoordinate.symm.trans (WHIRHistory.schedule_get_position (.query i))) + subst coordinate + have recorded := WHIRPhysicalRoots.projectEntry_query_mem + (localHistory ctx stack Q packet.val.profile a.history).tail old i x inPast + have recorded : (old,⟨.query i,x⟩) ∈ localHistory ctx stack Q packet.val.profile a.history := + List.mem_of_mem_tail recorded + obtain ⟨opening,opened,level,sample⟩ := WHIRPhysicalRoots.trace_recorded trace _ recorded + have row := (WHIRPhysicalRoots.trace_rooted saved.root trace opening opened).2 + cases opening with + | mk level' root x' result => + dsimp only at level sample row + subst level' + have rowEq : a.wire.rows[i.val]! = result.rows := by + rw [getElem!_def,row] + have source := (native_query packet saved program seed ro a model proofs observations run consistent + final current messages member replay.initial.1 raws ⟨i,root,x',result⟩ opened earlierQuery + m DuplexRefinement.zeroDigest introMessage).resolve_right + (quiet ⟨i,root,x',result⟩ opened) + rw [rowEq] + exact source) + exact ⟨q,m,digest,scheduled,currentMessage,scalars,evidence⟩ + +theorem base_eq_sourceRoot (profile : profileShape packet.val.profile saved.shape) : + base packet saved program seed ro = + sourceRoot seed (addresses packet) ⟨saved.root,initialShape saved.shape⟩ program (table packet seed ro) := by + have shape := PCSBCSNativeRootRoles.nativeShape_opening packet.val.profile saved profile 0 + have length : 2^((ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2) = + ParameterBounds.length (ParameterBounds.config packet.val.profile) 0 := by + simp [ParameterBounds.length] + unfold base sourceRoot + have ref : (⟨saved.root,PCSBCSNativeRootRoles.nativeShape packet.val.profile saved 0⟩ : Reference) = + ⟨saved.root,initialShape saved.shape⟩ := rfl + change WHIRPhysicalRows.compactBaseOracle (hash seed) + ⟨recordDomain (records (referenceLog packet program seed ro + ⟨saved.root,PCSBCSNativeRootRoles.nativeShape packet.val.profile saved 0⟩)),[]⟩ saved.root + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2 + (ParameterBounds.length (ParameterBounds.config packet.val.profile) 0) + (leafWords packet.val.profile 0) saved.shape.lanes = _ + rw [ref] + have shape' : initialShape saved.shape = + ⟨(ParameterBounds.length (ParameterBounds.config packet.val.profile) 0).log2, + leafWords packet.val.profile 0,saved.shape.lanes⟩ := by + simpa only [PCSBCSNativeRootRoles.nativeShape,ite_true] using shape + simp only [shape',referenceLog,length] + +/-- The complete strict incoming captured caller, with the same actual whole +root and the same canonical full native replies. -/ +def CapturedAssembly (original : PCSBCSCallerBinding.CallerInput packet.val.profile) + (current : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv boundary) + (ring : RingPCSGame.Prefix) (tape : CausalGame.Tape (ParameterBounds.config packet.val.profile)) + (native : Array CausalGame.Reply) : Prop := + ∃ parsed, + PCSBCSSourceFrozenReplies.replies current.2.coord saved + (PCSBCSSourceCallerSnapshot.capturedRegistry (addresses packet) program current + (fun key => (table packet seed ro) key.val)) + current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table packet seed ro) key.val)) = + some parsed ∧ + parsed = PCSRoundByRoundTranscriptState.priorAnswers native (CausalProbability.position current.2.coord) ∧ + PCSBCSRestorationHazard.incomingTrace + (PCSBCSSourcePacketTape.ringPrefix current (fun key => (table packet seed ro) key.val)) + (PCSBCSSourcePacketTape.tape current (fun key => (table packet seed ro) key.val)) parsed current.2.coord = + PCSBCSRestorationHazard.incomingTrace ring tape native current.2.coord ∧ + PCSBCSSourceCallerSnapshot.fromCapture (addresses packet) + ⟨saved.root,initialShape saved.shape⟩ program original saved current + (fun key => (table packet seed ro) key.val) = + some (PCSBCSRestorationHazard.literalCallerData packet.val.profile original + (sourceRoot seed (addresses packet) ⟨saved.root,initialShape saved.shape⟩ program (table packet seed ro)) + ring tape native current.2.coord) + +theorem native_assembly + (a : Accepted ctx Q cap packet saved) (model : WHIRCallerSupport.ProductionLayout) + (original : PCSBCSCallerBinding.CallerInput packet.val.profile) (claims : AnchoredSourceCaller.Claims) + (caller : AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table (boundary := boundary) packet seed ro)) = some claims) + (final current : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv boundary) + (entry : final.1.val = RawWHIRKeys.entry ctx packet.val) + (member : current ∈ PCSBCSCapturedSourceStatePath.packets final) + (recorded : (⟨.inl current,(table packet seed ro) (.inl current)⟩ : + Sigma PCSBCSSourceRootCapture.Answer) ∈ (Sampling.execute (table packet seed ro) program).2) + (ring : RingPCSGame.Prefix) (tape : CausalGame.Tape (ParameterBounds.config packet.val.profile)) + (native : Array CausalGame.Reply) + (raws : ∀ sourcePacket ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped sourcePacket.2.coord ((table packet seed ro) (.inl sourcePacket)) = + PCSBCSRestorationHazard.literalRaw ring tape sourcePacket.2.coord) + (transport : PCSBCSCapturedSourceAcceptance.ReplyTransport (addresses packet) program + (table packet seed ro) seed saved current native) + (clean : ∀ ref, ¬ OutputCollision (referenceLog packet program seed ro ref)) : + CapturedAssembly packet saved program seed ro original current ring tape native := by + have currentEntry : current.1.val = RawWHIRKeys.entry ctx packet.val := + (congrArg Subtype.val (PCSBCSCapturedSourceStatePath.packets_entry final current member)).trans entry + have roles := PCSBCSCapturedSourceAcceptance.roles_from_transport + (addresses packet) program (table packet seed ro) seed saved current native transport + have addressRoles := PCSBCSCapturedSourceTransport.address_packet model.layout saved + (PCSBCSSourceCallerAnswers.answers (table (boundary := boundary) packet seed ro)) current + a.configuration.1 a.configuration.2 claims (by simpa only [currentEntry] using caller) roles + have visited : (.inl current) ∈ ((Sampling.execute (table packet seed ro) program).2.map Sigma.fst) := + List.mem_map.mpr ⟨_,recorded,rfl⟩ + let ref : Reference := ⟨saved.root,initialShape saved.shape⟩ + let log := referenceLog packet program seed ro ref + have mentioned : ref ∈ addresses packet (.inl current) := by + change ref ∈ PCSBCSCapturedSourceTransport.address (.inl current) + rw [addressRoles] + exact List.mem_cons_self + have root := source_registry_enabled (addresses packet) program (table packet seed ro) + current ref mentioned visited + have root : PCSBCSSourceCallerSnapshot.capturedRegistry (addresses packet) program current + (fun key => (table packet seed ro) key.val) ref = some (freeze log ref.root ref.shape) := root + have inverses := PCSBCSCapturedSourceAcceptance.source_inverse + (addresses packet) program (table packet seed ro) seed saved current native addressRoles visited transport + obtain ⟨parsed,assembled⟩ := PCSBCSCapturedSourceTransport.replies_complete current.2.coord saved + (PCSBCSSourceCallerSnapshot.capturedRegistry (addresses packet) program current + (fun key => (table packet seed ro) key.val)) current.2.messages + (PCSBCSSourcePacketTape.strictPrefix current (fun key => (table packet seed ro) key.val)) (by + intro j earlier + obtain ⟨inverted,found,_⟩ := Option.map_eq_some_iff.mp (inverses j earlier) + exact ⟨inverted,found⟩) + have parsedEq := PCSBCSCapturedSourceStatePath.replies_exact current.2.coord saved _ _ _ native parsed assembled inverses + have priorRaws : ∀ earlier : current.Earlier, + PCSBCSSourcePacketTape.rawPrefix current (fun key => (table packet seed ro) key.val) + earlier.val earlier.property = PCSBCSRestorationHazard.literalRaw ring tape earlier.val := by + intro earlier + rw [PCSBCSSourcePacketTape.rawPrefix_table] + exact raws _ (PCSBCSCapturedSourceStatePath.predecessor_mem_packets final current member earlier) + have incoming := PCSBCSCapturedSourceStatePath.incoming_exact current + (table packet seed ro) ring tape native parsed parsedEq priorRaws + have snapshot := PCSBCSCapturedSourceStatePath.fromCapture_exact (addresses packet) ref + program original saved current (table packet seed ro) (freeze log ref.root ref.shape) root + ring tape native priorRaws inverses + have rawEq : (freeze log ref.root ref.shape).raw = + sourceRoot seed (addresses packet) ⟨saved.root,initialShape saved.shape⟩ program (table packet seed ro) := + (next_image_provenance seed log ref (referenceLog_authentic packet program seed ro ref) (clean ref)).2 + rw [rawEq] at snapshot + exact ⟨parsed,assembled,parsedEq,incoming,snapshot⟩ + +theorem original_bound (model : WHIRCallerSupport.ProductionLayout) + (input : PCSBCSCallerBinding.CallerInput packet.val.profile) + (reconstructed : PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table (boundary := boundary) packet seed ro)) = some input) : + ∃ claims : AnchoredSourceCaller.Claims, + AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table (boundary := boundary) packet seed ro)) = some claims ∧ + BoundOriginal input saved claims := by + obtain ⟨claims,fc,cc,prepared,decoded,recordEq,rootEq,_,rfl⟩ := + PCSBCSSourceCallerOriginal.original_exact packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table (boundary := boundary) packet seed ro)) input reconstructed + refine ⟨claims,decoded,recordEq,rootEq,rfl,?_,rfl,rfl,rfl⟩ + exact List.ofFn_getElem + +/-- Witnesses and consequences, never certificates supplied to the endpoint. -/ +structure CaptureResult (model : WHIRCallerSupport.ProductionLayout) + (a : Accepted ctx Q cap packet saved) where + original : PCSBCSCallerBinding.CallerInput packet.val.profile + claims : AnchoredSourceCaller.Claims + replay : StackWHIRReplay.Replay packet.val.profile cap + proof : Opening + final : PCSBCSChallengeOracle.EnteredPacket packet.val.profile B ctx.iv boundary + entry : final.1.val = RawWHIRKeys.entry ctx packet.val + messages : final.2.messages = packet.val.messages + terminal : final.2.coord = PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config packet.val.profile) + depth : packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config packet.val.profile) + original_decoded : PCSBCSSourceCallerOriginal.original packet.val.profile model.layout saved + (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table (boundary := boundary) packet seed ro)) = some original + caller_decoded : AnchoredSourceFreshCaller.decode model.layout saved (RawWHIRKeys.entry ctx packet.val) + (PCSBCSSourceCallerAnswers.answers (table (boundary := boundary) packet seed ro)) = some claims + bound_original : BoundOriginal original saved claims + bound_rows : WHIRPhysicalRoots.BoundRows (base packet saved program seed ro) + (roots packet saved program seed ro) a.wire + replay_original : replay.original = PCSBCSNativeOracleReplay.original a (base packet saved program seed ro) + initial : a.wire.initial = some replay.initial + lambda : a.wire.tape.1 = replay.initial.2 + erased : replay.whir.replies.map WHIRPhysicalErasure.eraseReply = a.wire.replies + opening : CausalGame.opening (ParameterBounds.config packet.val.profile) + (CausalGame.challenges (ParameterBounds.config packet.val.profile) a.wire.tape) replay.whir.replies = .ok proof + canonical : WHIRPhysicalHistory.decodeStack packet.val.profile cap + (fun _ => some (PCSBCSNativeOracleReplay.original a (base packet saved program seed ro))) + (roots packet saved program seed ro) (fun i => a.wire.rows[i]!) + ⟨packet.val.statement,packet.val.messages,(localHistory ctx stack Q packet.val.profile a.history).tail⟩ = some replay + explains : ∀ root ring, OriginalClaimsChecker.input original.prepared root ring = + PCSBCSNativeOracleReplay.input a root ring + experiment : CausalGame.experiment + (OriginalClaimsChecker.input original.prepared + (sourceRoot seed (addresses packet) ⟨saved.root,initialShape saved.shape⟩ program (table packet seed ro)) + replay.initial.1) (CausalStrategy.indexedStrategy replay.whir.replies) a.wire.tape = true + native_replies : nativeReplies original + (sourceRoot seed (addresses packet) ⟨saved.root,initialShape saved.shape⟩ program (table packet seed ro)) + (fun _ => CausalStrategy.indexedStrategy replay.whir.replies) replay.initial.1 a.wire.tape = replay.whir.replies + recorded : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + (⟨.inl current,(table packet seed ro) (.inl current)⟩ : Sigma PCSBCSSourceRootCapture.Answer) ∈ + (Sampling.execute (table packet seed ro) program).2 + raws : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + PCSBCSChallengeOracle.grouped current.2.coord ((table packet seed ro) (.inl current)) = + PCSBCSRestorationHazard.literalRaw replay.initial.1 a.wire.tape current.2.coord + transport : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + ReplyTransport (addresses packet) program (table packet seed ro) seed saved current replay.whir.replies + assembly : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + CapturedAssembly packet saved program seed ro original current replay.initial.1 a.wire.tape replay.whir.replies + mentioned : ∀ opening ∈ a.wire.openings, ∃ events, + PCSBCSFirstRootDisclosure.firstMention (addresses packet) + (PCSBCSNativeRootRoles.openingRole saved opening) program (table packet seed ro) = some events + +theorem openingReference_eq_role (profile : profileShape packet.val.profile saved.shape) + (opening : QueryOpening packet.val.profile) : + PCSBCSCapturedIdealNativeAcceptance.openingReference ctx Q packet opening saved.shape.lanes = + PCSBCSNativeRootRoles.openingRole saved opening := by + unfold PCSBCSCapturedIdealNativeAcceptance.openingReference PCSBCSNativeRootRoles.openingRole + rw [PCSBCSNativeRootRoles.nativeShape_opening packet.val.profile saved profile opening.level.val] + +end Capture + +section Whole +variable (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + (A B : Nat) (limit : A ≤ B) + (counted : DuplexModeGame.Counts A (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker)) + (seed : PrimitiveOracle) (ro : RawKey B → Digest32) + +noncomputable abbrev wholeAllocation (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) := + PCSBCSNativePhysicalFreeze.allocationProgram (p := a.input.packet.val.profile) (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker) A limit counted + +noncomputable abbrev wholeOpeningLog (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (opening : QueryOpening a.input.packet.val.profile) := + openingLog a.input.packet a.input.record (wholeAllocation cap registry Q attacker A B limit counted a) + seed ro opening + +noncomputable abbrev wholeReferenceLog (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (ref : Reference) := + referenceLog a.input.packet (wholeAllocation cap registry Q attacker A B limit counted a) seed ro ref + +/-- Original decoding uses the actual caller preparation and the genuine +previous construction-output answers from the same whole table. -/ +theorem mixed_success_original (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (familyCap : cap ≤ 2^64) + (success : (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro).result.value = + some a) : + ∃ input : PCSBCSCallerBinding.CallerInput a.input.packet.val.profile, + PCSBCSSourceCallerOriginal.original a.input.packet.val.profile + (registry.packetModel Q a.input.packet).layout a.input.record + (RawWHIRKeys.entry registry.context a.input.packet.val) + (PCSBCSSourceCallerAnswers.answers (table + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + a.input.packet seed ro)) = some input ∧ + input.m = a.native.request.claims.count ∧ + ∀ root ring, OriginalClaimsChecker.input input.prepared root ring = + PCSBCSNativeOracleReplay.input a.native root ring := by + obtain ⟨_,after,_,_,run,_⟩ := PCSBCSWholeNativePacketCoverage.mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨_,shape,_,_,_,_,_,_,_,_⟩ := AnchoredPhysicalExecution.verifySource_success cap .fresh + (registry.packetModel Q a.input.packet) registry.context rfl Q + a.input.packet a.input.record a.input.proofs after a.native run + obtain ⟨before,parsed,earlier⟩ := PCSBCSWholeNativePacketCoverage.mixed_success_caller_preparation + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨input,reconstructed,count,statement⟩ := PCSBCSNativeCallerOriginal.request_original + cap a.input.packet.val.profile (registry.packetModel Q a.input.packet) a.input.record + a.native.configuration shape (RawWHIRKeys.entry registry.context a.input.packet.val) + (WHIRPhysicalCaller.latestAnswers before) a.native.request familyCap parsed + refine ⟨input,?_,count,statement⟩ + rw [← reconstructed] + apply PCSBCSSourceCallerOriginal.original_prior_only + intro q member + rw [earlier q member] + rfl + +/-- Exact whole mixed-source endpoint. No accepted original, parsed replay, +sampled-row equality, raw-tape equality or reply-transport certificate is a +premise. The two primitive exclusions are deliberately low-level mixed-game +events; the actual real endpoint below derives both from one complete alarm. -/ +theorem mixed_success_capture_replyTransport + (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) (familyCap : cap ≤ 2^64) + (success : (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro).result.value = + some a) + (quiet : ∀ opening ∈ a.native.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (wholeOpeningLog cap registry Q attacker A B limit counted seed ro a opening) + opening.root opening.result.paths) + (clean : ∀ ref, ¬ OutputCollision + (wholeReferenceLog cap registry Q attacker A B limit counted seed ro a ref)) : + Nonempty (CaptureResult (stack := rfl) a.input.packet a.input.record + (wholeAllocation cap registry Q attacker A B limit counted a) seed ro + (registry.packetModel Q a.input.packet) a.native) := by + let program := wholeAllocation cap registry Q attacker A B limit counted a + obtain ⟨_,after,_,_,run,consistent⟩ := PCSBCSWholeNativePacketCoverage.mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨input,reconstructed,_,statement⟩ := mixed_success_original + cap registry Q attacker A B limit counted seed ro a familyCap success + obtain ⟨claims,caller,bound⟩ := original_bound a.input.packet a.input.record seed ro + (registry.packetModel Q a.input.packet) input reconstructed + obtain ⟨replay,proof,replayOriginal,initial,lambda,erased,parsed,canonical,accepted⟩ := + native_experiment a.input.packet a.input.record program seed ro + (registry.packetModel Q a.input.packet) a.input.proofs after a.native run consistent quiet + have acceptedOriginal : CausalGame.experiment + (OriginalClaimsChecker.input input.prepared (base a.input.packet a.input.record program seed ro) + replay.initial.1) (CausalStrategy.indexedStrategy replay.whir.replies) a.native.wire.tape = true := by + have same := statement (base a.input.packet a.input.record program seed ro) replay.initial.1 + have lanesEq : input.lanes = a.input.record.shape.lanes := congrArg CausalGame.Public.lanes same + have claimsEq := congrArg CausalGame.Public.claims same + change CausalGame.experiment + ⟨ParameterBounds.config a.input.packet.val.profile,input.lanes, + base a.input.packet a.input.record program seed ro, + (OriginalClaimsChecker.input input.prepared + (base a.input.packet a.input.record program seed ro) replay.initial.1).claims⟩ + (CausalStrategy.indexedStrategy replay.whir.replies) a.native.wire.tape = true + rw [claimsEq,lanesEq] + exact accepted + rw [base_eq_sourceRoot a.input.packet a.input.record program seed ro a.native.configuration.2] at acceptedOriginal + obtain ⟨seed0,bounded,seedState,depth,terminal,ordering,recorded,raws⟩ := + PCSBCSWholeNativePacketCoverage.mixed_success_tape cap registry Q attacker A B limit counted seed ro a success + have seedEq : seed0 = replay.initial := Option.some.inj (seedState.symm.trans initial) + subst seed0 + let packetB := PCSBCSNativePacketVisit.packetAtBound registry.context Q B a.input.packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket registry.context rfl B packetB + have messages : final.2.messages = a.input.packet.val.messages := rfl + have entry : final.1.val = RawWHIRKeys.entry registry.context a.input.packet.val := rfl + have nativeEq := PCSBCSNativeSourceOriginal.nativeReplies_indexed input + (sourceRoot seed (addresses a.input.packet) ⟨a.input.record.root,initialShape a.input.record.shape⟩ + program (table a.input.packet seed ro)) replay.initial.1 a.native.wire.tape replay.whir.replies proof parsed + have transports := native_replyTransport_of_decode a.input.packet a.input.record program seed ro + a.native (registry.packetModel Q a.input.packet) a.input.proofs after run consistent + replay canonical final messages raws quiet clean + refine ⟨{ + original := input, claims := claims, replay := replay, proof := proof, final := final + entry := entry, messages := messages, terminal := terminal, depth := depth + original_decoded := reconstructed, caller_decoded := caller, bound_original := bound + bound_rows := native_boundRows a.input.packet a.input.record program seed ro + (registry.packetModel Q a.input.packet) a.input.proofs after a.native run consistent quiet + replay_original := replayOriginal, initial := initial, lambda := lambda, erased := erased + opening := parsed, canonical := canonical, explains := statement, experiment := acceptedOriginal + native_replies := nativeEq, recorded := recorded, raws := raws, transport := transports + assembly := ?_, mentioned := ?_ }⟩ + · intro current member + exact native_assembly a.input.packet a.input.record program seed ro a.native + (registry.packetModel Q a.input.packet) input claims caller final current entry member + (recorded current member) replay.initial.1 a.native.wire.tape replay.whir.replies + raws (transports current member) clean + · intro opening member + obtain ⟨events,mentioned⟩ := PCSBCSWholeNativePacketCoverage.mixed_success_opening_firstMention + cap registry Q attacker A B limit counted seed ro a success opening member + rw [openingReference_eq_role a.input.packet a.input.record a.native.configuration.2 opening] at mentioned + exact ⟨events,mentioned⟩ + +end Whole + +/-- The complete alarm excludes collisions in every actual first-mention +capture. Missing captures have the literal empty log. No collision exclusion +is supplied separately to the real endpoint. -/ +theorem actualSourceLog_clean {p : ParameterBounds.Profile} {B boundary : Nat} {iv : Digest32} + {R : Type} (C : PrimitiveOracle) (program : Program R) + (A : Nat) (limit : A ≤ B) (counted : DuplexModeGame.Counts A program) + (policy : PublicMerkleProbability.RootPolicy) + (quiet : PublicMerkleProbability.traceAlarm policy [] + (PublicCompressionProgram.primitiveLog C iv program A counted) = false) + (ref : Reference) : + ¬ OutputCollision (PCSBCSNativePhysicalFreeze.actualSourceLog + (p := p) (iv := iv) (boundary := boundary) C program A limit counted ref) := by + have emptyAuth : AuthenticLog C [] := by intro n d member; cases member + have emptyClean : ¬ OutputCollision [] := by rintro ⟨a,b,d,member,_⟩; cases member + have totalClean := PublicMerkleProbability.traceAlarm_clean C policy [] + (PublicCompressionProgram.primitiveLog C iv program A counted) emptyAuth + (PublicCompressionProgram.primitiveLog_authentic C iv program A counted) emptyClean quiet + cases found : PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (p := p) (Q := B) (iv := iv) (boundary := boundary)) ref + (PCSBCSNativePhysicalFreeze.allocationProgram (p := p) (boundary := boundary) program A limit counted) + (PCSBCSNativePhysicalFreeze.actualTable (p := p) (B := B) (iv := iv) (boundary := boundary) C) with + | none => + simp only [PCSBCSNativePhysicalFreeze.actualSourceLog,sourceLog,found,Option.getD_none] + simpa only [PCSBCSSourceRootCapture.ordinaryPrefix,List.foldl_nil] using emptyClean + | some events => + obtain ⟨frozen⟩ := PCSBCSNativePhysicalFreeze.actual_firstMention_freeze C program A limit counted ref events found + intro collision + apply totalClean + apply PublicMerkleProbability.collision_mono _ collision + intro event member + apply List.mem_append_left + apply List.mem_reverse.mpr + rw [frozen.split] + exact List.mem_append_left _ (frozen.captured event member) + +section ActualWhole +variable (cap : Nat) + (nativeRegistry : {r : WHIRPhysicalDriver.ProductionRegistry // + r.context.iv = PCSBCSSourceCoordinateDecoder.seedIV}) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input nativeRegistry.val.context Q)) + (A B : Nat) (limit : A ≤ B) + (counted : DuplexModeGame.Counts A (PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q attacker)) +local notation "whole" => PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q attacker + +/-- Actual whole native success gives every captured replay/reply consequence +under the same single complete primitive alarm used by the probability layer. +First-mention, physical freeze, scanner admission and full opening plans are +derived, not endpoint premises. -/ +theorem actual_success_capture_replyTransport + (rootRegistry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (a : AnchoredPhysicalAfter.Accepted nativeRegistry.val.context Q cap) + (familyCap : cap ≤ 2^64) + (success : (runReal C nativeRegistry.val.context.iv whole).view.result.value = some a) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets a.input.packet.val.profile B + (RawWHIRKeys.entry nativeRegistry.val.context a.input.packet.val).frames.length rootRegistry) [] + (PublicCompressionProgram.primitiveLog C nativeRegistry.val.context.iv whole A counted) = false) : + Nonempty (CaptureResult (stack := rfl) a.input.packet a.input.record + (wholeAllocation cap nativeRegistry.val Q attacker A B limit counted a) + C (WHIRRealSimulator.rawTable B C) (nativeRegistry.val.packetModel Q a.input.packet) a.native) := by + have mixedSuccess : (PCSBCSWholeNativePacketCoverage.mixedView + cap nativeRegistry.val Q attacker A B limit counted C (WHIRRealSimulator.rawTable B C)).result.value = some a := by + rw [PCSBCSWholeNativePacketCoverage.actual_mixedView] + exact success + apply mixed_success_capture_replyTransport cap nativeRegistry.val Q attacker A B limit counted + C (WHIRRealSimulator.rawTable B C) a familyCap mixedSuccess + · intro opening member + have mentioned := PCSBCSWholeNativePacketCoverage.actual_success_opening_firstMention + cap nativeRegistry.val Q attacker A B limit counted C a success opening member + rw [openingReference_eq_role a.input.packet a.input.record a.native.configuration.2 opening] at mentioned + rw [nativeRegistry.property] at mentioned + obtain ⟨events,mentioned⟩ := mentioned + have evaluated := PCSBCSNativePhysicalFreeze.whole_success_evaluated + cap nativeRegistry.val Q attacker C A counted a success opening member + have quiet' : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets a.input.packet.val.profile B + (RawWHIRKeys.entry nativeRegistry.val.context a.input.packet.val).frames.length rootRegistry) [] + (PublicCompressionProgram.primitiveLog C PCSBCSSourceCoordinateDecoder.seedIV whole A counted) = false := by + simpa only [nativeRegistry.property] using quiet + have excluded := PCSBCSNativeCompleteAlarm.firstMention_opening_quiet + a.input.packet.val.profile B (RawWHIRKeys.entry nativeRegistry.val.context a.input.packet.val).frames.length + rootRegistry C whole A limit counted (PCSBCSNativeRootRoles.openingRole a.input.record opening) + events mentioned quiet' opening.result.paths + (by intro path present bytes input; exact (evaluated path present bytes input).1) + (by + intro path present bytes input event found + simpa only [nativeRegistry.property] using (evaluated path present bytes input).2 event found) + change ¬ PublicMerkleBinding.OpenPrimitiveBad C + (PCSBCSNativePhysicalFreeze.actualSourceLog (p := a.input.packet.val.profile) + (iv := nativeRegistry.val.context.iv) + (boundary := (RawWHIRKeys.entry nativeRegistry.val.context a.input.packet.val).frames.length) + C whole A limit counted (PCSBCSNativeRootRoles.openingRole a.input.record opening)) + opening.root opening.result.paths + simpa only [PCSBCSNativeRootRoles.openingRole,nativeRegistry.property] using excluded + · intro ref + exact actualSourceLog_clean C whole A limit counted _ quiet ref + +end ActualWhole + +section CountedWhole +variable (cap : Nat) + (nativeRegistry : {r : WHIRPhysicalDriver.ProductionRegistry // + r.context.iv = PCSBCSSourceCoordinateDecoder.seedIV}) (Q : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input nativeRegistry.val.context Q)) + (a b : Nat) (attackerCounted : WHIRSourceChronology.Counts a attacker) + (nativeBudget : WHIRSourceBackfill.AllResults + (fun input => sourceBudget nativeRegistry.val.context Q input.packet ≤ b) + (WHIRSourceChronology.erase attacker)) +local notation "whole" => PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q attacker +local notation "counted" => PCSBCSNativePhysicalFreeze.whole_counted + cap nativeRegistry.val Q attacker a b attackerCounted nativeBudget + +/-- Production-budget form: the whole count is derived from the arbitrary +attacker's count and the genuine verifier budget on its reachable inputs. -/ +theorem counted_whole_success_capture_replyTransport (B : Nat) (limit : a+b ≤ B) + (rootRegistry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (accepted : AnchoredPhysicalAfter.Accepted nativeRegistry.val.context Q cap) + (familyCap : cap ≤ 2^64) + (success : (runReal C nativeRegistry.val.context.iv whole).view.result.value = some accepted) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets accepted.input.packet.val.profile B + (RawWHIRKeys.entry nativeRegistry.val.context accepted.input.packet.val).frames.length rootRegistry) [] + (PublicCompressionProgram.primitiveLog C nativeRegistry.val.context.iv whole (a+b) counted) = false) : + Nonempty (CaptureResult (stack := rfl) accepted.input.packet accepted.input.record + (wholeAllocation cap nativeRegistry.val Q attacker (a+b) B limit counted accepted) + C (WHIRRealSimulator.rawTable B C) + (nativeRegistry.val.packetModel Q accepted.input.packet) accepted.native) := + actual_success_capture_replyTransport cap nativeRegistry Q attacker (a+b) B limit counted + rootRegistry C accepted familyCap success quiet +end CountedWhole + +#print axioms native_boundRows +#print axioms native_experiment +#print axioms native_replyTransport_of_decode +#print axioms mixed_success_original +#print axioms mixed_success_capture_replyTransport +#print axioms actualSourceLog_clean +#print axioms actual_success_capture_replyTransport +#print axioms counted_whole_success_capture_replyTransport +end Whir.PCSBCSWholeNativeCaptureTransport diff --git a/verification/whir/Whir/PCSBCSWholeNativePacketCoverage.lean b/verification/whir/Whir/PCSBCSWholeNativePacketCoverage.lean new file mode 100644 index 000000000..0bf042374 --- /dev/null +++ b/verification/whir/Whir/PCSBCSWholeNativePacketCoverage.lean @@ -0,0 +1,556 @@ +import Whir.PCSBCSNativePhysicalFreeze +import Whir.PCSBCSNativeCapturedTape +import Whir.PCSBCSNativeRootRoles + +/-! Whole historical native packet provenance. Attacker prequeries remain in the +allocation program; construction answers retain every byte of every block. -/ +set_option autoImplicit false +set_option backward.isDefEq.respectTransparency false +set_option maxHeartbeats 2000000 +namespace Whir.PCSBCSWholeNativePacketCoverage +open Concrete Protocol FiatShamirGame DuplexModeGame DuplexFraming TypedOracleCompiler +open PublicMerkleProgram WHIRSourceChronology WHIRPhysicalVerifier WHIRPhysicalReplay +open RawOracleCoupling.Concrete CausalProbability PCSBCSChallengeOracle +open MerkleTransport MerkleTransport.Commitments PCSBCSRestorationHazard +open PCSRoundByRoundTranscriptState +open PCSBCSNativeCapturedTape +open PCSBCSNativePhysicalFreeze (wholeProgram allocationProgram actualTable) + +noncomputable abbrev mixedTable {p : ParameterBounds.Profile} {B boundary : Nat} {iv : Digest32} + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) := + (EnteredPacket.partition (p := p) (Q := B) (iv := iv) (boundary := boundary)).split + (PublicCompressionCouplingMixed.oracle seed ro) + +/-- Literal equality of full source blocks, before any scalar or query-index +projection. The last block's unused high suffix is part of this equality. -/ +theorem fullWidth_of_answers (ctx : RawWHIRKeys.Context) (stack : ctx.mode = .stack) + (Q B : Nat) (packet : RawWHIRKeys.Packet ctx Q) + (bounded : pathCost (RawWHIRKeys.coordinate ctx packet.val 0) ≤ B) + {p : ParameterBounds.Profile} {entry : FramedHistory} + (profile : packet.val.profile = p) (aligned : RawWHIRKeys.entry ctx packet.val = entry) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (raw : GroupAnswer ctx Q (.inl packet)) + (answers : ∀ b : Fin (RawWHIRKeys.blocks ctx packet.val), + ∃ bound : pathCost (RawWHIRKeys.coordinate ctx packet.val b.val) ≤ B, + raw b = ro (constructionKey B ctx.iv (RawWHIRKeys.coordinate ctx packet.val b.val) bound)) : + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + let current := PCSBCSNativePacketBridge.enteredPacketAt ctx stack B packetB profile aligned + HEq (mixedTable seed ro (.inl current)) + (PCSBCSNativePacketCodec.nativeFullBlocksEquiv ctx stack B packetB raw) := by + cases profile + cases aligned + let packetB := PCSBCSNativePacketVisit.packetAtBound ctx Q B packet bounded + apply heq_of_eq + funext b + change ro ((PCSBCSNativePacketBridge.sourcePacket ctx stack B packetB).key b) = _ + rw [PCSBCSNativePacketBridge.sourcePacket_key,PCSBCSNativePacketCodec.nativeFullBlocksEquiv_apply] + obtain ⟨bound,equal⟩ := answers ⟨b.val,by + change b.val < RawWHIRKeys.blocks ctx packetB.val + rw [PCSBCSNativePacketBridge.packet_blocks_pcs ctx stack B packetB] + exact b.isLt⟩ + exact equal.symm + +section Whole +variable (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) (Q : Nat) + (attacker : Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + (A B : Nat) (limit : A ≤ B) (counted : DuplexModeGame.Counts A (wholeProgram cap registry Q attacker)) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + +noncomputable abbrev mixedView := + Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile B registry.context.iv [] + (wholeProgram cap registry Q attacker) A limit counted) + +theorem allocationView_mixed (p : ParameterBounds.Profile) (boundary : Nat) : + Sampling.eval (mixedTable (p := p) (iv := registry.context.iv) (boundary := boundary) seed ro) + (allocationProgram (p := p) (boundary := boundary) + (wholeProgram cap registry Q attacker) A limit counted) = + mixedView cap registry Q attacker A B limit counted seed ro := by + rw [Atomic.eval_program,RawOracleCoupling.Partition.join_split] + + theorem mixedView_runs : + Runs (erase (AnchoredPhysicalAfter.verifyAfter cap registry Q attacker)) + (mixedView cap registry Q attacker A B limit counted seed ro).observations + (mixedView cap registry Q attacker A B limit counted seed ro).result.value ∧ + WHIRSourceChronology.observations + (mixedView cap registry Q attacker A B limit counted seed ro).result.events = + (mixedView cap registry Q attacker A B limit counted seed ro).observations ∧ + AnchoredIdealPhysicalAcceptance.PrimitiveConsistent seed + (mixedView cap registry Q attacker A B limit counted seed ro).observations := by + have run : Runs (wholeProgram cap registry Q attacker) + (mixedView cap registry Q attacker A B limit counted seed ro).observations + (mixedView cap registry Q attacker A B limit counted seed ro).result := by + simp only [mixedView,PublicCompressionCouplingMixed.compile_actual] + exact runIdeal_runs (DuplexPublicSimulator.simulator B) ro registry.context.iv + ⟨seed,[]⟩ _ A limit counted + obtain ⟨erased,observed⟩ := WHIRPhysicalCaller.compile_run + (AnchoredPhysicalAfter.verifyAfter cap registry Q attacker) _ _ run + refine ⟨erased,observed,?_⟩ + simpa only [AnchoredIdealPhysicalAcceptance.PrimitiveConsistent,mixedView, + PublicCompressionCouplingMixed.compile_actual,DuplexPublicSimulator.simulator] using + PCSBCSMixedOrdinaryMerkle.runIdeal_initial_answers B seed ro registry.context.iv + (wholeProgram cap registry Q attacker) A limit counted + + theorem mixed_success_native_segment (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∃ before after, + (mixedView cap registry Q attacker A B limit counted seed ro).observations = before ++ after ∧ + Runs (erase attacker) before a.input ∧ + Runs (erase (AnchoredPhysicalDriver.verifySource cap .fresh + (registry.packetModel Q a.input.packet) registry.context rfl Q + a.input.packet a.input.record a.input.proofs)) after (some a.native) ∧ + AnchoredIdealPhysicalAcceptance.PrimitiveConsistent seed after := by + obtain ⟨run,_,consistent⟩ := mixedView_runs cap registry Q attacker A B limit counted seed ro + rw [success] at run + obtain ⟨input,before,after,native,split,first,last,equal⟩ := + AnchoredPhysicalAfter.native_segment cap registry Q attacker _ a run + cases equal + refine ⟨before,after,split,first,last,?_⟩ + intro o member ordinary + apply consistent o _ ordinary + rw [split] + exact List.mem_append_right _ member + + theorem mixed_success_recorded (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∀ current (member : current ∈ completion registry.context Q a.input.packet), + ∃ bounded : pathCost (RawWHIRKeys.coordinate registry.context current.val 0) ≤ B, + let entered := PCSBCSNativePacketBridge.enteredPacketAt registry.context rfl B + (PCSBCSNativePacketVisit.packetAtBound registry.context Q B current bounded) + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member) + (⟨.inl entered,mixedTable seed ro (.inl entered)⟩ : Sigma PCSBCSSourceRootCapture.Answer) ∈ + (Sampling.execute (mixedTable seed ro) + (allocationProgram (p := a.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) A limit counted)).2 := by + obtain ⟨before,after,split,_,nativeRun,_⟩ := mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + intro current member + obtain ⟨answer,queried⟩ := PCSBCSNativePacketVisit.verifySource_queried + cap .fresh (registry.packetModel Q a.input.packet) registry.context rfl Q + a.input.packet a.input.record a.input.proofs after a.native nativeRun current member + apply PCSBCSNativePacketVisit.observed_packet_recorded registry.context rfl Q B current + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member) + seed ro [] (wholeProgram cap registry Q attacker) A limit counted answer + have present : (⟨WHIRModeFinal.request registry.context Q current + ⟨0,RawWHIRKeys.blocks_positive registry.context current.val⟩,answer⟩ : Observation) ∈ + (mixedView cap registry Q attacker A B limit counted seed ro).observations := by + rw [split] + exact List.mem_append_right _ queried + simpa only [mixedView,PublicCompressionCouplingMixed.compile_actual] using present + + theorem mixed_success_depth (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + a.input.packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config a.input.packet.val.profile) := by + obtain ⟨_,after,_,_,run,_⟩ := mixed_success_native_segment cap registry Q attacker A B limit counted seed ro a success + obtain ⟨_,_,_,trace,_⟩ := AnchoredPhysicalExecution.verifySource_execution cap .fresh + (registry.packetModel Q a.input.packet) registry.context rfl Q + a.input.packet a.input.record a.input.proofs after a.native run + exact AnchoredPhysicalPreparation.accepted_completed_depth a.native + (trace_completed a.input.record.root (completion_chain registry.context Q a.input.packet) trace) + + +/-- The actual accepted history contains each scheduled packet, and every full +block of those actual answers is the whole runner's literal raw-table answer. -/ +theorem mixed_success_full_answers (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + Trace registry.context rfl Q a.input.packet.val.profile a.input.record.shape.lanes + a.input.proofs (completion registry.context Q a.input.packet) + (initialWireState a.input.packet.val.profile a.input.record.root) a.native.wire a.native.history ∧ + (∀ current ∈ completion registry.context Q a.input.packet, + ∃ raw, (⟨.inl current,raw⟩ : Sigma (GroupAnswer registry.context Q)) ∈ a.native.history) ∧ + (∀ (current : RawWHIRKeys.Packet registry.context Q) (raw : GroupAnswer registry.context Q (.inl current)), + (⟨.inl current,raw⟩ : Sigma (GroupAnswer registry.context Q)) ∈ a.native.history → + ∀ b : Fin (RawWHIRKeys.blocks registry.context current.val), + ∃ bound : pathCost (RawWHIRKeys.coordinate registry.context current.val b.val) ≤ B, + raw b = ro (constructionKey B registry.context.iv + (RawWHIRKeys.coordinate registry.context current.val b.val) bound)) := by + obtain ⟨before,after,split,_,run,_⟩ := mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨configured,same,prior,physical,request,whole,_,_,_,physicalRun⟩ := + AnchoredPhysicalExecution.verifySource_success cap .fresh (registry.packetModel Q a.input.packet) + registry.context rfl Q a.input.packet a.input.record a.input.proofs after a.native run + obtain ⟨final,history,suffix,trace,last,observed⟩ := readPackets_observed registry.context rfl Q + a.input.packet.val.profile a.input.record.shape.lanes a.input.proofs _ _ _ _ physical a.native physicalRun + obtain ⟨_,wireEq,historyEq⟩ := AnchoredPhysicalExecution.finish_success registry.context Q cap + a.input.packet a.input.record configured request final history _ a.native (done_eq last) + have traced : Trace registry.context rfl Q a.input.packet.val.profile a.input.record.shape.lanes + a.input.proofs (completion registry.context Q a.input.packet) + (initialWireState a.input.packet.val.profile a.input.record.root) a.native.wire a.native.history := by + simpa only [← wireEq,← historyEq] using trace + refine ⟨traced,trace_answers traced,?_⟩ + intro current raw member b + apply PCSBCSIdealConstructionAnswers.construction_observations (DuplexPublicSimulator.simulator B) + ro registry.context.iv ⟨seed,[]⟩ (wholeProgram cap registry Q attacker) A limit counted + _ _ (raw b) + have present : (⟨WHIRModeFinal.request registry.context Q current b,raw b⟩ : Observation) ∈ + (mixedView cap registry Q attacker A B limit counted seed ro).observations := by + rw [split,whole] + exact List.mem_append_right _ (List.mem_append_right _ + (observed current raw (by simpa only [historyEq] using member) b)) + simpa only [mixedView,PublicCompressionCouplingMixed.compile_actual,WHIRModeFinal.request] using present + +/-- Each scheduled whole allocation has the actual native full-width answer, +with its literal canonical entry and messages; visitation is also derived. -/ +theorem mixed_success_fullWidth_packets (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∀ current (member : current ∈ completion registry.context Q a.input.packet), + ∃ raw : GroupAnswer registry.context Q (.inl current), + ∃ bounded : pathCost (RawWHIRKeys.coordinate registry.context current.val 0) ≤ B, + let packetB := PCSBCSNativePacketVisit.packetAtBound registry.context Q B current bounded + let entered := PCSBCSNativePacketBridge.enteredPacketAt registry.context rfl B packetB + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member) + (⟨.inl current,raw⟩ : Sigma (GroupAnswer registry.context Q)) ∈ a.native.history ∧ + HEq (mixedTable seed ro (.inl entered)) + (PCSBCSNativePacketCodec.nativeFullBlocksEquiv registry.context rfl B packetB raw) ∧ + (⟨.inl entered,mixedTable seed ro (.inl entered)⟩ : Sigma PCSBCSSourceRootCapture.Answer) ∈ + (Sampling.execute (mixedTable seed ro) + (allocationProgram (p := a.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) A limit counted)).2 := by + obtain ⟨_,answers,blocks⟩ := mixed_success_full_answers cap registry Q attacker A B limit counted seed ro a success + intro current member + obtain ⟨raw,inHistory⟩ := answers current member + obtain ⟨bounded,recorded⟩ := mixed_success_recorded cap registry Q attacker A B limit counted seed ro a success current member + exact ⟨raw,bounded,inHistory,fullWidth_of_answers registry.context rfl Q B current bounded + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member) + seed ro raw (blocks current raw inHistory),recorded⟩ + +theorem mixed_success_literal_packets (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∃ initial, a.native.wire.initial = some initial ∧ + ∀ current (member : current ∈ completion registry.context Q a.input.packet), + ∃ bounded : pathCost (RawWHIRKeys.coordinate registry.context current.val 0) ≤ B, + let entered := PCSBCSNativePacketBridge.enteredPacketAt registry.context rfl B + (PCSBCSNativePacketVisit.packetAtBound registry.context Q B current bounded) + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member) + grouped entered.2.coord (mixedTable seed ro (.inl entered)) = + literalRaw initial.1 a.native.wire.tape entered.2.coord := by + obtain ⟨trace,answers,blocks⟩ := mixed_success_full_answers + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨initial,initialState,literals⟩ := trace_literals a.input.record.root + (completion_chain registry.context Q a.input.packet) trace + refine ⟨initial,initialState,?_⟩ + intro current member + obtain ⟨raw,inHistory⟩ := answers current member + obtain ⟨bounded,_⟩ := mixed_success_recorded cap registry Q attacker A B limit counted seed ro a success current member + refine ⟨bounded,?_⟩ + have groupedEq := observed_grouped registry.context rfl Q B current bounded + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member) + seed ro raw (blocks current raw inHistory) + have literal := literals current raw inHistory + (completion_profiles registry.context Q a.input.packet current member) + have lifted := congrArg + (Eq.mp (congrArg PCSBCSRounds.Raw (entered_query registry.context rfl Q B current bounded + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member)))) literal + have castEq := literal_cast initial.1 a.native.wire.tape _ _ + (entered_query registry.context rfl Q B current bounded + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member)) + exact groupedEq.trans (lifted.symm.trans castEq) + +/-- Full chronological tape coverage at the observed cap, on the whole +allocation program. Neither Q ≤ B nor suffix-cache equality is required. -/ +theorem mixed_success_tape (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∃ initial : RingPCSGame.Prefix × E, + ∃ bounded : pathCost (RawWHIRKeys.coordinate registry.context a.input.packet.val 0) ≤ B, + let packetB := PCSBCSNativePacketVisit.packetAtBound registry.context Q B a.input.packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket registry.context rfl B packetB + a.native.wire.initial = some initial ∧ + a.input.packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config a.input.packet.val.profile) ∧ + final.2.coord = lastCoordinate (ParameterBounds.config a.input.packet.val.profile) ∧ + PCSBCSNativePacketBridge.completionPackets registry.context rfl B packetB = + PCSBCSCapturedSourceStatePath.packets final ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + (⟨.inl current,mixedTable seed ro (.inl current)⟩ : Sigma PCSBCSSourceRootCapture.Answer) ∈ + (Sampling.execute (mixedTable seed ro) + (allocationProgram (p := a.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) A limit counted)).2) ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + grouped current.2.coord (mixedTable seed ro (.inl current)) = + literalRaw initial.1 a.native.wire.tape current.2.coord) := by + classical + obtain ⟨initial,initialState,literals⟩ := mixed_success_literal_packets + cap registry Q attacker A B limit counted seed ro a success + have self : a.input.packet ∈ completion registry.context Q a.input.packet := + List.mem_append_right _ (List.mem_singleton_self _) + obtain ⟨bounded,_⟩ := mixed_success_recorded cap registry Q attacker A B limit counted seed ro a success a.input.packet self + let packetB := PCSBCSNativePacketVisit.packetAtBound registry.context Q B a.input.packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket registry.context rfl B packetB + have depth := mixed_success_depth cap registry Q attacker A B limit counted seed ro a success + have ordering := PCSBCSNativePacketBridge.completionPackets_eq_of_length registry.context rfl B packetB depth + have packetMember : ∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + ∃ native, ∃ member : native ∈ completion registry.context Q a.input.packet, + ∃ bound : pathCost (RawWHIRKeys.coordinate registry.context native.val 0) ≤ B, + current = PCSBCSNativePacketBridge.enteredPacketAt registry.context rfl B + (PCSBCSNativePacketVisit.packetAtBound registry.context Q B native bound) + (completion_profiles registry.context Q a.input.packet native member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet native member) := by + intro current member + rw [← ordering] at member + obtain ⟨attached,_,equal⟩ := List.mem_map.mp member + have nativeMember : attached.val.val ∈ (completion registry.context Q a.input.packet).map Subtype.val := by + rw [completion_data a.input.packet packetB rfl] + exact List.mem_map.mpr ⟨attached.val,attached.property,rfl⟩ + obtain ⟨native,member,same⟩ := List.mem_map.mp nativeMember + obtain ⟨bound,_⟩ := mixed_success_recorded cap registry Q attacker A B limit counted seed ro a success native member + refine ⟨native,member,bound,?_⟩ + rw [← equal] + apply entered_ext + · rw [PCSBCSNativePacketBridge.enteredPacketAt_entry,PCSBCSNativePacketBridge.enteredPacketAt_entry] + rfl + · rw [PCSBCSNativePacketBridge.enteredPacketAt_messages,PCSBCSNativePacketBridge.enteredPacketAt_messages] + exact congrArg RawWHIRKeys.PacketData.messages same.symm + refine ⟨initial,bounded,initialState,depth, + PCSBCSNativePacketBridge.query_eq_last_of_length registry.context B packetB depth,ordering,?_,?_⟩ + · intro current member + obtain ⟨native,nativeMem,bound,equal⟩ := packetMember current member + subst current + obtain ⟨_,recorded⟩ := mixed_success_recorded cap registry Q attacker A B limit counted seed ro a success native nativeMem + exact recorded + · intro current member + obtain ⟨native,nativeMem,bound,equal⟩ := packetMember current member + subst current + obtain ⟨_,raw⟩ := literals native nativeMem + exact raw + +/-- Actual caller preparation reads its genuine queried construction answers. +This statement is separate from address admission; no hidden coverage premise +is needed to decide the public address. -/ +theorem mixed_success_caller_preparation (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∃ before, + AnchoredPhysicalDriver.request .fresh cap a.input.packet.val.profile + (registry.packetModel Q a.input.packet).layout a.input.record + (RawWHIRKeys.entry registry.context a.input.packet.val) + (WHIRPhysicalCaller.latestAnswers before) = some a.native.request ∧ + ∀ wanted ∈ WHIRCallerOutputs.callerOutputs (RawWHIRKeys.entry registry.context a.input.packet.val), + WHIRPhysicalCaller.latestAnswers before wanted = + some (PCSBCSSourceCallerAnswers.answers + (mixedTable (p := a.input.packet.val.profile) (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) seed ro) wanted) := by + obtain ⟨earlierTrace,after,split,_,run,_⟩ := mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨⟨before,physical,nativeSplit,_,queries,parsed⟩,_,_,_,_⟩ := + AnchoredPhysicalExecution.verifySource_execution cap .fresh (registry.packetModel Q a.input.packet) + registry.context rfl Q a.input.packet a.input.record a.input.proofs after a.native run + refine ⟨before,parsed,?_⟩ + intro wanted prior + have queried : Query.construction wanted + (RawWHIRKeys.callerOutput_admissible registry.context Q a.input.packet wanted prior) ∈ + before.map Observation.query := by + rw [queries] + exact List.mem_map.mpr ⟨⟨wanted,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨o,member,equal⟩ := List.mem_map.mp queried + apply WHIRPhysicalCaller.latestAnswers_consistent before wanted + (RawWHIRKeys.callerOutput_admissible registry.context Q a.input.packet wanted prior) _ ⟨o,member,equal⟩ + intro observation member valid same + have present : observation ∈ (mixedView cap registry Q attacker A B limit counted seed ro).observations := by + rw [split,nativeSplit] + exact List.mem_append_right _ (List.mem_append_left _ member) + have construction : (⟨.construction wanted valid,observation.answer⟩ : Observation) ∈ + (mixedView cap registry Q attacker A B limit counted seed ro).observations := by + cases observation + cases same + exact present + simp only [mixedView,PublicCompressionCouplingMixed.compile_actual] at construction + obtain ⟨bounded,actual⟩ := PCSBCSIdealConstructionAnswers.construction_observations + (DuplexPublicSimulator.simulator B) ro registry.context.iv ⟨seed,[]⟩ + (wholeProgram cap registry Q attacker) A limit counted wanted valid _ construction + rw [PCSBCSNativeIdealCallerOriginal.split_answers seed ro wanted bounded] + exact actual + +theorem mixed_success_fresh_decode (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∃ claims, AnchoredSourceFreshCaller.decode (registry.packetModel Q a.input.packet).layout + a.input.record (RawWHIRKeys.entry registry.context a.input.packet.val) + (PCSBCSSourceCallerAnswers.answers + (mixedTable (p := a.input.packet.val.profile) (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) seed ro)) = some claims := by + obtain ⟨before,parsed,earlier⟩ := mixed_success_caller_preparation + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨claims,caller,_,_,_⟩ := AnchoredPhysicalDriver.request_origin .fresh cap a.input.packet.val.profile + (registry.packetModel Q a.input.packet).layout a.input.record (RawWHIRKeys.entry registry.context a.input.packet.val) + (WHIRPhysicalCaller.latestAnswers before) a.native.request parsed + refine ⟨claims,?_⟩ + have tokens := WHIRCallerClaims.entryTokens_prior_only (RawWHIRKeys.entry registry.context a.input.packet.val) + (fun q => (WHIRPhysicalCaller.latestAnswers before q).getD DuplexRefinement.zeroDigest) + (PCSBCSSourceCallerAnswers.answers + (mixedTable (p := a.input.packet.val.profile) (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) seed ro)) + (by intro q member; rw [earlier q member]; rfl) + simpa only [AnchoredPhysicalDriver.decodeCaller,AnchoredSourceFreshCaller.decode,tokens] using caller + +theorem mixed_success_address_member (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) + (current : EnteredPacket a.input.packet.val.profile B registry.context.iv + (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (entry : current.1.val = RawWHIRKeys.entry registry.context a.input.packet.val) + (messages : current.2.messages = a.input.packet.val.messages) : + ∀ opening ∈ a.native.wire.openings, + PCSBCSCapturedIdealNativeAcceptance.openingReference registry.context Q a.input.packet opening + a.input.record.shape.lanes ∈ PCSBCSCapturedSourceTransport.address (.inl current) := by + obtain ⟨_,after,_,_,run,_⟩ := mixed_success_native_segment cap registry Q attacker A B limit counted seed ro a success + obtain ⟨valid,profile,roles,member⟩ := PCSBCSNativeRootRoles.verifySource_opening_member + cap .fresh (registry.packetModel Q a.input.packet) registry.context rfl Q + a.input.packet a.input.record a.input.proofs after a.native run + obtain ⟨claims,caller⟩ := mixed_success_fresh_decode cap registry Q attacker A B limit counted seed ro a success + have admitted := PCSBCSCapturedSourceTransport.address_packet (registry.packetModel Q a.input.packet).layout + a.input.record _ current valid profile claims (by simpa only [entry] using caller) + (by simpa only [messages] using roles) + rw [admitted,messages] + exact member + +/-- Every retained actual opening has a genuine first-address prefix in the +whole execution, including any earlier attacker mention of the same root. -/ +theorem mixed_success_opening_firstMention (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (mixedView cap registry Q attacker A B limit counted seed ro).result.value = some a) : + ∀ opening ∈ a.native.wire.openings, ∃ events, + PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (iv := registry.context.iv)) + (PCSBCSCapturedIdealNativeAcceptance.openingReference registry.context Q a.input.packet opening + a.input.record.shape.lanes) + (allocationProgram (p := a.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) A limit counted) + (mixedTable seed ro) = some events := by + classical + have self : a.input.packet ∈ completion registry.context Q a.input.packet := + List.mem_append_right _ (List.mem_singleton_self _) + obtain ⟨bounded,recorded⟩ := mixed_success_recorded cap registry Q attacker A B limit counted seed ro a success a.input.packet self + let current := PCSBCSNativePacketBridge.enteredPacketAt registry.context rfl B + (PCSBCSNativePacketVisit.packetAtBound registry.context Q B a.input.packet bounded) + (completion_profiles registry.context Q a.input.packet a.input.packet self) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet a.input.packet self) + have entry : current.1.val = RawWHIRKeys.entry registry.context a.input.packet.val := + PCSBCSNativePacketBridge.enteredPacketAt_entry registry.context rfl B _ _ _ + have messages : current.2.messages = a.input.packet.val.messages := + PCSBCSNativePacketBridge.enteredPacketAt_messages registry.context rfl B _ _ _ + intro opening member + apply PCSBCSFirstRootDisclosure.first_mention_exists _ (.inl current) _ + (mixed_success_address_member cap registry Q attacker A B limit counted seed ro a success current entry messages opening member) + exact List.mem_map.mpr ⟨_,recorded,rfl⟩ + +end Whole + +section Actual +variable (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) (Q : Nat) + (attacker : Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + (A B : Nat) (limit : A ≤ B) (counted : DuplexModeGame.Counts A (wholeProgram cap registry Q attacker)) + (C : PrimitiveOracle) + +theorem actual_mixedView : + mixedView cap registry Q attacker A B limit counted C (WHIRRealSimulator.rawTable B C) = + (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view := by + rw [mixedView,PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C registry.context.iv _ ⟨rfl,by simp⟩ _ _ limit _ + +theorem actual_success_fullWidth_packets (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = some a) : + ∀ current (member : current ∈ completion registry.context Q a.input.packet), + ∃ raw : GroupAnswer registry.context Q (.inl current), + ∃ bounded : pathCost (RawWHIRKeys.coordinate registry.context current.val 0) ≤ B, + let packetB := PCSBCSNativePacketVisit.packetAtBound registry.context Q B current bounded + let entered := PCSBCSNativePacketBridge.enteredPacketAt registry.context rfl B packetB + (completion_profiles registry.context Q a.input.packet current member) + (PCSBCSNativePacketBridge.completion_entries registry.context Q a.input.packet current member) + (⟨.inl current,raw⟩ : Sigma (GroupAnswer registry.context Q)) ∈ a.native.history ∧ + HEq (actualTable C (.inl entered)) + (PCSBCSNativePacketCodec.nativeFullBlocksEquiv registry.context rfl B packetB raw) ∧ + (⟨.inl entered,actualTable C (.inl entered)⟩ : Sigma PCSBCSSourceRootCapture.Answer) ∈ + (Sampling.execute (actualTable C) + (allocationProgram (p := a.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) A limit counted)).2 := by + apply mixed_success_fullWidth_packets cap registry Q attacker A B limit counted C + (WHIRRealSimulator.rawTable B C) a + rwa [actual_mixedView cap registry Q attacker A B limit counted C] + +theorem actual_success_tape (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = some a) : + ∃ initial : RingPCSGame.Prefix × E, + ∃ bounded : pathCost (RawWHIRKeys.coordinate registry.context a.input.packet.val 0) ≤ B, + let packetB := PCSBCSNativePacketVisit.packetAtBound registry.context Q B a.input.packet bounded + let final := PCSBCSNativePacketBridge.enteredPacket registry.context rfl B packetB + a.native.wire.initial = some initial ∧ + a.input.packet.val.messages.length = WHIRHistory.depth (ParameterBounds.config a.input.packet.val.profile) ∧ + final.2.coord = lastCoordinate (ParameterBounds.config a.input.packet.val.profile) ∧ + PCSBCSNativePacketBridge.completionPackets registry.context rfl B packetB = + PCSBCSCapturedSourceStatePath.packets final ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + (⟨.inl current,actualTable C (.inl current)⟩ : Sigma PCSBCSSourceRootCapture.Answer) ∈ + (Sampling.execute (actualTable C) + (allocationProgram (p := a.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) A limit counted)).2) ∧ + (∀ current ∈ PCSBCSCapturedSourceStatePath.packets final, + grouped current.2.coord (actualTable C (.inl current)) = + literalRaw initial.1 a.native.wire.tape current.2.coord) := by + apply mixed_success_tape cap registry Q attacker A B limit counted C (WHIRRealSimulator.rawTable B C) a + rwa [actual_mixedView cap registry Q attacker A B limit counted C] + +theorem actual_success_opening_firstMention (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = some a) : + ∀ opening ∈ a.native.wire.openings, ∃ events, + PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (iv := registry.context.iv)) + (PCSBCSCapturedIdealNativeAcceptance.openingReference registry.context Q a.input.packet opening + a.input.record.shape.lanes) + (allocationProgram (p := a.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) A limit counted) + (actualTable C) = some events := by + apply mixed_success_opening_firstMention cap registry Q attacker A B limit counted C + (WHIRRealSimulator.rawTable B C) a + rwa [actual_mixedView cap registry Q attacker A B limit counted C] + +/-- Source counts and reachable native budgets suffice; no supplied root +admission or physical-freeze certificate is an endpoint premise. -/ +theorem counted_whole_success_opening_firstMention + (a b : Nat) (attackerCounted : WHIRSourceChronology.Counts a attacker) + (budget : WHIRSourceBackfill.AllResults + (fun input => sourceBudget registry.context Q input.packet ≤ b) (erase attacker)) + (limit : a+b ≤ B) (accepted : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (runReal C registry.context.iv (wholeProgram cap registry Q attacker)).view.result.value = some accepted) : + ∀ opening ∈ accepted.native.wire.openings, ∃ events, + PCSBCSFirstRootDisclosure.firstMention + (PCSBCSCapturedSourceTransport.address (iv := registry.context.iv)) + (PCSBCSCapturedIdealNativeAcceptance.openingReference registry.context Q accepted.input.packet opening + accepted.input.record.shape.lanes) + (allocationProgram (p := accepted.input.packet.val.profile) + (boundary := (RawWHIRKeys.entry registry.context accepted.input.packet.val).frames.length) + (wholeProgram cap registry Q attacker) (a+b) limit + (PCSBCSNativePhysicalFreeze.whole_counted cap registry Q attacker a b attackerCounted budget)) + (actualTable C) = some events := + actual_success_opening_firstMention cap registry Q attacker (a+b) B limit + (PCSBCSNativePhysicalFreeze.whole_counted cap registry Q attacker a b attackerCounted budget) + C accepted success + +end Actual + +#print axioms mixedView_runs +#print axioms mixed_success_native_segment +#print axioms mixed_success_recorded +#print axioms mixed_success_full_answers +#print axioms mixed_success_literal_packets +#print axioms mixed_success_tape +#print axioms mixed_success_caller_preparation +#print axioms mixed_success_fresh_decode +#print axioms mixed_success_address_member +#print axioms mixed_success_opening_firstMention +#print axioms fullWidth_of_answers +#print axioms mixed_success_fullWidth_packets +#print axioms actual_success_fullWidth_packets +#print axioms actual_success_tape +#print axioms actual_success_opening_firstMention +#print axioms counted_whole_success_opening_firstMention +end Whir.PCSBCSWholeNativePacketCoverage diff --git a/verification/whir/Whir/PCSBCSWholeSourceObserver.lean b/verification/whir/Whir/PCSBCSWholeSourceObserver.lean new file mode 100644 index 000000000..12d4edfb1 --- /dev/null +++ b/verification/whir/Whir/PCSBCSWholeSourceObserver.lean @@ -0,0 +1,420 @@ +import Whir.PCSBCSWholeNativeCaptureTransport +import Whir.PCSBCSNativePublicCapture +import Whir.PCSBCSNativeSourceTables +import Whir.PCSBCSSourceKnowledgeComposition +import Whir.PCSBCSPublicPrimitiveOpening +import Whir.PublicCompressionModeSecurity + +/-! Historical pre607 PCS-only whole-source public knowledge observer. The +caller class is structural over every reachable attacker output, including +rejected inputs. It fixes public profile, entry boundary and caller grammar +before batch coins, but not the caller's adaptively decoded points or values. +This is not a current compiled verifier refinement or concrete BLAKE2s claim. -/ +set_option autoImplicit false +set_option maxHeartbeats 2000000 +set_option maxRecDepth 100000 +namespace Whir.PCSBCSWholeSourceObserver +open Concrete Protocol FiatShamirGame DuplexModeGame TypedOracleCompiler +open RawOracleCoupling PCSBCSChallengeOracle PCSBCSSourceRootReferences +open PCSBCSCapturedNativeReplyBridge PCSBCSCapturedSourceAcceptance +open PCSBCSWholeNativeCaptureTransport PCSBCSNativePublicCapture +open WHIRPhysicalVerifier PublicMerkleLog + +variable (cap : Nat) (registry : WHIRPhysicalDriver.ProductionRegistry) (Q : Nat) + +/-- Public geometry and grammar of a caller input, independently of whether +its subsequent verifier execution accepts. Caller points and values are still +computed by the genuine fresh caller preparation from earlier public answers. -/ +def FixedMetadata (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (boundary : Nat) + (input : AnchoredPhysicalAfter.Input registry.context Q) : Prop := + input.packet.val.profile = p ∧ + (RawWHIRKeys.entry registry.context input.packet.val).frames.length = boundary ∧ + (registry.packetModel Q input.packet).layout = layout + +/-- Every answer continuation of the source attacker is in this public caller +class. There is no restriction to accepted outputs or a favorable hidden table. -/ +def SourceClass (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (boundary : Nat) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input registry.context Q)) : Prop := + WHIRSourceBackfill.AllResults (FixedMetadata registry Q p layout boundary) + (WHIRSourceChronology.erase attacker) + +private theorem allResults_runs {R : Type} (program : Program R) (post : R → Prop) + (all : WHIRSourceBackfill.AllResults post program) + (trace : List Observation) (result : R) (run : PublicMerkleProgram.Runs program trace result) : + post result := by + induction run with + | done => exact all + | ask answer run ih => exact ih (all answer) + +section Mixed +variable (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + (A B : Nat) (limit : A ≤ B) + (counted : Counts A (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker)) + (seed : PrimitiveOracle) (ro : RawKey B → Digest32) +local notation "view" => PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker A B limit counted seed ro + +/-- Structural class membership follows from the actual attacker subrun. -/ +theorem mixed_success_metadata (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (boundary : Nat) + (sourceClass : SourceClass cap registry Q p layout boundary attacker) + (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (view).result.value = some a) : FixedMetadata registry Q p layout boundary a.input := by + obtain ⟨before,_,_,run,_,_⟩ := PCSBCSWholeNativePacketCoverage.mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + exact allResults_runs _ _ sourceClass before a.input run + +/-- Caller-output coverage is derived from the fresh caller's actual queried +prefix, which is retained in the whole public view. -/ +theorem mixed_success_publicOriginal (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (view).result.value = some a) : + publicOriginal a.input.packet.val.profile (registry.packetModel Q a.input.packet).layout + a.input.record (RawWHIRKeys.entry registry.context a.input.packet.val) view = + PCSBCSSourceCallerOriginal.original a.input.packet.val.profile + (registry.packetModel Q a.input.packet).layout a.input.record + (RawWHIRKeys.entry registry.context a.input.packet.val) + (PCSBCSSourceCallerAnswers.answers (table (boundary := + (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + a.input.packet seed ro)) := by + apply publicOriginal_recorded seed ro _ A limit counted + obtain ⟨before,after,split,_,run,_⟩ := PCSBCSWholeNativePacketCoverage.mixed_success_native_segment + cap registry Q attacker A B limit counted seed ro a success + obtain ⟨⟨caller,physical,nativeSplit,_,queries,_⟩,_,_,_,_⟩ := + AnchoredPhysicalExecution.verifySource_execution cap .fresh (registry.packetModel Q a.input.packet) + registry.context rfl Q a.input.packet a.input.record a.input.proofs after a.native run + intro wanted prior + have queried : Query.construction wanted + (RawWHIRKeys.callerOutput_admissible registry.context Q a.input.packet wanted prior) ∈ + caller.map Observation.query := by + rw [queries] + exact List.mem_map.mpr ⟨⟨wanted,prior⟩,List.mem_attach _ _,rfl⟩ + obtain ⟨o,member,equal⟩ := List.mem_map.mp queried + refine ⟨RawWHIRKeys.callerOutput_admissible registry.context Q a.input.packet wanted prior,o.answer,?_⟩ + have present : o ∈ (view).observations := by + rw [split,nativeSplit] + exact List.mem_append_right _ (List.mem_append_left _ member) + cases o + cases equal + exact present + +/-- A full native capture supplies every accepting source witness field. The +only failure input is the genuine public extractor predicate on that view. -/ +theorem capture_failure (a : AnchoredPhysicalAfter.Accepted registry.context Q cap) + (success : (view).result.value = some a) + (capture : CaptureResult (stack := rfl) a.input.packet a.input.record + (wholeAllocation cap registry Q attacker A B limit counted a) seed ro + (registry.packetModel Q a.input.packet) a.native) + (clean : ∀ ref, ¬ OutputCollision + (wholeReferenceLog cap registry Q attacker A B limit counted seed ro a ref)) + (failed : publicExtractionFailed (p := a.input.packet.val.profile) (B := B) + (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (registry.packetModel Q a.input.packet).layout a.input.record + (RawWHIRKeys.entry registry.context a.input.packet.val) + ⟨a.input.record.root,initialShape a.input.record.shape⟩ view) : + PCSBCSAdaptiveSourceKnowledgeProbability.Failed (registry.packetModel Q a.input.packet).layout + (wholeAllocation cap registry Q attacker A B limit counted a) (table + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + a.input.packet seed ro) := by + obtain ⟨original,decoded,failed⟩ := failed + rw [mixed_success_publicOriginal cap registry Q attacker A B limit counted seed ro a success, + capture.original_decoded] at decoded + have originalEq := Option.some.inj decoded + subst original + have publicClean : ¬ OutputCollision (publicLog + (PCSBCSCapturedSourceTransport.address (p := a.input.packet.val.profile) (Q := B) + (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length)) + ⟨a.input.record.root,initialShape a.input.record.shape⟩ view) := by + have eqLog := publicLog_actual seed ro + (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker) A limit counted + (PCSBCSCapturedSourceTransport.address (p := a.input.packet.val.profile) (Q := B) + (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length)) + ⟨a.input.record.root,initialShape a.input.record.shape⟩ + dsimp only at eqLog + simp only [Atomic.eval_program,Partition.join_split] at eqLog + rw [← eqLog] + exact clean _ + have publicClean' := publicClean + rw [← PCSBCSWholeNativePacketCoverage.allocationView_mixed cap registry Q attacker + A B limit counted seed ro a.input.packet.val.profile + (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length] at publicClean' + have root := publicRoot_actual seed ro + (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker) A limit counted + (PCSBCSCapturedSourceTransport.address (p := a.input.packet.val.profile) (Q := B) + (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length)) + ⟨a.input.record.root,initialShape a.input.record.shape⟩ publicClean' + dsimp only at root + simp only [Atomic.eval_program,Partition.join_split] at root + rw [root] at failed + refine ⟨{ + saved := a.input.record + original := capture.original + constructed := ?_ + native := { + primitive := seed + final := capture.final + claims := capture.claims + valid := a.native.configuration.1 + profile := a.native.configuration.2 + caller := ?_ + bound := capture.bound_original + terminal := capture.terminal + recorded := capture.recorded + authentic := ?_ + clean := clean _ + ring := capture.replay.initial.1 + tape := a.native.wire.tape + strategy := fun _ => CausalStrategy.indexedStrategy capture.replay.whir.replies + raws := capture.raws + transport := ?_ + accepted := capture.experiment + failed := failed } }⟩ + · rw [capture.entry] + exact capture.caller_decoded + · exact referenceLog_authentic a.input.packet _ seed ro _ + · intro current member + rw [capture.native_replies] + exact capture.transport current member + · rw [capture.entry] + exact capture.original_decoded +end Mixed + +/-- The literal whole source result and observations, not a projected verifier +suffix or a seed-indexed observer. -/ +abbrev WholeSourceView := View (WHIRSourceChronology.Result cap + (Option (AnchoredPhysicalAfter.Accepted registry.context Q cap))) + +/-- Actual native acceptance followed by failure of the public, computable +round-by-round extractor. Public reconstruction supplies the original. -/ +def PublicFailure (B : Nat) (view : WholeSourceView cap registry Q) : Prop := + ∃ a, view.result.value = some a ∧ + publicExtractionFailed (p := a.input.packet.val.profile) (B := B) + (iv := registry.context.iv) + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (registry.packetModel Q a.input.packet).layout a.input.record + (RawWHIRKeys.entry registry.context a.input.packet.val) + ⟨a.input.record.root,initialShape a.input.record.shape⟩ view + +/-- All exclusions are finite public checks on the same whole view. There is +no quantification over hidden tables or an assumed soundness certificate. -/ +def Good (B : Nat) (view : WholeSourceView cap registry Q) : Prop := + PublicFailure cap registry Q B view ∧ + ¬ OutputCollision (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog B registry.context.iv view) ∧ + ∀ a, view.result.value = some a → ∀ opening ∈ a.native.wire.openings, + ¬ PCSBCSPublicPrimitiveOpening.publicBadOpening B registry.context.iv + (boundary := (RawWHIRKeys.entry registry.context a.input.packet.val).frames.length) + (PCSBCSNativeRootRoles.openingRole a.input.record opening) view opening + +open Classical in +noncomputable def failureObserver (B : Nat) (view : WholeSourceView cap registry Q) : Bool := + decide (PublicFailure cap registry Q B view) + +open Classical in +noncomputable def goodObserver (B : Nat) (view : WholeSourceView cap registry Q) : Bool := + decide (Good cap registry Q B view) + +section Observer +variable (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input registry.context Q)) + (B : Nat) (counted : Counts B (PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker)) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) (boundary : Nat) + (familyCap : cap ≤ 2^64) + (sourceClass : SourceClass cap registry Q p layout boundary attacker) +local notation "whole" => PCSBCSNativePhysicalFreeze.wholeProgram cap registry Q attacker + +include familyCap sourceClass in +/-- ALL typed tables are realized by the existing inverse partition. Native +caller/reply acceptance evidence is derived by actual mixed whole success. -/ +theorem observerRefines : + PCSBCSSourceKnowledgeGame.ObserverRefines (p := p) (iv := registry.context.iv) + (boundary := boundary) layout whole counted (goodObserver cap registry Q B) := by + classical + intro typed observed + obtain ⟨seed,ro,equal⟩ := PCSBCSNativeSourceTables.every_table typed + rw [← equal] at observed ⊢ + simp only [PCSBCSSourceKnowledgeGame.source,Atomic.eval_program,Partition.join_split] at observed + have good : Good cap registry Q B + (PCSBCSWholeNativePacketCoverage.mixedView cap registry Q attacker B B (by rfl) counted seed ro) := + of_decide_eq_true observed + obtain ⟨⟨a,success,failed⟩,clean,quiet⟩ := good + have logs := PCSBCSPublicPrimitiveOpening.wholeReferenceLog_clean cap registry Q attacker + B B (by rfl) counted seed ro a clean + have exclusions : ∀ opening ∈ a.native.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad seed + (wholeOpeningLog cap registry Q attacker B B (by rfl) counted seed ro a opening) + opening.root opening.result.paths := by + intro opening member bad + exact quiet a success opening member + ((PCSBCSPublicPrimitiveOpening.mixed_success_publicBadOpening_iff cap registry Q attacker + B B (by rfl) counted seed ro a success opening member).mpr bad) + obtain ⟨capture⟩ := mixed_success_capture_replyTransport cap registry Q attacker + B B (by rfl) counted seed ro a familyCap success exclusions logs + obtain ⟨profile,entry,grammar⟩ := mixed_success_metadata cap registry Q attacker + B B (by rfl) counted seed ro p layout boundary sourceClass a success + subst p boundary layout + exact capture_failure cap registry Q attacker B B (by rfl) counted seed ro + a success capture logs failed +end Observer + +section Real +variable (nativeRegistry : {r : WHIRPhysicalDriver.ProductionRegistry // + r.context.iv = PCSBCSSourceCoordinateDecoder.seedIV}) + (attacker : WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input nativeRegistry.val.context Q)) + (B : Nat) (counted : Counts B (PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q attacker)) +local notation "whole" => PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q attacker + +/-- The SAME complete physical alarm excludes every accepted native opening +bad event, without a separate physical-freeze or scanner-admission premise. -/ +theorem actual_opening_quiet (rootRegistry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (a : AnchoredPhysicalAfter.Accepted nativeRegistry.val.context Q cap) + (success : (runReal C nativeRegistry.val.context.iv whole).view.result.value = some a) + (quiet : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets a.input.packet.val.profile B + (RawWHIRKeys.entry nativeRegistry.val.context a.input.packet.val).frames.length rootRegistry) [] + (PublicCompressionProgram.primitiveLog C nativeRegistry.val.context.iv whole B counted) = false) : + ∀ opening ∈ a.native.wire.openings, + ¬ PublicMerkleBinding.OpenPrimitiveBad C + (wholeOpeningLog cap nativeRegistry.val Q attacker B B (by rfl) counted C + (WHIRRealSimulator.rawTable B C) a opening) opening.root opening.result.paths := by + intro opening member + have mentioned := PCSBCSWholeNativePacketCoverage.actual_success_opening_firstMention + cap nativeRegistry.val Q attacker B B (by rfl) counted C a success opening member + rw [openingReference_eq_role a.input.packet a.input.record a.native.configuration.2 opening, + nativeRegistry.property] at mentioned + obtain ⟨events,mentioned⟩ := mentioned + have evaluated := PCSBCSNativePhysicalFreeze.whole_success_evaluated + cap nativeRegistry.val Q attacker C B counted a success opening member + have quiet' := quiet + rw [nativeRegistry.property] at quiet' + have excluded := PCSBCSNativeCompleteAlarm.firstMention_opening_quiet + a.input.packet.val.profile B (RawWHIRKeys.entry nativeRegistry.val.context a.input.packet.val).frames.length + rootRegistry C whole B (by rfl) counted (PCSBCSNativeRootRoles.openingRole a.input.record opening) + events mentioned quiet' opening.result.paths + (by intro path present bytes input; exact (evaluated path present bytes input).1) + (by + intro path present bytes input event found + simpa only [nativeRegistry.property] using (evaluated path present bytes input).2 event found) + change ¬ PublicMerkleBinding.OpenPrimitiveBad C + (PCSBCSNativePhysicalFreeze.actualSourceLog (p := a.input.packet.val.profile) + (iv := nativeRegistry.val.context.iv) + (boundary := (RawWHIRKeys.entry nativeRegistry.val.context a.input.packet.val).frames.length) + C whole B (by rfl) counted (PCSBCSNativeRootRoles.openingRole a.input.record opening)) + opening.root opening.result.paths + simpa only [PCSBCSNativeRootRoles.openingRole,nativeRegistry.property] using excluded + +/-- Pointwise real reduction to exactly the modeled complete trace alarm. -/ +theorem real_failure_good_or_alarm (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (boundary : Nat) + (sourceClass : SourceClass cap nativeRegistry.val Q p layout boundary attacker) + (rootRegistry : AnchoredHeaderRoots.Public) (C : PrimitiveOracle) + (failed : failureObserver cap nativeRegistry.val Q B + (runReal C nativeRegistry.val.context.iv whole).view = true) : + goodObserver cap nativeRegistry.val Q B (runReal C nativeRegistry.val.context.iv whole).view = true ∨ + PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary rootRegistry) [] + (PublicCompressionProgram.primitiveLog C nativeRegistry.val.context.iv whole B counted) = true := by + classical + by_cases alarm : PublicMerkleProbability.traceAlarm + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary rootRegistry) [] + (PublicCompressionProgram.primitiveLog C nativeRegistry.val.context.iv whole B counted) = true + · exact Or.inr alarm + have quiet := Bool.eq_false_iff.mpr alarm + have failure : PublicFailure cap nativeRegistry.val Q B + (runReal C nativeRegistry.val.context.iv whole).view := of_decide_eq_true failed + obtain ⟨a,success,extractionFailed⟩ := failure + have mixedSuccess := success + rw [← PCSBCSWholeNativePacketCoverage.actual_mixedView cap nativeRegistry.val Q attacker + B B (by rfl) counted C] at mixedSuccess + obtain ⟨profile,entry,_⟩ := mixed_success_metadata cap nativeRegistry.val Q attacker + B B (by rfl) counted C (WHIRRealSimulator.rawTable B C) + p layout boundary sourceClass a mixedSuccess + have ordinary := PCSBCSPublicPrimitiveOpening.publicOrdinaryLog_actual + (p := p) (iv := nativeRegistry.val.context.iv) (boundary := boundary) + C (WHIRRealSimulator.rawTable B C) whole B (by rfl) counted + simp only [Atomic.eval_program,Partition.join_split] at ordinary + change PCSBCSPublicPrimitiveOpening.publicOrdinaryLog B nativeRegistry.val.context.iv + (PCSBCSWholeNativePacketCoverage.mixedView cap nativeRegistry.val Q attacker + B B (by rfl) counted C (WHIRRealSimulator.rawTable B C)) = _ at ordinary + rw [PCSBCSWholeNativePacketCoverage.actual_mixedView cap nativeRegistry.val Q attacker + B B (by rfl) counted C] at ordinary + apply Or.inl + apply decide_eq_true + refine ⟨⟨a,success,extractionFailed⟩,?_,?_⟩ + · rw [ordinary] + intro collision + have loud := PCSBCSNativePhysicalMerkleBad.mixed_atomic_collision_alarm + (p := p) (boundary := boundary) C nativeRegistry.val.context.iv whole B (by rfl) counted + (PCSBCSSourcePrimitiveRootBudget.targets p B boundary rootRegistry) collision + exact alarm loud + · intro accepted acceptedSuccess opening member bad + have same := Option.some.inj (success.symm.trans acceptedSuccess) + subst accepted + have quiet' := quiet + rw [← profile,← entry] at quiet' + have excluded := actual_opening_quiet cap Q nativeRegistry attacker B counted rootRegistry C a success quiet' + apply excluded opening member + apply (PCSBCSPublicPrimitiveOpening.mixed_success_publicBadOpening_iff cap nativeRegistry.val Q + attacker B B (by rfl) counted C (WHIRRealSimulator.rawTable B C) a mixedSuccess opening member).mp + rw [PCSBCSWholeNativePacketCoverage.actual_mixedView] + exact bad +end Real + +section Composition +variable {Coins : Type} [Fintype Coins] [Nonempty Coins] + (nativeRegistry : {r : WHIRPhysicalDriver.ProductionRegistry // + r.context.iv = PCSBCSSourceCoordinateDecoder.seedIV}) + (attacker : Coins → WHIRSourceChronology.Source cap (AnchoredPhysicalAfter.Input nativeRegistry.val.context Q)) + (B : Nat) (counted : ∀ coins, Counts B (PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q (attacker coins))) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) (boundary : Nat) + (sourceClass : ∀ coins, SourceClass cap nativeRegistry.val Q p layout boundary (attacker coins)) + (rootRegistry : AnchoredHeaderRoots.Public) +local notation "adversary" => fun coins => PCSBCSNativePhysicalFreeze.wholeProgram cap nativeRegistry.val Q (attacker coins) + +omit [Fintype Coins] [Nonempty Coins] in +include sourceClass in +theorem realReduction : + PCSBCSSourceKnowledgeComposition.Reduction (p := p) (iv := nativeRegistry.val.context.iv) + (boundary := boundary) rootRegistry adversary counted + (failureObserver cap nativeRegistry.val Q B) (goodObserver cap nativeRegistry.val Q B) := by + intro C coins failed + exact real_failure_good_or_alarm cap Q nativeRegistry (attacker coins) B (counted coins) + p layout boundary (sourceClass coins) rootRegistry C failed + +include counted sourceClass rootRegistry in +/-- Full historical PCS-only random-compression endpoint, using the genuine +public observer and the derived ALL-table and SAME-alarm obligations. B counts +all ordinary calls plus full construction-path work, not distinct native calls. -/ +theorem random_compression_failure_probability (familyCap : cap ≤ 2^64) : + realProbability nativeRegistry.val.context.iv adversary (failureObserver cap nativeRegistry.val Q B) ≤ + (B : ℚ)*PCSRoundByRoundKnowledge.rbrError + duplexModeLoss B + + ((B : ℚ)^3+3*(B : ℚ)^2-2*(B : ℚ))/2^256 := by + apply PCSBCSSourceKnowledgeComposition.random_compression_failure_probability + (p := p) (boundary := boundary) rootRegistry layout adversary counted + (failureObserver cap nativeRegistry.val Q B) (goodObserver cap nativeRegistry.val Q B) + · intro coins + exact observerRefines cap nativeRegistry.val Q (attacker coins) B (counted coins) + p layout boundary familyCap (sourceClass coins) + · exact realReduction cap Q nativeRegistry attacker B counted p layout boundary sourceClass rootRegistry + +include counted sourceClass rootRegistry in +/-- The q56 RBR, 256-bit coupling, and complete Merkle terms are kept separate. +The variable B is the aggregate public source primitive-work budget. -/ +theorem explicit_failure_probability (familyCap : cap ≤ 2^64) : + realProbability nativeRegistry.val.context.iv adversary (failureObserver cap nativeRegistry.val Q B) ≤ + (B : ℚ)*((17/32 : ℚ)^56 + 1/2^78) + + min 1 ((2*(B : ℚ)^2-(B : ℚ))/2^256) + + ((B : ℚ)^3+3*(B : ℚ)^2-2*(B : ℚ))/2^256 := by + simpa only [PCSRoundByRoundKnowledge.rbrError,SupportedCandidateExtraction.radiusEnvelope, + duplexModeLoss_eq] using random_compression_failure_probability + cap Q nativeRegistry attacker B counted p layout boundary sourceClass rootRegistry familyCap +end Composition + +#print axioms observerRefines +#print axioms realReduction +#print axioms random_compression_failure_probability + +#print axioms explicit_failure_probability +end Whir.PCSBCSWholeSourceObserver diff --git a/verification/whir/Whir/PCSListExtraction.lean b/verification/whir/Whir/PCSListExtraction.lean new file mode 100644 index 000000000..e7f6e4f54 --- /dev/null +++ b/verification/whir/Whir/PCSListExtraction.lean @@ -0,0 +1,69 @@ +import Whir.ShoupTraceExtraction +import Whir.ConcreteRowExtraction +import CompPoly.Bivariate.GuruswamiSudan.Interpolation.Dense.Correctness +import CompPoly.Bivariate.GuruswamiSudan.Root.RothRuckenstein.Correctness +import CompPoly.Bivariate.GuruswamiSudan.Executable +import ArkLib.Data.CodingTheory.GuruswamiSudan.Correctness + +/-! Executable list decoding on the actual WHIR base-domain nodes. This adapter supplies a real non-enumerating E root provider, dense interpolation and Roth–Ruckenstein, followed by guarded novel-basis base-word projection. Radius and integer interpolation-capacity hypotheses are explicit. They are not replaced by PCS soundness, and verifier acceptance alone is not asserted to imply them. -/ +namespace Whir.PCSListExtraction +open Concrete CompPoly +local instance : Field E := ExtractionField.field + +/-- The complete root backend is instantiated, rather than supplied as an unimplemented oracle. -/ +def context : CompPoly.GuruswamiSudan.GSFilteredCoreContext E := + CompPoly.GuruswamiSudan.filteredCoreContextOfInterpRootContexts + (CompPoly.GuruswamiSudan.denseInterpContext E) + (CompPoly.GuruswamiSudan.rothRuckensteinRootContext E + (ShoupTraceExtraction.fieldRootContext CPolynomial.Raw.MulContext.naive + CPolynomial.Raw.ModContext.naive)) + +/-- Only N explicitly provided received values are read. No public root preimage is consulted. -/ +def receivedWord (depth : Nat) (received : Fin (2 ^ depth) → E) : + CompPoly.GuruswamiSudan.GSReceivedWord E where + points := Array.ofFn fun i => (E.ofK (UInt64.ofNat i.val), received i) + +/-- The caller's finite integer parameters are computational inputs; certificates are erased proofs. -/ +def listPolynomials (depth : Nat) (params : CompPoly.GuruswamiSudan.GSExecParams) + (received : Fin (2 ^ depth) → E) : Array (CPolynomial E) := + CompPoly.GuruswamiSudan.decodeWithParams context params (receivedWord depth received) + +def listWords (n rate : Nat) (params : CompPoly.GuruswamiSudan.GSExecParams) + (received : Fin (2 ^ (n + rate)) → E) : Array (Array K) := + (listPolynomials (n + rate) params received).filterMap (ConcreteRowExtraction.baseWords n) + +theorem listPolynomials_complete (n rate : Nat) (noWrap : n + rate ≤ 64) + (params : CompPoly.GuruswamiSudan.GSExecParams) (errors : Nat) + (certificate : _root_.GuruswamiSudan.GSParamCert (2 ^ n) (2 ^ (n + rate)) errors params) + (received : Fin (2 ^ (n + rate)) → E) (polynomial : Polynomial E) + (degree : polynomial.degree < (2 ^ n : Nat)) + (distance : hammingDist received + (fun i => polynomial.eval (E.ofK (UInt64.ofNat i.val))) ≤ errors) : + ∃ candidate ∈ (listPolynomials (n + rate) params received).toList, + candidate.toPoly = polynomial := by + exact (_root_.GuruswamiSudan.mem_decodeWithParams_iff_degree_and_distance + context params certificate + (ωs := AdditiveCode.concreteDomain (n + rate) noWrap) + (w := receivedWord (n + rate) received) (by rfl)).mpr ⟨degree, distance⟩ + +theorem listWords_complete (n rate : Nat) (noWrap : n + rate ≤ 64) + (params : CompPoly.GuruswamiSudan.GSExecParams) (errors : Nat) + (certificate : _root_.GuruswamiSudan.GSParamCert (2 ^ n) (2 ^ (n + rate)) errors params) + (received : Fin (2 ^ (n + rate)) → E) (words : Array K) + (shape : words.size = 2 ^ n) + (distance : hammingDist received + (fun i => (AdditiveCode.concretePolynomial n (words.map E.ofK)).eval + (E.ofK (UInt64.ofNat i.val))) ≤ errors) : + words ∈ (listWords n rate params received).toList := by + have small : n ≤ 64 := by omega + obtain ⟨candidate, member, polynomial⟩ := listPolynomials_complete n rate noWrap params errors + certificate received (AdditiveCode.concretePolynomial n (words.map E.ofK)) + (AdditiveCode.concrete_polynomial_degree_lt n small _) distance + have projected := ConcreteRowExtraction.baseWords_recovers n small words shape candidate polynomial + simp only [listWords, Array.toList_filterMap, List.mem_filterMap] + exact ⟨candidate, member, projected⟩ + +#print axioms context +#print axioms listPolynomials_complete +#print axioms listWords_complete +end Whir.PCSListExtraction diff --git a/verification/whir/Whir/PCSRewindExtractorGSFixtures.lean b/verification/whir/Whir/PCSRewindExtractorGSFixtures.lean new file mode 100644 index 000000000..d566e675f --- /dev/null +++ b/verification/whir/Whir/PCSRewindExtractorGSFixtures.lean @@ -0,0 +1,24 @@ +import Whir.InterleavedListExtraction + +/-! Independent non-unique-radius extension-field GS regression artifact. +This backend is not imported or executed by the Root0 knowledge extractor. -/ +namespace Whir.PCSRewindExtractorGSFixtures +open Concrete + +def extensionRows : Fin 2 → Array E := fun lane => + Array.ofFn fun j : Fin 4 => ⟨UInt64.ofNat (3 + lane.val * 11 + j.val), + UInt64.ofNat (5 + j.val), UInt64.ofNat (7 + lane.val)⟩ + +def runGS : IO Unit := do + let encoded := Array.ofFn fun lane : Fin 2 => encode 2 2 (extensionRows lane) + let received : Fin 2 → Fin 16 → E := fun lane q => + if q.val < 8 then (encoded[lane.val]!)[q.val]! + else (encoded[lane.val]!)[q.val]! + E.ofK 1 + let decoded := InterleavedListExtraction.candidates 2 2 2 8 2 15 false received + let expected := InterleavedListExtraction.assemble 2 false (List.ofFn extensionRows) + unless decoded.contains expected do throw (IO.userError "non-unique-radius interleaved GS target missing") + IO.println s!"interleaved-GS: 2 genuine E lanes, k=4, N=16, errors=8, candidates={decoded.length}" + +end Whir.PCSRewindExtractorGSFixtures + +def main : IO Unit := Whir.PCSRewindExtractorGSFixtures.runGS diff --git a/verification/whir/Whir/PCSRewindKnowledgeAnchor.lean b/verification/whir/Whir/PCSRewindKnowledgeAnchor.lean new file mode 100644 index 000000000..0f4133e0b --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeAnchor.lean @@ -0,0 +1,140 @@ +import Whir.PCSRewindKnowledgeBound +import Whir.AnchorPrefixRefinementCaller + +/-! Compressed-family dense-claims endpoint only. The actual transformed family +and ordinary point claims include the retained commitment anchor at its final +powers-batch position. A single public seed does not certify every original +FamilyClaim; that requires the separate joint-prefix original-source theorem. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open SamplingProbability AuthenticatedResetProbability + +private theorem anchored_claim_shapes {m : Nat} (c : Config) (record : AnchoredHeaderCodec.Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) + (j : Fin (AnchorPrefixRefinement.anchoredClaims c record family points seed).size) : + (AnchorPrefixRefinement.anchoredClaims c record family points seed)[j].weight.size = 2 ^ c.logN := by + have all : ∀ claim ∈ (AnchorPrefixRefinement.anchoredClaims c record family points seed).toList, + claim.weight.size = 2 ^ c.logN := by + intro claim member + simp only [AnchorPrefixRefinement.anchoredClaims, Array.toList_push, List.mem_append, List.mem_singleton] at member + rcases member with old | rfl + · obtain ⟨i, within, equal⟩ := Array.mem_iff_getElem.mp (Array.mem_toList_iff.mp old) + rw [← equal] + exact RingPCSGame.transformedClaims_shapes _ _ _ _ ⟨i, within⟩ + · simp [CommitmentAnchor.weight, ArrayLayout.size_tab] + exact all _ (Array.mem_toList_iff.mpr (Array.getElem_mem j.isLt)) + +/-- Literal record validity and profile metadata derive the supported lane and +retained point dimensions; dense transformed weights have the actual dimension +and their exact size is ordinaryPoints.size+2. -/ +theorem anchored_metadata_shapes {m : Nat} (profile : ParameterBounds.Profile) + (record : AnchoredHeaderCodec.Record) (family : Fin m → RingPCSGame.FamilyClaim) + (ordinaryPoints : Array RingPCSGame.PointClaim) (publicSeed : RingPCSGame.Prefix) + (valid : record.Valid) + (batchShape : record.shape.logBatch = (ParameterBounds.config profile).folds[0]!) + (dimensionShape : record.shape.logN = (ParameterBounds.config profile).logN) : + record.shape.lanes ≤ laneCount (ParameterBounds.config profile) ∧ + record.point.length = (ParameterBounds.config profile).logN ∧ + (AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) + record family ordinaryPoints publicSeed).size = ordinaryPoints.size + 2 ∧ + ∀ j : Fin (AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) + record family ordinaryPoints publicSeed).size, + (AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) + record family ordinaryPoints publicSeed)[j].weight.size = 2 ^ (ParameterBounds.config profile).logN := by + refine ⟨?_, valid.2.2.trans dimensionShape, ?_, anchored_claim_shapes _ _ _ _ _⟩ + · simpa only [batchShape] using valid.1.2.2.2.2.2 + · simp only [AnchorPrefixRefinement.anchoredClaims, Array.size_push, RingPCSGame.transformedClaims_size] + omega + +/-- Compressed-family dense claims only: the actual source caller's appended +anchor is included, but one seed does not uncompress every FamilyClaim. -/ +theorem anchored_production_knowledge_bound {m : Nat} (profile : ParameterBounds.Profile) + (record : AnchoredHeaderCodec.Record) (root : BaseOracle) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (strategy : Strategy) + (valid : record.Valid) + (batchShape : record.shape.logBatch = (ParameterBounds.config profile).folds[0]!) + (dimensionShape : record.shape.logN = (ParameterBounds.config profile).logN) + (pointCap : points.size + 2 ≤ 2 ^ 64) + (security : Nat) : + let claims := AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) record family points seed + let κ := probability (fun tape => experiment + (ExecutionShapes.Input profile record.shape.lanes root claims) strategy tape = true) + let gap := κ - (extractionCutoff : ℝ) + KnowledgeBound profile (knowledgeAttempts gap security) (knowledgeRounds profile gap) + record.shape.lanes root claims strategy (extractionCutoff + (1 / 2 : ℚ) ^ security) := by + obtain ⟨laneBound, _pointShape, claimCount, claimShape⟩ := + anchored_metadata_shapes profile record family points seed valid batchShape dimensionShape + have claimCap : (AnchorPrefixRefinement.anchoredClaims + (ParameterBounds.config profile) record family points seed).size ≤ 2 ^ 64 := by + rw [claimCount] + exact pointCap + exact production_universal_knowledge_bound profile record.shape.lanes root + (AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) record family points seed) + strategy laneBound claimShape claimCap security + +/-- Any verified output explains the compressed-family dense claims and the +same retained anchor point/value. No conclusion about every original family +functional follows from this fixed-seed endpoint. -/ +theorem anchored_extracted_output {m : Nat} (profile : ParameterBounds.Profile) + (attempts rounds : Nat) (record : AnchoredHeaderCodec.Record) (root : BaseOracle) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (publicSeed : RingPCSGame.Prefix) (strategy : Strategy) + (seed : RepeatedSeed profile attempts rounds) + (valid : record.Valid) + (batchShape : record.shape.logBatch = (ParameterBounds.config profile).folds[0]!) + (dimensionShape : record.shape.logN = (ParameterBounds.config profile).logN) + (w : Witness (ParameterBounds.config profile) record.shape.lanes) + (output : + let claims := AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) record family points publicSeed + let input := ExecutionShapes.Input profile record.shape.lanes root claims + (runRewind input strategy (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program input seed)).output = some w) : + Explains (ExecutionShapes.Input profile record.shape.lanes root + (AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) record family points publicSeed)) w ∧ + CommitmentAnchor.value (ParameterBounds.config profile) record.shape.lanes w record.point.toArray = record.value := by + have laneBound : record.shape.lanes ≤ laneCount (ParameterBounds.config profile) := by + simpa only [batchShape] using valid.1.2.2.2.2.2 + have pointShape : record.point.length = (ParameterBounds.config profile).logN := + valid.2.2.trans dimensionShape + let claims := AnchorPrefixRefinement.anchoredClaims (ParameterBounds.config profile) record family points publicSeed + have explains := repeatedExtractor_output_explains profile attempts rounds record.shape.lanes root claims + strategy seed laneBound w output + refine ⟨explains, ?_⟩ + have original : (⟨CommitmentAnchor.weight (ParameterBounds.config profile) record.shape.lanes record.point.toArray, + record.value⟩ : Claim) ∈ claims.toList := by + simp [claims, AnchorPrefixRefinement.anchoredClaims] + have same := explains.2 _ original + rw [CommitmentAnchor.weight_value _ _ _ _ (by simpa using pointShape)] at same + exact same + +/-- The actual retained anchor occupies the unchanged final batching power, +lambda^(ordinaryPoints.size+1), in both the weight and claimed value. -/ +theorem anchored_retained_batch {m : Nat} (c : Config) (record : AnchoredHeaderCodec.Record) + (family : Fin m → RingPCSGame.FamilyClaim) (ordinaryPoints : Array RingPCSGame.PointClaim) + (publicSeed : RingPCSGame.Prefix) (lambda : E) : + batchClaims (2 ^ c.logN) + (AnchorPrefixRefinement.anchoredClaims c record family ordinaryPoints publicSeed) lambda = + ⟨weightGlue + (batchClaims (2 ^ c.logN) + (RingPCSGame.transformedClaims (2 ^ c.logN) family ordinaryPoints publicSeed) lambda).weight + (CommitmentAnchor.weight c record.shape.lanes record.point.toArray) + (lambda ^ (ordinaryPoints.size + 1)), + WHIRNativeArithmetic.initialClaim family ordinaryPoints publicSeed lambda + + lambda ^ (ordinaryPoints.size + 1) * record.value⟩ := by + rw [AnchorPrefixRefinement.anchoredClaims, AnchorPrefixRefinement.batchClaims_push] + simp only [RingPCSGame.transformedClaims_size] + rw [← WHIRNativeArithmetic.initialClaim_eq_batch_value] + simp only [Nat.add_comm 1 ordinaryPoints.size] + +#print axioms anchored_production_knowledge_bound +#print axioms anchored_extracted_output +#print axioms anchored_retained_batch +#print axioms anchored_metadata_shapes +#check anchored_production_knowledge_bound +#check anchored_extracted_output +#check anchored_retained_batch +#check anchored_metadata_shapes +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRewindKnowledgeBound.lean b/verification/whir/Whir/PCSRewindKnowledgeBound.lean new file mode 100644 index 000000000..e42cc8b08 --- /dev/null +++ b/verification/whir/Whir/PCSRewindKnowledgeBound.lean @@ -0,0 +1,178 @@ +import Whir.ExtractorArithmeticCostRetained +import Whir.PCSRewindKnowledgeProduction + +/-! Concrete production knowledge requirement. Unlike the retired arbitrary +LocalCostModel contract, this uses the actual value-connected source counter +and an input-dependent polynomial. Encoded input/reply allocation and prover +computation are distinct resource units, not silently unit-cost field work. -/ +namespace Whir.PCSRewindExtractor +open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction +open AuthenticatedResetSupport ExtractorArithmeticCost +open SamplingProbability AuthenticatedResetProbability +open scoped BigOperators + +/-- End-to-end knowledge and efficiency of the legal repeated Root0 extractor +on a fixed dense public instance and adversarial causal strategy. Explains +contains exactly its dense claims, not uncompressed ring-family statements. -/ +structure KnowledgeBound (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) (error : ℚ) : Prop where + failure : knowledgeFailureProbability (repeatedExtractor profile attempts rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ ≤ error + arithmetic : ∀ seed : RepeatedSeed profile attempts rounds, + let input := ExecutionShapes.Input profile lanes root claims + (runCounted input strategy (streamLength input.config) + (attempts * (rounds * streamLength input.config)) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0)).fieldArithmetic ≤ + totalFieldPolynomial input attempts rounds input.config.logN 6 256 256 input.config.logN + responses : ∀ seed : RepeatedSeed profile attempts rounds, + let input := ExecutionShapes.Input profile lanes root claims + (runRewind input strategy (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program input seed)).responseCalls ≤ + attempts * (rounds * streamLength input.config) * (streamLength input.config + 1) + records : ∀ seed : RepeatedSeed profile attempts rounds, + let input := ExecutionShapes.Input profile lanes root claims + (∑ i, (collectedRecords ⟨input, strategy⟩ (initialLevel profile) (initialDepth profile) + (seedTapes profile rounds input rfl (seed i))).length) ≤ attempts * (rounds * input.config.queries[0]!) + counterValue : ∀ seed : RepeatedSeed profile attempts rounds, + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength input.config) + (attempts * (rounds * streamLength input.config)) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + let actual := runRewind input strategy (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program input seed) + measured.output = actual.output ∧ measured.responseCalls = actual.responseCalls + strictPrefix : ∀ (historyPrefix : List Batch) (message : Batch) + (next : Reply → RewindProgram (ParameterBounds.config profile) lanes) (fuel : Nat), + let input := ExecutionShapes.Input profile lanes root claims + runRewind input strategy (streamLength input.config) (fuel + 1) (.query historyPrefix message next) = + if historyPrefix.length ≤ streamLength input.config then + let actual := runRewind input strategy (streamLength input.config) fuel + (next (strategy input (replayPast input strategy [] historyPrefix) message)) + ⟨actual.output, actual.responseCalls + historyPrefix.length + 1⟩ + else ⟨none, 0⟩ + verifierValue : ∀ (tape : Tape (ParameterBounds.config profile)) (answers : List Reply), + let input := ExecutionShapes.Input profile lanes root claims + (countedAcceptedReplies input tape answers).1 = acceptedReplies input tape answers + preparationValue : ∀ (seed : RepeatedSeed profile attempts rounds) (i : Fin attempts), + let input := ExecutionShapes.Input profile lanes root claims + let retained := retainedRecords profile rounds lanes root claims strategy (seed i) + (CountedCandidateCheck.countedFilledRecords input retained).1 = filledRecords input retained ∧ + (CountedCandidateCheck.countedReceivedTables input retained).1 = + Array.ofFn (fun lane : Fin input.lanes => + Array.ofFn (fun q : Fin (blockLength input.config) => receivedLane input retained lane q)) + explains : ∀ (seed : RepeatedSeed profile attempts rounds) (w : Witness (ParameterBounds.config profile) lanes), + let input := ExecutionShapes.Input profile lanes root claims + (runRewind input strategy (repeatedExtractor profile attempts rounds).maxReplay + (repeatedExtractor profile attempts rounds).rewindRounds + ((repeatedExtractor profile attempts rounds).program input seed)).output = some w → Explains input w + preparationResources : ∀ (seed : RepeatedSeed profile attempts rounds), + root.size = blockLength (ParameterBounds.config profile) → + (∀ row ∈ root.toList, row.size = lanes) → + (∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) → + (∑ i, retainedPreparation profile rounds lanes root claims strategy (seed i)) ≤ + attempts * retainedPreparationPolynomial (ParameterBounds.config profile) rounds lanes claims.size + admittedResources : ∀ (seed : RepeatedSeed profile attempts rounds) (encodedInputWords : Nat), + root.size = blockLength (ParameterBounds.config profile) → + (∀ row ∈ root.toList, row.size = lanes) → + (∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) → + let input := ExecutionShapes.Input profile lanes root claims + let measured := runCounted input strategy (streamLength input.config) + (attempts * (rounds * streamLength input.config)) + (countedRepeatedProgram profile rounds input rfl (List.ofFn seed) 0) + measured.encodedReplyWords + CountedCandidateCheck.consumedWords input [] ≤ encodedInputWords → + measured.fieldArithmetic + measured.responseCalls + + (measured.encodedReplyWords + CountedCandidateCheck.consumedWords input []) ≤ + physicalFieldPolynomial (laneCount input.config) lanes (blockLength input.config) + claims.size input.config.folds.size attempts rounds 6 256 256 input.config.logN + + attempts * (rounds * streamLength input.config) * (streamLength input.config + 1) + encodedInputWords + +/-- Deterministic source properties discharge every efficiency and output +field. Only the independently proved actual failure inequality is composed. -/ +theorem knowledgeBound_of_failure (profile : ParameterBounds.Profile) (attempts rounds lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) (error : ℚ) + (failure : knowledgeFailureProbability (repeatedExtractor profile attempts rounds) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ ≤ error) : + KnowledgeBound profile attempts rounds lanes root claims strategy error where + failure := failure + arithmetic seed := (production_repeated_resources profile rounds attempts lanes root claims strategy seed).1 + responses seed := repeatedExtractor_responseCalls profile attempts rounds ⟨_, strategy⟩ seed + records seed := production_all_records profile attempts rounds lanes root claims strategy seed + counterValue seed := actualRepeated_value profile rounds attempts lanes root claims strategy seed + strictPrefix _ _ _ _ := rfl + verifierValue _ _ := countedAcceptedReplies_value _ _ _ + preparationValue seed i := retained_preparation_value profile rounds lanes root claims strategy (seed i) + explains seed w output := repeatedExtractor_output_explains profile attempts rounds lanes root claims strategy seed laneBound w output + admittedResources seed words rootShape rowShape claimShape admission := + production_repeated_physical_resource profile rounds attempts lanes root claims strategy seed words + rootShape rowShape laneBound claimShape admission + preparationResources seed rootShape rowShape claimShape := by + apply production_all_retained_preparation profile rounds attempts lanes root claims strategy seed + rootShape rowShape laneBound + intro claim member + obtain ⟨i, within, equal⟩ := Array.mem_iff_getElem.mp (Array.mem_toList_iff.mp member) + have shape : claims[i].weight.size = 2 ^ (ParameterBounds.config profile).logN := + claimShape ⟨i, within⟩ + rw [← equal, shape] + unfold laneCount width + rw [← Nat.pow_add, Nat.add_sub_of_le (InitialCandidates.production_initial_facts profile).2.1] + +/-- Efficient knowledge extraction for every actual source profile above its +rigorously amplified cutoff. The positive acceptance gap determines real +polynomial block fuel. No availability/goodness/certificate premise occurs. -/ +theorem production_knowledge_bound (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) (gap : ℝ) (gapPositive : 0 < gap) (security : Nat) + (advantage : (extractionCutoff : ℝ) + gap ≤ + probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true)) : + KnowledgeBound profile (knowledgeAttempts gap security) (knowledgeRounds profile gap) + lanes root claims strategy ((1 / 2 : ℚ) ^ security) := + knowledgeBound_of_failure profile _ _ lanes root claims strategy laneBound _ + (production_repeated_knowledge_failure profile lanes root claims strategy laneBound + claimShape claimCap gap gapPositive security advantage) + +/-- Universal acceptance-plus-failure form. The zero/negative-gap branch uses +the verifier's actual low acceptance mass; above cutoff the executable bounded +extractor uses inverse-gap fuel and verified-output amplification. The fuel is +an externally parameterized interaction bound, not a runtime computation of +the adversary's acceptance probability. -/ +theorem production_universal_knowledge_bound (profile : ParameterBounds.Profile) (lanes : Nat) + (root : BaseOracle) (claims : Array Claim) (strategy : Strategy) + (laneBound : lanes ≤ laneCount (ParameterBounds.config profile)) + (claimShape : ∀ j : Fin claims.size, claims[j].weight.size = 2 ^ (ParameterBounds.config profile).logN) + (claimCap : claims.size ≤ 2 ^ 64) (security : Nat) : + let κ := probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) + let gap := κ - (extractionCutoff : ℝ) + KnowledgeBound profile (knowledgeAttempts gap security) (knowledgeRounds profile gap) + lanes root claims strategy (extractionCutoff + (1 / 2 : ℚ) ^ security) := by + dsimp only + let κ := probability (fun tape => experiment (ExecutionShapes.Input profile lanes root claims) strategy tape = true) + let gap := κ - (extractionCutoff : ℝ) + apply knowledgeBound_of_failure profile _ _ lanes root claims strategy laneBound + by_cases high : (extractionCutoff : ℝ) < κ + · have positive : 0 < gap := sub_pos.mpr high + have advantage : (extractionCutoff : ℝ) + gap ≤ κ := by dsimp only [gap]; linarith + have bound := production_repeated_knowledge_failure profile lanes root claims strategy laneBound + claimShape claimCap gap positive security advantage + have cutoffNonnegative : (0 : ℚ) ≤ extractionCutoff := by norm_num [extractionCutoff] + exact bound.trans (by linarith) + · have bound := knowledge_failure_le_acceptance + (repeatedExtractor profile (knowledgeAttempts gap security) (knowledgeRounds profile gap)) + ⟨ExecutionShapes.Input profile lanes root claims, strategy⟩ + have low : κ ≤ (extractionCutoff : ℝ) := le_of_not_gt high + apply (Rat.cast_le (K := ℝ)).mp + have powerNonnegative : (0 : ℝ) ≤ ((1 / 2 : ℚ) ^ security : ℝ) := by positivity + push_cast + exact (bound.trans low).trans (by linarith) + +#print axioms knowledgeBound_of_failure +#print axioms production_knowledge_bound +#print axioms production_universal_knowledge_bound +#check production_knowledge_bound +#check production_universal_knowledge_bound +#print KnowledgeBound +end Whir.PCSRewindExtractor diff --git a/verification/whir/Whir/PCSRoundByRoundChronology.lean b/verification/whir/Whir/PCSRoundByRoundChronology.lean new file mode 100644 index 000000000..0ba681446 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundChronology.lean @@ -0,0 +1,58 @@ +import Whir.CausalPositions + +/-! Chronology includes the verifier's final tail draw even though it receives +no subsequent prover response. -/ +namespace Whir.PCSRoundByRoundChronology +open Concrete Protocol CausalGame CausalProbability CausalPositions +open Classical + +private theorem tail_not_mem_levels (c : Config) (j : Fin (c.logN - c.folds.toList.sum)) : + Coordinate.tail j ∉ [.initial] ++ (List.range c.folds.size).flatMap (levelCoordinates c) := by + simp only [List.mem_append, List.mem_cons, List.mem_nil_iff, or_false, List.mem_flatMap] + rintro (impossible | ⟨i, hi, member⟩) + · cases impossible + · have within := List.mem_range.mp hi + simp [levelCoordinates, within] at member + +private theorem levelPrefix_length (c : Config) (t : Tape c) : + ([Coordinate.initial] ++ (List.range c.folds.size).flatMap (levelCoordinates c)).length = + tailStart c (challenges c t) := by + have mapped : ((List.range c.folds.size).flatMap (levelCoordinates c)).map + (fun q => batch q (get q t)) = + (List.range c.folds.size).flatMap (levelBatches (challenges c t)) := by + rw [List.map_flatMap] + apply List.flatMap_congr + intro i hi + exact levelCoordinates_map c t i (List.mem_range.mp hi) + have lengths := congrArg List.length mapped + simpa only [List.length_map, List.length_append, List.length_singleton, + tailStart, levelStart] using congrArg (fun n => 1 + n) lengths + +/-- Zero-based position of every actual terminal draw, including the final one. -/ +theorem position_tail (c : Config) (t : Tape c) (j : Fin (c.logN - c.folds.toList.sum)) : + position (.tail j) = tailStart c (challenges c t) + j.val := by + unfold position visibleCoordinates + rw [List.idxOf_append_of_notMem (tail_not_mem_levels c j)] + rw [levelPrefix_length c t] + congr 1 + by_cases visible : j.val < c.logN - c.folds.toList.sum - 1 + · let k : Fin (c.logN - c.folds.toList.sum - 1) := ⟨j.val, visible⟩ + have member : Coordinate.tail j ∈ (List.ofFn fun k : Fin (c.logN - c.folds.toList.sum - 1) => + Coordinate.tail ⟨k.val, by omega⟩) := by + apply List.mem_ofFn.mpr + exact ⟨k, by congr⟩ + have bound := List.idxOf_lt_length_of_mem member + have eq := List.getElem_idxOf bound + simp only [List.getElem_ofFn] at eq + exact congrArg (fun q => match q with | Coordinate.tail a => a.val | _ => 0) eq + · have absent : Coordinate.tail j ∉ (List.ofFn fun k : Fin (c.logN - c.folds.toList.sum - 1) => + Coordinate.tail ⟨k.val, by omega⟩) := by + intro member + obtain ⟨k, eq⟩ := List.mem_ofFn.mp member + have same := Coordinate.tail.inj eq + have values : k.val = j.val := congrArg Fin.val same + exact visible (values ▸ k.isLt) + rw [List.idxOf_eq_length_iff.mpr absent, List.length_ofFn] + omega + +end Whir.PCSRoundByRoundChronology diff --git a/verification/whir/Whir/PCSRoundByRoundKnowledgeAnchor.lean b/verification/whir/Whir/PCSRoundByRoundKnowledgeAnchor.lean new file mode 100644 index 000000000..bfb67d6e2 --- /dev/null +++ b/verification/whir/Whir/PCSRoundByRoundKnowledgeAnchor.lean @@ -0,0 +1,58 @@ +import Whir.PCSRoundByRoundSourceDecoderCorrectness +import Whir.CommitmentAnchor + +/-! Immutable original-anchor applicability for the actual straight-line +extractor. Ambiguity is an outer, once-per-commitment event under the genuine +fresh-after-root point law, not a conditional per-opening RBR error. -/ +namespace Whir.PCSRoundByRoundKnowledge +open Concrete Protocol CausalGame ParameterBounds +open Classical + +set_option maxRecDepth 100000 +set_option maxHeartbeats 800000 +attribute [local irreducible] ParameterBounds.config + +/-- Actual returned words are members of the saved original anchor selector; +the selector is mathematical binding state, never the extraction algorithm. -/ +theorem extract_saved_anchor {m : Nat} (p : Profile) (commitment : CommitmentAnchor.Commitment p) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (w : Witness (config p) commitment.lanes) + (output : PCSRoundByRoundSource.run p commitment.lanes family points + (Array.ofFn commitment.point) commitment.value commitment.root = some w) : + w ∈ CommitmentAnchor.selected p commitment.lanes commitment.root commitment.point commitment.value := by + classical + have original := PCSRoundByRoundSource.run_output_explains p commitment.lanes family points + (Array.ofFn commitment.point) commitment.value commitment.root w output + exact Finset.mem_filter.mpr ⟨original.rootCandidate, original.anchor⟩ + +/-- Across arbitrary original families, stacking statements and point openings, +the unchanged saved point/value forces actual extracted outputs to coincide. -/ +theorem extracted_words_same_saved_anchor {m n : Nat} (p : Profile) + (commitment : CommitmentAnchor.Commitment p) + (clean : ¬ CommitmentAnchor.Ambiguous p commitment.lanes commitment.root commitment.point) + (family₁ : Fin m → RingPCSGame.FamilyClaim) (family₂ : Fin n → RingPCSGame.FamilyClaim) + (points₁ points₂ : Array RingPCSGame.PointClaim) + (w₁ w₂ : Witness (config p) commitment.lanes) + (left : PCSRoundByRoundSource.run p commitment.lanes family₁ points₁ + (Array.ofFn commitment.point) commitment.value commitment.root = some w₁) + (right : PCSRoundByRoundSource.run p commitment.lanes family₂ points₂ + (Array.ofFn commitment.point) commitment.value commitment.root = some w₂) : w₁ = w₂ := + CommitmentAnchor.cross_session p commitment clean w₁ w₂ + (extract_saved_anchor p commitment family₁ points₁ w₁ left) + (extract_saved_anchor p commitment family₂ points₂ w₂ right) + +/-- For every fixed root/shape before the genuinely uniform anchor point, +the exact outer ambiguity fiber is bounded by the fixed-list pair count. The +saved advertised value and all later original statements may be adaptive. -/ +theorem original_anchor_conditional_loss (p : Profile) (lanes : Nat) (root : BaseOracle) + (laneBound : lanes ≤ 2^(config p).folds[0]!) : + Soundness.uniformProb (Finset.univ.filter fun point : Fin (config p).logN → E => + CommitmentAnchor.Ambiguous p lanes root point) ≤ + ((InitialCandidates.witnesses (config p) lanes root).card.choose 2 : ℚ) * + ((config p).logN : ℚ) / 2^192 := + CommitmentAnchor.ambiguity_probability p lanes root laneBound + +#print axioms extract_saved_anchor +#print axioms extracted_words_same_saved_anchor +#print axioms original_anchor_conditional_loss +end Whir.PCSRoundByRoundKnowledge diff --git a/verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean b/verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean index 7073bb431..7ee80262c 100644 --- a/verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean +++ b/verification/whir/Whir/PCSRoundByRoundSourceDecoder.lean @@ -10,6 +10,7 @@ namespace Whir.PCSRoundByRoundSource open Concrete Protocol CausalGame KnowledgeExtraction SupportedCandidateExtraction open scoped BigOperators set_option maxHeartbeats 4000000 +local instance : Field E := ExtractionField.field /-- Literal physical availability, not equality with an honest commitment. -/ def FullRoot (c : Config) (lanes : Nat) (root : BaseOracle) : Prop := @@ -21,17 +22,40 @@ instance (c : Config) (lanes : Nat) (root : BaseOracle) : Decidable (FullRoot c def receivedLane (input : Public) (lane : Fin input.lanes) : Fin (blockLength input.config) → E := fun q => E.ofK (recordLane input.lanes input.root[q.val]! lane.val) -/-- One counted Gao/novel/base-word run per occupied lane; only lane vectors -are materialized. Root leaves are neither copied nor searched. -/ +/-- Share the public-domain nodal product across occupied lanes, charging its +construction once. Root leaves are neither copied nor searched. -/ def decodeRoot (input : Public) (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : Option (Witness input.config input.lanes) × Nat := + let nodal := if input.lanes = 0 then (0,0) else + ReedSolomonExtraction.countedNodal (ConcreteRowExtraction.domain + (input.config.logN - input.config.folds[0]! + input.config.rates[0]!) noWrap) let decoded := Array.ofFn fun lane : Fin input.lanes => - ConcreteRowExtraction.countedExtractRow (input.config.logN - input.config.folds[0]!) - input.config.rates[0]! noWrap ⟨Array.ofFn (receivedLane input lane), by simp⟩ + ConcreteRowExtraction.countedExtractRowPrepared (input.config.logN - input.config.folds[0]!) + input.config.rates[0]! noWrap ⟨Array.ofFn (receivedLane input lane), by simp⟩ (nodal.1,0) (PCSRewindExtraction.assembleWitness input fun lane => (decoded[lane.val]'(by simp [decoded])).1, - (decoded.map Prod.snd).toList.sum) + nodal.2 + (decoded.map Prod.snd).toList.sum) + +theorem decodeRoot_value (input : Public) + (noWrap : input.config.logN - input.config.folds[0]! + input.config.rates[0]! ≤ 64) : + (decodeRoot input noWrap).1 = + PCSRewindExtraction.assembleWitness input (fun lane => + (ConcreteRowExtraction.countedExtractRow + (input.config.logN - input.config.folds[0]!) input.config.rates[0]! noWrap + ⟨Array.ofFn (receivedLane input lane),by simp⟩).1) := by + by_cases empty : input.lanes = 0 + · simp only [decodeRoot,empty,↓reduceIte] + apply congrArg (PCSRewindExtraction.assembleWitness input) + funext lane + have := lane.isLt + omega + · simp only [decodeRoot,empty,↓reduceIte,Array.getElem_ofFn] + apply congrArg (PCSRewindExtraction.assembleWitness input) + funext lane + exact ConcreteRowExtraction.countedExtractRow_shared_value _ _ noWrap _ + +#print axioms decodeRoot_value def matchingRows (input : Public) (w : Witness input.config input.lanes) : Finset (Fin (blockLength input.config)) := @@ -61,14 +85,29 @@ theorem decodeRoot_cost (input : Public) (redundancy : width input.config < blockLength input.config) : (decodeRoot input noWrap).2 ≤ input.lanes * ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) := by - simp only [decodeRoot, Array.toList_map, Array.toList_ofFn, List.map_ofFn, List.sum_ofFn] - calc - _ ≤ ∑ _lane : Fin input.lanes, - ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) := by - apply Finset.sum_le_sum - intro lane _ - exact ConcreteRowExtraction.countedExtractRow_polynomial_cost _ _ noWrap redundancy _ - _ = _ := by simp + by_cases empty : input.lanes = 0 + · simp [decodeRoot,empty] + · simp only [decodeRoot,empty,↓reduceIte,Array.toList_map, + Array.toList_ofFn,List.map_ofFn,List.sum_ofFn] + have positive : 0 < input.lanes := by omega + calc + _ ≤ ∑ lane : Fin input.lanes, + (ConcreteRowExtraction.countedExtractRow + (input.config.logN-input.config.folds[0]!) input.config.rates[0]! noWrap + ⟨Array.ofFn (receivedLane input lane),by simp⟩).2 := by + simp_rw [ConcreteRowExtraction.countedExtractRow_shared_cost] + rw [Finset.sum_add_distrib] + simp only [Finset.sum_const,Finset.card_univ,Fintype.card_fin,nsmul_eq_mul] + simpa only [Function.comp_apply,Nat.cast_id] using + Nat.add_le_add_right (Nat.le_mul_of_pos_left _ positive) _ + _ ≤ ∑ _lane : Fin input.lanes, + ConcreteRowExtraction.rowArithmeticPolynomial (blockLength input.config) := by + apply Finset.sum_le_sum + intro lane _ + exact ConcreteRowExtraction.countedExtractRow_polynomial_cost _ _ noWrap redundancy _ + _ = _ := by simp + +#print axioms decodeRoot_cost def runForConfig {m : Nat} (c : Config) (noWrap : c.logN - c.folds[0]! + c.rates[0]! ≤ 64) (lanes : Nat) diff --git a/verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean b/verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean index e8446b9e8..979d90d17 100644 --- a/verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean +++ b/verification/whir/Whir/PCSRoundByRoundSourceDecoderCorrectness.lean @@ -75,9 +75,9 @@ attribute [local irreducible] ParameterBounds.config ((PCSRewindExtraction.witnessLane input w lane).map E.ofK))[i.val]!) ≤ blockLength input.config - width input.config) : (decodeRoot input noWrap).1 = some w := by + rw [decodeRoot_value] apply PCSRewindExtraction.assembleWitness_recovers intro lane - simp only [Array.getElem_ofFn] exact (ConcreteRowExtraction.countedExtractRow_recovers _ _ noWrap redundancy (PCSRewindExtraction.witnessLane input w lane) (by simp [PCSRewindExtraction.witnessLane]) _ (radius lane)).1 diff --git a/verification/whir/Whir/PCSStateRestorationCost.lean b/verification/whir/Whir/PCSStateRestorationCost.lean new file mode 100644 index 000000000..6c1dae45a --- /dev/null +++ b/verification/whir/Whir/PCSStateRestorationCost.lean @@ -0,0 +1,61 @@ +import Whir.PCSStateRestorationAdaptive + +/-! Actual query counts and persistent metadata of the finite restoration game. -/ +namespace Whir.PCSStateRestoration.Adaptive +open TypedOracleCompiler TypedFiatShamirGame + +set_option autoImplicit false + +universe u v w +variable {Key : Type u} {Answer : Key → Type v} {Public : Type w} [DecidableEq Key] + +/-- First-registration metadata survives the complete execution, even if retries +and restoration decisions depend on every answer in the completed public view. -/ +theorem registry_execution_preserves (policy : Policy Key Answer Public) (n cursor : Nat) + (view : View Key Answer Public) (wanted : Key) (publicData : Public) + (registered : view.registry wanted = some publicData) (table : (key : Key) → Answer key) : + (Sampling.eval table (program policy n cursor view)).registry wanted = some publicData := by + induction n generalizing cursor view with + | zero => exact registered + | succ n ih => + cases chosen : policy.choose cursor view.history with + | none => + simp only [program,chosen,Sampling.eval_pad] + exact ih _ _ registered + | some key => + simp only [program,chosen,Sampling.eval] + exact ih _ _ (registry_never_overwrites policy cursor view key wanted _ publicData registered) + +@[simp] theorem phases_adversary (Q : Nat) (adversary verifier : Policy Key Answer Public) + (cursor : Nat) (history : History Key Answer Public) (before : cursor < Q) : + (phases Q adversary verifier).choose cursor history = adversary.choose cursor history := by + simp [phases,before] + +@[simp] theorem phases_verifier (Q : Nat) (adversary verifier : Policy Key Answer Public) + (cursor : Nat) (history : History Key Answer Public) : + (phases Q adversary verifier).choose (Q+cursor) history = verifier.choose cursor history := by + simp [phases] + +/-- Total requests include repeated and abandoned requests and final verification. +Their deterministic operation bound is Q+k, not the number of fresh samples. -/ +theorem requests_le {Q k : Nat} (adversary verifier : Policy Key Answer Public) + (view : View Key Answer Public) (trace : List (Sigma Answer)) (result : View Key Answer Public) + (run : Sampling.Runs (program (phases Q adversary verifier) (Q+k) 0 view) trace result) : + trace.length ≤ Q+k := run.length_le + +/-- In contrast, the memo-interpreter trace counts distinct fresh exposures only. +Fixed-prefix cache entries and repeated challenges allocate no additional draw. -/ +theorem fresh_exposure_accounting {Q k : Nat} (adversary verifier : Policy Key Answer Public) + (view : View Key Answer Public) (cache : Cache Key Answer) (trace : List (Sigma Answer)) + (result : View Key Answer Public × Cache Key Answer) + (run : Sampling.Runs + (RawOracleCoupling.memo (program (phases Q adversary verifier) (Q+k) 0 view) cache) + trace result) : + trace.length ≤ Q+k ∧ (trace.map Sigma.fst).Nodup ∧ + ∀ entry ∈ trace, cache entry.1 = none := by + obtain ⟨fresh,distinct⟩ := PCSStateRestoration.memo_runs_distinct _ cache trace result run + exact ⟨run.length_le,distinct,fresh⟩ + +#print axioms registry_execution_preserves +#print axioms fresh_exposure_accounting +end Whir.PCSStateRestoration.Adaptive diff --git a/verification/whir/Whir/PCSStateRestorationLatentExample.lean b/verification/whir/Whir/PCSStateRestorationLatentExample.lean new file mode 100644 index 000000000..8995cb2e9 --- /dev/null +++ b/verification/whir/Whir/PCSStateRestorationLatentExample.lean @@ -0,0 +1,113 @@ +import Whir.PCSStateRestorationLatent + +/-! Kernel-sized actual adaptive ROM example. The adversary queries the child +before its parent; final verification queries the parent and repeats the child. +The child's literal before-state depends on the undisclosed parent answer. -/ +namespace Whir.PCSStateRestoration.Latent.Example +open TypedOracleCompiler TypedFiatShamirGame + +set_option autoImplicit false + +abbrev Answer (_ : Bool) := Bool + +/-- false is the parent key; true is the child key. -/ +def model : NodeModel Bool Answer Bool where + reconstruct key rest := match key with + | false => false + | true => rest ⟨false,by decide⟩ + before publicData key := key && publicData + after publicData key answer := if key then publicData || answer else answer + +def adversary : Sampling Bool Answer Bool 1 := + .draw true (fun child => .ret child) + +def verifier (_ : Bool) : Sampling Bool Answer (Bool × Bool) 2 := + .draw false (fun parent => .draw true (fun child => .ret (parent,child))) + +def source : Sampling Bool Answer (Bool × Bool) 3 := Sampling.bind adversary verifier + +def table : Table Bool Answer := fun key => key + +theorem actual_request_trace : + (Sampling.execute table source).2 = [⟨true,true⟩,⟨false,false⟩,⟨true,true⟩] := by rfl + +theorem actual_result : (Sampling.execute table source).1 = (false,true) := by rfl + +theorem actual_memo_trace : + (Sampling.execute table (RawOracleCoupling.memo source (fun _ => none))).2 = + [⟨true,true⟩,⟨false,false⟩] := by rfl + +theorem actual_memo_result : + (Sampling.execute table (RawOracleCoupling.memo source (fun _ => none))).1.1 = (false,true) := by rfl + +/-- Both executions expose the child first with identical empty preceding view, +but its latent public state differs because the parent's answer differs. -/ +theorem capture_is_genuinely_latent : + firstDisclosure true source (fun _ => false) = some [] ∧ + firstDisclosure true source (fun key => !key) = some [] ∧ + publicNode model true (fun _ => false) = false ∧ + publicNode model true (fun key => !key) = true := by decide + +private theorem bool_true_probability : + Soundness.uniformProb (Finset.univ.filter fun answer : Bool => answer = true) = (1 : ℚ)/2 := by + have filtered : (Finset.univ.filter fun answer : Bool => answer = true) = {true} := by + ext answer + cases answer <;> simp + rw [Soundness.uniformProb,filtered] + norm_num + +theorem conditional_hazard : ConditionalHazard model ((1 : ℚ)/2) := by + intro key rest safe + cases key with + | false => simpa [model] using le_of_eq bool_true_probability + | true => + have parentZero : rest ⟨false,by decide⟩ = false := by simpa [model] using safe + simpa [model,parentZero] using le_of_eq bool_true_probability + +def Failure (oracle : Table Bool Answer) : Prop := oracle false || oracle true = true + +instance : DecidablePred Failure := by + intro oracle + unfold Failure + infer_instance + +/-- The literal final path is parent then child although the query order is +child, parent, child. Its repeated child is the same globally memoized answer. -/ +theorem accepted_path (oracle : Table Bool Answer) (failed : Failure oracle) : + StatePath model oracle (Sampling.execute oracle source).2 false true := by + have requestTrace : (Sampling.execute oracle source).2 = + [⟨true,oracle true⟩,⟨false,oracle false⟩,⟨true,oracle true⟩] := by rfl + rw [requestTrace] + have finalState : after model true oracle = true := by simpa [after,publicNode,model,erase,Failure] using failed + have childPath : StatePath model oracle + [⟨true,oracle true⟩,⟨false,oracle false⟩,⟨true,oracle true⟩] (before model true oracle) true := by + apply StatePath.step true (by simp) + rw [finalState] + exact StatePath.nil true + exact StatePath.step false (by simp) childPath + +/-- The generic latent theorem applies to this unrestricted child-before-parent +program. The expression is its query bound, not a claimed security level. -/ +theorem probability_bound : Soundness.uniformProb (Finset.univ.filter Failure) ≤ + (1 : ℚ)*(1/2) + (2 : ℚ)*(1/2) := by + have bound := adversary_verifier_failure_probability model 1 2 adversary verifier (1/2) + (by positivity) conditional_hazard Failure accepted_path + have sameFilter : + @Finset.filter (Table Bool Answer) Failure (fun oracle => Classical.propDecidable (Failure oracle)) Finset.univ = + Finset.univ.filter Failure := by + ext oracle + simp + rw [sameFilter] at bound + simpa using bound + +#eval (Sampling.execute table source).1 +#eval (Sampling.execute table source).2.map (fun entry => (entry.1,entry.2)) +#eval (Sampling.execute table (RawOracleCoupling.memo source (fun _ => none))).2.map + (fun entry => (entry.1,entry.2)) + +#print axioms actual_memo_trace +#print axioms capture_is_genuinely_latent +#print axioms conditional_hazard +#print axioms accepted_path +#print axioms probability_bound +end Whir.PCSStateRestoration.Latent.Example diff --git a/verification/whir/Whir/PCSStateRestorationPath.lean b/verification/whir/Whir/PCSStateRestorationPath.lean new file mode 100644 index 000000000..baf2014b6 --- /dev/null +++ b/verification/whir/Whir/PCSStateRestorationPath.lean @@ -0,0 +1,103 @@ +import Whir.PCSStateRestorationCost + +/-! Accepted-path restoration does not restrict arbitrary adversarial prequeries. +A final verifier path is ordered by source rounds, not by RO query time. Its +literal predecessor/after states must link, and each challenge node must be a +recorded first-capture certificate (including memoized repetitions). -/ +namespace Whir.PCSStateRestoration.Adaptive +open TypedOracleCompiler TypedFiatShamirGame +open FiatShamirGame (average average_mono) + +set_option autoImplicit false +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +universe u v w +variable {Key : Type u} {Answer : Key → Type v} {Public : Type w} + +/-- A finite source-round path through actually exposed certificate nodes. +Adjacency is literal equality of the previous after-state and next before-state. +The path need not follow query chronology: grinding can expose a child first. -/ +inductive StatePath (cert : Certificate Key Answer Public) (history : History Key Answer Public) : + Bool → Bool → Prop where + | nil (state : Bool) : StatePath cert history state state + | step (entry : Entry Key Answer Public) {final : Bool} (recorded : entry ∈ history) + (rest : StatePath cert history (cert.after entry.1 entry.2.1 entry.2.2) final) : + StatePath cert history (cert.before entry.1 entry.2.1) final + +/-- A path starting in state zero and ending in state one necessarily contains +an actual zero-to-one transition, even with nonmonotone state restorations. -/ +theorem path_has_transition (cert : Certificate Key Answer Public) (history : History Key Answer Public) + (start finish : Bool) : StatePath cert history start finish → start = false → finish = true → Dirty cert history := by + intro path + induction path with + | nil state => + intro initialState finalState + have impossible : false = true := initialState.symm.trans finalState + cases impossible + | step entry member rest ih => + intro initialState finalState + cases returned : cert.after entry.1 entry.2.1 entry.2.2 with + | false => exact ih returned finalState + | true => exact ⟨entry,member,initialState,returned⟩ + +section Probability +variable [DecidableEq Key] [Fintype Key] +variable [∀ key, Fintype (Answer key)] [∀ key, Nonempty (Answer key)] + +/-- Accepted-path version of the fixed-prefix theorem. Unlike global `Causal`, +it allows every arbitrary adversarial key and hypothetical prefix; only the +successful final source-round path must connect initial zero to final one. +The local hazard and first-capture memo invariant, not a final bad probability, +derive the union bound. -/ +theorem path_failure_probability (cert : Certificate Key Answer Public) (policy : Policy Key Answer Public) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard cert epsilon) + (n cursor : Nat) (view : View Key Answer Public) (cache : Cache Key Answer) + (recorded : Recorded view cache) (clean : ¬ Dirty cert view.history) + (failure : View Key Answer Public → Prop) + (acceptedPath : ∀ table : (key : Key) → Answer key, + failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)) → + StatePath cert (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)).history false true) : + Soundness.uniformProb (Finset.univ.filter fun table : (key : Key) → Answer key => + failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view))) ≤ + (n : ℚ)*epsilon := by + classical + have bound := memo_transition_bound cert policy epsilon nonnegative hazard n cursor view cache recorded clean + have coupling := RawOracleCoupling.table_eq_memo (program policy n cursor view) cache + (fun view => if Dirty cert view.history then (1 : ℚ) else 0) + have tableBound := coupling.trans_le bound + have covered : average (fun table : (key : Key) → Answer key => + if failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)) + then (1 : ℚ) else 0) ≤ (n : ℚ)*epsilon := by + apply le_trans _ tableBound + apply average_mono + intro table + by_cases bad : failure (Sampling.eval (RawOracleCoupling.overlay cache table) (program policy n cursor view)) + · have transition := path_has_transition cert _ false true (acceptedPath table bad) rfl rfl + simp [bad,transition] + · simp only [bad,↓reduceIte]; split <;> norm_num + simpa only [average,Soundness.uniformProb,Finset.card_filter,Nat.cast_sum, + Nat.cast_ite,Nat.cast_one,Nat.cast_zero] using covered + +/-- Main finite adaptive query theorem: Q adversarial hash-chain requests and +at most k final-verifier requests share one persistent memo cache and registry. +The only source-specific obligations are the conditional fresh-message hazard +and the literal accepted extraction-failure path from state zero to state one. -/ +theorem accepted_path_failure_probability (cert : Certificate Key Answer Public) + (adversary verifier : Policy Key Answer Public) (Q k : Nat) + (epsilon : ℚ) (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard cert epsilon) + (failure : View Key Answer Public → Prop) + (acceptedPath : ∀ table : (key : Key) → Answer key, + failure (Sampling.eval table (program (phases Q adversary verifier) (Q+k) 0 initial)) → + StatePath cert (Sampling.eval table (program (phases Q adversary verifier) (Q+k) 0 initial)).history false true) : + Soundness.uniformProb (Finset.univ.filter fun table : (key : Key) → Answer key => + failure (Sampling.eval table (program (phases Q adversary verifier) (Q+k) 0 initial))) ≤ + ((Q+k : Nat) : ℚ)*epsilon := by + exact path_failure_probability cert (phases Q adversary verifier) epsilon nonnegative hazard (Q+k) 0 initial + (fun _ => none) (by intro key answer hit; cases hit) (by simp [initial,Dirty]) failure acceptedPath + +end Probability + +#print axioms path_has_transition +#print axioms path_failure_probability +#print axioms accepted_path_failure_probability +end Whir.PCSStateRestoration.Adaptive diff --git a/verification/whir/Whir/PublicCompressionCouplingLateLinks.lean b/verification/whir/Whir/PublicCompressionCouplingLateLinks.lean new file mode 100644 index 000000000..90a9fc53f --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingLateLinks.lean @@ -0,0 +1,78 @@ +import Whir.PublicCompressionCoupling + +/-! Actual finite probability of a later fresh compression answer filling an +already queried CV position. This includes the backward-recognition mechanism. +It does not bound forward guesses of unrevealed construction chaining values +and must not be presented as the complete simulator distinguishing loss. -/ +namespace Whir.PublicCompressionCoupling +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram TypedOracleCompiler +attribute [local instance] PublicMerkleLog.instDecidableEqNode + +noncomputable def lateLinkAlarm {R : Type} (C : PrimitiveOracle) {Q : Nat} : + Computation R Q → Log → Bool + | .ret _, _ => false + | .draw input next, log => + decide (PublicMerkleLog.lookup log input = none ∧ + C input ∈ PublicMerkleProbability.cvTargets log) || + lateLinkAlarm C (next (C input)) ((input,C input)::log) + +theorem lateLinkAlarm_implies_table_alarm {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) (log : Log) (hit : lateLinkAlarm C p log = true) : + PublicMerkleProbability.alarm (fun _ => ∅) C p log = true := by + induction p generalizing log with + | ret => simp [lateLinkAlarm] at hit + | draw input next ih => + rcases Bool.or_eq_true_iff.mp hit with first | later + · have event := of_decide_eq_true first + have targets : C input ∈ PublicMerkleProbability.badTargets (fun _ => ∅) log := by + simp only [PublicMerkleProbability.badTargets,PublicMerkleProbability.targets] + exact Finset.mem_union.mpr (Or.inr (Finset.mem_union.mpr (Or.inr event.2))) + apply Bool.or_eq_true_iff.mpr + exact Or.inl (decide_eq_true ⟨event.1,targets⟩) + · apply Bool.or_eq_true_iff.mpr + exact Or.inr (ih (C input) ((input,C input)::log) later) + +theorem actual_lateLink_probability {R : Type} {Q : Nat} (p : Computation R Q) : + average (fun C : PrimitiveOracle => if lateLinkAlarm C p [] then (1:ℚ) else 0) ≤ + PublicMerkleProbability.bound Q 0 := by + have tableBound := PublicMerkleProbability.random_compression_bound + (fun _ => ∅) Q 0 (by intro log budget; simp) p + apply le_trans _ tableBound + apply average_mono + intro C + cases hit : lateLinkAlarm C p [] with + | false => + split + · rename_i impossible; cases impossible + · split <;> norm_num + | true => + simp only [lateLinkAlarm_implies_table_alarm C p [] hit,↓reduceIte] + norm_num + +set_option backward.isDefEq.respectTransparency false in +/-- All adaptive Program continuations and all uncached construction internals +are charged. The explicit factor four is conservative and actually derived. -/ +theorem actual_mode_lateLink_probability {R : Type} (iv : Digest32) (program : Program R) + (Q : Nat) (counted : Counts Q program) : + average (fun C : PrimitiveOracle => + if lateLinkAlarm C (compile iv program Q counted) [] then (1:ℚ) else 0) ≤ + min 1 (4*(Q.choose 2 : ℚ)/2^256) := by + apply le_min + · calc + _ ≤ average (fun _ : PrimitiveOracle => (1:ℚ)) := by + apply average_mono + intro C + split <;> norm_num + _ = 1 := average_const _ + · have h := actual_lateLink_probability (compile iv program Q counted) + have ledger : PublicMerkleProbability.bound Q 0 = 4*(Q.choose 2 : ℚ)/2^256 := by + rw [Nat.cast_choose_two] + unfold PublicMerkleProbability.bound + push_cast + ring + simpa only [ledger] using h + +#print axioms lateLinkAlarm_implies_table_alarm +#print axioms actual_mode_lateLink_probability +end Whir.PublicCompressionCoupling diff --git a/verification/whir/Whir/PublicCompressionCouplingLog.lean b/verification/whir/Whir/PublicCompressionCouplingLog.lean new file mode 100644 index 000000000..16046a4ff --- /dev/null +++ b/verification/whir/Whir/PublicCompressionCouplingLog.lean @@ -0,0 +1,115 @@ +import Whir.PublicCompressionCoupling + +/-! The birthday monitor's event is connected to the actual simulator's +output-collision predicate, for the complete finite compression trace. Hidden +construction calls are retained in this proof log, not in the public View. +This still does not charge missed recognition or construct the DMV coupling. -/ +namespace Whir.PublicCompressionCoupling +open FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open PublicCompressionProgram TypedOracleCompiler +attribute [local instance] PublicMerkleLog.instDecidableEqNode + +noncomputable def completedLog {R : Type} (C : PrimitiveOracle) {Q : Nat} : + Computation R Q → Log → Log + | .ret _, log => log + | .draw input next, log => completedLog C (next (C input)) ((input,C input)::log) + +theorem completedLog_length {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) (log : Log) : (completedLog C p log).length ≤ Q+log.length := by + induction p generalizing log with + | ret => simp [completedLog] + | @draw n input next ih => + have ht := ih (C input) ((input,C input)::log) + simp only [completedLog,List.length_cons] at * + omega + +theorem completedLog_authentic {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) (log : Log) (auth : PublicMerkleLog.AuthenticLog C log) : + PublicMerkleLog.AuthenticLog C (completedLog C p log) := by + induction p generalizing log with + | ret => exact auth + | draw input next ih => + apply ih (C input) ((input,C input)::log) + intro n d member + rcases List.mem_cons.mp member with member | member + · cases member; rfl + · exact auth n d member + +theorem clean_observe (C : PrimitiveOracle) (log : Log) + (auth : PublicMerkleLog.AuthenticLog C log) + (clean : ¬DuplexPublicSimulator.OutputCollision log) (input : Node) + (noFreshCollision : ¬(PublicMerkleLog.lookup log input = none ∧ C input ∈ outputs log)) : + ¬DuplexPublicSimulator.OutputCollision ((input,C input)::log) := by + have same : ∀ n, (n,C input) ∈ log → n = input := by + intro n member + cases hit : PublicMerkleLog.lookup log input with + | none => + exfalso + apply noFreshCollision ⟨hit,?_⟩ + exact List.mem_toFinset.mpr (List.mem_map.mpr ⟨(n,C input),member,rfl⟩) + | some d => + have hi := PublicMerkleLog.lookup_mem hit + have hd := auth input d hi + have hi' : (input,C input) ∈ log := by simpa only [hd] using hi + by_contra different + exact clean ⟨n,input,C input,member,hi',different⟩ + rintro ⟨a,b,d,ha,hb,different⟩ + rcases List.mem_cons.mp ha with ha | ha + · cases ha + rcases List.mem_cons.mp hb with hb | hb + · cases hb; exact different rfl + · exact different (same b hb).symm + · rcases List.mem_cons.mp hb with hb | hb + · cases hb; exact different (same a ha) + · exact clean ⟨a,b,d,ha,hb,different⟩ + +theorem collisionAlarm_false_clean {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) (log : Log) (auth : PublicMerkleLog.AuthenticLog C log) + (clean : ¬DuplexPublicSimulator.OutputCollision log) + (noAlarm : collisionAlarm C p log = false) : + ¬DuplexPublicSimulator.OutputCollision (completedLog C p log) := by + induction p generalizing log with + | ret => exact clean + | draw input next ih => + have alarms := Bool.or_eq_false_iff.mp noAlarm + have fresh := of_decide_eq_false alarms.1 + apply ih (C input) ((input,C input)::log) + · intro n d member + rcases List.mem_cons.mp member with member | member + · cases member; rfl + · exact auth n d member + · exact clean_observe C log auth clean input fresh + · exact alarms.2 + +theorem completedLog_collision_alarm {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) (collision : DuplexPublicSimulator.OutputCollision (completedLog C p [])) : + collisionAlarm C p [] = true := by + cases h : collisionAlarm C p [] with + | true => rfl + | false => + exact False.elim ((collisionAlarm_false_clean C p [] + (by intro n d member; simp at member) + (by simp [DuplexPublicSimulator.OutputCollision]) h) collision) + +open Classical in +/-- Exactly the collision predicate appearing in radicalExtend's recognition +lemma is covered by the sampled-table birthday bound, not assumed separately. -/ +theorem actual_completedLog_collision_bound {R : Type} (iv : Digest32) (program : Program R) + (Q : Nat) (counted : Counts Q program) : + average (fun C : PrimitiveOracle => + if DuplexPublicSimulator.OutputCollision (completedLog C (compile iv program Q counted) []) + then (1:ℚ) else 0) ≤ compressionBirthdayLoss Q := by + classical + apply le_trans _ (actual_mode_collision_bound_capped iv program Q counted) + apply average_mono + intro C + by_cases bad : DuplexPublicSimulator.OutputCollision + (completedLog C (compile iv program Q counted) []) + · simp only [bad,↓reduceIte,completedLog_collision_alarm C _ bad] + norm_num + · simp only [bad,↓reduceIte] + split <;> norm_num + +#print axioms collisionAlarm_false_clean +#print axioms actual_completedLog_collision_bound +end Whir.PublicCompressionCoupling diff --git a/verification/whir/Whir/PublicCompressionProgram.lean b/verification/whir/Whir/PublicCompressionProgram.lean index 221b56188..acbf26dd0 100644 --- a/verification/whir/Whir/PublicCompressionProgram.lean +++ b/verification/whir/Whir/PublicCompressionProgram.lean @@ -31,6 +31,28 @@ def planCalls (cv : Digest32) : (xs : List DuplexEncoding.Instruction) → Compu | [] => .ret cv | i :: rest => .draw ⟨cv,i.1,i.2,true⟩ (fun d => planCalls d rest) +private def planCallsStored (cv : Digest32) : + (xs : List DuplexEncoding.Instruction) → Computation Digest32 xs.length + | [] => .ret cv + | i :: rest => .draw ⟨cv,i.1,i.2,true⟩ (fun d => + let bytes := Array.ofFn d + planCallsStored (fun j => bytes[j.val]'(by simp [bytes])) rest) + +@[csimp] private theorem planCalls_stored : planCalls = planCallsStored := by + funext cv xs + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => + simp only [planCalls,planCallsStored] + congr 1 + funext d + have stored : (fun j : Fin 32 => + (Array.ofFn d)[j.val]'(by simp)) = d := by + funext j + simp + rw [stored] + exact ih d + theorem planCalls_eval (C : PrimitiveOracle) (cv : Digest32) (xs : List DuplexEncoding.Instruction) : Sampling.eval C (planCalls cv xs) = evalPlan (compressionOf C) cv xs := by induction xs generalizing cv with diff --git a/verification/whir/Whir/PublicMerkleLog.lean b/verification/whir/Whir/PublicMerkleLog.lean index e77c6c610..f4f0e8cba 100644 --- a/verification/whir/Whir/PublicMerkleLog.lean +++ b/verification/whir/Whir/PublicMerkleLog.lean @@ -104,6 +104,30 @@ finals also handles a final query appearing before its predecessor queries. -/ def records (log : PublicLog) : Records := log.filterMap fun (n,d) => (parse log n d).map fun bytes => (bytes,d) +private def storedRecord (record : Node × Digest32) : Node × Digest32 := + let bytes := Array.ofFn record.2 + (record.1, fun i => bytes[i.val]'(by simp [bytes])) + +private theorem storedRecord_eq (record : Node × Digest32) : + storedRecord record = record := by + apply Prod.ext + · simp only [storedRecord] + · funext i + simp [storedRecord] + +private def storedRecords (log : PublicLog) : Records := + let stored := log.map storedRecord + stored.filterMap fun (n,d) => (parse stored n d).map fun bytes => (bytes,d) + +@[csimp] private theorem records_stored : + records = storedRecords := by + funext log + have hs : log.map storedRecord = log := by + have hf : storedRecord = id := funext storedRecord_eq + rw [hf] + exact List.map_id log + simp only [storedRecords, hs, records] + def observe (log : PublicLog) (n : Node) (answer : Digest32) : PublicLog × Records := let updated := insert log n answer (updated, records updated) diff --git a/verification/whir/Whir/PublicMerkleProgram.lean b/verification/whir/Whir/PublicMerkleProgram.lean index a28085c63..11d0dc713 100644 --- a/verification/whir/Whir/PublicMerkleProgram.lean +++ b/verification/whir/Whir/PublicMerkleProgram.lean @@ -159,23 +159,40 @@ private theorem storedQuery_eq (C : PrimitiveOracle) : funext n exact withStoredDigest_eq _ _ +private def hashResultStored (C : PrimitiveOracle) (bytes : List Byte) : Option Digest32 := + PublicMerkleLog.run (storedQuery C) DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) + +private theorem hashResultStored_present (C : PrimitiveOracle) (bytes : List Byte) : + (hashResultStored C bytes).isSome := by + unfold hashResultStored + rw [storedQuery_eq] + obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) + (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 + rw [hd] + rfl + def hashStored (C : PrimitiveOracle) (bytes : List Byte) : Digest32 := - let result := PublicMerkleLog.run (storedQuery C) DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) - result.get (by - dsimp only [result] - rw [storedQuery_eq] - obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) - (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 - rw [hd] - rfl) + (hashResultStored C bytes).get (hashResultStored_present C bytes) @[csimp] theorem ordinaryHash_stored : PublicMerkleLog.hash = hashStored := by funext C bytes obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 - simp only [PublicMerkleLog.hash, hashStored, storedQuery_eq, hd] + simp only [PublicMerkleLog.hash, hashStored, hashResultStored, storedQuery_eq, hd] rfl +/-- Force the stored ordinary fold before passing its digest to a consumer. +The continuation prevents a function-valued digest from delaying that fold +until each individual byte projection in native compilation. -/ +def withHashStored {T : Type} (C : PrimitiveOracle) (bytes : List Byte) + (next : Digest32 → T) : T := + next ((hashResultStored C bytes).get (hashResultStored_present C bytes)) + +theorem withHashStored_eq {T : Type} (C : PrimitiveOracle) (bytes : List Byte) + (next : Digest32 → T) : withHashStored C bytes next = next (PublicMerkleLog.hash C bytes) := by + unfold withHashStored + exact congrArg next (congrFun (congrFun ordinaryHash_stored C) bytes).symm + def hashBlake2sStored : List Byte → Digest32 := hashStored blake2sOracle /-- Rewrite the imported wrapper as well: its previously compiled body must @@ -184,6 +201,39 @@ not retain the old unstored fold. Neither implementation calls itself. -/ PublicMerkleLog.hashBlake2s = hashBlake2sStored := by exact congrFun ordinaryHash_stored blake2sOracle +/-- Materialize each public plan reply before using it as the next input CV. +This keeps the literal record list while avoiding repeated evaluation of the +entire preceding compression chain through function-valued digests. -/ +private def planFromStored (C : PrimitiveOracle) (cv : Digest32) (count : Nat) : + List (List Byte) → PublicMerkleLog.PublicLog + | [] => [] + | [b] => + let input := PublicMerkleLog.node cv count b true + withStoredDigest (C input) (fun digest => [(input,digest)]) + | b :: next :: rest => + let input := PublicMerkleLog.node cv count b false + withStoredDigest (C input) (fun digest => + (input,digest) :: planFromStored C digest (count+b.length) (next :: rest)) + +@[csimp] theorem ordinaryPlanFrom_stored : PublicMerkleLog.planFrom = planFromStored := by + funext C cv count bs + induction bs generalizing cv count with + | nil => rfl + | cons b rest ih => + cases rest with + | nil => + simp only [PublicMerkleLog.planFrom,planFromStored,withStoredDigest_eq] + | cons next rest => + simp only [PublicMerkleLog.planFrom,planFromStored,withStoredDigest_eq,ih] + +def planStored (C : PrimitiveOracle) (bytes : List Byte) : PublicMerkleLog.PublicLog := + planFromStored C DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) + +@[csimp] theorem ordinaryPlan_stored : PublicMerkleLog.plan = planStored := by + funext C bytes + unfold PublicMerkleLog.plan planStored + rw [ordinaryPlanFrom_stored] + theorem hash_bind_real_result (C : PrimitiveOracle) (iv : Digest32) (bytes : List Byte) (next : Digest32 → Program R) : (runReal C iv (WHIRModeFinal.bind (hash bytes) next)).view.result = diff --git a/verification/whir/Whir/ReedSolomonExtraction.lean b/verification/whir/Whir/ReedSolomonExtraction.lean index 1d0205a07..b7d199a4b 100644 --- a/verification/whir/Whir/ReedSolomonExtraction.lean +++ b/verification/whir/Whir/ReedSolomonExtraction.lean @@ -180,25 +180,49 @@ theorem countedRawMul_cost_of_size (p q : CPolynomial.Raw F) (width : Nat) Nat.mul_le_mul left (Nat.add_le_add left (Nat.mul_le_mul_left 2 right)) _ = 3 * width ^ 2 := by ring -/-- Instrumented canonical multiplication returns exactly the polynomial used -by Gao and triangular extraction. Its field count is the raw convolution count. -/ +/-- Instrumented canonical multiplication puts the shorter operand on the +convolution's iterated side. This avoids repeated long shifted accumulators; +trimming makes polynomial commutativity valid even for empty raw arrays. -/ def countedMul (p q : CPolynomial F) : CPolynomial F × Nat := - let result := countedRawMul p.val q.val + let result := if p.val.size ≤ q.val.size then countedRawMul p.val q.val + else countedRawMul q.val p.val (⟨result.1.trim, CPolynomial.Raw.Trim.isCanonical_trim _⟩, result.2) omit [DecidableEq F] in theorem countedMul_value (p q : CPolynomial F) : (countedMul p q).1 = p * q := by - apply CPolynomial.ext - change (countedRawMul p.val q.val).1.trim = _ - rw [countedRawMul_value] - rfl + by_cases ordered : p.val.size ≤ q.val.size + · simp only [countedMul,ordered,↓reduceIte] + apply CPolynomial.ext + change (countedRawMul p.val q.val).1.trim = _ + rw [countedRawMul_value] + rfl + · simp only [countedMul,ordered,↓reduceIte] + apply CPolynomial.ext + change (countedRawMul q.val p.val).1.trim = _ + rw [countedRawMul_value] + change (q * p).val = (p * q).val + rw [mul_comm] + +omit [DecidableEq F] in +theorem countedMul_cost_asymmetric (p q : CPolynomial F) : + (countedMul p q).2 ≤ p.val.size * (p.val.size + 2 * q.val.size) := by + by_cases ordered : p.val.size ≤ q.val.size + · simpa only [countedMul,ordered,↓reduceIte] using countedRawMul_cost p.val q.val + · have shorter : q.val.size ≤ p.val.size := by omega + have squares := Nat.mul_self_le_mul_self shorter + simp only [countedMul,ordered,↓reduceIte] + exact (countedRawMul_cost q.val p.val).trans (by nlinarith) omit [DecidableEq F] in theorem countedMul_cost (p q : CPolynomial F) (width : Nat) (left : p.val.size ≤ width) (right : q.val.size ≤ width) : - (countedMul p q).2 ≤ 3 * width ^ 2 := - countedRawMul_cost_of_size p.val q.val width left right + (countedMul p q).2 ≤ 3 * width ^ 2 := by + calc + _ ≤ p.val.size * (p.val.size + 2 * q.val.size) := countedMul_cost_asymmetric p q + _ ≤ width * (width + 2 * width) := + Nat.mul_le_mul left (Nat.add_le_add left (Nat.mul_le_mul_left 2 right)) + _ = 3 * width ^ 2 := by ring /-- Raw power uses the same repeated-multiplication specification as the division backend, rather than pretending that constructing `X^k` is free. -/ @@ -891,8 +915,8 @@ theorem countedBasisFactor_cost (inverseCost : Nat) (node other : F) : have factorSupport : (CPolynomial.X - CPolynomial.C other).val.size ≤ 2 := (sub_support _ _).trans (max_le (Nat.le_refl 2) (c.trans (by omega))) have scalar := constant_support (node - other)⁻¹ - have product := countedRawMul_cost (CPolynomial.C (node - other)⁻¹).val - (CPolynomial.X - CPolynomial.C other).val + have product := countedMul_cost_asymmetric (CPolynomial.C (node - other)⁻¹) + (CPolynomial.X - CPolynomial.C other) have productBudget : (countedMul (CPolynomial.C (node - other)⁻¹) (CPolynomial.X - CPolynomial.C other)).2 ≤ 5 := by exact product.trans (by @@ -950,12 +974,49 @@ theorem countedBasis_cost (inverseCost n : Nat) (nodes : Fin n → F) (i : Fin n (by intro term ht; obtain ⟨j, hj, rfl⟩ := List.mem_map.mp ht; exact countedBasisFactor_cost _ _ _) exact bound.trans (Nat.mul_le_mul_right _ (by simpa using length)) +/-- Zero coefficients contribute no basis polynomial. Skip their construction +and inversions for every interpolant, while charging the coefficient test. -/ +def countedInterpolationTerm (inverseCost n : Nat) (nodes : Fin n → F) (i : Fin n) + (value : F) : CPolynomial F × Nat := + if value == 0 then (0,1) else + let basis := countedBasis inverseCost n nodes i + let term := countedMul (CPolynomial.C value) basis.1 + (term.1,basis.2+term.2+1) + +omit [DecidableEq F] in +theorem countedInterpolationTerm_value (inverseCost n : Nat) (nodes : Fin n → F) + (i : Fin n) (value : F) : + (countedInterpolationTerm inverseCost n nodes i value).1 = + CPolynomial.C value * (countedBasis inverseCost n nodes i).1 := by + by_cases zero : value = 0 + · subst value + simp [countedInterpolationTerm] + · simp [countedInterpolationTerm,zero,countedMul_value] + +omit [DecidableEq F] in +theorem countedInterpolationTerm_support (inverseCost n : Nat) (nodes : Fin n → F) + (i : Fin n) (value : F) : + (countedInterpolationTerm inverseCost n nodes i value).1.val.size ≤ 2*n+1 := by + rw [countedInterpolationTerm_value] + exact (constant_mul_support _ _).trans (countedBasis_support _ _ _ _) + +omit [DecidableEq F] in +theorem countedInterpolationTerm_cost (inverseCost n : Nat) (nodes : Fin n → F) + (i : Fin n) (value : F) : + (countedInterpolationTerm inverseCost n nodes i value).2 ≤ + n*(inverseCost+9+3*(2*n+1)^2)+3*(2*n+1)^2+1 := by + unfold countedInterpolationTerm + split + · simp + · exact Nat.add_le_add_right + (Nat.add_le_add (countedBasis_cost _ _ _ _) + (countedMul_cost _ _ _ ((constant_support _).trans (by omega)) + (countedBasis_support _ _ _ _))) 1 + def countedInterpolant (inverseCost : Nat) (D : Domain (F := F)) (received : Vector F D.n) : CPolynomial F × Nat := countedSum ((List.finRange D.n).map fun i => - let basis := countedBasis inverseCost D.n (D.val[·]) i - let term := countedMul (CPolynomial.C (received.get i)) basis.1 - (term.1, basis.2 + term.2)) + countedInterpolationTerm inverseCost D.n (D.val[·]) i (received.get i)) omit [DecidableEq F] in theorem countedInterpolant_value (inverseCost : Nat) (D : Domain (F := F)) @@ -965,17 +1026,17 @@ theorem countedInterpolant_value (inverseCost : Nat) (D : Domain (F := F)) apply CPolynomial.toPolyLinearEquiv.injective rw [CPolynomial.toPolyLinearEquiv_apply, CPolynomial.toPolyLinearEquiv_apply, countedInterpolant, countedSum_value] - simp only [List.map_map, countedMul_value, countedBasis_value] + simp only [List.map_map] rw [← List.sum_toFinset _ (List.nodup_finRange _)] simp only [List.toFinset_finRange] rw [CompPoly.ReedSolomon.Gao.receivedInterpolant, CPolynomial.CLagrange.cinterpolate_eq_interpolate, Lagrange.interpolate] - simp [CPolynomial.toPoly_sum, CPolynomial.toPoly_mul, CPolynomial.C_toPoly, - CPolynomial.CLagrange.cbasis_eq_basis] + simp [countedInterpolationTerm_value,countedBasis_value,CPolynomial.toPoly_sum, + CPolynomial.toPoly_mul,CPolynomial.C_toPoly,CPolynomial.CLagrange.cbasis_eq_basis] def interpolationBudget (inverseCost n : Nat) : Nat := n * (n * (inverseCost + 9 + 3 * (2 * n + 1) ^ 2) + - 3 * (2 * n + 1) ^ 2 + (2 * n + 1)) + 3 * (2 * n + 1) ^ 2 + 1 + (2 * n + 1)) omit [DecidableEq F] in theorem countedInterpolant_support (inverseCost : Nat) (D : Domain (F := F)) @@ -984,8 +1045,7 @@ theorem countedInterpolant_support (inverseCost : Nat) (D : Domain (F := F)) apply countedSum_support intro term ht obtain ⟨i, hi, rfl⟩ := List.mem_map.mp ht - rw [countedMul_value] - exact (constant_mul_support _ _).trans (countedBasis_support _ _ _ _) + exact countedInterpolationTerm_support _ _ _ _ _ omit [DecidableEq F] in theorem countedInterpolant_cost (inverseCost : Nat) (D : Domain (F := F)) @@ -994,22 +1054,17 @@ theorem countedInterpolant_cost (inverseCost : Nat) (D : Domain (F := F)) unfold countedInterpolant interpolationBudget have bound := countedSum_cost ((List.finRange D.n).map fun i => - let basis := countedBasis inverseCost D.n (D.val[·]) i - let term := countedMul (CPolynomial.C (received.get i)) basis.1 - (term.1, basis.2 + term.2)) + countedInterpolationTerm inverseCost D.n (D.val[·]) i (received.get i)) (2 * D.n + 1) - (D.n * (inverseCost + 9 + 3 * (2 * D.n + 1) ^ 2) + 3 * (2 * D.n + 1) ^ 2) + (D.n * (inverseCost + 9 + 3 * (2 * D.n + 1) ^ 2) + 3 * (2 * D.n + 1) ^ 2 + 1) (by intro term ht obtain ⟨i, hi, rfl⟩ := List.mem_map.mp ht - rw [countedMul_value] - exact (constant_mul_support _ _).trans (countedBasis_support _ _ _ _)) + exact countedInterpolationTerm_support _ _ _ _ _) (by intro term ht obtain ⟨i, hi, rfl⟩ := List.mem_map.mp ht - exact Nat.add_le_add (countedBasis_cost _ _ _ _) - (countedMul_cost _ _ _ ((constant_support _).trans (by omega)) - (countedBasis_support _ _ _ _))) + exact countedInterpolationTerm_cost _ _ _ _ _) simpa only [List.length_map, List.length_finRange] using bound def countedNodal (D : Domain (F := F)) : CPolynomial F × Nat := @@ -1108,12 +1163,11 @@ theorem xgcdStepBudget_mono (inverseCost : Nat) {a b : Nat} (bound : a ≤ b) : unfold xgcdStepBudget gcongr -/-- Complete coefficient-arithmetic instrumentation of Gao: nodal product, -Lagrange interpolation, partial xgcd and both final remainder/division calls. -The public-domain array construction itself uses no field arithmetic. -/ -def countedDecode (inverseCost k : Nat) (D : Domain (F := F)) (received : Vector F D.n) : +/-- Reuse an already materialized public-domain nodal product. Its cost field +charges construction at the owner, not again at each independent row. -/ +def countedDecodePrepared (inverseCost k : Nat) (D : Domain (F := F)) + (received : Vector F D.n) (nodal : CPolynomial F × Nat) : Option (CPolynomial F) × Nat := - let nodal := countedNodal D let interpolant := countedInterpolant inverseCost D received let gcd := countedXgcd inverseCost ((D.n + k + 1) / 2) nodal.1 interpolant.1 let remainder := countedMod inverseCost gcd.1.1 gcd.1.2.2 @@ -1123,11 +1177,39 @@ def countedDecode (inverseCost k : Nat) (D : Domain (F := F)) (received : Vector (if quotient.1.degree < k then some quotient.1 else none, cost + quotient.2) else (none, cost) +omit [DecidableEq F] in +theorem countedDecodePrepared_value_cost_independent (inverseCost k : Nat) + (D : Domain (F := F)) (received : Vector F D.n) (nodal : CPolynomial F) (cost : Nat) : + (countedDecodePrepared inverseCost k D received (nodal,cost)).1 = + (countedDecodePrepared inverseCost k D received (nodal,0)).1 := by + unfold countedDecodePrepared + dsimp only + split_ifs <;> rfl + +omit [DecidableEq F] in +theorem countedDecodePrepared_cost (inverseCost k : Nat) (D : Domain (F := F)) + (received : Vector F D.n) (nodal : CPolynomial F) (cost : Nat) : + (countedDecodePrepared inverseCost k D received (nodal,cost)).2 = + cost + (countedDecodePrepared inverseCost k D received (nodal,0)).2 := by + unfold countedDecodePrepared + dsimp only + split_ifs <;> simp [Nat.add_assoc] + +#print axioms countedDecodePrepared_value_cost_independent +#print axioms countedDecodePrepared_cost + +/-- Complete coefficient-arithmetic instrumentation of Gao: nodal product, +Lagrange interpolation, partial xgcd and both final remainder/division calls. +The public-domain array construction itself uses no field arithmetic. -/ +def countedDecode (inverseCost k : Nat) (D : Domain (F := F)) (received : Vector F D.n) : + Option (CPolynomial F) × Nat := + countedDecodePrepared inverseCost k D received (countedNodal D) + omit [DecidableEq F] in theorem countedDecode_value (inverseCost k : Nat) (D : Domain (F := F)) (received : Vector F D.n) : (countedDecode inverseCost k D received).1 = decode k D received := by - simp only [countedDecode, countedNodal_value, countedInterpolant_value, countedXgcd_value, + simp only [countedDecode, countedDecodePrepared, countedNodal_value, countedInterpolant_value, countedXgcd_value, countedMod_value, countedDiv_value, decode, CompPoly.ReedSolomon.Gao.decode, CompPoly.ReedSolomon.Gao.partialGcd] split_ifs <;> simp_all @@ -1172,7 +1254,7 @@ theorem countedDecode_cost (inverseCost k : Nat) (D : Domain (F := F)) gcd.1.1 gcd.1.2.2 rSupport tSupport have nodalCost := countedNodal_cost D have interpolantCost := countedInterpolant_cost inverseCost D received - unfold countedDecode + unfold countedDecode countedDecodePrepared change (if (countedMod inverseCost gcd.1.1 gcd.1.2.2).1 == 0 then (if (countedDiv inverseCost gcd.1.1 gcd.1.2.2).1.degree < k then some (countedDiv inverseCost gcd.1.1 gcd.1.2.2).1 else none, @@ -1188,4 +1270,12 @@ theorem countedDecode_cost (inverseCost k : Nat) (D : Domain (F := F)) dsimp only [residueWidth] at gcdBudget omega +#print axioms countedInterpolationTerm_value +#print axioms countedInterpolationTerm_support +#print axioms countedInterpolationTerm_cost +#print axioms countedInterpolant_value +#print axioms countedInterpolant_cost +#print axioms countedDecode_value +#print axioms countedDecode_cost + end Whir.ReedSolomonExtraction diff --git a/verification/whir/Whir/ShoupTraceExtraction.lean b/verification/whir/Whir/ShoupTraceExtraction.lean new file mode 100644 index 000000000..1868156cf --- /dev/null +++ b/verification/whir/Whir/ShoupTraceExtraction.lean @@ -0,0 +1,117 @@ +import Whir.TraceBasisExtraction +import Whir.FrobeniusExtraction +import CompPoly.Univariate.Roots.Shoup.Correctness +import CompPoly.Bivariate.GuruswamiSudan.Root.FieldRoots.FiniteField + +/-! Source-extension root extraction without field enumeration. Scalar Frobenius powers are obtained from the bounded squaring ladder, not the canonical scalar natural-power recursion. The executable wrapper is proved equal to the certified Shoup algorithm; the global source field dictionaries are unchanged. These are root-backend correctness results, not a full PCS knowledge theorem or a full coefficient-operation bound. -/ +namespace Whir.ShoupTraceExtraction +open Concrete CompPoly CompPoly.CPolynomial.Roots.FiniteField TraceExtraction TraceBasisExtraction +set_option maxRecDepth 8192 +local instance : Field E := ExtractionField.field + +abbrev MulBackend := CPolynomial.Raw.MulContext E +abbrev ModBackend := CPolynomial.Raw.ModContext E + +/-- Scalar Frobenius powers are shared: 191 squarings for the entire trace coordinate. Modular polynomial powers use the certified bounded modular-power implementation. -/ +def traceCoordinate (M : MulBackend) (D : ModBackend) (modulus : CPolynomial E) (beta : E) : + CPolynomial E := + let scalars := FrobeniusExtraction.powers 192 beta + (List.range 192).foldl (fun total i => total + + CPolynomial.C scalars[i]! * xPowModWith M D modulus (2 ^ i)) 0 + +theorem traceCoordinate_eq (M : MulBackend) (D : ModBackend) (modulus : CPolynomial E) (beta : E) : + traceCoordinate M D modulus beta = traceCoordinatePolynomialWith M D traceContext modulus beta := by + simp only [traceCoordinate, traceCoordinatePolynomialWith, traceContext, + FrobeniusExtraction.powers_value] + apply List.foldl_ext + intro total i member + have bound : i < 192 := List.mem_range.mp member + simp [getElem!_pos, bound] + +/-- The source-specialized refinement is deliberately direct: only the expensive scalar-power call is replaced, and the certified polynomial backend remains unchanged. -/ +def refineFactor (M : MulBackend) (D : ModBackend) (beta : E) (factor : CPolynomial E) : + Array (CPolynomial E) := + let factor := CPolynomial.monicNormalize factor + if factor == 0 || factor == 1 then #[] + else if isRepresentedLinearFactor factor then #[factor] + else + let tracePoly := traceCoordinate M D factor beta + traceContext.baseConstants.foldl (fun children constant => + let child := CPolynomial.monicNormalize + (CPolynomial.gcdMonic factor (tracePoly - CPolynomial.C constant)) + pushNontrivialChild children child) #[] + +theorem refineFactor_eq (M : MulBackend) (D : ModBackend) (beta : E) (factor : CPolynomial E) : + refineFactor M D beta factor = shoupRefineFactorWith M D traceContext beta factor := by + simp only [refineFactor, shoupRefineFactorWith, traceCoordinate_eq] + +def refineFactors (M : MulBackend) (D : ModBackend) (beta : E) (factors : Array (CPolynomial E)) : + Array (CPolynomial E) := + factors.foldl (fun out factor => out ++ refineFactor M D beta factor) #[] + +theorem refineFactors_eq (M : MulBackend) (D : ModBackend) (beta : E) (factors : Array (CPolynomial E)) : + refineFactors M D beta factors = shoupRefineFactorsWith M D traceContext beta factors := by + simp only [refineFactors, shoupRefineFactorsWith, refineFactor_eq] + +def splitCandidates (M : MulBackend) (D : ModBackend) (polynomial : CPolynomial E) : + Array (CPolynomial E) := + let polynomial := CPolynomial.monicNormalize polynomial + if polynomial == 0 || polynomial == 1 then #[] + else if isRepresentedLinearFactor polynomial then #[polynomial] + else traceContext.basis.foldl (fun factors beta => refineFactors M D beta factors) #[polynomial] + +theorem splitCandidates_eq (M : MulBackend) (D : ModBackend) (polynomial : CPolynomial E) : + splitCandidates M D polynomial = shoupSplitCandidatesWith M D traceContext polynomial := by + simp only [splitCandidates, shoupSplitCandidatesWith, refineFactors_eq] + +def splitter (M : MulBackend) (D : ModBackend) : LinearFactorProductSplitter E where + splitLinearFactors _ polynomial := representedLinearFactorsOnly (splitCandidates M D polynomial) + validInput _ polynomial := shoupSplitterInput traceContext polynomial + sound := by + intro q polynomial factor member + rw [splitCandidates_eq] at member + exact shoupSplitLinearFactorsWith_sound M D traceContext member + complete := by + intro q polynomial root valid nonzero isRoot + simpa only [splitCandidates_eq, shoupSplitLinearFactorsWith] using + shoupSplitLinearFactorsWith_complete M D traceContext valid nonzero isRoot + +/-- Establish validity with the field-size parameter opaque; this avoids normalizing the dense specification X^(2^192) during source-instance elaboration. The runtime still computes only modular powers. -/ +private def rootContextFromShoup {F : Type} [Field F] [BEq F] [LawfulBEq F] + (M : CPolynomial.Raw.MulContext F) (D : CPolynomial.Raw.ModContext F) + (ctx : SmallPrimeTraceContext F) : GuruswamiSudan.FieldRootContext F := + GuruswamiSudan.finiteFieldRootContextWith F M D ctx.toFiniteFieldContext + (shoupLinearFactorProductSplitterWith M D ctx) (by + intro polynomial nonzero + exact ⟨finiteFieldRootProductWith_ne_zero_of_ne_zero M D ctx.toFiniteFieldContext nonzero, + finiteFieldRootProductWith_dvd_frobenius M D ctx nonzero⟩) + +theorem roots_eq (M : MulBackend) (D : ModBackend) (polynomial : CPolynomial E) : + rootsInFiniteFieldWith M D traceContext.toFiniteFieldContext (splitter M D) polynomial = + (rootContextFromShoup M D traceContext).rootsInField polynomial := by + simp only [rootContextFromShoup, GuruswamiSudan.finiteFieldRootContextWith, + rootsInFiniteFieldWith, splitter, shoupLinearFactorProductSplitterWith, + splitCandidates_eq, shoupSplitLinearFactorsWith] + +/-- A real complete univariate root provider for source E, using the certified root-product reduction and source binary trace splitter. -/ +def fieldRootContext (M : MulBackend) (D : ModBackend) : + GuruswamiSudan.FieldRootContext E where + rootsInField := rootsInFiniteFieldWith M D traceContext.toFiniteFieldContext (splitter M D) + sound := by + intro polynomial root member + rw [roots_eq] at member + exact (rootContextFromShoup M D traceContext).sound polynomial root member + complete := by + intro polynomial root nonzero isRoot + rw [roots_eq] + exact (rootContextFromShoup M D traceContext).complete polynomial root nonzero isRoot + +#print axioms roots_eq + +#print axioms traceCoordinate_eq +#print axioms refineFactor_eq +#print axioms refineFactors_eq +#print axioms splitCandidates_eq +#print axioms splitter +#print axioms fieldRootContext +end Whir.ShoupTraceExtraction diff --git a/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean b/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean new file mode 100644 index 000000000..9a52fbeb2 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean @@ -0,0 +1,152 @@ +import Whir.SpongefishCurrentCommitmentReceive +import Whir.SpongefishCurrentRecordOpeningQueries +import Whir.SpongefishCurrentPhysicalRootCapture +import Whir.SpongefishCurrentPrimitiveEventCompiler + +/-! Real BLAKE2s execution of the current byte-adapter paths, including raw-root +mismatch, truncated immutable record and an output-block boundary. This is a +hand-port regression, not a Rust compiler or whole native acceptance theorem. -/ +open Whir Whir.Concrete Whir.FiatShamirGame Whir.DuplexRefinement Whir.DuplexFraming +open Whir.SpongefishSessionAdapter Whir.SpongefishPCSRoundFrames + +private def report (label : String) : IO Unit := do + IO.println s!"current adapter: {label}" + (← IO.getStdout).flush + +def main : IO Unit := do + let C := DuplexModeGame.blake2sOracle + let c := DuplexModeGame.compressionOf C + let parameter := DuplexCompression.parameterIV + let tag := ([] : List Byte) + let derived := DuplexModeGame.runReal C parameter (SpongefishOrdinarySession.deriveProgram parameter tag) + let session := derive c parameter tag + unless derived.view.result = session && derived.view.observations.length = 2 do + throw (IO.userError "observed session derivation disagrees") + report "observed session derivation agrees" + let state := init c parameter session + let pending : Pending := {domain := session} + let shape : Shape := ⟨2,1,1,1⟩ + let header := SpongefishCurrentAnchorHeader.bytes shape zeroDigest + let headerCursor : Cursor := {state,pending,narg := header ++ [7]} + let (headerAfter,headerRoot) ← match SpongefishCurrentAnchorHeader.readHeader c headerCursor shape with + | some result => pure result + | none => throw (IO.userError "canonical raw32 preanchor header rejected") + unless headerAfter.narg = [7] && headerAfter.bytesRead = 104 && + headerAfter.messagesRead = 4 && Array.ofFn headerRoot = Array.ofFn zeroDigest do + throw (IO.userError "preanchor header root or exact cursor differs") + let headerQuery := SpongefishCurrentModeQueries.coordinate headerAfter.pending 0 + if bounded : pathCost headerQuery ≤ 4096 then + let raw := DuplexModeGame.constructionKey 4096 parameter headerQuery bounded + unless (SpongefishCurrentAnchorHeader.rawHeader shape parameter raw).map Array.ofFn = + some (Array.ofFn zeroDigest) do + throw (IO.userError "raw preanchor coordinate lost its root") + let ref := SpongefishCurrentPhysicalRootCapture.reference shape zeroDigest + let key : PublicCompressionCouplingMixed.Key 4096 := .inr raw + let input : DuplexFraming.Node := ⟨zeroDigest,fun _ => 0,0,true⟩ + let prior : List (SpongefishCurrentPhysicalRootCapture.Event 4096) := + [⟨.inl input,C input⟩] + let events := prior ++ [⟨key,zeroDigest⟩] + let some frozen := SpongefishCurrentPhysicalRootCapture.capture shape parameter ref events + | throw (IO.userError "current literal raw key did not capture the physical root") + unless frozen.queryPrefix = [(input,C input)] do + throw (IO.userError "current root capture included its own answer or lost the strict prefix") + let extended := events ++ [⟨key,fun i => if i.val = 0 then 1 else 0⟩] + let some retained := SpongefishCurrentPhysicalRootCapture.capture shape parameter ref extended + | throw (IO.userError "earlier adversarial root mention was lost") + unless retained.raw = frozen.raw && retained.queryPrefix = frozen.queryPrefix do + throw (IO.userError "later current reply replaced the first physical root capture") + report "literal current physical root reused its earliest strict prefix independently of later replies" + else + throw (IO.userError "preanchor header exceeded the smoke query budget") + let anchorBytes ← match DuplexRefinement.squeeze c headerAfter.state (24*shape.logN) with + | .ok (_,bytes) => pure bytes + | .error _ => throw (IO.userError "preanchor point squeeze failed") + unless anchorBytes.length = 48 do + throw (IO.userError "preanchor point squeeze returned the wrong byte count") + unless (SpongefishCurrentAnchorHeader.readHeader c + {headerCursor with narg := header.take 103} shape).isNone do + throw (IO.userError "truncated preanchor header accepted") + report "raw32 preanchor header and literal root captured before 48 point bytes; truncation rejected" + let value := E.ofK 9 + let transport := header ++ scalarCodec.bytes value ++ [7] + let receiveCursor : Cursor := {state,pending,narg := transport} + let (receivedAfter,received) ← match SpongefishCurrentCommitmentReceive.receive c receiveCursor shape with + | some result => pure result + | none => throw (IO.userError "actual commitment-receive operation rejected canonical input") + let some (sampledPoint,pointRest) := (vectorCodec shape.logN).parse anchorBytes + | throw (IO.userError "actual sampled point failed its canonical codec") + unless pointRest = [] && received.point = List.ofFn sampledPoint && + received.value = value && Array.ofFn received.root = Array.ofFn zeroDigest && + receivedAfter.narg = [7] && receivedAfter.bytesRead = 128 && + receivedAfter.messagesRead = 5 do + throw (IO.userError "actual receive point, root, value or individual cursor differs") + unless (SpongefishCurrentCommitmentReceive.receive c + {receiveCursor with narg := transport.take 127} shape).isNone do + throw (IO.userError "truncated actual anchor value accepted") + report "actual commitment receive retained sampled point, raw root and later prover value; truncated value rejected" + let calls : List Call := [.read .scalar,.read .scalar,.read .scalar,.read .root, + .draw (.anchor (shape.logN-1)),.read .scalar] + let compiled := DuplexModeGame.runReal C parameter + (SpongefishCurrentPrimitiveEventCompiler.replayProgram receiveCursor calls) + let compiledAfter ← match compiled.view.result with + | .ok result => pure result + | .error _ => throw (IO.userError "observed current primitive compiler rejected canonical receive") + unless compiledAfter.narg = receivedAfter.narg && + compiledAfter.bytesRead = receivedAfter.bytesRead && + compiledAfter.messagesRead = receivedAfter.messagesRead && + compiledAfter.state.pending = receivedAfter.state.pending && + compiledAfter.state.consumed = receivedAfter.state.consumed && + Array.ofFn compiledAfter.state.cv = Array.ofFn receivedAfter.state.cv do + throw (IO.userError "observed current compiler differs from actual receive") + let rejecting := DuplexModeGame.runReal C parameter + (SpongefishCurrentPrimitiveEventCompiler.replayProgram + {receiveCursor with narg := transport.take 127} calls) + match rejecting.view.result with + | .error (reached,.readRejected .scalar) => + unless reached.bytesRead = 104 && reached.messagesRead = 4 && + reached.state.consumed = 48 do + throw (IO.userError "rejecting current compiler lost the reached pre-value cursor") + | _ => throw (IO.userError "current compiler did not report the truncated later value") + report "observed primitive compiler matched actual receive and retained rejecting-prefix state" + let record : Record := { + shape := ⟨2,1,1,1⟩,root := zeroDigest, + context := ⟨zeroDigest,[1,2,3,4,5],true,0,0⟩, + point := [0,0],value := 0 } + let source := openingBytes record + let cur : Cursor := {state,pending,narg := source ++ [9,10]} + let after ← match SpongefishRecordBindingParser.verify c cur record with + | some next => pure next + | none => throw (IO.userError "canonical current record rejected") + unless after.narg = [9,10] && after.bytesRead = source.length && + after.messagesRead = (SpongefishRecordBindingParser.messages record).length do + throw (IO.userError "source record cursor or individual reads disagree") + report "raw-root record parsed with exact cursor and individual read counts" + let q := SpongefishCurrentModeQueries.coordinate after.pending 0 + if bounded : pathCost q ≤ 4096 then + let raw := DuplexModeGame.constructionKey 4096 parameter q bounded + let candidates := SpongefishCurrentRecordModeCapture.rawRecords record.shape parameter raw + unless candidates.length ≤ 4 && candidates.any (fun r => openingBytes r = source) do + throw (IO.userError "literal current raw coordinate lost the saved record") + report "literal raw coordinate recovered the bounded saved-record candidates" + else + throw (IO.userError "current record exceeded the smoke query budget") + let other := {record with root := fun i => if i.val = 0 then 1 else 0} + unless (SpongefishRecordBindingParser.verify c cur other).isNone do + throw (IO.userError "foreign raw root accepted") + report "foreign raw root rejected" + unless (SpongefishRecordBindingParser.verify c {cur with narg := source.take (source.length-1)} record).isNone do + throw (IO.userError "truncated current record accepted") + report "truncated record rejected" + let bytes ← match DuplexRefinement.squeeze c after.state 37 with + | .ok (_,bytes) => pure bytes + | .error _ => throw (IO.userError "source squeeze failed") + let projections := (List.range 2).map fun block => + DuplexFraming.withCoordinate c parameter + (SpongefishCurrentModeQueries.coordinate after.pending block) fun out => Array.ofFn out + for j in [:bytes.length] do + let some digest := projections[j/32]? | throw (IO.userError "missing output block") + let some expected := digest[j%32]? | throw (IO.userError "missing output byte") + unless bytes[j]?.getD 0 = expected do + throw (IO.userError s!"source output byte coordinate differs at {j}") + IO.println s!"PASS current observed session derivation ({derived.view.observations.length} primitive calls), raw-root record ({after.bytesRead} bytes, {after.messagesRead} individual reads), foreign/truncated rejection, 37 projected output bytes" + (← IO.getStdout).flush diff --git a/verification/whir/Whir/SpongefishCurrentAnchorHeader.lean b/verification/whir/Whir/SpongefishCurrentAnchorHeader.lean new file mode 100644 index 000000000..ceff567c7 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentAnchorHeader.lean @@ -0,0 +1,347 @@ +import Whir.SpongefishCurrentRecordModeCapture + +/-! Deterministic hand-port of the current #607 `commit.rs` preanchor header: +three individual F192 constants, then one raw32 root, before `verifier_messages`. +The public shape guard is the 64-bit source guard. This is not compiled Rust +correspondence, Rows constraint soundness, or a BLAKE2s/uniformity claim. +Malformed reads and mismatches return `none`; Rust error identity, retained +failed-read state and poisoning are deliberately not modeled. No anchor point, +anchor value, saved context, or previously trusted root is an input to recovery. -/ +namespace Whir.SpongefishCurrentAnchorHeader +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishSessionAdapter SpongefishPCSRoundFrames SpongefishRecordBindingParser +set_option autoImplicit false + +/-- Literal current header, not the historical five-scalar digest packing. -/ +def bytes (shape : Shape) (root : Digest32) : List Byte := commitPrefix shape root + +theorem bytes_length (shape : Shape) (root : Digest32) : + (bytes shape root).length = 104 := commitPrefix_length shape root + +def fields (shape : Shape) (root : Digest32) : List SpongefishRecordBindingParser.Message := + scalarMessages (constants AnchoredHeaderCodec.anchorMarker shape) ++ [⟨.root,root⟩] + +theorem fields_bytes (shape : Shape) (root : Digest32) : + (fields shape root).flatMap Message.bytes = bytes shape root := by + rw [fields,List.flatMap_append,scalar_messages_bytes] + rfl + +/-- Canonical constants are checked; the raw root is decoded, never compared +against a supplied root. Insufficient transport has no fake valid fallback. -/ +def decode (shape : Shape) (source : List Byte) : Option (Digest32 × List Byte) := do + if ¬ shape.Valid then none else do + let (header,rest) ← SpongefishCurrentRecordDecoder.scalars 3 source + if header ≠ constants AnchoredHeaderCodec.anchorMarker shape then none else + rootCodec.parse rest + +theorem decode_encoded (shape : Shape) (valid : shape.Valid) (root : Digest32) + (rest : List Byte) : decode shape (bytes shape root ++ rest) = some (root,rest) := by + unfold decode bytes commitPrefix + simp only [valid,not_true_eq_false,↓reduceIte,List.append_assoc] + rw [show 3 = (constants AnchoredHeaderCodec.anchorMarker shape).length from rfl, + SpongefishCurrentRecordDecoder.scalars_encoded] + dsimp only [Bind.bind,Option.bind] + simp only [ne_eq,not_true_eq_false,↓reduceIte] + exact Codec.parse_append rootCodec root rest + +theorem decode_source (shape : Shape) (source rest : List Byte) (root : Digest32) + (accepted : decode shape source = some (root,rest)) : + shape.Valid ∧ source = bytes shape root ++ rest := by + unfold decode at accepted + split at accepted + · contradiction + · rename_i valid + obtain ⟨⟨header,after⟩,readHeader,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · contradiction + · rename_i equal + have canonical := (SpongefishCurrentRecordDecoder.scalars_source 3 source after header readHeader).2 + have rootSource := Codec.canonical_read rootCodec after rest root accepted + have matchHeader : header = constants AnchoredHeaderCodec.anchorMarker shape := by + simpa only [ne_eq,not_not] using equal + rw [matchHeader,rootSource] at canonical + exact ⟨by simpa using valid,by simpa [bytes,commitPrefix,Codec.bytes,rootCodec, + rawRoot,List.append_assoc] using canonical⟩ + +theorem decode_exact (shape : Shape) (source rest : List Byte) (root : Digest32) : + decode shape source = some (root,rest) ↔ + shape.Valid ∧ source = bytes shape root ++ rest := by + constructor + · exact decode_source shape source rest root + · rintro ⟨valid,rfl⟩; exact decode_encoded shape valid root rest + +/-- Exactly the last 104 bytes, with no uniqueness assumption or candidate scan. -/ +def suffix (shape : Shape) (source : List Byte) : Option Digest32 := do + let (root,rest) ← decode shape (source.drop (source.length-104)) + if rest = [] then some root else none + +theorem suffix_recovery (shape : Shape) (valid : shape.Valid) (root : Digest32) + (pre : List Byte) : suffix shape (pre ++ bytes shape root) = some root := by + unfold suffix + simp only [List.length_append,bytes_length,Nat.add_sub_cancel_right,List.drop_left] + have parsed := decode_encoded shape valid root [] + simp only [List.append_nil] at parsed + rw [parsed] + rfl + +theorem suffix_source (shape : Shape) (source : List Byte) (root : Digest32) + (accepted : suffix shape source = some root) : + shape.Valid ∧ List.IsSuffix (bytes shape root) source := by + unfold suffix at accepted + cases parsed : decode shape (source.drop (source.length-104)) with + | none => simp [parsed] at accepted + | some pair => + obtain ⟨actual,rest⟩ := pair + simp only [parsed] at accepted + change (if rest = [] then some actual else none) = some root at accepted + split at accepted + · rename_i empty + cases accepted + obtain ⟨valid,canonical⟩ := decode_source shape _ rest root parsed + rw [empty,List.append_nil] at canonical + exact ⟨valid,source.take (source.length-104),by + rw [← canonical]; exact List.take_append_drop _ source⟩ + · contradiction + +theorem suffix_unique (shape : Shape) (valid : shape.Valid) (root other : Digest32) + (pre : List Byte) (accepted : suffix shape (pre ++ bytes shape root) = some other) : + other = root := by + exact Option.some.inj (accepted.symm.trans (suffix_recovery shape valid root pre)) + +/-- Actual individual verifier calls: three checked scalar reads followed by +an unchecked raw32 root read. The root is selected before any verifier answer. -/ +def readHeader (c : Compression) (cur : Cursor) (shape : Shape) : + Option (Cursor × Digest32) := do + if ¬ shape.Valid then none else do + let next ← verifyFields c cur (scalarMessages (constants AnchoredHeaderCodec.anchorMarker shape)) + SpongefishPCSRoundFrames.read c next .root + +private theorem raw_read_exact (c : Compression) (cur next : Cursor) (root : Digest32) : + SpongefishPCSRoundFrames.read c cur .root = some (next,root) ↔ + checkedRead c cur ⟨.root,root⟩ = some next := by + constructor + · intro accepted + unfold SpongefishPCSRoundFrames.read at accepted + cases parsed : rootCodec.parse cur.narg with + | none => simp [WireKind.codec,parsed] at accepted + | some pair => + obtain ⟨actual,rest⟩ := pair + simp only [WireKind.codec,parsed] at accepted + dsimp only [Bind.bind,Option.bind,Pure.pure] at accepted + have equality : (advance c cur ⟨.root,actual⟩ rest,actual) = (next,root) := + Option.some.inj accepted + have actualEq : actual = root := congrArg Prod.snd equality + have cursorEq : next = advance c cur ⟨.root,actual⟩ rest := + (congrArg Prod.fst equality).symm + have canonical := Codec.canonical_read rootCodec cur.narg rest actual parsed + apply (checkedRead_exact c cur next ⟨.root,root⟩).mpr + refine ⟨rest,?_,?_⟩ + · change cur.narg = rootCodec.bytes root ++ rest + rw [← actualEq] + exact canonical + · rw [← actualEq] + exact cursorEq + · intro accepted + obtain ⟨rest,source,rfl⟩ := (checkedRead_exact c cur next ⟨.root,root⟩).mp accepted + exact read_append c cur .root root rest source + +private theorem verifyFields_append (c : Compression) (cur : Cursor) + (a b : List SpongefishRecordBindingParser.Message) : + verifyFields c cur (a ++ b) = (verifyFields c cur a).bind (fun next => verifyFields c next b) := by + induction a generalizing cur with + | nil => rfl + | cons message a ih => + change ((checkedRead c cur message).bind (fun middle => verifyFields c middle (a ++ b))) = + (((checkedRead c cur message).bind (fun middle => verifyFields c middle a)).bind + (fun next => verifyFields c next b)) + cases checkedRead c cur message with + | none => rfl + | some middle => exact ih middle + +theorem readHeader_exact (c : Compression) (cur next : Cursor) (shape : Shape) + (root : Digest32) : readHeader c cur shape = some (next,root) ↔ + shape.Valid ∧ verifyFields c cur (fields shape root) = some next := by + unfold readHeader + by_cases valid : shape.Valid + · simp only [valid,not_true_eq_false,↓reduceIte,true_and,fields,verifyFields_append] + cases result : verifyFields c cur (scalarMessages (constants AnchoredHeaderCodec.anchorMarker shape)) with + | none => simp + | some middle => + change SpongefishPCSRoundFrames.read c middle .root = some (next,root) ↔ + verifyFields c middle [⟨.root,root⟩] = some next + have singleton : verifyFields c middle [⟨.root,root⟩] = + checkedRead c middle ⟨.root,root⟩ := by + simp only [verifyFields] + cases checkedRead c middle ⟨.root,root⟩ <;> rfl + rw [singleton] + exact raw_read_exact c middle next root + · simp [valid] + +/-- There are no grouped scalar reads and no draw in the header replay. -/ +theorem readHeader_replay (c : Compression) (cur next : Cursor) (shape : Shape) + (root : Digest32) (accepted : readHeader c cur shape = some (next,root)) : + replayCalls c cur [.read .scalar,.read .scalar,.read .scalar,.read .root] = some next := by + have verified := ((readHeader_exact c cur next shape root).mp accepted).2 + exact verifyFields_replay c cur next (fields shape root) verified + +/-- Remainder, read counters and public event history are derived from reads. -/ +private theorem fields_facts (c : Compression) (cur next : Cursor) + (ms : List SpongefishRecordBindingParser.Message) + (accepted : verifyFields c cur ms = some next) : + cur.narg = ms.flatMap Message.bytes ++ next.narg ∧ + next.bytesRead = cur.bytesRead + (ms.map fun m => m.1.codec.size).sum ∧ + next.messagesRead = cur.messagesRead + (ms.map fun m => m.1.messages).sum ∧ + next.events = cur.events ++ (ms.map fun m => SourceEvent.prover m.1 m.bytes) ∧ + next.state = absorb c cur.state (ms.flatMap Message.bytes) := by + induction ms generalizing cur with + | nil => + simp only [verifyFields,Option.some.injEq] at accepted + cases accepted + simp + | cons message ms ih => + simp only [verifyFields] at accepted + obtain ⟨middle,step,tail⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨rest,source,state⟩ := (checkedRead_exact c cur middle message).mp step + have facts := ih middle tail + rw [state] at facts + dsimp only [advance] at facts + obtain ⟨remaining,byteCount,messageCount,events,absorbed⟩ := facts + exact ⟨by rw [source,remaining]; simp [List.flatMap_cons,List.append_assoc], + by simpa [List.map_cons,List.sum_cons,Nat.add_assoc] using byteCount, + by simpa [List.map_cons,List.sum_cons,Nat.add_assoc] using messageCount, + by simpa [List.map_cons,List.append_assoc] using events, + by simpa [List.flatMap_cons,absorb_append] using absorbed⟩ + +theorem readHeader_facts (c : Compression) (cur next : Cursor) (shape : Shape) + (root : Digest32) (accepted : readHeader c cur shape = some (next,root)) : + shape.Valid ∧ cur.narg = bytes shape root ++ next.narg ∧ + next.bytesRead = cur.bytesRead + 104 ∧ next.messagesRead = cur.messagesRead + 4 ∧ + next.events = cur.events ++ (fields shape root).map (fun m => SourceEvent.prover m.1 m.bytes) ∧ + next.state = absorb c cur.state (bytes shape root) ∧ + next.pending.run = cur.pending.run ++ bytes shape root := by + obtain ⟨valid,verified⟩ := (readHeader_exact c cur next shape root).mp accepted + obtain ⟨source,byteCount,messageCount,events,state⟩ := fields_facts c cur next _ verified + rw [fields_bytes] at source state + have run := SpongefishCurrentRecordModeCapture.verifyFields_run c cur next _ verified + rw [fields_bytes] at run + refine ⟨valid,source,?_,?_,events,state,run⟩ + · change next.bytesRead = cur.bytesRead + 104 at byteCount + exact byteCount + · change next.messagesRead = cur.messagesRead + 4 at messageCount + exact messageCount + +theorem readHeader_decoder (c : Compression) (cur next : Cursor) (shape : Shape) + (root : Digest32) (accepted : readHeader c cur shape = some (next,root)) : + decode shape cur.narg = some (root,next.narg) := by + obtain ⟨valid,source,_⟩ := readHeader_facts c cur next shape root accepted + exact (decode_exact shape cur.narg next.narg root).mpr ⟨valid,source⟩ + +/-- Complete successful-header domain. Invalid public shapes, mismatched +constants and truncated headers cannot enter the successful read semantics. -/ +theorem readHeader_source (c : Compression) (cur : Cursor) (shape : Shape) + (root : Digest32) : + (∃ next,readHeader c cur shape = some (next,root)) ↔ + shape.Valid ∧ ∃ rest,cur.narg = bytes shape root ++ rest := by + constructor + · rintro ⟨next,accepted⟩ + obtain ⟨valid,source,_⟩ := readHeader_facts c cur next shape root accepted + exact ⟨valid,next.narg,source⟩ + · rintro ⟨valid,rest,source⟩ + have before : cur.narg = (fields shape root).flatMap Message.bytes ++ rest := by + rw [fields_bytes] + exact source + obtain ⟨next,verified⟩ := (verifyFields_source c cur (fields shape root)).mpr ⟨rest,before⟩ + exact ⟨next,(readHeader_exact c cur next shape root).mpr ⟨valid,verified⟩⟩ + +/-- Recover the header from the last closed absorb body, irrespective of all +prior absorb bytes and preceding output consumption. -/ +def fromHistory (shape : Shape) (history : FramedHistory) : Option Digest32 := + match history.frames.getLast? with + | some (.absorb _ source) => suffix shape source + | _ => none + +theorem closed_header (m : Pending) (shape : Shape) (valid : shape.Valid) + (root : Digest32) (pre : List Byte) (run : m.run = pre ++ bytes shape root) : + fromHistory shape (close m).core.history = some root := by + have nonempty : m.run ≠ [] := by + intro empty + have len := congrArg List.length (run.symm.trans empty) + simp only [List.length_append,List.length_nil,bytes_length] at len + omega + simp only [fromHistory,close,nonempty,↓reduceIte,Pending.core,List.map_append, + List.map_singleton,ByteFrame.historicalCore,List.getLast?_append,List.getLast?_singleton] + change suffix shape m.run = some root + rw [run] + exact suffix_recovery shape valid root pre + +def rawHeader {Q : Nat} (shape : Shape) (iv : Digest32) (raw : RawKey Q) : Option Digest32 := + (WHIRHeaderRoots.decodeRaw iv raw).bind (fun q => fromHistory shape q.history) + +theorem rawHeader_sound {Q : Nat} (shape : Shape) (iv : Digest32) (raw : RawKey Q) + (root : Digest32) (accepted : rawHeader shape iv raw = some root) : + ∃ q : Coordinate, ∃ bound : pathCost q ≤ Q, + DuplexEncoding.Admissible q ∧ constructionKey Q iv q bound = raw ∧ + ∃ previous source, q.history.frames.getLast? = some (.absorb previous source) ∧ + shape.Valid ∧ List.IsSuffix (bytes shape root) source := by + obtain ⟨q,decoded,parsed⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨bound,valid,key⟩ := WHIRHeaderRoots.decodeRaw_sound iv raw q decoded + refine ⟨q,bound,valid,key,?_⟩ + unfold fromHistory at parsed + split at parsed + · rename_i previous source last + obtain ⟨shapeValid,sourceSuffix⟩ := suffix_source shape source root parsed + exact ⟨previous,source,last,shapeValid,sourceSuffix⟩ + · contradiction + +/-- Actual next nonempty anchor group, every returned byte, and an exact whole +bounded raw key. Only the prior representation/frame geometry and total path +budget are hypotheses; output uniformity, fixed CV, root equality, later anchor +point/value and trusted parser matching are not. -/ +theorem readHeader_anchor_byte {Q : Nat} (c : Compression) (iv : Digest32) + (cur next : Cursor) (shape : Shape) (root : Digest32) + (accepted : readHeader c cur shape = some (next,root)) + (represented : RepresentsCurrent c iv cur.pending cur.state) + (framed : SpongefishCurrentModeQueries.FrameDomain cur.pending) + (state : State) (output : List Byte) + (squeezed : squeeze c next.state (24*shape.logN) = .ok (state,output)) + (j : Nat) (within : j < 24*shape.logN) + (work : pathCost (SpongefishCurrentModeQueries.coordinate next.pending + ((next.pending.consumed+j)/32)) ≤ Q) : + let q := SpongefishCurrentModeQueries.coordinate next.pending ((next.pending.consumed+j)/32) + DuplexEncoding.Admissible q ∧ + rawHeader shape iv (constructionKey Q iv q work) = some root ∧ + output[j]'(by obtain ⟨_,len⟩ := squeeze_exact_cursor c next.state state _ output squeezed; omega) = + evalCoordinate c iv q ⟨(next.pending.consumed+j)%32,Nat.mod_lt _ (by decide)⟩ := by + obtain ⟨valid,verified⟩ := (readHeader_exact c cur next shape root).mp accepted + obtain ⟨afterRep,afterFrame⟩ := SpongefishCurrentModeQueries.all_round_frame_domain c iv cur next + ((fields shape root).map fun message => .read message.1) represented framed + (verifyFields_replay c cur next _ verified) + have positive : 24*shape.logN ≠ 0 := by have := valid.1; omega + have admissible := SpongefishCurrentModeQueries.squeezed_coordinate_admissible c iv next.pending + next.state state afterRep afterFrame _ positive output squeezed j within + refine ⟨admissible,?_,SpongefishCurrentModeQueries.squeezed_byte c iv next.pending + next.state state afterRep _ positive output squeezed j within⟩ + rw [rawHeader,WHIRHeaderRoots.decodeRaw_construction iv _ admissible work] + simp only [Option.bind_some,SpongefishCurrentModeQueries.coordinate] + have run := SpongefishCurrentRecordModeCapture.verifyFields_run c cur next _ verified + rw [fields_bytes] at run + exact closed_header next.pending shape valid root cur.pending.run run + +#print axioms bytes_length +#print axioms fields_bytes +#print axioms decode_encoded +#print axioms decode_source +#print axioms decode_exact +#print axioms suffix_recovery +#print axioms suffix_source +#print axioms suffix_unique +#print axioms readHeader_exact +#print axioms readHeader_replay +#print axioms readHeader_facts +#print axioms readHeader_decoder +#print axioms readHeader_source +#print axioms closed_header +#print axioms rawHeader_sound +#print axioms readHeader_anchor_byte +end Whir.SpongefishCurrentAnchorHeader diff --git a/verification/whir/Whir/SpongefishCurrentCommitmentReceive.lean b/verification/whir/Whir/SpongefishCurrentCommitmentReceive.lean new file mode 100644 index 000000000..db1035cd9 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentCommitmentReceive.lean @@ -0,0 +1,129 @@ +import Whir.SpongefishCurrentAnchorHeader + +/-! Successful current commitment receive: capture the actual preheader state, +read the guarded raw-root header, sample the complete anchor vector, read its +advertised value, and retain one immutable record. This hand-port does not model +Rust error identity/poisoning, prove Rows constraints, or assert uniformity. -/ +namespace Whir.SpongefishCurrentCommitmentReceive +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishSessionAdapter SpongefishPCSRoundFrames SpongefishRecordBindingParser +set_option autoImplicit false + +/-- The point and saved context are computed by the source operations, not +provided as matching certificates or a caller-selected saved record. -/ +def receive (c : Compression) (cur : Cursor) (shape : Shape) : Option (Cursor × Record) := do + let (header,root) ← SpongefishCurrentAnchorHeader.readHeader c cur shape + let (sampled,bytes) ← match squeezeGroup c header (.anchor (shape.logN-1)) with + | .error _ => none + | .ok value => some value + let (point,rest) ← (vectorCodec shape.logN).parse bytes + if rest ≠ [] then none else do + let (next,value) ← read c sampled .scalar + pure (next,{shape,root,context := capture cur.state,point := List.ofFn point,value}) + +/-- Successful source execution exposes the genuine header, sampler and scalar +read subruns. The retained record is their literal result, not an assumption. -/ +theorem receive_runs (c : Compression) (cur next : Cursor) (shape : Shape) (r : Record) + (accepted : receive c cur shape = some (next,r)) : + ∃ header root sampled bytes, ∃ (point : Fin shape.logN → E), ∃ value, + SpongefishCurrentAnchorHeader.readHeader c cur shape = some (header,root) ∧ + squeezeGroup c header (.anchor (shape.logN-1)) = .ok (sampled,bytes) ∧ + (vectorCodec shape.logN).parse bytes = some (point,[]) ∧ + read c sampled .scalar = some (next,value) ∧ + r = {shape,root,context := capture cur.state,point := List.ofFn point,value} := by + unfold receive at accepted + obtain ⟨⟨header,root⟩,readHeader,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + cases drawn : squeezeGroup c header (.anchor (shape.logN-1)) with + | error error => simp [drawn] at accepted + | ok sampledBytes => + obtain ⟨sampled,bytes⟩ := sampledBytes + simp only [drawn] at accepted + change Option.bind ((vectorCodec shape.logN).parse bytes) _ = some (next,r) at accepted + obtain ⟨⟨point,rest⟩,decoded,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · contradiction + · rename_i empty + have restEmpty : rest = [] := by simpa only [ne_eq,not_not] using empty + subst rest + obtain ⟨⟨after,value⟩,readValue,equal⟩ := Option.bind_eq_some_iff.mp accepted + have same := Option.some.inj equal + cases same + exact ⟨header,root,sampled,bytes,point,value,readHeader,drawn,decoded,readValue,rfl⟩ + +/-- The entire sampled vector is retained; its canonical bytes and the actual +preheader context can be recovered from every successful result. -/ +theorem receive_retains (c : Compression) (cur next : Cursor) (shape : Shape) (r : Record) + (accepted : receive c cur shape = some (next,r)) : + r.shape = shape ∧ r.context = capture cur.state ∧ r.point.length = shape.logN ∧ + ∃ header sampled bytes, ∃ (point : Fin shape.logN → E), + SpongefishCurrentAnchorHeader.readHeader c cur shape = some (header,r.root) ∧ + squeezeGroup c header (.anchor (shape.logN-1)) = .ok (sampled,bytes) ∧ + bytes = (vectorCodec shape.logN).bytes point ∧ r.point = List.ofFn point ∧ + read c sampled .scalar = some (next,r.value) := by + obtain ⟨header,root,sampled,bytes,point,value,readHeader,drawn,decoded,readValue,rfl⟩ := + receive_runs c cur next shape r accepted + exact ⟨rfl,rfl,List.length_ofFn,header,sampled,bytes,point,readHeader,drawn, + by simpa only [List.append_nil] using Codec.canonical_read (vectorCodec shape.logN) bytes [] point decoded, + rfl,readValue⟩ + +private theorem squeezeGroup_source (c : Compression) (cur sampled : Cursor) + (g : Group) (bytes : List Byte) + (accepted : squeezeGroup c cur g = .ok (sampled,bytes)) : + squeeze c cur.state g.bytes = .ok (sampled.state,bytes) := by + cases actual : squeeze c cur.state g.bytes with + | error error => simp [squeezeGroup,actual] at accepted + | ok result => + obtain ⟨state,output⟩ := result + have same : ({cur with + state := state + pending := draw cur.pending g.bytes + events := cur.events ++ [.verifier output]} : Cursor) = sampled ∧ output = bytes := by + simpa [squeezeGroup,actual] using accepted + simp only [← same.1,← same.2] + +/-- The entire actual commitment-receive operation yields its sampled point +bytes and the root-bearing raw key BEFORE those bytes are answered. The anchor +value is subsequently read from the prover, not assumed or supplied to a parser. +Prior mode representation, frame geometry and total path work remain explicit. -/ +theorem receive_anchor_source {Q : Nat} (c : Compression) (iv : Digest32) + (cur next : Cursor) (shape : Shape) (r : Record) + (accepted : receive c cur shape = some (next,r)) + (represented : RepresentsCurrent c iv cur.pending cur.state) + (framed : SpongefishCurrentModeQueries.FrameDomain cur.pending) : + ∃ header sampled bytes, ∃ (point : Fin shape.logN → E), + SpongefishCurrentAnchorHeader.readHeader c cur shape = some (header,r.root) ∧ + bytes = (vectorCodec shape.logN).bytes point ∧ r.point = List.ofFn point ∧ + read c sampled .scalar = some (next,r.value) ∧ + ∃ (squeezed : squeeze c header.state (24*shape.logN) = .ok (sampled.state,bytes)), + ∀ (j : Nat) (within : j < 24*shape.logN) + (work : DuplexFraming.pathCost (SpongefishCurrentModeQueries.coordinate header.pending + ((header.pending.consumed+j)/32)) ≤ Q), + let q := SpongefishCurrentModeQueries.coordinate header.pending ((header.pending.consumed+j)/32) + DuplexEncoding.Admissible q ∧ + SpongefishCurrentAnchorHeader.rawHeader shape iv (constructionKey Q iv q work) = some r.root ∧ + bytes[j]'(by + obtain ⟨_,len⟩ := squeeze_exact_cursor c header.state sampled.state (24*shape.logN) bytes squeezed + omega) = + evalCoordinate c iv q ⟨(header.pending.consumed+j)%32,Nat.mod_lt _ (by decide)⟩ := by + obtain ⟨_,_,_,header,sampled,bytes,point,readHeader,drawn,encoded,pointEq,readValue⟩ := + receive_retains c cur next shape r accepted + have valid := ((SpongefishCurrentAnchorHeader.readHeader_exact c cur header shape r.root).mp + readHeader).1 + have count : (Group.anchor (shape.logN-1)).bytes = 24*shape.logN := by + simp only [Group.bytes,Group.elements] + have positive := valid.1 + omega + have squeezed := squeezeGroup_source c header sampled (.anchor (shape.logN-1)) bytes drawn + rw [count] at squeezed + refine ⟨header,sampled,bytes,point,readHeader,encoded,pointEq,readValue,squeezed,?_⟩ + intro j within work + exact SpongefishCurrentAnchorHeader.readHeader_anchor_byte c iv cur header shape r.root + readHeader represented framed sampled.state bytes squeezed j within work + +#print axioms receive_anchor_source + +#print axioms receive_runs +#print axioms receive_retains +end Whir.SpongefishCurrentCommitmentReceive diff --git a/verification/whir/Whir/SpongefishCurrentModeQueries.lean b/verification/whir/Whir/SpongefishCurrentModeQueries.lean new file mode 100644 index 000000000..2412dd23d --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentModeQueries.lean @@ -0,0 +1,188 @@ +import Whir.SpongefishOrdinarySession + +/-! Current successful source draws are byte projections of absorb-only output +coordinates. This is the deterministic bridge into the already-proved whole +mode game; it does not assume uniformity or current native acceptance. -/ +namespace Whir.SpongefishCurrentModeQueries +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames +set_option autoImplicit false + +/-- Source-byte framing bounds, not accepted algebraic claims. -/ +def FrameDomain (m : Pending) : Prop := + (∀ f ∈ m.frames, match f with | .absorb previous bytes => previous < 2^49 ∧ bytes ≠ []) ∧ + m.previous ≤ maxCursor + +/-- Closing a pending prover run is part of the semantic query, not a supplied CV. -/ +def coordinate (m : Pending) (block : Nat) : Coordinate := + ⟨(close m).core.history,.output block⟩ + +theorem coordinate_admissible (m : Pending) (valid : FrameDomain m) + (block : Nat) (bounded : block < 2^44) : DuplexEncoding.Admissible (coordinate m block) := by + have sourceFrames : ∀ f ∈ (close m).frames, + match f with | .absorb previous bytes => previous < 2^49 ∧ bytes ≠ [] := by + intro f member + by_cases empty : m.run = [] + · simp only [close,empty,↓reduceIte] at member + exact valid.1 f member + · simp only [close,empty,↓reduceIte,List.mem_append,List.mem_singleton] at member + rcases member with inOld | rfl + · exact valid.1 f inOld + · exact ⟨by have := valid.2; simp only [maxCursor] at this; omega,empty⟩ + change (∀ f ∈ (close m).frames.map ByteFrame.historicalCore, DuplexEncoding.FrameValid f) ∧ _ + constructor + · intro f member + obtain ⟨frame,inFrame,rfl⟩ := List.mem_map.mp member + cases frame with + | absorb previous bytes => exact sourceFrames _ inFrame + · exact bounded + +/-- The source state contains exactly the public closed history and cursor. -/ +theorem finished_state (c : Compression) (parameter : Digest32) (m : Pending) (s : State) + (h : RepresentsCurrent c parameter m s) : + finish c s = {cv := evalHistory c parameter (close m).core.history,consumed := m.consumed,output := (finish c s).output} := by + have hf := finish_represents c parameter m.core s h + have closed := materialize_closed c parameter (closeRun m.core) (finish c s).output + hf.1 (closeRun_empty m.core) + have state := hf.2.1.trans closed + have history : (closeRun m.core).history = (close m).core.history := + congrArg Model.history (close_core m).symm + have cursor : (closeRun m.core).consumed = m.consumed := closeRun_consumed m.core + rw [history,cursor] at state + exact state + +/-- Every actual returned byte refers to the same prior prover history. The +byte position, not a projected query index, determines the output coordinate. -/ +theorem squeezed_byte (c : Compression) (parameter : Digest32) (m : Pending) (s t : State) + (h : RepresentsCurrent c parameter m s) (n : Nat) (positive : n ≠ 0) + (bytes : List Byte) (ok : squeeze c s n = .ok (t,bytes)) (j : Nat) (within : j < n) : + bytes[j]'(by obtain ⟨_,len⟩ := squeeze_exact_cursor c s t n bytes ok; omega) = + evalCoordinate c parameter (coordinate m ((m.consumed+j)/32)) + ⟨(m.consumed+j)%32,Nat.mod_lt _ (by decide)⟩ := by + have hf := finish_represents c parameter m.core s h + have state := finished_state c parameter m s h + have cv : (finish c s).cv = evalHistory c parameter (close m).core.history := + congrArg State.cv state + have cursor : (finish c s).consumed = m.consumed := congrArg State.consumed state + have value := AnchoredByteStreamSampler.squeezeLoop_getElem c (finish c s) n j hf.2.2 within + unfold squeeze at ok + simp only [positive,↓reduceIte] at ok + split at ok + · have exactBytes : (squeezeLoop c n (finish c s)).2 = bytes := + congrArg Prod.snd (Except.ok.inj ok) + simpa only [exactBytes,cv,cursor,coordinate,evalCoordinate,evalTerminal] using value + · contradiction + +/-- The source guard also certifies the finite output-block address. -/ +theorem squeezed_coordinate_admissible (c : Compression) (parameter : Digest32) + (m : Pending) (s t : State) (h : RepresentsCurrent c parameter m s) + (valid : FrameDomain m) (n : Nat) (positive : n ≠ 0) (bytes : List Byte) + (ok : squeeze c s n = .ok (t,bytes)) (j : Nat) (within : j < n) : + DuplexEncoding.Admissible (coordinate m ((m.consumed+j)/32)) := by + have cursor : s.consumed = m.consumed := + h.2.1 ▸ materialize_consumed c parameter m.core s.output h.1 + have limit : s.consumed+n ≤ maxCursor := by + unfold squeeze at ok + simp only [positive,↓reduceIte] at ok + split at ok + · assumption + · contradiction + apply coordinate_admissible m valid + rw [cursor] at limit + simp only [maxCursor] at limit + omega + +theorem initial_frame_domain (session : Digest32) : FrameDomain {domain := session} := by + simp [FrameDomain,maxCursor] + +theorem close_frame_domain (m : Pending) (valid : FrameDomain m) : FrameDomain (close m) := by + unfold close + by_cases empty : m.run = [] + · simpa only [empty,↓reduceIte] using valid + · simp only [empty,↓reduceIte,FrameDomain,List.mem_append,List.mem_singleton] + constructor + · intro f member + rcases member with old | rfl + · exact valid.1 f old + · change m.previous < 2^49 ∧ m.run ≠ [] + exact ⟨by have := valid.2; simp only [maxCursor] at this; omega,empty⟩ + · simp [maxCursor] + +theorem bind_frame_domain (m : Pending) (bytes : List Byte) (valid : FrameDomain m) + (cursor : m.consumed ≤ maxCursor) : FrameDomain (bind m bytes) := by + unfold SpongefishPCSRoundFrames.bind + by_cases empty : bytes = [] + · simpa only [empty,↓reduceIte] using valid + · simp only [empty,↓reduceIte,FrameDomain] + exact ⟨valid.1,by split; exact valid.2; exact cursor⟩ + +theorem draw_frame_domain (m : Pending) (n : Nat) (valid : FrameDomain m) : + FrameDomain (draw m n) := by + unfold draw + by_cases empty : n = 0 + · simpa only [empty,↓reduceIte] using valid + · simpa only [empty,↓reduceIte,FrameDomain] using close_frame_domain m valid + +theorem replayCall_frame_domain (c : Compression) (parameter : Digest32) (cur next : Cursor) + (call : Call) (h : RepresentsCurrent c parameter cur.pending cur.state) + (valid : FrameDomain cur.pending) (ok : replayCall c cur call = some next) : + FrameDomain next.pending := by + cases call with + | read kind => + simp only [replayCall] at ok + cases parsed : read c cur kind with + | none => simp [parsed] at ok + | some pair => + rcases pair with ⟨after,value⟩ + simp only [parsed,Option.map_some,Option.some.injEq] at ok + subst next + unfold SpongefishPCSRoundFrames.read at parsed + cases decoded : kind.codec.parse cur.narg with + | none => simp [decoded] at parsed + | some pair => + rcases pair with ⟨actual,rest⟩ + simp only [decoded] at parsed + rcases parsed with ⟨rfl,rfl⟩ + exact bind_frame_domain cur.pending _ valid h.1.2.2.1 + | draw group => + simp only [replayCall,squeezeGroup] at ok + cases result : squeeze c cur.state group.bytes with + | error e => simp [result] at ok + | ok pair => + rcases pair with ⟨state,bytes⟩ + simp only [result] at ok + cases ok + exact draw_frame_domain cur.pending group.bytes valid + | hint => + simp only [replayCall,takeHint] at ok + cases hints : cur.hints with + | nil => simp [hints] at ok + | cons bytes rest => + simp only [hints,Option.some.injEq] at ok + cases ok + exact valid + +/-- Successful normalized current replay derives frame admission from the +initial state, not from a supplied accepted-transcript certificate. -/ +theorem all_round_frame_domain (c : Compression) (parameter : Digest32) (cur next : Cursor) + (calls : List Call) (h : RepresentsCurrent c parameter cur.pending cur.state) + (valid : FrameDomain cur.pending) (ok : replayCalls c cur calls = some next) : + RepresentsCurrent c parameter next.pending next.state ∧ FrameDomain next.pending := by + induction calls generalizing cur with + | nil => + simp only [replayCalls,Option.some.injEq] at ok + subst next + exact ⟨h,valid⟩ + | cons call calls ih => + simp only [replayCalls] at ok + obtain ⟨after,step,tail⟩ := Option.bind_eq_some_iff.mp ok + exact ih after (replayCall_bridge c parameter cur after call h step) + (replayCall_frame_domain c parameter cur after call h valid step) tail + +#print axioms all_round_frame_domain + +#print axioms coordinate_admissible +#print axioms finished_state +#print axioms squeezed_byte +#print axioms squeezed_coordinate_admissible +end Whir.SpongefishCurrentModeQueries diff --git a/verification/whir/Whir/SpongefishCurrentPhysicalRootCapture.lean b/verification/whir/Whir/SpongefishCurrentPhysicalRootCapture.lean new file mode 100644 index 000000000..4154c1a44 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentPhysicalRootCapture.lean @@ -0,0 +1,541 @@ +import Whir.SpongefishCurrentCommitmentReceive +import Whir.PCSBCSPublicExtractor + +/-! Current #607 raw-header capture at PR600 75d4562bde1efe296b4e32d2a195fdfc232b3ead. +This is an executable public hand-port, not compiler/Rust equivalence. Unlike the +historical packet recognizer, it reads three scalar constants and a raw32 root +from the last closed absorb frame of an exact bounded output key. No saved +record, answer, opening tape, or final-log completion is an input to recognition. + +Physical dimensions follow commit.rs:335-347 and verify.rs:379-405: height is +logN-logBatch+logRate, full leaf width is 2^logBatch, occupied width is lanes. +merkle.rs:167-174,589-590 hashes zeros(full-occupied) || row; verifier.rs:116-117, +152-158 removes the prefix only after authentication. The getter below uses the +existing full-image sourceCells/freeze path, never hashes a compact row instead. +Malformed keys/headers fail; missing images remain unavailable with rectangular +numerical defaults, not authenticated fallback leaves. Error identity/poisoning, +native event instrumentation and the original knowledge-statement join are not +asserted here. -/ +namespace Whir.SpongefishCurrentPhysicalRootCapture +open Concrete FiatShamirGame DuplexFraming DuplexModeGame SpongefishSessionAdapter +open SpongefishPCSRoundFrames SpongefishRecordBindingParser PCSBCSSourceRootReferences +open PublicMerkleLog PCSBCSMerkleRootCache PCSBCSMerkleLeafImages +open DuplexRefinement TypedOracleCompiler +set_option autoImplicit false + +/-- One fixed physical shape, derived from the actual expected header shape. -/ +def physicalShape (shape : SpongefishSessionAdapter.Shape) : PCSBCSMerkleRootCache.Shape := + initialShape shape + +def reference (shape : SpongefishSessionAdapter.Shape) (root : Digest32) : Reference := + ⟨root,physicalShape shape⟩ + +theorem physical_shape (shape : SpongefishSessionAdapter.Shape) : + (physicalShape shape).height = shape.logN-shape.logBatch+shape.logRate ∧ + (physicalShape shape).leafWords = 2^shape.logBatch ∧ + (physicalShape shape).occupied = shape.lanes := ⟨rfl,rfl,rfl⟩ + +theorem occupied_guard (shape : SpongefishSessionAdapter.Shape) (valid : shape.Valid) : + 1 ≤ (physicalShape shape).occupied ∧ + (physicalShape shape).occupied ≤ (physicalShape shape).leafWords ∧ + 0 < (physicalShape shape).height ∧ (physicalShape shape).height < 64 := by + rcases valid with ⟨batch,n,rate,height,lanes,fits⟩ + change 1 ≤ shape.lanes ∧ shape.lanes ≤ 2^shape.logBatch ∧ + 0 < shape.logN-shape.logBatch+shape.logRate ∧ + shape.logN-shape.logBatch+shape.logRate < 64 + exact ⟨lanes,fits,by omega,height⟩ + +/-- Output-key recognition only: exact IV/template/path bound first, literal +current canonical suffix second. It deliberately permits an adversarial earlier +output-key mention, without requiring a current-root-firstMention certificate. -/ +def recognize {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (raw : PublicCompressionCouplingMixed.Key B) : Option Reference := + match raw with + | .inl _ => none + | .inr key => do + let q ← WHIRHeaderRoots.decodeRaw iv key + match q.terminal with + | .output _ => (SpongefishCurrentAnchorHeader.fromHistory shape q.history).map (reference shape) + | _ => none + +def addresses {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (raw : PublicCompressionCouplingMixed.Key B) : List Reference := + (recognize shape iv raw).toList + +theorem recognize_output {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (work : pathCost q ≤ B) + (block : Nat) (terminal : q.terminal = .output block) (root : Digest32) + (header : SpongefishCurrentAnchorHeader.fromHistory shape q.history = some root) : + recognize shape iv (.inr (constructionKey B iv q work)) = some (reference shape root) := by + simp [recognize,WHIRHeaderRoots.decodeRaw_construction iv q valid work,terminal,header] + +theorem recognize_rawHeader {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (work : pathCost q ≤ B) + (block : Nat) (terminal : q.terminal = .output block) (root : Digest32) + (header : SpongefishCurrentAnchorHeader.rawHeader shape iv + (constructionKey B iv q work) = some root) : + recognize shape iv (.inr (constructionKey B iv q work)) = some (reference shape root) := by + have parsed : SpongefishCurrentAnchorHeader.fromHistory shape q.history = some root := by + simpa only [SpongefishCurrentAnchorHeader.rawHeader, + WHIRHeaderRoots.decodeRaw_construction iv q valid work,Option.bind_some] using header + exact recognize_output shape iv q valid work block terminal root parsed + +theorem recognize_sound {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (raw : PublicCompressionCouplingMixed.Key B) (ref : Reference) + (found : recognize shape iv raw = some ref) : + ∃ key q, ∃ work : pathCost q ≤ B, ∃ block previous source, + raw = .inr key ∧ DuplexEncoding.Admissible q ∧ + constructionKey B iv q work = key ∧ q.terminal = .output block ∧ + q.history.frames.getLast? = some (.absorb previous source) ∧ + shape.Valid ∧ List.IsSuffix (SpongefishCurrentAnchorHeader.bytes shape ref.root) source ∧ + ref.shape = physicalShape shape := by + cases raw with + | inl input => simp [recognize] at found + | inr key => + obtain ⟨q,decoded,found⟩ := Option.bind_eq_some_iff.mp found + cases terminal : q.terminal with + | commitment consumed => simp [terminal] at found + | powBase consumed difficulty => simp [terminal] at found + | output block => + simp only [terminal] at found + obtain ⟨root,parsed,equal⟩ := Option.map_eq_some_iff.mp found + subst ref + have rawHeader : SpongefishCurrentAnchorHeader.rawHeader shape iv key = some root := by + simp [SpongefishCurrentAnchorHeader.rawHeader,decoded,parsed] + obtain ⟨other,work,valid,keyEq,previous,source,last,shapeValid,suffix⟩ := + SpongefishCurrentAnchorHeader.rawHeader_sound shape iv key root rawHeader + have otherEq : other = q := by + have otherDecoded := WHIRHeaderRoots.decodeRaw_construction iv other valid work + rw [keyEq,decoded] at otherDecoded + exact (Option.some.inj otherDecoded).symm + subst other + exact ⟨key,q,work,block,previous,source,rfl,valid,keyEq,terminal,last,shapeValid,suffix,rfl⟩ + +/-- Includes wrong IV/template/holes/flags/lengths and over-budget geometry. -/ +theorem malformed_key_rejected {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (key : RawKey B) (bad : WHIRHeaderRoots.decodeRaw iv key = none) : + recognize shape iv (.inr key) = none := by simp [recognize,bad] + +theorem malformed_header_rejected {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (key : RawKey B) (q : Coordinate) + (decoded : WHIRHeaderRoots.decodeRaw iv key = some q) + (bad : SpongefishCurrentAnchorHeader.fromHistory shape q.history = none) : + recognize shape iv (.inr key) = none := by + simp only [recognize,decoded] + change (match q.terminal with + | .output _ => (SpongefishCurrentAnchorHeader.fromHistory shape q.history).map (reference shape) + | _ => none) = none + cases terminal : q.terminal <;> simp [bad] + +theorem invalid_shape_rejected {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (raw : PublicCompressionCouplingMixed.Key B) (invalid : ¬ shape.Valid) : + recognize shape iv raw = none := by + cases found : recognize shape iv raw with + | none => rfl + | some ref => + obtain ⟨_,_,_,_,_,_,_,_,_,_,_,valid,_,_⟩ := recognize_sound shape iv raw ref found + exact (invalid valid).elim + +/-- Every actual sampled-point byte of a successful current receive discloses +its fixed-shape root address at the corresponding literal preanswer output key. +The representation, frame domain and per-key path cap remain explicit. -/ +theorem receive_membership {B : Nat} (c : Compression) (iv : Digest32) + (cur next : Cursor) (shape : SpongefishSessionAdapter.Shape) (r : Record) + (accepted : SpongefishCurrentCommitmentReceive.receive c cur shape = some (next,r)) + (represented : RepresentsCurrent c iv cur.pending cur.state) + (framed : SpongefishCurrentModeQueries.FrameDomain cur.pending) : + ∃ header sampled bytes, ∃ (point : Fin shape.logN → E), + SpongefishCurrentAnchorHeader.readHeader c cur shape = some (header,r.root) ∧ + bytes = (vectorCodec shape.logN).bytes point ∧ r.point = List.ofFn point ∧ + read c sampled .scalar = some (next,r.value) ∧ + ∀ (j : Nat) (_within : j < 24*shape.logN) + (work : pathCost (SpongefishCurrentModeQueries.coordinate header.pending + ((header.pending.consumed+j)/32)) ≤ B), + reference shape r.root ∈ addresses shape iv (.inr (constructionKey B iv + (SpongefishCurrentModeQueries.coordinate header.pending + ((header.pending.consumed+j)/32)) work)) := by + obtain ⟨header,sampled,bytes,point,readHeader,encoded,pointEq,readValue,squeezed,source⟩ := + SpongefishCurrentCommitmentReceive.receive_anchor_source (Q := B) c iv cur next shape r + accepted represented framed + refine ⟨header,sampled,bytes,point,readHeader,encoded,pointEq,readValue,?_⟩ + intro j within work + obtain ⟨valid,parsed,_⟩ := source j within work + have found := recognize_rawHeader shape iv _ valid work _ rfl r.root parsed + simp [addresses,found] + +abbrev Event (B : Nat) := Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32) + +def firstPrefix {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (ref : Reference) (events : List (Event B)) : Option (List (Event B)) := + PCSBCSNativePublicCapture.firstPrefix (addresses shape iv) ref events + +def ordinaryStep {B : Nat} (log : PublicLog) (event : Event B) : PublicLog := + match event.1 with + | .inl input => (input,event.2) :: log + | .inr _ => log + +/-- Convert only completed ordinary draws in the captured prefix. Raw output +answers are not ordinary Merkle hashes, and the triggering answer is absent. -/ +def ordinaryLog {B : Nat} (events : List (Event B)) : PublicLog := + events.foldl ordinaryStep [] + +def capture {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (ref : Reference) (events : List (Event B)) : Option Frozen := + (firstPrefix shape iv ref events).map (fun before => freeze (ordinaryLog before) ref.root ref.shape) + +def root0 {B : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (ref : Reference) (events : List (Event B)) : Option (Array (Array K)) := + (capture shape iv ref events).map Frozen.raw + +/-- General execution join: this is the actual adaptive trace, not a supplied +firstMention certificate. It applies to every current-key sampling program. -/ +theorem firstPrefix_source {B n : Nat} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) (ref : Reference) + (program : Sampling (PublicCompressionCouplingMixed.Key B) (fun _ => Digest32) R n) + (table : PublicCompressionCouplingMixed.Key B → Digest32) : + PCSBCSFirstRootDisclosure.firstMention (addresses shape iv) ref program table = + firstPrefix shape iv ref (Sampling.execute table program).2 := + PCSBCSNativePublicCapture.firstPrefix_execute _ _ _ _ + +theorem firstPrefix_extension {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (events before later : List (Event B)) + (found : firstPrefix shape iv ref events = some before) : + firstPrefix shape iv ref (events ++ later) = some before := by + induction events generalizing before with + | nil => simp [firstPrefix,PCSBCSNativePublicCapture.firstPrefix] at found + | cons event rest ih => + simp only [firstPrefix,PCSBCSNativePublicCapture.firstPrefix] at found ⊢ + split at found + · rename_i present + cases found + simp [PCSBCSNativePublicCapture.firstPrefix,present] + · rename_i absent + obtain ⟨earlierEvents,earlier,equal⟩ := Option.map_eq_some_iff.mp found + subst before + simp only [List.cons_append,PCSBCSNativePublicCapture.firstPrefix,absent,↓reduceIte] + exact congrArg (Option.map (event :: ·)) (ih earlierEvents earlier) + +/-- The prefix excludes the earliest mentioning event and contains no earlier +mention. In particular it is strictly shorter than the trace containing reply. -/ +theorem firstPrefix_earliest {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (events before : List (Event B)) + (found : firstPrefix shape iv ref events = some before) : + ∃ event rest, events = before ++ event :: rest ∧ + ref ∈ addresses shape iv event.1 ∧ firstPrefix shape iv ref before = none := by + induction events generalizing before with + | nil => simp [firstPrefix,PCSBCSNativePublicCapture.firstPrefix] at found + | cons event rest ih => + simp only [firstPrefix,PCSBCSNativePublicCapture.firstPrefix] at found + split at found + · rename_i member + cases found + exact ⟨event,rest,rfl,member,rfl⟩ + · rename_i absent + obtain ⟨earlierEvents,earlier,equal⟩ := Option.map_eq_some_iff.mp found + subst before + obtain ⟨mention,after,source,member,missing⟩ := ih earlierEvents earlier + refine ⟨mention,after,by simp [source],member,?_⟩ + simp only [firstPrefix,PCSBCSNativePublicCapture.firstPrefix,absent,↓reduceIte] + change (firstPrefix shape iv ref earlierEvents).map (event :: ·) = none + rw [missing]; rfl + +theorem firstPrefix_before_reply {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (events before : List (Event B)) + (found : firstPrefix shape iv ref events = some before) : before.length < events.length := by + obtain ⟨event,rest,rfl,_,_⟩ := firstPrefix_earliest shape iv ref events before found + simp only [List.length_append,List.length_cons] + omega + +/-- Earlier adversarial disclosure wins; otherwise the current key freezes +exactly the prior prefix BEFORE this key receives its answer. No final-log fill. -/ +theorem current_reply_prefix {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (prior after : List (Event B)) (event : Event B) + (member : ref ∈ addresses shape iv event.1) : + firstPrefix shape iv ref (prior ++ event :: after) = + some ((firstPrefix shape iv ref prior).getD prior) := by + induction prior with + | nil => simp [firstPrefix,PCSBCSNativePublicCapture.firstPrefix,member] + | cons old prior ih => + simp only [List.cons_append,firstPrefix,PCSBCSNativePublicCapture.firstPrefix] + by_cases present : ref ∈ addresses shape iv old.1 + · simp [present] + · simp only [present,↓reduceIte] + change (firstPrefix shape iv ref (prior ++ event :: after)).map (old :: ·) = + some (((firstPrefix shape iv ref prior).map (old :: ·)).getD (old :: prior)) + rw [ih] + cases firstPrefix shape iv ref prior <;> rfl + +theorem current_capture {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (prior after : List (Event B)) (event : Event B) + (member : ref ∈ addresses shape iv event.1) : + capture shape iv ref (prior ++ event :: after) = some + (freeze (ordinaryLog ((firstPrefix shape iv ref prior).getD prior)) ref.root ref.shape) := by + rw [capture,current_reply_prefix shape iv ref prior after event member]; rfl + +/-- Covers both branches without a selected-prefix premise: an earlier +adversarial mention is strictly earlier, or the whole prior log is frozen. -/ +theorem current_reply_strict {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (prior : List (Event B)) : + ((firstPrefix shape iv ref prior).getD prior).length < prior.length+1 := by + cases found : firstPrefix shape iv ref prior with + | none => simp + | some before => + have strict := firstPrefix_before_reply shape iv ref prior before found + simp only [Option.getD_some] + omega + +theorem current_answer_independent {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (prior after later : List (Event B)) + (key : PublicCompressionCouplingMixed.Key B) (answer other : Digest32) + (member : ref ∈ addresses shape iv key) : + capture shape iv ref (prior ++ ⟨key,answer⟩ :: after) = + capture shape iv ref (prior ++ ⟨key,other⟩ :: later) := by + rw [current_capture shape iv ref prior after ⟨key,answer⟩ member, + current_capture shape iv ref prior later ⟨key,other⟩ member] + +theorem capture_extension {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (events later : List (Event B)) (frozen : Frozen) + (found : capture shape iv ref events = some frozen) : + capture shape iv ref (events ++ later) = some frozen := by + obtain ⟨before,earlier,equal⟩ := Option.map_eq_some_iff.mp found + rw [capture,firstPrefix_extension shape iv ref events before later earlier] + exact congrArg some equal + +theorem root0_extension {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (events later : List (Event B)) (frozen : Frozen) + (found : capture shape iv ref events = some frozen) : + root0 shape iv ref (events ++ later) = root0 shape iv ref events := by + simp only [root0,capture_extension shape iv ref events later frozen found,found] + +/-- Full physical image extraction precedes the compact suffix operation. -/ +theorem freeze_full_image (log : PublicLog) (shape : SpongefishSessionAdapter.Shape) + (root : Digest32) : + imageTable (freeze log root (physicalShape shape)).cells = + PCSBCSMerkleQueryLog.rawRoot0 log root + (physicalShape shape).height (physicalShape shape).leafWords ∧ + (freeze log root (physicalShape shape)).raw = + (PCSBCSMerkleQueryLog.rawRoot0 log root + (physicalShape shape).height (physicalShape shape).leafWords).map + (fun image => (image.toList.drop ((physicalShape shape).leafWords-shape.lanes)).toArray) := + ⟨imageTable_eq_full _ _ _ _ _,compactTable_eq_drop _ _ _ _ _⟩ + +theorem captured_shape {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (root : Digest32) (events : List (Event B)) (frozen : Frozen) + (found : capture shape iv (reference shape root) events = some frozen) : + shape.Valid ∧ frozen.shape = physicalShape shape ∧ + frozen.raw.size = 2^(physicalShape shape).height ∧ + ∀ row ∈ frozen.raw.toList, row.size = shape.lanes := by + obtain ⟨before,earlier,equal⟩ := Option.map_eq_some_iff.mp found + obtain ⟨event,_,_,member,_⟩ := firstPrefix_earliest shape iv _ events before earlier + have recognized : recognize shape iv event.1 = some (reference shape root) := by + simpa only [addresses,Option.mem_toList] using member + obtain ⟨_,_,_,_,_,_,_,_,_,_,_,valid,_,_⟩ := recognize_sound shape iv _ _ recognized + subst frozen + have rectangular := freeze_shape (ordinaryLog before) root (physicalShape shape) + (occupied_guard shape valid).2.1 + exact ⟨valid,rfl,rectangular⟩ + +/-- Literal source leaf hashing is on the full zero-prefixed image. -/ +theorem leaf_hash_full (hash : MerkleTransport.Primitive) (leafWords : Nat) + (index : Nat) (row : List K) : + MerkleTransport.leafNodes hash leafWords [(index,row)] = + [(index,hash (ByteCodec.wordsBytes + (List.replicate (leafWords-row.length) 0 ++ row)))] := rfl + +/-- When a frozen full image is present, its getter keeps that exact image and +only then drops the leading zero lanes. Quantified over all rows, not a chosen +opening witness or a presumed root-equality certificate. -/ +theorem freeze_cell (log : PublicLog) (shape : SpongefishSessionAdapter.Shape) + (valid : shape.Valid) (root : Digest32) (index : Nat) + (inside : index < 2^(physicalShape shape).height) (row : List K) + (width : row.length = shape.lanes) + (present : (PCSBCSMerkleQueryLog.fromPublic log root (physicalShape shape).height).get + (MerkleTransport.addressAbove index (physicalShape shape).height []) = + some (MerkleBinding.leafImage 0 (physicalShape shape).leafWords row)) : + ∃ cell, (freeze log root (physicalShape shape)).cells[index]? = some cell ∧ + cell.image = (MerkleBinding.leafImage 0 (physicalShape shape).leafWords row).toArray ∧ + cell.compact = row.toArray ∧ cell.available = true ∧ cell.paddingValid = true := by + let cell := leafCell (physicalShape shape).leafWords shape.lanes + (MerkleBinding.leafImage 0 (physicalShape shape).leafWords row) + have admitted := leafCell_admitted (physicalShape shape).leafWords shape.lanes row width + (occupied_guard shape valid).2.1 + refine ⟨cell,?_,?_,admitted.2.2,admitted.1,admitted.2.1⟩ + · change (sourceCells log root _ _ _)[index]? = some cell + rw [sourceCells_get _ _ _ _ _ _ inside] + simp only [cellAt,present] + rfl + · have full := MerkleBinding.leafImage_length (0 : K) (physicalShape shape).leafWords row + (width ▸ (occupied_guard shape valid).2.1) + simp only [cell,leafCell,full,↓reduceIte] + +/-- Public observations reconstruct the actual mixed draw trace, with the +source's first-answer seed cache. No historical packet allocation is used. -/ +def publicCapture {B : Nat} {R : Type} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (view : DuplexModeGame.View R) : Option Frozen := + capture shape iv ref (PCSBCSNativePublicCapture.mixedTrace B iv [] view.observations) + +theorem publicCapture_source {B : Nat} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) (ref : Reference) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (program : DuplexModeGame.Program R) (remaining : Nat) (limit : remaining ≤ B) + (counted : DuplexModeGame.Counts remaining program) : + let compiled := PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted + publicCapture (B := B) shape iv ref + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) compiled) = + capture shape iv ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) compiled).2 := by + dsimp only [publicCapture] + rw [PCSBCSNativePublicCapture.mixedTrace_actual B seed ro iv [] program remaining limit counted] + +theorem capture_provenance {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : Reference) (events : List (Event B)) (frozen : Frozen) + (found : capture shape iv ref events = some frozen) : + ∃ before event after, events = before ++ event :: after ∧ + ref ∈ addresses shape iv event.1 ∧ firstPrefix shape iv ref before = none ∧ + frozen = freeze (ordinaryLog before) ref.root ref.shape ∧ + frozen.queryPrefix = ordinaryLog before ∧ before.length < events.length := by + obtain ⟨before,earlier,equal⟩ := Option.map_eq_some_iff.mp found + obtain ⟨event,after,source,member,missing⟩ := + firstPrefix_earliest shape iv ref events before earlier + refine ⟨before,event,after,source,member,missing,equal.symm,?_, + firstPrefix_before_reply shape iv ref events before earlier⟩ + rw [← equal] + rfl + +private theorem fold_ordinary_authentic {B : Nat} (C : PrimitiveOracle) + (events : List (Event B)) + (correct : ∀ event ∈ events, ∀ input, event.1 = .inl input → event.2 = C input) + (prior : PublicLog) (auth : AuthenticLog C prior) : + AuthenticLog C (events.foldl ordinaryStep prior) := by + induction events generalizing prior with + | nil => exact auth + | cons event rest ih => + simp only [List.foldl_cons] + apply ih (fun e member => correct e (List.mem_cons_of_mem _ member)) + intro input answer member + cases keyEq : event.1 with + | inl node => + simp only [ordinaryStep,keyEq,List.mem_cons] at member + rcases member with head | old + · have same := congrArg Prod.fst head + have value := congrArg Prod.snd head + change input = node at same + rw [same] + exact (value.trans (correct event List.mem_cons_self node keyEq)).symm + · exact auth input answer old + | inr key => + simp only [ordinaryStep,keyEq] at member + exact auth input answer member + +/-- Prefix authenticity comes from the actual executed mixed oracle, not a +caller-supplied correspondence or a completed final-log hash table. -/ +theorem captured_source_authentic {B n : Nat} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) (ref : Reference) + (C : PrimitiveOracle) (ro : RawKey B → Digest32) + (program : Sampling (PublicCompressionCouplingMixed.Key B) (fun _ => Digest32) R n) + (frozen : Frozen) + (found : capture shape iv ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle C ro) program).2 = some frozen) : + AuthenticLog C frozen.queryPrefix := by + obtain ⟨before,earlier,equal⟩ := Option.map_eq_some_iff.mp found + rw [← equal] + change AuthenticLog C (ordinaryLog before) + apply fold_ordinary_authentic C before _ [] (by simp [AuthenticLog]) + intro event member input keyEq + have present := PCSBCSNativePublicCapture.firstPrefix_subset (addresses shape iv) ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle C ro) program).2 before + earlier event member + have answer := PCSBCSNativePublicCapture.execute_answers + (PublicCompressionCouplingMixed.oracle C ro) program event present + simpa [keyEq,PublicCompressionCouplingMixed.oracle] using answer + +/-- Actual successful source openings authenticate the full zero-prefixed +images; the frozen getter returns their compact suffixes, or the existing +compression collision/fresh-target event. This does not assume equality of a +frozen root with a separately selected opening tape. The proof and its output +are the very computation in `accepted`, universally quantified. -/ +theorem opened_getter_or_bad (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) (shape : SpongefishSessionAdapter.Shape) + (valid : shape.Valid) (root : Digest32) (proof : MerkleTransport.PrunedMerklePaths) + (queries : List Nat) (output : List MerkleTransport.RawPath) + (accepted : proof.open (hash C) root (2^(physicalShape shape).height) + queries shape.lanes (physicalShape shape).leafWords = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (MerkleTransport.hashing (hash C)), + bytes.length < 2^64) : + (∀ p ∈ output, ∃ row cell, + row.length = shape.lanes ∧ + p.leafData = MerkleBinding.leafImage 0 (physicalShape shape).leafWords row ∧ + (freeze log root (physicalShape shape)).cells[p.leafIndex]? = some cell ∧ + cell.image = p.leafData.toArray ∧ cell.compact = row.toArray ∧ + cell.available = true ∧ cell.paddingValid = true) ∨ + PublicMerkleBinding.OpenPrimitiveBad C log root output := by + have refined := MerkleTransport.open_refines _ _ _ _ _ _ _ _ accepted + have conditions := ((MerkleTransport.open_spec _ _ _ _ _ _ _ _).mp accepted).1 + have facts : ∀ p ∈ output, p.path.length = (physicalShape shape).height ∧ + p.root (hash C) = root := by + intro p member + obtain ⟨q,_,_,_,_,_,_,_,depth,rootEq⟩ := + MerkleTransport.forall₂_mem_right refined member + exact ⟨by simpa only [Nat.log2_two_pow] using depth,rootEq⟩ + rcases PCSBCSMerkleQueryLog.opened_rows C log auth root (physicalShape shape).height output + (fun p member => (facts p member).1) (fun p member => (facts p member).2) bounds with + present | bad + · left + intro p member + obtain ⟨q,qMember,row,_,width,indexEq,imageEq,_,_,_⟩ := + MerkleTransport.forall₂_mem_right refined member + have inside : p.leafIndex < 2^(physicalShape shape).height := by + rw [indexEq] + exact conditions.range q qMember + have full := present p member + rw [imageEq] at full + obtain ⟨cell,lookup,image,compact,available,padding⟩ := + freeze_cell log shape valid root p.leafIndex inside row width full + exact ⟨row,cell,width,imageEq,lookup,by rw [imageEq]; exact image, + compact,available,padding⟩ + · exact Or.inr bad + +/-- The actual Option getter has exactly the first prefix's full-image +extraction followed by occupied-suffix removal; later logs are not consulted. -/ +theorem root0_provenance {B : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (root : Digest32) (events : List (Event B)) (table : Array (Array K)) + (found : root0 shape iv (reference shape root) events = some table) : + ∃ before event after, events = before ++ event :: after ∧ + reference shape root ∈ addresses shape iv event.1 ∧ + firstPrefix shape iv (reference shape root) before = none ∧ + table = (PCSBCSMerkleQueryLog.rawRoot0 (ordinaryLog before) root + (physicalShape shape).height (physicalShape shape).leafWords).map + (fun image => (image.toList.drop ((physicalShape shape).leafWords-shape.lanes)).toArray) := by + obtain ⟨frozen,captured,sameTable⟩ := Option.map_eq_some_iff.mp found + obtain ⟨before,event,after,source,member,missing,frozenEq,_,_⟩ := + capture_provenance shape iv _ events frozen captured + refine ⟨before,event,after,source,member,missing,?_⟩ + rw [← sameTable,frozenEq] + exact (freeze_full_image (ordinaryLog before) shape root).2 + +#print axioms current_reply_strict +#print axioms current_answer_independent +#print axioms root0_provenance +#print axioms publicCapture_source +#print axioms capture_provenance +#print axioms captured_source_authentic +#print axioms opened_getter_or_bad +#print axioms occupied_guard +#print axioms recognize_sound +#print axioms malformed_key_rejected +#print axioms malformed_header_rejected +#print axioms invalid_shape_rejected +#print axioms receive_membership +#print axioms firstPrefix_source +#print axioms firstPrefix_extension +#print axioms firstPrefix_earliest +#print axioms firstPrefix_before_reply +#print axioms current_reply_prefix +#print axioms current_capture +#print axioms capture_extension +#print axioms root0_extension +#print axioms freeze_full_image +#print axioms captured_shape +#print axioms leaf_hash_full +#print axioms freeze_cell +end Whir.SpongefishCurrentPhysicalRootCapture diff --git a/verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean b/verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean new file mode 100644 index 000000000..f48884b33 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean @@ -0,0 +1,620 @@ +import Whir.SpongefishOrdinarySession +import Whir.PublicCompressionProgram + +/-! Executable primitive-event hand-port for the current #607 byte cursor at +75d4562bde1efe296b4e32d2a195fdfc232b3ead. Every compression is an observed +literal primitive query. Arbitrary pre-existing pending/output buffers are +retained. The checked codec rejects insufficient transport before absorption; +its canonical dictionaries are bijective, not a model of additional Rust +malformed-field checks. Hints are the already-decoded separate source channel. +No mode-coupling, whole native acceptance, Rows, or Aeneas join is asserted. -/ +namespace Whir.SpongefishCurrentPrimitiveEventCompiler +open FiatShamirGame DuplexRefinement DuplexModeGame SpongefishPCSRoundFrames +set_option autoImplicit false + +abbrev seq {A B : Type} := @WHIRModeFinal.bind A B + +/-- The only primitive entry point: the literal complete compression node. -/ +def primitive (cv : Digest32) (block : Block64) (tweak : UInt64) + (last : Bool) : Program Digest32 := + .ask (.primitive .auxiliary ⟨cv,block,tweak,last⟩) Program.done + +@[simp] theorem primitive_real (C : PrimitiveOracle) (iv cv : Digest32) + (block : Block64) (tweak : UInt64) (last : Bool) : + (runReal C iv (primitive cv block tweak last)).view.result = + compressionOf C cv block tweak last := rfl + +/-- Consumed output is moved into the previous-frame cursor before the full +pending block is tested, exactly as in absorbByte. -/ +def absorbByteProgram (s : State) (b : Byte) : Program State := + let s := if s.consumed = 0 then s else {s with previous := s.consumed, consumed := 0} + if s.pending.size = 64 then + seq (primitive s.cv (padded s.pending) (absorbTweak s.first false 64 s.previous) true) + (fun d => .done {memoCV s d with pending := #[b], first := false, previous := 0}) + else .done {s with pending := s.pending.push b} + +def absorbProgram : State → List Byte → Program State + | s, [] => .done s + | s, b :: bs => seq (absorbByteProgram s b) (fun t => absorbProgram t bs) + +def finishProgram (s : State) : Program State := + if s.pending.isEmpty then .done s else + seq (primitive s.cv (padded s.pending) + (absorbTweak s.first true s.pending.size s.previous) true) + (fun d => .done {memoCV s d with pending := #[], first := true, previous := 0}) + +def squeezeByteProgram (s : State) : Program (State × Byte) := + let next := fun d => Program.done + ({memoOutput s d with consumed := s.consumed + 1}, + d ⟨s.consumed % 32, Nat.mod_lt _ (by decide)⟩) + if s.consumed % 32 = 0 then + seq (primitive s.cv (wordsBlock [s.consumed / 32]) (UInt64.ofNat (6*2^56)) true) next + else next s.output + +def squeezeLoopProgram : Nat → State → Program (State × List Byte) + | 0, s => .done (s, []) + | n+1, s => seq (squeezeByteProgram s) (fun (t,b) => + seq (squeezeLoopProgram n t) (fun (u,bs) => .done (u,b::bs))) + +/-- Both guards precede finalization, including on arbitrary malformed states. -/ +def squeezeProgram (s : State) (n : Nat) : Program (Except Error (State × List Byte)) := + if n = 0 then .done (.ok (s, [])) + else if s.consumed + n ≤ maxCursor then + seq (finishProgram s) (fun t => + seq (squeezeLoopProgram n t) (fun result => .done (.ok result))) + else .done (.error .cursorExhausted) + +@[simp] theorem absorbByteProgram_real (C : PrimitiveOracle) (iv : Digest32) + (s : State) (b : Byte) : + (runReal C iv (absorbByteProgram s b)).view.result = absorbByte (compressionOf C) s b := by + simp only [absorbByteProgram,absorbByte] + split <;> split <;> + simp [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal,memoCV_eq] + +@[simp] theorem absorbProgram_real (C : PrimitiveOracle) (iv : Digest32) + (s : State) (bs : List Byte) : + (runReal C iv (absorbProgram s bs)).view.result = absorb (compressionOf C) s bs := by + induction bs generalizing s with + | nil => rfl + | cons b bs ih => + simp only [absorbProgram,seq,WHIRModeFinal.bind_real_result,absorbByteProgram_real,ih, + absorb,List.foldl_cons] + +@[simp] theorem finishProgram_real (C : PrimitiveOracle) (iv : Digest32) (s : State) : + (runReal C iv (finishProgram s)).view.result = finish (compressionOf C) s := by + simp only [finishProgram,finish,finalized] + split <;> simp_all [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal,memoCV_eq] + +@[simp] theorem squeezeByteProgram_real (C : PrimitiveOracle) (iv : Digest32) (s : State) : + (runReal C iv (squeezeByteProgram s)).view.result = squeezeByte (compressionOf C) s := by + simp only [squeezeByteProgram,squeezeByte,outputBlock] + split <;> simp_all [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal,memoOutput_eq] + +@[simp] theorem squeezeLoopProgram_real (C : PrimitiveOracle) (iv : Digest32) + (n : Nat) (s : State) : + (runReal C iv (squeezeLoopProgram n s)).view.result = squeezeLoop (compressionOf C) n s := by + induction n generalizing s with + | zero => rfl + | succ n ih => + simp [squeezeLoopProgram,seq,WHIRModeFinal.bind_real_result,squeezeLoop,ih,runReal] + +@[simp] theorem squeezeProgram_real (C : PrimitiveOracle) (iv : Digest32) + (s : State) (n : Nat) : + (runReal C iv (squeezeProgram s n)).view.result = squeeze (compressionOf C) s n := by + unfold squeezeProgram squeeze + split + · rfl + · split + · simp [seq,WHIRModeFinal.bind_real_result,runReal] + · rfl + +/-- Parse is performed before constructing any absorb program. -/ +def readProgram (cur : Cursor) (kind : WireKind) : Program (Option (Cursor × kind.Value)) := + match kind.codec.parse cur.narg with + | none => .done none + | some (value,rest) => + let bytes := kind.codec.bytes value + seq (absorbProgram cur.state bytes) (fun s => .done (some + ({cur with + state := s + pending := bind cur.pending bytes + narg := rest + bytesRead := cur.bytesRead + kind.codec.size + messagesRead := cur.messagesRead + kind.messages + events := cur.events ++ [.prover kind bytes]},value))) + +def squeezeGroupProgram (cur : Cursor) (g : Group) : Program (Except Error (Cursor × List Byte)) := + seq (squeezeProgram cur.state g.bytes) (fun result => .done (match result with + | .error e => .error e + | .ok (s,bytes) => .ok ({cur with + state := s + pending := draw cur.pending g.bytes + events := cur.events ++ [.verifier bytes]},bytes))) + +def hintProgram (cur : Cursor) : Program (Option Cursor) := .done (takeHint cur) + +def publicAbsorbProgram (cur : Cursor) (bytes : List Byte) : Program Cursor := + seq (absorbProgram cur.state bytes) (fun s => .done + {cur with + state := s + pending := bind cur.pending bytes + events := cur.events ++ [.publicBytes bytes]}) + +@[simp] theorem readProgram_real (C : PrimitiveOracle) (iv : Digest32) + (cur : Cursor) (kind : WireKind) : + (runReal C iv (readProgram cur kind)).view.result = read (compressionOf C) cur kind := by + unfold readProgram SpongefishPCSRoundFrames.read + cases kind.codec.parse cur.narg with + | none => rfl + | some pair => rcases pair with ⟨value,rest⟩; simp [seq,WHIRModeFinal.bind_real_result,runReal] + +@[simp] theorem squeezeGroupProgram_real (C : PrimitiveOracle) (iv : Digest32) + (cur : Cursor) (g : Group) : + (runReal C iv (squeezeGroupProgram cur g)).view.result = squeezeGroup (compressionOf C) cur g := by + simp only [squeezeGroupProgram,seq,WHIRModeFinal.bind_real_result,squeezeProgram_real] + unfold squeezeGroup + cases squeeze (compressionOf C) cur.state g.bytes <;> rfl + +@[simp] theorem hintProgram_real (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) : + (runReal C iv (hintProgram cur)).view.result = takeHint cur := rfl + +@[simp] theorem publicAbsorbProgram_real (C : PrimitiveOracle) (iv : Digest32) + (cur : Cursor) (bytes : List Byte) : + (runReal C iv (publicAbsorbProgram cur bytes)).view.result = publicAbsorb (compressionOf C) cur bytes := by + simp [publicAbsorbProgram,seq,WHIRModeFinal.bind_real_result,runReal,publicAbsorb] + +/-- Errors add diagnostics but do not reinterpret source rejection. The reached +cursor is the input to the failing call: reads and guarded draws are atomic. -/ +inductive ReplayError where + | readRejected (kind : WireKind) + | drawRejected (error : Error) + | missingHint + +abbrev ReplayResult := Except (Cursor × ReplayError) Cursor + +def callProgram (cur : Cursor) : Call → Program ReplayResult + | .read kind => seq (readProgram cur kind) (fun result => .done (match result with + | none => .error (cur,.readRejected kind) | some (next,_) => .ok next)) + | .draw g => seq (squeezeGroupProgram cur g) (fun result => .done (match result with + | .error e => .error (cur,.drawRejected e) | .ok (next,_) => .ok next)) + | .hint => .done (match takeHint cur with + | none => .error (cur,.missingHint) | some next => .ok next) + +def replayProgram : Cursor → List Call → Program ReplayResult + | cur, [] => .done (.ok cur) + | cur, call :: calls => seq (callProgram cur call) (fun result => match result with + | .error e => .done (.error e) | .ok next => replayProgram next calls) + +/-- Instrumented actual operations, not independently supplied opening tapes. -/ +def actualCall (c : Compression) (cur : Cursor) : Call → ReplayResult + | .read kind => match read c cur kind with + | none => .error (cur,.readRejected kind) | some (next,_) => .ok next + | .draw g => match squeezeGroup c cur g with + | .error e => .error (cur,.drawRejected e) | .ok (next,_) => .ok next + | .hint => match takeHint cur with + | none => .error (cur,.missingHint) | some next => .ok next + +def actualReplay (c : Compression) : Cursor → List Call → ReplayResult + | cur, [] => .ok cur + | cur, call :: calls => match actualCall c cur call with + | .error e => .error e | .ok next => actualReplay c next calls + +def erase (result : ReplayResult) : Option Cursor := result.toOption + +@[simp] theorem callProgram_real (C : PrimitiveOracle) (iv : Digest32) + (cur : Cursor) (call : Call) : + (runReal C iv (callProgram cur call)).view.result = actualCall (compressionOf C) cur call := by + cases call <;> simp [callProgram,actualCall,seq,WHIRModeFinal.bind_real_result,runReal] + +@[simp] theorem replayProgram_real (C : PrimitiveOracle) (iv : Digest32) + (cur : Cursor) (calls : List Call) : + (runReal C iv (replayProgram cur calls)).view.result = actualReplay (compressionOf C) cur calls := by + induction calls generalizing cur with + | nil => rfl + | cons call calls ih => + simp only [replayProgram,seq,WHIRModeFinal.bind_real_result,callProgram_real,actualReplay] + cases actualCall (compressionOf C) cur call <;> simp [runReal,ih] + +theorem actualCall_erases (c : Compression) (cur : Cursor) (call : Call) : + erase (actualCall c cur call) = replayCall c cur call := by + cases call with + | read kind => + simp only [actualCall,replayCall] + cases SpongefishPCSRoundFrames.read c cur kind <;> rfl + | draw g => + simp only [actualCall,replayCall] + cases squeezeGroup c cur g <;> rfl + | hint => + unfold actualCall replayCall + cases takeHint cur <;> rfl + +theorem actualReplay_erases (c : Compression) (cur : Cursor) (calls : List Call) : + erase (actualReplay c cur calls) = replayCalls c cur calls := by + induction calls generalizing cur with + | nil => rfl + | cons call calls ih => + simp only [actualReplay,replayCalls,← actualCall_erases] + cases actualCall c cur call with + | error => rfl + | ok next => exact ih next + +/-- Unconditional success AND failure correspondence, retaining the entire +reached cursor in the diagnostic result and exact source Option on erasure. -/ +theorem replayProgram_source (C : PrimitiveOracle) (iv : Digest32) + (cur : Cursor) (calls : List Call) : + erase (runReal C iv (replayProgram cur calls)).view.result = + replayCalls (compressionOf C) cur calls := by + rw [replayProgram_real,actualReplay_erases] + +/-- Syntactic provenance excludes any hidden construction queries. -/ +def OnlyPrimitive {R : Type} : Program R → Prop + | .done _ => True + | .ask q next => (∃ n, q = .primitive .auxiliary n) ∧ ∀ d, OnlyPrimitive (next d) + +theorem onlyPrimitive_seq {A B : Type} (p : Program A) (next : A → Program B) + (hp : OnlyPrimitive p) (hn : ∀ a, OnlyPrimitive (next a)) : OnlyPrimitive (seq p next) := by + induction p with + | done a => exact hn a + | ask q cont ih => exact ⟨hp.1,fun d => ih d (hp.2 d)⟩ +theorem seq_done_counted {A B : Type} (p : Program A) (f : A → B) {Q : Nat} + (h : Counts Q p) : Counts Q (seq p (fun a => .done (f a))) := by + simpa using WHIRModeFinal.bind_counted p (fun a => .done (f a)) Q 0 h (fun _ => trivial) + + +theorem primitive_certified (cv : Digest32) (block : Block64) (tweak : UInt64) (last : Bool) : + Counts 1 (primitive cv block tweak last) ∧ OnlyPrimitive (primitive cv block tweak last) := + ⟨⟨Nat.le_refl 1,fun _ => trivial⟩,⟨⟨_,rfl⟩,fun _ => trivial⟩⟩ + +/-- Every visited byte costs at most one primitive, even for arbitrary initial +pending buffers. This is source work, not the number of ideal raw lookups. -/ +theorem absorbByteProgram_certified (s : State) (b : Byte) : + Counts 1 (absorbByteProgram s b) ∧ OnlyPrimitive (absorbByteProgram s b) := by + unfold absorbByteProgram + split <;> dsimp only <;> split + all_goals + first + | exact ⟨⟨Nat.le_refl 1,fun _ => trivial⟩,⟨⟨_,rfl⟩,fun _ => trivial⟩⟩ + | exact ⟨trivial,trivial⟩ + +theorem absorbProgram_certified (s : State) (bs : List Byte) : + Counts bs.length (absorbProgram s bs) ∧ OnlyPrimitive (absorbProgram s bs) := by + induction bs generalizing s with + | nil => exact ⟨trivial,trivial⟩ + | cons b bs ih => + refine ⟨?_,onlyPrimitive_seq _ _ (absorbByteProgram_certified s b).2 (fun t => (ih t).2)⟩ + simpa [absorbProgram,seq,List.length_cons,Nat.add_comm] using WHIRModeFinal.bind_counted _ _ 1 bs.length + (absorbByteProgram_certified s b).1 (fun t => (ih t).1) + +theorem finishProgram_certified (s : State) : + Counts 1 (finishProgram s) ∧ OnlyPrimitive (finishProgram s) := by + unfold finishProgram + split + · exact ⟨trivial,trivial⟩ + · exact ⟨⟨Nat.le_refl 1,fun _ => trivial⟩,⟨⟨_,rfl⟩,fun _ => trivial⟩⟩ + +theorem squeezeByteProgram_certified (s : State) : + Counts 1 (squeezeByteProgram s) ∧ OnlyPrimitive (squeezeByteProgram s) := by + unfold squeezeByteProgram + split + · exact ⟨⟨Nat.le_refl 1,fun _ => trivial⟩,⟨⟨_,rfl⟩,fun _ => trivial⟩⟩ + · exact ⟨trivial,trivial⟩ + +theorem squeezeLoopProgram_certified (n : Nat) (s : State) : + Counts n (squeezeLoopProgram n s) ∧ OnlyPrimitive (squeezeLoopProgram n s) := by + induction n generalizing s with + | zero => exact ⟨trivial,trivial⟩ + | succ n ih => + have tail : ∀ p : State × Byte, Counts n + (seq (squeezeLoopProgram n p.1) (fun (u,bs) => .done (u,p.2::bs))) := by + intro p + exact seq_done_counted _ _ (ih p.1).1 + refine ⟨?_,onlyPrimitive_seq _ _ (squeezeByteProgram_certified s).2 (fun p => + onlyPrimitive_seq _ _ (ih p.1).2 (fun _ => trivial))⟩ + simpa [squeezeLoopProgram,seq,Nat.add_comm] using WHIRModeFinal.bind_counted _ _ 1 n + (squeezeByteProgram_certified s).1 tail + +theorem squeezeProgram_certified (s : State) (n : Nat) : + Counts (n+1) (squeezeProgram s n) ∧ OnlyPrimitive (squeezeProgram s n) := by + unfold squeezeProgram + split + · exact ⟨trivial,trivial⟩ + · split + · refine ⟨?_,onlyPrimitive_seq _ _ (finishProgram_certified s).2 (fun t => + onlyPrimitive_seq _ _ (squeezeLoopProgram_certified n t).2 (fun _ => trivial))⟩ + simpa [Nat.add_comm] using WHIRModeFinal.bind_counted _ _ 1 n + (finishProgram_certified s).1 (fun t => by + exact seq_done_counted _ _ (squeezeLoopProgram_certified n t).1) + · exact ⟨trivial,trivial⟩ + +theorem readProgram_certified (cur : Cursor) (kind : WireKind) : + Counts kind.codec.size (readProgram cur kind) ∧ OnlyPrimitive (readProgram cur kind) := by + unfold readProgram + cases kind.codec.parse cur.narg with + | none => exact ⟨trivial,trivial⟩ + | some pair => + rcases pair with ⟨value,rest⟩ + refine ⟨?_,onlyPrimitive_seq _ _ (absorbProgram_certified _ _).2 (fun _ => trivial)⟩ + have len : (kind.codec.bytes value).length = kind.codec.size := by simp [Codec.bytes] + rw [← len] + exact seq_done_counted _ _ (absorbProgram_certified _ _).1 + +theorem squeezeGroupProgram_certified (cur : Cursor) (g : Group) : + Counts (g.bytes+1) (squeezeGroupProgram cur g) ∧ OnlyPrimitive (squeezeGroupProgram cur g) := by + refine ⟨?_,onlyPrimitive_seq _ _ (squeezeProgram_certified _ _).2 (fun _ => trivial)⟩ + exact seq_done_counted _ _ (squeezeProgram_certified _ _).1 + +def callWork : Call → Nat + | .read kind => kind.codec.size + | .draw g => g.bytes+1 + | .hint => 0 + +def sourceBudget (calls : List Call) : Nat := (calls.map callWork).sum + +theorem callProgram_certified (cur : Cursor) (call : Call) : + Counts (callWork call) (callProgram cur call) ∧ OnlyPrimitive (callProgram cur call) := by + cases call with + | read kind => + refine ⟨?_,onlyPrimitive_seq _ _ (readProgram_certified _ _).2 (fun _ => trivial)⟩ + exact seq_done_counted _ _ (readProgram_certified _ _).1 + | draw g => + refine ⟨?_,onlyPrimitive_seq _ _ (squeezeGroupProgram_certified _ _).2 (fun _ => trivial)⟩ + exact seq_done_counted _ _ (squeezeGroupProgram_certified _ _).1 + | hint => exact ⟨trivial,trivial⟩ + +theorem replayProgram_certified (cur : Cursor) (calls : List Call) : + Counts (sourceBudget calls) (replayProgram cur calls) ∧ OnlyPrimitive (replayProgram cur calls) := by + induction calls generalizing cur with + | nil => exact ⟨trivial,trivial⟩ + | cons call calls ih => + have tails : ∀ result : ReplayResult, Counts (sourceBudget calls) + (match result with | .error e => Program.done (.error e) | .ok next => replayProgram next calls) := by + intro result + cases result with + | error => trivial + | ok next => exact (ih next).1 + refine ⟨?_,onlyPrimitive_seq _ _ (callProgram_certified _ _).2 (fun result => ?_)⟩ + · simpa [replayProgram,seq,sourceBudget] using WHIRModeFinal.bind_counted _ _ (callWork call) (sourceBudget calls) + (callProgram_certified _ _).1 tails + · cases result with + | error => trivial + | ok next => exact (ih next).2 + +/-- Observed literal nodes are answered by the same real C, and the number of +observations is exactly the primitive cost: no hidden calls, no dedup discount. -/ +theorem observed_provenance {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (hp : OnlyPrimitive p) : + (∀ o ∈ (runReal C iv p).view.observations, + ∃ n, o.query = .primitive .auxiliary n ∧ o.answer = C n) ∧ + (runReal C iv p).view.observations.length = (runReal C iv p).primitiveCost := by + induction p with + | done => exact ⟨by simp [runReal],rfl⟩ + | ask q next ih => + obtain ⟨n,rfl⟩ := hp.1 + have h := ih (C n) (hp.2 (C n)) + refine ⟨?_,?_⟩ + · intro o ho + simp only [runReal,realAnswer,prepend,List.mem_cons] at ho + rcases ho with rfl | ho + · exact ⟨n,rfl,rfl⟩ + · exact h.1 o ho + · simp only [runReal,realAnswer,prepend,Query.cost,List.length_cons] + omega + +theorem replay_observed_budget (C : PrimitiveOracle) (iv : Digest32) + (cur : Cursor) (calls : List Call) : + (∀ o ∈ (runReal C iv (replayProgram cur calls)).view.observations, + ∃ n, o.query = .primitive .auxiliary n ∧ o.answer = C n) ∧ + (runReal C iv (replayProgram cur calls)).view.observations.length = + (runReal C iv (replayProgram cur calls)).primitiveCost ∧ + (runReal C iv (replayProgram cur calls)).primitiveCost ≤ sourceBudget calls := + ⟨(observed_provenance C iv _ (replayProgram_certified cur calls).2).1, + (observed_provenance C iv _ (replayProgram_certified cur calls).2).2, + runReal_counts C iv _ _ (replayProgram_certified cur calls).1⟩ + +/-- Explicit linear source budget in literal read/draw bytes plus one per draw. +It does not identify these bytes with ideal construction-coordinate queries. -/ +def byteWork : Call → Nat + | .read kind => kind.codec.size + | .draw g => g.bytes + | .hint => 0 + +theorem sourceBudget_linear (calls : List Call) : + sourceBudget calls ≤ (calls.map byteWork).sum + calls.length := by + induction calls with + | nil => simp [sourceBudget] + | cons call calls ih => + have step : callWork call ≤ byteWork call + 1 := by cases call <;> simp [callWork,byteWork] + simp only [sourceBudget,List.map_cons,List.sum_cons,List.length_cons] at * + omega + +theorem sourceBudget_uniform (calls : List Call) (W : Nat) + (bounded : ∀ call ∈ calls, byteWork call ≤ W) : sourceBudget calls ≤ calls.length * (W+1) := by + induction calls with + | nil => simp [sourceBudget] + | cons call calls ih => + have head := bounded call List.mem_cons_self + have tail := ih (fun c hc => bounded c (List.mem_cons_of_mem _ hc)) + have step : callWork call ≤ byteWork call + 1 := by cases call <;> simp [callWork,byteWork] + simp only [sourceBudget,List.map_cons,List.sum_cons,List.length_cons,Nat.add_mul,Nat.one_mul] at * + omega + +/-- Rejecting parse and exhausted/zero draws issue no primitive at all. -/ +theorem read_rejected_before_absorb (cur : Cursor) (kind : WireKind) + (rejected : kind.codec.parse cur.narg = none) : readProgram cur kind = .done none := by + simp [readProgram,rejected] + +theorem squeeze_zero_before_finish (s : State) : squeezeProgram s 0 = .done (.ok (s,[])) := by + simp [squeezeProgram] + +theorem squeeze_rejected_before_finish (s : State) (n : Nat) + (positive : n ≠ 0) (exhausted : maxCursor < s.consumed+n) : + squeezeProgram s n = .done (.error .cursorExhausted) := by + simp [squeezeProgram,positive,Nat.not_le.mpr exhausted] + +/-- Trace concatenation retains repeated nodes and rejecting-prefix work. -/ +theorem seq_observations {A B : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program A) (next : A → Program B) : + (runReal C iv (seq p next)).view.observations = + (runReal C iv p).view.observations ++ + (runReal C iv (next (runReal C iv p).view.result)).view.observations := by + induction p with + | done => rfl + | ask q cont ih => + simpa only [seq,WHIRModeFinal.bind,runReal,prepend,List.cons_append] using + congrArg (Observation.mk q (realAnswer C iv q) :: ·) (ih (realAnswer C iv q)) + +def record (C : PrimitiveOracle) (n : DuplexFraming.Node) : List Observation := + [⟨.primitive .auxiliary n,C n⟩] + +/-- These source traces compute literal nodes from the actual reached states, +not from ideal raw keys or an independently supplied opening tape. -/ +def absorbByteTrace (C : PrimitiveOracle) (s : State) : List Observation := + let t := if s.consumed = 0 then s else {s with previous := s.consumed, consumed := 0} + if t.pending.size = 64 then + record C ⟨t.cv,padded t.pending,absorbTweak t.first false 64 t.previous,true⟩ + else [] + +def absorbTrace (C : PrimitiveOracle) : State → List Byte → List Observation + | _, [] => [] + | s, b :: bs => absorbByteTrace C s ++ absorbTrace C (absorbByte (compressionOf C) s b) bs + +def finishTrace (C : PrimitiveOracle) (s : State) : List Observation := + if s.pending.isEmpty then [] else + record C ⟨s.cv,padded s.pending,absorbTweak s.first true s.pending.size s.previous,true⟩ + +def squeezeByteTrace (C : PrimitiveOracle) (s : State) : List Observation := + if s.consumed % 32 = 0 then + record C ⟨s.cv,wordsBlock [s.consumed / 32],UInt64.ofNat (6*2^56),true⟩ + else [] + +def squeezeLoopTrace (C : PrimitiveOracle) : Nat → State → List Observation + | 0, _ => [] + | n+1, s => squeezeByteTrace C s ++ + squeezeLoopTrace C n (squeezeByte (compressionOf C) s).1 + +def squeezeTrace (C : PrimitiveOracle) (s : State) (n : Nat) : List Observation := + if n = 0 then [] else if s.consumed+n ≤ maxCursor then + finishTrace C s ++ squeezeLoopTrace C n (finish (compressionOf C) s) + else [] + +@[simp] theorem absorbByteProgram_trace (C : PrimitiveOracle) (iv : Digest32) (s : State) (b : Byte) : + (runReal C iv (absorbByteProgram s b)).view.observations = absorbByteTrace C s := by + simp only [absorbByteProgram,absorbByteTrace] + split <;> split <;> rfl + +@[simp] theorem absorbProgram_trace (C : PrimitiveOracle) (iv : Digest32) (s : State) (bs : List Byte) : + (runReal C iv (absorbProgram s bs)).view.observations = absorbTrace C s bs := by + induction bs generalizing s with + | nil => rfl + | cons b bs ih => simp only [absorbProgram,seq_observations,absorbByteProgram_trace, + absorbByteProgram_real,ih,absorbTrace] + +@[simp] theorem finishProgram_trace (C : PrimitiveOracle) (iv : Digest32) (s : State) : + (runReal C iv (finishProgram s)).view.observations = finishTrace C s := by + unfold finishProgram finishTrace + split <;> rfl + +@[simp] theorem squeezeByteProgram_trace (C : PrimitiveOracle) (iv : Digest32) (s : State) : + (runReal C iv (squeezeByteProgram s)).view.observations = squeezeByteTrace C s := by + unfold squeezeByteProgram squeezeByteTrace + split <;> rfl + +@[simp] theorem squeezeLoopProgram_trace (C : PrimitiveOracle) (iv : Digest32) (n : Nat) (s : State) : + (runReal C iv (squeezeLoopProgram n s)).view.observations = squeezeLoopTrace C n s := by + induction n generalizing s with + | zero => rfl + | succ n ih => + simp only [squeezeLoopProgram,seq_observations,squeezeByteProgram_trace, + squeezeByteProgram_real,ih,runReal,List.append_nil,squeezeLoopTrace] + +@[simp] theorem squeezeProgram_trace (C : PrimitiveOracle) (iv : Digest32) (s : State) (n : Nat) : + (runReal C iv (squeezeProgram s n)).view.observations = squeezeTrace C s n := by + unfold squeezeProgram squeezeTrace + split + · rfl + · split + · simp only [seq_observations,finishProgram_trace,finishProgram_real, + squeezeLoopProgram_trace,runReal,List.append_nil] + · rfl + +def callTrace (C : PrimitiveOracle) (cur : Cursor) : Call → List Observation + | .read kind => match kind.codec.parse cur.narg with + | none => [] | some (value,_) => absorbTrace C cur.state (kind.codec.bytes value) + | .draw g => squeezeTrace C cur.state g.bytes + | .hint => [] + +def replayTrace (C : PrimitiveOracle) : Cursor → List Call → List Observation + | _, [] => [] + | cur, call :: calls => callTrace C cur call ++ + match actualCall (compressionOf C) cur call with + | .error _ => [] | .ok next => replayTrace C next calls + +@[simp] theorem readProgram_trace (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (kind : WireKind) : + (runReal C iv (readProgram cur kind)).view.observations = callTrace C cur (.read kind) := by + simp only [readProgram,callTrace] + cases kind.codec.parse cur.narg with + | none => rfl + | some pair => + rcases pair with ⟨value,rest⟩ + simp only [seq_observations,absorbProgram_trace,runReal,List.append_nil] + +@[simp] theorem squeezeGroupProgram_trace (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (g : Group) : + (runReal C iv (squeezeGroupProgram cur g)).view.observations = callTrace C cur (.draw g) := by + simp only [squeezeGroupProgram,seq_observations,squeezeProgram_trace,runReal,List.append_nil,callTrace] + +@[simp] theorem callProgram_trace (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (call : Call) : + (runReal C iv (callProgram cur call)).view.observations = callTrace C cur call := by + cases call <;> simp only [callProgram,seq_observations,readProgram_trace, + squeezeGroupProgram_trace,runReal,List.append_nil,callTrace] + +/-- Exact trace and exact primitive count, including the work of a rejecting +prefix. The reference trace follows only the actual source-reached cursor. -/ +theorem replayProgram_trace (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (calls : List Call) : + (runReal C iv (replayProgram cur calls)).view.observations = replayTrace C cur calls := by + induction calls generalizing cur with + | nil => rfl + | cons call calls ih => + simp only [replayProgram,seq_observations,callProgram_trace,callProgram_real,replayTrace] + cases actualCall (compressionOf C) cur call <;> simp only [runReal,ih] + +theorem replayProgram_exact_count (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (calls : List Call) : + (runReal C iv (replayProgram cur calls)).primitiveCost = (replayTrace C cur calls).length := by + rw [← replayProgram_trace] + exact (replay_observed_budget C iv cur calls).2.1.symm + +/-- PublicCompressionProgram's executable sampling backend, with the source +budget certificate supplied internally rather than as an acceptance premise. -/ +def compiledReplay (iv : Digest32) (cur : Cursor) (calls : List Call) : + PublicCompressionProgram.Computation (Execution ReplayResult) (sourceBudget calls) := + PublicCompressionProgram.compile iv (replayProgram cur calls) (sourceBudget calls) + (replayProgram_certified cur calls).1 + +theorem compiledReplay_real (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (calls : List Call) : + TypedOracleCompiler.Sampling.eval C (compiledReplay iv cur calls) = runReal C iv (replayProgram cur calls) := + PublicCompressionProgram.compile_eval C iv _ _ _ + +theorem compiledReplay_source (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (calls : List Call) : + (TypedOracleCompiler.Sampling.eval C (compiledReplay iv cur calls)).view.result = actualReplay (compressionOf C) cur calls := by + rw [compiledReplay_real,replayProgram_real] + +#print axioms compiledReplay_real +#print axioms compiledReplay_source + +#print axioms replayProgram_trace +#print axioms replayProgram_exact_count + +#print axioms absorbByteProgram_real +#print axioms absorbProgram_real +#print axioms finishProgram_real +#print axioms squeezeByteProgram_real +#print axioms squeezeLoopProgram_real +#print axioms squeezeProgram_real +#print axioms readProgram_real +#print axioms squeezeGroupProgram_real +#print axioms replayProgram_real +#print axioms replayProgram_source +#print axioms replayProgram_certified +#print axioms replay_observed_budget +#print axioms sourceBudget_linear +#print axioms sourceBudget_uniform +end Whir.SpongefishCurrentPrimitiveEventCompiler diff --git a/verification/whir/Whir/SpongefishCurrentRecordCodecSmoke.lean b/verification/whir/Whir/SpongefishCurrentRecordCodecSmoke.lean new file mode 100644 index 000000000..70425a774 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRecordCodecSmoke.lean @@ -0,0 +1,37 @@ +import Whir.SpongefishCurrentRecordDecoder + +/-! Literal current-codec boundary regression. This exercises the checked +hand-port, not Rust acceptance, read poisoning or cryptographic binding. -/ +open Whir Whir.Concrete Whir.FiatShamirGame Whir.SpongefishSessionAdapter +open Whir.SpongefishCurrentRecordDecoder + +private def changeByte (source : List Byte) (offset : Nat) (value : Byte) : List Byte := + source.zipIdx |>.map fun (b,i) => if i = offset then value else b + +def main : IO Unit := do + for n in [:65] do + for first in [false,true] do + let pending : List Byte := (List.range n).map fun i => ⟨(i+11)%256,Nat.mod_lt _ (by decide)⟩ + let r : Record := { + shape := ⟨2,1,1,1⟩,root := fun i=>⟨i.val+1,by omega⟩, + context := ⟨DuplexRefinement.zeroDigest,pending,first,13,7⟩, + point := [E.ofK 1,E.ofK 2],value := E.ofK 3 } + let bytes := openingBytes r + let some (actual,rest) := decode r.shape (bytes ++ [99]) + | throw (IO.userError s!"valid saved context rejected at {n}/{first}") + unless openingBytes actual = bytes && actual.context.pending = pending && rest = [99] do + throw (IO.userError s!"literal current context changed at {n}/{first}") + let candidates := suffixCandidates r.shape ([23,99,33] ++ bytes) + unless candidates.length ≤ 4 && candidates.any (fun candidate => openingBytes candidate = bytes) do + throw (IO.userError s!"current suffix lost the actual record at {n}/{first}") + unless (decode r.shape (bytes.take (bytes.length-1))).isNone do + throw (IO.userError "truncated literal record accepted") + unless (decode r.shape (changeByte bytes 144 2)).isNone do + throw (IO.userError "noncanonical first flag accepted") + unless (decode r.shape (changeByte bytes 168 1)).isNone do + throw (IO.userError "noncanonical squeezed high word accepted") + if n % 24 ≠ 0 then + unless (decode r.shape (changeByte bytes (184+n) 1)).isNone do + throw (IO.userError s!"nonzero pending padding accepted at {n}") + IO.println "PASS current raw32 record decoder: every pending length 0..64, both first flags, exact point/value and transport suffix, truncation, metadata normalization and zero byte-padding rejection" + (← IO.getStdout).flush diff --git a/verification/whir/Whir/SpongefishCurrentRecordDecoder.lean b/verification/whir/Whir/SpongefishCurrentRecordDecoder.lean new file mode 100644 index 000000000..f24c03b70 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRecordDecoder.lean @@ -0,0 +1,247 @@ +import Whir.SpongefishRecordBindingParser +import Mathlib.Data.List.OfFn + +/-! Literal raw32 saved-record recovery for the current opening grammar. +This is a public-byte parser, not Rust acceptance or failed-read poisoning. -/ +namespace Whir.SpongefishCurrentRecordDecoder +open Concrete FiatShamirGame SpongefishSessionAdapter SpongefishPCSRoundFrames +set_option autoImplicit false + +/-- Exactly the normalized byte image, including all padding after the live suffix. -/ +theorem pending_image (ctx : Context) : + scalarsBytes (pendingPacks ctx) = + List.ofFn (fun i : Fin (((ctx.pending.length+23)/24)*24) => ctx.pending[i.val]?.getD 0) := by + have chunks := List.ofFn_mul + (fun i : Fin (((ctx.pending.length+23)/24)*24) => ctx.pending[i.val]?.getD 0) + unfold scalarsBytes pendingPacks + rw [List.flatMap_def,List.map_ofFn] + change (List.ofFn (fun i : Fin ((ctx.pending.length+23)/24) => + scalarBytes (ByteCodec.decodeE (fun j => ctx.pending[24*i.val+j.val]?.getD 0)))).flatten = _ + simp only [scalarBytes,ByteCodec.encodeE_decodeE] + simpa only [Nat.mul_comm] using chunks.symm + +theorem pending_recovery (ctx : Context) : + (scalarsBytes (pendingPacks ctx)).take ctx.pending.length = ctx.pending := by + rw [pending_image] + have ample : ctx.pending.length ≤ ((ctx.pending.length+23)/24)*24 := by omega + apply List.ext_getElem + · simp only [List.length_take,List.length_ofFn,Nat.min_eq_left ample] + · intro i _ within + simp only [List.getElem_take,List.getElem_ofFn,List.getElem?_eq_getElem within,Option.getD_some] + +def scalars : Nat → List Byte → Option (List E × List Byte) + | 0,bytes => some ([],bytes) + | n+1,bytes => do + let (value,bytes) ← scalarCodec.parse bytes + let (tail,rest) ← scalars n bytes + pure (value::tail,rest) + +theorem scalars_source (n : Nat) (source rest : List Byte) (values : List E) + (accepted : scalars n source = some (values,rest)) : + values.length = n ∧ source = scalarsBytes values ++ rest := by + induction n generalizing source rest values with + | zero => + simp only [scalars,Option.some.injEq,Prod.mk.injEq] at accepted + obtain ⟨rfl,rfl⟩ := accepted + exact ⟨rfl,rfl⟩ + | succ n ih => + simp only [scalars] at accepted + obtain ⟨⟨value,bytes⟩,readValue,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + obtain ⟨⟨tail,after⟩,readTail,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + have tailResult := ih bytes after tail readTail + have equal := Option.some.inj accepted + cases equal + obtain ⟨length,remaining⟩ := tailResult + have before := Codec.canonical_read scalarCodec source bytes value readValue + rw [remaining] at before + exact ⟨by simpa only [List.length_cons] using congrArg Nat.succ length, + by simpa only [scalarsBytes,List.flatMap_cons,List.append_assoc,Codec.bytes, + scalarCodec,scalarBytes] using before⟩ + +theorem scalars_encoded (values : List E) (rest : List Byte) : + scalars values.length (scalarsBytes values ++ rest) = some (values,rest) := by + induction values with + | nil => rfl + | cons value values ih => + simp only [List.length_cons,scalars,scalarsBytes,List.flatMap_cons,List.append_assoc] + change (do + let (value',bytes) ← scalarCodec.parse (scalarCodec.bytes value ++ (scalarsBytes values ++ rest)) + let (tail,rest') ← scalars values.length bytes + pure (value'::tail,rest')) = some (value::values,rest) + rw [Codec.parse_append] + simp [ih] + +/-- The shape is public caller/configuration metadata. Metadata normalization is +checked by exact re-encoding, not by silently discarding malformed high fields. -/ +def decode (shape : AnchoredHeaderCodec.Shape) (source : List Byte) : + Option (Record × List Byte) := do + if ¬ shape.Valid then none else do + let (header,bytes) ← scalars 3 source + if header ≠ constants AnchoredHeaderCodec.openingMarker shape then none else do + let (root,bytes) ← rootCodec.parse bytes + let (cv,bytes) ← rootCodec.parse bytes + let (metadata,bytes) ← scalarCodec.parse bytes + let (squeezed,bytes) ← scalarCodec.parse bytes + let n := metadata.c0.toNat + if 64 < n then none else do + let (packs,bytes) ← scalars ((n+23)/24) bytes + let (point,bytes) ← scalars shape.logN bytes + let (value,rest) ← scalarCodec.parse bytes + let record : Record := { + shape,root,context := ⟨cv,(scalarsBytes packs).take n,metadata.c1 == 1, + metadata.c2,squeezed.c0⟩,point,value } + if source = openingBytes record ++ rest then some (record,rest) else none + +theorem decode_source (shape : AnchoredHeaderCodec.Shape) (source rest : List Byte) + (record : Record) (accepted : decode shape source = some (record,rest)) : + source = openingBytes record ++ rest := by + unfold decode at accepted + split at accepted + · contradiction + · obtain ⟨⟨header,bytes⟩,readHeader,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · contradiction + · obtain ⟨⟨root,bytes⟩,readRoot,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + obtain ⟨⟨cv,bytes⟩,readCV,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + obtain ⟨⟨metadata,bytes⟩,readMetadata,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + obtain ⟨⟨squeezed,bytes⟩,readSqueezed,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · contradiction + · obtain ⟨⟨packs,bytes⟩,readPacks,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + obtain ⟨⟨point,bytes⟩,readPoint,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + obtain ⟨⟨value,rest⟩,readValue,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · rename_i exactSource + have equality := Option.some.inj accepted + cases equality + exact exactSource + · contradiction + +theorem decode_encoded (r : Record) (valid : r.shape.Valid) + (pendingBound : r.context.pending.length ≤ 64) (pointLength : r.point.length = r.shape.logN) + (rest : List Byte) : decode r.shape (openingBytes r ++ rest) = some (r,rest) := by + have pending64 : r.context.pending.length < 2^64 := by omega + have size : (UInt64.ofNat r.context.pending.length).toNat = r.context.pending.length := by + simp only [UInt64.toNat_ofNat',Nat.mod_eq_of_lt pending64] + have packsLength : (pendingPacks r.context).length = (r.context.pending.length+23)/24 := by + simp only [pendingPacks,List.length_ofFn] + have ample : r.context.pending.length ≤ (pendingPacks r.context).length*24 := by + rw [packsLength] + omega + have first : (((if r.context.first then 1 else 0) : K) == 1) = r.context.first := by + cases r.context.first <;> decide + have scalarRead (x : E) (tail : List Byte) : + scalarCodec.parse (scalarBytes x ++ tail) = some (x,tail) := + Codec.parse_append scalarCodec x tail + have rootRead (x : Digest32) (tail : List Byte) : + rootCodec.parse (rawRoot x ++ tail) = some (x,tail) := + Codec.parse_append rootCodec x tail + simp [decode,valid,openingBytes,constants,contextScalars,scalarsBytes, + List.append_assoc,scalars,scalarRead,rootRead, + size,show ¬64 < r.context.pending.length by omega] + have packsRead := scalars_encoded (pendingPacks r.context) + (scalarsBytes r.point ++ (scalarBytes r.value ++ rest)) + simp only [scalarsBytes] at packsRead + rw [← packsLength,packsRead] + simp only [Option.bind_some] + have pointRead := scalars_encoded r.point (scalarBytes r.value ++ rest) + simp only [scalarsBytes] at pointRead + rw [← pointLength,pointRead] + simp only [Option.bind_some] + rw [scalarRead] + simp only [Option.bind_some,Nat.min_eq_left ample] + have pending := pending_recovery r.context + simp only [scalarsBytes] at pending + rw [pending,first] + simp + +/-- Canonical raw32 framing is injective at the fixed public source shape. +This is frame identity, not a cryptographic PCS binding theorem. -/ +theorem opening_injective (r s : Record) (rValid : r.shape.Valid) (sValid : s.shape.Valid) + (rPending : r.context.pending.length ≤ 64) (sPending : s.context.pending.length ≤ 64) + (rPoint : r.point.length = r.shape.logN) (sPoint : s.point.length = s.shape.logN) + (shape : r.shape = s.shape) (image : openingBytes r = openingBytes s) : r = s := by + have left := decode_encoded r rValid rPending rPoint [] + have right := decode_encoded s sValid sPending sPoint [] + simp only [List.append_nil] at left right + rw [shape,image] at left + exact congrArg Prod.fst (Option.some.inj (left.symm.trans right)) + +/-- All four possible pending-pack widths are inspected. Returning candidates +does not assume suffix uniqueness or choose an unproved first match. -/ +def suffixAt (shape : Shape) (source : List Byte) (packs : Nat) : Option Record := do + let (r,rest) ← decode shape (source.drop (source.length-(208+24*(packs+shape.logN)))) + if rest = [] then some r else none + +def suffixCandidates (shape : Shape) (source : List Byte) : List Record := + (List.range 4).filterMap (suffixAt shape source) + +theorem suffixCandidates_length (shape : Shape) (source : List Byte) : + (suffixCandidates shape source).length ≤ 4 := by + exact (List.length_filterMap_le _ _).trans (by simp) + +theorem suffixAt_source (shape : Shape) (source : List Byte) (packs : Nat) (r : Record) + (accepted : suffixAt shape source packs = some r) : + List.IsSuffix (openingBytes r) source := by + unfold suffixAt at accepted + cases read : decode shape (source.drop (source.length-(208+24*(packs+shape.logN)))) with + | none => simp [read] at accepted + | some pair => + obtain ⟨s,rest⟩ := pair + simp only [read] at accepted + change (if rest = [] then some s else none) = some r at accepted + split at accepted + · rename_i empty + have canonical := decode_source shape _ rest s read + cases accepted + rw [empty,List.append_nil] at canonical + exact ⟨source.take (source.length-(208+24*(packs+shape.logN))), + by rw [← canonical]; exact List.take_append_drop _ source⟩ + · contradiction + +theorem suffixCandidates_source (shape : Shape) (source : List Byte) (r : Record) + (member : r ∈ suffixCandidates shape source) : List.IsSuffix (openingBytes r) source := by + obtain ⟨packs,_,accepted⟩ := List.mem_filterMap.mp member + exact suffixAt_source shape source packs r accepted + +theorem suffixCandidates_recovery (r : Record) (valid : r.shape.Valid) + (pending : r.context.pending.length ≤ 64) (point : r.point.length = r.shape.logN) + (pre : List Byte) : r ∈ suffixCandidates r.shape (pre ++ openingBytes r) := by + let packs := (r.context.pending.length+23)/24 + have bound : packs < 4 := by dsimp [packs]; omega + have size : (openingBytes r).length = 208+24*(packs+r.shape.logN) := by + rw [openingBytes_length,point] + apply List.mem_filterMap.mpr + refine ⟨packs,List.mem_range.mpr bound,?_⟩ + unfold suffixAt + simp only [List.length_append,← size,Nat.add_sub_cancel_right,List.drop_left] + have parsed := decode_encoded r valid pending point [] + simp only [List.append_nil] at parsed + rw [parsed] + rfl + +#print axioms suffixCandidates_length +#print axioms suffixAt_source +#print axioms suffixCandidates_source +#print axioms suffixCandidates_recovery + +#print axioms scalars_source +#print axioms opening_injective + +#print axioms decode_encoded + +#print axioms pending_image +#print axioms pending_recovery +#print axioms scalars_encoded +#print axioms decode_source +end Whir.SpongefishCurrentRecordDecoder diff --git a/verification/whir/Whir/SpongefishCurrentRecordModeCapture.lean b/verification/whir/Whir/SpongefishCurrentRecordModeCapture.lean new file mode 100644 index 000000000..9ce0e6ab0 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRecordModeCapture.lean @@ -0,0 +1,130 @@ +import Whir.SpongefishCurrentRecordDecoder +import Whir.WHIRHeaderRoots + +/-! Current opening-record root references are recovered from the actual last +closed absorb body. These are deterministic hand-port transport results, not +Rust acceptance or a completed current native knowledge composition. -/ +namespace Whir.SpongefishCurrentRecordModeCapture +open Concrete FiatShamirGame DuplexRefinement DuplexFraming +open SpongefishSessionAdapter SpongefishPCSRoundFrames SpongefishRecordBindingParser +set_option autoImplicit false + +theorem bind_run (m : Pending) (bytes : List Byte) : + (SpongefishPCSRoundFrames.bind m bytes).run = m.run ++ bytes := by + by_cases empty : bytes = [] <;> simp [SpongefishPCSRoundFrames.bind,empty] + +theorem verifyFields_run (c : Compression) (cur next : Cursor) + (fields : List SpongefishRecordBindingParser.Message) + (accepted : verifyFields c cur fields = some next) : + next.pending.run = cur.pending.run ++ fields.flatMap Message.bytes := by + induction fields generalizing cur with + | nil => simp only [verifyFields,Option.some.injEq] at accepted; cases accepted; simp + | cons message fields ih => + simp only [verifyFields] at accepted + obtain ⟨middle,step,tail⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨rest,_,state⟩ := (checkedRead_exact c cur middle message).mp step + have later := ih middle tail + rw [state] at later + simpa only [advance,bind_run,List.flatMap_cons,List.append_assoc] using later + +theorem verify_run (c : Compression) (cur next : Cursor) (r : Record) + (accepted : verify c cur r = some next) : + next.pending.run = cur.pending.run ++ openingBytes r := by + simpa only [messages_bytes] using verifyFields_run c cur next (messages r) accepted + +/-- Only public frame bytes are inspected. All bounded suffix candidates are +retained; there is no unproved first-match selection. -/ +def records (shape : AnchoredHeaderCodec.Shape) (history : FramedHistory) : List Record := + match history.frames.getLast? with + | some (.absorb _ bytes) => SpongefishCurrentRecordDecoder.suffixCandidates shape bytes + | _ => [] + +theorem records_length (shape : AnchoredHeaderCodec.Shape) (history : FramedHistory) : + (records shape history).length ≤ 4 := by + unfold records + split + · exact SpongefishCurrentRecordDecoder.suffixCandidates_length _ _ + · simp + +theorem closed_record (m : Pending) (r : Record) (pre : List Byte) + (run : m.run = pre ++ openingBytes r) (valid : r.shape.Valid) + (pending : r.context.pending.length ≤ 64) (point : r.point.length = r.shape.logN) : + r ∈ records r.shape (close m).core.history := by + have nonempty : m.run ≠ [] := by + intro empty + have len := congrArg List.length (run.symm.trans empty) + simp only [List.length_append,List.length_nil,openingBytes_length] at len + omega + simp only [records,close,nonempty,↓reduceIte,Pending.core,List.map_append, + List.map_singleton,ByteFrame.historicalCore,List.getLast?_append,List.getLast?_singleton] + change r ∈ SpongefishCurrentRecordDecoder.suffixCandidates r.shape m.run + rw [run] + exact SpongefishCurrentRecordDecoder.suffixCandidates_recovery r valid pending point pre + +theorem verified_record_coordinate (c : Compression) (cur next : Cursor) (r : Record) + (accepted : verify c cur r = some next) (valid : r.shape.Valid) + (pending : r.context.pending.length ≤ 64) (point : r.point.length = r.shape.logN) + (block : Nat) : + r ∈ records r.shape (SpongefishCurrentModeQueries.coordinate next.pending block).history := by + exact closed_record next.pending r cur.pending.run (verify_run c cur next r accepted) + valid pending point + +/-- Exact reconstruction checks the whole raw coordinate, including IV and +template bits, before any current record bytes become root references. -/ +def rawRecords {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) + (raw : DuplexModeGame.RawKey Q) : List Record := + match WHIRHeaderRoots.decodeRaw iv raw with + | none => [] + | some q => records shape q.history + +theorem rawRecords_length {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) + (raw : DuplexModeGame.RawKey Q) : (rawRecords shape iv raw).length ≤ 4 := by + unfold rawRecords + split + · simp + · exact records_length _ _ + +theorem rawRecords_sound {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) + (raw : DuplexModeGame.RawKey Q) (r : Record) (member : r ∈ rawRecords shape iv raw) : + ∃ q : Coordinate, ∃ bound : pathCost q ≤ Q, + DuplexEncoding.Admissible q ∧ DuplexModeGame.constructionKey Q iv q bound = raw ∧ + r ∈ records shape q.history := by + unfold rawRecords at member + cases decoded : WHIRHeaderRoots.decodeRaw iv raw with + | none => simp [decoded] at member + | some q => + simp only [decoded] at member + obtain ⟨bound,valid,exactKey⟩ := WHIRHeaderRoots.decodeRaw_sound iv raw q decoded + exact ⟨q,bound,valid,exactKey,member⟩ + +#print axioms rawRecords_sound + +theorem rawRecords_construction {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (bound : pathCost q ≤ Q) : + rawRecords shape iv (DuplexModeGame.constructionKey Q iv q bound) = records shape q.history := by + rw [rawRecords,WHIRHeaderRoots.decodeRaw_construction iv q valid bound] + +theorem verified_raw_record {Q : Nat} (c : Compression) (cur next : Cursor) (r : Record) + (accepted : verify c cur r = some next) (valid : r.shape.Valid) + (pending : r.context.pending.length ≤ 64) (point : r.point.length = r.shape.logN) + (block : Nat) (iv : Digest32) + (framed : SpongefishCurrentModeQueries.FrameDomain next.pending) (bounded : block < 2^44) + (work : pathCost (SpongefishCurrentModeQueries.coordinate next.pending block) ≤ Q) : + r ∈ rawRecords r.shape iv (DuplexModeGame.constructionKey Q iv + (SpongefishCurrentModeQueries.coordinate next.pending block) work) := by + rw [rawRecords_construction _ _ _ (SpongefishCurrentModeQueries.coordinate_admissible + next.pending framed block bounded) work] + exact verified_record_coordinate c cur next r accepted valid pending point block + +#print axioms rawRecords_length +#print axioms rawRecords_construction +#print axioms verified_raw_record + +#print axioms bind_run +#print axioms verifyFields_run +#print axioms verify_run +#print axioms records_length +#print axioms closed_record +#print axioms verified_record_coordinate +end Whir.SpongefishCurrentRecordModeCapture diff --git a/verification/whir/Whir/SpongefishCurrentRecordOpeningQueries.lean b/verification/whir/Whir/SpongefishCurrentRecordOpeningQueries.lean new file mode 100644 index 000000000..e16cf830a --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRecordOpeningQueries.lean @@ -0,0 +1,40 @@ +import Whir.SpongefishCurrentRecordModeCapture + +/-! The successful current opening parser is joined to the actual next squeeze. +Every returned byte has a bounded whole raw coordinate that retains the parsed +record. This is a deterministic hand-port statement, not Rust correspondence, +a random-oracle independence premise, or a native knowledge theorem. -/ +namespace Whir.SpongefishCurrentRecordOpeningQueries +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishSessionAdapter SpongefishPCSRoundFrames SpongefishRecordBindingParser +set_option autoImplicit false + +/-- Successful parsing and squeezing determine the literal reference and reply +at every byte position. Neither a saved-record equality nor a trusted parser +is supplied. The complete construction path budget remains explicit. -/ +theorem verified_squeezed_byte {Q : Nat} (c : Compression) (iv : Digest32) + (cur next : Cursor) (r : Record) + (accepted : verify c cur r = some next) (valid : r.shape.Valid) + (pending : r.context.pending.length ≤ 64) (point : r.point.length = r.shape.logN) + (represented : RepresentsCurrent c iv next.pending next.state) + (framed : SpongefishCurrentModeQueries.FrameDomain next.pending) + (n : Nat) (positive : n ≠ 0) (state : State) (bytes : List Byte) + (squeezed : squeeze c next.state n = .ok (state,bytes)) (j : Nat) (within : j < n) + (work : pathCost (SpongefishCurrentModeQueries.coordinate next.pending + ((next.pending.consumed+j)/32)) ≤ Q) : + let q := SpongefishCurrentModeQueries.coordinate next.pending + ((next.pending.consumed+j)/32) + r ∈ SpongefishCurrentRecordModeCapture.rawRecords r.shape iv (constructionKey Q iv q work) ∧ + bytes[j]'(by obtain ⟨_,len⟩ := squeeze_exact_cursor c next.state state n bytes squeezed; omega) = + evalCoordinate c iv q ⟨(next.pending.consumed+j)%32,Nat.mod_lt _ (by decide)⟩ := by + constructor + · rw [SpongefishCurrentRecordModeCapture.rawRecords_construction _ _ _ + (SpongefishCurrentModeQueries.squeezed_coordinate_admissible c iv next.pending + next.state state represented framed n positive bytes squeezed j within) work] + exact SpongefishCurrentRecordModeCapture.verified_record_coordinate c cur next r accepted + valid pending point _ + · exact SpongefishCurrentModeQueries.squeezed_byte c iv next.pending next.state state + represented n positive bytes squeezed j within + +#print axioms verified_squeezed_byte +end Whir.SpongefishCurrentRecordOpeningQueries diff --git a/verification/whir/Whir/SpongefishOrdinarySession.lean b/verification/whir/Whir/SpongefishOrdinarySession.lean new file mode 100644 index 000000000..af93030bc --- /dev/null +++ b/verification/whir/Whir/SpongefishOrdinarySession.lean @@ -0,0 +1,141 @@ +import Whir.SpongefishPCSRoundFrames +import Whir.AnchoredByteStreamSampler +import Whir.WHIRModeFinal +import Whir.PublicCompressionCouplingActualCausalBound +import Whir.PublicCompressionModeSecurity + +/-! The current session ID is computed by observed ordinary primitive queries. +This bridge preserves adaptive continuation dependence on that computed ID and +charges the entire derivation before using the ID as the duplex model domain. +It is a hand-port of the pinned ordinary plan, not compiler or native acceptance +refinement. No session ID is conditioned to an externally selected digest. -/ +namespace Whir.SpongefishOrdinarySession +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishSessionAdapter +set_option autoImplicit false + +/-- Sequential ordinary calls retain every repeated input and answer. -/ +def instructions (cv : Digest32) : List DuplexEncoding.Instruction → Program Digest32 + | [] => .done cv + | i :: rest => .ask (.primitive .auxiliary ⟨cv,i.1,i.2,true⟩) + (fun answer => instructions answer rest) + +theorem instructions_counted (cv : Digest32) (xs : List DuplexEncoding.Instruction) : + Counts xs.length (instructions cv xs) := by + induction xs generalizing cv with + | nil => trivial + | cons i rest ih => + simp only [instructions,Counts,Query.cost,List.length_cons] + exact ⟨by omega,fun answer => by simpa using ih answer⟩ + +theorem instructions_real (C : PrimitiveOracle) (iv cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + (runReal C iv (instructions cv xs)).view.result = evalPlan (compressionOf C) cv xs := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => + simpa only [instructions,runReal,prepend,realAnswer,evalPlan,List.foldl_cons,compressionOf] + using ih (C ⟨cv,i.1,i.2,true⟩) + +theorem instructions_observation_count (C : PrimitiveOracle) (iv cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + (runReal C iv (instructions cv xs)).view.observations.length = xs.length := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => + simpa only [instructions,runReal,prepend,realAnswer,List.length_cons] + using congrArg Nat.succ (ih (C ⟨cv,i.1,i.2,true⟩)) + +private theorem derive_cursor (c : Compression) (parameter : Digest32) (tag : List Byte) : + (finish c (absorb c (init c parameter derivationIV) tag)).consumed = 0 := by + rw [finish_consumed] + by_cases empty : tag = [] + · simp [empty,init,seed] + · exact absorb_nonempty_cursor c _ tag empty + +theorem derive_output_block (c : Compression) (parameter : Digest32) (tag : List Byte) : + derive c parameter tag = + outputBlock c (finalized c (absorb c (init c parameter derivationIV) tag)) 0 := by + let s := finish c (absorb c (init c parameter derivationIV) tag) + have cursor : s.consumed = 0 := derive_cursor c parameter tag + have cache : CacheValid c s := by simp [CacheValid,cursor] + funext i + unfold derive + have value := AnchoredByteStreamSampler.squeezeLoop_getElem c s 32 i.val cache i.isLt + simpa only [s,cursor,finish_cv,Nat.zero_add,Nat.div_eq_of_lt i.isLt, + Nat.mod_eq_of_lt i.isLt] using value + +theorem derivation_plan_evaluates (c : Compression) (parameter : Digest32) (tag : List Byte) : + evalPlan c parameter (derivationPlan tag) = derive c parameter tag := by + rw [derive_output_block] + have chunks := chunks_evaluate c (init c parameter derivationIV) tag rfl + change evalPlan c (init c parameter derivationIV).cv + (DuplexEncoding.chunks true 0 [] tag ++ [(wordsBlock [0],UInt64.ofNat (6*2^56))]) = _ + rw [evalPlan_append] + have chunks' : evalPlan c (init c parameter derivationIV).cv + (DuplexEncoding.chunks true 0 [] tag) = + finalized c (absorb c (init c parameter derivationIV) tag) := chunks + rw [chunks'] + rfl + +/-- SessionId::new's entire computation is ordinary observed work. -/ +def deriveProgram (parameter : Digest32) (tag : List Byte) : Program Digest32 := + instructions parameter (derivationPlan tag) + +theorem deriveProgram_counted (parameter : Digest32) (tag : List Byte) : + Counts (derivationPrimitiveCost tag) (deriveProgram parameter tag) := + instructions_counted parameter _ + +theorem deriveProgram_real (C : PrimitiveOracle) (iv parameter : Digest32) (tag : List Byte) : + (runReal C iv (deriveProgram parameter tag)).view.result = + derive (compressionOf C) parameter tag := by + rw [deriveProgram,instructions_real,derivation_plan_evaluates] + +theorem deriveProgram_observation_count (C : PrimitiveOracle) (iv parameter : Digest32) + (tag : List Byte) : + (runReal C iv (deriveProgram parameter tag)).view.observations.length = + 2 + (tag.length+63)/64 := by + rw [deriveProgram,instructions_observation_count] + exact derivation_cost_closed tag + +/-- The continuation receives the actually computed session ID, not a premise. -/ +def afterDerive {R : Type} (parameter : Digest32) (tag : List Byte) + (next : Digest32 → Program R) : Program R := + WHIRModeFinal.bind (deriveProgram parameter tag) next + +theorem afterDerive_counted {R : Type} (parameter : Digest32) (tag : List Byte) + (next : Digest32 → Program R) (B : Nat) (counted : ∀ session, Counts B (next session)) : + Counts (derivationPrimitiveCost tag+B) (afterDerive parameter tag next) := + WHIRModeFinal.bind_counted _ _ _ _ (deriveProgram_counted parameter tag) counted + +theorem afterDerive_real {R : Type} (C : PrimitiveOracle) (iv parameter : Digest32) + (tag : List Byte) (next : Digest32 → Program R) : + (runReal C iv (afterDerive parameter tag next)).view.result = + (runReal C iv (next (derive (compressionOf C) parameter tag))).view.result := by + rw [afterDerive,WHIRModeFinal.bind_real_result,deriveProgram_real] + +open Classical in +/-- The global loss charges ordinary derivation and all adaptive continuation +work together. It is ideal-compression mode security, not BLAKE2s security. -/ +theorem afterDerive_mode_bound {Coins R : Type} [Fintype Coins] + (parameter : Digest32) (tag : List Byte) (B : Nat) + (next : Coins → Digest32 → Program R) + (counted : ∀ coin session, Counts B (next coin session)) (D : View R → Bool) : + let Q := derivationPrimitiveCost tag+B + letI := DuplexPublicSimulator.seedFintype + ModeAdv (DuplexPublicSimulator.simulator Q) parameter + (fun coin => afterDerive parameter tag (next coin)) + (fun coin => afterDerive_counted parameter tag (next coin) B (counted coin)) D ≤ + min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) := by + simpa only [duplexModeLoss_eq] using PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss + (AdvCoins := Coins) (R := R) (derivationPrimitiveCost tag+B) parameter + (fun coin => afterDerive parameter tag (next coin)) + (fun coin => afterDerive_counted parameter tag (next coin) B (counted coin)) D + +#print axioms derivation_plan_evaluates +#print axioms deriveProgram_real +#print axioms deriveProgram_observation_count +#print axioms afterDerive_counted +#print axioms afterDerive_real +#print axioms afterDerive_mode_bound +end Whir.SpongefishOrdinarySession diff --git a/verification/whir/Whir/SpongefishPCSRoundFrames.lean b/verification/whir/Whir/SpongefishPCSRoundFrames.lean new file mode 100644 index 000000000..9586ff2cb --- /dev/null +++ b/verification/whir/Whir/SpongefishPCSRoundFrames.lean @@ -0,0 +1,931 @@ +import Whir.SpongefishPowAdapter +import Whir.RawOracleCoupling + +/-! Current #607 PCS round/cursor bridge, source-inspected at +`75d4562bde1efe296b4e32d2a195fdfc232b3ead`. This is NOT a universal Rust +refinement, a construction-uniformity claim, or a current SourceDriver theorem. +The finite laws below are exact byte-coordinate pushforwards: they do not +assume that the deployed BLAKE sponge produces independent uniform bytes. + +Callsite pins (paths relative to crates/): +* pcs/src/stack.rs:291-296,415-418: record binding, gamma, six map E, lambda; + pcs/src/ring_switch.rs:49,541-545,562-564 fixes the six-map order. +* pcs/src/whir/prove.rs:125-131,150-163,201-216,235-244,263-271,293: + start quadratic; fold E/next quadratic; raw root; OOD; PoW; queries/lambda; + residual before final queries; no polynomial after the last residual draw. +* pcs/src/whir/verify.rs:250-251,277-280,475-477,487-492,518,561-575: + same generic OpeningVerifier calls for native and Rows. +* pcs/src/whir/mod.rs:91-100,111-131: all three E limbs, disjoint chunks, + fixed-count strata, neither sorting nor deduplication. +* pcs/src/verifier.rs:100-105 and leanvm_core/src/rec/verifier/mod.rs: + 153-164,226-251: native/Rows root32, E192, same query grouping. +* fiat_shamir/src/arith.rs:327-335,351-362: only c0,c2 are sent for + the unweighted quadratic. Reconstructed c1 is not an absorbed message. +* fiat_shamir/src/verifier.rs:88-107,155-163,177-185: successful canonical + read absorbs the exact consumed bytes; positive PoW raw32 then LE u64. +* leanvm_core/src/rec/transcript.rs:185-204,224-239: identical whole-word + messages/draws; positive trial constrains the first digest word. + +Bridge hypotheses are explicit: canonical successful reads, successful guarded +squeezes, and initial Represents. Source poisoning, malformed reads, hints/EOF, +Rows free-wire constraints, and a whole-current-event compiler are not proved +here. Session derivation is separately charged by derivationPrimitiveCost; +the session ID may be a fixed model domain only after that ordinary query path +has been accounted for. A whole-current wrapper must retain a dynamic domain +registry when the observed derive answer selects the session ID; this module +does not condition that answer to a fixed registry domain. The current typed +grammar cannot express the old Scalar24 nonce or role7/8/9 terminals. -/ +namespace Whir.SpongefishPCSRoundFrames +open FiatShamirGame Concrete DuplexRefinement SpongefishSessionAdapter +open scoped BigOperators +set_option autoImplicit false + +def sourceRevision : String := SpongefishSessionAdapter.sourceRevision + +/-- A distinct type-level profile: no implicit historical codec conversion. -/ +inductive CodecVersion where | current607 | historical552 + deriving DecidableEq + +def currentVersion : CodecVersion := .current607 + +/-- SHA256 pins of the inspected actual source, not generated-code evidence. -/ +def sourcePins : List (String × String) := + [("pcs/src/whir/prove.rs","4335eb6728ebd7916bb14d086cc4b104e5a547162173316b81cbca97fec7d5d1"), + ("pcs/src/whir/verify.rs","7cb2b200249e3cd842d61aa1b7cf1feb702e1c2ebc03812649a6eb5a5a712add"), + ("pcs/src/whir/mod.rs","990f4a99bca7b4079043ab224972313075ba15fa2172a646fd8de5e91063c327"), + ("pcs/src/whir/commit.rs","e59c1d4052925af940c50166e47baf04024fec41eed745b22f8c86443c5d90bc"), + ("pcs/src/verifier.rs","9e4fb7af8e0180fb575e2f77017632e3808cfdab4f94e4d3a488231dc2b5cdbb"), + ("pcs/src/stack.rs","5d63bc7203f01a97b0823c3c33b874f35ff2e355bcd6334afb4a08ea83e4db27"), + ("pcs/src/ring_switch.rs","422657fcb5045503f4cf203348224693b6f2e9dfe27cc02c3d0de0eaa29b8a02"), + ("leanvm_core/src/rec/verifier/mod.rs","9c81bd01362cfce4cefce0b771f8b169d222d346a5979dbccc7bc62b90cecf44"), + ("leanvm_core/src/rec/transcript.rs","bf770f07c3b85640e01b6d855a4aab069fb848206a3826ed69e29b09c646c894"), + ("fiat_shamir/src/arith.rs","9a98c7470d8ba45c6cc8a0c236b3a2250ab8211a73253883242db75901d8e6f2"), + ("fiat_shamir/src/verifier.rs","afeeef22f1bb90b5142edc076ecc23a525d7efa5310bd6d2511d242e09f97fd9"), + ("fiat_shamir/src/prover.rs","d6d54b2ffa18dbebfaf085be6fb3e4b9364bb6fd28f395aa14c76860f421d3a8")] + + +/-- The only completed frame of the deployed ordinary byte grammar. -/ +inductive ByteFrame where + | absorb (previousConsumed : Nat) (bytes : List Byte) + deriving DecidableEq + +def ByteFrame.historicalCore : ByteFrame → Frame + | .absorb previous bytes => .absorb previous bytes + +structure Pending where + domain : Digest32 + frames : List ByteFrame := [] + run : List Byte := [] + previous : Nat := 0 + consumed : Nat := 0 + +def Pending.core (m : Pending) : Model := + ⟨⟨m.domain,zeroDigest,m.frames.map ByteFrame.historicalCore⟩, + m.run,m.previous,m.consumed⟩ + +def close (m : Pending) : Pending := + if m.run = [] then m else + {m with frames := m.frames ++ [.absorb m.previous m.run], run := [], previous := 0} + +def bind (m : Pending) (bs : List Byte) : Pending := + if bs = [] then m else + {m with + run := m.run ++ bs + previous := if m.consumed = 0 then m.previous else m.consumed + consumed := 0} + +def draw (m : Pending) (n : Nat) : Pending := + if n = 0 then m else {close m with consumed := m.consumed + n} + +theorem close_core (m : Pending) : (close m).core = closeRun m.core := by + by_cases h : m.run = [] <;> simp [close,closeRun,Pending.core,h,List.map_append, + ByteFrame.historicalCore] + +theorem bind_core (m : Pending) (bs : List Byte) : + (bind m bs).core = modelAbsorb m.core bs := by + by_cases h : bs = [] + · simp [bind,modelAbsorb,Pending.core,h] + · simp [bind,modelAbsorb,Pending.core,h] + rfl + +theorem draw_core (m : Pending) (n : Nat) : + (draw m n).core = modelSqueeze m.core n := by + by_cases h : n = 0 + · simp [draw,modelSqueeze,h] + · simp only [draw,modelSqueeze,h,↓reduceIte] + rw [← close_core] + rfl + +/-- No byte of an earlier prover message is lost at a subsequent draw. -/ +def retainedBytes (m : Pending) : List Byte := + (m.frames.flatMap fun f => match f with | .absorb _ bs => bs) ++ m.run + +theorem close_retains (m : Pending) : retainedBytes (close m) = retainedBytes m := by + by_cases h : m.run = [] <;> simp [close,retainedBytes,h,List.flatMap_append] + +theorem draw_retains (m : Pending) (n : Nat) : retainedBytes (draw m n) = retainedBytes m := by + by_cases h : n = 0 + · simp [draw,h] + · simpa [draw,h,retainedBytes] using close_retains m + +theorem bind_retains (m : Pending) (bs : List Byte) : + retainedBytes (bind m bs) = retainedBytes m ++ bs := by + by_cases h : bs = [] <;> simp [bind,retainedBytes,h,List.append_assoc] + +def RepresentsCurrent (c : Compression) (parameter : Digest32) (m : Pending) (s : State) : Prop := + Represents c parameter m.core s + +theorem session_bridge (c : Compression) (parameter session : Digest32) (instanceBytes : List Byte) : + RepresentsCurrent c parameter (bind {domain := session} instanceBytes) + (absorb c (init c parameter session) instanceBytes) := by + unfold RepresentsCurrent + rw [bind_core] + exact session_represents c parameter session instanceBytes + +theorem bind_bridge (c : Compression) (parameter : Digest32) (m : Pending) (s : State) + (h : RepresentsCurrent c parameter m s) (bs : List Byte) : + RepresentsCurrent c parameter (bind m bs) (absorb c s bs) := by + unfold RepresentsCurrent at * + rw [bind_core] + exact absorb_represents c parameter m.core s h bs + +theorem draw_bridge (c : Compression) (parameter : Digest32) (m : Pending) (s t : State) + (h : RepresentsCurrent c parameter m s) (n : Nat) (bytes : List Byte) + (ok : squeeze c s n = .ok (t,bytes)) : + RepresentsCurrent c parameter (draw m n) t := by + unfold RepresentsCurrent at * + rw [draw_core] + exact squeeze_represents c parameter m.core s t h n bytes ok + +/-- Fixed-length canonical codecs; nonce is UInt64, not E/Scalar24. -/ +structure Codec (A : Type) where + size : Nat + encode : A → Fin size → Byte + decode : (Fin size → Byte) → A + decode_encode : ∀ a, decode (encode a) = a + encode_decode : ∀ bs, encode (decode bs) = bs + +def scalarCodec : Codec E := + ⟨24,ByteCodec.encodeE,ByteCodec.decodeE,ByteCodec.decodeE_encodeE,ByteCodec.encodeE_decodeE⟩ +def rootCodec : Codec Digest32 := ⟨32,id,id,fun _ => rfl,fun _ => rfl⟩ +def nonceCodec : Codec UInt64 := + ⟨8,ByteCodec.encodeK,ByteCodec.decodeK,ByteCodec.decodeK_encodeK,ByteCodec.encodeK_decodeK⟩ + +def Codec.bytes {A : Type} (codec : Codec A) (a : A) : List Byte := List.ofFn (codec.encode a) +def Codec.parse {A : Type} (codec : Codec A) (bs : List Byte) : Option (A × List Byte) := + if h : codec.size ≤ bs.length then + some (codec.decode (fun i => bs[i.val]'(by omega)),bs.drop codec.size) + else none + +theorem Codec.parse_append {A : Type} (codec : Codec A) (a : A) (suffix : List Byte) : + codec.parse (codec.bytes a ++ suffix) = some (a,suffix) := by + have len : codec.size ≤ (codec.bytes a ++ suffix).length := by simp [Codec.bytes] + simp only [Codec.parse,len,↓reduceDIte] + have first : (fun i : Fin codec.size => + (codec.bytes a ++ suffix)[i.val]'(by omega)) = codec.encode a := by + funext i + rw [List.getElem_append_left (by simp [Codec.bytes])] + exact List.getElem_ofFn _ + rw [first,codec.decode_encode] + simp [Codec.bytes] + +theorem Codec.canonical_read {A : Type} (codec : Codec A) (bs rest : List Byte) (a : A) + (ok : codec.parse bs = some (a,rest)) : bs = codec.bytes a ++ rest := by + unfold Codec.parse at ok + split at ok + · rename_i h + cases ok + have encoded : codec.bytes (codec.decode (fun i : Fin codec.size => bs[i.val]'(by omega))) = + bs.take codec.size := by + simp only [Codec.bytes,codec.encode_decode] + apply List.ext_getElem + · simp; omega + · intro i hi hj + simp only [List.getElem_ofFn,List.getElem_take] + rw [encoded] + exact (List.take_append_drop codec.size bs).symm + · cases ok + +/-- Byte vectors and E vectors are bijective using every c0,c1,c2 byte. -/ +def vectorEncode (n : Nat) (xs : Fin n → E) : Fin (n*24) → Byte := fun i => + ByteCodec.encodeE (xs ⟨i.val/24,by have := i.isLt; omega⟩) ⟨i.val%24,by omega⟩ +def vectorDecode (n : Nat) (bs : Fin (n*24) → Byte) : Fin n → E := fun j => + ByteCodec.decodeE (fun i => bs ⟨j.val*24+i.val,by have := j.isLt; have := i.isLt; omega⟩) + +theorem vector_decode_encode (n : Nat) (xs : Fin n → E) : + vectorDecode n (vectorEncode n xs) = xs := by + funext j + unfold vectorDecode + have first : (fun i : Fin 24 => vectorEncode n xs + ⟨j.val*24+i.val,by have := j.isLt; have := i.isLt; omega⟩) = ByteCodec.encodeE (xs j) := by + funext i + simp only [vectorEncode] + have div : (j.val*24+i.val)/24 = j.val := by omega + have mod : (j.val*24+i.val)%24 = i.val := by omega + simp only [div,mod] + rw [first,ByteCodec.decodeE_encodeE] + +theorem vector_encode_decode (n : Nat) (bs : Fin (n*24) → Byte) : + vectorEncode n (vectorDecode n bs) = bs := by + funext i + simp only [vectorEncode,vectorDecode,ByteCodec.encodeE_decodeE] + congr 1 + apply Fin.ext + simpa only [Nat.mul_comm] using Nat.div_add_mod i.val 24 + +def vectorCodec (n : Nat) : Codec (Fin n → E) := + ⟨n*24,vectorEncode n,vectorDecode n,vector_decode_encode n,vector_encode_decode n⟩ + +def vectorEquiv (n : Nat) : (Fin (n*24) → Byte) ≃ (Fin n → E) where + toFun := vectorDecode n + invFun := vectorEncode n + left_inv := vector_encode_decode n + right_inv := vector_decode_encode n + +theorem sampleVec_codec (c : Compression) (s t : State) (n : Nat) + (bytes : Fin (n*24) → Byte) + (ok : squeeze c s (24*n) = .ok (t,List.ofFn bytes)) : + sampleVec c s n = .ok (t,List.ofFn (vectorDecode n bytes)) := by + unfold sampleVec + split + · rename_i e hs + rw [ok] at hs + cases hs + · rename_i u bs hs + have values : (u,bs) = (t,List.ofFn bytes) := Except.ok.inj (hs.symm.trans ok) + cases values + apply congrArg Except.ok + apply Prod.ext + · rfl + · apply congrArg List.ofFn + funext j + unfold vectorDecode + apply congrArg ByteCodec.decodeE + funext i + simp only [List.getElem_ofFn] + apply congrArg bytes + apply Fin.ext + simp only [Nat.mul_comm] + + +inductive WireKind where | scalar | root | nonce | vector (count : Nat) +abbrev WireKind.Value : WireKind → Type + | .scalar => E | .root => Digest32 | .nonce => UInt64 | .vector n => Fin n → E +def WireKind.codec : (k : WireKind) → Codec k.Value + | .scalar => scalarCodec | .root => rootCodec | .nonce => nonceCodec | .vector n => vectorCodec n +def WireKind.messages : WireKind → Nat + | .vector n => n | _ => 1 + +/-- Source read counts, remaining transport, earlier outputs and exact messages +are all retained. A hint has no absorb event but remains in the public log. -/ +inductive SourceEvent where + | publicBytes (bytes : List Byte) + | prover (kind : WireKind) (bytes : List Byte) + | verifier (bytes : List Byte) + | hint (bytes : List Byte) + +structure Cursor where + state : State + pending : Pending + narg : List Byte + bytesRead : Nat := 0 + messagesRead : Nat := 0 + hintsRead : Nat := 0 + hints : List (List Byte) := [] + events : List SourceEvent := [] + +def read (c : Compression) (cur : Cursor) (kind : WireKind) : Option (Cursor × kind.Value) := do + let (value,rest) ← kind.codec.parse cur.narg + let bytes := kind.codec.bytes value + pure ({cur with + state := absorb c cur.state bytes + pending := bind cur.pending bytes + narg := rest + bytesRead := cur.bytesRead + kind.codec.size + messagesRead := cur.messagesRead + kind.messages + events := cur.events ++ [.prover kind bytes]},value) + +theorem read_append (c : Compression) (cur : Cursor) (kind : WireKind) + (value : kind.Value) (rest : List Byte) + (source : cur.narg = kind.codec.bytes value ++ rest) : + read c cur kind = some ({cur with + state := absorb c cur.state (kind.codec.bytes value), + pending := bind cur.pending (kind.codec.bytes value), narg := rest, + bytesRead := cur.bytesRead + kind.codec.size, + messagesRead := cur.messagesRead + kind.messages, + events := cur.events ++ [.prover kind (kind.codec.bytes value)]},value) := by + simp [read,source,Codec.parse_append] + +theorem read_bridge (c : Compression) (parameter : Digest32) (cur next : Cursor) + (kind : WireKind) (value : kind.Value) + (h : RepresentsCurrent c parameter cur.pending cur.state) + (ok : read c cur kind = some (next,value)) : + RepresentsCurrent c parameter next.pending next.state ∧ + cur.narg = kind.codec.bytes value ++ next.narg ∧ + next.bytesRead = cur.bytesRead + kind.codec.size ∧ + next.messagesRead = cur.messagesRead + kind.messages ∧ + next.events = cur.events ++ [.prover kind (kind.codec.bytes value)] := by + unfold read at ok + cases hp : kind.codec.parse cur.narg with + | none => simp [hp] at ok + | some pair => + rcases pair with ⟨v,rest⟩ + simp only [hp] at ok + rcases ok with ⟨rfl,rfl⟩ + exact ⟨bind_bridge c parameter cur.pending cur.state h _, + Codec.canonical_read kind.codec cur.narg rest v hp,rfl,rfl,rfl⟩ + +/-- Maximal ordinary uninterrupted PCS draw groups. OOD zero-dimensional +vectors issue no verifier call; a nonempty OOD group carries dimension-1. -/ +inductive Group where + | anchor (dimensionMinusOne : Nat) + | stackFamilyAndLambda + | fold + | ood (dimensionMinusOne : Nat) + | queryAndLambda (depth count : Nat) + | residualFold + | positivePow + | finalDigest + deriving DecidableEq + +def queryDraws (depth count : Nat) : Nat := (count + (192/depth) - 1)/(192/depth) +def Group.elements : Group → Nat + | .anchor d | .ood d => d+1 + | .stackFamilyAndLambda => 8 + | .fold | .residualFold => 1 + | .queryAndLambda depth count => queryDraws depth count + 1 + | .positivePow | .finalDigest => 0 + +def Group.bytes (g : Group) : Nat := + match g with | .positivePow | .finalDigest => 32 | _ => 24*g.elements + +def Group.entropyBits (g : Group) : Nat := 8*g.bytes + +theorem all_group_entropy_min192 (g : Group) : 192 ≤ g.entropyBits := by + cases g <;> simp [Group.entropyBits,Group.bytes,Group.elements] <;> omega + +theorem positive_pow_entropy : Group.positivePow.entropyBits = 256 := rfl + +theorem group_carrier_card (g : Group) : + Fintype.card (Fin g.bytes → Byte) = 2^g.entropyBits := by + simp only [Fintype.card_fun,Fintype.card_fin,Byte,Group.entropyBits] + rw [show (256 : Nat) = 2^8 by decide,← pow_mul] + +def squeezeGroup (c : Compression) (cur : Cursor) (g : Group) : + Except Error (Cursor × List Byte) := do + let (s,bytes) ← squeeze c cur.state g.bytes + pure ({cur with + state := s + pending := draw cur.pending g.bytes + events := cur.events ++ [.verifier bytes]},bytes) + +theorem group_bridge (c : Compression) (parameter : Digest32) (cur : Cursor) + (g : Group) (s : State) (bytes : List Byte) + (h : RepresentsCurrent c parameter cur.pending cur.state) + (ok : squeeze c cur.state g.bytes = .ok (s,bytes)) : + RepresentsCurrent c parameter (draw cur.pending g.bytes) s ∧ + s.consumed = cur.state.consumed + g.bytes ∧ bytes.length = g.bytes := + ⟨draw_bridge c parameter cur.pending cur.state s h g.bytes bytes ok, + squeeze_exact_cursor c cur.state s g.bytes bytes ok⟩ + +theorem query_lambda_grouping (c : Compression) (s : State) (depth count : Nat) + (limit : s.consumed + (Group.queryAndLambda depth count).bytes ≤ maxCursor) : + squeeze c s (Group.queryAndLambda depth count).bytes = + match squeeze c s (24*queryDraws depth count) with + | .error e => .error e + | .ok (t,xs) => match squeeze c t 24 with + | .error e => .error e + | .ok (u,ys) => .ok (u,xs++ys) := + query_lambda_concatenates c s (queryDraws depth count) limit + +theorem query_chunks_length (depth : Nat) (x : E) : + (queryChunks depth x).length = 192/depth := by simp [queryChunks] + +theorem query_chunk_vector_length (depth : Nat) (xs : List E) : + (xs.flatMap (queryChunks depth)).length = xs.length * (192/depth) := by + induction xs with + | nil => simp + | cons x xs ih => + simp only [List.flatMap_cons,List.length_append,query_chunks_length,ih,List.length_cons] + simp only [Nat.add_mul,Nat.one_mul] + omega + +/-- Native and Rows loop termination requires 1 <= depth < 64. Invalid +depth/count totalizations here are not Rust panic/overflow semantics. -/ +theorem query_draws_adequate (depth count : Nat) (positive : 0 < depth) (small : depth < 64) : + count ≤ queryDraws depth count * (192/depth) := by + have per : 0 < 192/depth := Nat.div_pos (by omega) positive + have rem := Nat.mod_lt (count + (192/depth) - 1) per + have split := Nat.mod_add_div (count + (192/depth) - 1) (192/depth) + unfold queryDraws + rw [Nat.mul_comm] + omega + + +/-- Current PoW source schedule: zero has neither a read nor a byte event. +Positive has one raw32 group followed by one canonical LE UInt64 read. -/ +inductive Call where + | read (kind : WireKind) + | draw (group : Group) + | hint + +def powSchedule (bits : Fin 64) : List Call := + if bits.val = 0 then [] else [.draw .positivePow,.read .nonce] + +def querySchedule (depth count : Nat) (bits : Fin 64) : List Call := + powSchedule bits ++ [.draw (.queryAndLambda depth count),.hint,.read (.vector 2)] + +def oodSchedule (dimension : Nat) : List Call := + (if dimension = 0 then [] else [.draw (.ood (dimension-1))]) ++ + [.read .scalar,.read (.vector 2)] + +def foldSchedule : List Call := [.draw .fold,.read (.vector 2)] +def residualSchedule (rounds : Nat) : List Call := + (List.range rounds).flatMap fun j => + [.draw .residualFold] ++ (if j+1 < rounds then [.read (.vector 2)] else []) + +def rootBoundarySchedule (dimension oodCount depth count : Nat) (bits : Fin 64) : List Call := + [.read .root] ++ (List.replicate oodCount (oodSchedule dimension)).flatten ++ + querySchedule depth count bits + +def finalBoundarySchedule (dimension depth count : Nat) (bits : Fin 64) : List Call := + [.read (.vector (2^dimension))] ++ querySchedule depth count bits ++ residualSchedule dimension + +/-- Normalized successful-read replay, not a verifier acceptance machine. +PoW's work predicate is checked separately by checkPow below. Hints have +already been decoded successfully from the separate hint channel. -/ +def takeHint (cur : Cursor) : Option Cursor := + match cur.hints with + | [] => none + | bs :: rest => some {cur with + hints := rest + hintsRead := cur.hintsRead + 1 + events := cur.events ++ [.hint bs]} + +def publicAbsorb (c : Compression) (cur : Cursor) (bytes : List Byte) : Cursor := + {cur with + state := absorb c cur.state bytes + pending := bind cur.pending bytes + events := cur.events ++ [.publicBytes bytes]} + +def replayCall (c : Compression) (cur : Cursor) : Call → Option Cursor + | .read kind => (read c cur kind).map Prod.fst + | .draw g => match squeezeGroup c cur g with | .error _ => none | .ok result => some result.1 + | .hint => takeHint cur + +def replayCalls (c : Compression) : Cursor → List Call → Option Cursor + | cur, [] => some cur + | cur, call :: calls => do + let next ← replayCall c cur call + replayCalls c next calls + +theorem replayCall_bridge (c : Compression) (parameter : Digest32) (cur next : Cursor) + (call : Call) (h : RepresentsCurrent c parameter cur.pending cur.state) + (ok : replayCall c cur call = some next) : + RepresentsCurrent c parameter next.pending next.state := by + cases call with + | read kind => + simp only [replayCall] at ok + cases hr : read c cur kind with + | none => simp [hr] at ok + | some pair => + rcases pair with ⟨t,value⟩ + simp only [hr,Option.map_some,Option.some.injEq] at ok + subst next + exact (read_bridge c parameter cur t kind value h hr).1 + | draw g => + simp only [replayCall,squeezeGroup] at ok + cases hs : squeeze c cur.state g.bytes with + | error e => simp [hs] at ok + | ok pair => + rcases pair with ⟨s,bytes⟩ + simp only [hs] at ok + cases ok + exact draw_bridge c parameter cur.pending cur.state s h g.bytes bytes hs + | hint => + simp only [replayCall,takeHint] at ok + cases hh : cur.hints with + | nil => simp [hh] at ok + | cons bs rest => + simp only [hh,Option.some.injEq] at ok + subst next + exact h + +theorem all_round_replay_bridge (c : Compression) (parameter : Digest32) + (cur next : Cursor) (calls : List Call) + (h : RepresentsCurrent c parameter cur.pending cur.state) + (ok : replayCalls c cur calls = some next) : + RepresentsCurrent c parameter next.pending next.state := by + induction calls generalizing cur with + | nil => + simp only [replayCalls,Option.some.injEq] at ok + subst next + exact h + | cons call calls ih => + simp only [replayCalls] at ok + cases hc : replayCall c cur call with + | none => simp [hc] at ok + | some middle => + simp only [hc] at ok + exact ih middle (replayCall_bridge c parameter cur middle call h hc) ok + +def SourceEvent.proverBytes : SourceEvent → List Byte + | .prover _ bytes => bytes | _ => [] +def SourceEvent.proverCount : SourceEvent → Nat + | .prover kind _ => kind.messages | _ => 0 +def SourceEvent.hintCount : SourceEvent → Nat + | .hint _ => 1 | _ => 0 +def SourceEvent.model (m : Pending) : SourceEvent → Pending + | .publicBytes bytes | .prover _ bytes => bind m bytes + | .verifier bytes => draw m bytes.length + | .hint _ => m + +/-- An exact extension, retaining all earlier messages, outputs and counts. +This is about successful normalized source replay, not Rust acceptance. -/ +def Extends (cur next : Cursor) : Prop := + ∃ suffix : List SourceEvent, + next.events = cur.events ++ suffix ∧ + cur.narg = suffix.flatMap SourceEvent.proverBytes ++ next.narg ∧ + next.bytesRead = cur.bytesRead + (suffix.flatMap SourceEvent.proverBytes).length ∧ + next.messagesRead = cur.messagesRead + (suffix.map SourceEvent.proverCount).sum ∧ + next.hintsRead = cur.hintsRead + (suffix.map SourceEvent.hintCount).sum ∧ + next.pending = suffix.foldl SourceEvent.model cur.pending + +theorem extends_refl (cur : Cursor) : Extends cur cur := by + exact ⟨[],by simp⟩ + +theorem extends_trans (a b c : Cursor) (ab : Extends a b) (bc : Extends b c) : Extends a c := by + rcases ab with ⟨xs,eventsAB,nargAB,bytesAB,messagesAB,hintsAB,modelAB⟩ + rcases bc with ⟨ys,eventsBC,nargBC,bytesBC,messagesBC,hintsBC,modelBC⟩ + refine ⟨xs++ys,?_,?_,?_,?_,?_,?_⟩ + · simp only [eventsBC,eventsAB,List.append_assoc] + · rw [List.flatMap_append,List.append_assoc,nargAB,nargBC] + · simp only [List.flatMap_append,List.length_append,bytesBC,bytesAB,Nat.add_assoc] + · simp only [List.map_append,List.sum_append,messagesBC,messagesAB,Nat.add_assoc] + · simp only [List.map_append,List.sum_append,hintsBC,hintsAB,Nat.add_assoc] + · simp only [List.foldl_append,modelBC,modelAB] + +theorem replayCall_transport (c : Compression) (cur next : Cursor) (call : Call) + (ok : replayCall c cur call = some next) : Extends cur next := by + cases call with + | read kind => + cases hp : kind.codec.parse cur.narg with + | none => simp [replayCall,read,hp] at ok + | some pair => + rcases pair with ⟨value,rest⟩ + simp [replayCall,read,hp] at ok + subst next + refine ⟨[.prover kind (kind.codec.bytes value)],?_,?_,?_,?_,?_,?_⟩ + · rfl + · simpa [SourceEvent.proverBytes] using Codec.canonical_read kind.codec cur.narg rest value hp + · simp [SourceEvent.proverBytes,Codec.bytes] + · simp [SourceEvent.proverCount] + · simp [SourceEvent.hintCount] + · rfl + | draw g => + cases hs : squeeze c cur.state g.bytes with + | error e => simp [replayCall,squeezeGroup,hs] at ok + | ok pair => + rcases pair with ⟨s,bytes⟩ + simp [replayCall,squeezeGroup,hs] at ok + subst next + refine ⟨[.verifier bytes],rfl,?_,?_,?_,?_,?_⟩ + · simp [SourceEvent.proverBytes] + · simp [SourceEvent.proverBytes] + · simp [SourceEvent.proverCount] + · simp [SourceEvent.hintCount] + · simp [SourceEvent.model,(squeeze_exact_cursor c cur.state s g.bytes bytes hs).2] + | hint => + cases hh : cur.hints with + | nil => simp [replayCall,takeHint,hh] at ok + | cons bytes rest => + simp [replayCall,takeHint,hh] at ok + subst next + refine ⟨[.hint bytes],rfl,?_,?_,?_,?_,?_⟩ + · simp [SourceEvent.proverBytes] + · simp [SourceEvent.proverBytes] + · simp [SourceEvent.proverCount] + · simp [SourceEvent.hintCount] + · rfl + +theorem all_round_transport (c : Compression) (cur next : Cursor) (calls : List Call) + (ok : replayCalls c cur calls = some next) : Extends cur next := by + induction calls generalizing cur with + | nil => + simp only [replayCalls,Option.some.injEq] at ok + subst next + exact extends_refl cur + | cons call calls ih => + simp only [replayCalls] at ok + cases hc : replayCall c cur call with + | none => simp [hc] at ok + | some middle => + simp only [hc] at ok + exact extends_trans cur middle next (replayCall_transport c cur middle call hc) (ih middle ok) + + +/-- Every call in these schedules is one of the actual PCS/native/Rows wire +operations. Grouped vector reads preserve the individual message count. -/ +def recordBindingSchedule (r : Record) : List Call := + [.read (.vector 3),.read .root,.read .root,.read (.vector 2), + .read (.vector ((r.context.pending.length+23)/24)),.read (.vector r.point.length),.read .scalar] + +def readBytes : Call → Nat + | .read kind => kind.codec.size | _ => 0 +def readMessages : Call → Nat + | .read kind => kind.messages | _ => 0 + +theorem record_binding_bytes (r : Record) : + ((recordBindingSchedule r).map readBytes).sum = (openingBytes r).length := by + rw [openingBytes_length] + simp [recordBindingSchedule,readBytes,WireKind.codec,vectorCodec,scalarCodec,rootCodec] + omega + +theorem record_binding_messages (r : Record) : + ((recordBindingSchedule r).map readMessages).sum = + 8 + (r.context.pending.length+23)/24 + r.point.length := by + simp [recordBindingSchedule,readMessages,WireKind.messages] + omega + +/-- Exact metadata framing shared by the native and Rows call sequence in +commit.rs:124-164,219-241. Raw root/CV and normalized pending bytes remain +in the ordinary absorb run, before any stack-family challenge. -/ +theorem sourceMetadataFraming (c : Compression) (parameter : Digest32) + (m : Pending) (s : State) (r : Record) + (h : RepresentsCurrent c parameter m s) : + RepresentsCurrent c parameter (bind m (openingBytes r)) + (absorbMessages c s (openingMessages r)) := by + rw [opening_grouping] + exact bind_bridge c parameter m s h _ + +theorem source_record_binding_counts (r : Record) (pointShape : r.point.length = r.shape.logN) : + ((recordBindingSchedule r).map readBytes).sum = + 208 + 24*((r.context.pending.length+23)/24 + r.shape.logN) ∧ + ((recordBindingSchedule r).map readMessages).sum = + 8 + (r.context.pending.length+23)/24 + r.shape.logN := by + rw [record_binding_bytes,record_binding_messages,openingBytes_length,pointShape] + exact ⟨rfl,rfl⟩ + + +structure Boundary where + dimension : Nat + oodCount : Nat + depth : Nat + count : Nat + grinding : Fin 64 + +def Boundary.schedule (b : Boundary) : List Call := + rootBoundarySchedule b.dimension b.oodCount b.depth b.count b.grinding + +/-- Literal current source loop layout after the record binding. Shape/config +checks and PCS equations remain upstream, not new soundness premises here. -/ +structure OpeningLayout where + initialRounds : Nat + firstBoundary : Boundary + intermediate : List (Nat × Boundary) + finalFoldRounds : Nat + residualDimension : Nat + finalDepth : Nat + finalCount : Nat + finalGrinding : Fin 64 + +def OpeningLayout.schedule (layout : OpeningLayout) : List Call := + [.draw .stackFamilyAndLambda,.read (.vector 2)] ++ + (List.replicate layout.initialRounds foldSchedule).flatten ++ + layout.firstBoundary.schedule ++ + layout.intermediate.flatMap (fun stage => + (List.replicate stage.1 foldSchedule).flatten ++ stage.2.schedule) ++ + (List.replicate layout.finalFoldRounds foldSchedule).flatten ++ + finalBoundarySchedule layout.residualDimension layout.finalDepth layout.finalCount layout.finalGrinding + +theorem all_actual_schedule_entropy (layout : OpeningLayout) (g : Group) + (_callsite : Call.draw g ∈ layout.schedule) : 192 ≤ g.entropyBits := + all_group_entropy_min192 g + + +theorem zero_pow_schedule : powSchedule ⟨0,by decide⟩ = [] := rfl + +theorem positive_pow_schedule (bits : Fin 64) (positive : bits.val ≠ 0) : + powSchedule bits = [.draw .positivePow,.read .nonce] := by simp [powSchedule,positive] + +theorem zero_query_schedule (depth count : Nat) : + querySchedule depth count ⟨0,by decide⟩ = + [.draw (.queryAndLambda depth count),.hint,.read (.vector 2)] := rfl + +theorem positive_query_schedule (depth count : Nat) (bits : Fin 64) (positive : bits.val ≠ 0) : + querySchedule depth count bits = [.draw .positivePow,.read .nonce, + .draw (.queryAndLambda depth count),.hint,.read (.vector 2)] := by + simp [querySchedule,positive_pow_schedule bits positive] + +/-- Reuses the exact deployed checked trial/buffers; difficulty is not used as +verifier entropy. This helper includes predicate failures, not poisoned reads. -/ +def checkPow := SpongefishPowAdapter.check + +theorem positive_pow_bridge (C : DuplexModeGame.PrimitiveOracle) (parameter : Digest32) + (m : Pending) (s t : State) (bits : Fin 64) (nonce : UInt64) (challenge : Digest32) + (h : RepresentsCurrent (DuplexModeGame.compressionOf C) parameter m s) + (positive : bits.val ≠ 0) + (ok : squeeze (DuplexModeGame.compressionOf C) s 32 = .ok (t,List.ofFn challenge)) : + checkPow C s bits nonce = .ok + (absorb (DuplexModeGame.compressionOf C) t (SpongefishPowAdapter.nonceBytes nonce), + SpongefishPowAdapter.clears bits (SpongefishPowAdapter.trial C challenge nonce)) ∧ + RepresentsCurrent (DuplexModeGame.compressionOf C) parameter + (bind (draw m 32) (SpongefishPowAdapter.nonceBytes nonce)) + (absorb (DuplexModeGame.compressionOf C) t (SpongefishPowAdapter.nonceBytes nonce)) := + ⟨SpongefishPowAdapter.positive_checked C s t bits nonce challenge positive ok, + bind_bridge _ parameter _ t (draw_bridge _ parameter m s t h 32 _ ok) _⟩ + +theorem zero_pow_bridge (C : DuplexModeGame.PrimitiveOracle) (s : State) (nonce : UInt64) : + checkPow C s ⟨0,by decide⟩ nonce = .ok (s,true) := rfl + +theorem nonce_codec_matches (nonce : UInt64) : + nonceCodec.bytes nonce = SpongefishPowAdapter.nonceBytes nonce := rfl + +theorem root_codec_matches (root : Digest32) : rootCodec.bytes root = rawRoot root := rfl + +theorem scalar_codec_matches (x : E) : scalarCodec.bytes x = scalarBytes x := rfl + +/-- Successful normalized source PoW cursor. Unlike the byte-event replay, +this computes the actual checked predicate and keeps the nonce-bound state +even when that predicate is false. Missing nonce transport fails the read. -/ +def powCursor (C : DuplexModeGame.PrimitiveOracle) (cur : Cursor) (bits : Fin 64) : + Option (Cursor × Bool) := + if bits.val = 0 then some (cur,true) else + match squeezeGroup (DuplexModeGame.compressionOf C) cur .positivePow with + | .error _ => none + | .ok (challenged,bytes) => do + let (next,nonce) ← read (DuplexModeGame.compressionOf C) challenged .nonce + let challenge : Digest32 := fun i => bytes[i.val]?.getD 0 + pure (next,SpongefishPowAdapter.clears bits (SpongefishPowAdapter.trial C challenge nonce)) + +theorem zero_pow_cursor (C : DuplexModeGame.PrimitiveOracle) (cur : Cursor) : + powCursor C cur ⟨0,by decide⟩ = some (cur,true) := rfl + +theorem positive_pow_cursor (C : DuplexModeGame.PrimitiveOracle) (cur : Cursor) + (bits : Fin 64) (nonce : UInt64) (challenge : Digest32) (t : State) (rest : List Byte) + (positive : bits.val ≠ 0) + (drawOK : squeeze (DuplexModeGame.compressionOf C) cur.state 32 = .ok (t,List.ofFn challenge)) + (readOK : cur.narg = nonceCodec.bytes nonce ++ rest) : + powCursor C cur bits = some + ({cur with + state := absorb (DuplexModeGame.compressionOf C) t (nonceCodec.bytes nonce) + pending := bind (draw cur.pending 32) (nonceCodec.bytes nonce) + narg := rest + bytesRead := cur.bytesRead + 8 + messagesRead := cur.messagesRead + 1 + events := cur.events ++ [.verifier (List.ofFn challenge),.prover .nonce (nonceCodec.bytes nonce)]}, + SpongefishPowAdapter.clears bits (SpongefishPowAdapter.trial C challenge nonce)) := by + have decoded : (fun i : Fin 32 => (List.ofFn challenge)[i.val]?.getD 0) = challenge := by + funext i + simp only [List.getElem?_ofFn,dite_eq_left i.isLt,Option.getD_some] + simp only [powCursor,positive,↓reduceIte,squeezeGroup,Group.bytes,drawOK] + dsimp only [Bind.bind,Pure.pure,Except.instMonad,Except.bind,Except.pure] + simp only [read,WireKind.codec] + dsimp only [Bind.bind,Pure.pure] + rw [readOK,Codec.parse_append] + simp only [Option.bind_some] + rw [decoded] + simp only [WireKind.messages,List.append_assoc] + rfl + + +/-- Exact finite fresh-vector law, not a premise asserting uniformity. The +coordinate space is literal bytes and the inverse codec is proved above. -/ +private noncomputable instance : Fintype E := + Fintype.ofEquiv Scalar24 + {toFun := ByteCodec.decodeE, invFun := ByteCodec.encodeE, + left_inv := ByteCodec.encodeE_decodeE, right_inv := ByteCodec.decodeE_encodeE} + +theorem full_vector_distribution (n : Nat) (payoff : (Fin n → E) → ℚ) : + average (fun bs : Fin (n*24) → Byte => payoff (vectorDecode n bs)) = average payoff := + RawOracleCoupling.average_equiv (vectorEquiv n) payoff + +def Codec.equiv {A : Type} (codec : Codec A) : (Fin codec.size → Byte) ≃ A where + toFun := codec.decode + invFun := codec.encode + left_inv := codec.encode_decode + right_inv := codec.decode_encode + +def Group.Response (g : Group) : Type := + match g with | .positivePow | .finalDigest => Digest32 | _ => Fin g.elements → E + +def Group.codec (g : Group) : Codec g.Response := + match g with + | .positivePow | .finalDigest => rootCodec + | .anchor d | .ood d => vectorCodec (d+1) + | .stackFamilyAndLambda => vectorCodec 8 + | .fold | .residualFold => vectorCodec 1 + | .queryAndLambda depth count => vectorCodec (queryDraws depth count+1) + +private noncomputable instance (g : Group) : Fintype g.Response := by + cases g <;> dsimp [Group.Response,Group.elements] <;> infer_instance + +theorem group_codec_size (g : Group) : g.codec.size = g.bytes := by + cases g <;> simp [Group.codec,Group.bytes,Group.elements,vectorCodec,rootCodec,Nat.mul_comm] + +/-- All current groups, including raw32 PoW/digest and stack's eight E, have +their checked finite byte-codec law. No uniformity hypothesis is introduced. -/ +theorem all_group_distribution (g : Group) (payoff : g.Response → ℚ) : + average (fun bs : Fin g.codec.size → Byte => payoff (g.codec.decode bs)) = average payoff := + RawOracleCoupling.average_equiv g.codec.equiv payoff + +theorem all_group_response_card (g : Group) : + Fintype.card g.Response = 2^g.entropyBits := by + rw [← Fintype.card_congr g.codec.equiv,group_codec_size,group_carrier_card] + +/-- The exact atom law in the finite byte experiment, hence minimum entropy +192 for every nonempty actual group. Not a law of fixed BLAKE outputs. -/ +noncomputable def groupAtom (g : Group) (x : g.Response) : ℚ := by + classical + exact average (fun bs : Fin g.codec.size → Byte => if g.codec.decode bs = x then 1 else 0) + +theorem all_group_atom_law (g : Group) (x : g.Response) : + groupAtom g x = 1/(2^g.entropyBits : Nat) := by + classical + unfold groupAtom + rw [all_group_distribution g (fun y => if y = x then 1 else 0)] + simp [average,all_group_response_card] + + + +/-- Query positions have the exact source pushforward law. This intentionally +makes no iid/unstratified-query claim: count controls both chunks and strata. -/ +def queryProjection (depth count : Nat) (xs : Fin (queryDraws depth count + 1) → E) : + List Nat × E := + (projectQueries count depth (List.ofFn fun i : Fin (queryDraws depth count) => + xs ⟨i.val,by omega⟩),xs ⟨queryDraws depth count,by omega⟩) + +theorem query_projection_distribution (depth count : Nat) (payoff : (List Nat × E) → ℚ) : + average (fun bs : Fin ((queryDraws depth count+1)*24) → Byte => + payoff (queryProjection depth count (vectorDecode _ bs))) = + average (fun xs : Fin (queryDraws depth count+1) → E => + payoff (queryProjection depth count xs)) := + full_vector_distribution (queryDraws depth count+1) + (fun xs => payoff (queryProjection depth count xs)) + +theorem query_distribution_retains_history (cur : Cursor) (depth count : Nat) + (payoff : Cursor → (List Nat × E) → ℚ) : + average (fun bs : Fin ((queryDraws depth count+1)*24) → Byte => + payoff cur (queryProjection depth count (vectorDecode _ bs))) = + average (fun xs : Fin (queryDraws depth count+1) → E => + payoff cur (queryProjection depth count xs)) := + query_projection_distribution depth count (payoff cur) + + +/-- Prefix causality includes ALL earlier prover bytes/output events and read +counts; later events cannot change the captured prefix. -/ +def publicPrefix (cur : Cursor) (later : List SourceEvent) : List SourceEvent := + (cur.events ++ later).take cur.events.length + +theorem source_prefix_causality (cur : Cursor) (later : List SourceEvent) : + publicPrefix cur later = cur.events := by simp [publicPrefix] + +theorem query_prefix_causality (count depth : Nat) (xs ys : List E) + (enough : count ≤ (xs.flatMap (queryChunks depth)).length) : + projectQueries count depth (xs++ys) = projectQueries count depth xs := + projected_query_causality count depth xs ys enough + +theorem current_query_causality (depth count : Nat) (positive : 0 < depth) (small : depth < 64) + (xs : Fin (queryDraws depth count) → E) (later : List E) : + projectQueries count depth (List.ofFn xs ++ later) = + projectQueries count depth (List.ofFn xs) := by + apply projected_query_causality + rw [query_chunk_vector_length,List.length_ofFn] + exact query_draws_adequate depth count positive small + + +/-- Session derivation is NOT folded into a zero-cost domain selection. -/ +theorem separate_session_charge (tag : List Byte) : + derivationPrimitiveCost tag + 1 = 3 + (tag.length+63)/64 := by + rw [derivation_cost_closed] + omega + +#print axioms session_bridge +#print axioms read_bridge +#print axioms group_bridge +#print axioms all_group_entropy_min192 +#print axioms group_carrier_card +#print axioms query_lambda_grouping +#print axioms positive_pow_bridge +#print axioms full_vector_distribution +#print axioms query_projection_distribution +#print axioms source_prefix_causality +#print axioms query_prefix_causality +#print axioms separate_session_charge +#print axioms query_draws_adequate +#print axioms all_round_replay_bridge +#print axioms record_binding_bytes +#print axioms record_binding_messages +#print axioms all_actual_schedule_entropy +#print axioms all_group_distribution +#print axioms all_round_transport +#print axioms sampleVec_codec +#print axioms zero_pow_cursor +#print axioms positive_pow_cursor +#print axioms all_group_response_card +#print axioms all_group_atom_law +#print axioms query_distribution_retains_history +#print axioms current_query_causality +#print axioms sourceMetadataFraming +#print axioms source_record_binding_counts +end Whir.SpongefishPCSRoundFrames diff --git a/verification/whir/Whir/SpongefishPowAdapter.lean b/verification/whir/Whir/SpongefishPowAdapter.lean new file mode 100644 index 000000000..c78ff894d --- /dev/null +++ b/verification/whir/Whir/SpongefishPowAdapter.lean @@ -0,0 +1,104 @@ +import Whir.SpongefishSessionAdapter +import Whir.PublicMerkleLog + +/-! Hand-ported positive-PoW byte adapter for the current source pin in +SpongefishSessionAdapter. The trial uses ordinary BLAKE2s-256, not the old +Scalar24 nonce role. Nonces are prover messages: their search is not verifier +challenge entropy. This module preserves state after a failed work predicate; +proof reads, poisoning, EOF and compiler correspondence remain separate. -/ +namespace Whir.SpongefishPowAdapter +open Concrete FiatShamirGame DuplexRefinement DuplexModeGame PublicMerkleLog + +set_option autoImplicit false + +def nonceBytes (nonce : UInt64) : List Byte := List.ofFn (ByteCodec.encodeNat 8 nonce.toNat) +def trialTag : Fin 8 → Byte := fun i => + ⟨("FS-POW-1".toUTF8[i.val]!).toNat % 256,Nat.mod_lt _ (by decide)⟩ +def trialBytes (challenge : Digest32) (nonce : UInt64) : List Byte := + List.ofFn challenge ++ nonceBytes nonce ++ List.replicate 16 0 ++ List.ofFn trialTag + +theorem nonceBytes_length (nonce : UInt64) : (nonceBytes nonce).length = 8 := by simp [nonceBytes] +theorem trialBytes_length (challenge : Digest32) (nonce : UInt64) : + (trialBytes challenge nonce).length = 64 := by simp [trialBytes,nonceBytes_length] + +def firstWord (digest : Digest32) : UInt64 := + ByteCodec.decodeK (fun i => digest ⟨i.val,by omega⟩) + +def clears (bits : Fin 64) (digest : Digest32) : Bool := + decide (bits.val ≤ (firstWord digest).toBitVec.clz.toNat) + +/-- Counting leading zeroes is equivalent to the exact first-word threshold, +including zero difficulty and the all-zero digest. No whole-digest big-endian +interpretation is substituted for the native little-endian first word. -/ +theorem leading_zero_threshold (word : BitVec 64) (bits : Fin 64) : + bits.val ≤ word.clz.toNat ↔ word.toNat < 2^(64-bits.val) := by + constructor + · intro enough + exact (BitVec.toNat_lt_two_pow_sub_clz (x := word)).trans_le + (Nat.pow_le_pow_of_le (by decide) (by omega)) + · intro small + by_contra missing + have less : word.clz.toNat < bits.val := by omega + have nonzero : word ≠ 0#64 := by + intro zero + have count := BitVec.clz_eq_iff_eq_zero.mpr zero + have := congrArg BitVec.toNat count + norm_num at this + omega + have lower := BitVec.two_pow_sub_clz_le_toNat_of_ne_zero (x := word) (by decide) nonzero + have exponent : 64-bits.val ≤ 64-1-word.clz.toNat := by omega + have monotone := Nat.pow_le_pow_of_le (a := 2) (by decide) exponent + omega + +theorem clears_threshold (bits : Fin 64) (digest : Digest32) : + clears bits digest = true ↔ (firstWord digest).toNat < 2^(64-bits.val) := by + simp only [clears,decide_eq_true_eq] + exact leading_zero_threshold _ _ + +def trial (C : PrimitiveOracle) (challenge : Digest32) (nonce : UInt64) : Digest32 := + hash C (trialBytes challenge nonce) + +/-- `bits` carries the source's MAX_BITS guard. Zero difficulty performs neither +squeeze nor nonce absorption. Positive difficulty draws raw32 and absorbs the +LE u64 before checking its predicate, so a failed predicate retains that state. -/ +def check (C : PrimitiveOracle) (s : State) (bits : Fin 64) (nonce : UInt64) : + Except Error (State × Bool) := + if bits.val = 0 then .ok (s,true) else + match squeeze (compressionOf C) s 32 with + | .error e => .error e + | .ok (t,bytes) => + let challenge : Digest32 := fun i => bytes[i.val]?.getD 0 + .ok (absorb (compressionOf C) t (nonceBytes nonce),clears bits (trial C challenge nonce)) + +theorem zero_no_event (C : PrimitiveOracle) (s : State) (nonce : UInt64) : + check C s ⟨0,by decide⟩ nonce = .ok (s,true) := rfl + +theorem positive_checked (C : PrimitiveOracle) (s t : State) (bits : Fin 64) + (nonce : UInt64) (challenge : Digest32) (positive : bits.val ≠ 0) + (draw : squeeze (compressionOf C) s 32 = .ok (t,List.ofFn challenge)) : + check C s bits nonce = + .ok (absorb (compressionOf C) t (nonceBytes nonce),clears bits (trial C challenge nonce)) := by + simp only [check,positive,↓reduceIte,draw] + have decoded : (fun i : Fin 32 => (List.ofFn challenge)[i.val]?.getD 0) = challenge := by + funext i + simp only [List.getElem?_ofFn,dite_eq_left i.isLt,Option.getD_some] + rw [decoded] + +theorem nonce_absorb_cursor (C : PrimitiveOracle) (t : State) (nonce : UInt64) : + (absorb (compressionOf C) t (nonceBytes nonce)).consumed = 0 := by + apply absorb_nonempty_cursor + intro empty + have := congrArg List.length empty + simp [nonceBytes_length] at this + +theorem raw_challenge_cursor (C : PrimitiveOracle) (s t : State) (challenge : Digest32) + (draw : squeeze (compressionOf C) s 32 = .ok (t,List.ofFn challenge)) : + t.consumed = s.consumed + 32 := (squeeze_exact_cursor (compressionOf C) s t 32 _ draw).1 + +#print axioms leading_zero_threshold +#print axioms clears_threshold +#print axioms zero_no_event +#print axioms positive_checked +#print axioms nonce_absorb_cursor +#print axioms raw_challenge_cursor +end Whir.SpongefishPowAdapter diff --git a/verification/whir/Whir/SpongefishRecordBindingParser.lean b/verification/whir/Whir/SpongefishRecordBindingParser.lean new file mode 100644 index 000000000..432dbbd1a --- /dev/null +++ b/verification/whir/Whir/SpongefishRecordBindingParser.lean @@ -0,0 +1,197 @@ +import Whir.SpongefishCurrentModeQueries + +/-! Current native record fields are read and compared in their real order. +Scalar reads are individual, not a grouped-vector rejection shortcut. This +successful/failed parse model does not assert Rust poison or error identity. -/ +namespace Whir.SpongefishRecordBindingParser +open Concrete FiatShamirGame DuplexRefinement DuplexFraming +open SpongefishPCSRoundFrames SpongefishSessionAdapter +set_option autoImplicit false + +abbrev Message := (kind : WireKind) × kind.Value + +def Message.bytes (message : Message) : List Byte := message.1.codec.bytes message.2 + +def scalarMessages (values : List E) : List Message := values.map fun x => ⟨.scalar,x⟩ + +def messages (r : Record) : List Message := + scalarMessages (constants AnchoredHeaderCodec.openingMarker r.shape) ++ + [⟨.root,r.root⟩,⟨.root,r.context.cv⟩] ++ scalarMessages (contextScalars r.context) ++ + scalarMessages (pendingPacks r.context) ++ scalarMessages r.point ++ [⟨.scalar,r.value⟩] + +theorem scalar_messages_bytes (values : List E) : + (scalarMessages values).flatMap Message.bytes = scalarsBytes values := by + rw [scalarMessages,List.flatMap_map] + rfl + +theorem messages_bytes (r : Record) : (messages r).flatMap Message.bytes = openingBytes r := by + simp [messages,List.flatMap_append,scalar_messages_bytes,Message.bytes,WireKind.codec, + Codec.bytes,rootCodec,scalarCodec,openingBytes,rawRoot,scalarBytes,List.append_assoc] + +/-- Read first, compare second: a false field does not skip source absorption. -/ +def checkedRead (c : Compression) (cur : Cursor) (message : Message) : Option Cursor := + match SpongefishPCSRoundFrames.read c cur message.1 with + | none => none + | some pair => if message.1.codec.bytes pair.2 = message.bytes then some pair.1 else none + +def verifyFields (c : Compression) : Cursor → List Message → Option Cursor + | cur,[] => some cur + | cur,message::rest => do + let next ← checkedRead c cur message + verifyFields c next rest + +def verify (c : Compression) (cur : Cursor) (r : Record) : Option Cursor := + verifyFields c cur (messages r) + +def advance (c : Compression) (cur : Cursor) (message : Message) (rest : List Byte) : Cursor := + {cur with state := absorb c cur.state message.bytes, pending := SpongefishPCSRoundFrames.bind cur.pending message.bytes, narg := rest, bytesRead := cur.bytesRead+message.1.codec.size, messagesRead := cur.messagesRead+message.1.messages, events := cur.events ++ [.prover message.1 message.bytes]} + +theorem checkedRead_append (c : Compression) (cur : Cursor) (message : Message) (rest : List Byte) + (source : cur.narg = message.bytes ++ rest) : + checkedRead c cur message = some (advance c cur message rest) := by + rw [checkedRead,read_append c cur message.1 message.2 rest source] + simp [advance,Message.bytes] + +theorem checkedRead_exact (c : Compression) (cur next : Cursor) (message : Message) : + checkedRead c cur message = some next ↔ + ∃ rest,cur.narg = message.bytes ++ rest ∧ next = advance c cur message rest := by + constructor + · intro accepted + unfold checkedRead SpongefishPCSRoundFrames.read at accepted + cases parsed : message.1.codec.parse cur.narg with + | none => simp [parsed] at accepted + | some pair => + rcases pair with ⟨value,rest⟩ + simp only [parsed] at accepted + dsimp [Bind.bind,Option.bind,Pure.pure] at accepted + split at accepted + next equal => + simp only [Option.some.injEq] at accepted + have source := Codec.canonical_read message.1.codec cur.narg rest value parsed + rw [equal] at source + exact ⟨rest,source,by simpa only [advance,equal] using accepted.symm⟩ + next different => contradiction + · rintro ⟨rest,source,rfl⟩ + exact checkedRead_append c cur message rest source + +theorem verifyFields_source (c : Compression) (cur : Cursor) (fields : List Message) : + (∃ next,verifyFields c cur fields = some next) ↔ + ∃ rest,cur.narg = fields.flatMap Message.bytes ++ rest := by + induction fields generalizing cur with + | nil => + constructor + · intro _ + exact ⟨cur.narg,rfl⟩ + · intro _ + exact ⟨cur,rfl⟩ + | cons message fields ih => + constructor + · rintro ⟨next,accepted⟩ + simp only [verifyFields] at accepted + obtain ⟨middle,step,tail⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨remaining,source,state⟩ := (checkedRead_exact c cur middle message).mp step + obtain ⟨rest,after⟩ := (ih middle).mp ⟨next,tail⟩ + have middleNarg : middle.narg = remaining := by rw [state]; rfl + rw [← middleNarg,after] at source + exact ⟨rest,by simpa only [List.flatMap_cons,List.append_assoc] using source⟩ + · rintro ⟨rest,source⟩ + have before : cur.narg = message.bytes ++ (fields.flatMap Message.bytes ++ rest) := by + simpa only [List.flatMap_cons,List.append_assoc] using source + let middle := advance c cur message (fields.flatMap Message.bytes ++ rest) + obtain ⟨next,tail⟩ := (ih middle).mpr ⟨rest,rfl⟩ + exact ⟨next,by + rw [verifyFields,checkedRead_append c cur message _ before] + exact tail⟩ + +theorem verify_source (c : Compression) (cur : Cursor) (r : Record) : + (∃ next,verify c cur r = some next) ↔ ∃ rest,cur.narg = openingBytes r ++ rest := by + rw [verify,verifyFields_source,messages_bytes] + +theorem verifyFields_transport (c : Compression) (cur next : Cursor) (fields : List Message) + (accepted : verifyFields c cur fields = some next) : Extends cur next := by + induction fields generalizing cur with + | nil => + simp only [verifyFields,Option.some.injEq] at accepted + subst next + exact extends_refl cur + | cons message fields ih => + simp only [verifyFields] at accepted + obtain ⟨middle,step,tail⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨rest,source,state⟩ := (checkedRead_exact c cur middle message).mp step + have replay : replayCall c cur (.read message.1) = some middle := by + rw [replayCall,read_append c cur message.1 message.2 rest source] + simp only [Option.map_some] + exact congrArg some state.symm + exact extends_trans cur middle next (replayCall_transport c cur middle _ replay) (ih middle tail) + +theorem verify_transport (c : Compression) (cur next : Cursor) (r : Record) + (accepted : verify c cur r = some next) : Extends cur next := + verifyFields_transport c cur next (messages r) accepted + +theorem verify_reject (c : Compression) (cur : Cursor) (r : Record) + (different : ¬ ∃ rest,cur.narg = openingBytes r ++ rest) : verify c cur r = none := by + cases result : verify c cur r with + | none => rfl + | some next => exact False.elim (different ((verify_source c cur r).mp ⟨next,result⟩)) + +/-- Successful checked reads are the actual individual source read replay. -/ +theorem verifyFields_replay (c : Compression) (cur next : Cursor) (fields : List Message) + (accepted : verifyFields c cur fields = some next) : + replayCalls c cur (fields.map fun message => .read message.1) = some next := by + induction fields generalizing cur with + | nil => exact accepted + | cons message fields ih => + simp only [verifyFields] at accepted + obtain ⟨middle,step,tail⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨rest,source,state⟩ := (checkedRead_exact c cur middle message).mp step + have replay : replayCall c cur (.read message.1) = some middle := by + rw [replayCall,read_append c cur message.1 message.2 rest source] + simp only [Option.map_some] + exact congrArg some state.symm + simp only [List.map_cons,replayCalls,replay] + exact ih middle tail + +theorem verify_bridge (c : Compression) (parameter : Digest32) (cur next : Cursor) + (r : Record) (h : RepresentsCurrent c parameter cur.pending cur.state) + (valid : SpongefishCurrentModeQueries.FrameDomain cur.pending) + (accepted : verify c cur r = some next) : + RepresentsCurrent c parameter next.pending next.state ∧ + SpongefishCurrentModeQueries.FrameDomain next.pending := + SpongefishCurrentModeQueries.all_round_frame_domain c parameter cur next + ((messages r).map fun message => .read message.1) h valid + (verifyFields_replay c cur next (messages r) accepted) + +/-- A draw after the checked record has both its real bytes and a bounded +semantic address. Neither hidden CV equality nor supplied frame admissibility +is assumed for the resulting cursor. -/ +theorem verify_draw_byte (c : Compression) (parameter : Digest32) (cur next : Cursor) + (r : Record) (h : RepresentsCurrent c parameter cur.pending cur.state) + (valid : SpongefishCurrentModeQueries.FrameDomain cur.pending) + (accepted : verify c cur r = some next) (n : Nat) (positive : n ≠ 0) + (t : State) (bytes : List Byte) (ok : squeeze c next.state n = .ok (t,bytes)) + (j : Nat) (within : j < n) : + DuplexEncoding.Admissible + (SpongefishCurrentModeQueries.coordinate next.pending ((next.pending.consumed+j)/32)) ∧ + bytes[j]'(by obtain ⟨_,len⟩ := squeeze_exact_cursor c next.state t n bytes ok; omega) = + evalCoordinate c parameter + (SpongefishCurrentModeQueries.coordinate next.pending ((next.pending.consumed+j)/32)) + ⟨(next.pending.consumed+j)%32,Nat.mod_lt _ (by decide)⟩ := by + obtain ⟨represented,framed⟩ := verify_bridge c parameter cur next r h valid accepted + exact ⟨SpongefishCurrentModeQueries.squeezed_coordinate_admissible c parameter + next.pending next.state t represented framed n positive bytes ok j within, + SpongefishCurrentModeQueries.squeezed_byte c parameter next.pending next.state t + represented n positive bytes ok j within⟩ + +#print axioms verify_draw_byte + +#print axioms verifyFields_replay +#print axioms verify_bridge + +#print axioms verify_source +#print axioms verify_transport +#print axioms verify_reject + +#print axioms messages_bytes +#print axioms checkedRead_append +#print axioms checkedRead_exact +end Whir.SpongefishRecordBindingParser diff --git a/verification/whir/Whir/SpongefishSessionAdapter.lean b/verification/whir/Whir/SpongefishSessionAdapter.lean new file mode 100644 index 000000000..bdf878424 --- /dev/null +++ b/verification/whir/Whir/SpongefishSessionAdapter.lean @@ -0,0 +1,366 @@ +import Whir.DuplexCompression +import Whir.DuplexEncoding +import Whir.AnchoredHeaderCodec + +/-! Byte adapter for native #607 at 75d4562b. This reuses only the ordinary +absorb/squeeze core of the explicitly historical #552 DuplexRefinement. +AnchoredHeaderCodec/Roots and DuplexFraming retain their historical meanings. +The adapter is a source-inspected hand port, NOT compiler equivalence, source +acceptance, extraction, an FS theorem, or an indifferentiability theorem. + +Source: fiat_shamir/{session,duplex,codec,prover,verifier}.rs and +pcs/whir/commit.rs. Session derivation is a separate ordinary primitive path; +it must be charged even when the session identifier is subsequently fixed. +Historical domain/statement fields are mapped to (sessionId, zero32), NOT to +(tag, instance). The canonical nonempty instance is an ordinary absorb run. +PoW's positive difficulty draws raw32 then absorbs LE u64; zero difficulty is +no event. Historical roles 7/8/9, Scalar24 nonce, and nonmutating commitment +are NOT deployed #607 operations. A final raw32 draw is an ordinary squeeze, +not historical role7. `SpongefishPowAdapter` proves the deployed trial predicate +and checked-state transition. Nonce search, poisoned reads/hints/EOF, and the +actual source observer/reduction remain outside this session adapter. -/ +namespace Whir.SpongefishSessionAdapter +open FiatShamirGame Concrete DuplexRefinement + + def sourceRevision : String := "75d4562bde1efe296b4e32d2a195fdfc232b3ead" + + def derivationIV : Digest32 := fun i => + ⟨("irtf-cfrg-fiat-shamir/session-id".toUTF8[i.val]!).toNat % 256, + Nat.mod_lt _ (by decide)⟩ + + def init (c : Compression) (parameter iv : Digest32) : State := + seed c parameter iv zeroDigest + + theorem init_node (c : Compression) (parameter iv : Digest32) : + (init c parameter iv).cv = + c parameter (ByteCodec.pairBytes (iv, zeroDigest)) (UInt64.ofNat (2^56)) true := rfl + + theorem init_prefix (iv : Digest32) (i : Fin 32) : + ByteCodec.pairBytes (iv, zeroDigest) ⟨i.val, by omega⟩ = iv i := by + simp [ByteCodec.pairBytes, i.isLt] + + theorem init_zero_suffix (iv : Digest32) (i : Fin 32) : + ByteCodec.pairBytes (iv, zeroDigest) ⟨32+i.val, by omega⟩ = 0 := by + simp [ByteCodec.pairBytes, zeroDigest, show ¬32+i.val < 32 by omega] + + theorem absorb_zero_cursor (c : Compression) (s : State) (bs : List Byte) + (h : s.consumed = 0) : (absorb c s bs).consumed = 0 := by + by_cases empty : bs = [] + · simp [empty, h] + · exact absorb_nonempty_cursor c s bs empty + + /-- Derivation is always a valid 32-byte draw, including an empty tag. -/ + def derive (c : Compression) (parameter : Digest32) (tag : List Byte) : Digest32 := + let bs := (squeezeLoop c 32 (finish c (absorb c (init c parameter derivationIV) tag))).2 + fun i => bs[i.val]'(by simp only [bs, squeezeLoop_length]; exact i.isLt) + + theorem derive_checked (c : Compression) (parameter : Digest32) (tag : List Byte) : + squeeze c (absorb c (init c parameter derivationIV) tag) 32 = + .ok ((squeezeLoop c 32 (finish c (absorb c (init c parameter derivationIV) tag))).1, + List.ofFn (derive c parameter tag)) := by + have cursor := absorb_zero_cursor c (init c parameter derivationIV) tag rfl + simp only [squeeze, show (32 : Nat) ≠ 0 by decide, cursor, maxCursor] + simp only [show (0+32 ≤ 2^49-1) by decide, ↓reduceIte] + congr 2 + + /-- Exactly the source constructor's instance bytes; empty input panics in Rust. -/ + def newSession (c : Compression) (parameter session : Digest32) (instanceBytes : List Byte) : + Option State := + if instanceBytes = [] then none else some (absorb c (init c parameter session) instanceBytes) + + theorem newSession_nonempty (c : Compression) (parameter session : Digest32) + (instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) : + newSession c parameter session instanceBytes = some (absorb c (init c parameter session) instanceBytes) := by + simp [newSession, nonempty] + + /-- Derived, not assumed: historical seed fields now mean sessionId and zero32. +The instance is in `modelAbsorb`, never in the old seed's second 32 bytes. -/ + theorem session_represents (c : Compression) (parameter session : Digest32) + (instanceBytes : List Byte) : + Represents c parameter (modelAbsorb ⟨⟨session,zeroDigest,[]⟩,[],0,0⟩ instanceBytes) + (absorb c (init c parameter session) instanceBytes) := + absorb_represents c parameter _ _ (seed_represents c parameter session zeroDigest) instanceBytes + + /-- Explicit ordinary primitive plan: seed, every tag block, and output block0. +The extra one-node session initialization is NOT included here. No role7/8/9. -/ + def derivationPlan (tag : List Byte) : List DuplexEncoding.Instruction := + (ByteCodec.pairBytes (derivationIV,zeroDigest), UInt64.ofNat (2^56)) :: + DuplexEncoding.chunks true 0 [] tag ++ + [(wordsBlock [0], UInt64.ofNat (6*2^56))] + + def derivationPrimitiveCost (tag : List Byte) : Nat := (derivationPlan tag).length + + theorem derivation_cost (tag : List Byte) : + derivationPrimitiveCost tag = 2 + (DuplexEncoding.chunks true 0 [] tag).length := by + simp [derivationPrimitiveCost, derivationPlan]; omega + + theorem derivation_empty_cost : derivationPrimitiveCost [] = 2 := by + simp [derivationPrimitiveCost, derivationPlan, DuplexEncoding.chunks] + + theorem derivation_and_session_init_cost (tag : List Byte) : + derivationPrimitiveCost tag + 1 = + 3 + (DuplexEncoding.chunks true 0 [] tag).length := by rw [derivation_cost]; omega + + def scalarBytes (x : E) : List Byte := List.ofFn (ByteCodec.encodeE x) + def scalarsBytes (xs : List E) : List Byte := xs.flatMap scalarBytes + def rawRoot (root : Digest32) : List Byte := List.ofFn root + /-- Number of ordinary absorb nodes, including the delayed final block. -/ + theorem chunks_length (first : Bool) (previous : Nat) (pending bs : List Byte) + (bounded : pending.length ≤ 64) : + (DuplexEncoding.chunks first previous pending bs).length = + (pending.length + bs.length + 63)/64 := by + induction bs generalizing first previous pending with + | nil => + by_cases empty : pending = [] + · simp [DuplexEncoding.chunks, empty] + · have positive : 0 < pending.length := List.length_pos_iff.mpr empty + simp only [DuplexEncoding.chunks, empty, ↓reduceIte, List.length_cons, List.length_nil] + omega + | cons b bs ih => + by_cases full : pending.length = 64 + · simp only [DuplexEncoding.chunks, full, ↓reduceIte, List.length_cons] + rw [ih false 0 [b] (by simp)] + simp only [List.length_cons, List.length_nil] + omega + · simp only [DuplexEncoding.chunks, full, ↓reduceIte] + rw [ih first previous (pending++[b]) (by simp; omega)] + simp only [List.length_append, List.length_cons, List.length_nil] + omega + + theorem derivation_cost_closed (tag : List Byte) : + derivationPrimitiveCost tag = 2 + (tag.length+63)/64 := by + rw [derivation_cost, chunks_length true 0 [] tag (by simp)] + simp + + + @[simp] theorem scalarBytes_length (x : E) : (scalarBytes x).length = 24 := by simp [scalarBytes] + @[simp] theorem scalarsBytes_length (xs : List E) : (scalarsBytes xs).length = 24*xs.length := by + induction xs with + | nil => rfl + | cons x xs ih => simp [scalarsBytes]; omega + @[simp] theorem rawRoot_length (root : Digest32) : (rawRoot root).length = 32 := by simp [rawRoot] + + theorem rawRoot_injective : Function.Injective rawRoot := by + intro a b h + funext i + have := congrArg (fun bs => bs[i.val]?) h + simpa only [rawRoot, List.getElem?_ofFn, dite_eq_left i.isLt, Option.some.injEq] using this + + theorem raw_not_historical (root : Digest32) : + rawRoot root ≠ scalarsBytes [(ByteCodec.hashToScalars root).1, (ByteCodec.hashToScalars root).2] := by + intro h + have := congrArg List.length h + simp at this + + abbrev Shape := AnchoredHeaderCodec.Shape + def constants (marker : E) (shape : Shape) : List E := + [marker, AnchoredHeaderCodec.shapeScalar shape, AnchoredHeaderCodec.lanesScalar shape] + + def commitPrefix (shape : Shape) (root : Digest32) : List Byte := + scalarsBytes (constants AnchoredHeaderCodec.anchorMarker shape) ++ rawRoot root + + theorem commitPrefix_length (shape : Shape) (root : Digest32) : + (commitPrefix shape root).length = 104 := by simp [commitPrefix, constants] + + /-- There are 3E+raw32 BEFORE drawing logN complete E coordinates; +only the advertised value after the draw brings transport to 4E+raw32. -/ + def commitTransport (shape : Shape) (root : Digest32) (value : E) : List Byte := + commitPrefix shape root ++ scalarBytes value + + theorem commitTransport_length (shape : Shape) (root : Digest32) (value : E) : + (commitTransport shape root value).length = 128 := by + simp [commitTransport, commitPrefix_length] + + def absorbMessages (c : Compression) (s : State) (messages : List (List Byte)) : State := + messages.foldl (absorb c) s + + theorem absorbMessages_flatten (c : Compression) (s : State) (messages : List (List Byte)) : + absorbMessages c s messages = absorb c s messages.flatten := by + induction messages generalizing s with + | nil => rfl + | cons m ms ih => simp only [absorbMessages, List.foldl_cons, List.flatten_cons, absorb_append] at *; exact ih _ + + theorem commitPrefix_grouping (c : Compression) (s : State) (shape : Shape) (root : Digest32) : + absorbMessages c s ((constants AnchoredHeaderCodec.anchorMarker shape).map scalarBytes ++ [rawRoot root]) = + absorb c s (commitPrefix shape root) := by + rw [absorbMessages_flatten] + simp [commitPrefix, scalarsBytes, List.flatten_append, List.flatMap_def] + + def commit (c : Compression) (s : State) (shape : Shape) (root : Digest32) (value : E) : + Except Error (State × List E) := do + let (t, point) ← sampleVec c (absorb c s (commitPrefix shape root)) shape.logN + pure (observe c t value, point) + + /-- Complete 24-byte draws survive grouping, even if only c0 is projected. +No absorb/value event is moved across this draw. -/ + theorem draw_grouping (c : Compression) (s : State) (a b : Nat) + (limit : s.consumed + (24*a+24*b) ≤ maxCursor) : + squeeze c s (24*(a+b)) = + match squeeze c s (24*a) with + | .error e => .error e + | .ok (t,xs) => match squeeze c t (24*b) with + | .error e => .error e + | .ok (u,ys) => .ok (u,xs++ys) := by + rw [Nat.mul_add] + exact squeeze_concatenates c s (24*a) (24*b) limit + + /-- Source uses ALL 192 bits, not c0-only: disjoint depth-bit chunks, +low bits first, then fixed-count strata. Native 64-bit shifts/masks are kept +literally. Source callers require 1 ≤ depth < 64 and count < 2^64. +Totalization outside those source preconditions is not a Rust panic model. -/ + def limb (x : E) (i : Nat) : UInt64 := + match i with | 0 => x.c0 | 1 => x.c1 | 2 => x.c2 | _ => 0 + + def queryChunks (depth : Nat) (x : E) : List Nat := + (List.range (192/depth)).map fun j => + let off := j*depth + let sh := off%64 + let chunk := limb x (off/64) >>> UInt64.ofNat sh + let chunk := if sh+depth > 64 then + chunk ||| (limb x (off/64+1) <<< UInt64.ofNat (64-sh)) else chunk + (chunk &&& UInt64.ofNat (2^depth-1)).toNat + + def strata (count depth : Nat) : List (Nat × Nat) := + ((List.range 64).reverse.filter fun g => + ((UInt64.ofNat count >>> UInt64.ofNat g) &&& 1) == 1).flatMap fun g => + (List.range (2^g)).map fun j => (min g depth, + (UInt64.ofNat j &&& UInt64.ofNat (2^(min g depth)-1)).toNat) + + def projectQueries (count depth : Nat) (xs : List E) : List Nat := + ((xs.flatMap (queryChunks depth)).take count).zip (strata count depth) |>.map fun p => + let low := depth-p.2.1 + ((UInt64.ofNat p.1 &&& UInt64.ofNat (2^low-1)) ||| + (UInt64.ofNat p.2.2 <<< UInt64.ofNat low)).toNat + + /-- For fixed source count/strata, later E draws cannot affect the projected +positions already supplied by an adequate prefix. Changing count also changes +strata and is deliberately NOT claimed to preserve positions. -/ + theorem projected_query_causality (count depth : Nat) (xs ys : List E) + (enough : count ≤ (xs.flatMap (queryChunks depth)).length) : + projectQueries count depth (xs++ys) = projectQueries count depth xs := by + simp only [projectQueries, List.flatMap_append, List.take_append, + Nat.sub_eq_zero_of_le enough, List.take_zero, List.append_nil] + + theorem sample_full_cursor (c : Compression) (s t : State) (x : E) + (ok : sample c s = .ok (t,x)) : t.consumed = s.consumed + 24 := by + unfold sample at ok + split at ok + · cases ok + · rename_i u bs hs + cases ok + exact (squeeze_exact_cursor c s t 24 bs hs).1 + + structure Context where + cv : Digest32 + pending : List Byte + first : Bool + previous : UInt64 + squeezed : UInt64 + + def capture (s : State) : Context := + ⟨s.cv, s.pending.toList, s.first, UInt64.ofNat s.previous, UInt64.ofNat s.consumed⟩ + + theorem capture_cache_irrelevant (s : State) (out : Digest32) : + capture {s with output := out} = capture s := rfl + + /-- Three normalized LE words per E, literal zero in every absent byte. +This includes zeroing the unused high bytes of the final partial word. -/ + def pendingPacks (ctx : Context) : List E := + List.ofFn fun i : Fin ((ctx.pending.length+23)/24) => + ByteCodec.decodeE (fun j => ctx.pending[24*i.val+j.val]?.getD 0) + + theorem pendingPack_bytes (ctx : Context) (i : Fin ((ctx.pending.length+23)/24)) : + ByteCodec.encodeE ((pendingPacks ctx)[i.val]'(by simp [pendingPacks])) = + (fun j => ctx.pending[24*i.val+j.val]?.getD 0) := by + simp [pendingPacks, ByteCodec.encodeE_decodeE] + + def contextScalars (ctx : Context) : List E := + [⟨UInt64.ofNat ctx.pending.length, if ctx.first then 1 else 0, ctx.previous⟩, + ⟨ctx.squeezed,0,0⟩] + + structure Record where + shape : Shape + root : Digest32 + context : Context + point : List E + value : E + + /-- Native opening order: 3 constants, raw root, raw original CV, two +metadata E, ceil(pendingBytes/24) normalized E, original point, original value. -/ + def openingBytes (r : Record) : List Byte := + scalarsBytes (constants AnchoredHeaderCodec.openingMarker r.shape) ++ + rawRoot r.root ++ rawRoot r.context.cv ++ scalarsBytes (contextScalars r.context) ++ + scalarsBytes (pendingPacks r.context) ++ scalarsBytes r.point ++ scalarBytes r.value + + theorem openingBytes_length (r : Record) : + (openingBytes r).length = 208 + 24*((r.context.pending.length+23)/24 + r.point.length) := by + simp [openingBytes, constants, contextScalars, pendingPacks]; omega + + theorem openingBytes_point_length (r : Record) (point : r.point.length = r.shape.logN) : + (openingBytes r).length = 208 + 24*((r.context.pending.length+23)/24 + r.shape.logN) := by + rw [openingBytes_length, point] + + def openingMessages (r : Record) : List (List Byte) := + (constants AnchoredHeaderCodec.openingMarker r.shape).map scalarBytes ++ + [rawRoot r.root, rawRoot r.context.cv] ++ (contextScalars r.context).map scalarBytes ++ + (pendingPacks r.context).map scalarBytes ++ r.point.map scalarBytes ++ [scalarBytes r.value] + + theorem opening_grouping (c : Compression) (s : State) (r : Record) : + absorbMessages c s (openingMessages r) = absorb c s (openingBytes r) := by + rw [absorbMessages_flatten] + simp [openingMessages, openingBytes, scalarsBytes, List.flatten_append, List.flatMap_def, + List.append_assoc] + + /-- A byte-level expected-record parser, not the source verifier or its acceptance theorem. -/ + def readOpening (r : Record) (transport : List Byte) : Option (List Byte) := + if transport.take (openingBytes r).length = openingBytes r then + some (transport.drop (openingBytes r).length) else none + + theorem readOpening_honest (r : Record) (suffix : List Byte) : + readOpening r (openingBytes r ++ suffix) = some suffix := by simp [readOpening] + + theorem readOpening_sound (r : Record) (transport suffix : List Byte) + (h : readOpening r transport = some suffix) : transport = openingBytes r ++ suffix := by + unfold readOpening at h + split at h + · rename_i same + cases h + calc + transport = transport.take (openingBytes r).length ++ transport.drop (openingBytes r).length := + (List.take_append_drop _ _).symm + _ = openingBytes r ++ transport.drop (openingBytes r).length := by rw [same] + · cases h + + /-- Reproducible differential fixture, not a universal Rust equivalence proof. +The external probe includes the pinned actual Rust source modules and native +BLAKE2s implementation. Each output line is compared byte-for-byte. -/ + def runtimeFixture : List String := Id.run do + let c := DuplexCompression.compress + let parameter := DuplexCompression.parameterIV + let root : Digest32 := fun i => ⟨i.val, by omega⟩ + let mut lines := ["init|" ++ DuplexCompression.hex (rawRoot (init c parameter root).cv)] + for n in [0,1,31,32,63,64,65,129] do + let tag : List Byte := (List.range n).map fun i => ⟨i%256, Nat.mod_lt _ (by decide)⟩ + lines := lines ++ ["derive" ++ toString n ++ "|" ++ DuplexCompression.hex (rawRoot (derive c parameter tag))] + let tag : List Byte := "607-runtime-fixture".toUTF8.toList.map fun b => + ⟨b.toNat%256, Nat.mod_lt _ (by decide)⟩ + let session := derive c parameter tag + let s := absorb c (init c parameter session) (littleWord 0x0102030405060708) + lines := lines ++ ["session|" ++ DuplexCompression.hex (rawRoot s.cv)] + let shape : Shape := ⟨3,1,1,2⟩ + let value : E := ⟨1,2,3⟩ + let headerBytes := commitPrefix shape root + lines := lines ++ ["prefix|" ++ DuplexCompression.hex headerBytes] + match sampleVec c (absorb c s headerBytes) shape.logN with + | .error e => return lines ++ ["error|" ++ reprStr e] + | .ok (t,point) => + lines := lines ++ ["point|" ++ DuplexCompression.hex (scalarsBytes point), + "commit|" ++ DuplexCompression.hex (commitTransport shape root value)] + let r : Record := ⟨shape,root,capture s,point,value⟩ + let opening := openingBytes r + lines := lines ++ ["opening|" ++ DuplexCompression.hex opening] + match squeeze c (absorb c (observe c t value) opening) 32 with + | .error e => return lines ++ ["error|" ++ reprStr e] + | .ok (_,bytes) => return lines ++ ["final32|" ++ DuplexCompression.hex bytes] + +end Whir.SpongefishSessionAdapter diff --git a/verification/whir/Whir/TraceBasisExtraction.lean b/verification/whir/Whir/TraceBasisExtraction.lean new file mode 100644 index 000000000..c8baa9872 --- /dev/null +++ b/verification/whir/Whir/TraceBasisExtraction.lean @@ -0,0 +1,144 @@ +import Whir.TraceExtraction +import CompPoly.Univariate.Roots.Shoup.Basic + +/-! The 192 canonical bit vectors of the source's three-word extension. Basis correctness uses literal bit coordinates, not a chosen or enumerated field basis. -/ +namespace Whir.TraceBasisExtraction +open Concrete TraceExtraction +open scoped BigOperators +local instance : Field E := ExtractionField.field + +abbrev BitIndex := Fin 3 × Fin 64 + +def component (word : E) (part : Fin 3) : K := + if part.val = 0 then word.c0 else if part.val = 1 then word.c1 else word.c2 + +def bits (word : E) (index : BitIndex) : ZMod 2 := + if (component word index.1).toBitVec.getLsbD index.2.val then 1 else 0 + +def bitVector (index : BitIndex) : E := + let word := (1 : K) <<< UInt64.ofNat index.2.val + if index.1.val = 0 then ⟨word, 0, 0⟩ else + if index.1.val = 1 then ⟨0, word, 0⟩ else ⟨0, 0, word⟩ + +theorem bits_add (a b : E) (index : BitIndex) : bits (a + b) index = bits a index + bits b index := by + rcases index with ⟨part, bit⟩ + change bits (E.add a b) (part, bit) = _ + fin_cases part <;> simp only [bits, component, E.add, Nat.reduceEqDiff, + Nat.reduceEqDiff, if_true, if_false, UInt64.toBitVec_xor, BitVec.getLsbD_xor] + all_goals + split <;> split <;> simp_all <;> decide + +noncomputable def readBits : E →ₗ[ZMod 2] (BitIndex → ZMod 2) where + toFun := bits + map_add' a b := funext (bits_add a b) + map_smul' scalar word := by + fin_cases scalar + · change bits ((0 : ZMod 2) • word) = (0 : ZMod 2) • bits word + rw [zero_smul, zero_smul] + funext index + change bits E.zero index = 0 + simp [bits, component, E.zero] + · change bits ((1 : ZMod 2) • word) = (1 : ZMod 2) • bits word + rw [one_smul, one_smul] + +private theorem word_bits_injective (a b : K) + (same : ∀ bit : Fin 64, + (if a.toBitVec.getLsbD bit.val then (1 : ZMod 2) else 0) = + (if b.toBitVec.getLsbD bit.val then (1 : ZMod 2) else 0)) : a = b := by + apply UInt64.toBitVec_inj.mp + apply BitVec.eq_of_getLsbD_eq_iff.mpr + intro index bound + have observed := same ⟨index, bound⟩ + cases ha : a.toBitVec.getLsbD index <;> cases hb : b.toBitVec.getLsbD index <;> simp_all + +theorem readBits_injective : Function.Injective readBits := by + intro a b same + have c0 : a.c0 = b.c0 := word_bits_injective _ _ (fun bit => by + simpa [readBits, bits, component] using congrFun same ((0 : Fin 3), bit)) + have c1 : a.c1 = b.c1 := word_bits_injective _ _ (fun bit => by + simpa [readBits, bits, component] using congrFun same ((1 : Fin 3), bit)) + have c2 : a.c2 = b.c2 := word_bits_injective _ _ (fun bit => by + simpa [readBits, bits, component] using congrFun same ((2 : Fin 3), bit)) + cases a + cases b + simp_all + +private theorem bitWord_values (bit observed : Fin 64) : + (if (((1 : K) <<< UInt64.ofNat bit.val).toBitVec.getLsbD observed.val) then + (1 : ZMod 2) else 0) = if observed = bit then 1 else 0 := by + rw [← FieldModel.coeff_bitPoly] + change (FieldModel.wordPoly ((1 : K) <<< UInt64.ofNat bit.val)).coeff observed.val = _ + rw [FieldModel.wordPoly_basis bit.val bit.isLt] + simp only [Polynomial.coeff_X_pow, Fin.ext_iff, eq_comm] + +theorem readBits_bitVector (index : BitIndex) : readBits (bitVector index) = Pi.single index 1 := by + funext observed + rcases index with ⟨part, bit⟩ + rcases observed with ⟨otherPart, otherBit⟩ + fin_cases part <;> fin_cases otherPart <;> + simp only [readBits, LinearMap.coe_mk, AddHom.coe_mk, bits, component, bitVector, + Nat.reduceEqDiff, ite_true, ite_false, bitWord_values, Pi.single_apply, + UInt64.toBitVec_zero, BitVec.getLsbD_zero, Bool.false_eq_true, + Prod.mk.injEq, Fin.ext_iff, Nat.reduceEqDiff, true_and, false_and] + +theorem readBits_surjective : Function.Surjective readBits := by + intro values + refine ⟨∑ index, values index • bitVector index, ?_⟩ + rw [map_sum] + simp only [map_smul, readBits_bitVector] + exact (pi_eq_sum_univ' values).symm + +noncomputable def coordinateEquiv : E ≃ₗ[ZMod 2] (BitIndex → ZMod 2) := + LinearEquiv.ofBijective readBits ⟨readBits_injective, readBits_surjective⟩ + +noncomputable def binaryBasis : Module.Basis BitIndex (ZMod 2) E := + Module.Basis.ofEquivFun coordinateEquiv + +theorem binaryBasis_value (index : BitIndex) : binaryBasis index = bitVector index := by + apply readBits_injective + rw [readBits_bitVector] + change coordinateEquiv (binaryBasis index) = _ + simp [binaryBasis, Module.Basis.coe_ofEquivFun] + +def canonicalBasis : Array E := Array.ofFn fun index : Fin 192 => + bitVector (finProdFinEquiv.symm index : BitIndex) + +theorem canonicalBasis_trace_separates {a b : E} (different : a ≠ b) : + ∃ beta, beta ∈ canonicalBasis.toList ∧ trace (beta * (a - b)) ≠ 0 := by + let basis : Module.Basis (Fin 192) (ZMod 2) E := binaryBasis.reindex finProdFinEquiv + obtain ⟨index, separated⟩ := basis_trace_separates basis different + refine ⟨basis index, ?_, separated⟩ + simp only [canonicalBasis, Array.toList_ofFn] + apply List.mem_ofFn.mpr + refine ⟨index, ?_⟩ + simp [canonicalBasis, basis, binaryBasis_value] + +/-- Source-specialized trace metadata for the certified, non-enumerating Shoup splitter. Executing the generic splitter still requires a fast scalar-power refinement, separately from this bounded trace function. -/ +def traceContext : CompPoly.CPolynomial.Roots.FiniteField.SmallPrimeTraceContext E where + q := 2 ^ 192 + finite := inferInstance + card_eq := FieldModel.natCard_E + frobenius_fixed word := by simpa only [FieldModel.card_E] using FiniteField.pow_card word + p := 2 + k := 192 + p_prime := by decide + q_eq := rfl + baseConstants := #[0, 1] + baseConstants_size := rfl + basis := canonicalBasis + basis_size := Array.size_ofFn + traceValue := trace + traceValue_eq_powerSum word := by + rw [CompPoly.CPolynomial.Roots.FiniteField.tracePowerSum_eq_sum_range] + exact trace_eq_powerSum word + traceValue_mem_base word := by + rcases trace_base_values word with h | h <;> simp [h] + trace_separates := canonicalBasis_trace_separates + +#print axioms bits_add +#print axioms readBits_injective +#print axioms readBits_bitVector +#print axioms readBits_surjective +#print axioms binaryBasis_value +#print axioms canonicalBasis_trace_separates +end Whir.TraceBasisExtraction diff --git a/verification/whir/Whir/TraceExtraction.lean b/verification/whir/Whir/TraceExtraction.lean new file mode 100644 index 000000000..3042041e9 --- /dev/null +++ b/verification/whir/Whir/TraceExtraction.lean @@ -0,0 +1,138 @@ +import Whir.ExtractionField +import Mathlib.FieldTheory.Finite.Trace + +/-! A bounded executable characteristic-two trace kernel for source extension words. It squares iteratively, never computes scalar powers using an exponential exponent loop, and never enumerates the field. The canonical 192-word binary basis bridge and the efficient Shoup/Roth backend refinement remain separate from these trace identities. -/ +namespace Whir.TraceExtraction +open Concrete +open scoped BigOperators + +structure TraceResult (F : Type*) where + value : F + nextPower : F + fieldOps : Nat + +section Kernel +variable {F : Type*} [CommRing F] + +def traceLoop : Nat → F → F → TraceResult F + | 0, term, total => ⟨total, term, 0⟩ + | count + 1, term, total => + let rest := traceLoop count (term * term) (total + term) + ⟨rest.value, rest.nextPower, rest.fieldOps + 2⟩ + +theorem traceLoop_value (count : Nat) (term total : F) : + (traceLoop count term total).value = total + ∑ i ∈ Finset.range count, term ^ (2 ^ i) := by + induction count generalizing term total with + | zero => simp [traceLoop] + | succ count ih => + rw [traceLoop, ih, Finset.sum_range_succ'] + simp only [pow_zero, pow_one] + have shifted : ∑ i ∈ Finset.range count, (term * term) ^ (2 ^ i) = + ∑ i ∈ Finset.range count, term ^ (2 ^ (i + 1)) := by + apply Finset.sum_congr rfl + intro i _ + rw [← pow_two, ← pow_mul, Nat.pow_succ] + congr 1 + omega + rw [shifted] + ring + +theorem traceLoop_nextPower (count : Nat) (term total : F) : + (traceLoop count term total).nextPower = term ^ (2 ^ count) := by + induction count generalizing term total with + | zero => simp [traceLoop] + | succ count ih => + rw [traceLoop, ih, ← pow_two, ← pow_mul, Nat.pow_succ] + congr 1 + omega + +theorem traceLoop_fieldOps (count : Nat) (term total : F) : + (traceLoop count term total).fieldOps = 2 * count := by + induction count generalizing term total with + | zero => rfl + | succ count ih => simp [traceLoop, ih]; omega + +end Kernel + +/-- The actual 192-bit extension trace uses 192 squares and 192 additions, with canonical ring operations. -/ +def trace (word : E) : E := (traceLoop 192 word 0).value + +theorem trace_eq_powerSum (word : E) : + trace word = ∑ i ∈ Finset.range 192, word ^ (2 ^ i) := by + simp only [trace, traceLoop_value, zero_add] + +theorem trace_384_fieldOps (word : E) : (traceLoop 192 word 0).fieldOps = 384 := by + rw [traceLoop_fieldOps] + +section FieldTrace +local instance : Field E := ExtractionField.field +noncomputable instance binaryAlgebra : Algebra (ZMod 2) E := + (ZMod.castHom (dvd_refl 2) E).toAlgebra + +theorem binary_finrank : Module.finrank (ZMod 2) E = 192 := by + apply Nat.pow_right_injective (by decide : 2 ≤ 2) + simpa only [ZMod.card, FieldModel.card_E] using + (Module.card_eq_pow_finrank (K := ZMod 2) (V := E)).symm + +theorem trace_eq_algebraTrace (word : E) : + trace word = algebraMap (ZMod 2) E (Algebra.trace (ZMod 2) E word) := by + rw [FiniteField.algebraMap_trace_eq_sum_pow, binary_finrank] + simpa using trace_eq_powerSum word + +theorem trace_base_values (word : E) : trace word = 0 ∨ trace word = 1 := by + rw [trace_eq_algebraTrace] + generalize Algebra.trace (ZMod 2) E word = result + fin_cases result + · exact Or.inl (map_zero _) + · exact Or.inr (map_one _) + +/-- Nondegeneracy is supplied by the proved finite-field trace form, not by a guessed concrete trace-one word. -/ +theorem trace_pair_separates {a b : E} (different : a ≠ b) : + ∃ beta : E, trace (beta * (a - b)) ≠ 0 := by + have nonzero : a - b ≠ 0 := sub_ne_zero.mpr different + have nondegenerate := (traceForm_nondegenerate (ZMod 2) E).1 (a - b) + by_contra! vanished + apply nonzero + apply nondegenerate + intro beta + have zeroTrace := vanished beta + rw [trace_eq_algebraTrace] at zeroTrace + have zero : Algebra.trace (ZMod 2) E (beta * (a - b)) = 0 := + (algebraMap (ZMod 2) E).injective (by simpa using zeroTrace) + simpa [Algebra.traceForm_apply, mul_sub, map_sub, mul_comm] using zero + +/-- Any actual binary basis reduces field-wide trace separation to only its 192 vectors. This theorem does not construct or execute a classical chosen basis. -/ +theorem basis_trace_separates (basis : Module.Basis (Fin 192) (ZMod 2) E) + {a b : E} (different : a ≠ b) : + ∃ index, trace (basis index * (a - b)) ≠ 0 := by + by_contra! vanished + let map : E →ₗ[ZMod 2] ZMod 2 := + (Algebra.trace (ZMod 2) E).comp (LinearMap.mulRight (ZMod 2) (a - b)) + have zeroMap : map = 0 := by + apply basis.ext + intro index + have zeroTrace := vanished index + rw [trace_eq_algebraTrace] at zeroTrace + have zero : Algebra.trace (ZMod 2) E (basis index * (a - b)) = 0 := + (algebraMap (ZMod 2) E).injective (by simpa using zeroTrace) + simpa [map] using zero + obtain ⟨beta, separated⟩ := trace_pair_separates different + apply separated + rw [trace_eq_algebraTrace] + have : Algebra.trace (ZMod 2) E (beta * (a - b)) = 0 := by + simpa [map] using DFunLike.congr_fun zeroMap beta + simp [this] + +end FieldTrace + +#print axioms traceLoop_value +#print axioms traceLoop_nextPower +#print axioms traceLoop_fieldOps +#print axioms trace_eq_powerSum +#print axioms trace_384_fieldOps +#print axioms binary_finrank +#print axioms trace_eq_algebraTrace +#print axioms trace_base_values +#print axioms trace_pair_separates +#print axioms basis_trace_separates +end Whir.TraceExtraction diff --git a/verification/whir/Whir/TriangularExtraction.lean b/verification/whir/Whir/TriangularExtraction.lean index 16d78ec18..ae8fddeda 100644 --- a/verification/whir/Whir/TriangularExtraction.lean +++ b/verification/whir/Whir/TriangularExtraction.lean @@ -201,7 +201,7 @@ theorem countedPeel_cost (inverseCost : Nat) (basis : Nat → CPolynomial F) calc _ ≤ (CPolynomial.C a).val.size * ((CPolynomial.C a).val.size + 2 * (basis size).val.size) := - ReedSolomonExtraction.countedRawMul_cost _ _ + ReedSolomonExtraction.countedMul_cost_asymmetric _ _ _ ≤ 1 * (1 + 2 * width) := Nat.mul_le_mul constantSize (Nat.add_le_add constantSize (Nat.mul_le_mul_left 2 basisSize)) @@ -434,7 +434,7 @@ theorem countedPreparedPeel_cost (inverseCost : Nat) (v : Nat → F) (depth size have productSupport : (countedMul (CPolynomial.C coefficient) basis.1).1.val.size ≤ width := by rw [countedMul_value]; exact (constant_mul_support _ _).trans basisSupport have productCost : (countedMul (CPolynomial.C coefficient) basis.1).2 ≤ 1 + 2 * width := by - exact (countedRawMul_cost _ _).trans (by + exact (countedMul_cost_asymmetric _ _).trans (by calc _ ≤ 1 * (1 + 2 * width) := Nat.mul_le_mul (constant_support coefficient) diff --git a/verification/whir/Whir/WHIRPhysicalSoundness.lean b/verification/whir/Whir/WHIRPhysicalSoundness.lean index a20308c34..570adbc04 100644 --- a/verification/whir/Whir/WHIRPhysicalSoundness.lean +++ b/verification/whir/Whir/WHIRPhysicalSoundness.lean @@ -473,7 +473,7 @@ theorem trace_authenticatedRows {ctx : RawWHIRKeys.Context} {stack : ctx.mode = rw [rows,actualRows,incoming] exact atQueries_get _ _ j jBound -private theorem run_indexed_replies (input : CausalGame.Public) (tape : CausalGame.Tape input.config) +theorem run_indexed_replies (input : CausalGame.Public) (tape : CausalGame.Tape input.config) (replies : Array CausalGame.Reply) (proof : Opening) (parsed : CausalGame.opening input.config (CausalGame.challenges input.config tape) replies = .ok proof) : CausalGame.run (CausalStrategy.indexedStrategy replies) input [] diff --git a/verification/whir/lakefile.toml b/verification/whir/lakefile.toml index b1967b6d5..f233df471 100644 --- a/verification/whir/lakefile.toml +++ b/verification/whir/lakefile.toml @@ -66,3 +66,55 @@ root = "Whir.PCSBCSSourceCoordinateDecoderSmoke" [[lean_exe]] name = "pcsbcsPublicLogExtractorSmoke" root = "Whir.PCSBCSPublicLogExtractorSmoke" + +[[lean_exe]] +name = "pcsbcsCallerPayloadCostSmoke" +root = "Whir.PCSBCSCallerPayloadCostSmoke" + +[[lean_exe]] +name = "pcsbcsCallerSchedulePolynomialSmoke" +root = "Whir.PCSBCSCallerSchedulePolynomialBoundSmoke" + +[[lean_exe]] +name = "pcsbcsCapturedNativeReplyBridgeSmoke" +root = "Whir.PCSBCSCapturedNativeReplyBridgeSmoke" + +[[lean_exe]] +name = "pcsbcsCapturedSourceExecutableSmoke" +root = "Whir.PCSBCSCapturedSourceExecutableSmoke" + +[[lean_exe]] +name = "pcsbcsSavedRecordDecoderSmoke" +root = "Whir.PCSBCSSourceSavedRecordDecoderSmoke" + +[[lean_exe]] +name = "pcsbcsSavedRecordDecoderCostSmoke" +root = "Whir.PCSBCSSourceSavedRecordDecoderCostSmoke" + +[[lean_exe]] +name = "pcsbcsMerkleSeedProjectionSmoke" +root = "Whir.PCSBCSMerkleSeedProjectionSmoke" + +[[lean_exe]] +name = "pcsbcsPublicCallerAnswersSmoke" +root = "Whir.PCSBCSPublicCallerAnswersSmoke" + +[[lean_exe]] +name = "pcsbcsSourcePublicMetadataSmoke" +root = "Whir.PCSBCSSourcePublicMetadataSmoke" + +[[lean_exe]] +name = "pcsbcsNativePacketCodecSmoke" +root = "Whir.PCSBCSNativePacketCodecSmoke" + +[[lean_exe]] +name = "pcsbcsPublicExtractorSmoke" +root = "Whir.PCSBCSPublicExtractorSmoke" + +[[lean_exe]] +name = "spongefishCurrentAdapterSmoke" +root = "Whir.SpongefishCurrentAdapterSmoke" + +[[lean_exe]] +name = "spongefishCurrentRecordCodecSmoke" +root = "Whir.SpongefishCurrentRecordCodecSmoke" From 47119f3fd40b59f5337152c5ed0c82e11616b1b7 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 05:45:15 +0100 Subject: [PATCH 21/28] proof: couple initialized current transcript byte replay --- verification/whir/README.md | 9 +- verification/whir/Whir.lean | 4 + .../Whir/SpongefishCurrentAdapterSmoke.lean | 48 ++ .../SpongefishCurrentInitializedMode.lean | 163 +++++ .../SpongefishCurrentMixedModeCompiler.lean | 590 ++++++++++++++++++ ...SpongefishCurrentObservedSessionEntry.lean | 305 +++++++++ .../SpongefishCurrentRoundSeparation.lean | 230 +++++++ 7 files changed, 1348 insertions(+), 1 deletion(-) create mode 100644 verification/whir/Whir/SpongefishCurrentInitializedMode.lean create mode 100644 verification/whir/Whir/SpongefishCurrentMixedModeCompiler.lean create mode 100644 verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRoundSeparation.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index 3ac08e886..9620b0846 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -142,6 +142,12 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentPrimitiveEventCompiler` separately compiles current byte reads, guarded draws and decoded hints into actual observed primitive queries. Its real execution agrees with the entire reached cursor and the hand-port replay's success or rejection, including work before a later failure. Zero draws and cursor-exhausted draws issue no finalization query; insufficient typed transport is rejected before absorption. `replayProgram_trace` identifies every literal compression node and answer in source order, while `replayProgram_exact_count` and the linear byte-work budget charge every occurrence. This compiler does not invoke a hidden compression function or assume mode representation or acceptance. It is not yet a mode-replacement, whole-native branching, raw hint/poison, Rows or Aeneas correspondence. +`SpongefishCurrentObservedSessionEntry` compiles session derivation, the literal `(session,zero32)` initialization node, nonempty instance absorption and reached replay into one ordinary public interaction. `SpongefishCurrentMixedModeCompiler` is a computable current semantic cursor compiler with full 32-byte construction-answer caching. Reads parse before binding; zero and exhausted draws keep their source guard order; decoded hints do not absorb. Its internally proved `resource` function charges complete construction paths on all reply-dependent and rejecting branches. Neither a hidden compression function nor supplied acceptance, coordinate-validity or `Counts` certificates are used to obtain the source endpoint. + +`SpongefishCurrentInitializedMode.program_real` joins those components: the actual observed derivation answer selects the subsequent semantic domain, and full reached/rejected byte replay agrees with the ordinary hand-port setup and replay. `afterPrefix_mode_bound` permits an arbitrary counted adaptive attacker prefix that produces the proof and hints, then charges all initialization and continuation work in the same interaction. Its exact ideal-compression mode loss is `min(1,(2Q^2-Q)/2^256)`, where `Q = A + setupBudget(tag,instanceBytes) + resource(instanceBytes.length+3,calls)`. This closes initialized current byte-source mode coupling, not the native PCS equation machine, original-statement decoder, current whole-observer knowledge composition, deterministic BLAKE2s security or Rust correspondence. + +`SpongefishCurrentRoundSeparation.opening_between` proves that any two verifier messages in the actual current PCS opening schedule have a nonempty canonical prover payload between them. A hint alone is not such a payload, and absent PoW introduces no verifier round. Closing a nonempty prover message after a positive draw strictly extends the full history, so the next literal raw construction key differs even if the previous draw stopped partway through a 32-byte output block. Consecutive E values within one verifier message may still share a block; they are not asserted to be independent rounds. Together with the current codec carrier cardinalities, these are PCS-only framing and entropy-carrier results, not yet the distributional native acceptance reduction. + `AnchoredMixedAttackerPrefix` preserves the unchanged mixed source lowering and its entire public view while freezing the literal strict-prefix Merkle table before the first anchor reply. Repeated grouped queries reuse the first prepared root and point. The exact ambiguity bound is `n/2^124` for the aggregate mixed draw cap, or `remaining/2^124` under the source `Counts` work bound; allocations, lookup requests and full construction-path work are not equated. The wrapper uses the historical pre-#607 header grammar. `AnchoredMixedAttackerPrefixSource.initial_source_prefixes` derives the cache and first-root invariants at every actual source prefix. Cache-hit observations can be omitted from the draw log without preserving its literal order; outside ordinary output collisions, their membership set suffices to preserve digest-selected preimages. `AnchoredMixedAttackerPrefixObserver.source_prefixes_of_alarm` derives precisely that guard from the SAME complete physical Merkle alarm already paid by the source observer. No second collision loss, clean-cache assumption, externally supplied frozen-root equality or extra lowering is introduced. @@ -174,6 +180,7 @@ The model also fixes a Lean L0 extraction discrepancy: authenticate the full pad - [WHIR, ePrint 2024/1586](https://eprint.iacr.org/2024/1586): substantive full-paper sections read from the November 21, 2024 PDF. Lemma 4.4 is the interleaved Johnson bound; Definition 4.9 defines MCA; Definition 4.14 and Claim 4.15 concern multiplicative folding; Construction 5.1/Theorem 5.2 give conditional RBR soundness. This numbering is not silently attributed to every later proceedings revision. - [WHIR proceedings, primary publisher](https://doi.org/10.1007/978-3-031-91134-7_8), footnote 6: the paper assumes `char(F) != 2` for its 2-smooth multiplicative subgroup and folding operation. This excludes direct application to this additive characteristic-two variant. The exact full-paper knowledge theorem was not verified in the newly retrieved publisher material and is not transplanted into the Lean model. - [Building Cryptographic Proofs from Hash Functions, source edition v1.2](https://github.com/hash-based-snargs-book/hash-based-snargs-book/blob/305fa3d9d19ee6dba135de64b3156d1760df8426/snargs-book.pdf), March 25, 2026: Definition 31.1.6 requires a polynomial-time extractor from IOP strings without verifier coins; Theorem 31.3.1 gives straight-line state-restoration knowledge loss `(t+k)*epsilonRBR`; Theorem 26.1.1 gives BCS knowledge loss `epsilonSR(Q) + deltaMT_multi(Q,Q+1) + Q^2/2^lambda`. Construction 25.1.1 requires the raw minimum verifier-message entropy to be at least `lambda`. Grouped PCS messages have an E element, giving the intended PCS-only `lambda = 192`; neither 256-bit compression nor a hypothetical stretched seed changes that hypothesis. The actual byte-duplex/full-history and shared-Merkle adapter must be proved before applying these expressions. Flock, bus/GKR and outer-protocol entropy are not covered. +- The same pinned book's section 25.1 explicitly distinguishes the hash-chain query, which includes the previous verifier randomness, from the basic full-prefix variant (`remark:bcs-with-basic-fs`). The latter queries the instance, all preceding commitments and salts, needs no minimum-round entropy condition, and omits the hash-chain `Q^2/2^lambda` term. Current duplex histories retain the full absorbed prover prefix and consumed-count tags, not previous coin bytes, so this basic variant is the appropriate adapter target. The current initialized byte-mode theorem does not by itself establish the required current native PCS/original-statement distributional join, and neither book knowledge theorem is applied unconditionally to deployed code. - [Ligerito, ePrint 2025/1187](https://eprint.iacr.org/2025/1187): full [author PDF](https://angeris.github.io/papers/ligerito.pdf), dated May 2025, read including the matrix-vector/partial-sumcheck construction and recursive protocol section 6. An immutable ePrint revision identifier was not obtained. - [Ring switching, ePrint 2024/504](https://eprint.iacr.org/2024/504): packing/security sections read from a cached full PDF. Definition 2.2 is packing and Theorem 3.5 is the compiler security statement in that inspected copy. Its precise dated ePrint revision was not established; the inspected bytes are identified by SHA-256 below. - [LCH14, arXiv 1404.3458v2](https://arxiv.org/abs/1404.3458v2): July 24, 2014 version. Section II-B equations (3)-(4) give additive subspace polynomials; II-C gives the normalized product basis and the subsequent sections the transform recurrence. @@ -241,7 +248,7 @@ Its checked `random_compression_failure_probability` bounds acceptance with no o `PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. -The final warning-denied library and compiled-model closure passed, and `Audit.lean` checked **14607 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. The compiled current real-BLAKE2s adapter exercised observed session derivation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The current record codec exercised all 65 pending-buffer lengths with both first flags. Eight maintained model, reset/counting, source-stream, PCS grouping and real-BLAKE2s Merkle/public-log scenarios passed. +The final warning-denied library and compiled-model closure passed, and `Audit.lean` checked **14789 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. The compiled current real-BLAKE2s adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The current record codec exercised all 65 pending-buffer lengths with both first flags. Eight maintained model, reset/counting, source-stream, PCS grouping and real-BLAKE2s Merkle/public-log scenarios passed in the preceding closure. The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index c7e36ff6b..d44ee969e 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -243,3 +243,7 @@ import Whir.AnchoredMixedAttackerPrefixObserver import Whir.SpongefishCurrentCommitmentReceive import Whir.SpongefishCurrentPhysicalRootCapture import Whir.SpongefishCurrentPrimitiveEventCompiler +import Whir.SpongefishCurrentObservedSessionEntry +import Whir.SpongefishCurrentMixedModeCompiler +import Whir.SpongefishCurrentInitializedMode +import Whir.SpongefishCurrentRoundSeparation diff --git a/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean b/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean index 9a52fbeb2..9bb4a9697 100644 --- a/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean +++ b/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean @@ -2,6 +2,8 @@ import Whir.SpongefishCurrentCommitmentReceive import Whir.SpongefishCurrentRecordOpeningQueries import Whir.SpongefishCurrentPhysicalRootCapture import Whir.SpongefishCurrentPrimitiveEventCompiler +import Whir.SpongefishCurrentInitializedMode +import Whir.SpongefishCurrentRoundSeparation /-! Real BLAKE2s execution of the current byte-adapter paths, including raw-root mismatch, truncated immutable record and an output-block boundary. This is a @@ -13,6 +15,10 @@ private def report (label : String) : IO Unit := do IO.println s!"current adapter: {label}" (← IO.getStdout).flush +private def eventBytes (events : List SourceEvent) : List Byte := + events.flatMap fun event => match event with + | .publicBytes bytes | .prover _ bytes | .verifier bytes | .hint bytes => bytes + def main : IO Unit := do let C := DuplexModeGame.blake2sOracle let c := DuplexModeGame.compressionOf C @@ -23,6 +29,48 @@ def main : IO Unit := do unless derived.view.result = session && derived.view.observations.length = 2 do throw (IO.userError "observed session derivation disagrees") report "observed session derivation agrees" + let instanceBytes : List Byte := [11] + let valueBytes := scalarBytes (E.ofK 9) + let initializedNarg := rawRoot zeroDigest ++ valueBytes + let initializedCalls : List Call := + [.read .root,.draw .fold,.draw .fold,.read .scalar,.draw .fold,.hint] + let initialized := DuplexModeGame.runReal C parameter + (SpongefishCurrentInitializedMode.program parameter tag instanceBytes initializedNarg [[7]] initializedCalls) + let some (.ok initializedData) := initialized.view.result + | throw (IO.userError "observed initialized mixed entry rejected valid input") + let some (.ok actualInitialized) := + SpongefishCurrentObservedSessionEntry.actualEntry c parameter tag instanceBytes initializedNarg [[7]] initializedCalls + | throw (IO.userError "actual initialized replay rejected valid input") + unless initializedData.narg = [] && initializedData.bytesRead = 56 && + initializedData.messagesRead = 2 && initializedData.hintsRead = 1 && + initializedData.pending.frames = actualInitialized.pending.frames && + initializedData.pending.consumed = actualInitialized.pending.consumed && + eventBytes initializedData.events = eventBytes actualInitialized.events do + throw (IO.userError "initialized mixed replay disagrees on actual bytes, cache reuse or reached state") + let ordinaryCount := initialized.view.observations.countP fun o => match o.query with + | .primitive _ _ => true | .construction _ _ => false + let constructionCount := initialized.view.observations.countP fun o => match o.query with + | .primitive _ _ => false | .construction _ _ => true + unless ordinaryCount = 3 && constructionCount = 3 && + initialized.primitiveCost ≤ SpongefishCurrentInitializedMode.budget tag instanceBytes initializedCalls do + throw (IO.userError "session seed or full-coordinate cache work disagrees") + report "observed initialized session and mixed replay matched actual bytes across shared and fresh output blocks" + let rejectedEntry := DuplexModeGame.runReal C parameter + (SpongefishCurrentInitializedMode.program parameter tag instanceBytes + (rawRoot zeroDigest ++ valueBytes.take 23) [[7]] initializedCalls) + let some (.error (rejectedData,.readRejected .scalar)) := rejectedEntry.view.result + | throw (IO.userError "initialized mode did not retain scalar rejection") + unless rejectedData.bytesRead = 32 && rejectedData.messagesRead = 1 && + rejectedData.narg.length = 23 && rejectedData.pending.consumed = 48 && + rejectedData.hintsRead = 0 do + throw (IO.userError "initialized mode charged or mutated an unreached rejected suffix") + report "observed initialized mode retained reached reject prefix and no later hint" + let layout : OpeningLayout := + ⟨2,⟨2,1,3,5,⟨1,by decide⟩⟩,[(1,⟨1,1,2,3,⟨0,by decide⟩⟩)],1,2,1,3,⟨0,by decide⟩⟩ + unless SpongefishCurrentRoundSeparation.scan false layout.schedule = some true && + (SpongefishCurrentRoundSeparation.scan false [.draw .fold,.hint,.draw .fold]).isNone do + throw (IO.userError "current round separation accepted a hint as an absorbed prover payload") + report "actual current PCS schedule separated verifier messages; a transport hint alone did not" let state := init c parameter session let pending : Pending := {domain := session} let shape : Shape := ⟨2,1,1,1⟩ diff --git a/verification/whir/Whir/SpongefishCurrentInitializedMode.lean b/verification/whir/Whir/SpongefishCurrentInitializedMode.lean new file mode 100644 index 000000000..76d0350ca --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentInitializedMode.lean @@ -0,0 +1,163 @@ +import Whir.SpongefishCurrentObservedSessionEntry +import Whir.SpongefishCurrentMixedModeCompiler + +/-! Current #607 initialized mixed mode. The complete SessionId derivation and +session/zero32 seed are observed ordinary queries. Their actually returned +session selects the subsequent construction domain. No fixed-domain registry, +success certificate, hidden CV or independently supplied session is assumed. + +This is the initialized byte-cursor source adapter, not the native PCS equation +machine, Merkle/original-claim observer, Rust compiler correspondence or a +Fiat-Shamir knowledge endpoint. Empty instance input is outside native +constructor correspondence because Rust panics there. -/ +namespace Whir.SpongefishCurrentInitializedMode +open Concrete FiatShamirGame DuplexRefinement DuplexModeGame +open SpongefishSessionAdapter SpongefishPCSRoundFrames SpongefishCurrentModeQueries +set_option autoImplicit false + +abbrev Result := Except (SpongefishCurrentMixedModeCompiler.Data × + SpongefishCurrentPrimitiveEventCompiler.ReplayError) SpongefishCurrentMixedModeCompiler.Data + +/-- Semantic data is reconstructed from the literal constructor input and its +observed derived domain. The ordinary setup's physical CV is intentionally not +an independent construction-oracle state. -/ +def initial (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : SpongefishCurrentMixedModeCompiler.SemanticCursor where + data := SpongefishCurrentMixedModeCompiler.forget + (SpongefishCurrentObservedSessionEntry.cursor session instanceBytes narg hints {cv := zeroDigest}) + framed := bind_frame_domain {domain := session} instanceBytes (initial_frame_domain session) + (by simp [maxCursor]) + bounded := by + by_cases empty : instanceBytes = [] <;> + simp [SpongefishCurrentMixedModeCompiler.forget,SpongefishCurrentObservedSessionEntry.cursor, + SpongefishPCSRoundFrames.bind,empty,maxCursor] + +@[simp] theorem initial_data (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) (state : State) : + (initial session instanceBytes narg hints).data = + SpongefishCurrentMixedModeCompiler.forget + (SpongefishCurrentObservedSessionEntry.cursor session instanceBytes narg hints state) := rfl + +@[simp] theorem constructor_domain (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) (state : State) : + (SpongefishCurrentObservedSessionEntry.cursor session instanceBytes narg hints state).pending.domain = + session := by + by_cases empty : instanceBytes = [] <;> + simp [SpongefishCurrentObservedSessionEntry.cursor,SpongefishPCSRoundFrames.bind,empty] + +@[simp] theorem initial_weight (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : + SpongefishCurrentMixedModeCompiler.weight (initial session instanceBytes narg hints).data.pending = + instanceBytes.length+3 := by + by_cases empty : instanceBytes = [] <;> + simp [initial,SpongefishCurrentMixedModeCompiler.forget, + SpongefishCurrentObservedSessionEntry.cursor,SpongefishCurrentMixedModeCompiler.weight, + SpongefishPCSRoundFrames.bind,retainedBytes,empty] + +/-- Setup is the existing observed ordinary program, not a new seed evaluator. +Every callback, including rejecting replay, is in the same shared Program. -/ +def program (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : Program (Option Result) := + WHIRModeFinal.bind + (SpongefishCurrentObservedSessionEntry.setupProgram parameter tag instanceBytes narg hints) + (fun result => match result with + | none => .done none + | some actual => WHIRModeFinal.bind + (SpongefishCurrentMixedModeCompiler.replayProgram + (initial actual.pending.domain instanceBytes narg hints) calls) + (fun result => .done (some (SpongefishCurrentMixedModeCompiler.eraseResult result)))) + +def budget (tag instanceBytes : List Byte) (calls : List Call) : Nat := + SpongefishCurrentObservedSessionEntry.setupBudget tag instanceBytes + + SpongefishCurrentMixedModeCompiler.resource (instanceBytes.length+3) calls + +theorem program_counted (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : + Counts (budget tag instanceBytes calls) (program parameter tag instanceBytes narg hints calls) := by + apply WHIRModeFinal.bind_counted _ _ + (SpongefishCurrentObservedSessionEntry.setupBudget tag instanceBytes) + (SpongefishCurrentMixedModeCompiler.resource (instanceBytes.length+3) calls) + (SpongefishCurrentObservedSessionEntry.setupProgram_certified parameter tag instanceBytes narg hints).1 + intro result + cases result with + | none => trivial + | some actual => + exact SpongefishCurrentPrimitiveEventCompiler.seq_done_counted _ _ + (SpongefishCurrentMixedModeCompiler.replay_counted _ calls _ (by simp)) + +theorem program_real (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + (runReal C parameter (program parameter tag instanceBytes narg hints calls)).view.result = + (SpongefishCurrentObservedSessionEntry.actualEntry (compressionOf C) parameter + tag instanceBytes narg hints calls).map SpongefishCurrentMixedModeCompiler.forgetResult := by + rw [program,WHIRModeFinal.bind_real_result,SpongefishCurrentObservedSessionEntry.setupProgram_real] + by_cases empty : instanceBytes = [] + · simp [SpongefishCurrentObservedSessionEntry.actualEntry, + SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty,runReal] + · simp only [SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty,↓reduceIte, + Option.map_some,WHIRModeFinal.bind_real_result,runReal] + have same := SpongefishCurrentMixedModeCompiler.replay_real C parameter + (initial (derive (compressionOf C) parameter tag) instanceBytes narg hints) + (SpongefishCurrentObservedSessionEntry.cursor (derive (compressionOf C) parameter tag) + instanceBytes narg hints + (absorb (compressionOf C) (init (compressionOf C) parameter + (derive (compressionOf C) parameter tag)) instanceBytes)) + rfl (session_bridge (compressionOf C) parameter _ instanceBytes) + (by intro q d found; cases found) calls + simpa [SpongefishCurrentObservedSessionEntry.actualEntry, + SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty] using congrArg some same + +/-- The counts apply to every ordinary reply and every construction reply, +including invalid constructor and rejected replay, without an external cap +or a verifier-success premise. -/ +theorem program_work (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + (runReal C parameter (program parameter tag instanceBytes narg hints calls)).primitiveCost ≤ + budget tag instanceBytes calls := + runReal_counts C parameter _ _ (program_counted parameter tag instanceBytes narg hints calls) + +structure Input where + narg : List Byte + hints : List (List Byte) + +/-- An arbitrary counted attacker interaction may generate the proof and +hints from its own oracle answers. Its observations remain before every +initialized-verifier observation in the unchanged shared interpreter. -/ +def afterPrefix (parameter : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program Input) (calls : List Call) : Program (Option Result) := + WHIRModeFinal.bind prefixProgram (fun input => + program parameter tag instanceBytes input.narg input.hints calls) + +theorem afterPrefix_counted (parameter : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program Input) (calls : List Call) (A : Nat) + (attacker : Counts A prefixProgram) : + Counts (A+budget tag instanceBytes calls) + (afterPrefix parameter tag instanceBytes prefixProgram calls) := + WHIRModeFinal.bind_counted _ _ A _ attacker + (fun input => program_counted parameter tag instanceBytes input.narg input.hints calls) + +/-- Current initialized byte-source coupling, with arbitrary adaptive +attacker prefix and rejection behavior. This is ideal-compression mode +security; it is not a current PCS acceptance or knowledge theorem. -/ +theorem afterPrefix_mode_bound {Coins : Type} [Fintype Coins] + (parameter : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Coins → Program Input) (calls : List Call) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (D : View (Option Result) → Bool) : + let Q := A+budget tag instanceBytes calls + letI := DuplexPublicSimulator.seedFintype + ModeAdv (DuplexPublicSimulator.simulator Q) parameter + (fun coin => afterPrefix parameter tag instanceBytes (prefixProgram coin) calls) + (fun coin => afterPrefix_counted parameter tag instanceBytes (prefixProgram coin) calls A + (attacker coin)) D ≤ min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) := by + simpa only [duplexModeLoss_eq] using + PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss + (AdvCoins := Coins) (R := Option Result) (A+budget tag instanceBytes calls) parameter + (fun coin => afterPrefix parameter tag instanceBytes (prefixProgram coin) calls) + (fun coin => afterPrefix_counted parameter tag instanceBytes (prefixProgram coin) calls A + (attacker coin)) D + +#print axioms program_counted +#print axioms program_real +#print axioms program_work +#print axioms afterPrefix_mode_bound +end Whir.SpongefishCurrentInitializedMode diff --git a/verification/whir/Whir/SpongefishCurrentMixedModeCompiler.lean b/verification/whir/Whir/SpongefishCurrentMixedModeCompiler.lean new file mode 100644 index 000000000..8928e021f --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentMixedModeCompiler.lean @@ -0,0 +1,590 @@ +import Whir.SpongefishCurrentPrimitiveEventCompiler +import Whir.SpongefishCurrentPhysicalRootCapture + +/-! Byte-level current #607 hand-port into the existing public-compression mode +program. This is not Rust/Aeneas equivalence, native acceptance, or FS extraction. +Only output requests use construction coordinates; ordinary public compression +can be composed with the unchanged Program/bind and Mixed.compile interpreters. +The cache stores complete 32-byte replies, not independent 24-byte coins. -/ +namespace Whir.SpongefishCurrentMixedModeCompiler +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentModeQueries +set_option autoImplicit false + +deriving instance DecidableEq for Terminal +deriving instance DecidableEq for Coordinate + +abbrev seq {A B : Type} := @WHIRModeFinal.bind A B + +/-- Everything observed by the source cursor except its unobserved physical CV, +pending block, and output buffer. Transport and reached counters are retained. -/ +structure Data where + pending : Pending + narg : List Byte + bytesRead : Nat := 0 + messagesRead : Nat := 0 + hintsRead : Nat := 0 + hints : List (List Byte) := [] + events : List SourceEvent := [] + +def forget (cur : Cursor) : Data := + ⟨cur.pending,cur.narg,cur.bytesRead,cur.messagesRead,cur.hintsRead,cur.hints,cur.events⟩ + +abbrev Cache := Coordinate → Option Digest32 + +def GoodCache (c : Compression) (iv : Digest32) (cache : Cache) : Prop := + ∀ q d, cache q = some d → d = evalCoordinate c iv q + +/-- Certificates concern byte framing and cursors only, never acceptance or C. -/ +structure SemanticCursor where + data : Data + framed : FrameDomain data.pending + bounded : data.pending.consumed ≤ maxCursor + cache : Cache := fun _ => none + +def start (cur : Cursor) (framed : FrameDomain cur.pending) + (bounded : cur.pending.consumed ≤ maxCursor) : SemanticCursor := + ⟨forget cur,framed,bounded,fun _ => none⟩ + +def store (cache : Cache) (q : Coordinate) (d : Digest32) : Cache := + fun other => if other = q then some d else cache other + + theorem good_store (c : Compression) (iv : Digest32) (cache : Cache) + (good : GoodCache c iv cache) (q : Coordinate) : + GoodCache c iv (store cache q (evalCoordinate c iv q)) := by + classical + intro other d h + unfold store at h + split at h + · rename_i equal; subst other; exact Option.some.inj h.symm + · exact good other d h + +/-- A cache miss asks the exact existing construction query. A cache hit reuses +all 32 bytes, including across calls and when a coordinate is repeated. -/ +def request (cache : Cache) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : Program (Cache × Digest32) := + match cache q with + | some d => .done (cache,d) + | none => .ask (.construction q valid) (fun d => .done (store cache q d,d)) + +theorem request_real (C : PrimitiveOracle) (iv : Digest32) (cache : Cache) + (good : GoodCache (compressionOf C) iv cache) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : + let result := (runReal C iv (request cache q valid)).view.result + GoodCache (compressionOf C) iv result.1 ∧ result.2 = evalCoordinate (compressionOf C) iv q := by + unfold request + cases found : cache q with + | none => exact ⟨good_store _ _ _ good q,rfl⟩ + | some d => exact ⟨good,good q d found⟩ + +theorem request_counted (cache : Cache) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : Counts (pathCost q) (request cache q valid) := by + unfold request + cases cache q with + | none => exact ⟨Nat.le_refl _,fun _ => trivial⟩ + | some => trivial + + theorem coordinate_cost (m : Pending) (block : Nat) : + pathCost (coordinate m block) = pathCost (coordinate m 0) := by + simp [pathCost,DuplexEncoding.plan,coordinate] + +/-- Coordinates are close-history plus floor(byte-position/32), not call index. -/ +def collect (m : Pending) (positions : List Nat) + (valid : ∀ p ∈ positions, DuplexEncoding.Admissible (coordinate m (p/32))) + (cache : Cache) : Program (Cache × List Byte) := + match positions with + | [] => .done (cache,[]) + | p :: ps => seq (request cache (coordinate m (p/32)) (valid p List.mem_cons_self)) + (fun (next,d) => seq (collect m ps (fun j h => valid j (List.mem_cons_of_mem _ h)) next) + (fun (last,bs) => .done (last,d ⟨p%32,Nat.mod_lt _ (by decide)⟩ :: bs))) + + theorem collect_real (C : PrimitiveOracle) (iv : Digest32) (m : Pending) + (positions : List Nat) + (valid : ∀ p ∈ positions, DuplexEncoding.Admissible (coordinate m (p/32))) + (cache : Cache) (good : GoodCache (compressionOf C) iv cache) : + let result := (runReal C iv (collect m positions valid cache)).view.result + GoodCache (compressionOf C) iv result.1 ∧ + result.2 = positions.map (fun p => evalCoordinate (compressionOf C) iv + (coordinate m (p/32)) ⟨p%32,Nat.mod_lt _ (by decide)⟩) := by + induction positions generalizing cache with + | nil => exact ⟨good,rfl⟩ + | cons p ps ih => + simp only [collect,seq,WHIRModeFinal.bind_real_result] + have first := request_real C iv cache good (coordinate m (p/32)) (valid p List.mem_cons_self) + have tail := ih (fun j h => valid j (List.mem_cons_of_mem _ h)) _ first.1 + exact ⟨tail.1,by simp only [runReal,List.map_cons,first.2,tail.2]⟩ + + theorem collect_counted (m : Pending) (positions : List Nat) + (valid : ∀ p ∈ positions, DuplexEncoding.Admissible (coordinate m (p/32))) + (cache : Cache) : Counts (positions.length * pathCost (coordinate m 0)) + (collect m positions valid cache) := by + induction positions generalizing cache with + | nil => trivial + | cons p ps ih => + have tails : ∀ result : Cache × Digest32, + Counts (ps.length * pathCost (coordinate m 0)) + (seq (collect m ps (fun j h => valid j (List.mem_cons_of_mem _ h)) result.1) + (fun (last,bs) => .done (last,result.2 ⟨p%32,Nat.mod_lt _ (by decide)⟩ :: bs))) := by + intro result + exact SpongefishCurrentPrimitiveEventCompiler.seq_done_counted _ _ (ih _ result.1) + simpa only [collect,List.length_cons,Nat.add_mul,Nat.one_mul,coordinate_cost,Nat.add_comm] + using WHIRModeFinal.bind_counted _ _ (pathCost (coordinate m (p/32))) + (ps.length * pathCost (coordinate m 0)) (request_counted _ _ _) tails + + def positions (m : Pending) (n : Nat) : List Nat := + (List.range n).map (m.consumed + ·) + + theorem positions_valid (m : Pending) (framed : FrameDomain m) (n : Nat) + (guard : m.consumed + n ≤ maxCursor) : + ∀ p ∈ positions m n, DuplexEncoding.Admissible (coordinate m (p/32)) := by + intro p member + obtain ⟨j,inRange,rfl⟩ := List.mem_map.mp member + have within := List.mem_range.mp inRange + apply coordinate_admissible m framed + simp only [maxCursor] at guard + omega + + def boundData (cur : SemanticCursor) (bytes : List Byte) : SemanticCursor := + {cur with + data := {cur.data with pending := bind cur.data.pending bytes} + framed := bind_frame_domain _ _ cur.framed cur.bounded + bounded := by + by_cases empty : bytes = [] + · simpa [SpongefishPCSRoundFrames.bind,empty] using cur.bounded + · simp [SpongefishPCSRoundFrames.bind,empty,maxCursor]} + + def publicProgram (cur : SemanticCursor) (bytes : List Byte) : Program SemanticCursor := + .done {boundData cur bytes with data := + {(boundData cur bytes).data with events := cur.data.events ++ [.publicBytes bytes]}} + + def readNext (cur : SemanticCursor) (kind : WireKind) (value : kind.Value) + (rest : List Byte) : SemanticCursor := + {boundData cur (kind.codec.bytes value) with data := + {(boundData cur (kind.codec.bytes value)).data with + narg := rest + bytesRead := cur.data.bytesRead + kind.codec.size + messagesRead := cur.data.messagesRead + kind.messages + events := cur.data.events ++ [.prover kind (kind.codec.bytes value)]}} + + def hintNext (cur : SemanticCursor) (bytes : List Byte) (rest : List (List Byte)) : SemanticCursor := + {cur with data := {cur.data with + hints := rest + hintsRead := cur.data.hintsRead+1 + events := cur.data.events ++ [.hint bytes]}} + + def drawn (cur : SemanticCursor) (n : Nat) (guard : cur.data.pending.consumed+n ≤ maxCursor) + (cache : Cache) (bytes : List Byte) : SemanticCursor := + {data := {cur.data with + pending := draw cur.data.pending n + events := cur.data.events ++ [.verifier bytes]} + framed := draw_frame_domain _ _ cur.framed + bounded := by + by_cases zero : n = 0 + · simpa [draw,zero] using cur.bounded + · simpa [draw,zero] using guard + cache := cache} + +abbrev ReplayError := SpongefishCurrentPrimitiveEventCompiler.ReplayError +abbrev Result := Except (SemanticCursor × ReplayError) SemanticCursor + +def eraseResult : Result → Except (Data × ReplayError) Data + | .ok cur => .ok cur.data + | .error (cur,e) => .error (cur.data,e) + +def forgetResult : SpongefishCurrentPrimitiveEventCompiler.ReplayResult → Except (Data × ReplayError) Data + | .ok cur => .ok (forget cur) + | .error (cur,e) => .error (forget cur,e) + +/-- Reads are parsed before binding. Failing reads/draws/hints retain the reached +cursor; hints never bind. Guards are precisely the existing source guards. -/ +def replayProgram : SemanticCursor → List Call → Program Result + | cur, [] => .done (.ok cur) + | cur, .read kind :: calls => + match kind.codec.parse cur.data.narg with + | none => .done (.error (cur,.readRejected kind)) + | some (value,rest) => replayProgram (readNext cur kind value rest) calls + | cur, .hint :: calls => + match cur.data.hints with + | [] => .done (.error (cur,.missingHint)) + | bytes :: rest => replayProgram (hintNext cur bytes rest) calls + | cur, .draw g :: calls => + if _zero : g.bytes = 0 then + replayProgram {cur with data := {cur.data with events := cur.data.events ++ [.verifier []]}} calls + else if guard : cur.data.pending.consumed + g.bytes ≤ maxCursor then + seq (collect cur.data.pending (positions cur.data.pending g.bytes) + (positions_valid _ cur.framed _ guard) cur.cache) + (fun (cache,bytes) => replayProgram (drawn cur g.bytes guard cache bytes) calls) + else .done (.error (cur,.drawRejected .cursorExhausted)) + +/-- Explicit physical-byte envelope; old frame boundaries are charged too. -/ +def weight (m : Pending) : Nat := (retainedBytes m).length + m.frames.length + 3 + + theorem chunks_length (first : Bool) (previous : Nat) (pending bytes : List Byte) : + (DuplexEncoding.chunks first previous pending bytes).length ≤ bytes.length+1 := by + induction bytes generalizing first previous pending with + | nil => simp only [DuplexEncoding.chunks]; split <;> simp + | cons b bs ih => + simp only [DuplexEncoding.chunks,List.length_cons] + split + · simp only [List.length_cons]; have := ih false 0 [b]; omega + · exact Nat.le_trans (ih _ _ _) (by omega) + + theorem path_weight (m : Pending) (block : Nat) : pathCost (coordinate m block) ≤ weight m := by + have frames : ∀ fs : List ByteFrame, + (fs.map ByteFrame.historicalCore |>.flatMap DuplexEncoding.framePlan).length ≤ + (fs.flatMap fun f => match f with | .absorb _ bs => bs).length + fs.length := by + intro fs + induction fs with + | nil => simp + | cons f fs ih => + cases f with + | absorb previous bs => + simp only [List.map_cons,List.flatMap_cons,List.length_append,List.length_cons, + ByteFrame.historicalCore,DuplexEncoding.framePlan] at ih ⊢ + have := chunks_length true previous [] bs + omega + have old := frames m.frames + have closed := frames (close m).frames + by_cases empty : m.run = [] + · simpa [pathCost,DuplexEncoding.plan,coordinate,close,empty,Pending.core,weight,retainedBytes, + List.length_append] using (show + ((m.frames.map ByteFrame.historicalCore).flatMap DuplexEncoding.framePlan).length+2 ≤ + (m.frames.flatMap fun f => match f with | .absorb _ bs => bs).length+m.frames.length+3 by omega) + · simp only [close,empty,↓reduceIte,List.flatMap_append,List.flatMap_singleton, + List.length_append,List.length_singleton] at closed + change + ((m.frames ++ [ByteFrame.absorb m.previous m.run]).map ByteFrame.historicalCore |>.flatMap + DuplexEncoding.framePlan).length ≤ + (m.frames.flatMap fun f => match f with | .absorb _ bs => bs).length + + m.run.length + (m.frames.length+1) at closed + have bound : + (((m.frames ++ [ByteFrame.absorb m.previous m.run]).map ByteFrame.historicalCore).flatMap + DuplexEncoding.framePlan).length+2 ≤ + (m.frames.flatMap fun f => match f with | .absorb _ bs => bs).length+ + m.run.length+m.frames.length+3 := by omega + simp only [pathCost,DuplexEncoding.plan,coordinate,close,empty,↓reduceIte,Pending.core, + weight,retainedBytes,List.map_append,List.map_singleton,List.flatMap_append, + List.flatMap_singleton,List.length_append,List.length_cons] at bound ⊢ + omega + + theorem bind_weight (m : Pending) (bytes : List Byte) : + weight (bind m bytes) = weight m + bytes.length := by + rw [weight,bind_retains,List.length_append] + by_cases empty : bytes = [] <;> + simp [SpongefishPCSRoundFrames.bind,empty,weight,Nat.add_comm,Nat.add_left_comm] + + theorem draw_weight (m : Pending) (n : Nat) : weight (draw m n) ≤ weight m + 1 := by + rw [weight,draw_retains] + by_cases zero : n = 0 + · simp [draw,zero,weight] + · by_cases empty : m.run = [] <;> simp [draw,zero,close,empty,weight,Nat.add_assoc] + +/-- Finite worst-case resource function, based on physical initial bytes/history +and literal call sizes. It overcharges cache hits and rejecting suffixes, but each +miss pays its entire construction path, not merely one squeezed byte. -/ +def resource : Nat → List Call → Nat + | _, [] => 0 + | w, .read kind :: calls => resource (w+kind.codec.size) calls + | w, .draw g :: calls => g.bytes*w + resource (w+1) calls + | w, .hint :: calls => resource w calls + + theorem replay_counted (cur : SemanticCursor) (calls : List Call) (w : Nat) + (cap : weight cur.data.pending ≤ w) : Counts (resource w calls) (replayProgram cur calls) := by + induction calls generalizing cur w with + | nil => trivial + | cons call calls ih => + cases call with + | read kind => + simp only [replayProgram] + cases kind.codec.parse cur.data.narg with + | none => trivial + | some pair => + obtain ⟨value,rest⟩ := pair + apply ih + change weight (bind cur.data.pending (kind.codec.bytes value)) ≤ w+kind.codec.size + rw [bind_weight] + simp only [Codec.bytes,List.length_ofFn] + omega + | hint => + simp only [replayProgram] + cases cur.data.hints with + | nil => trivial + | cons bytes rest => exact ih _ w cap + | draw g => + simp only [replayProgram] + split + · apply WHIRModeFinal.counts_mono (ih _ (w+1) (by dsimp; omega)) + simp only [resource]; omega + · split + · apply WHIRModeFinal.counts_mono + (WHIRModeFinal.bind_counted _ _ (g.bytes*w) (resource (w+1) calls) ?_ ?_) + · exact Nat.le_refl _ + · apply WHIRModeFinal.counts_mono (collect_counted _ _ _ _) + simp only [positions,List.length_map,List.length_range] + exact Nat.mul_le_mul_left _ ((path_weight _ 0).trans cap) + · intro pair + apply ih + exact (draw_weight _ _).trans (by omega) + · trivial + + + theorem public_real (C : PrimitiveOracle) (iv : Digest32) (cur : SemanticCursor) + (actual : Cursor) (same : cur.data = forget actual) (bytes : List Byte) : + (runReal C iv (publicProgram cur bytes)).view.result.data = + forget (publicAbsorb (compressionOf C) actual bytes) := by + simp [publicProgram,runReal,boundData,same,publicAbsorb,forget] + +/-- Source representation is an immutable initial precondition, not an +accepted-current-state certificate. No physical CV enters the compiler. -/ + theorem cursor_eq (c : Compression) (iv : Digest32) (actual : Cursor) + (represented : RepresentsCurrent c iv actual.pending actual.state) : + actual.state.consumed = actual.pending.consumed := + (congrArg State.consumed represented.2.1).trans + (materialize_consumed c iv actual.pending.core actual.state.output represented.1) + + theorem collect_source (C : PrimitiveOracle) (iv : Digest32) (actual : Cursor) + (represented : RepresentsCurrent (compressionOf C) iv actual.pending actual.state) + (framed : FrameDomain actual.pending) (cache : Cache) + (good : GoodCache (compressionOf C) iv cache) (n : Nat) (positive : n ≠ 0) + (guard : actual.pending.consumed+n ≤ maxCursor) (state : State) (bytes : List Byte) + (squeezed : squeeze (compressionOf C) actual.state n = .ok (state,bytes)) : + let result := (runReal C iv (collect actual.pending (positions actual.pending n) + (positions_valid _ framed _ guard) cache)).view.result + GoodCache (compressionOf C) iv result.1 ∧ result.2 = bytes := by + have h := collect_real C iv actual.pending (positions actual.pending n) + (positions_valid _ framed _ guard) cache good + refine ⟨h.1,h.2.trans ?_⟩ + apply List.ext_getElem + · simp [positions,(squeeze_exact_cursor _ _ _ _ _ squeezed).2] + · intro j hj hb + simp only [positions,List.map_map,List.getElem_map,List.getElem_range] + exact (squeezed_byte _ _ _ _ _ represented n positive bytes squeezed j + (by simpa [positions] using hj)).symm + +/-- Success and rejection both agree with the instrumented actual replay after +erasing only unobserved physical state. The failing cursor and prefix events +and counters are preserved, rather than dropping an error to `none`. -/ +theorem replay_real (C : PrimitiveOracle) (iv : Digest32) (cur : SemanticCursor) + (actual : Cursor) (same : cur.data = forget actual) + (represented : RepresentsCurrent (compressionOf C) iv actual.pending actual.state) + (good : GoodCache (compressionOf C) iv cur.cache) (calls : List Call) : + eraseResult (runReal C iv (replayProgram cur calls)).view.result = + forgetResult (SpongefishCurrentPrimitiveEventCompiler.actualReplay + (compressionOf C) actual calls) := by + induction calls generalizing cur actual with + | nil => exact congrArg Except.ok same + | cons call calls ih => + have pending : cur.data.pending = actual.pending := congrArg Data.pending same + have narg : cur.data.narg = actual.narg := congrArg Data.narg same + have hints : cur.data.hints = actual.hints := congrArg Data.hints same + have cursor := cursor_eq (compressionOf C) iv actual represented + cases call with + | read kind => + cases parsed : kind.codec.parse actual.narg with + | none => + simp [replayProgram,parsed,runReal,eraseResult,forgetResult,forget, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read,same] + | some pair => + obtain ⟨value,rest⟩ := pair + let next : Cursor := {actual with + state := absorb (compressionOf C) actual.state (kind.codec.bytes value) + pending := bind actual.pending (kind.codec.bytes value) + narg := rest + bytesRead := actual.bytesRead+kind.codec.size + messagesRead := actual.messagesRead+kind.messages + events := actual.events ++ [.prover kind (kind.codec.bytes value)]} + have h := ih (readNext cur kind value rest) next + (by simp [readNext,boundData,same,forget,next]) + (bind_bridge _ _ _ _ represented _) good + simpa [replayProgram,narg,parsed, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read,next] using h + | hint => + cases transport : actual.hints with + | nil => + simp [replayProgram,transport,runReal,eraseResult,forgetResult,forget, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint,same] + | cons bytes rest => + let next : Cursor := {actual with + hints := rest + hintsRead := actual.hintsRead+1 + events := actual.events ++ [.hint bytes]} + have h := ih (hintNext cur bytes rest) next + (by simp [hintNext,same,forget,next]) represented good + simpa [replayProgram,hints,transport, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint,next] using h + | draw g => + by_cases zero : g.bytes = 0 + · let next : Cursor := {actual with events := actual.events ++ [.verifier []]} + have h := ih + {cur with data := {cur.data with events := cur.data.events ++ [.verifier []]}} + next (by simp [same,forget,next]) represented good + simpa [replayProgram,zero, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeeze,draw,next] using h + · by_cases guard : cur.data.pending.consumed+g.bytes ≤ maxCursor + · have actualGuard : actual.pending.consumed+g.bytes ≤ maxCursor := by + simpa only [pending] using guard + let result := squeezeLoop (compressionOf C) g.bytes (finish (compressionOf C) actual.state) + have squeezed : squeeze (compressionOf C) actual.state g.bytes = .ok result := by + simp [squeeze,zero,cursor,actualGuard,result] + let collected := (runReal C iv (collect cur.data.pending + (positions cur.data.pending g.bytes) + (positions_valid _ cur.framed _ guard) cur.cache)).view.result + have source : GoodCache (compressionOf C) iv collected.1 ∧ collected.2 = result.2 := by + have h := collect_source C iv actual represented + (by simpa only [pending] using cur.framed) cur.cache good g.bytes zero + actualGuard result.1 result.2 squeezed + simpa only [collected,pending] using h + let next : Cursor := {actual with + state := result.1 + pending := draw actual.pending g.bytes + events := actual.events ++ [.verifier result.2]} + have h := ih (drawn cur g.bytes guard collected.1 collected.2) next + (by simp [drawn,same,forget,next,source.2]) + (draw_bridge _ _ _ _ _ represented _ _ squeezed) source.1 + simpa [replayProgram,zero,guard,seq,WHIRModeFinal.bind_real_result, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeezed,next,collected] using h + · have exhausted : ¬actual.pending.consumed+g.bytes ≤ maxCursor := by + simpa only [pending] using guard + simp only [replayProgram,zero,↓reduceDIte,guard,runReal,eraseResult, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeeze,cursor, + exhausted,↓reduceIte] + simp only [forgetResult] + exact congrArg (fun d => Except.error (d, + SpongefishCurrentPrimitiveEventCompiler.ReplayError.drawRejected .cursorExhausted)) same + +theorem source_endpoint (C : PrimitiveOracle) (iv : Digest32) (actual : Cursor) + (represented : RepresentsCurrent (compressionOf C) iv actual.pending actual.state) + (framed : FrameDomain actual.pending) (calls : List Call) : + let cur := start actual framed represented.1.2.2.1 + Counts (resource (weight actual.pending) calls) (replayProgram cur calls) ∧ + eraseResult (runReal C iv (replayProgram cur calls)).view.result = + forgetResult (SpongefishCurrentPrimitiveEventCompiler.actualReplay + (compressionOf C) actual calls) ∧ + (runReal C iv (replayProgram cur calls)).primitiveCost ≤ + resource (weight actual.pending) calls := by + dsimp only + have counted := replay_counted (start actual framed represented.1.2.2.1) calls + (weight actual.pending) (Nat.le_refl _) + exact ⟨counted,replay_real C iv _ actual rfl represented (by intro q d h; cases h) calls, + runReal_counts C iv _ _ counted⟩ + +/-- Public binding and ordinary compression use the same existing Program. +These compositional entry points do not introduce a new framing convention. -/ +def publicReplayProgram (cur : SemanticCursor) (bytes : List Byte) + (calls : List Call) : Program Result := + seq (publicProgram cur bytes) (fun next => replayProgram next calls) + +theorem publicReplay_counted (cur : SemanticCursor) (bytes : List Byte) (calls : List Call) : + Counts (resource (weight cur.data.pending+bytes.length) calls) + (publicReplayProgram cur bytes calls) := by + change Counts _ (replayProgram _ calls) + apply replay_counted + change weight (bind cur.data.pending bytes) ≤ weight cur.data.pending+bytes.length + exact Nat.le_of_eq (bind_weight _ _) + +theorem publicReplay_real (C : PrimitiveOracle) (iv : Digest32) (cur : SemanticCursor) + (actual : Cursor) (same : cur.data = forget actual) + (represented : RepresentsCurrent (compressionOf C) iv actual.pending actual.state) + (good : GoodCache (compressionOf C) iv cur.cache) (bytes : List Byte) (calls : List Call) : + eraseResult (runReal C iv (publicReplayProgram cur bytes calls)).view.result = + forgetResult (SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) + (publicAbsorb (compressionOf C) actual bytes) calls) := by + unfold publicReplayProgram + rw [seq,WHIRModeFinal.bind_real_result] + apply replay_real + · exact public_real C iv cur actual same bytes + · exact bind_bridge _ _ _ _ represented _ + · exact good + +/-- One ordinary observation can precede any current replay without becoming a +semantic absorb or selecting a fictitious independent verifier round. Its real +answer is the shared public C answer; Counts charges it on every continuation. -/ +def ordinaryReplayProgram (input : Node) (cur : SemanticCursor) + (calls : List Call) : Program Result := + seq (SpongefishCurrentPrimitiveEventCompiler.primitive input.cv input.block input.tweak input.last) + (fun _ => replayProgram cur calls) + +theorem ordinaryReplay_counted (input : Node) (cur : SemanticCursor) (calls : List Call) : + Counts (1+resource (weight cur.data.pending) calls) (ordinaryReplayProgram input cur calls) := by + exact WHIRModeFinal.bind_counted _ _ 1 _ + (SpongefishCurrentPrimitiveEventCompiler.primitive_certified _ _ _ _).1 + (fun _ => replay_counted cur calls _ (Nat.le_refl _)) + +theorem ordinaryReplay_real (C : PrimitiveOracle) (iv : Digest32) (input : Node) + (cur : SemanticCursor) (actual : Cursor) (same : cur.data = forget actual) + (represented : RepresentsCurrent (compressionOf C) iv actual.pending actual.state) + (good : GoodCache (compressionOf C) iv cur.cache) (calls : List Call) : + eraseResult (runReal C iv (ordinaryReplayProgram input cur calls)).view.result = + forgetResult (SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) actual calls) := by + simp only [ordinaryReplayProgram,seq,WHIRModeFinal.bind_real_result] + exact replay_real C iv cur actual same represented good calls + +#print axioms publicReplay_real +#print axioms publicReplay_counted +#print axioms ordinaryReplay_real +#print axioms ordinaryReplay_counted + +#print axioms source_endpoint +#print axioms replay_counted +#print axioms collect_source + +/-- Literal raw construction requests recover current raw32 headers when an +actual header receipt generated the pending run. No saved record is assumed. -/ + theorem header_request {B : Nat} (c : Compression) (iv : Digest32) + (before header : Cursor) (shape : SpongefishSessionAdapter.Shape) (root : Digest32) + (received : SpongefishCurrentAnchorHeader.readHeader c before shape = some (header,root)) + (framed : FrameDomain header.pending) (block : Nat) (bounded : block < 2^44) + (work : pathCost (coordinate header.pending block) ≤ B) : + SpongefishCurrentAnchorHeader.rawHeader shape iv + (constructionKey B iv (coordinate header.pending block) work) = some root ∧ + SpongefishCurrentPhysicalRootCapture.recognize shape iv + (.inr (constructionKey B iv (coordinate header.pending block) work)) = + some (SpongefishCurrentPhysicalRootCapture.reference shape root) := by + have valid := coordinate_admissible header.pending framed block bounded + have facts := SpongefishCurrentAnchorHeader.readHeader_facts c before header shape root received + have parsed := SpongefishCurrentAnchorHeader.closed_header header.pending shape facts.1 root + before.pending.run facts.2.2.2.2.2.2 + have raw : SpongefishCurrentAnchorHeader.rawHeader shape iv + (constructionKey B iv (coordinate header.pending block) work) = some root := by + rw [SpongefishCurrentAnchorHeader.rawHeader, + WHIRHeaderRoots.decodeRaw_construction iv _ valid work] + exact parsed + exact ⟨raw,SpongefishCurrentPhysicalRootCapture.recognize_rawHeader shape iv _ valid work + block rfl root raw⟩ + +/-- No per-query admissibility or Counts premise: header framing is propagated +from the initial source invariants, the byte guard gives the block bound, and +the physical history envelope proves the complete raw path bound internally. -/ +theorem header_request_derived (c : Compression) (iv : Digest32) + (before header : Cursor) (shape : SpongefishSessionAdapter.Shape) (root : Digest32) + (received : SpongefishCurrentAnchorHeader.readHeader c before shape = some (header,root)) + (represented : RepresentsCurrent c iv before.pending before.state) + (framed : FrameDomain before.pending) (n j : Nat) + (guard : header.pending.consumed+n ≤ maxCursor) (within : j < n) : + let q := coordinate header.pending ((header.pending.consumed+j)/32) + let work := path_weight header.pending ((header.pending.consumed+j)/32) + DuplexEncoding.Admissible q ∧ + SpongefishCurrentAnchorHeader.rawHeader shape iv + (constructionKey (weight header.pending) iv q work) = some root ∧ + SpongefishCurrentPhysicalRootCapture.recognize shape iv + (.inr (constructionKey (weight header.pending) iv q work)) = + some (SpongefishCurrentPhysicalRootCapture.reference shape root) := by + have replay := SpongefishCurrentAnchorHeader.readHeader_replay c before header shape root received + have propagated := all_round_frame_domain c iv before header + [.read .scalar,.read .scalar,.read .scalar,.read .root] represented framed replay + have block : (header.pending.consumed+j)/32 < 2^44 := by + simp only [maxCursor] at guard + omega + exact ⟨coordinate_admissible _ propagated.2 _ block, + header_request c iv before header shape root received propagated.2 _ block (path_weight _ _)⟩ + +#print axioms header_request_derived + +end Whir.SpongefishCurrentMixedModeCompiler diff --git a/verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean b/verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean new file mode 100644 index 000000000..dfc6dca78 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean @@ -0,0 +1,305 @@ +import Whir.SpongefishCurrentPrimitiveEventCompiler + +/-! Ordinary-source initialized session entry for current #607 at +75d4562bde1efe296b4e32d2a195fdfc232b3ead. SessionId derivation, the literal +session/zero32 seed, instance absorption, and every reached replay call share +one observed primitive interaction. No live CV, session ID, successful replay, +or mode-equivalence certificate is an input. + +The Rust constructor panics on empty instance bytes. Here `none` denotes an +invalid constructor input; correspondence to its ordinary initialized state is +claimed only for nonempty instance bytes, not as Rust panic/error equality. +This is an executable mathematical hand-port, not Aeneas equivalence, the +current mixed-mode compiler, or a whole deployed Fiat-Shamir knowledge claim. +-/ +namespace Whir.SpongefishCurrentObservedSessionEntry +open FiatShamirGame Concrete DuplexRefinement DuplexModeGame +open SpongefishSessionAdapter SpongefishOrdinarySession SpongefishPCSRoundFrames +open SpongefishCurrentPrimitiveEventCompiler +set_option autoImplicit false + +/-- The seed CV is the observed answer to the literal native initialization node. -/ +def initProgram (parameter session : Digest32) : Program State := + seq (primitive parameter (ByteCodec.pairBytes (session,zeroDigest)) + (UInt64.ofNat (2^56)) true) (fun cv => .done {cv := cv}) + +@[simp] theorem initProgram_real (C : PrimitiveOracle) (iv parameter session : Digest32) : + (runReal C iv (initProgram parameter session)).view.result = + init (compressionOf C) parameter session := by + simp [initProgram,seq,WHIRModeFinal.bind_real_result,runReal,init,seed] + +theorem initProgram_certified (parameter session : Digest32) : + Counts 1 (initProgram parameter session) ∧ OnlyPrimitive (initProgram parameter session) := + ⟨seq_done_counted _ _ (primitive_certified _ _ _ _).1, + onlyPrimitive_seq _ _ (primitive_certified _ _ _ _).2 (fun _ => trivial)⟩ + +/-- Public instance absorption is recorded separately from proof-transport reads. +The counters start at zero; neither narg nor hints are consumed at construction. -/ +def cursor (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) (s : State) : Cursor := + {state := s, pending := bind {domain := session} instanceBytes, + narg := narg, hints := hints, events := [.publicBytes instanceBytes]} + +/-- Continuation from an actually derived ID; no caller supplies the session seed. -/ +def sessionProgram (parameter session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : Program Cursor := + seq (initProgram parameter session) (fun s => + seq (absorbProgram s instanceBytes) (fun t => + .done (cursor session instanceBytes narg hints t))) + +@[simp] theorem sessionProgram_real (C : PrimitiveOracle) (iv parameter session : Digest32) + (instanceBytes narg : List Byte) (hints : List (List Byte)) : + (runReal C iv (sessionProgram parameter session instanceBytes narg hints)).view.result = + cursor session instanceBytes narg hints + (absorb (compressionOf C) (init (compressionOf C) parameter session) instanceBytes) := by + simp [sessionProgram,seq,WHIRModeFinal.bind_real_result,runReal] + +/-- Empty instance bytes are outside the source constructor's valid input domain. -/ +def setupProgram (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) : Program (Option Cursor) := + if instanceBytes = [] then .done none else + afterDerive parameter tag (fun session => + seq (sessionProgram parameter session instanceBytes narg hints) (fun cur => .done (some cur))) + +/-- Reference construction uses the existing derive/init/newSession adapters. -/ +def actualSetup (c : Compression) (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) : Option Cursor := + let session := derive c parameter tag + (newSession c parameter session instanceBytes).map (cursor session instanceBytes narg hints) + +@[simp] theorem setupProgram_real (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) : + (runReal C iv (setupProgram parameter tag instanceBytes narg hints)).view.result = + actualSetup (compressionOf C) parameter tag instanceBytes narg hints := by + by_cases empty : instanceBytes = [] + · simp [setupProgram,actualSetup,newSession,empty,runReal] + · simp [setupProgram,actualSetup,newSession,empty,afterDerive_real, + seq,WHIRModeFinal.bind_real_result,runReal] + +/-- Valid-input source correspondence; the session and every CV are computed. -/ +theorem setupProgram_nonempty (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (nonempty : instanceBytes ≠ []) : + (runReal C iv (setupProgram parameter tag instanceBytes narg hints)).view.result = + some (cursor (derive (compressionOf C) parameter tag) instanceBytes narg hints + (absorb (compressionOf C) + (init (compressionOf C) parameter (derive (compressionOf C) parameter tag)) instanceBytes)) := by + rw [setupProgram_real] + simp [actualSetup,newSession_nonempty _ _ _ _ nonempty] + +theorem setupProgram_empty (parameter : Digest32) (tag narg : List Byte) + (hints : List (List Byte)) : setupProgram parameter tag [] narg hints = .done none := by + simp [setupProgram] + +/-- The initialized current frame relation is derived internally, not assumed. -/ +theorem setupProgram_bridge (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (nonempty : instanceBytes ≠ []) : + ∃ cur, (runReal C iv (setupProgram parameter tag instanceBytes narg hints)).view.result = some cur ∧ + RepresentsCurrent (compressionOf C) parameter cur.pending cur.state := by + refine ⟨_,setupProgram_nonempty C iv parameter tag instanceBytes narg hints nonempty,?_⟩ + exact session_bridge (compressionOf C) parameter _ instanceBytes + +/-- Invalid construction and rejected replay are distinct result boundaries. +A replay error retains the entire actually reached cursor. -/ +def entryProgram (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : Program (Option ReplayResult) := + seq (setupProgram parameter tag instanceBytes narg hints) (fun result => match result with + | none => .done none + | some cur => seq (replayProgram cur calls) (fun result => .done (some result))) + +def actualEntry (c : Compression) (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : Option ReplayResult := + (actualSetup c parameter tag instanceBytes narg hints).map (fun cur => actualReplay c cur calls) + +@[simp] theorem entryProgram_real (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + (runReal C iv (entryProgram parameter tag instanceBytes narg hints calls)).view.result = + actualEntry (compressionOf C) parameter tag instanceBytes narg hints calls := by + simp only [entryProgram,seq,WHIRModeFinal.bind_real_result,setupProgram_real,actualEntry] + cases actualSetup (compressionOf C) parameter tag instanceBytes narg hints <;> + simp [WHIRModeFinal.bind_real_result,runReal] + +/-- Erasure agrees with the source adapter on both accepted and rejected replay. -/ +theorem entryProgram_source (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + ((runReal C iv (entryProgram parameter tag instanceBytes narg hints calls)).view.result.bind erase) = + (actualSetup (compressionOf C) parameter tag instanceBytes narg hints).bind + (fun cur => replayCalls (compressionOf C) cur calls) := by + rw [entryProgram_real] + unfold actualEntry + cases actualSetup (compressionOf C) parameter tag instanceBytes narg hints <;> + simp [actualReplay_erases] + +/-- Every reply-dependent continuation is charged, not just successful replay. -/ +def setupBudget (tag instanceBytes : List Byte) : Nat := + derivationPrimitiveCost tag + (1 + instanceBytes.length) + +def entryBudget (tag instanceBytes : List Byte) (calls : List Call) : Nat := + setupBudget tag instanceBytes + sourceBudget calls + +theorem instructions_onlyPrimitive (cv : Digest32) (xs : List DuplexEncoding.Instruction) : + OnlyPrimitive (instructions cv xs) := by + induction xs generalizing cv with + | nil => trivial + | cons i rest ih => exact ⟨⟨_,rfl⟩,fun answer => ih answer⟩ + +theorem sessionProgram_certified (parameter session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : + Counts (1+instanceBytes.length) (sessionProgram parameter session instanceBytes narg hints) ∧ + OnlyPrimitive (sessionProgram parameter session instanceBytes narg hints) := by + refine ⟨WHIRModeFinal.bind_counted _ _ 1 instanceBytes.length + (initProgram_certified parameter session).1 (fun s => + seq_done_counted _ _ (absorbProgram_certified s instanceBytes).1),?_⟩ + exact onlyPrimitive_seq _ _ (initProgram_certified parameter session).2 (fun s => + onlyPrimitive_seq _ _ (absorbProgram_certified s instanceBytes).2 (fun _ => trivial)) + +theorem setupProgram_certified (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) : + Counts (setupBudget tag instanceBytes) (setupProgram parameter tag instanceBytes narg hints) ∧ + OnlyPrimitive (setupProgram parameter tag instanceBytes narg hints) := by + unfold setupProgram + split + · exact ⟨trivial,trivial⟩ + · refine ⟨afterDerive_counted parameter tag _ (1+instanceBytes.length) (fun session => + seq_done_counted _ _ (sessionProgram_certified parameter session instanceBytes narg hints).1),?_⟩ + exact onlyPrimitive_seq _ _ (instructions_onlyPrimitive parameter (derivationPlan tag)) (fun session => + onlyPrimitive_seq _ _ (sessionProgram_certified parameter session instanceBytes narg hints).2 + (fun _ => trivial)) + +theorem entryProgram_certified (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : + Counts (entryBudget tag instanceBytes calls) (entryProgram parameter tag instanceBytes narg hints calls) ∧ + OnlyPrimitive (entryProgram parameter tag instanceBytes narg hints calls) := by + refine ⟨WHIRModeFinal.bind_counted _ _ (setupBudget tag instanceBytes) (sourceBudget calls) + (setupProgram_certified parameter tag instanceBytes narg hints).1 (fun result => ?_), + onlyPrimitive_seq _ _ (setupProgram_certified parameter tag instanceBytes narg hints).2 + (fun result => ?_)⟩ + · cases result with + | none => trivial + | some cur => exact seq_done_counted _ _ (replayProgram_certified cur calls).1 + · cases result with + | none => trivial + | some cur => exact onlyPrimitive_seq _ _ (replayProgram_certified cur calls).2 (fun _ => trivial) + +theorem entryBudget_closed (tag instanceBytes : List Byte) (calls : List Call) : + entryBudget tag instanceBytes calls = + 3 + (tag.length+63)/64 + instanceBytes.length + sourceBudget calls := by + unfold entryBudget setupBudget + rw [derivation_cost_closed] + omega + +/-- Repeated nodes remain repeated observations, even for a cached oracle answer. -/ +def instructionsTrace (C : PrimitiveOracle) : Digest32 → List DuplexEncoding.Instruction → List Observation + | _, [] => [] + | cv, i :: rest => record C ⟨cv,i.1,i.2,true⟩ ++ instructionsTrace C (C ⟨cv,i.1,i.2,true⟩) rest + +theorem instructions_trace (C : PrimitiveOracle) (iv cv : Digest32) + (xs : List DuplexEncoding.Instruction) : + (runReal C iv (instructions cv xs)).view.observations = instructionsTrace C cv xs := by + induction xs generalizing cv with + | nil => rfl + | cons i rest ih => + simpa only [instructions,runReal,realAnswer,prepend,instructionsTrace,record,List.singleton_append] + using congrArg (Observation.mk (.primitive .auxiliary ⟨cv,i.1,i.2,true⟩) + (C ⟨cv,i.1,i.2,true⟩) :: ·) (ih (C ⟨cv,i.1,i.2,true⟩)) + +def sessionTrace (C : PrimitiveOracle) (parameter session : Digest32) + (instanceBytes : List Byte) : List Observation := + record C ⟨parameter,ByteCodec.pairBytes (session,zeroDigest),UInt64.ofNat (2^56),true⟩ ++ + absorbTrace C (init (compressionOf C) parameter session) instanceBytes + +theorem initProgram_trace (C : PrimitiveOracle) (iv parameter session : Digest32) : + (runReal C iv (initProgram parameter session)).view.observations = + record C ⟨parameter,ByteCodec.pairBytes (session,zeroDigest),UInt64.ofNat (2^56),true⟩ := rfl + +theorem sessionProgram_trace (C : PrimitiveOracle) (iv parameter session : Digest32) + (instanceBytes narg : List Byte) (hints : List (List Byte)) : + (runReal C iv (sessionProgram parameter session instanceBytes narg hints)).view.observations = + sessionTrace C parameter session instanceBytes := by + simp only [sessionProgram,seq_observations,initProgram_trace,initProgram_real, + absorbProgram_trace,runReal,List.append_nil,sessionTrace] + +def setupTrace (C : PrimitiveOracle) (parameter : Digest32) (tag instanceBytes : List Byte) : + List Observation := + if instanceBytes = [] then [] else + instructionsTrace C parameter (derivationPlan tag) ++ + sessionTrace C parameter (derive (compressionOf C) parameter tag) instanceBytes + +theorem setupProgram_trace (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) : + (runReal C iv (setupProgram parameter tag instanceBytes narg hints)).view.observations = + setupTrace C parameter tag instanceBytes := by + unfold setupProgram setupTrace + split + · rfl + · simp only [afterDerive,seq_observations,deriveProgram_real, + sessionProgram_trace,runReal,List.append_nil] + rw [deriveProgram,instructions_trace] + +def entryTrace (C : PrimitiveOracle) (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : List Observation := + setupTrace C parameter tag instanceBytes ++ + match actualSetup (compressionOf C) parameter tag instanceBytes narg hints with + | none => [] | some cur => replayTrace C cur calls + +theorem entryProgram_trace (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + (runReal C iv (entryProgram parameter tag instanceBytes narg hints calls)).view.observations = + entryTrace C parameter tag instanceBytes narg hints calls := by + simp only [entryProgram,seq_observations,setupProgram_trace,setupProgram_real,entryTrace] + cases actualSetup (compressionOf C) parameter tag instanceBytes narg hints <;> + simp only [seq_observations,replayProgram_trace,runReal,List.append_nil] + +theorem setupProgram_observation_count (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (nonempty : instanceBytes ≠ []) : + (runReal C iv (setupProgram parameter tag instanceBytes narg hints)).view.observations.length = + 3 + (tag.length+63)/64 + + (absorbTrace C (init (compressionOf C) parameter (derive (compressionOf C) parameter tag)) + instanceBytes).length := by + rw [setupProgram_trace] + simp only [setupTrace,nonempty,↓reduceIte,sessionTrace,List.length_append,record, + List.length_cons,List.length_nil] + rw [← instructions_trace C iv,← deriveProgram,deriveProgram_observation_count] + omega + +/-- Exact reached trace/cost and a worst-case bound including all calls, with no +success or externally supplied counting premise. -/ +theorem entryProgram_observed_work (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + (∀ o ∈ (runReal C iv (entryProgram parameter tag instanceBytes narg hints calls)).view.observations, + ∃ n, o.query = .primitive .auxiliary n ∧ o.answer = C n) ∧ + (runReal C iv (entryProgram parameter tag instanceBytes narg hints calls)).primitiveCost = + (entryTrace C parameter tag instanceBytes narg hints calls).length ∧ + (runReal C iv (entryProgram parameter tag instanceBytes narg hints calls)).primitiveCost ≤ + entryBudget tag instanceBytes calls := by + have provenance := observed_provenance C iv _ + (entryProgram_certified parameter tag instanceBytes narg hints calls).2 + refine ⟨provenance.1,?_,runReal_counts C iv _ _ + (entryProgram_certified parameter tag instanceBytes narg hints calls).1⟩ + rw [← entryProgram_trace] + exact provenance.2.symm + +/-- Existing executable public-compression backend; its Counts proof is internal. -/ +def compiledEntry (iv parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : + PublicCompressionProgram.Computation (Execution (Option ReplayResult)) (entryBudget tag instanceBytes calls) := + PublicCompressionProgram.compile iv (entryProgram parameter tag instanceBytes narg hints calls) + (entryBudget tag instanceBytes calls) (entryProgram_certified parameter tag instanceBytes narg hints calls).1 + +theorem compiledEntry_real (C : PrimitiveOracle) (iv parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + TypedOracleCompiler.Sampling.eval C (compiledEntry iv parameter tag instanceBytes narg hints calls) = + runReal C iv (entryProgram parameter tag instanceBytes narg hints calls) := + PublicCompressionProgram.compile_eval C iv _ _ _ + +#print axioms initProgram_real +#print axioms setupProgram_nonempty +#print axioms setupProgram_bridge +#print axioms entryProgram_real +#print axioms entryProgram_source +#print axioms entryProgram_certified +#print axioms setupProgram_trace +#print axioms setupProgram_observation_count +#print axioms entryProgram_trace +#print axioms entryProgram_observed_work +#print axioms compiledEntry_real +end Whir.SpongefishCurrentObservedSessionEntry diff --git a/verification/whir/Whir/SpongefishCurrentRoundSeparation.lean b/verification/whir/Whir/SpongefishCurrentRoundSeparation.lean new file mode 100644 index 000000000..5b99907ae --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRoundSeparation.lean @@ -0,0 +1,230 @@ +import Whir.SpongefishCurrentRecordModeCapture + +/-! Current #607 round boundaries. Consecutive E values within one verifier +message may share a 32-byte output block. This module checks that distinct +scheduled verifier messages have a nonempty absorbed prover payload between +them, and proves that this creates a distinct construction history. These are +causal framing results, not a random-oracle or whole-system entropy theorem. -/ +namespace Whir.SpongefishCurrentRoundSeparation +open Concrete FiatShamirGame DuplexRefinement +open SpongefishPCSRoundFrames +set_option autoImplicit false + +/-- `waiting` means a verifier message has been emitted since the last +nonempty prover payload. No guard is added to the source verifier. -/ +def scan : Bool → List Call → Option Bool + | waiting, [] => some waiting + | waiting, .read kind :: rest => + scan (if kind.codec.size = 0 then waiting else false) rest + | waiting, .hint :: rest => scan waiting rest + | waiting, .draw _ :: rest => + if waiting then none else scan true rest + +theorem scan_append (waiting : Bool) (xs ys : List Call) : + scan waiting (xs ++ ys) = (scan waiting xs).bind (fun next => scan next ys) := by + induction xs generalizing waiting with + | nil => rfl + | cons call xs ih => + cases call with + | read kind => simpa only [List.cons_append,scan] using ih _ + | hint => simpa only [List.cons_append,scan] using ih waiting + | draw group => cases waiting <;> simp [scan,ih] + +private theorem scan_waiting_without_payload (middle suffix : List Call) (g : Group) + (empty : ∀ kind, Call.read kind ∈ middle → kind.codec.size = 0) : + scan true (middle ++ Call.draw g :: suffix) = none := by + induction middle with + | nil => rfl + | cons call middle ih => + cases call with + | draw first => rfl + | hint => + exact ih (fun kind member => empty kind (by simp [member])) + | read kind => + have zero := empty kind (by simp) + simpa only [List.cons_append,scan,zero,↓reduceIte] using + ih (fun next member => empty next (by simp [member])) + +/-- The source schedule check implies a real nonempty payload between any +two verifier messages, not just an unrelated absence of adjacent draws. -/ +theorem scan_between (waiting finished : Bool) (pre middle suffix : List Call) + (first second : Group) + (ok : scan waiting (pre ++ (Call.draw first :: (middle ++ Call.draw second :: suffix))) = + some finished) : + ∃ kind, Call.read kind ∈ middle ∧ kind.codec.size ≠ 0 := by + classical + rw [scan_append] at ok + obtain ⟨ready,_,tail⟩ := Option.bind_eq_some_iff.mp ok + cases ready + · simp only [scan,Bool.false_eq_true,↓reduceIte] at tail + by_contra absent + have empty : ∀ kind, Call.read kind ∈ middle → kind.codec.size = 0 := by + intro kind member + by_contra positive + exact absent ⟨kind,member,positive⟩ + rw [scan_waiting_without_payload middle suffix second empty] at tail + cases tail + · simp [scan] at tail + +theorem payload_nonempty (kind : WireKind) (positive : kind.codec.size ≠ 0) + (value : kind.Value) : kind.codec.bytes value ≠ [] := by + intro empty + have length := congrArg List.length empty + simp only [Codec.bytes,List.length_ofFn,List.length_nil] at length + exact positive length + +@[simp] theorem scan_fold : scan false foldSchedule = some false := by + simp [scan,foldSchedule,WireKind.codec,vectorCodec] + +@[simp] theorem scan_pow (waiting : Bool) (bits : Fin 64) : + scan waiting (powSchedule bits) = + if bits.val = 0 then some waiting else if waiting then none else some false := by + by_cases zero : bits.val = 0 + · simp [powSchedule,zero,scan] + · cases waiting <;> simp [powSchedule,zero,scan,WireKind.codec,nonceCodec] + +@[simp] theorem scan_query (depth count : Nat) (bits : Fin 64) : + scan false (querySchedule depth count bits) = some false := by + simp only [querySchedule,scan_append,scan_pow] + by_cases zero : bits.val = 0 <;> + simp [zero,scan,WireKind.codec,vectorCodec] + +@[simp] theorem scan_ood (dimension : Nat) : + scan false (oodSchedule dimension) = some false := by + by_cases zero : dimension = 0 <;> + simp [oodSchedule,zero,scan,WireKind.codec,vectorCodec] + +private theorem scan_flatMap_reset {A : Type} (xs : List A) (f : A → List Call) + (reset : ∀ x ∈ xs, scan false (f x) = some false) : + scan false (xs.flatMap f) = some false := by + induction xs with + | nil => rfl + | cons x xs ih => + simp only [List.flatMap_cons,scan_append] + rw [reset x (by simp)] + simp only [Option.bind_some] + exact ih (fun y hy => reset y (by simp [hy])) + +@[simp] theorem scan_folds (rounds : Nat) : + scan false ((List.replicate rounds foldSchedule).flatten) = some false := by + simpa only [List.flatMap_id] using + scan_flatMap_reset (List.replicate rounds foldSchedule) id + (fun x member => by simpa only [(List.mem_replicate.mp member).2,id_eq] using scan_fold) + +@[simp] theorem scan_root (waiting : Bool) (dimension oodCount depth count : Nat) + (bits : Fin 64) : + scan waiting (rootBoundarySchedule dimension oodCount depth count bits) = some false := by + have ood : scan false ((List.replicate oodCount (oodSchedule dimension)).flatten) = some false := by + simpa only [List.flatMap_id] using + scan_flatMap_reset (List.replicate oodCount (oodSchedule dimension)) id + (fun x member => by simpa only [(List.mem_replicate.mp member).2,id_eq] using scan_ood dimension) + simp only [rootBoundarySchedule,List.cons_append,List.nil_append,scan, + WireKind.codec,rootCodec,show ¬(32 : Nat) = 0 by decide,↓reduceIte, + scan_append,ood,Option.bind_some,scan_query] + +/-- Every repeated fold absorbs two real E values before another verifier +message; every root boundary also begins with a raw32 prover message. -/ +theorem scan_intermediate (stages : List (Nat × Boundary)) : + scan false (stages.flatMap (fun stage => + (List.replicate stage.1 foldSchedule).flatten ++ stage.2.schedule)) = some false := by + apply scan_flatMap_reset + intro stage _ + simp [scan_append,Boundary.schedule] + +private theorem scan_residual_from (start rounds : Nat) : + scan false ((List.range' start rounds).flatMap (fun j => + [.draw .residualFold] ++ + if j+1 < start+rounds then [.read (.vector 2)] else [])) = + some (decide (rounds ≠ 0)) := by + induction rounds generalizing start with + | zero => simp [scan] + | succ rounds ih => + cases rounds with + | zero => simp [List.range'_succ,scan] + | succ rounds => + have first : start+1 < start+(rounds+1+1) := by omega + simpa [List.range'_succ,List.flatMap_cons,first,scan,WireKind.codec,vectorCodec, + Nat.add_assoc,Nat.add_left_comm,Nat.add_comm] using ih (start+1) + +theorem scan_residual (rounds : Nat) : + scan false (residualSchedule rounds) = some (decide (rounds ≠ 0)) := by + simpa [residualSchedule,List.range_eq_range'] using scan_residual_from 0 rounds + +theorem scan_final (waiting : Bool) (dimension depth count : Nat) (bits : Fin 64) : + scan waiting (finalBoundarySchedule dimension depth count bits) = + some (decide (dimension ≠ 0)) := by + simp [finalBoundarySchedule,scan_append,scan,WireKind.codec,vectorCodec, + scan_query,scan_residual] + +/-- Every scheduled current PCS verifier message is separated from the next +by a nonempty actual prover payload. A final residual draw needs no following +payload, and absent PoW introduces no extra verifier round. -/ +theorem scan_opening (layout : OpeningLayout) : + scan false layout.schedule = some (decide (layout.residualDimension ≠ 0)) := by + have boundary : scan false layout.firstBoundary.schedule = some false := by + simp [Boundary.schedule] + simp [OpeningLayout.schedule,scan_append,scan,WireKind.codec,vectorCodec, + boundary,scan_intermediate,scan_final] + +theorem opening_between (layout : OpeningLayout) (pre middle suffix : List Call) + (first second : Group) + (scheduled : layout.schedule = + pre ++ (Call.draw first :: (middle ++ Call.draw second :: suffix))) : + ∃ kind, Call.read kind ∈ middle ∧ ∀ value : kind.Value, kind.codec.bytes value ≠ [] := by + have safe := scan_opening layout + rw [scheduled] at safe + obtain ⟨kind,member,positive⟩ := scan_between false _ pre middle suffix first second safe + exact ⟨kind,member,payload_nonempty kind positive⟩ + +/-- A nonempty prover message following a positive draw cannot reuse any +output coordinate from that draw's history, even when the prior draw stopped +partway through a 32-byte output block. -/ +theorem prover_message_adds_history (m : Pending) (n : Nat) (positive : n ≠ 0) + (bytes : List Byte) (nonempty : bytes ≠ []) : + ((close (SpongefishPCSRoundFrames.bind (draw m n) bytes)).core.history.frames).length = + ((close m).core.history.frames).length + 1 := by + simp only [draw,positive,↓reduceIte,SpongefishPCSRoundFrames.bind,nonempty, + close,Pending.core] + simp [nonempty,List.map_append] + +theorem distinct_history_after_prover (m : Pending) (n : Nat) (positive : n ≠ 0) + (bytes : List Byte) (nonempty : bytes ≠ []) (beforeBlock afterBlock : Nat) : + SpongefishCurrentModeQueries.coordinate m beforeBlock ≠ + SpongefishCurrentModeQueries.coordinate + (SpongefishPCSRoundFrames.bind (draw m n) bytes) afterBlock := by + intro equal + have len := congrArg (fun q : Coordinate => q.history.frames.length) equal + have grew := prover_message_adds_history m n positive bytes nonempty + simp only [SpongefishCurrentModeQueries.coordinate] at len + omega + +/-- Both raw keys are literal full-IV/template encodings of admissible source +coordinates. Their inequality is derived from the prover-message boundary, +not from a hash-collision assumption or a different output index. -/ +theorem distinct_raw_key_after_prover {Q : Nat} (parameter : Digest32) + (m : Pending) (n : Nat) (positive : n ≠ 0) (bytes : List Byte) (nonempty : bytes ≠ []) + (beforeBlock afterBlock : Nat) + (beforeValid : DuplexEncoding.Admissible (SpongefishCurrentModeQueries.coordinate m beforeBlock)) + (afterValid : DuplexEncoding.Admissible (SpongefishCurrentModeQueries.coordinate + (SpongefishPCSRoundFrames.bind (draw m n) bytes) afterBlock)) + (beforeBound : DuplexFraming.pathCost (SpongefishCurrentModeQueries.coordinate m beforeBlock) ≤ Q) + (afterBound : DuplexFraming.pathCost (SpongefishCurrentModeQueries.coordinate + (SpongefishPCSRoundFrames.bind (draw m n) bytes) afterBlock) ≤ Q) : + DuplexModeGame.constructionKey Q parameter (SpongefishCurrentModeQueries.coordinate m beforeBlock) beforeBound ≠ + DuplexModeGame.constructionKey Q parameter (SpongefishCurrentModeQueries.coordinate + (SpongefishPCSRoundFrames.bind (draw m n) bytes) afterBlock) afterBound := by + intro equal + have decoded := congrArg (WHIRHeaderRoots.decodeRaw parameter) equal + rw [WHIRHeaderRoots.decodeRaw_construction parameter _ beforeValid beforeBound, + WHIRHeaderRoots.decodeRaw_construction parameter _ afterValid afterBound] at decoded + exact distinct_history_after_prover m n positive bytes nonempty beforeBlock afterBlock + (Option.some.inj decoded) + +#print axioms scan_append +#print axioms scan_intermediate +#print axioms scan_opening +#print axioms opening_between +#print axioms prover_message_adds_history +#print axioms distinct_history_after_prover +#print axioms distinct_raw_key_after_prover +end Whir.SpongefishCurrentRoundSeparation From b5af065b17573634fd2f28c1fd9e4305ea13daa5 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 12:43:54 +0100 Subject: [PATCH 22/28] proof: join accepted current caller path to the public original list Store executable digests and squeeze outputs as data behind csimp equalities, add the observed physical record-capture compiler, literal byte transport and current caller parser coverage, and derive the parser's call order, domain, proof bytes and empty hints from an accepted setup, receive, payload and binding replay (SpongefishCurrentAcceptedJoin). --- verification/whir/README.md | 12 +- verification/whir/Whir.lean | 10 + .../Whir/AnchoredSourceFreshCallerSmoke.lean | 8 + verification/whir/Whir/DuplexCompression.lean | 65 +- verification/whir/Whir/DuplexFraming.lean | 65 +- verification/whir/Whir/DuplexModeGame.lean | 12 +- verification/whir/Whir/DuplexRefinement.lean | 83 ++ verification/whir/Whir/MerkleTransport.lean | 128 ++ .../Whir/PCSBCSSourceRootReferencesSmoke.lean | 22 +- .../whir/Whir/PrunedMerkleProgram.lean | 16 + .../whir/Whir/PublicCompressionProgram.lean | 54 +- verification/whir/Whir/PublicMerkleLog.lean | 57 + .../whir/Whir/PublicMerkleProgram.lean | 97 +- .../Whir/SpongefishCurrentAbsorbedPrefix.lean | 151 +++ .../Whir/SpongefishCurrentAcceptedJoin.lean | 877 +++++++++++++ .../Whir/SpongefishCurrentAdapterSmoke.lean | 41 +- ...SpongefishCurrentAnchorAttackerPrefix.lean | 507 ++++++++ .../Whir/SpongefishCurrentByteTransport.lean | 104 ++ .../Whir/SpongefishCurrentCallerGetter.lean | 157 +++ ...SpongefishCurrentCallerGetterCoverage.lean | 440 +++++++ .../Whir/SpongefishCurrentCallerSmoke.lean | 107 ++ ...pongefishCurrentObservedRecordBinding.lean | 1146 +++++++++++++++++ ...SpongefishCurrentObservedSessionEntry.lean | 54 + ...SpongefishCurrentPhysicalModeCompiler.lean | 337 +++++ ...ongefishCurrentPrimitiveEventCompiler.lean | 64 +- .../SpongefishCurrentReplayProvenance.lean | 178 +++ ...SpongefishCurrentSourceCallerOriginal.lean | 591 +++++++++ .../whir/Whir/SpongefishOrdinarySession.lean | 4 + .../whir/Whir/SpongefishPCSRoundFrames.lean | 19 + .../whir/Whir/SpongefishPowAdapter.lean | 20 +- .../whir/Whir/SpongefishSessionAdapter.lean | 21 +- verification/whir/Whir/WHIRCallerSource.lean | 16 + verification/whir/Whir/WHIRModeFinal.lean | 33 + verification/whir/Whir/WHIRPowProgram.lean | 20 +- verification/whir/Whir/WHIRROM.lean | 14 + verification/whir/lakefile.toml | 8 + 36 files changed, 5402 insertions(+), 136 deletions(-) create mode 100644 verification/whir/Whir/SpongefishCurrentAbsorbedPrefix.lean create mode 100644 verification/whir/Whir/SpongefishCurrentAcceptedJoin.lean create mode 100644 verification/whir/Whir/SpongefishCurrentAnchorAttackerPrefix.lean create mode 100644 verification/whir/Whir/SpongefishCurrentByteTransport.lean create mode 100644 verification/whir/Whir/SpongefishCurrentCallerGetter.lean create mode 100644 verification/whir/Whir/SpongefishCurrentCallerGetterCoverage.lean create mode 100644 verification/whir/Whir/SpongefishCurrentCallerSmoke.lean create mode 100644 verification/whir/Whir/SpongefishCurrentObservedRecordBinding.lean create mode 100644 verification/whir/Whir/SpongefishCurrentPhysicalModeCompiler.lean create mode 100644 verification/whir/Whir/SpongefishCurrentReplayProvenance.lean create mode 100644 verification/whir/Whir/SpongefishCurrentSourceCallerOriginal.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index 9620b0846..f4c3366d8 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -148,6 +148,14 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentRoundSeparation.opening_between` proves that any two verifier messages in the actual current PCS opening schedule have a nonempty canonical prover payload between them. A hint alone is not such a payload, and absent PoW introduces no verifier round. Closing a nonempty prover message after a positive draw strictly extends the full history, so the next literal raw construction key differs even if the previous draw stopped partway through a 32-byte output block. Consecutive E values within one verifier message may still share a block; they are not asserted to be independent rounds. Together with the current codec carrier cardinalities, these are PCS-only framing and entropy-carrier results, not yet the distributional native acceptance reduction. +`SpongefishCurrentAbsorbedPrefix` shows that a current construction key carries the session domain, the zero statement seed, every completed absorb body with its consumed-count tag and the output block, and no earlier verifier coin value: the ancestry shape of the book's basic full-prefix variant. `SpongefishCurrentByteTransport.replay_conserves` proves that every reached replay, accepted or rejected, retains exactly the proof bytes it consumed: retained history followed by the unread proof equals the instance followed by the proof. `SpongefishCurrentAnchorAttackerPrefix` re-establishes first-root anchoring for the raw32 grammar, reusing only the bounded-coordinate partition and finite-oracle mathematics of the historical modules: every output key with the current header suffix freezes the same physical root before its answer, including off-vector blocks and adversarial prequeries (`candidate_before_every_reply`). It is not a native original-claim knowledge theorem. + +`SpongefishCurrentPhysicalModeCompiler` runs the same byte source while retaining the actual seed, absorb and finalization chaining values as ordinary observed answers; output bytes remain the cached construction replies, and its state relation erases only the output cache. `SpongefishCurrentObservedRecordBinding.program_accepted` runs setup, prelude, commitment receive, payload and expected-record binding in that compiler and recovers, from an accepted run, the hand-port composition together with `record.context = capture pre.state`. The saved context is therefore the captured pre-receive state of the same execution, not a supplied record or context equality; field mismatches retain the cursor after the successful read. + +`SpongefishCurrentSourceCallerOriginal` is the deterministic current original-statement parser: for a raw construction key it enumerates at most four raw records, replays the caller tape `calls layout r` on the key's own history bytes using only public construction replies, and prepares the original claims. `SpongefishCurrentCallerGetterCoverage` proves that public replies cover the actual source replay, including rejected prefixes. `SpongefishCurrentAcceptedJoin.accepted_original` joins this parser to an accepted native caller path. Given accepted setup, prelude, receive, payload and binding, followed by any verifier suffix that queries the post-binding coordinate, the received record is among that key's raw-decoded candidates, the parser's public result equals the physical replay, and every prepared original is in the public original list. `accepted_original_next` derives that query when the suffix begins with a positive challenge draw, as the PCS opening does after binding: the draw either requests the first output block of the post-binding coordinate or finds it already recorded. The parser's call order, derived domain, reconstructed proof bytes and empty hints are consequences of the accepted replay rather than hypotheses: `composition_replay` shows that receive and binding are one accepted replay of the caller tape, and `shift_replay` shows that a hint-free replay accepted with unread proof bytes makes the same queries on its consumed prefix. Header validity follows from the accepted receive, and `actualReplay_bounded` derives the received context's one-block pending-buffer bound. `observed_original` states the same result for the observed physical compiler. Native PCS equation, proof-of-work and original-claim acceptance remain explicit; this is not a deployed Fiat-Shamir knowledge endpoint. + +Executable paths that previously returned or retained a digest or squeeze output as a closure, and so recomputed earlier compressions at each use, now store the computed values as data. Each stored form is selected for compiled code by `@[csimp]` with a kernel-checked equality to the unchanged semantic definition (for example `DuplexRefinement.materialize_memo`, `stream_memo`, `DuplexFraming.evalPlan_stored`, `PublicMerkleLog.ordinaryPlan_stored` and the observed session traces), so every theorem about the semantic definitions applies to the executed code unchanged. + `AnchoredMixedAttackerPrefix` preserves the unchanged mixed source lowering and its entire public view while freezing the literal strict-prefix Merkle table before the first anchor reply. Repeated grouped queries reuse the first prepared root and point. The exact ambiguity bound is `n/2^124` for the aggregate mixed draw cap, or `remaining/2^124` under the source `Counts` work bound; allocations, lookup requests and full construction-path work are not equated. The wrapper uses the historical pre-#607 header grammar. `AnchoredMixedAttackerPrefixSource.initial_source_prefixes` derives the cache and first-root invariants at every actual source prefix. Cache-hit observations can be omitted from the draw log without preserving its literal order; outside ordinary output collisions, their membership set suffices to preserve digest-selected preimages. `AnchoredMixedAttackerPrefixObserver.source_prefixes_of_alarm` derives precisely that guard from the SAME complete physical Merkle alarm already paid by the source observer. No second collision loss, clean-cache assumption, externally supplied frozen-root equality or extra lowering is introduced. @@ -200,7 +208,7 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: -- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. +- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native PCS equation and accepted-opening adapter, its distributional source join and the basic full-prefix BCS knowledge endpoint for the deployed transcript remain open. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. @@ -248,7 +256,7 @@ Its checked `random_compression_failure_probability` bounds acceptance with no o `PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. -The final warning-denied library and compiled-model closure passed, and `Audit.lean` checked **14789 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. The compiled current real-BLAKE2s adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The current record codec exercised all 65 pending-buffer lengths with both first flags. Eight maintained model, reset/counting, source-stream, PCS grouping and real-BLAKE2s Merkle/public-log scenarios passed in the preceding closure. +The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15221 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index d44ee969e..7d6e72634 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -247,3 +247,13 @@ import Whir.SpongefishCurrentObservedSessionEntry import Whir.SpongefishCurrentMixedModeCompiler import Whir.SpongefishCurrentInitializedMode import Whir.SpongefishCurrentRoundSeparation +import Whir.SpongefishCurrentAbsorbedPrefix +import Whir.SpongefishCurrentAnchorAttackerPrefix +import Whir.SpongefishCurrentCallerGetter +import Whir.SpongefishCurrentSourceCallerOriginal +import Whir.SpongefishCurrentPhysicalModeCompiler +import Whir.SpongefishCurrentCallerGetterCoverage +import Whir.SpongefishCurrentReplayProvenance +import Whir.SpongefishCurrentObservedRecordBinding +import Whir.SpongefishCurrentByteTransport +import Whir.SpongefishCurrentAcceptedJoin diff --git a/verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean b/verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean index 54c38d403..59e3d81df 100644 --- a/verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean +++ b/verification/whir/Whir/AnchoredSourceFreshCallerSmoke.lean @@ -54,6 +54,14 @@ private def actualBlocks (entry : FramedHistory) : List (Coordinate × Array Byt (WHIRCallerOutputs.callerOutputs entry).map (fun q => (q,Array.ofFn (DuplexRefinement.evalCoordinate compression iv q))) +private def actualBlocksStored (entry : FramedHistory) : List (Coordinate × Array Byte) := + (WHIRCallerOutputs.callerOutputs entry).map fun q => + DuplexFraming.withCoordinate compression iv q (fun d => (q,Array.ofFn d)) + +@[csimp] private theorem actualBlocks_stored : actualBlocks = actualBlocksStored := by + funext entry + simp only [actualBlocks,actualBlocksStored,DuplexFraming.withCoordinate_eq] + private def answersFromBlocks (blocks : List (Coordinate × Array Byte)) (q : Coordinate) : Digest32 := match blocks.find? (fun row => decide (row.1 = q)) with | some (_,bytes) => fun i => bytes[i.val]! diff --git a/verification/whir/Whir/DuplexCompression.lean b/verification/whir/Whir/DuplexCompression.lean index ae5c63b7a..0ca353843 100644 --- a/verification/whir/Whir/DuplexCompression.lean +++ b/verification/whir/Whir/DuplexCompression.lean @@ -53,7 +53,9 @@ def digest (ws : Array UInt32) : Digest32 := fun i => def parameterIV : Digest32 := digest (ivWords.set! 0 (ivWords[0]! ^^^ 0x01010020)) -def compress : Compression := fun h block counter last => Id.run do +/-- Data-valued compression result; byte-function consumers enter through CPS. -/ +def compressionWords (h : Digest32) (block : Block64) (counter : UInt64) (last : Bool) : + Array UInt32 := Id.run do let hw := (Array.range 8).map (word h) let m := (Array.range 16).map (word block) let mut v := hw ++ ivWords @@ -64,12 +66,30 @@ def compress : Compression := fun h block counter last => Id.run do for g in [0:8] do let (a,b,c,d) := lanes[g]! v := mix v a b c d m[schedule[2*g]!]! m[schedule[2*g+1]!]! - return digest ((Array.range 8).map fun i => hw[i]! ^^^ v[i]! ^^^ v[i+8]!) + return (Array.range 8).map fun i => hw[i]! ^^^ v[i]! ^^^ v[i+8]! + +def compress : Compression := fun h block counter last => + digest (compressionWords h block counter last) + +def withCompression {Result : Type} (h : Digest32) (block : Block64) (counter : UInt64) + (last : Bool) (next : Digest32 → Result) : Result := + let words := compressionWords h block counter last + next (digest words) + +theorem withCompression_eq {Result : Type} (h : Digest32) (block : Block64) (counter : UInt64) + (last : Bool) (next : Digest32 → Result) : + withCompression h block counter last next = next (compress h block counter last) := rfl /-- Ordinary one-block BLAKE2s-256 (inputs of length at most 64). -/ def hashBlock (bytes : Array Byte) : Digest32 := compress parameterIV (padded bytes) (UInt64.ofNat bytes.size) true +def withHashBlock {Result : Type} (bytes : Array Byte) (next : Digest32 → Result) : Result := + withCompression parameterIV (padded bytes) (UInt64.ofNat bytes.size) true next + +theorem withHashBlock_eq {Result : Type} (bytes : Array Byte) (next : Digest32 → Result) : + withHashBlock bytes next = next (hashBlock bytes) := rfl + /-- Ordinary BLAKE2s PoW test; not a claimed soundness amplification. -/ def powOK (base : Digest32) (nonce : Scalar24) (bits : Nat) : Bool := let bs := List.ofFn base ++ List.ofFn nonce ++ littleWord 0x31574f502d534646 @@ -77,6 +97,16 @@ def powOK (base : Digest32) (nonce : Scalar24) (bits : Nat) : Bool := let low := ByteCodec.decodeNat 8 (fun i => d ⟨i.val, by omega⟩) low % 2^bits == 0 +def powOKStored (base : Digest32) (nonce : Scalar24) (bits : Nat) : Bool := + let bs := List.ofFn base ++ List.ofFn nonce ++ littleWord 0x31574f502d534646 + withHashBlock bs.toArray fun d => + let low := ByteCodec.decodeNat 8 (fun i => d ⟨i.val,by omega⟩) + low % 2^bits == 0 + +@[csimp] theorem powOK_stored : powOK = powOKStored := by + funext base nonce bits + simp only [powOK,powOKStored,withHashBlock_eq] + def hex (bs : List Byte) : String := String.ofList (bs.flatMap fun b => let digits := "0123456789abcdef".toList.toArray @@ -88,6 +118,15 @@ def knownAnswers : Bool := hex (List.ofFn (hashBlock #[])) == "69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9" && hex (List.ofFn (hashBlock #[97,98,99])) == "508c5e8c327c14e2e1a72ba34eeb452f37458b209ed63a294d999b4c86675982" +def knownAnswersStored : Bool := + withHashBlock #[] (fun d => + hex (List.ofFn d) == "69217a3079908094e11121d042354a7c1f55b6482ca1a51e1b250dfd1ed0eef9") && + withHashBlock #[97,98,99] (fun d => + hex (List.ofFn d) == "508c5e8c327c14e2e1a72ba34eeb452f37458b209ed63a294d999b4c86675982") + +@[csimp] theorem knownAnswers_stored : knownAnswers = knownAnswersStored := by + simp only [knownAnswers,knownAnswersStored,withHashBlock_eq] + /-- Observable snapshot used by the source-pinned external Rust differential probe: CV, active pending bytes, first flag, prior cursor, consumed cursor, cached output block, nonmutating commitment. -/ @@ -96,6 +135,26 @@ def snapshot (label : String) (s : State) : String := toString s.first ++ "|" ++ toString s.previous ++ "|" ++ toString s.consumed ++ "|" ++ hex (List.ofFn s.output) ++ "|" ++ hex (List.ofFn (commitment compress s)) +def snapshotStored (label : String) (s : State) : String := + let t := finish compress s + withCompression t.cv (wordsBlock [s.consumed]) (UInt64.ofNat (7*2^56)) true fun d => + label ++ "|" ++ hex (List.ofFn s.cv) ++ "|" ++ hex s.pending.toList ++ "|" ++ + toString s.first ++ "|" ++ toString s.previous ++ "|" ++ toString s.consumed ++ "|" ++ + hex (List.ofFn s.output) ++ "|" ++ hex (List.ofFn d) + +@[csimp] theorem snapshot_stored : snapshot = snapshotStored := by + funext label s + simp only [snapshot,snapshotStored,withCompression_eq,finish_cv,commitment] + +def powBaseHex (s : State) (bits : Nat) : String := + let t := finish compress s + withCompression t.cv (wordsBlock [s.consumed,bits]) (UInt64.ofNat (8*2^56)) true + (fun d => hex (List.ofFn d)) + +theorem powBaseHex_eq (s : State) (bits : Nat) : + powBaseHex s bits = hex (List.ofFn (powBase compress s bits)) := by + simp only [powBaseHex,withCompression_eq,finish_cv,powBase] + def traceDraw (label : String) (s : State) (n : Nat) : State × List String := match squeeze compress s n with | .error e => (s, [label ++ ":error:" ++ reprStr e]) @@ -146,7 +205,7 @@ def differentialTrace : List String := Id.run do let vectorBad := match squeeze compress s 24 with | .error .cursorExhausted => true | _ => false return out ++ ["bits-limit:" ++ toString bitsBad, "cursor-limit:" ++ toString cursorBad, - "vector-limit:" ++ toString vectorBad, "pow-base:" ++ hex (List.ofFn (powBase compress s 63))] + "vector-limit:" ++ toString vectorBad, "pow-base:" ++ powBaseHex s 63] /-- Observed verbatim from the pinned Rust source in an external Rust 1.97 harness. Fixtures retain state as well as challenges and all export families. diff --git a/verification/whir/Whir/DuplexFraming.lean b/verification/whir/Whir/DuplexFraming.lean index 10cf0aca7..844d95d09 100644 --- a/verification/whir/Whir/DuplexFraming.lean +++ b/verification/whir/Whir/DuplexFraming.lean @@ -438,6 +438,19 @@ def traceFrame (c : Compression) (t : Traced) : Frame → Traced let n : Node := ⟨t.state.cv,nonceBlock nonce previous bits,UInt64.ofNat (9*2^56),true⟩ ⟨{cv := nodeValue c n},n :: t.nodes⟩ +/-- Captured nonce trees store their computed CV at a data-valued boundary, +just as absorb and finish already do through the executable state machine. -/ +def traceFrameMemo (c : Compression) (t : Traced) : Frame → Traced + | .absorb previous bs => + traceFinish c (traceAbsorb c ⟨{cv := t.state.cv, previous := previous},t.nodes⟩ bs) + | .nonce previous bits nonce => + let n : Node := ⟨t.state.cv,nonceBlock nonce previous bits,UInt64.ofNat (9*2^56),true⟩ + ⟨memoCV {cv := zeroDigest} (nodeValue c n),n :: t.nodes⟩ + +@[csimp] theorem traceFrame_memo : traceFrame = traceFrameMemo := by + funext c t f + cases f <;> simp only [traceFrame,traceFrameMemo,memoCV_eq] + theorem traceFrame_cv (c : Compression) (t : Traced) (f : Frame) : (traceFrame c t f).state.cv = evalFrame c t.state.cv f := by cases f with @@ -873,42 +886,66 @@ theorem modeKey_injective (iv : Digest32) {a b : Coordinate} CV. The data-valued fold is essential: a Digest32-valued helper can be eta expanded into a byte function that recomputes the whole predecessor chain. This evaluator allocates neither mode Programs nor public execution traces. -/ -private def evalPlanStoredResult (c : Compression) (cv : Digest32) : +def evalPlanResult (c : Compression) (cv : Digest32) : List DuplexEncoding.Instruction → Option Digest32 | [] => some cv | i :: rest => - let bytes := Array.ofFn (c cv i.1 i.2 true) - evalPlanStoredResult c (fun j => bytes[j.val]'(by - simp only [bytes,Array.size_ofFn] - exact j.isLt)) rest + withDigest (c cv i.1 i.2 true) fun answer => + evalPlanResult c answer rest -private theorem evalPlanStoredResult_eq (c : Compression) (cv : Digest32) +theorem evalPlanResult_eq (c : Compression) (cv : Digest32) (xs : List DuplexEncoding.Instruction) : - evalPlanStoredResult c cv xs = some (evalPlan c cv xs) := by + evalPlanResult c cv xs = some (evalPlan c cv xs) := by induction xs generalizing cv with | nil => rfl - | cons i rest ih => simp [evalPlanStoredResult,ih,evalPlan] + | cons i rest ih => simp only [evalPlanResult,withDigest_eq,ih,evalPlan,List.foldl_cons] + +/-- The public digest evaluator uses the same boxed fold; callers retaining +its result should use `withPlan` to avoid eta-expanding the entire traversal. -/ +def evalPlanStored (c : Compression) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) : Digest32 := + let result := evalPlanResult c cv xs + result.get (by simp only [result,evalPlanResult_eq,Option.isSome_some]) + +@[csimp] theorem evalPlan_stored : evalPlan = evalPlanStored := by + funext c cv xs + simp only [evalPlanStored,evalPlanResult_eq,Option.get_some] + +def withPlan {Result : Type} (c : Compression) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) (next : Digest32 → Result) : Result := + let result := evalPlanResult c cv xs + next (result.get (by simp only [result,evalPlanResult_eq,Option.isSome_some])) + +theorem withPlan_eq {Result : Type} (c : Compression) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) (next : Digest32 → Result) : + withPlan c cv xs next = next (evalPlan c cv xs) := by + simp only [withPlan,evalPlanResult_eq,Option.get_some] def evalCoordinateStored (c : Compression) (iv : Digest32) (q : Coordinate) : Digest32 := - let result := evalPlanStoredResult c iv (DuplexEncoding.plan q) - result.get (by simp only [result,evalPlanStoredResult_eq,Option.isSome_some]) + let result := evalPlanResult c iv (DuplexEncoding.plan q) + result.get (by simp only [result,evalPlanResult_eq,Option.isSome_some]) /-- Checked runtime refinement for the actual construction evaluator; the logical semantics, all compression inputs, and all resource bounds are unchanged. -/ @[csimp] theorem evalCoordinate_stored : evalCoordinate = evalCoordinateStored := by funext c iv q - simp only [evalCoordinateStored,evalPlanStoredResult_eq,Option.get_some,plan_evaluate] + simp only [evalCoordinateStored,evalPlanResult_eq,Option.get_some,plan_evaluate] /-- A data-valued consumer can force the complete construction once, rather than invoking the Digest32-valued wrapper separately for each requested byte. -/ def withCoordinate {Result : Type} (c : Compression) (iv : Digest32) (q : Coordinate) (next : Digest32 → Result) : Result := - let result := evalPlanStoredResult c iv (DuplexEncoding.plan q) - next (result.get (by simp only [result,evalPlanStoredResult_eq,Option.isSome_some])) + withPlan c iv (DuplexEncoding.plan q) next theorem withCoordinate_eq {Result : Type} (c : Compression) (iv : Digest32) (q : Coordinate) (next : Digest32 → Result) : withCoordinate c iv q next = next (evalCoordinate c iv q) := by - simp only [withCoordinate,evalPlanStoredResult_eq,Option.get_some,plan_evaluate] + simp only [withCoordinate,withPlan_eq,plan_evaluate] + +#print axioms traceFrame_memo +#print axioms evalPlanResult_eq +#print axioms evalPlan_stored +#print axioms withPlan_eq +#print axioms withCoordinate_eq end Whir.DuplexFraming diff --git a/verification/whir/Whir/DuplexModeGame.lean b/verification/whir/Whir/DuplexModeGame.lean index 3dd6d50eb..84e91be9a 100644 --- a/verification/whir/Whir/DuplexModeGame.lean +++ b/verification/whir/Whir/DuplexModeGame.lean @@ -362,15 +362,15 @@ theorem concrete_transfer {Q : Nat} {Seed State AdvCoins Result : Type} have hm := randomCompression_transfer sim iv security adversary counted D ideal linarith -/-- Force a construction's boxed instruction fold once at the data-valued -execution boundary. Merely returning a Digest32 from realAnswer permits the -compiler to defer the entire construction until each individual byte lookup. -/ +/-- Materialize ordinary replies and force each construction's boxed fold at +the data-valued execution boundary. Function-valued wrappers alone permit eta +expansion to recompute earlier compression histories at each byte lookup. -/ def runRealStored {Result : Type} (oracle : PrimitiveOracle) (iv : Digest32) : Program Result → Execution Result | .done r => ⟨⟨[],r⟩,0,0,0⟩ | .ask (.primitive purpose input) next => - let answer := oracle input - prepend (.primitive purpose input) answer 0 (runRealStored oracle iv (next answer)) + DuplexRefinement.withDigest (oracle input) fun answer => + prepend (.primitive purpose input) answer 0 (runRealStored oracle iv (next answer)) | .ask (.construction q valid) next => DuplexFraming.withCoordinate (compressionOf oracle) iv q fun answer => prepend (.construction q valid) answer 0 (runRealStored oracle iv (next answer)) @@ -381,6 +381,6 @@ def runRealStored {Result : Type} (oracle : PrimitiveOracle) (iv : Digest32) : | done r => rfl | ask q next ih => cases q <;> simp only [runReal,runRealStored,realAnswer, - DuplexFraming.withCoordinate_eq,ih] + DuplexRefinement.withDigest_eq,DuplexFraming.withCoordinate_eq,ih] end Whir.DuplexModeGame diff --git a/verification/whir/Whir/DuplexRefinement.lean b/verification/whir/Whir/DuplexRefinement.lean index 2b05a5afa..df0dbd4a5 100644 --- a/verification/whir/Whir/DuplexRefinement.lean +++ b/verification/whir/Whir/DuplexRefinement.lean @@ -43,6 +43,17 @@ structure State where consumed : Nat := 0 output : Digest32 := zeroDigest +/-- Materialize a digest before entering a data-valued continuation. Returning +a function-valued digest alone permits eta expansion to defer the entire +computation until each byte lookup, including earlier compression histories. -/ +def withDigest {Result : Type} (d : Digest32) (next : Digest32 → Result) : Result := + let bytes := Array.ofFn d + next (fun i => bytes[i.val]'(by simp only [bytes,Array.size_ofFn]; exact i.isLt)) + +theorem withDigest_eq {Result : Type} (d : Digest32) (next : Digest32 → Result) : + withDigest d next = next d := by + simp [withDigest] + /-- Eagerly close a finite digest over 32 stored bytes, rather than retaining a closure that recursively recomputes the previous compression history. -/ def memoCV (s : State) (d : Digest32) : State := @@ -192,6 +203,19 @@ def verifyNonce (compress : Compression) (powOK : Digest32 → Scalar24 → Nat .ok (bindNonce compress s nonce bits, ok) else .error .grindingBits +def verifyNonceMemo (c : Compression) (powOK : Digest32 → Scalar24 → Nat → Bool) + (s : State) (nonce : Scalar24) (bits : Nat) : Except Error (State × Bool) := + if bits ≤ 63 then + let s := finish c s + let ok := if bits = 0 then decide (nonce = fun _ => 0) else + withDigest (powBase c s bits) fun base => powOK base nonce bits + .ok (bindNonce c s nonce bits,ok) + else .error .grindingBits + +@[csimp] theorem verifyNonce_memo : verifyNonce = verifyNonceMemo := by + funext c powOK s nonce bits + simp only [verifyNonce,verifyNonceMemo,withDigest_eq] + @[simp] theorem absorb_empty (c : Compression) (s : State) : absorb c s [] = s := rfl /-- All positive/empty call chunkings denote the same absorb run. -/ @@ -407,6 +431,35 @@ theorem squeezeLoop_stream (c : Compression) (s : State) (n : Nat) (h : CacheVal rw [squeezeByte_value c s h, ih _ (squeezeByte_cache c s h)] rfl +/-- Direct reference streams use the same stored output cache as ordinary +draws, including a partially consumed initial block. Empty streams do no work. -/ +def streamMemo (c : Compression) (cv : Digest32) (offset n : Nat) : List Byte := + if n = 0 then [] else + let s : State := {cv := cv,consumed := offset} + let s := if offset % 32 = 0 then s else + memoOutput s (outputBlock c cv (offset / 32)) + (squeezeLoop c n s).2 + +@[csimp] theorem stream_memo : stream = streamMemo := by + funext c cv offset n + by_cases empty : n = 0 + · subst n; simp only [stream,streamMemo,↓reduceIte] + · by_cases aligned : offset % 32 = 0 + · have cache : CacheValid c ({cv := cv,consumed := offset} : State) := by + intro hn + exact (hn aligned).elim + simpa only [streamMemo,empty,aligned,↓reduceIte] using + (squeezeLoop_stream c {cv := cv,consumed := offset} n cache).symm + · have cache : CacheValid c + (memoOutput {cv := cv,consumed := offset} (outputBlock c cv (offset / 32))) := by + simp only [memoOutput_eq,CacheValid] + intro _ + trivial + simpa only [streamMemo,empty,aligned,↓reduceIte,memoOutput_eq] using + (squeezeLoop_stream c + (memoOutput {cv := cv,consumed := offset} (outputBlock c cv (offset / 32))) + n cache).symm + theorem squeezeLoop_cache (c : Compression) (s : State) (n : Nat) (h : CacheValid c s) : CacheValid c (squeezeLoop c n s).1 := by induction n generalizing s with @@ -494,6 +547,22 @@ def evalHistoryMemo (c : Compression) (iv : Digest32) (h : FramedHistory) : Dige simp only [memoCV_eq] exact (fold h.frames (seed c iv h.domain h.statement)).symm +theorem evalHistoryState_cv (c : Compression) (iv : Digest32) (h : FramedHistory) : + (evalHistoryState c iv h).cv = evalHistory c iv h := + (congrFun (congrFun (congrFun evalHistory_memo c) iv) h).symm + +/-- History consumers keep the already snapshotted state, rather than closing +over a digest-valued replay wrapper that may be eta-expanded. -/ +def withHistory {Result : Type} (c : Compression) (iv : Digest32) (h : FramedHistory) + (next : Digest32 → Result) : Result := + let state := evalHistoryState c iv h + next state.cv + +theorem withHistory_eq {Result : Type} (c : Compression) (iv : Digest32) + (h : FramedHistory) (next : Digest32 → Result) : + withHistory c iv h next = next (evalHistory c iv h) := by + simp only [withHistory,evalHistoryState_cv] + def evalTerminal (c : Compression) (cv : Digest32) : Terminal → Digest32 | .output block => outputBlock c cv block | .commitment consumed => c cv (wordsBlock [consumed]) (UInt64.ofNat (7 * 2^56)) true @@ -517,6 +586,14 @@ structure Model where def materialize (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) : State := absorb c {cv := evalHistory c iv m.history, previous := m.previous, consumed := m.consumed, output := out} m.run +def materializeMemo (c : Compression) (iv : Digest32) (m : Model) (out : Digest32) : State := + withHistory c iv m.history fun cv => + absorb c {cv := cv, previous := m.previous, consumed := m.consumed, output := out} m.run + +@[csimp] theorem materialize_memo : materialize = materializeMemo := by + funext c iv m out + simp only [materialize,materializeMemo,withHistory_eq] + def Model.Valid (m : Model) : Prop := (m.run ≠ [] → m.consumed = 0) ∧ (m.run = [] → m.previous = 0) ∧ m.consumed ≤ maxCursor ∧ m.previous ≤ maxCursor @@ -1042,4 +1119,10 @@ theorem absorbTweak_source_bits (first last : Bool) (len previous : Nat) simp only [UInt64.ofNat_or, UInt64.ofNat_shiftLeft _ 56 (by decide), UInt64.ofNat_shiftLeft _ 49 (by decide)] rfl +#print axioms verifyNonce_memo +#print axioms evalHistoryState_cv +#print axioms withHistory_eq +#print axioms materialize_memo +#print axioms stream_memo + end Whir.DuplexRefinement diff --git a/verification/whir/Whir/MerkleTransport.lean b/verification/whir/Whir/MerkleTransport.lean index 1555d4935..17ae6adbd 100644 --- a/verification/whir/Whir/MerkleTransport.lean +++ b/verification/whir/Whir/MerkleTransport.lean @@ -2,6 +2,7 @@ import Whir.ByteCodec import Whir.MerkleBinding import Whir.MerkleLevels import Mathlib.Data.Nat.Bitwise +import Whir.DuplexRefinement /-! Baseline `fiat_shamir/src/merkle.rs:164-236` transport at `69f5499304a6957f6780c8998999d783bae13302`. The Merkle file is byte-identical @@ -168,6 +169,100 @@ def leafNodes (hash : Primitive) (leafWords : Nat) (table : Level (List K)) : Level Digest32 := table.map fun (i, row) => (i, hash (ByteCodec.wordsBytes (leafImage 0 leafWords row))) +/-- Leaf replies enter a data-valued table; no closure over a prior hash chain +is retained in the level walk. -/ +private def leafNodesStored (hash : Primitive) (leafWords : Nat) + (table : Level (List K)) : Level Digest32 := + table.map fun (i,row) => + DuplexRefinement.withDigest (hash (ByteCodec.wordsBytes (leafImage 0 leafWords row))) + (fun d => (i,d)) + +@[csimp] private theorem leafNodes_stored : leafNodes = leafNodesStored := by + funext hash leafWords table + simp only [leafNodes,leafNodesStored,DuplexRefinement.withDigest_eq] + +/-- Only a successful parent emission computes a hash, matching emit's original +Option guard and preserving every missing-sibling rejection. -/ +private def emitDigest (pair : Digest32 × Digest32 → Digest32) + (index : Nat) (left right : Digest32) + (result : Option (Level Digest32 × Level Digest32 × List Digest32)) : + Option (Level Digest32 × Level Digest32 × List Digest32) := + result.bind fun (parents,known,rest) => + DuplexRefinement.withDigest (pair (left,right)) (fun d => + some ((index/2,d)::parents, + (2*(index/2),left)::(2*(index/2)+1,right)::known,rest)) + +private theorem emitDigest_eq (pair : Digest32 × Digest32 → Digest32) + (index : Nat) (left right : Digest32) + (result : Option (Level Digest32 × Level Digest32 × List Digest32)) : + emitDigest pair index left right result = emit pair index left right result := by + cases result <;> simp [emitDigest,emit,DuplexRefinement.withDigest_eq] + +private def foldLevelDigest (pair : Digest32 × Digest32 → Digest32) : + Level Digest32 → List Digest32 → Option (Level Digest32 × Level Digest32 × List Digest32) + | [], supplied => some ([],[],supplied) + | (i,d)::nodes, supplied => + if i % 2 = 0 then + match nodes with + | (j,e)::tail => + if j = i+1 then emitDigest pair i d e (foldLevelDigest pair tail supplied) + else match supplied with + | [] => none + | s::ss => emitDigest pair i d s (foldLevelDigest pair ((j,e)::tail) ss) + | [] => match supplied with + | [] => none + | s::ss => emitDigest pair i d s (foldLevelDigest pair [] ss) + else match supplied with + | [] => none + | s::ss => emitDigest pair i s d (foldLevelDigest pair nodes ss) +termination_by nodes => nodes.length + +private theorem foldLevelDigest_eq (pair : Digest32 × Digest32 → Digest32) + (nodes : Level Digest32) (supplied : List Digest32) : + foldLevelDigest pair nodes supplied = foldLevel pair nodes supplied := by + induction nodes using (measure List.length).wf.induction generalizing supplied with + | _ nodes ih => + cases nodes with + | nil => rw [foldLevelDigest.eq_def,foldLevel.eq_def] + | cons x nodes => + rcases x with ⟨i,d⟩ + rw [foldLevelDigest.eq_def,foldLevel.eq_def] + by_cases hi : i % 2 = 0 + · simp only [hi,↓reduceIte] + cases nodes with + | nil => + have tailEq := ih [] (by change 0 < 1; decide) + cases supplied <;> simp [emitDigest_eq,tailEq] + | cons x tail => + rcases x with ⟨j,e⟩ + have tailEq := ih tail (by change tail.length < tail.length+2; omega) + have nodesEq := ih ((j,e)::tail) (by + change ((j,e)::tail).length < ((i,d)::(j,e)::tail).length + simp) + by_cases hj : j = i+1 + · simp [hj,emitDigest_eq,tailEq] + · cases supplied <;> simp [hj,emitDigest_eq,nodesEq] + · have nodesEq := ih nodes (by + change nodes.length < ((i,d)::nodes).length + simp) + cases supplied <;> simp [hi,emitDigest_eq,nodesEq] + +private def runLevelsDigest (pair : Digest32 × Digest32 → Digest32) : + Nat → Level Digest32 → List Digest32 → + Option (Level Digest32 × List (Level Digest32) × List Digest32) + | 0,nodes,supplied => some (nodes,[],supplied) + | n+1,nodes,supplied => do + let (parents,known,rest) ← foldLevelDigest pair nodes supplied + let (final,levels,remainder) ← runLevelsDigest pair n parents rest + return (final,known::levels,remainder) + +private theorem runLevelsDigest_eq (pair : Digest32 × Digest32 → Digest32) + (n : Nat) (nodes : Level Digest32) (supplied : List Digest32) : + runLevelsDigest pair n nodes supplied = runLevels pair n nodes supplied := by + induction n generalizing nodes supplied with + | zero => rfl + | succ n ih => simp only [runLevelsDigest,runLevels,foldLevelDigest_eq,ih] + def distinctPaths (leafWords : Nat) (levels : List (Level Digest32)) (table : Level (List K)) : Option (Level RawPath) := collect (fun (i, row) => do @@ -197,6 +292,33 @@ def PrunedMerklePaths.open (hash : Primitive) (proof : PrunedMerklePaths) let distinct ← distinctPaths leafWords levels table collect (fun q => binaryLookup q distinct) queries +/-- Specialize only the executable digest walk; generic MerkleLevels APIs and +all proof equations retain their original polymorphic semantics. -/ +private def PrunedMerklePaths.openStored (hash : Primitive) (proof : PrunedMerklePaths) + (root : Digest32) (numLeaves : Nat) (queries : List Nat) + (rowWords leafWords : Nat) : Option (List RawPath) := do + if numLeaves = 0 ∨ 2 ^ numLeaves.log2 ≠ numLeaves ∨ queries = [] then none + else if (sortedUnique queries).length ≠ proof.leafData.length ∨ rowWords > leafWords then none + else if ¬ ∀ row ∈ proof.leafData, row.length = rowWords then none + else if ∃ q ∈ queries, numLeaves ≤ q then none + else do + let table := leafTable queries proof.leafData + let nodes := leafNodes hash leafWords table + let (final,levels,rest) ← runLevelsDigest + (fun p => hash (List.ofFn (ByteCodec.pairBytes p))) numLeaves.log2 nodes proof.siblingHashes + if rest ≠ [] then none + else do + let (_,computed) ← final.head? + if computed ≠ root then none + else do + let distinct ← distinctPaths leafWords levels table + collect (fun q => binaryLookup q distinct) queries + +@[csimp] private theorem PrunedMerklePaths.open_stored : + PrunedMerklePaths.open = PrunedMerklePaths.openStored := by + funext hash proof root numLeaves queries rowWords leafWords + simp only [PrunedMerklePaths.open,PrunedMerklePaths.openStored,runLevelsDigest_eq] + theorem collect_mem {A B : Type} (f : A → Option B) (xs : List A) (ys : List B) (h : collect f xs = some ys) {y : B} (hy : y ∈ ys) : ∃ x ∈ xs, f x = some y := by @@ -1144,4 +1266,10 @@ theorem recorded_oracle_absent_irrelevant (snapshot : Snapshot) (root : Digest32 end Commitments +#print axioms leafNodes_stored +#print axioms emitDigest_eq +#print axioms foldLevelDigest_eq +#print axioms runLevelsDigest_eq +#print axioms PrunedMerklePaths.open_stored + end Whir.MerkleTransport diff --git a/verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean b/verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean index 41643b5de..a1528d937 100644 --- a/verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean +++ b/verification/whir/Whir/PCSBCSSourceRootReferencesSmoke.lean @@ -5,6 +5,17 @@ open Whir Concrete Protocol FiatShamirGame WHIRHistory WHIRHistoryKey open AnchoredHeaderCodec WHIRCallerClaims PCSBCSSourceRootReferences open DuplexModeGame DuplexFraming PCSBCSMerkleRootCache +local instance : DecidableEq Terminal := by + intro a b + cases a <;> cases b <;> simp <;> infer_instance + +local instance : DecidableEq Coordinate := by + intro a b + cases a + cases b + simp only [Coordinate.mk.injEq] + infer_instance + private def digest (n : Nat) : Digest32 := fun i => ⟨(n / 256^i.val) % 256,Nat.mod_lt _ (by decide)⟩ private def p : ParameterBounds.Profile := (⟨1,by decide⟩,⟨0,by decide⟩) @@ -55,7 +66,11 @@ def smoke : IO Unit := do let payload := ((WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout)).map zeroToken let tokens := payload ++ (openingScalars saved).map CallerToken.sent let entry := tokenHistory (digest 11) (digest 13) tokens - let answers := DuplexRefinement.evalCoordinate compression iv + let blocks := (WHIRCallerOutputs.callerOutputs entry).map fun q => + DuplexFraming.withCoordinate compression iv q (fun d => (q,d)) + let answers := fun q => match blocks.find? (fun row => decide (row.1 = q)) with + | some (_,d) => d + | none => DuplexRefinement.evalCoordinate compression iv q require "fresh caller identity admitted" (AnchoredSourceFreshCaller.decode layout saved entry answers).isSome printParse "initial exact role3" (parseInitial saved (openingScalars saved) 3) printParse "initial rejected context-CV role5" (parseInitial saved (openingScalars saved) 5) @@ -106,8 +121,9 @@ def smoke : IO Unit := do require "noncanonical root halves rejected" (parsePhase c q malformed (i.val+1) 2).isNone | _ => pure () - let physical := DuplexRefinement.evalCoordinate compression iv key - IO.println s!"actual deployed compression output first byte={physical ⟨0,by decide⟩}" + let physicalByte := DuplexFraming.withCoordinate compression iv key + (fun d => d ⟨0,by decide⟩) + IO.println s!"actual deployed compression output first byte={physicalByte}" let final := register registry [] (digest 17) (initialShape saved.shape) require "final proof root already captured costs zero addresses" (decide (final.size = registry.size)) diff --git a/verification/whir/Whir/PrunedMerkleProgram.lean b/verification/whir/Whir/PrunedMerkleProgram.lean index 2dbfe55fc..41b46ed4c 100644 --- a/verification/whir/Whir/PrunedMerkleProgram.lean +++ b/verification/whir/Whir/PrunedMerkleProgram.lean @@ -34,6 +34,20 @@ def eval (H : Primitive) : HashProgram R → R | .done r => r | .hash bytes next => eval H (next (H bytes)) +/-- The direct reference evaluator bypasses both lower and runReal. Snapshot +the hash reply at the recursive consumer, not in a Digest32-returning wrapper. -/ +private def evalStored (H : Primitive) : HashProgram R → R + | .done r => r + | .hash bytes next => + DuplexRefinement.withDigest (H bytes) (fun d => evalStored H (next d)) + +@[csimp] private theorem eval_stored : @eval = @evalStored := by + funext R H p + induction p with + | done => rfl + | hash bytes next ih => + simp only [eval,evalStored,DuplexRefinement.withDigest_eq,ih] + theorem eval_bind (H : Primitive) (p : HashProgram R) (next : R → HashProgram S) : eval H (bind p next) = eval H (next (eval H p)) := by induction p with @@ -172,6 +186,8 @@ theorem Certified.counts {p : HashProgram R} {budget : Nat} {post : R → Prop} (budget-(PublicMerkleLog.chunks bytes).length) (fun d => ih d (h.2 d)) exact WHIRModeFinal.counts_mono hh (by have := h.1; omega) +#print axioms eval_stored + end HashProgram abbrev LevelResult := Option (Level Digest32 × Level Digest32 × List Digest32) diff --git a/verification/whir/Whir/PublicCompressionProgram.lean b/verification/whir/Whir/PublicCompressionProgram.lean index acbf26dd0..5045b3d94 100644 --- a/verification/whir/Whir/PublicCompressionProgram.lean +++ b/verification/whir/Whir/PublicCompressionProgram.lean @@ -35,23 +35,14 @@ private def planCallsStored (cv : Digest32) : (xs : List DuplexEncoding.Instruction) → Computation Digest32 xs.length | [] => .ret cv | i :: rest => .draw ⟨cv,i.1,i.2,true⟩ (fun d => - let bytes := Array.ofFn d - planCallsStored (fun j => bytes[j.val]'(by simp [bytes])) rest) + withDigest d (fun stored => planCallsStored stored rest)) @[csimp] private theorem planCalls_stored : planCalls = planCallsStored := by funext cv xs induction xs generalizing cv with | nil => rfl | cons i rest ih => - simp only [planCalls,planCallsStored] - congr 1 - funext d - have stored : (fun j : Fin 32 => - (Array.ofFn d)[j.val]'(by simp)) = d := by - funext j - simp - rw [stored] - exact ih d + simp only [planCalls,planCallsStored,withDigest_eq,ih] theorem planCalls_eval (C : PrimitiveOracle) (cv : Digest32) (xs : List DuplexEncoding.Instruction) : Sampling.eval C (planCalls cv xs) = evalPlan (compressionOf C) cv xs := by @@ -63,6 +54,17 @@ def queryCalls (iv : Digest32) : (q : Query) → Computation Digest32 q.cost | .primitive _ n => .draw n (fun d => .ret d) | .construction q _ => planCalls iv (DuplexEncoding.plan q) +/-- Sampling executes independently of the mode interpreter, so primitive +replies need their own data-valued snapshot before reaching a continuation. -/ +private def queryCallsStored (iv : Digest32) : + (q : Query) → Computation Digest32 q.cost + | .primitive _ n => .draw n (fun d => withDigest d (fun stored => .ret stored)) + | .construction q _ => planCalls iv (DuplexEncoding.plan q) + +@[csimp] private theorem queryCalls_stored : queryCalls = queryCallsStored := by + funext iv q + cases q <;> simp only [queryCalls,queryCallsStored,withDigest_eq] <;> rfl + theorem queryCalls_eval (C : PrimitiveOracle) (iv : Digest32) (q : Query) : Sampling.eval C (queryCalls iv q) = realAnswer C iv q := by cases q with @@ -94,6 +96,31 @@ def primitiveLog {R : Type} (C : PrimitiveOracle) (iv : Digest32) (p : Program R) (Q : Nat) (h : Counts Q p) : PublicMerkleLog.PublicLog := toLog (Sampling.execute C (compile iv p Q h)).2 +/-- The generic Sampling executor stores its original oracle reply, outside +queryCalls' continuation. Share one snapshot across that continuation and log +entry instead of leaving a separately deferred digest in the public trace. -/ +private def executeStored {R : Type} (C : PrimitiveOracle) {Q : Nat} : + Computation R Q → R × List (Sigma (fun _ : Node => Digest32)) + | .ret r => (r,[]) + | .draw n next => withDigest (C n) (fun d => + let result := executeStored C (next d) + (result.1,⟨n,d⟩::result.2)) + +private theorem executeStored_eq {R : Type} (C : PrimitiveOracle) {Q : Nat} + (p : Computation R Q) : executeStored C p = Sampling.execute C p := by + induction p with + | ret => rfl + | draw n next ih => + simp only [executeStored,withDigest_eq,Sampling.execute,ih] + +private def primitiveLogStored {R : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program R) (Q : Nat) (h : Counts Q p) : PublicMerkleLog.PublicLog := + toLog (executeStored C (compile iv p Q h)).2 + +@[csimp] private theorem primitiveLog_stored : @primitiveLog = @primitiveLogStored := by + funext R C iv p Q h + simp only [primitiveLog,primitiveLogStored,executeStored_eq] + theorem primitiveLog_length {R : Type} (C : PrimitiveOracle) (iv : Digest32) (p : Program R) (Q : Nat) (h : Counts Q p) : (primitiveLog C iv p Q h).length ≤ Q := by @@ -250,4 +277,9 @@ def smoke : IO Unit := do throw (IO.userError "shared compression cache failed to reuse repeated input") IO.println "Conditional mode: 4 full compression calls, tags [0,1,6,0], 2 public direct records, 3 fresh cached draws; exact result OK" +#print axioms planCalls_stored +#print axioms queryCalls_stored +#print axioms executeStored_eq +#print axioms primitiveLog_stored + end Whir.PublicCompressionProgram diff --git a/verification/whir/Whir/PublicMerkleLog.lean b/verification/whir/Whir/PublicMerkleLog.lean index f4f0e8cba..b67b1a048 100644 --- a/verification/whir/Whir/PublicMerkleLog.lean +++ b/verification/whir/Whir/PublicMerkleLog.lean @@ -47,6 +47,28 @@ def run (query : Node → Option Digest32) (cv : Digest32) (count : Nat) : let d ← query (node cv count b false) run query d (count + b.length) (next :: rest) +/-- Reference/getter execution does not pass through runReal. Snapshot at +the Option boundary, including the final reply, without changing absence. -/ +private def runStored (query : Node → Option Digest32) (cv : Digest32) (count : Nat) : + List (List Byte) → Option Digest32 + | [] => none + | [b] => (query (node cv count b true)).bind (fun d => withDigest d Option.some) + | b :: next :: rest => (query (node cv count b false)).bind (fun d => + withDigest d (fun stored => runStored query stored (count+b.length) (next :: rest))) + +@[csimp] private theorem run_stored : run = runStored := by + funext query cv count bs + induction bs generalizing cv count with + | nil => rfl + | cons b rest ih => + cases rest with + | nil => + simp only [run,runStored,withDigest_eq] + cases query (node cv count b true) <;> rfl + | cons next rest => + simp only [run,runStored,withDigest_eq,ih] + rfl + def hash (C : PrimitiveOracle) (bytes : List Byte) : Digest32 := (run (fun n => some (C n)) DuplexCompression.parameterIV 0 (chunks bytes)).getD DuplexCompression.parameterIV @@ -64,6 +86,38 @@ def planFrom (C : PrimitiveOracle) (cv : Digest32) (count : Nat) : def plan (C : PrimitiveOracle) (bytes : List Byte) : PublicLog := planFrom C DuplexCompression.parameterIV 0 (chunks bytes) +/-- Materialize each public plan reply before using it as the next input CV. +This keeps the literal record list while avoiding repeated evaluation of the +entire preceding compression chain through function-valued digests. -/ +private def planFromStored (C : PrimitiveOracle) (cv : Digest32) (count : Nat) : + List (List Byte) → PublicMerkleLog.PublicLog + | [] => [] + | [b] => + let input := PublicMerkleLog.node cv count b true + withDigest (C input) (fun digest => [(input,digest)]) + | b :: next :: rest => + let input := PublicMerkleLog.node cv count b false + withDigest (C input) (fun digest => + (input,digest) :: planFromStored C digest (count+b.length) (next :: rest)) + +@[csimp] theorem ordinaryPlanFrom_stored : PublicMerkleLog.planFrom = planFromStored := by + funext C cv count bs + induction bs generalizing cv count with + | nil => rfl + | cons b rest ih => + cases rest with + | nil => + simp only [PublicMerkleLog.planFrom,planFromStored,withDigest_eq] + | cons next rest => + simp only [PublicMerkleLog.planFrom,planFromStored,withDigest_eq,ih] + +def planStored (C : PrimitiveOracle) (bytes : List Byte) : PublicMerkleLog.PublicLog := + planFromStored C DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) + +@[csimp] theorem ordinaryPlan_stored : PublicMerkleLog.plan = planStored := by + funext C bytes + unfold PublicMerkleLog.plan planStored + rw [ordinaryPlanFrom_stored] /-- Only a full output-CV match and the exact ordinary counter are accepted. -/ def predecessor (log : PublicLog) (count : Nat) (cv : Digest32) : Option Node := @@ -892,4 +946,7 @@ theorem frozen_target_fresh (C : PrimitiveOracle) (oldLog : PublicLog) · exact False.elim (noCollision h) · exact h +#print axioms run_stored +#print axioms ordinaryPlanFrom_stored + end Whir.PublicMerkleLog diff --git a/verification/whir/Whir/PublicMerkleProgram.lean b/verification/whir/Whir/PublicMerkleProgram.lean index 11d0dc713..d1258a618 100644 --- a/verification/whir/Whir/PublicMerkleProgram.lean +++ b/verification/whir/Whir/PublicMerkleProgram.lean @@ -78,35 +78,6 @@ def hashFrom (cv : Digest32) (count : Nat) : (bs : List (List Byte)) → bs ≠ .ask (.primitive .verification (PublicMerkleLog.node cv count b false)) fun answer => hashFrom answer (count+b.length) (next :: rest) (by simp) -/-- Close each 256-bit reply over stored bytes before it becomes another CV; -do not retain a function that recomputes the whole preceding hash chain. -/ -private def withStoredDigest {T : Type} (d : Digest32) (next : Digest32 → T) : T := - let bytes := Array.ofFn d - next (fun i => bytes[i.val]'(by simp only [bytes, Array.size_ofFn]; exact i.isLt)) - -private theorem withStoredDigest_eq {T : Type} (d : Digest32) (next : Digest32 → T) : - withStoredDigest d next = next d := by - simp [withStoredDigest] - -private def hashFromStored (cv : Digest32) (count : Nat) : - (bs : List (List Byte)) → bs ≠ [] → Program Digest32 - | [], h => False.elim (h rfl) - | [b], _ => .ask (.primitive .verification (PublicMerkleLog.node cv count b true)) - (fun answer => withStoredDigest answer Program.done) - | b :: next :: rest, _ => - .ask (.primitive .verification (PublicMerkleLog.node cv count b false)) fun answer => - withStoredDigest answer (fun cv => hashFromStored cv (count+b.length) (next :: rest) (by simp)) - -@[csimp] theorem hashFrom_stored : hashFrom = hashFromStored := by - funext cv count bs hne - induction bs generalizing cv count with - | nil => contradiction - | cons b rest ih => - cases rest with - | nil => simp only [hashFrom, hashFromStored, withStoredDigest_eq] - | cons next rest => - simp only [hashFrom, hashFromStored, withStoredDigest_eq, ih] - def hash (bytes : List Byte) : Program Digest32 := hashFrom DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) (PublicMerkleLog.chunks_nonempty bytes) @@ -149,23 +120,12 @@ theorem hash_real_result (C : PrimitiveOracle) (iv : Digest32) (bytes : List Byt rw [hashFrom_real_run C iv _ _ _ (PublicMerkleLog.chunks_nonempty bytes)] rfl -/-- The pure hash API uses the existing ordinary fold with eagerly stored -replies. Unlike evaluating a mode Program, this allocates no public trace. -/ -private def storedQuery (C : PrimitiveOracle) (n : Node) : Option Digest32 := - withStoredDigest (C n) Option.some - -private theorem storedQuery_eq (C : PrimitiveOracle) : - storedQuery C = (fun n => some (C n)) := by - funext n - exact withStoredDigest_eq _ _ - private def hashResultStored (C : PrimitiveOracle) (bytes : List Byte) : Option Digest32 := - PublicMerkleLog.run (storedQuery C) DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) + PublicMerkleLog.run (fun n => some (C n)) DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) private theorem hashResultStored_present (C : PrimitiveOracle) (bytes : List Byte) : (hashResultStored C bytes).isSome := by unfold hashResultStored - rw [storedQuery_eq] obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 rw [hd] @@ -178,7 +138,7 @@ def hashStored (C : PrimitiveOracle) (bytes : List Byte) : Digest32 := funext C bytes obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 - simp only [PublicMerkleLog.hash, hashStored, hashResultStored, storedQuery_eq, hd] + simp only [PublicMerkleLog.hash, hashStored, hashResultStored, hd] rfl /-- Force the stored ordinary fold before passing its digest to a consumer. @@ -186,12 +146,26 @@ The continuation prevents a function-valued digest from delaying that fold until each individual byte projection in native compilation. -/ def withHashStored {T : Type} (C : PrimitiveOracle) (bytes : List Byte) (next : Digest32 → T) : T := - next ((hashResultStored C bytes).get (hashResultStored_present C bytes)) + match present : hashResultStored C bytes with + | some digest => next digest + | none => False.elim (by + have stored := hashResultStored_present C bytes + simp [present] at stored) theorem withHashStored_eq {T : Type} (C : PrimitiveOracle) (bytes : List Byte) (next : Digest32 → T) : withHashStored C bytes next = next (PublicMerkleLog.hash C bytes) := by + obtain ⟨d,hd⟩ := PublicMerkleLog.run_nonempty C (PublicMerkleLog.chunks bytes) + (PublicMerkleLog.chunks_nonempty bytes) DuplexCompression.parameterIV 0 + simp only [PublicMerkleLog.hash,hd,Option.getD_some] unfold withHashStored - exact congrArg next (congrFun (congrFun ordinaryHash_stored C) bytes).symm + split + · rename_i digest present + unfold hashResultStored at present + exact congrArg next (Option.some.inj (present.symm.trans hd)) + · rename_i present + unfold hashResultStored at present + have impossible := present.symm.trans hd + contradiction def hashBlake2sStored : List Byte → Digest32 := hashStored blake2sOracle @@ -201,38 +175,6 @@ not retain the old unstored fold. Neither implementation calls itself. -/ PublicMerkleLog.hashBlake2s = hashBlake2sStored := by exact congrFun ordinaryHash_stored blake2sOracle -/-- Materialize each public plan reply before using it as the next input CV. -This keeps the literal record list while avoiding repeated evaluation of the -entire preceding compression chain through function-valued digests. -/ -private def planFromStored (C : PrimitiveOracle) (cv : Digest32) (count : Nat) : - List (List Byte) → PublicMerkleLog.PublicLog - | [] => [] - | [b] => - let input := PublicMerkleLog.node cv count b true - withStoredDigest (C input) (fun digest => [(input,digest)]) - | b :: next :: rest => - let input := PublicMerkleLog.node cv count b false - withStoredDigest (C input) (fun digest => - (input,digest) :: planFromStored C digest (count+b.length) (next :: rest)) - -@[csimp] theorem ordinaryPlanFrom_stored : PublicMerkleLog.planFrom = planFromStored := by - funext C cv count bs - induction bs generalizing cv count with - | nil => rfl - | cons b rest ih => - cases rest with - | nil => - simp only [PublicMerkleLog.planFrom,planFromStored,withStoredDigest_eq] - | cons next rest => - simp only [PublicMerkleLog.planFrom,planFromStored,withStoredDigest_eq,ih] - -def planStored (C : PrimitiveOracle) (bytes : List Byte) : PublicMerkleLog.PublicLog := - planFromStored C DuplexCompression.parameterIV 0 (PublicMerkleLog.chunks bytes) - -@[csimp] theorem ordinaryPlan_stored : PublicMerkleLog.plan = planStored := by - funext C bytes - unfold PublicMerkleLog.plan planStored - rw [ordinaryPlanFrom_stored] theorem hash_bind_real_result (C : PrimitiveOracle) (iv : Digest32) (bytes : List Byte) (next : Digest32 → Program R) : @@ -335,4 +277,7 @@ theorem hash_trace {bytes : List Byte} {trace : List Observation} {digest : Dige trace.length = (PublicMerkleLog.chunks bytes).length ∧ ∀ o ∈ trace, ∃ n, o.query = .primitive .verification n := hashFrom_trace run +#print axioms ordinaryHash_stored +#print axioms withHashStored_eq + end Whir.PublicMerkleProgram diff --git a/verification/whir/Whir/SpongefishCurrentAbsorbedPrefix.lean b/verification/whir/Whir/SpongefishCurrentAbsorbedPrefix.lean new file mode 100644 index 000000000..49c0e656a --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentAbsorbedPrefix.lean @@ -0,0 +1,151 @@ +import Whir.SpongefishCurrentInitializedMode +import Whir.SpongefishCurrentRoundSeparation + +/-! Literal full-prefix transport for the current source construction domain. +The source key contains the observed session domain, zero statement seed, +EVERY completed absorb body and its consumed-count tag, and the output block. +It does not contain earlier verifier coin values. This is the ancestry shape +of the basic full-prefix BCS variant, not its hash-chain variant. + +Recovering this prefix is not yet an adapter for the book's public instance, +IOP messages, source acceptance or state-restoration extractor. In particular, +caller points derived from earlier output coordinates still need the actual +public-output getter and original-statement join. -/ +namespace Whir.SpongefishCurrentAbsorbedPrefix +open Concrete FiatShamirGame DuplexRefinement SpongefishPCSRoundFrames +set_option autoImplicit false + +structure Prefix where + session : Digest32 + frames : List ByteFrame + deriving DecidableEq + +def Prefix.history (p : Prefix) : FramedHistory := + ⟨p.session,zeroDigest,p.frames.map ByteFrame.historicalCore⟩ + +def Prefix.bytes (p : Prefix) : List Byte := + p.frames.flatMap fun frame => match frame with | .absorb _ bytes => bytes + +def ofPending (m : Pending) : Prefix := ⟨(close m).domain,(close m).frames⟩ + +def frames : List Frame → Option (List ByteFrame) + | [] => some [] + | .absorb previous bytes :: rest => + (frames rest).map (ByteFrame.absorb previous bytes :: ·) + | .nonce _ _ _ :: _ => none + +def parse (history : FramedHistory) : Option Prefix := + if history.statement = zeroDigest then + (frames history.frames).map (fun fs => ⟨history.domain,fs⟩) + else none + +/-- Full bounded raw encoding is checked before source ancestry is exposed. +Historical nonce, commitment and powBase coordinates are not current source +rounds and do not become a forged current prefix. -/ +def rawPrefix {Q : Nat} (parameter : Digest32) (raw : DuplexModeGame.RawKey Q) : + Option (Prefix × Nat) := do + let q ← WHIRHeaderRoots.decodeRaw parameter raw + match q.terminal with + | .output block => (parse q.history).map (fun p => (p,block)) + | _ => none + +@[simp] theorem frames_encoded (fs : List ByteFrame) : + frames (fs.map ByteFrame.historicalCore) = some fs := by + induction fs with + | nil => rfl + | cons frame fs ih => cases frame; simp [frames,ByteFrame.historicalCore,ih] + +@[simp] theorem frames_recovered (source : List Frame) (decoded : List ByteFrame) + (ok : frames source = some decoded) : + decoded.map ByteFrame.historicalCore = source := by + induction source generalizing decoded with + | nil => simp only [frames,Option.some.injEq] at ok; subst decoded; rfl + | cons frame rest ih => + cases frame with + | nonce previous difficulty nonce => simp [frames] at ok + | absorb previous bytes => + simp only [frames,Option.map_eq_some_iff] at ok + obtain ⟨tail,parsed,equal⟩ := ok + subst decoded + simpa only [List.map_cons,ByteFrame.historicalCore] using + congrArg (Frame.absorb previous bytes :: ·) (ih tail parsed) + +@[simp] theorem parse_history (p : Prefix) : parse p.history = some p := by + simp [parse,Prefix.history] + +theorem parse_sound (history : FramedHistory) (p : Prefix) (ok : parse history = some p) : + p.history = history := by + unfold parse at ok + split at ok + · rename_i statement + obtain ⟨fs,decoded,equal⟩ := Option.map_eq_some_iff.mp ok + subst p + cases history + simp only [Prefix.history] + simp only [FramedHistory.mk.injEq] at statement ⊢ + exact ⟨trivial,statement.symm,frames_recovered _ _ decoded⟩ + · cases ok + +@[simp] theorem pending_history (m : Pending) : + (ofPending m).history = (close m).core.history := rfl + +theorem complete_prover_bytes (m : Pending) : + (ofPending m).bytes = retainedBytes m := by + have empty : (close m).run = [] := by + by_cases run : m.run = [] <;> simp [close,run] + simpa only [Prefix.bytes,ofPending,retainedBytes,empty,List.append_nil] using close_retains m + +/-- No flattening or truncated-root equality is used for key equality. -/ +theorem raw_roundtrip {Q : Nat} (parameter : Digest32) (m : Pending) (block : Nat) + (valid : DuplexEncoding.Admissible (SpongefishCurrentModeQueries.coordinate m block)) + (bound : DuplexFraming.pathCost (SpongefishCurrentModeQueries.coordinate m block) ≤ Q) : + rawPrefix parameter (DuplexModeGame.constructionKey Q parameter + (SpongefishCurrentModeQueries.coordinate m block) bound) = some (ofPending m,block) := by + rw [rawPrefix,WHIRHeaderRoots.decodeRaw_construction parameter _ valid bound] + change (parse (ofPending m).history).map (fun p => (p,block)) = _ + rw [parse_history] + rfl + +theorem rawPrefix_sound {Q : Nat} (parameter : Digest32) (raw : DuplexModeGame.RawKey Q) + (p : Prefix) (block : Nat) (ok : rawPrefix parameter raw = some (p,block)) : + ∃ bound : DuplexFraming.pathCost (⟨p.history,.output block⟩ : Coordinate) ≤ Q, + DuplexEncoding.Admissible ⟨p.history,.output block⟩ ∧ + DuplexModeGame.constructionKey Q parameter ⟨p.history,.output block⟩ bound = raw := by + unfold rawPrefix at ok + obtain ⟨q,decoded,rest⟩ := Option.bind_eq_some_iff.mp ok + cases q with + | mk history terminal => + cases terminal with + | commitment consumed => simp at rest + | powBase consumed difficulty => simp at rest + | output outputBlock => + obtain ⟨prefixValue,parsed,equal⟩ := Option.map_eq_some_iff.mp rest + obtain ⟨samePrefix,sameBlock⟩ := Prod.mk.inj equal + subst prefixValue + subst outputBlock + have sameHistory := parse_sound history p parsed + subst history + exact WHIRHeaderRoots.decodeRaw_sound parameter raw ⟨p.history,.output block⟩ decoded + +theorem raw_source_prefix_injective {Q : Nat} (parameter : Digest32) + (m₁ m₂ : Pending) (block₁ block₂ : Nat) + (valid₁ : DuplexEncoding.Admissible (SpongefishCurrentModeQueries.coordinate m₁ block₁)) + (valid₂ : DuplexEncoding.Admissible (SpongefishCurrentModeQueries.coordinate m₂ block₂)) + (bound₁ : DuplexFraming.pathCost (SpongefishCurrentModeQueries.coordinate m₁ block₁) ≤ Q) + (bound₂ : DuplexFraming.pathCost (SpongefishCurrentModeQueries.coordinate m₂ block₂) ≤ Q) + (same : DuplexModeGame.constructionKey Q parameter + (SpongefishCurrentModeQueries.coordinate m₁ block₁) bound₁ = + DuplexModeGame.constructionKey Q parameter + (SpongefishCurrentModeQueries.coordinate m₂ block₂) bound₂) : + ofPending m₁ = ofPending m₂ ∧ block₁ = block₂ := by + have decoded := congrArg (rawPrefix parameter) same + rw [raw_roundtrip parameter m₁ block₁ valid₁ bound₁, + raw_roundtrip parameter m₂ block₂ valid₂ bound₂] at decoded + exact Prod.mk.inj (Option.some.inj decoded) + +#print axioms parse_sound +#print axioms complete_prover_bytes +#print axioms raw_roundtrip +#print axioms raw_source_prefix_injective +#print axioms rawPrefix_sound +end Whir.SpongefishCurrentAbsorbedPrefix diff --git a/verification/whir/Whir/SpongefishCurrentAcceptedJoin.lean b/verification/whir/Whir/SpongefishCurrentAcceptedJoin.lean new file mode 100644 index 000000000..b23631a12 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentAcceptedJoin.lean @@ -0,0 +1,877 @@ +import Whir.SpongefishCurrentByteTransport +import Whir.SpongefishCurrentCallerGetterCoverage +import Whir.SpongefishCurrentObservedRecordBinding + +/-! Accepted current caller path to the public original list. The parser's +reconstructed proof bytes, derived domain and empty hint list are consequences +of the actual accepted replay, not join equations: the parser replays the caller +tape on exactly the consumed prefix of the attacker's proof bytes, and the +caller grammar contains no hint. The source continues with an arbitrary verifier +suffix `rest`, which is where the post-binding coordinate is queried. + +Receive and expected-record binding are joined to the literal caller tape: the +accepted native composition (setup, prelude, receive, payload, binding) is one +accepted actual replay of `calls layout r`. Native PCS equation, proof-of-work +and original-claim acceptance remain outside this byte-level join. -/ +namespace Whir.SpongefishCurrentAcceptedJoin +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentModeQueries +open SpongefishCurrentMixedModeCompiler SpongefishCurrentReplayProvenance +open SpongefishCurrentCallerGetterCoverage +set_option autoImplicit false +set_option maxRecDepth 10000 + +/-! ## Hint-free caller grammar -/ + +def HintFree (calls : List Call) : Prop := ∀ c ∈ calls, c ≠ .hint + +theorem shapeCalls_hintFree : ∀ (shape : List WHIRCallerShape.EventShape) (calls : List Call), + SpongefishCurrentSourceCallerOriginal.shapeCalls shape = some calls → HintFree calls + | [], calls, h => by + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls, Option.some.injEq] at h + subst h + intro c member + cases member + | .absorb n :: rest, calls, h => by + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls] at h + split at h + · obtain ⟨tail, tailEq, rfl⟩ := Option.map_eq_some_iff.mp h + intro c member + rcases List.mem_cons.mp member with rfl | later + · simp + · exact shapeCalls_hintFree rest tail tailEq c later + · cases h + | .squeeze n :: rest, calls, h => by + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls] at h + split at h + · obtain ⟨tail, tailEq, rfl⟩ := Option.map_eq_some_iff.mp h + intro c member + rcases List.mem_cons.mp member with rfl | later + · simp + · exact shapeCalls_hintFree rest tail tailEq c later + · cases h + | .nonce bits :: rest, calls, h => by + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls] at h + split at h + · obtain ⟨tail, tailEq, rfl⟩ := Option.map_eq_some_iff.mp h + intro c member + rcases List.mem_append.mp member with first | later + · simp only [List.mem_cons, List.not_mem_nil, or_false] at first + rcases first with rfl | rfl <;> simp + · exact shapeCalls_hintFree rest tail tailEq c later + · cases h + +/-- The four caller tape parts. -/ +def headerCalls (logN : Nat) : List Call := + [.read .scalar,.read .scalar,.read .scalar,.read .root,.draw (.anchor (logN-1)),.read .scalar] + +def messageCalls (r : SpongefishSessionAdapter.Record) : List Call := + (SpongefishRecordBindingParser.messages r).map (fun message => .read message.1) + +theorem calls_parts (layout : WHIRCallerClaims.CallerLayout) (r : SpongefishSessionAdapter.Record) + (tape : List Call) (callOrder : SpongefishCurrentSourceCallerOriginal.calls layout r = some tape) : + ∃ before payload, + SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before ∧ + SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payload ∧ + tape = before ++ headerCalls r.shape.logN ++ payload ++ messageCalls r := by + unfold SpongefishCurrentSourceCallerOriginal.calls at callOrder + obtain ⟨before, beforeEq, callOrder⟩ := Option.bind_eq_some_iff.mp callOrder + obtain ⟨payload, payloadEq, callOrder⟩ := Option.bind_eq_some_iff.mp callOrder + exact ⟨before, payload, beforeEq, payloadEq, (Option.some.inj callOrder).symm⟩ + +theorem calls_hintFree (layout : WHIRCallerClaims.CallerLayout) (r : SpongefishSessionAdapter.Record) + (tape : List Call) (callOrder : SpongefishCurrentSourceCallerOriginal.calls layout r = some tape) : + HintFree tape := by + obtain ⟨before, payload, beforeEq, payloadEq, rfl⟩ := calls_parts layout r tape callOrder + have first := shapeCalls_hintFree _ _ beforeEq + have second := shapeCalls_hintFree _ _ payloadEq + intro c member + rcases List.mem_append.mp member with member | member + · rcases List.mem_append.mp member with member | member + · rcases List.mem_append.mp member with member | member + · exact first c member + · simp only [headerCalls, List.mem_cons, List.not_mem_nil, or_false] at member + rcases member with rfl | rfl | rfl | rfl | rfl | rfl <;> simp + · exact second c member + · obtain ⟨message, _, rfl⟩ := List.mem_map.mp member + simp + +/-! ## Replay invariants -/ + +theorem replay_suffix (C : PrimitiveOracle) (iv : Digest32) : + ∀ (calls : List Call) (cur fin : SemanticCursor), + (runReal C iv (replayProgram cur calls)).view.result = .ok fin → + fin.data.narg <:+ cur.data.narg + | [], cur, fin, h => by + simp only [replayProgram, runReal, Except.ok.injEq] at h + subst h + exact List.suffix_refl _ + | .read kind :: calls, cur, fin, h => by + cases parsed : kind.codec.parse cur.data.narg with + | none => simp [replayProgram, parsed, runReal] at h + | some pair => + obtain ⟨value, rest⟩ := pair + simp only [replayProgram, parsed] at h + have tail := replay_suffix C iv calls _ fin h + have bytes := Codec.canonical_read kind.codec cur.data.narg rest value parsed + rw [bytes] + exact tail.trans (List.suffix_append _ _) + | .hint :: calls, cur, fin, h => by + cases hintEq : cur.data.hints with + | nil => simp [replayProgram, hintEq, runReal] at h + | cons bytes rest => + simp only [replayProgram, hintEq] at h + exact (replay_suffix C iv calls _ fin h :) + | .draw group :: calls, cur, fin, h => by + by_cases zero : group.bytes = 0 + · simp only [replayProgram, zero, ↓reduceDIte] at h + exact (replay_suffix C iv calls _ fin h :) + · by_cases guard : cur.data.pending.consumed + group.bytes ≤ maxCursor + · simp only [replayProgram, zero, ↓reduceDIte, guard, seq, + WHIRModeFinal.bind_real_result] at h + exact (replay_suffix C iv calls _ fin h :) + · simp [replayProgram, zero, guard, runReal] at h + +theorem bind_domain (m : Pending) (bytes : List Byte) : + (SpongefishPCSRoundFrames.bind m bytes).domain = m.domain := by + unfold SpongefishPCSRoundFrames.bind + split <;> rfl + +theorem close_domain (m : Pending) : (close m).domain = m.domain := by + unfold close + split <;> rfl + +theorem draw_domain (m : Pending) (n : Nat) : (draw m n).domain = m.domain := by + unfold draw + split + · rfl + · exact close_domain m + +theorem coordinate_domain (m : Pending) (block : Nat) : + (coordinate m block).history.domain = m.domain := by + simp only [coordinate, Pending.core] + exact close_domain m + +theorem replay_domain (C : PrimitiveOracle) (iv : Digest32) : + ∀ (calls : List Call) (cur fin : SemanticCursor), + (runReal C iv (replayProgram cur calls)).view.result = .ok fin → + fin.data.pending.domain = cur.data.pending.domain + | [], cur, fin, h => by + simp only [replayProgram, runReal, Except.ok.injEq] at h + subst h + rfl + | .read kind :: calls, cur, fin, h => by + cases parsed : kind.codec.parse cur.data.narg with + | none => simp [replayProgram, parsed, runReal] at h + | some pair => + obtain ⟨value, rest⟩ := pair + simp only [replayProgram, parsed] at h + exact (replay_domain C iv calls _ fin h).trans (bind_domain _ _) + | .hint :: calls, cur, fin, h => by + cases hintEq : cur.data.hints with + | nil => simp [replayProgram, hintEq, runReal] at h + | cons bytes rest => + simp only [replayProgram, hintEq] at h + exact (replay_domain C iv calls _ fin h :) + | .draw group :: calls, cur, fin, h => by + by_cases zero : group.bytes = 0 + · simp only [replayProgram, zero, ↓reduceDIte] at h + exact (replay_domain C iv calls _ fin h :) + · by_cases guard : cur.data.pending.consumed + group.bytes ≤ maxCursor + · simp only [replayProgram, zero, ↓reduceDIte, guard, seq, + WHIRModeFinal.bind_real_result] at h + exact (replay_domain C iv calls _ fin h).trans (draw_domain _ _) + · simp [replayProgram, zero, guard, runReal] at h + +/-- Accepted prefix of a call list: the replay of `xs ++ ys` is the replay of +`xs` followed by the replay of `ys` from its accepted cursor. -/ +theorem replay_append (C : PrimitiveOracle) (iv : Digest32) (ys : List Call) : + ∀ (xs : List Call) (cur fin : SemanticCursor), + (runReal C iv (replayProgram cur xs)).view.result = .ok fin → + (runReal C iv (replayProgram cur (xs ++ ys))).view.observations = + (runReal C iv (replayProgram cur xs)).view.observations ++ + (runReal C iv (replayProgram fin ys)).view.observations ∧ + (runReal C iv (replayProgram cur (xs ++ ys))).view.result = + (runReal C iv (replayProgram fin ys)).view.result + | [], cur, fin, h => by + simp only [replayProgram, runReal, Except.ok.injEq] at h + subst h + simp [replayProgram, runReal] + | .read kind :: xs, cur, fin, h => by + cases parsed : kind.codec.parse cur.data.narg with + | none => simp [replayProgram, parsed, runReal] at h + | some pair => + obtain ⟨value, rest⟩ := pair + simp only [replayProgram, parsed] at h + simp only [List.cons_append, replayProgram, parsed] + exact replay_append C iv ys xs _ fin h + | .hint :: xs, cur, fin, h => by + cases hintEq : cur.data.hints with + | nil => simp [replayProgram, hintEq, runReal] at h + | cons bytes rest => + simp only [replayProgram, hintEq] at h + simp only [List.cons_append, replayProgram, hintEq] + exact replay_append C iv ys xs _ fin h + | .draw group :: xs, cur, fin, h => by + by_cases zero : group.bytes = 0 + · simp only [replayProgram, zero, ↓reduceDIte] at h + simp only [List.cons_append, replayProgram, zero, ↓reduceDIte] + exact replay_append C iv ys xs _ fin h + · by_cases guard : cur.data.pending.consumed + group.bytes ≤ maxCursor + · simp only [replayProgram, zero, ↓reduceDIte, guard, seq, + WHIRModeFinal.bind_real_result] at h + simp only [List.cons_append, replayProgram, zero, ↓reduceDIte, guard, seq, + WHIRModeFinal.bind_real_result, bind_real_observations] + have tail := replay_append C iv ys xs _ fin h + exact ⟨by rw [tail.1, List.append_assoc], tail.2⟩ + · simp [replayProgram, zero, guard, runReal] at h + +/-! ## Replay on the consumed prefix -/ + +/-- The same semantic cursor with extra unread proof bytes and arbitrary hints. -/ +def shift (cur : SemanticCursor) (extra : List Byte) (hints : List (List Byte)) : SemanticCursor := + {cur with data := {cur.data with narg := cur.data.narg ++ extra, hints := hints}} + +/-- A hint-free replay accepted with `extra` still unread performs exactly the +same queries, with the same answers, when `extra` is removed from its input. -/ +theorem shift_replay (C : PrimitiveOracle) (iv : Digest32) (extra : List Byte) + (hints : List (List Byte)) : + ∀ (calls : List Call), HintFree calls → ∀ (cur fin : SemanticCursor), + (runReal C iv (replayProgram (shift cur extra hints) calls)).view.result = .ok fin → + extra <:+ fin.data.narg → + ∃ parsed : SemanticCursor, + (runReal C iv (replayProgram cur calls)).view.result = .ok parsed ∧ + fin = shift parsed extra hints ∧ + (runReal C iv (replayProgram cur calls)).view.observations = + (runReal C iv (replayProgram (shift cur extra hints) calls)).view.observations + | [], _, cur, fin, h, _ => by + simp only [replayProgram, runReal, Except.ok.injEq] at h + subst h + exact ⟨cur, rfl, rfl, rfl⟩ + | .read kind :: calls, free, cur, fin, h, unread => by + have rest_free : HintFree calls := fun c member => free c (List.mem_cons_of_mem _ member) + cases parsed : kind.codec.parse (shift cur extra hints).data.narg with + | none => simp [replayProgram, parsed, runReal] at h + | some pair => + obtain ⟨value, after⟩ := pair + simp only [replayProgram, parsed] at h + have tail := replay_suffix C iv calls _ fin h + obtain ⟨before, rfl⟩ := unread.trans tail + have bytes := Codec.canonical_read kind.codec _ _ value parsed + have prefixEq : cur.data.narg = kind.codec.bytes value ++ before := by + have joined : cur.data.narg ++ extra = (kind.codec.bytes value ++ before) ++ extra := by + rw [List.append_assoc] + exact bytes + exact List.append_cancel_right joined + have parsedA : kind.codec.parse cur.data.narg = some (value, before) := by + rw [prefixEq] + exact Codec.parse_append _ _ _ + have same : readNext (shift cur extra hints) kind value (before ++ extra) = + shift (readNext cur kind value before) extra hints := rfl + rw [same] at h + obtain ⟨parsedCur, ok, finEq, observed⟩ := + shift_replay C iv extra hints calls rest_free _ fin h unread + refine ⟨parsedCur, ?_, finEq, ?_⟩ + · simp only [replayProgram, parsedA] + exact ok + · simp only [replayProgram, parsedA, parsed] + rw [same] + exact observed + | .hint :: _, free, _, _, _, _ => absurd rfl (free .hint List.mem_cons_self) + | .draw group :: calls, free, cur, fin, h, unread => by + have rest_free : HintFree calls := fun c member => free c (List.mem_cons_of_mem _ member) + by_cases zero : group.bytes = 0 + · simp only [replayProgram, zero, ↓reduceDIte] at h + have same : ({shift cur extra hints with data := {(shift cur extra hints).data with + events := (shift cur extra hints).data.events ++ [.verifier []]}} : SemanticCursor) = + shift {cur with data := {cur.data with events := cur.data.events ++ [.verifier []]}} + extra hints := rfl + rw [same] at h + obtain ⟨parsedCur, ok, finEq, observed⟩ := + shift_replay C iv extra hints calls rest_free _ fin h unread + refine ⟨parsedCur, ?_, finEq, ?_⟩ + · simp only [replayProgram, zero, ↓reduceDIte] + exact ok + · simp only [replayProgram, zero, ↓reduceDIte] + rw [same] + exact observed + · by_cases guard : cur.data.pending.consumed + group.bytes ≤ maxCursor + · have guardB : (shift cur extra hints).data.pending.consumed + group.bytes ≤ maxCursor := guard + let P := collect cur.data.pending (positions cur.data.pending group.bytes) + (positions_valid _ cur.framed _ guard) cur.cache + have progB : replayProgram (shift cur extra hints) (.draw group :: calls) = + seq P (fun (cache, bytes) => + replayProgram (shift (drawn cur group.bytes guard cache bytes) extra hints) calls) := by + simp only [replayProgram, zero, ↓reduceDIte, guardB] + rfl + have progA : replayProgram cur (.draw group :: calls) = + seq P (fun (cache, bytes) => replayProgram (drawn cur group.bytes guard cache bytes) calls) := by + simp only [replayProgram, zero, ↓reduceDIte, guard] + rfl + obtain ⟨⟨cache, bytes⟩, hr⟩ : ∃ x, (runReal C iv P).view.result = x := ⟨_, rfl⟩ + rw [progB, seq, WHIRModeFinal.bind_real_result, hr] at h + obtain ⟨parsedCur, ok, finEq, observed⟩ := + shift_replay C iv extra hints calls rest_free _ fin h unread + refine ⟨parsedCur, ?_, finEq, ?_⟩ + · rw [progA, seq, WHIRModeFinal.bind_real_result, hr] + exact ok + · rw [progA, progB, seq, bind_real_observations, bind_real_observations, hr] + exact congrArg _ observed + · have guardB : ¬ (shift cur extra hints).data.pending.consumed + group.bytes ≤ maxCursor := guard + simp [replayProgram, zero, guardB, runReal] at h + +/-! ## Parser coverage from the accepted replay -/ + +theorem initial_domain (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints).data.pending.domain = + session := + SpongefishCurrentInitializedMode.constructor_domain session instanceBytes narg hints {cv := zeroDigest} + +/-- The parser's reconstructed proof bytes, derived domain and empty hints are +derived from the accepted actual replay of the caller tape. The source runs the +tape followed by an arbitrary verifier suffix; the coordinate is the first +post-tape construction coordinate at any output block. -/ +theorem candidate_accepted (C : PrimitiveOracle) (iv : Digest32) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (r : SpongefishSessionAdapter.Record) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (tape rest : List Call) (A : Nat) (attacker : Counts A prefixProgram) + (nonempty : instanceBytes ≠ []) + (callOrder : SpongefishCurrentSourceCallerOriginal.calls layout r = some tape) + (fin : SemanticCursor) (block : Nat) + (accepted : (runReal C iv (replayProgram (SpongefishCurrentInitializedMode.initial + (SpongefishSessionAdapter.derive (compressionOf C) iv tag) instanceBytes + (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints) tape)).view.result = .ok fin) : + SpongefishCurrentSourceCallerOriginal.candidate + (Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes (tape ++ rest)) + p layout (coordinate fin.data.pending block) r instanceBytes + (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes + prefixProgram (tape ++ rest))).view.observations = + SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout + (coordinate fin.data.pending block) r instanceBytes := by + apply SpongefishCurrentSourceCallerOriginal.candidate_physical + intro tape' tapeEq o member + have tapeSame := Option.some.inj (callOrder.symm.trans tapeEq) + subst tapeSame + set input := (runReal C iv prefixProgram).view.result with inputDef + set session := SpongefishSessionAdapter.derive (compressionOf C) iv tag with sessionDef + have saved := SpongefishCurrentByteTransport.replay_conserves C iv (instanceBytes ++ input.narg) + (SpongefishCurrentInitializedMode.initial session instanceBytes input.narg input.hints) tape + (SpongefishCurrentByteTransport.initial_conserves session instanceBytes input.narg input.hints) + rw [accepted] at saved + change retainedBytes fin.data.pending ++ fin.data.narg = instanceBytes ++ input.narg at saved + obtain ⟨consumed, consumedEq⟩ := replay_suffix C iv tape _ fin accepted + change consumed ++ fin.data.narg = input.narg at consumedEq + have retained : retainedBytes fin.data.pending = instanceBytes ++ consumed := by + rw [← consumedEq, ← List.append_assoc] at saved + exact List.append_cancel_right saved + have bytesEq : (SpongefishCurrentSourceCallerOriginal.historyBytes + (coordinate fin.data.pending block)).drop instanceBytes.length = consumed := by + rw [SpongefishCurrentByteTransport.coordinate_bytes, retained, List.drop_left] + have domainEq : (coordinate fin.data.pending block).history.domain = session := by + rw [coordinate_domain, replay_domain C iv tape _ fin accepted, initial_domain] + rw [bytesEq, domainEq] at member + have shifted : SpongefishCurrentInitializedMode.initial session instanceBytes input.narg input.hints = + shift (SpongefishCurrentInitializedMode.initial session instanceBytes consumed []) + fin.data.narg input.hints := by + rw [← consumedEq] + rfl + have acceptedShift := accepted + rw [shifted] at acceptedShift + obtain ⟨_, _, _, observed⟩ := shift_replay C iv fin.data.narg input.hints tape + (calls_hintFree layout r tape callOrder) _ fin acceptedShift (List.suffix_refl _) + rw [observed, ← shifted] at member + apply actual_getter C iv + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram (tape ++ rest)) + (replayProgram (SpongefishCurrentInitializedMode.initial session instanceBytes input.narg + input.hints) tape) _ + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram + (tape ++ rest) A attacker) + ?_ (initialized_recorded C iv session instanceBytes input.narg input.hints tape).2 o member + intro o' member' + apply afterPrefix_replay_included C iv tag instanceBytes prefixProgram (tape ++ rest) nonempty + rw [(replay_append C iv rest tape _ fin accepted).1] + exact List.mem_append_left _ member' + +/-! ## The physical pending buffer never exceeds one block -/ + +theorem absorbByte_bounded (c : Compression) (s : State) (b : Byte) (h : s.pending.size ≤ 64) : + (absorbByte c s b).pending.size ≤ 64 := by + unfold absorbByte + by_cases consumed : s.consumed = 0 <;> by_cases full : s.pending.size = 64 <;> + simp [consumed, full, Array.size_push] <;> omega + +theorem absorb_bounded (c : Compression) : + ∀ (bytes : List Byte) (s : State), s.pending.size ≤ 64 → (absorb c s bytes).pending.size ≤ 64 + | [], _, h => h + | b :: bytes, s, h => absorb_bounded c bytes _ (absorbByte_bounded c s b h) + +theorem squeezeLoop_pending (c : Compression) : + ∀ (n : Nat) (s : State), (squeezeLoop c n s).1.pending = s.pending + | 0, _ => rfl + | n + 1, s => by + simp only [squeezeLoop] + exact (squeezeLoop_pending c n _).trans rfl + +theorem squeeze_bounded (c : Compression) (s t : State) (n : Nat) (bytes : List Byte) + (h : s.pending.size ≤ 64) (ok : squeeze c s n = .ok (t, bytes)) : t.pending.size ≤ 64 := by + unfold squeeze at ok + split at ok + · cases ok + exact h + · split at ok + · have stateEq : t = (squeezeLoop c n (finish c s)).1 := + (congrArg Prod.fst (Except.ok.inj ok)).symm + rw [stateEq, squeezeLoop_pending] + unfold finish + split + · exact h + · simp + · cases ok + +open SpongefishCurrentPrimitiveEventCompiler in +theorem actualReplay_bounded (c : Compression) : + ∀ (calls : List Call) (cur next : Cursor), cur.state.pending.size ≤ 64 → + actualReplay c cur calls = .ok next → next.state.pending.size ≤ 64 + | [], cur, next, h, ok => by + simp only [actualReplay, Except.ok.injEq] at ok + subst ok + exact h + | call :: calls, cur, next, h, ok => by + simp only [actualReplay] at ok + cases step : actualCall c cur call with + | error e => simp [step] at ok + | ok mid => + simp only [step] at ok + apply actualReplay_bounded c calls mid next _ ok + cases call with + | read kind => + simp only [actualCall] at step + cases readEq : SpongefishPCSRoundFrames.read c cur kind with + | none => simp [readEq] at step + | some pair => + simp only [readEq, Except.ok.injEq] at step + subst step + cases parsed : kind.codec.parse cur.narg with + | none => simp [SpongefishPCSRoundFrames.read, parsed] at readEq + | some value => + obtain ⟨v0, rest⟩ := value + rw [SpongefishPCSRoundFrames.read_append c cur kind v0 rest + (Codec.canonical_read kind.codec cur.narg rest v0 parsed)] at readEq + rw [← Option.some.inj readEq] + exact absorb_bounded c _ _ h + | draw g => + simp only [actualCall] at step + cases drawn : squeezeGroup c cur g with + | error e => simp [drawn] at step + | ok pair => + simp only [drawn, Except.ok.injEq] at step + subst step + unfold squeezeGroup at drawn + cases squeezed : squeeze c cur.state g.bytes with + | error e => simp [squeezed] at drawn + | ok result => + simp only [squeezed] at drawn + cases drawn + exact squeeze_bounded c cur.state result.1 g.bytes result.2 h squeezed + | hint => + simp only [actualCall] at step + cases taken : takeHint cur with + | none => simp [taken] at step + | some after => + simp only [taken, Except.ok.injEq] at step + subst step + unfold takeHint at taken + split at taken + · cases taken + · cases taken + exact h + +theorem setup_bounded (c : Compression) (iv : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (initial : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup c iv tag instanceBytes narg hints = + some initial) : initial.state.pending.size ≤ 64 := by + unfold SpongefishCurrentObservedSessionEntry.actualSetup SpongefishSessionAdapter.newSession at setup + split at setup + · cases setup + · cases setup + exact absorb_bounded c _ _ (by simp [SpongefishSessionAdapter.init, seed]) + +/-! ## Receive and binding are one accepted replay of the caller tape -/ + +open SpongefishCurrentPrimitiveEventCompiler in +theorem actualReplay_append (c : Compression) (ys : List Call) : + ∀ (xs : List Call) (cur mid : Cursor), actualReplay c cur xs = .ok mid → + actualReplay c cur (xs ++ ys) = actualReplay c mid ys + | [], cur, mid, h => by + simp only [actualReplay, Except.ok.injEq] at h + subst h + rfl + | x :: xs, cur, mid, h => by + simp only [List.cons_append, actualReplay] at h ⊢ + cases step : actualCall c cur x with + | error e => simp [step] at h + | ok next => + simp only [step] at h ⊢ + exact actualReplay_append c ys xs next mid h + +open SpongefishCurrentPrimitiveEventCompiler SpongefishRecordBindingParser in +theorem verifyFields_replay (c : Compression) : + ∀ (messages : List SpongefishRecordBindingParser.Message) (cur next : Cursor), + verifyFields c cur messages = some next → + actualReplay c cur (messages.map (fun message => .read message.1)) = .ok next + | [], cur, next, h => by + simp only [verifyFields, Option.some.injEq] at h + subst h + rfl + | message :: messages, cur, next, h => by + simp only [verifyFields] at h + obtain ⟨mid, midEq, h⟩ := Option.bind_eq_some_iff.mp h + have readOk : ∃ value, SpongefishPCSRoundFrames.read c cur message.1 = some (mid, value) := by + unfold checkedRead at midEq + cases hr : SpongefishPCSRoundFrames.read c cur message.1 with + | none => simp [hr] at midEq + | some pair => + simp only [hr] at midEq + split at midEq + · cases Option.some.inj midEq + exact ⟨pair.2, rfl⟩ + · cases midEq + obtain ⟨value, readEq⟩ := readOk + simp only [List.map_cons, actualReplay, actualCall, readEq] + exact verifyFields_replay c messages mid next h + +open SpongefishCurrentPrimitiveEventCompiler in +theorem receive_replay (c : Compression) (cur next : Cursor) (shape : AnchoredHeaderCodec.Shape) + (r : SpongefishSessionAdapter.Record) + (accepted : SpongefishCurrentCommitmentReceive.receive c cur shape = some (next, r)) : + actualReplay c cur (headerCalls shape.logN) = .ok next := by + obtain ⟨header, root, sampled, bytes, point, value, readHeader, drawn, _, readValue, _⟩ := + SpongefishCurrentCommitmentReceive.receive_runs c cur next shape r accepted + have fields := ((SpongefishCurrentAnchorHeader.readHeader_exact c cur header shape root).mp + readHeader).2 + have first := verifyFields_replay c (SpongefishCurrentAnchorHeader.fields shape root) cur header fields + have split : headerCalls shape.logN = + (SpongefishCurrentAnchorHeader.fields shape root).map (fun message => .read message.1) ++ + [.draw (.anchor (shape.logN-1)),.read .scalar] := by + simp [headerCalls, SpongefishCurrentAnchorHeader.fields, + SpongefishRecordBindingParser.scalarMessages, SpongefishSessionAdapter.constants] + rw [split, actualReplay_append c _ _ cur header first] + simp [actualReplay, actualCall, drawn, readValue] + +open SpongefishCurrentPrimitiveEventCompiler in +/-- The accepted native composition is one accepted replay of the caller tape. -/ +theorem composition_replay (c : Compression) (layout : WHIRCallerClaims.CallerLayout) + (r : SpongefishSessionAdapter.Record) (before payloadCalls : List Call) + (initial pre received payload next : Cursor) + (preRun : actualReplay c initial before = .ok pre) + (receivedEq : SpongefishCurrentCommitmentReceive.receive c pre + (AnchoredSourceCaller.shape layout) = some (received, r)) + (payloadRun : actualReplay c received payloadCalls = .ok payload) + (bindingEq : SpongefishRecordBindingParser.verify c payload r = some next) : + actualReplay c initial (before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r) = + .ok next := by + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains c pre received _ r receivedEq).1 + have header := receive_replay c pre received _ r receivedEq + rw [← shapeEq] at header + have binding := verifyFields_replay c (SpongefishRecordBindingParser.messages r) payload next + bindingEq + rw [actualReplay_append c _ _ _ _ (by rw [actualReplay_append c _ _ _ _ (by + rw [actualReplay_append c _ _ _ _ preRun]; exact header)]; exact payloadRun)] + exact binding + +/-- The accepted native composition is the accepted semantic source replay of +the caller tape, with the same erased cursor data. -/ +theorem accepted_semantic (C : PrimitiveOracle) (iv : Digest32) + (layout : WHIRCallerClaims.CallerLayout) (r : SpongefishSessionAdapter.Record) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) (initial pre received payload next : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) iv tag instanceBytes + narg hints = some initial) + (preRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial before = + .ok pre) + (receivedEq : SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre + (AnchoredSourceCaller.shape layout) = some (received, r)) + (payloadRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received + payloadCalls = .ok payload) + (bindingEq : SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next) : + ∃ fin : SemanticCursor, + (runReal C iv (replayProgram (SpongefishCurrentInitializedMode.initial + (SpongefishSessionAdapter.derive (compressionOf C) iv tag) instanceBytes narg hints) + (before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r))).view.result = + .ok fin ∧ + fin.data = SpongefishCurrentMixedModeCompiler.forget next := by + set session := SpongefishSessionAdapter.derive (compressionOf C) iv tag with sessionDef + have initialEq : SpongefishCurrentObservedSessionEntry.cursor session instanceBytes narg hints + (absorb (compressionOf C) (SpongefishSessionAdapter.init (compressionOf C) iv session) + instanceBytes) = initial := by + simpa [SpongefishCurrentObservedSessionEntry.actualSetup, SpongefishSessionAdapter.newSession, + nonempty] using setup + have tapeRun := composition_replay (compressionOf C) layout r before payloadCalls initial pre + received payload next preRun receivedEq payloadRun bindingEq + have erased := SpongefishCurrentMixedModeCompiler.replay_real C iv + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) + (SpongefishCurrentObservedSessionEntry.cursor session instanceBytes narg hints + (absorb (compressionOf C) (SpongefishSessionAdapter.init (compressionOf C) iv session) + instanceBytes)) + rfl (session_bridge (compressionOf C) iv session instanceBytes) + (by intro other d found; cases found) (before ++ headerCalls r.shape.logN ++ payloadCalls ++ + messageCalls r) + rw [initialEq, tapeRun] at erased + revert erased + cases (runReal C iv (replayProgram (SpongefishCurrentInitializedMode.initial session + instanceBytes narg hints) (before ++ headerCalls r.shape.logN ++ payloadCalls ++ + messageCalls r))).view.result with + | error e => intro erased; cases erased + | ok fin => + intro erased + exact ⟨fin, rfl, Except.ok.inj erased⟩ + +/-- Accepted native setup, prelude, receive, payload and expected-record binding, +followed by a source query of the post-binding coordinate, place the physically +prepared original in the public extractor's original list. No equation between +the parser's reconstruction and the native path is assumed. -/ +theorem accepted_original (C : PrimitiveOracle) (iv : Digest32) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (r : SpongefishSessionAdapter.Record) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (rest : List Call) (A : Nat) (attacker : Counts A prefixProgram) + (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (initial pre received payload next : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) iv tag instanceBytes + (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints = some initial) + (preRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial before = + .ok pre) + (receivedEq : SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre + (AnchoredSourceCaller.shape layout) = some (received, r)) + (payloadRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received + payloadCalls = .ok payload) + (bindingEq : SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next) + (block : Nat) (blockBound : block < 2^44) : + let tape := before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes (tape ++ rest) + let q := coordinate next.pending block + let observations := (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag + instanceBytes prefixProgram (tape ++ rest))).view.observations + (∃ proof d, (⟨.construction q proof, d⟩ : Observation) ∈ observations) → + ∃ work : pathCost q ≤ Q, + r ∈ SpongefishCurrentRecordModeCapture.rawRecords (AnchoredSourceCaller.shape layout) iv + (constructionKey Q iv q work) ∧ + SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q r instanceBytes observations = + SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r instanceBytes ∧ + ∀ input, SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r + instanceBytes = some input → + input ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv + (constructionKey Q iv q work) instanceBytes observations := by + intro tape Q q observations queried + set input := (runReal C iv prefixProgram).view.result with inputDef + set session := SpongefishSessionAdapter.derive (compressionOf C) iv tag with sessionDef + obtain ⟨shapeEq, contextEq, _, header, _, _, _, readHeader, _⟩ := + SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq + have valid : r.shape.Valid := by + rw [shapeEq] + exact ((SpongefishCurrentAnchorHeader.readHeader_exact _ pre header _ r.root).mp readHeader).1 + have pendingBound : r.context.pending.length ≤ 64 := by + rw [contextEq] + simpa [SpongefishSessionAdapter.capture] using + actualReplay_bounded _ before initial pre (setup_bounded _ _ _ _ _ _ _ setup) preRun + have callOrder : SpongefishCurrentSourceCallerOriginal.calls layout r = some tape := by + simp only [SpongefishCurrentSourceCallerOriginal.calls, beforeEq, payloadEq] + rfl + obtain ⟨fin, accepted, finData⟩ := accepted_semantic C iv layout r tag instanceBytes input.narg + input.hints nonempty before payloadCalls initial pre received payload next setup preRun + receivedEq payloadRun bindingEq + have pendingEq : fin.data.pending = next.pending := congrArg Data.pending finData + have framed : FrameDomain next.pending := pendingEq ▸ fin.framed + obtain ⟨proof, d, member⟩ := queried + have work := observation_cap (real_runs C iv _) _ + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram + (tape ++ rest) A attacker) _ member + have selected := (SpongefishCurrentSourceCallerOriginal.receive_binding_candidate + (compressionOf C) iv pre received payload next (AnchoredSourceCaller.shape layout) r + receivedEq bindingEq valid pendingBound framed block blockBound work).1 + have complete := candidate_accepted C iv p layout r tag instanceBytes prefixProgram tape rest A + attacker nonempty callOrder fin block accepted + rw [pendingEq] at complete + refine ⟨work, selected, complete, ?_⟩ + intro prepared preparedEq + unfold SpongefishCurrentSourceCallerOriginal.original + rw [WHIRHeaderRoots.decodeRaw_construction iv _ (coordinate_admissible _ framed block blockBound) work] + apply List.mem_filterMap.mpr + exact ⟨r, selected, complete.trans preparedEq⟩ + +theorem collect_head (C : PrimitiveOracle) (iv : Digest32) (m : Pending) (P : List Nat) + (valid : ∀ p ∈ P, DuplexEncoding.Admissible (coordinate m (p/32))) (cache : Cache) + (p : Nat) (ps : List Nat) (head : P = p :: ps) (miss : cache (coordinate m (p/32)) = none) : + ∃ proof d, (⟨.construction (coordinate m (p/32)) proof, d⟩ : Observation) ∈ + (runReal C iv (collect m P valid cache)).view.observations := by + subst head + simp only [collect, seq, bind_real_observations] + refine ⟨valid p List.mem_cons_self, evalCoordinate (compressionOf C) iv (coordinate m (p/32)), + List.mem_append_left _ ?_⟩ + simp [request, miss, runReal, prepend, realAnswer] + +/-- A positive verifier draw after an accepted tape queries the first output +block of the post-tape coordinate, or found it already recorded in the tape. -/ +theorem next_draw_queried (C : PrimitiveOracle) (iv : Digest32) (cur fin : SemanticCursor) + (tape rest : List Call) (g : Group) + (accepted : (runReal C iv (replayProgram cur tape)).view.result = .ok fin) + (recorded : Recorded fin.cache (runReal C iv (replayProgram cur tape)).view.observations) + (positive : g.bytes ≠ 0) (guard : fin.data.pending.consumed + g.bytes ≤ maxCursor) : + ∃ proof d, (⟨.construction (coordinate fin.data.pending (fin.data.pending.consumed / 32)) proof, + d⟩ : Observation) ∈ (runReal C iv (replayProgram cur (tape ++ .draw g :: rest))).view.observations := by + rw [(replay_append C iv _ tape cur fin accepted).1] + cases hit : fin.cache (coordinate fin.data.pending (fin.data.pending.consumed / 32)) with + | some d => + obtain ⟨proof, member⟩ := recorded _ d hit + exact ⟨proof, d, List.mem_append_left _ member⟩ + | none => + have prog : replayProgram fin (.draw g :: rest) = + seq (collect fin.data.pending (positions fin.data.pending g.bytes) + (positions_valid _ fin.framed _ guard) fin.cache) + (fun (cache, bytes) => replayProgram (drawn fin g.bytes guard cache bytes) rest) := by + simp only [replayProgram, positive, ↓reduceDIte, guard] + obtain ⟨k, hk⟩ := Nat.exists_eq_succ_of_ne_zero positive + have head : positions fin.data.pending g.bytes = + (fin.data.pending.consumed + 0) :: (List.range k).map (fun j => fin.data.pending.consumed + (j+1)) := by + simp [positions, hk, List.range_succ_eq_map] + obtain ⟨proof, d, member⟩ := collect_head C iv fin.data.pending _ + (positions_valid _ fin.framed _ guard) fin.cache _ _ head (by simpa using hit) + simp only [Nat.add_zero] at member + refine ⟨proof, d, List.mem_append_right _ ?_⟩ + rw [prog, seq, bind_real_observations] + exact List.mem_append_left _ member + +/-- When the verifier suffix begins with a positive challenge draw, as the PCS +opening does after binding, the post-binding query is derived rather than assumed. -/ +theorem accepted_original_next (C : PrimitiveOracle) (iv : Digest32) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (r : SpongefishSessionAdapter.Record) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (g : Group) (rest : List Call) (A : Nat) (attacker : Counts A prefixProgram) + (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (initial pre received payload next : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) iv tag instanceBytes + (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints = some initial) + (preRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial before = + .ok pre) + (receivedEq : SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre + (AnchoredSourceCaller.shape layout) = some (received, r)) + (payloadRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received + payloadCalls = .ok payload) + (bindingEq : SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next) + (positive : g.bytes ≠ 0) (guard : next.pending.consumed + g.bytes ≤ maxCursor) : + let tape := before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes (tape ++ .draw g :: rest) + let q := coordinate next.pending (next.pending.consumed / 32) + let observations := (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag + instanceBytes prefixProgram (tape ++ .draw g :: rest))).view.observations + ∃ work : pathCost q ≤ Q, + r ∈ SpongefishCurrentRecordModeCapture.rawRecords (AnchoredSourceCaller.shape layout) iv + (constructionKey Q iv q work) ∧ + SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q r instanceBytes observations = + SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r instanceBytes ∧ + ∀ input, SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r + instanceBytes = some input → + input ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv + (constructionKey Q iv q work) instanceBytes observations := by + intro tape Q q observations + obtain ⟨fin, accepted, finData⟩ := accepted_semantic C iv layout r tag instanceBytes + (runReal C iv prefixProgram).view.result.narg (runReal C iv prefixProgram).view.result.hints + nonempty before payloadCalls initial pre received payload next setup preRun receivedEq + payloadRun bindingEq + have pendingEq : fin.data.pending = next.pending := congrArg Data.pending finData + have recorded := (initialized_recorded C iv (SpongefishSessionAdapter.derive (compressionOf C) iv tag) + instanceBytes (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints tape).1 + rw [accepted] at recorded + have queried : ∃ proof d, (⟨.construction (coordinate next.pending (next.pending.consumed / 32)) + proof, d⟩ : Observation) ∈ (runReal C iv (replayProgram (SpongefishCurrentInitializedMode.initial + (SpongefishSessionAdapter.derive (compressionOf C) iv tag) instanceBytes + (runReal C iv prefixProgram).view.result.narg (runReal C iv prefixProgram).view.result.hints) + (tape ++ .draw g :: rest))).view.observations := by + rw [← pendingEq] + exact next_draw_queried C iv _ fin tape rest g accepted recorded positive + (by rw [pendingEq]; exact guard) + obtain ⟨proof, d, member⟩ := queried + have blockBound : next.pending.consumed / 32 < 2^44 := by + simp only [maxCursor] at guard + omega + exact accepted_original C iv p layout r tag instanceBytes prefixProgram (.draw g :: rest) A + attacker nonempty before payloadCalls beforeEq payloadEq initial pre received payload next setup + preRun receivedEq payloadRun bindingEq _ blockBound + ⟨proof, d, afterPrefix_replay_included C iv tag instanceBytes prefixProgram + (tape ++ .draw g :: rest) nonempty _ member⟩ + +#print axioms calls_hintFree +#print axioms replay_suffix +#print axioms replay_domain +#print axioms replay_append +#print axioms shift_replay +#print axioms candidate_accepted +#print axioms composition_replay +#print axioms accepted_original +#print axioms accepted_original_next + +/-- The same conclusion from the observed physical compiler, which retains the +actual record-capture context: its accepted snapshot's pending history selects +the post-binding coordinate. -/ +theorem observed_original (C : PrimitiveOracle) (iv : Digest32) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (r : SpongefishSessionAdapter.Record) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (rest : List Call) (A : Nat) (attacker : Counts A prefixProgram) + (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (snapshot : SpongefishCurrentPhysicalModeCompiler.Captured) + (accepted : (runReal C iv (SpongefishCurrentObservedRecordBinding.program iv tag instanceBytes + (runReal C iv prefixProgram).view.result.narg (runReal C iv prefixProgram).view.result.hints + (AnchoredSourceCaller.shape layout) before payloadCalls)).view.result = + some (.ok (snapshot, r))) + (block : Nat) (blockBound : block < 2^44) : + let tape := before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes (tape ++ rest) + let q := coordinate snapshot.1.pending block + let observations := (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag + instanceBytes prefixProgram (tape ++ rest))).view.observations + (∃ proof d, (⟨.construction q proof, d⟩ : Observation) ∈ observations) → + ∃ work : pathCost q ≤ Q, + r ∈ SpongefishCurrentRecordModeCapture.rawRecords (AnchoredSourceCaller.shape layout) iv + (constructionKey Q iv q work) ∧ + SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q r instanceBytes observations = + SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r instanceBytes ∧ + ∀ input, SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r + instanceBytes = some input → + input ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv + (constructionKey Q iv q work) instanceBytes observations := by + obtain ⟨initial, pre, received, payload, next, setup, preRun, receivedEq, payloadRun, bindingEq, + snapshotEq, _⟩ := SpongefishCurrentObservedRecordBinding.program_accepted C iv tag instanceBytes + _ _ _ before payloadCalls snapshot r accepted + subst snapshotEq + exact accepted_original C iv p layout r tag instanceBytes prefixProgram rest A attacker nonempty + before payloadCalls beforeEq payloadEq initial pre received payload next setup preRun receivedEq + payloadRun bindingEq block blockBound + +#print axioms observed_original + +end Whir.SpongefishCurrentAcceptedJoin diff --git a/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean b/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean index 9bb4a9697..bb2df0805 100644 --- a/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean +++ b/verification/whir/Whir/SpongefishCurrentAdapterSmoke.lean @@ -4,6 +4,7 @@ import Whir.SpongefishCurrentPhysicalRootCapture import Whir.SpongefishCurrentPrimitiveEventCompiler import Whir.SpongefishCurrentInitializedMode import Whir.SpongefishCurrentRoundSeparation +import Whir.SpongefishCurrentObservedRecordBinding /-! Real BLAKE2s execution of the current byte-adapter paths, including raw-root mismatch, truncated immutable record and an output-block boundary. This is a @@ -25,8 +26,9 @@ def main : IO Unit := do let parameter := DuplexCompression.parameterIV let tag := ([] : List Byte) let derived := DuplexModeGame.runReal C parameter (SpongefishOrdinarySession.deriveProgram parameter tag) - let session := derive c parameter tag - unless derived.view.result = session && derived.view.observations.length = 2 do + let session := derived.view.result + unless withDerived c parameter tag (fun expected => + Array.ofFn expected = Array.ofFn session) && derived.view.observations.length = 2 do throw (IO.userError "observed session derivation disagrees") report "observed session derivation agrees" let instanceBytes : List Byte := [11] @@ -65,6 +67,41 @@ def main : IO Unit := do rejectedData.hintsRead = 0 do throw (IO.userError "initialized mode charged or mutated an unreached rejected suffix") report "observed initialized mode retained reached reject prefix and no later hint" + let observedShape : Shape := ⟨2,1,1,1⟩ + let receiveBytes := SpongefishCurrentAnchorHeader.bytes observedShape zeroDigest ++ valueBytes + let some observedStart := SpongefishCurrentObservedSessionEntry.actualSetup c parameter tag + instanceBytes receiveBytes [] + | throw (IO.userError "observed-record constructor rejected") + let some (_,observedRecord) := SpongefishCurrentCommitmentReceive.receive c observedStart observedShape + | throw (IO.userError "observed-record literal receive rejected") + let expectedBytes := (SpongefishRecordBindingParser.messages observedRecord).flatMap + (fun message => message.bytes) + let observedInput := receiveBytes ++ expectedBytes + let observedRun := DuplexModeGame.runReal C parameter + (SpongefishCurrentObservedRecordBinding.program parameter tag instanceBytes observedInput [] + observedShape [] []) + let some (.ok (observedSnapshot,retainedRecord)) := observedRun.view.result + | throw (IO.userError "observed initialized record composition rejected") + unless observedSnapshot.1.narg = [] && observedSnapshot.1.bytesRead = observedInput.length && + retainedRecord.point = observedRecord.point && retainedRecord.value = observedRecord.value && + Array.ofFn retainedRecord.context.cv = Array.ofFn (capture observedStart.state).cv && + retainedRecord.context.pending = (capture observedStart.state).pending && + retainedRecord.context.previous = (capture observedStart.state).previous && + retainedRecord.context.squeezed = (capture observedStart.state).squeezed do + throw (IO.userError "observed record did not retain its computed pre-header context") + report "observed initialized receive and expected-record binding derived the actual immutable context" + let foreignRecord := {observedRecord with root := fun _ => 1} + let foreignBytes := (SpongefishRecordBindingParser.messages foreignRecord).flatMap + (fun message => message.bytes) + let foreignRun := DuplexModeGame.runReal C parameter + (SpongefishCurrentObservedRecordBinding.program parameter tag instanceBytes + (receiveBytes ++ foreignBytes) [] observedShape [] []) + let some (.error (foreignSnapshot,.fieldMismatch .root)) := foreignRun.view.result + | throw (IO.userError "foreign expected-record root was not rejected after its read") + unless foreignSnapshot.1.bytesRead = receiveBytes.length + 104 && + foreignSnapshot.1.narg.length = foreignBytes.length - 104 do + throw (IO.userError "foreign record rejection lost the reached post-absorb cursor") + report "observed opening mismatch retained read-first-compare-second rejection transport" let layout : OpeningLayout := ⟨2,⟨2,1,3,5,⟨1,by decide⟩⟩,[(1,⟨1,1,2,3,⟨0,by decide⟩⟩)],1,2,1,3,⟨0,by decide⟩⟩ unless SpongefishCurrentRoundSeparation.scan false layout.schedule = some true && diff --git a/verification/whir/Whir/SpongefishCurrentAnchorAttackerPrefix.lean b/verification/whir/Whir/SpongefishCurrentAnchorAttackerPrefix.lean new file mode 100644 index 000000000..b1335c497 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentAnchorAttackerPrefix.lean @@ -0,0 +1,507 @@ +import Whir.SpongefishCurrentPhysicalRootCapture +import Whir.SpongefishCurrentInitializedMode +import Whir.AnchoredMixedAttackerPrefixObserver + +/-! Current raw32 first-root anchoring. Only the generic bounded-coordinate +partition and its finite-oracle math are reused from the historical modules; +the historical saved-header parser/registry is not used. Every output key with +the current 104-byte suffix freezes the same physical root before its answer, +including off-vector blocks and adversarial prequeries. The source lowering is +unchanged. Supported Profile alignment is explicit caller metadata, not an +additional source guard. This is not a native original-claim knowledge theorem. -/ +namespace Whir.SpongefishCurrentAnchorAttackerPrefix +open Concrete FiatShamirGame DuplexFraming DuplexModeGame TypedOracleCompiler +open ParameterBounds AnchoredByteStreamGroups AnchoredFiatShamirSecurityCodec +open PublicMerkleLog PCSBCSMerkleRootCache +set_option autoImplicit false +set_option maxRecDepth 100000 +set_option maxHeartbeats 2000000 + +/-- Exactly the existing mathematical Profile/list domain. -/ +structure Supported (p : Profile) (shape : SpongefishSessionAdapter.Shape) : Prop where + valid : shape.Valid + dimension : shape.logN = (config p).logN + batch : shape.logBatch = (config p).folds[0]! + rate : shape.logRate = (config p).rates[0]! + +/-- A computable current predicate; no historical framing or root input. -/ +def accept (shape : SpongefishSessionAdapter.Shape) (history : FramedHistory) : Bool := + (SpongefishCurrentAnchorHeader.fromHistory shape history).isSome + +abbrev Packet (p : Profile) (Q : Nat) (iv : Digest32) + (shape : SpongefishSessionAdapter.Shape) := + AnchoredByteStreamCausal.Packet Q (config p).logN iv (accept shape) + +def root {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (packet : Packet p Q iv shape) : Digest32 := + (SpongefishCurrentAnchorHeader.fromHistory shape packet.val.history).getD DuplexRefinement.zeroDigest + +theorem packet_header {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (packet : Packet p Q iv shape) : + SpongefishCurrentAnchorHeader.fromHistory shape packet.val.history = some (root shape packet) := by + have found := packet.property + cases parsed : SpongefishCurrentAnchorHeader.fromHistory shape packet.val.history with + | none => simp [accept,parsed] at found + | some digest => simp [root,parsed] + +/-- All consecutive output blocks, not just the native first draw, carry the +same current root. The physical recognizer also recognizes output blocks beyond +this vector, which remain outside the vector partition. -/ +theorem packet_key_header {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (packet : Packet p Q iv shape) + (i : Fin (blockCount (config p).logN)) : + SpongefishCurrentAnchorHeader.rawHeader shape iv (key packet.val i) = some (root shape packet) := by + simp [SpongefishCurrentAnchorHeader.rawHeader,key_decodes,coordinate,packet_header] + +theorem packet_key_member {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (packet : Packet p Q iv shape) + (i : Fin (blockCount (config p).logN)) : + SpongefishCurrentPhysicalRootCapture.reference shape (root shape packet) ∈ + SpongefishCurrentPhysicalRootCapture.addresses shape iv (.inr (key packet.val i)) := by + have found := SpongefishCurrentPhysicalRootCapture.recognize_output shape iv + (coordinate packet.val i) (packet.val.admissible i) (packet.val.bounded i) + i.val rfl (root shape packet) (packet_header shape packet) + simp [SpongefishCurrentPhysicalRootCapture.addresses,key,found] + +/-- Historical grouping stores completed pairs newest-first; physical capture +uses chronological Sigma events. This conversion never fabricates an answer. -/ +def events {Q : Nat} (past : AnchoredMixedAttackerPrefix.History Q) : + List (SpongefishCurrentPhysicalRootCapture.Event Q) := + past.reverse.map (fun e => ⟨e.1,e.2⟩) + +def candidate {Q : Nat} (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (digest : Digest32) (past : AnchoredMixedAttackerPrefix.History Q) : Frozen := + let prior := events past + let ref := SpongefishCurrentPhysicalRootCapture.reference shape digest + freeze (SpongefishCurrentPhysicalRootCapture.ordinaryLog + ((SpongefishCurrentPhysicalRootCapture.firstPrefix shape iv ref prior).getD prior)) + digest (SpongefishCurrentPhysicalRootCapture.physicalShape shape) + +/-- Preparation consults only the literal earliest completed prefix. -/ +def prepare {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (past : AnchoredMixedAttackerPrefix.History Q) (packet : Packet p Q iv shape) : + AnchoredFiatShamirSecurity.PreAnchor p := + ⟨shape.lanes,(candidate shape iv (root shape packet) past).raw, + ⟨supported.valid.2.2.2.2.1,by + rw [← supported.batch] + exact supported.valid.2.2.2.2.2⟩⟩ + +def policy {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (advertise : AnchoredMixedAttackerPrefix.History Q → Packet p Q iv shape → + Joint (config p).logN → E) : + AnchoredMixedAttackerPrefix.Grouped.Policy p Q iv (accept shape) := + ⟨prepare shape supported,advertise⟩ + +theorem candidate_before_every_reply {Q : Nat} + (shape : SpongefishSessionAdapter.Shape) (iv digest : Digest32) + (past : AnchoredMixedAttackerPrefix.History Q) + (key : PublicCompressionCouplingMixed.Key Q) (answer : Digest32) + (later : List (SpongefishCurrentPhysicalRootCapture.Event Q)) + (mention : SpongefishCurrentPhysicalRootCapture.reference shape digest ∈ + SpongefishCurrentPhysicalRootCapture.addresses shape iv key) : + SpongefishCurrentPhysicalRootCapture.capture shape iv + (SpongefishCurrentPhysicalRootCapture.reference shape digest) + (events past ++ ⟨key,answer⟩ :: later) = some (candidate shape iv digest past) := + SpongefishCurrentPhysicalRootCapture.current_capture shape iv _ _ _ _ mention + +theorem candidate_strict {Q : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv digest : Digest32) (past : AnchoredMixedAttackerPrefix.History Q) : + ((SpongefishCurrentPhysicalRootCapture.firstPrefix shape iv + (SpongefishCurrentPhysicalRootCapture.reference shape digest) (events past)).getD + (events past)).length < (events past).length+1 := + SpongefishCurrentPhysicalRootCapture.current_reply_strict shape iv _ _ + +theorem repeated_physical_reference {Q : Nat} (shape : SpongefishSessionAdapter.Shape) + (iv : Digest32) (ref : PCSBCSSourceRootReferences.Reference) + (prior later : List (SpongefishCurrentPhysicalRootCapture.Event Q)) (frozen : Frozen) + (found : SpongefishCurrentPhysicalRootCapture.capture shape iv ref prior = some frozen) : + SpongefishCurrentPhysicalRootCapture.capture shape iv ref (prior ++ later) = some frozen := + SpongefishCurrentPhysicalRootCapture.capture_extension shape iv ref prior later frozen found + +/-- The nonempty raw32 root read resets the consumed cursor. -/ +private theorem header_consumed (c : DuplexRefinement.Compression) + (cur header : SpongefishPCSRoundFrames.Cursor) (shape : SpongefishSessionAdapter.Shape) + (digest : Digest32) + (readHeader : SpongefishCurrentAnchorHeader.readHeader c cur shape = some (header,digest)) : + header.pending.consumed = 0 := by + unfold SpongefishCurrentAnchorHeader.readHeader at readHeader + split at readHeader + · contradiction + · obtain ⟨middle,_,last⟩ := Option.bind_eq_some_iff.mp readHeader + unfold SpongefishPCSRoundFrames.read at last + obtain ⟨⟨value,rest⟩,_,equal⟩ := Option.bind_eq_some_iff.mp last + have same := Option.some.inj equal + have cursor := congrArg Prod.fst same + dsimp only at cursor + rw [← cursor] + simp [SpongefishPCSRoundFrames.bind,SpongefishPCSRoundFrames.WireKind.codec, + SpongefishPCSRoundFrames.Codec.bytes,SpongefishPCSRoundFrames.rootCodec] + +/-- Every coordinate of the retained current E-vector is derived from its +literal consecutive raw32 construction replies. No `r.point = sampled` input. -/ +theorem receive_point_coordinates {Q : Nat} (c : DuplexRefinement.Compression) + (iv : Digest32) (cur next : SpongefishPCSRoundFrames.Cursor) + (shape : SpongefishSessionAdapter.Shape) (r : SpongefishSessionAdapter.Record) + (accepted : SpongefishCurrentCommitmentReceive.receive c cur shape = some (next,r)) + (represented : SpongefishPCSRoundFrames.RepresentsCurrent c iv cur.pending cur.state) + (framed : SpongefishCurrentModeQueries.FrameDomain cur.pending) + (bounded : ∀ (header : SpongefishPCSRoundFrames.Cursor), + SpongefishCurrentAnchorHeader.readHeader c cur shape = some (header,r.root) → + ∀ i : Fin (blockCount shape.logN), + pathCost (SpongefishCurrentModeQueries.coordinate header.pending i.val) ≤ Q) : + ∃ header, ∃ point : Fin shape.logN → E, + SpongefishCurrentAnchorHeader.readHeader c cur shape = some (header,r.root) ∧ + r.point = List.ofFn point ∧ + point = AnchoredFiatShamirSecurityCodec.point shape.logN (fun i => + DuplexRefinement.evalCoordinate c iv + (SpongefishCurrentModeQueries.coordinate header.pending i.val)) := by + obtain ⟨header,sampled,bytes,pt,readHeader,encoded,pointEq,readValue,squeezed,source⟩ := + SpongefishCurrentCommitmentReceive.receive_anchor_source (Q := Q) c iv cur next shape r + accepted represented framed + refine ⟨header,pt,readHeader,pointEq,?_⟩ + have reset := header_consumed c cur header shape r.root readHeader + funext j + rw [AnchoredFiatShamirSecurityCodec.point_bytes] + have byte (i : Fin 24) : + ByteCodec.encodeE (pt j) i = + DuplexRefinement.evalCoordinate c iv + (SpongefishCurrentModeQueries.coordinate header.pending ((24*j.val+i.val)/32)) + ⟨(24*j.val+i.val)%32,Nat.mod_lt _ (by decide)⟩ := by + have within : 24*j.val+i.val < 24*shape.logN := by have := j.isLt; have := i.isLt; omega + have block : (24*j.val+i.val)/32 < blockCount shape.logN := by + have := block_capacity shape.logN + omega + have work := bounded header readHeader ⟨(24*j.val+i.val)/32,block⟩ + have actual := (source (24*j.val+i.val) within (by simpa [reset] using work)).2.2 + have div : (j.val*24+i.val)/24 = j.val := by have := i.isLt; omega + have mod : i.val%24 = i.val := Nat.mod_eq_of_lt i.isLt + simpa [encoded,SpongefishPCSRoundFrames.Codec.bytes,SpongefishPCSRoundFrames.vectorCodec, + SpongefishPCSRoundFrames.vectorEncode,reset,Nat.mul_comm,div,mod] using actual + have chunk : (fun i : Fin 24 => + DuplexRefinement.evalCoordinate c iv + (SpongefishCurrentModeQueries.coordinate header.pending ((24*j.val+i.val)/32)) + ⟨(24*j.val+i.val)%32,Nat.mod_lt _ (by decide)⟩) = + ByteCodec.encodeE (pt j) := funext (fun i => (byte i).symm) + rw [chunk] + exact (ByteCodec.decodeE_encodeE (pt j)).symm + +noncomputable local instance (P : Prop) : Decidable P := Classical.propDecidable P + +/-- Exact finite raw-table point law for consecutive full raw32 replies. The +generic joint equivalence also retains all residual bytes and outside keys. -/ +theorem current_joint_point_law {Q dimension : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) + (packet : AnchoredByteStreamCausal.Packet Q dimension iv (accept shape)) + (payoff : (Fin dimension → E) → ℚ) : + average (fun table : RawKey Q → Digest32 => + payoff (AnchoredFiatShamirSecurityCodec.point dimension (fun i => table (key packet.val i)))) = + average payoff := by + have law := RawOracleCoupling.average_equiv (rawParts packet.val) + (fun parts => payoff (AnchoredFiatShamirSecurityCodec.point dimension parts.1)) + have product := WHIRObservableSecurity.average_product + (fun parts : Blocks dimension × (Outside packet.val → Digest32) => + payoff (AnchoredFiatShamirSecurityCodec.point dimension parts.1)) + have reduced : average (fun parts : Blocks dimension × (Outside packet.val → Digest32) => + payoff (AnchoredFiatShamirSecurityCodec.point dimension parts.1)) = + average (fun blocks : Blocks dimension => payoff (AnchoredFiatShamirSecurityCodec.point dimension blocks)) := by + simpa only [average_const] using product + have vector := RawOracleCoupling.average_equiv (vectorParts dimension) + (fun answer => payoff answer.1) + have vectorProduct := WHIRObservableSecurity.average_product + (fun answer : Joint dimension => payoff answer.1) + have vectorReduced : average (fun answer : Joint dimension => payoff answer.1) = average payoff := by + simpa only [average_const] using vectorProduct + exact law.trans (reduced.trans (vector.trans vectorReduced)) + + +/-- Adaptive prequeries are covered by the same exact whole-run memo coupling, +not a freshness premise at the later native draw. Preparation uses the earliest +physical root snapshot even if that root was mentioned outside this packet. -/ +theorem current_aggregate_ambiguity {p : Profile} {Q n : Nat} {iv : Digest32} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (advertise : AnchoredMixedAttackerPrefix.History Q → Packet p Q iv shape → + Joint (config p).logN → E) + (source : Sampling (PublicCompressionCouplingMixed.Key Q) (fun _ => Digest32) R n) : + Soundness.uniformProb (Finset.univ.filter fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + AnchoredFiatShamirSecurity.Dirty + (AnchoredMixedAttackerPrefix.Grouped.execution (policy shape supported advertise) source table).1.2) ≤ + (n : ℚ)/2^124 := + AnchoredMixedAttackerPrefix.Grouped.prepared_raw_table_ambiguity (policy shape supported advertise) source + +/-- Exact adaptive distribution, including prequeries, complete public source +answers, immutable records and memoized full block vectors. Freshness belongs +at first contact with the vector, not at a subsequent native draw. -/ +theorem current_adaptive_distribution {p : Profile} {Q n : Nat} {iv : Digest32} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (advertise : AnchoredMixedAttackerPrefix.History Q → Packet p Q iv shape → + Joint (config p).logN → E) + (source : Sampling (PublicCompressionCouplingMixed.Key Q) (fun _ => Digest32) R n) + (payoff : (R × AnchoredMixedAttackerPrefix.Grouped.Records + (p := p) (Q := Q) (iv := iv) (accept := accept shape)) × + AnchoredMixedAttackerPrefix.Grouped.GroupCache + (p := p) (Q := Q) (iv := iv) (accept := accept shape) → ℚ) : + average (fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + payoff (AnchoredMixedAttackerPrefix.Grouped.execution (policy shape supported advertise) source table)) = + Sampling.expectation payoff (RawOracleCoupling.memo + (AnchoredMixedAttackerPrefix.Grouped.compile (policy shape supported advertise) source [] []) + (fun _ => none)) := + AnchoredMixedAttackerPrefix.Grouped.prepared_full_distribution (policy shape supported advertise) source payoff + + +/-- Entire actual source View, including failed callbacks and all full answers, +is unchanged by the mathematical observer. -/ +theorem current_source_view {p : Profile} {Q : Nat} {iv : Digest32} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (advertise : AnchoredMixedAttackerPrefix.History Q → Packet p Q iv shape → + Joint (config p).logN → E) + (C : PrimitiveOracle) (ro : RawKey Q → Digest32) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + (AnchoredMixedAttackerPrefix.Grouped.execution (policy shape supported advertise) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted) + (PublicCompressionCouplingMixed.oracle C ro)).1.1 = + (runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨C,[]⟩ program remaining cap counted).view := by + rw [AnchoredMixedAttackerPrefix.Grouped.execution_result,PublicCompressionCouplingMixed.compile_actual] + +/-- Physical source work, including rejected prefixes and repeated requests, +is charged by Counts; ideal raw lookup count is not substituted for it. -/ +theorem current_all_source_work {Q : Nat} {iv : Digest32} {R : Type} + (C : PrimitiveOracle) (ro : RawKey Q → Digest32) (program : Program R) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + let view := Sampling.eval (PublicCompressionCouplingMixed.oracle C ro) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted) + AnchoredMixedAttackerPrefix.constructionRequests view.observations ≤ + AnchoredMixedAttackerPrefix.constructionWork view.observations ∧ + AnchoredMixedAttackerPrefix.primitiveRequests view.observations + + AnchoredMixedAttackerPrefix.constructionWork view.observations ≤ remaining := by + dsimp only + rw [PublicCompressionCouplingMixed.compile_actual] + refine ⟨AnchoredMixedAttackerPrefix.constructionRequests_le_work _,?_⟩ + rw [AnchoredMixedAttackerPrefix.work_decomposition] + exact PublicCompressionCouplingMixed.runIdeal_viewCost Q C ro iv [] program remaining cap counted + + +theorem current_source_ambiguity {p : Profile} {Q : Nat} {iv : Digest32} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (advertise : AnchoredMixedAttackerPrefix.History Q → Packet p Q iv shape → + Joint (config p).logN → E) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + Soundness.uniformProb (Finset.univ.filter fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + AnchoredFiatShamirSecurity.Dirty (AnchoredMixedAttackerPrefix.Grouped.execution + (policy shape supported advertise) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted) table).1.2) ≤ + (remaining : ℚ)/2^124 := current_aggregate_ambiguity shape supported advertise _ + +/-- The literal mixed compile supplies its earliest-root prefix, not an +externally asserted first mention or root/table equality certificate. -/ +theorem current_source_capture {Q : Nat} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (ref : PCSBCSSourceRootReferences.Reference) (C : PrimitiveOracle) (ro : RawKey Q → Digest32) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) : + let compiled := PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted + SpongefishCurrentPhysicalRootCapture.publicCapture (B := Q) shape iv ref + (Sampling.eval (PublicCompressionCouplingMixed.oracle C ro) compiled) = + SpongefishCurrentPhysicalRootCapture.capture shape iv ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle C ro) compiled).2 := + SpongefishCurrentPhysicalRootCapture.publicCapture_source shape iv ref C ro program remaining cap counted + +/-- Rejected attacker-prefix work is charged by the actual all-source Counts. -/ +theorem initialized_prefix_ambiguity {p : Profile} {Q : Nat} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (parameter : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (calls : List SpongefishPCSRoundFrames.Call) (A : Nat) (attacker : Counts A prefixProgram) + (cap : A + SpongefishCurrentInitializedMode.budget tag instanceBytes calls ≤ Q) + (advertise : AnchoredMixedAttackerPrefix.History Q → Packet p Q parameter shape → + Joint (config p).logN → E) : + Soundness.uniformProb (Finset.univ.filter fun table : PublicCompressionCouplingMixed.Key Q → Digest32 => + AnchoredFiatShamirSecurity.Dirty (AnchoredMixedAttackerPrefix.Grouped.execution + (policy shape supported advertise) + (PublicCompressionCouplingMixed.compile Q parameter [] + (SpongefishCurrentInitializedMode.afterPrefix parameter tag instanceBytes prefixProgram calls) + (A+SpongefishCurrentInitializedMode.budget tag instanceBytes calls) cap + (SpongefishCurrentInitializedMode.afterPrefix_counted parameter tag instanceBytes prefixProgram calls A attacker)) + table).1.2) ≤ ((A+SpongefishCurrentInitializedMode.budget tag instanceBytes calls : Nat) : ℚ)/2^124 := + current_source_ambiguity shape supported advertise _ _ cap _ + +/-- Existing capped list math applies without a caller-supplied list. -/ +theorem candidate_list_bound {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (past : AnchoredMixedAttackerPrefix.History Q) (packet : Packet p Q iv shape) : + (InitialCandidates.witnesses (config p) (prepare shape supported past packet).lanes + (prepare shape supported past packet).root).card ≤ 2^32 := + InitialCandidates.production_witnesses_card p _ _ + +/-- The candidate is the fixed physical full-image/suffix extraction, with +the Profile's exact domain size; its list bound is not a shape certificate. -/ +theorem candidate_geometry {p : Profile} {Q : Nat} {iv : Digest32} + (shape : SpongefishSessionAdapter.Shape) (supported : Supported p shape) + (past : AnchoredMixedAttackerPrefix.History Q) (packet : Packet p Q iv shape) : + (prepare shape supported past packet).root.size = + 2^((config p).logN-(config p).folds[0]!+(config p).rates[0]!) ∧ + ∀ row ∈ (prepare shape supported past packet).root.toList, row.size = shape.lanes := by + have rectangular := freeze_shape + (SpongefishCurrentPhysicalRootCapture.ordinaryLog + ((SpongefishCurrentPhysicalRootCapture.firstPrefix shape iv + (SpongefishCurrentPhysicalRootCapture.reference shape (root shape packet)) (events past)).getD + (events past))) + (root shape packet) (SpongefishCurrentPhysicalRootCapture.physicalShape shape) + (SpongefishCurrentPhysicalRootCapture.occupied_guard shape supported.valid).2.1 + simpa only [prepare,candidate,SpongefishCurrentPhysicalRootCapture.physicalShape, + PCSBCSSourceRootReferences.initialShape,supported.dimension,supported.batch,supported.rate] using rectangular + + +/-- Source authenticity is derived from actual compile draws, including an +arbitrary independent raw table. Construction answers are never Merkle records. -/ +theorem current_captured_authentic {Q : Nat} {R : Type} + (shape : SpongefishSessionAdapter.Shape) (iv : Digest32) + (ref : PCSBCSSourceRootReferences.Reference) (C : PrimitiveOracle) (ro : RawKey Q → Digest32) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) + (frozen : Frozen) + (found : SpongefishCurrentPhysicalRootCapture.publicCapture (B := Q) shape iv ref + (Sampling.eval (PublicCompressionCouplingMixed.oracle C ro) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)) = some frozen) : + AuthenticLog C frozen.queryPrefix := by + rw [current_source_capture] at found + exact SpongefishCurrentPhysicalRootCapture.captured_source_authentic shape iv ref C ro _ frozen found + +/-- The cache/source collision guard is a consequence of the SAME complete +physical trace alarm. This generic observer lemma has no historical parser. -/ +theorem current_source_quiet {Q : Nat} {R : Type} (C : PrimitiveOracle) + (iv : Digest32) (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining program) (roots : PublicMerkleProbability.RootPolicy) + (quiet : PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv program remaining counted) = false) : + ¬ OutputCollision (PCSBCSMerkleSeedProjection.ordinaryObservations + (Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable Q C)) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)).observations) := + AnchoredMixedAttackerPrefixObserver.ordinary_quiet_of_alarm C iv program remaining cap counted roots quiet + +/-- Exact public/source capture equality above needs no collision charge. +For getter authentication the same physical alarm also covers fresh targets. +These are the existing monitor's explicit physical-boundary metadata: literal +prefix inclusion/saturation, root registration before answers, and evaluation +of opening plans. Establishing them for the native original accepted path is +not asserted by this interface. No frozen-root/table equality is an input. -/ +theorem current_getter_of_alarm {R : Type} + (C : PrimitiveOracle) (iv : Digest32) (program : Program R) + (remaining : Nat) (counted : Counts remaining program) + (roots : PublicMerkleProbability.RootPolicy) (grow : PublicMerkleProbability.RootsGrow roots) + (shape : SpongefishSessionAdapter.Shape) (valid : shape.Valid) (digest : Digest32) + (before after log : PublicLog) + (splitTrace : PublicCompressionProgram.primitiveLog C iv program remaining counted = before ++ after) + (included : ∀ e ∈ log, e ∈ before) + (saturated : ∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ log) + (registered : digest ∈ roots before.reverse) + (proof : MerkleTransport.PrunedMerklePaths) (queries : List Nat) + (output : List MerkleTransport.RawPath) + (accepted : proof.open (hash C) digest + (2^(SpongefishCurrentPhysicalRootCapture.physicalShape shape).height) queries shape.lanes + (SpongefishCurrentPhysicalRootCapture.physicalShape shape).leafWords = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (MerkleTransport.hashing (hash C)), + bytes.length < 2^56) + (plans : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (MerkleTransport.hashing (hash C)), + ∀ e ∈ PublicMerkleLog.plan C bytes, + e ∈ PublicCompressionProgram.primitiveLog C iv program remaining counted) + (quiet : PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv program remaining counted) = false) : + ∀ p ∈ output, ∃ row cell, + row.length = shape.lanes ∧ + p.leafData = MerkleBinding.leafImage 0 + (SpongefishCurrentPhysicalRootCapture.physicalShape shape).leafWords row ∧ + (freeze log digest (SpongefishCurrentPhysicalRootCapture.physicalShape shape)).cells[p.leafIndex]? = + some cell ∧ + cell.image = p.leafData.toArray ∧ cell.compact = row.toArray ∧ + cell.available = true ∧ cell.paddingValid = true := by + have auth := PublicCompressionProgram.primitiveLog_authentic C iv program remaining counted + have logAuth : AuthenticLog C log := by + intro n d member + apply auth n d + rw [splitTrace] + exact List.mem_append_left _ (included _ member) + rcases SpongefishCurrentPhysicalRootCapture.opened_getter_or_bad C log logAuth shape valid + digest proof queries output accepted (fun p hp bytes hb => by + have small := bounds p hp bytes hb + exact small.trans_le (by norm_num)) with good | bad + · exact good + · have alarm := PublicMerkleProbability.opening_alarm C roots grow _ auth + ⟨before,after,log,digest,output,splitTrace,included,saturated,registered,bounds,plans,bad⟩ + rw [quiet] at alarm + cases alarm + +/-- Getter authentication for the actual computed current first-root capture. +The freeze/table equality is proved from capture, never supplied by a caller. +Only the physical monitor's boundary/plan metadata remains explicit. -/ +theorem current_captured_getter {Q : Nat} {R : Type} + (C : PrimitiveOracle) (ro : RawKey Q → Digest32) (iv : Digest32) + (program : Program R) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining program) + (roots : PublicMerkleProbability.RootPolicy) (grow : PublicMerkleProbability.RootsGrow roots) + (shape : SpongefishSessionAdapter.Shape) (valid : shape.Valid) (digest : Digest32) + (frozen : Frozen) + (found : SpongefishCurrentPhysicalRootCapture.publicCapture (B := Q) shape iv + (SpongefishCurrentPhysicalRootCapture.reference shape digest) + (Sampling.eval (PublicCompressionCouplingMixed.oracle C ro) + (PublicCompressionCouplingMixed.compile Q iv [] program remaining cap counted)) = some frozen) + (before after : PublicLog) + (splitTrace : PublicCompressionProgram.primitiveLog C iv program remaining counted = before ++ after) + (included : ∀ e ∈ frozen.queryPrefix, e ∈ before) + (saturated : ∀ n d, (n,d) ∈ before → tag n = 0 → (n,d) ∈ frozen.queryPrefix) + (registered : digest ∈ roots before.reverse) + (proof : MerkleTransport.PrunedMerklePaths) (queries : List Nat) + (output : List MerkleTransport.RawPath) + (accepted : proof.open (hash C) digest + (2^(SpongefishCurrentPhysicalRootCapture.physicalShape shape).height) queries shape.lanes + (SpongefishCurrentPhysicalRootCapture.physicalShape shape).leafWords = some output) + (bounds : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (MerkleTransport.hashing (hash C)), + bytes.length < 2^56) + (plans : ∀ p ∈ output, ∀ bytes ∈ p.opening.inputs (MerkleTransport.hashing (hash C)), + ∀ e ∈ PublicMerkleLog.plan C bytes, + e ∈ PublicCompressionProgram.primitiveLog C iv program remaining counted) + (quiet : PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv program remaining counted) = false) : + ∀ p ∈ output, ∃ row cell, + row.length = shape.lanes ∧ + p.leafData = MerkleBinding.leafImage 0 + (SpongefishCurrentPhysicalRootCapture.physicalShape shape).leafWords row ∧ + frozen.cells[p.leafIndex]? = some cell ∧ + cell.image = p.leafData.toArray ∧ cell.compact = row.toArray ∧ + cell.available = true ∧ cell.paddingValid = true := by + rw [current_source_capture] at found + obtain ⟨prior,event,later,_,_,_,literal,_,_⟩ := + SpongefishCurrentPhysicalRootCapture.capture_provenance shape iv _ _ frozen found + have fixed : frozen = freeze frozen.queryPrefix digest + (SpongefishCurrentPhysicalRootCapture.physicalShape shape) := by + rw [literal] + rfl + have good := current_getter_of_alarm C iv program remaining counted roots grow shape valid digest + before after frozen.queryPrefix splitTrace included saturated registered proof queries output + accepted bounds plans quiet + intro p member + obtain ⟨row,cell,width,image,lookup,full,compact,available,padding⟩ := good p member + refine ⟨row,cell,width,image,?_,full,compact,available,padding⟩ + rw [fixed] + exact lookup + + +#print axioms packet_key_member +#print axioms candidate_before_every_reply +#print axioms candidate_strict +#print axioms repeated_physical_reference +#print axioms receive_point_coordinates +#print axioms current_joint_point_law +#print axioms current_aggregate_ambiguity +#print axioms current_source_view +#print axioms current_source_ambiguity +#print axioms current_source_capture +#print axioms initialized_prefix_ambiguity +#print axioms candidate_list_bound +#print axioms current_captured_authentic +#print axioms current_source_quiet +#print axioms current_getter_of_alarm +#print axioms current_captured_getter +#print axioms current_adaptive_distribution +#print axioms current_all_source_work +#print axioms candidate_geometry + +end Whir.SpongefishCurrentAnchorAttackerPrefix diff --git a/verification/whir/Whir/SpongefishCurrentByteTransport.lean b/verification/whir/Whir/SpongefishCurrentByteTransport.lean new file mode 100644 index 000000000..eefca065f --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentByteTransport.lean @@ -0,0 +1,104 @@ +import Whir.SpongefishCurrentSourceCallerOriginal + +/-! The current replay retains exactly its consumed prover bytes. This proves +source transport from the literal codec reads rather than asking the caller to +supply equality between a decoded query history and the original proof. -/ +namespace Whir.SpongefishCurrentByteTransport +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentMixedModeCompiler +set_option autoImplicit false + + def resultData : Result → Data + | .ok cur => cur.data + | .error (cur,_) => cur.data + + def Conserves (whole : List Byte) (data : Data) : Prop := + retainedBytes data.pending ++ data.narg = whole + + theorem read_conserves (whole : List Byte) (cur : SemanticCursor) (kind : WireKind) + (value : kind.Value) (rest : List Byte) (before : Conserves whole cur.data) + (parsed : kind.codec.parse cur.data.narg = some (value,rest)) : + Conserves whole (readNext cur kind value rest).data := by + have bytes := Codec.canonical_read kind.codec cur.data.narg rest value parsed + simp only [Conserves,readNext,boundData,bind_retains] + rw [List.append_assoc,← bytes] + exact before + + theorem hint_conserves (whole : List Byte) (cur : SemanticCursor) + (bytes : List Byte) (rest : List (List Byte)) (before : Conserves whole cur.data) : + Conserves whole (hintNext cur bytes rest).data := before + + theorem drawn_conserves (whole : List Byte) (cur : SemanticCursor) (n : Nat) + (guard : cur.data.pending.consumed+n ≤ maxCursor) (cache : Cache) (bytes : List Byte) + (before : Conserves whole cur.data) : Conserves whole (drawn cur n guard cache bytes).data := by + simpa only [Conserves,drawn,draw_retains] using before + + theorem replay_conserves (C : PrimitiveOracle) (iv : Digest32) (whole : List Byte) + (cur : SemanticCursor) (calls : List Call) (before : Conserves whole cur.data) : + Conserves whole (resultData (runReal C iv (replayProgram cur calls)).view.result) := by + induction calls generalizing cur with + | nil => exact before + | cons call calls ih => + cases call with + | read kind => + cases parsed : kind.codec.parse cur.data.narg with + | none => simpa only [replayProgram,parsed,runReal,resultData] using before + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [replayProgram,parsed] + exact ih _ (read_conserves whole cur kind value rest before parsed) + | hint => + cases hintEq : cur.data.hints with + | nil => simpa only [replayProgram,hintEq,runReal,resultData] using before + | cons bytes rest => + simp only [replayProgram,hintEq] + exact ih _ (hint_conserves whole cur bytes rest before) + | draw group => + by_cases zero : group.bytes = 0 + · simp only [replayProgram,zero,↓reduceDIte] + exact ih _ before + · by_cases guard : cur.data.pending.consumed+group.bytes ≤ maxCursor + · simp only [replayProgram,zero,↓reduceDIte,guard,seq, + WHIRModeFinal.bind_real_result] + exact ih _ (drawn_conserves whole cur group.bytes guard _ _ before) + · simpa only [replayProgram,zero,↓reduceDIte,guard,runReal,resultData] using before + + theorem initial_conserves (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : + Conserves (instanceBytes ++ narg) + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints).data := by + change retainedBytes (SpongefishPCSRoundFrames.bind {domain := session} instanceBytes) ++ narg = + instanceBytes ++ narg + rw [bind_retains] + rfl + + theorem coordinate_bytes (m : Pending) (block : Nat) : + SpongefishCurrentSourceCallerOriginal.historyBytes + (SpongefishCurrentModeQueries.coordinate m block) = retainedBytes m := by + simp only [SpongefishCurrentSourceCallerOriginal.historyBytes, + SpongefishCurrentModeQueries.coordinate, + ← SpongefishCurrentAbsorbedPrefix.pending_history, + SpongefishCurrentAbsorbedPrefix.parse_history,Option.map_some,Option.getD_some, + SpongefishCurrentAbsorbedPrefix.complete_prover_bytes] + + theorem initialized_consumed_transport (C : PrimitiveOracle) (iv session : Digest32) + (instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) + (block : Nat) + (consumed : (resultData (runReal C iv (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) calls)).view.result).narg = []) : + let data := resultData (runReal C iv (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) calls)).view.result + (SpongefishCurrentSourceCallerOriginal.historyBytes + (SpongefishCurrentModeQueries.coordinate data.pending block)).drop instanceBytes.length = narg := by + dsimp only + rw [coordinate_bytes] + have saved := replay_conserves C iv (instanceBytes ++ narg) + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) calls + (initial_conserves session instanceBytes narg hints) + simp only [Conserves,consumed,List.append_nil] at saved + rw [saved] + simp + +#print axioms replay_conserves +#print axioms initialized_consumed_transport +end Whir.SpongefishCurrentByteTransport diff --git a/verification/whir/Whir/SpongefishCurrentCallerGetter.lean b/verification/whir/Whir/SpongefishCurrentCallerGetter.lean new file mode 100644 index 000000000..f6e2b5bb0 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentCallerGetter.lean @@ -0,0 +1,157 @@ +import Whir.SpongefishCurrentInitializedMode +import Whir.SpongefishCurrentCommitmentReceive + +/-! Current public-answer transport. Only literal construction observations are +used; missing or over-budget answers reject, and all 32 reply bytes are retained. +This interpreter is deterministic and does not run an oracle or Mixed.compile. -/ +namespace Whir.SpongefishCurrentCallerGetter +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +set_option autoImplicit false + + def lookup (q : Coordinate) : List Observation → Option Digest32 + | [] => none + | o :: os => match o.query with + | .construction other _ => if other = q then some o.answer else lookup q os + | .primitive _ _ => lookup q os + + def bounded {Q : Nat} (observations : List Observation) (q : Coordinate) : Option Digest32 := + if pathCost q ≤ Q then lookup q observations else none + + def raw {Q : Nat} (iv : Digest32) (observations : List Observation) + (key : RawKey Q) : Option Digest32 := do + let q ← WHIRHeaderRoots.decodeRaw iv key + bounded (Q := Q) observations q + + theorem raw_construction {Q : Nat} (iv : Digest32) (observations : List Observation) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (work : pathCost q ≤ Q) : + raw iv observations (constructionKey Q iv q work) = lookup q observations := by + simp [raw,WHIRHeaderRoots.decodeRaw_construction iv q valid work,bounded,work] + + def answer {Q : Nat} (observations : List Observation) : Query → Option Digest32 + | .construction q _ => bounded (Q := Q) observations q + | .primitive _ _ => none + + def run {A : Type} (get : Query → Option Digest32) : Program A → Option A + | .done a => some a + | .ask q next => (get q).bind (fun d => run get (next d)) + +/-- Unlike runReal, this interpreter accepts an arbitrary getter. Close any +computed reply before the adaptive continuation can retain or reuse it. -/ +private def runStored {A : Type} (get : Query → Option Digest32) : + Program A → Option A + | .done a => some a + | .ask q next => (get q).bind (fun d => + withDigest d (fun stored => runStored get (next stored))) + +@[csimp] private theorem run_stored : @run = @runStored := by + funext A get p + induction p with + | done => rfl + | ask q next ih => + simp only [run,runStored,withDigest_eq,ih] + + theorem run_congr {A : Type} (p : Program A) (a b : Query → Option Digest32) + (equal : a = b) : run a p = run b p := by rw [equal] + + theorem run_real {A : Type} (C : PrimitiveOracle) (iv : Digest32) (p : Program A) + (get : Query → Option Digest32) + (observed : ∀ o ∈ (runReal C iv p).view.observations, + get o.query = some o.answer) : + run get p = some (runReal C iv p).view.result := by + induction p with + | done a => rfl + | ask query next ih => + have first := observed ⟨query,realAnswer C iv query⟩ (by simp [runReal,prepend]) + have tail := ih (realAnswer C iv query) (fun o h => observed o (by + simp only [runReal,prepend]; exact List.mem_cons_of_mem _ h)) + simp only [run,first,Option.bind_some,tail,runReal,prepend] + + theorem lookup_real (C : PrimitiveOracle) (iv : Digest32) (observations : List Observation) + (consistent : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (present : ∃ o ∈ observations, o.query = .construction q valid) : + lookup q observations = some (evalCoordinate (compressionOf C) iv q) := by + induction observations with + | nil => simp at present + | cons o os ih => + have head := consistent o List.mem_cons_self + have tail := ih (fun x h => consistent x (List.mem_cons_of_mem _ h)) + cases query : o.query with + | primitive purpose input => + simp only [lookup,query] + apply tail + obtain ⟨x,h,e⟩ := present + rcases List.mem_cons.mp h with rfl | h + · rw [query] at e; cases e + · exact ⟨x,h,e⟩ + | construction other proof => + simp only [lookup,query] + split + · rename_i equal + subst other + simpa [query,realAnswer] using congrArg some head + · rename_i different + apply tail + obtain ⟨x,h,e⟩ := present + rcases List.mem_cons.mp h with rfl | h + · rw [query] at e + cases e + exact False.elim (different rfl) + · exact ⟨x,h,e⟩ + + theorem bounded_real {Q : Nat} (C : PrimitiveOracle) (iv : Digest32) + (observations : List Observation) + (consistent : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (work : pathCost q ≤ Q) + (present : ∃ o ∈ observations, o.query = .construction q valid) : + bounded (Q := Q) observations q = some (evalCoordinate (compressionOf C) iv q) := by + simp only [bounded,work,↓reduceIte] + exact lookup_real C iv observations consistent q valid present + + theorem real_consistent {A : Type} (C : PrimitiveOracle) (iv : Digest32) (p : Program A) : + ∀ o ∈ (runReal C iv p).view.observations, o.answer = realAnswer C iv o.query := by + induction p with + | done a => simp [runReal] + | ask q next ih => + intro o h + rcases List.mem_cons.mp h with rfl | h + · rfl + · exact ih (realAnswer C iv q) o h + +/-- The actual byte cursor fixes both the block floor and byte remainder. No +sampled coordinate or independent E192 answer is supplied to this theorem. -/ + theorem squeezed_raw_byte {Q : Nat} (C : PrimitiveOracle) (iv : Digest32) + (m : SpongefishPCSRoundFrames.Pending) (s t : State) + (represented : SpongefishPCSRoundFrames.RepresentsCurrent (compressionOf C) iv m s) + (framed : SpongefishCurrentModeQueries.FrameDomain m) + (n : Nat) (positive : n ≠ 0) (bytes : List Byte) + (squeezed : squeeze (compressionOf C) s n = .ok (t,bytes)) (j : Nat) (within : j < n) + (work : pathCost (SpongefishCurrentModeQueries.coordinate m ((m.consumed+j)/32)) ≤ Q) + (observations : List Observation) + (consistent : ∀ o ∈ observations, o.answer = realAnswer C iv o.query) + (present : ∃ o ∈ observations, ∃ valid, + o.query = .construction (SpongefishCurrentModeQueries.coordinate m ((m.consumed+j)/32)) valid) : + (raw iv observations (constructionKey Q iv + (SpongefishCurrentModeQueries.coordinate m ((m.consumed+j)/32)) work)).map + (fun digest => digest ⟨(m.consumed+j)%32,Nat.mod_lt _ (by decide)⟩) = + some (bytes[j]'(by + obtain ⟨_,len⟩ := squeeze_exact_cursor (compressionOf C) s t n bytes squeezed + omega)) := by + have valid := SpongefishCurrentModeQueries.squeezed_coordinate_admissible + (compressionOf C) iv m s t represented framed n positive bytes squeezed j within + obtain ⟨o,member,proof,equal⟩ := present + rw [raw_construction iv observations _ valid work, + lookup_real C iv observations consistent _ valid ⟨o,member,equal⟩] + simp only [Option.map_some] + rw [SpongefishCurrentModeQueries.squeezed_byte + (compressionOf C) iv m s t represented n positive bytes squeezed j within] + +#print axioms run_stored + +#print axioms raw_construction +#print axioms run_real +#print axioms lookup_real +#print axioms bounded_real +#print axioms real_consistent +#print axioms squeezed_raw_byte +end Whir.SpongefishCurrentCallerGetter diff --git a/verification/whir/Whir/SpongefishCurrentCallerGetterCoverage.lean b/verification/whir/Whir/SpongefishCurrentCallerGetterCoverage.lean new file mode 100644 index 000000000..58db6dc92 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentCallerGetterCoverage.lean @@ -0,0 +1,440 @@ +import Whir.SpongefishCurrentReplayProvenance +import Whir.SpongefishCurrentSourceCallerOriginal +import Whir.PCSBCSMixedConstructionTrace + +/-! Actual current replay provenance and public-answer completeness. Compiler +cache entries and returned bytes have literal earlier construction observations, +including rejected prefixes. Counts bounds the keys of this execution, not the +unobserved keys of other raw-record candidates. No oracle is consulted by the +public parser. `SpongefishCurrentAcceptedJoin` derives the parser's call order, +domain and byte transport from accepted receive and binding; native equation +acceptance remains a separate source interface. -/ +namespace Whir.SpongefishCurrentCallerGetterCoverage +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentModeQueries +open SpongefishCurrentMixedModeCompiler SpongefishCurrentReplayProvenance +set_option autoImplicit false +set_option maxRecDepth 10000 + +/-- A cached full digest is backed by a literal construction observation in the +already completed chronological prefix, not by a coordinate-only certificate. -/ +def Recorded (cache : Cache) (past : List Observation) : Prop := + ∀ q d, cache q = some d → ∃ valid, (⟨.construction q valid,d⟩ : Observation) ∈ past + +def ConstructionTrace (os : List Observation) : Prop := + ∀ o ∈ os, ∃ q valid, o.query = .construction q valid + +def ByteRecorded (m : Pending) (past : List Observation) (p : Nat) (b : Byte) : Prop := + ∃ d valid, (⟨.construction (coordinate m (p/32)) valid,d⟩ : Observation) ∈ past ∧ + b = d ⟨p%32,Nat.mod_lt _ (by decide)⟩ + +def resultCache : Result → Cache + | .ok cur => cur.cache + | .error (cur,_) => cur.cache + +theorem empty_recorded (past : List Observation) : Recorded (fun _ => none) past := by + intro q d hit + cases hit + +theorem recorded_mono {cache : Cache} {a b : List Observation} + (recorded : Recorded cache a) (included : ∀ o ∈ a, o ∈ b) : Recorded cache b := by + intro q d hit + obtain ⟨valid,member⟩ := recorded q d hit + exact ⟨valid,included _ member⟩ + +theorem store_recorded (cache : Cache) (past : List Observation) (recorded : Recorded cache past) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (d : Digest32) : + Recorded (store cache q d) (past ++ [⟨.construction q valid,d⟩]) := by + intro other value hit + unfold store at hit + split at hit + · rename_i equal + subst other + cases Option.some.inj hit + exact ⟨valid,List.mem_append_right _ (by simp)⟩ + · obtain ⟨proof,member⟩ := recorded other value hit + exact ⟨proof,List.mem_append_left _ member⟩ + +theorem request_recorded (cache : Cache) (past : List Observation) + (recorded : Recorded cache past) (q : Coordinate) (valid : DuplexEncoding.Admissible q) + {os : List Observation} {result : Cache × Digest32} + (ran : Runs (request cache q valid) os result) : + Recorded result.1 (past ++ os) ∧ + (∃ proof, (⟨.construction q proof,result.2⟩ : Observation) ∈ past ++ os) ∧ + ConstructionTrace os := by + cases hit : cache q with + | some d => + simp only [request,hit] at ran + cases ran + exact ⟨by simpa using recorded,by simpa using recorded q d hit,by simp [ConstructionTrace]⟩ + | none => + simp only [request,hit] at ran + cases ran with + | ask _ _ d tail => + cases tail + exact ⟨store_recorded cache past recorded q valid d, + ⟨valid,List.mem_append_right _ (by simp)⟩,by + intro o member + simp only [List.mem_singleton] at member + subst o + exact ⟨q,valid,rfl⟩⟩ + +/-- A hit emits no new query; every byte comes from the earlier literal full +answer. This statement also applies to ideal independent-oracle executions. -/ +theorem request_hit (cache : Cache) (past : List Observation) (recorded : Recorded cache past) + (q : Coordinate) (valid : DuplexEncoding.Admissible q) (d : Digest32) + (hit : cache q = some d) : + request cache q valid = .done (cache,d) ∧ + ∃ proof, (⟨.construction q proof,d⟩ : Observation) ∈ past := by + exact ⟨by simp [request,hit],recorded q d hit⟩ + +theorem collect_recorded (m : Pending) (positions : List Nat) + (valid : ∀ p ∈ positions, DuplexEncoding.Admissible (coordinate m (p/32))) + (cache : Cache) (past : List Observation) (recorded : Recorded cache past) + {os : List Observation} {result : Cache × List Byte} + (ran : Runs (collect m positions valid cache) os result) : + Recorded result.1 (past ++ os) ∧ + List.Forall₂ (ByteRecorded m (past ++ os)) positions result.2 ∧ ConstructionTrace os := by + induction positions generalizing cache past os result with + | nil => + cases ran + exact ⟨by simpa using recorded,.nil,by simp [ConstructionTrace]⟩ + | cons p ps ih => + obtain ⟨first,before,after,trace,requested,rest⟩ := bind_runs _ _ ran + obtain ⟨last,tail,empty,afterEq,collected,done⟩ := bind_runs _ _ rest + cases done + simp only [List.append_nil] at afterEq + subst after + obtain ⟨firstRecorded,firstAnswer,firstTrace⟩ := request_recorded cache past recorded + (coordinate m (p/32)) (valid p List.mem_cons_self) requested + obtain ⟨lastRecorded,bytesRecorded,tailTrace⟩ := ih _ first.1 (past ++ before) + firstRecorded collected + subst os + refine ⟨by simpa only [List.append_assoc] using lastRecorded,?_,?_⟩ + · obtain ⟨proof,member⟩ := firstAnswer + apply List.Forall₂.cons + · refine ⟨first.2,proof,?_,rfl⟩ + simpa only [List.append_assoc] using List.mem_append_left tail member + · simpa only [List.append_assoc] using bytesRecorded + · intro o member + rcases List.mem_append.mp member with member | member + · exact firstTrace o member + · exact tailTrace o member + +theorem replay_recorded (cur : SemanticCursor) (calls : List Call) + (past : List Observation) (recorded : Recorded cur.cache past) + {os : List Observation} {result : Result} (ran : Runs (replayProgram cur calls) os result) : + Recorded (resultCache result) (past ++ os) ∧ ConstructionTrace os := by + induction calls generalizing cur past os result with + | nil => + cases ran + exact ⟨by simpa [resultCache] using recorded,by simp [ConstructionTrace]⟩ + | cons call calls ih => + cases call with + | read kind => + simp only [replayProgram] at ran + cases parsed : kind.codec.parse cur.data.narg with + | none => + simp only [parsed] at ran + cases ran + exact ⟨by simpa [resultCache] using recorded,by simp [ConstructionTrace]⟩ + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [parsed] at ran + exact ih (readNext cur kind value rest) past recorded ran + | hint => + simp only [replayProgram] at ran + cases hints : cur.data.hints with + | nil => + simp only [hints] at ran + cases ran + exact ⟨by simpa [resultCache] using recorded,by simp [ConstructionTrace]⟩ + | cons bytes rest => + simp only [hints] at ran + exact ih (hintNext cur bytes rest) past recorded ran + | draw g => + simp only [replayProgram] at ran + split at ran + · exact ih {cur with data := {cur.data with events := cur.data.events ++ [.verifier []]}} + past recorded ran + · split at ran + · obtain ⟨pair,before,after,trace,collected,rest⟩ := bind_runs _ _ ran + have first := collect_recorded _ _ _ _ past recorded collected + have last := ih _ (past ++ before) first.1 rest + subst os + refine ⟨by simpa only [List.append_assoc] using last.1,?_⟩ + intro o member + rcases List.mem_append.mp member with member | member + · exact first.2.2 o member + · exact last.2 o member + · cases ran + exact ⟨by simpa [resultCache] using recorded,by simp [ConstructionTrace]⟩ + +/-- Empty initial cache and the actual rejecting/succeeding replay discharge +all cache and query-provenance premises internally. -/ +theorem initialized_recorded (C : PrimitiveOracle) (iv session : Digest32) + (instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + let p := replayProgram (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) calls + Recorded (resultCache (runReal C iv p).view.result) (runReal C iv p).view.observations ∧ + ConstructionTrace (runReal C iv p).view.observations := by + simpa only [List.nil_append] using replay_recorded _ calls [] (empty_recorded []) + (real_runs C iv _) + +/-- Public replay also retains an actual rejected prefix; no success or raw +record candidate is required for completeness of this true tape. -/ +theorem replay_getter_complete (C : PrimitiveOracle) (iv session : Digest32) + (instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + let p := replayProgram (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) calls + let Q := resource (instanceBytes.length+3) calls + SpongefishCurrentCallerGetter.run + (SpongefishCurrentCallerGetter.answer (Q := Q) (runReal C iv p).view.observations) p = + some (runReal C iv p).view.result := by + apply SpongefishCurrentCallerGetter.run_real + exact actual_getter C iv _ _ _ (replay_counted _ calls _ (by simp)) + (fun _ h => h) (initialized_recorded C iv session instanceBytes narg hints calls).2 + +/-- The actual replay suffix is present after the arbitrary attacker prefix and +ordinary constructor queries, before the erased-result return. -/ +theorem afterPrefix_replay_included (C : PrimitiveOracle) (iv : Digest32) + (tag instanceBytes : List Byte) (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (calls : List Call) (nonempty : instanceBytes ≠ []) : + let input := (runReal C iv prefixProgram).view.result + let part := replayProgram (SpongefishCurrentInitializedMode.initial + (SpongefishSessionAdapter.derive (compressionOf C) iv tag) instanceBytes input.narg input.hints) calls + ∀ o ∈ (runReal C iv part).view.observations, + o ∈ (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls)).view.observations := by + dsimp only + intro o member + rw [SpongefishCurrentInitializedMode.afterPrefix,bind_real_observations] + apply List.mem_append_right + rw [SpongefishCurrentInitializedMode.program,bind_real_observations, + SpongefishCurrentObservedSessionEntry.setupProgram_nonempty C iv iv tag instanceBytes _ _ nonempty] + apply List.mem_append_right + simp only [SpongefishCurrentInitializedMode.constructor_domain,bind_real_observations, + runReal,List.append_nil] + exact member + +/-- Aggregate Q is derived from the attacker certificate plus the initialized +resource function. No initial-cache, per-key cap or getter premise is supplied. -/ +theorem afterPrefix_getter (C : PrimitiveOracle) (iv : Digest32) + (tag instanceBytes : List Byte) (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (calls : List Call) (A : Nat) (attacker : Counts A prefixProgram) (nonempty : instanceBytes ≠ []) : + let input := (runReal C iv prefixProgram).view.result + let part := replayProgram (SpongefishCurrentInitializedMode.initial + (SpongefishSessionAdapter.derive (compressionOf C) iv tag) instanceBytes input.narg input.hints) calls + let whole := SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes calls + ∀ o ∈ (runReal C iv part).view.observations, + SpongefishCurrentCallerGetter.answer (Q := Q) (runReal C iv whole).view.observations o.query = + some o.answer := by + apply actual_getter C iv _ _ _ + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram calls A attacker) + (afterPrefix_replay_included C iv tag instanceBytes prefixProgram calls nonempty) + exact (initialized_recorded C iv _ instanceBytes _ _ calls).2 +/-- Full public-view replay completeness, including exact reached error data. +The actual physical cursor is constructed, not accepted as a saved context. -/ +theorem afterPrefix_replay_complete (C : PrimitiveOracle) (iv : Digest32) + (tag instanceBytes : List Byte) (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (calls : List Call) (A : Nat) (attacker : Counts A prefixProgram) (nonempty : instanceBytes ≠ []) : + let input := (runReal C iv prefixProgram).view.result + let session := SpongefishSessionAdapter.derive (compressionOf C) iv tag + let initial := SpongefishCurrentInitializedMode.initial session instanceBytes input.narg input.hints + let whole := SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes calls + (SpongefishCurrentCallerGetter.run + (SpongefishCurrentCallerGetter.answer (Q := Q) (runReal C iv whole).view.observations) + (replayProgram initial calls)).map eraseResult = + some (forgetResult (SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) + (SpongefishCurrentObservedSessionEntry.cursor session instanceBytes input.narg input.hints + (absorb (compressionOf C) (SpongefishSessionAdapter.init (compressionOf C) iv session) instanceBytes)) calls)) := by + dsimp only + rw [SpongefishCurrentCallerGetter.run_real C iv _ _ + (afterPrefix_getter C iv tag instanceBytes prefixProgram calls A attacker nonempty), + Option.map_some] + exact congrArg some (replay_real C iv _ _ rfl + (session_bridge (compressionOf C) iv _ instanceBytes) + (by intro q d found; cases found) calls) + + +/-- Internally obtained provenance of *all* cached digests at the actual reached +cursor (including errors), with their aggregate bounded raw keys and literal +public getter equality. Replayed bytes need no fresh oracle query. -/ +theorem afterPrefix_cached_getter (C : PrimitiveOracle) (iv : Digest32) + (tag instanceBytes : List Byte) (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (calls : List Call) (A : Nat) (attacker : Counts A prefixProgram) (nonempty : instanceBytes ≠ []) : + let input := (runReal C iv prefixProgram).view.result + let part := replayProgram (SpongefishCurrentInitializedMode.initial + (SpongefishSessionAdapter.derive (compressionOf C) iv tag) instanceBytes input.narg input.hints) calls + let whole := SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes calls + ∀ q d, resultCache (runReal C iv part).view.result q = some d → + ∃ valid, ∃ work : pathCost q ≤ Q, + (⟨.construction q valid,d⟩ : Observation) ∈ (runReal C iv whole).view.observations ∧ + SpongefishCurrentCallerGetter.raw iv (runReal C iv whole).view.observations + (constructionKey Q iv q work) = some d := by + dsimp only + intro q d hit + obtain ⟨valid,member⟩ := (initialized_recorded C iv _ instanceBytes _ _ calls).1 q d hit + have present := afterPrefix_replay_included C iv tag instanceBytes prefixProgram calls nonempty _ member + have cap := observation_cap (real_runs C iv _) _ + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram calls A attacker) + _ present + refine ⟨valid,cap,present,?_⟩ + rw [SpongefishCurrentCallerGetter.raw_construction iv _ q valid cap] + have consistent := SpongefishCurrentCallerGetter.real_consistent C iv + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls) + rw [SpongefishCurrentCallerGetter.lookup_real C iv _ consistent q valid ⟨_,present,rfl⟩] + exact congrArg some (consistent _ present).symm + +/-- Extract only the actual replay branch from the source operational execution. +Constructor rejection has no branch; replay errors do, and retain their tape. -/ +theorem afterPrefix_replay_subrun (iv : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (tape : List Call) + {os : List Observation} {data : SpongefishCurrentInitializedMode.Result} + (ran : Runs (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape) + os (some data)) : + ∃ input : SpongefishCurrentInitializedMode.Input, ∃ session result reached, + eraseResult result = data ∧ + Runs (replayProgram (SpongefishCurrentInitializedMode.initial + session instanceBytes input.narg input.hints) tape) reached result ∧ + (∀ o ∈ reached, o ∈ os) := by + obtain ⟨input,attacker,verifier,trace,_,entry⟩ := bind_runs _ _ ran + obtain ⟨setup,ordinary,replay,entryTrace,_,rest⟩ := bind_runs _ _ entry + cases setup with + | none => cases rest + | some actual => + obtain ⟨result,reached,empty,replayTrace,replayed,done⟩ := bind_runs _ _ rest + cases done + simp only [List.append_nil] at replayTrace + subst replay + refine ⟨input,actual.pending.domain,result,reached,rfl,replayed,?_⟩ + intro o member + rw [trace,entryTrace] + exact List.mem_append_right _ (List.mem_append_right _ member) + +/-- Cache provenance for the actual initialized operational source, including +the .error byte result. No externally supplied cache invariant is needed. -/ +theorem afterPrefix_runs_recorded (iv : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (tape : List Call) + {os : List Observation} {data : SpongefishCurrentInitializedMode.Result} + (ran : Runs (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape) + os (some data)) : + ∃ result : Result, eraseResult result = data ∧ Recorded (resultCache result) os := by + obtain ⟨input,session,result,reached,erased,replayed,included⟩ := + afterPrefix_replay_subrun iv tag instanceBytes prefixProgram tape ran + have recorded := (replay_recorded _ tape [] (empty_recorded []) replayed).1 + exact ⟨result,erased,recorded_mono (by simpa using recorded) included⟩ + +/-- Actual unchanged Mixed.compile lowering: every cached full digest is backed +both by a public construction observation and its raw draw in the atomic query +trace, with the independent RO answer at the internally bounded key. -/ +theorem lowered_cached_provenance (iv : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (tape : List Call) + (A : Nat) (attacker : Counts A prefixProgram) + (seed : DuplexPublicSimulator.Seed) + (ro : RawKey (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape) → Digest32) + (log : DuplexPublicSimulator.PublicLog) (data : SpongefishCurrentInitializedMode.Result) + (reached : + (runIdeal (DuplexPublicSimulator.simulator (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape)) + ro iv ⟨seed,log⟩ (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape) + _ (Nat.le_refl _) (SpongefishCurrentInitializedMode.afterPrefix_counted + iv tag instanceBytes prefixProgram tape A attacker)).view.result = some data) : + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape + let source := SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape + let counted := SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram tape A attacker + let execution := runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨seed,log⟩ source Q (Nat.le_refl Q) counted + ∃ result : Result, eraseResult result = data ∧ + ∀ q d, resultCache result q = some d → + ∃ valid, ∃ work : pathCost q ≤ Q, + (⟨.construction q valid,d⟩ : Observation) ∈ execution.view.observations ∧ + d = ro (constructionKey Q iv q work) ∧ + SpongefishCurrentCallerGetter.raw iv execution.view.observations + (constructionKey Q iv q work) = some d ∧ + (⟨.inr (constructionKey Q iv q work),d⟩ : + Sigma (fun _ : PublicCompressionCouplingMixed.Key Q => Digest32)) ∈ + (TypedOracleCompiler.Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) + (PublicCompressionCouplingMixed.compile Q iv log source Q (Nat.le_refl Q) counted)).2 := by + dsimp only + have ran := ideal_runs + (DuplexPublicSimulator.simulator (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape)) + ro iv ⟨seed,log⟩ (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape) + _ (Nat.le_refl _) (SpongefishCurrentInitializedMode.afterPrefix_counted + iv tag instanceBytes prefixProgram tape A attacker) + rw [reached] at ran + obtain ⟨result,erased,recorded⟩ := afterPrefix_runs_recorded iv tag instanceBytes prefixProgram tape ran + refine ⟨result,erased,?_⟩ + intro q d hit + obtain ⟨valid,member⟩ := recorded q d hit + obtain ⟨work,answer,getter⟩ := ideal_observed_getter + (DuplexPublicSimulator.simulator (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape)) + ro iv ⟨seed,log⟩ _ _ (Nat.le_refl _) _ q valid d member + obtain ⟨bound,allocated⟩ := PCSBCSMixedConstructionTrace.ideal_recorded seed ro iv log _ _ + (Nat.le_refl _) _ q valid d member + exact ⟨valid,work,member,answer,getter,allocated⟩ + +/-- Completeness for the actual ideal source replay, not a fictitious decoded +tape. `some data` includes every replay rejection; it only excludes constructor +rejection, when no replay branch exists. Source observations alone determine +every getter answer, with no independent oracle fallback. -/ +theorem afterPrefix_ideal_replay_complete (iv : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (tape : List Call) + (A : Nat) (attacker : Counts A prefixProgram) + (seed : DuplexPublicSimulator.Seed) + (ro : RawKey (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape) → Digest32) + (log : DuplexPublicSimulator.PublicLog) (data : SpongefishCurrentInitializedMode.Result) + (reached : + (runIdeal (DuplexPublicSimulator.simulator (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape)) + ro iv ⟨seed,log⟩ (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape) + _ (Nat.le_refl _) (SpongefishCurrentInitializedMode.afterPrefix_counted + iv tag instanceBytes prefixProgram tape A attacker)).view.result = some data) : + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape + let source := SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape + let counted := SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram tape A attacker + let execution := runIdeal (DuplexPublicSimulator.simulator Q) ro iv ⟨seed,log⟩ source Q (Nat.le_refl Q) counted + ∃ input : SpongefishCurrentInitializedMode.Input, ∃ session result, + eraseResult result = data ∧ + Recorded (resultCache result) execution.view.observations ∧ + SpongefishCurrentCallerGetter.run + (SpongefishCurrentCallerGetter.answer (Q := Q) execution.view.observations) + (replayProgram (SpongefishCurrentInitializedMode.initial session instanceBytes input.narg input.hints) tape) = + some result := by + dsimp only + have ran := ideal_runs + (DuplexPublicSimulator.simulator (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape)) + ro iv ⟨seed,log⟩ (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram tape) + _ (Nat.le_refl _) (SpongefishCurrentInitializedMode.afterPrefix_counted + iv tag instanceBytes prefixProgram tape A attacker) + rw [reached] at ran + obtain ⟨input,session,result,observations,erased,replayed,included⟩ := + afterPrefix_replay_subrun iv tag instanceBytes prefixProgram tape ran + have provenance := replay_recorded _ tape [] (empty_recorded []) replayed + refine ⟨input,session,result,erased,recorded_mono (by simpa using provenance.1) included,?_⟩ + apply run_observed replayed + intro o member + obtain ⟨q,valid,equal⟩ := provenance.2 o member + obtain ⟨query,d⟩ := o + dsimp only at equal + subst query + have present := included _ member + obtain ⟨work,_,getter⟩ := ideal_observed_getter + (DuplexPublicSimulator.simulator (A + SpongefishCurrentInitializedMode.budget tag instanceBytes tape)) + ro iv ⟨seed,log⟩ _ _ (Nat.le_refl _) _ q valid d present + rw [SpongefishCurrentCallerGetter.raw_construction iv _ q valid work] at getter + simpa only [SpongefishCurrentCallerGetter.answer,SpongefishCurrentCallerGetter.bounded, + work,↓reduceIte] using getter + +#print axioms request_recorded +#print axioms request_hit +#print axioms collect_recorded +#print axioms replay_recorded +#print axioms initialized_recorded +#print axioms replay_getter_complete +#print axioms afterPrefix_replay_included +#print axioms afterPrefix_getter +#print axioms afterPrefix_cached_getter +#print axioms afterPrefix_runs_recorded +#print axioms lowered_cached_provenance +#print axioms afterPrefix_replay_complete +#print axioms afterPrefix_replay_subrun +#print axioms afterPrefix_ideal_replay_complete +end Whir.SpongefishCurrentCallerGetterCoverage diff --git a/verification/whir/Whir/SpongefishCurrentCallerSmoke.lean b/verification/whir/Whir/SpongefishCurrentCallerSmoke.lean new file mode 100644 index 000000000..6a277ddbf --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentCallerSmoke.lean @@ -0,0 +1,107 @@ +import Whir.SpongefishCurrentSourceCallerOriginal +import Whir.SpongefishCurrentPhysicalModeCompiler + +/-! Literal current-session caller reconstruction using real BLAKE2s replies. +The scalar payload and nonce are parser fixtures, not an accepted PCS opening +or a proof-of-work claim. The returned original is checked against the actual +received anchor and actual sampled caller point. -/ +namespace Whir.SpongefishCurrentCallerSmoke +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishSessionAdapter SpongefishPCSRoundFrames WHIRCallerClaims + +local instance : Add E := ⟨E.add⟩ +local instance : Mul E := ⟨E.mul⟩ +local instance : Zero E := ⟨E.zero⟩ +local instance : One E := ⟨E.one⟩ +local instance (n : Nat) : OfNat E n := ⟨FieldModel.instCommRingE.natCast n⟩ + +def p : ParameterBounds.Profile := ⟨⟨0,by decide⟩,⟨0,by decide⟩⟩ +def layout : CallerLayout := + .recursion ⟨⟨[],[],[],0⟩,[],#[.committed 0 13],⟨0,6,7⟩,1⟩ + +private def report (label : String) : IO Unit := do + IO.println s!"current caller: {label}" + (← IO.getStdout).flush + +private def proofBytes : List WHIRCallerShape.EventShape → List Byte + | [] => [] + | .absorb n :: rest => List.replicate n 0 ++ proofBytes rest + | .squeeze _ :: rest => proofBytes rest + | .nonce _ :: rest => List.replicate 8 0 ++ proofBytes rest + +private def allConstructed (observations : List Observation) : List Observation := + observations.filter fun o => match o.query with + | .construction _ _ => true + | .primitive _ _ => false + +def smoke : IO Unit := do + let C := DuplexModeGame.blake2sOracle + let c := compressionOf C + let parameter := DuplexCompression.parameterIV + let tag : List Byte := [3,5] + let instanceBytes : List Byte := [11,17] + let shape := AnchoredSourceCaller.shape layout + let preludeShape := SpongefishCurrentSourceCallerOriginal.preludeShape layout + let payloadShape := SpongefishCurrentSourceCallerOriginal.payloadShape layout + let some preludeCalls := SpongefishCurrentSourceCallerOriginal.shapeCalls preludeShape + | throw (IO.userError "unsupported prelude fixture") + let headBytes := SpongefishCurrentAnchorHeader.bytes shape zeroDigest ++ scalarBytes (E.ofK 9) + let firstBytes := proofBytes preludeShape ++ headBytes ++ proofBytes payloadShape + let some start := SpongefishCurrentObservedSessionEntry.actualSetup c parameter tag instanceBytes firstBytes [] + | throw (IO.userError "nonempty current session rejected") + let .ok before := SpongefishCurrentPrimitiveEventCompiler.actualReplay c start preludeCalls + | throw (IO.userError "actual prelude rejected") + let some (_,record) := SpongefishCurrentCommitmentReceive.receive c before shape + | throw (IO.userError "actual current header/anchor/value rejected") + report "actual initialized prelude and raw-root anchor receive completed" + let bindingBytes := (SpongefishRecordBindingParser.messages record).flatMap (fun message => message.bytes) + let narg := firstBytes ++ bindingBytes + let some callerCalls := SpongefishCurrentSourceCallerOriginal.calls layout record + | throw (IO.userError "unsupported caller fixture") + let source := runReal C parameter + (SpongefishCurrentPhysicalModeCompiler.program parameter tag instanceBytes narg [] + (callerCalls ++ [.draw .fold])) + let some (.ok captured) := source.view.result + | throw (IO.userError "observed physical source caller rejected") + report "observed physical compiler completed all caller and opening-record fields" + let some (.ok beforeGamma) := SpongefishCurrentObservedSessionEntry.actualEntry c parameter tag + instanceBytes narg [] callerCalls + | throw (IO.userError "actual source caller rejected") + unless captured.1.narg = [] && captured.1.bytesRead = narg.length && + beforeGamma.bytesRead = narg.length do + throw (IO.userError "caller source transport differs") + report "real initialized source consumed exact caller and binding bytes" + let q := SpongefishCurrentModeQueries.coordinate beforeGamma.pending 0 + if work : pathCost q ≤ 1048576 then + let raw := constructionKey 1048576 parameter q work + let inputs := SpongefishCurrentSourceCallerOriginal.original p layout parameter raw + instanceBytes source.view.observations + let some input := inputs.find? (fun input => input.anchorPoint == record.point.toArray && + input.anchorValue == record.value) + | throw (IO.userError "literal public source getter failed to reconstruct actual original") + unless input.lanes = 16 && input.m = 1 && input.points.size = 0 && + input.prepared.familyWeights.size = 1 && input.prepared.familyTargets[0]!.size = 64 && + input.prepared.anchorTable.size = 32768 && input.prepared.anchorClaim.value = E.ofK 9 do + throw (IO.userError "reconstructed original dimensions or literal values differ") + if family : 0 < input.m then + unless input.anchorPoint[0]! != (input.family ⟨0,family⟩).point[0]! do + throw (IO.userError "actual independent caller point was not retained") + else throw (IO.userError "literal caller family disappeared") + report "public construction replies reconstructed actual anchor, caller point and original preparation" + unless (SpongefishCurrentSourceCallerOriginal.original p layout parameter raw + [99] source.view.observations).isEmpty do + throw (IO.userError "foreign literal instance accepted") + unless (SpongefishCurrentSourceCallerOriginal.original p layout parameter raw + instanceBytes []).isEmpty do + throw (IO.userError "missing public construction replies accepted") + let constructed := allConstructed source.view.observations + unless (SpongefishCurrentSourceCallerOriginal.original p layout parameter raw + instanceBytes constructed).any (fun other => other.anchorPoint == input.anchorPoint && + other.anchorValue == input.anchorValue && other.m = input.m) do + throw (IO.userError "ordinary primitive answers improperly substituted for construction replies") + report "foreign instance and missing replies rejected; only literal construction observations used" + else throw (IO.userError "fixture raw-key construction exceeded explicit cap") + +end Whir.SpongefishCurrentCallerSmoke + +def main : IO Unit := Whir.SpongefishCurrentCallerSmoke.smoke diff --git a/verification/whir/Whir/SpongefishCurrentObservedRecordBinding.lean b/verification/whir/Whir/SpongefishCurrentObservedRecordBinding.lean new file mode 100644 index 000000000..a8a875d10 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentObservedRecordBinding.lean @@ -0,0 +1,1146 @@ +import Whir.SpongefishCurrentPhysicalModeCompiler +import Whir.SpongefishCurrentCommitmentReceive + +/-! Observed current record binding. The immutable expected record is received +from the source interaction; its context is captured before the header. Field +mismatches retain the cursor AFTER the successful read and absorption. +This hand-port retains the existing canonical codec and decoded-hint assumptions; +it does not model Rust poisoning, native equations, metadata or PoW. -/ +namespace Whir.SpongefishCurrentObservedRecordBinding +open Concrete FiatShamirGame DuplexRefinement DuplexModeGame +open SpongefishSessionAdapter SpongefishPCSRoundFrames SpongefishCurrentModeQueries +set_option autoImplicit false + +abbrev Physical := SpongefishCurrentPhysicalModeCompiler.Cursor +abbrev Actual := SpongefishPCSRoundFrames.Cursor +abbrev seq {A B : Type} := @WHIRModeFinal.bind A B + +/-- Internal induction invariant, not an input to the initialized endpoint. -/ +def Linked (C : PrimitiveOracle) (iv : Digest32) (p : Physical) (a : Actual) : Prop := + p.semantic.data = SpongefishCurrentMixedModeCompiler.forget a ∧ + SpongefishCurrentPhysicalModeCompiler.SameState p.physical a.state ∧ + RepresentsCurrent (compressionOf C) iv a.pending a.state ∧ + SpongefishCurrentMixedModeCompiler.GoodCache (compressionOf C) iv p.semantic.cache + +def LinkedResult (C : PrimitiveOracle) (iv : Digest32) : + SpongefishCurrentPhysicalModeCompiler.Result → + SpongefishCurrentPrimitiveEventCompiler.ReplayResult → Prop + | .ok p, .ok a => Linked C iv p a + | .error (p,e), .error (a,f) => Linked C iv p a ∧ e = f + | _, _ => False + +theorem replay_linked (C : PrimitiveOracle) (iv : Digest32) (cur : Physical) + (actual : Actual) (linked : Linked C iv cur actual) (calls : List Call) : + LinkedResult C iv + (runReal C iv (SpongefishCurrentPhysicalModeCompiler.replayProgram cur calls)).view.result + (SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) actual calls) := by + obtain ⟨same,physical,represented,good⟩ := linked + induction calls generalizing cur actual with + | nil => exact ⟨same,physical,represented,good⟩ + | cons call calls ih => + have pending : cur.semantic.data.pending = actual.pending := congrArg (fun d => d.pending) same + have narg : cur.semantic.data.narg = actual.narg := congrArg (fun d => d.narg) same + have hints : cur.semantic.data.hints = actual.hints := congrArg (fun d => d.hints) same + have cursor := SpongefishCurrentMixedModeCompiler.cursor_eq (compressionOf C) iv actual represented + cases call with + | read kind => + cases parsed : kind.codec.parse actual.narg with + | none => + simp only [SpongefishCurrentPhysicalModeCompiler.replayProgram,narg,parsed,runReal,LinkedResult, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read] + exact ⟨⟨same,physical,represented,good⟩,rfl⟩ + | some pair => + obtain ⟨value,rest⟩ := pair + let next : Actual := {actual with + state := absorb (compressionOf C) actual.state (kind.codec.bytes value) + pending := bind actual.pending (kind.codec.bytes value) + narg := rest, bytesRead := actual.bytesRead+kind.codec.size, + messagesRead := actual.messagesRead+kind.messages, + events := actual.events ++ [.prover kind (kind.codec.bytes value)]} + have h := ih ⟨SpongefishCurrentMixedModeCompiler.readNext cur.semantic kind value rest, + absorb (compressionOf C) cur.physical (kind.codec.bytes value)⟩ next + (by simp [SpongefishCurrentMixedModeCompiler.readNext, + SpongefishCurrentMixedModeCompiler.boundData,same,SpongefishCurrentMixedModeCompiler.forget,next]) + (SpongefishCurrentPhysicalModeCompiler.same_absorb _ _ _ physical _) + (bind_bridge _ _ _ _ represented _) good + simpa [SpongefishCurrentPhysicalModeCompiler.replayProgram,narg,parsed,seq, + SpongefishCurrentPhysicalModeCompiler.seq,WHIRModeFinal.bind_real_result, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read,next] using h + | hint => + cases transport : actual.hints with + | nil => + simp only [SpongefishCurrentPhysicalModeCompiler.replayProgram,hints,transport,runReal,LinkedResult, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint] + exact ⟨⟨same,physical,represented,good⟩,trivial⟩ + | cons bytes rest => + let next : Actual := {actual with + hints := rest, hintsRead := actual.hintsRead+1, events := actual.events ++ [.hint bytes]} + have h := ih ⟨SpongefishCurrentMixedModeCompiler.hintNext cur.semantic bytes rest,cur.physical⟩ next + (by simp [SpongefishCurrentMixedModeCompiler.hintNext,same, + SpongefishCurrentMixedModeCompiler.forget,next]) physical represented good + simpa [SpongefishCurrentPhysicalModeCompiler.replayProgram,hints,transport, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint,next] using h + | draw g => + by_cases zero : g.bytes = 0 + · let next : Actual := {actual with events := actual.events ++ [.verifier []]} + have h := ih {cur with semantic := {cur.semantic with data := + {cur.semantic.data with events := cur.semantic.data.events ++ [.verifier []]}}} + next (by simp [same,SpongefishCurrentMixedModeCompiler.forget,next]) physical represented good + simpa [SpongefishCurrentPhysicalModeCompiler.replayProgram,zero, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeeze,draw,next] using h + · by_cases guard : cur.semantic.data.pending.consumed+g.bytes ≤ maxCursor + · have actualGuard : actual.pending.consumed+g.bytes ≤ maxCursor := by simpa only [pending] using guard + let result := squeezeLoop (compressionOf C) g.bytes (finish (compressionOf C) actual.state) + have squeezed : squeeze (compressionOf C) actual.state g.bytes = .ok result := by + simp [squeeze,zero,cursor,actualGuard,result] + let collected := (runReal C iv (SpongefishCurrentMixedModeCompiler.collect cur.semantic.data.pending + (SpongefishCurrentMixedModeCompiler.positions cur.semantic.data.pending g.bytes) + (SpongefishCurrentMixedModeCompiler.positions_valid _ cur.semantic.framed _ guard) + cur.semantic.cache)).view.result + have source : SpongefishCurrentMixedModeCompiler.GoodCache (compressionOf C) iv collected.1 ∧ + collected.2 = result.2 := by + have h := SpongefishCurrentMixedModeCompiler.collect_source C iv actual represented + (by simpa only [pending] using cur.semantic.framed) cur.semantic.cache good g.bytes zero + actualGuard result.1 result.2 squeezed + simpa only [collected,pending] using h + let next : Actual := {actual with + state := result.1 + pending := draw actual.pending g.bytes + events := actual.events ++ [.verifier result.2]} + have h := ih ⟨SpongefishCurrentMixedModeCompiler.drawn cur.semantic g.bytes guard collected.1 collected.2, + {finish (compressionOf C) cur.physical with consumed := cur.semantic.data.pending.consumed+g.bytes}⟩ next + (by simp [SpongefishCurrentMixedModeCompiler.drawn,same, + SpongefishCurrentMixedModeCompiler.forget,next,source.2]) + (SpongefishCurrentPhysicalModeCompiler.same_draw _ _ _ physical _ _ (by rw [pending,cursor])) + (draw_bridge _ _ _ _ _ represented _ _ squeezed) source.1 + simpa [SpongefishCurrentPhysicalModeCompiler.replayProgram,zero,guard,seq, + SpongefishCurrentPhysicalModeCompiler.seq,WHIRModeFinal.bind_real_result, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeezed,next,collected] using h + · have exhausted : ¬actual.pending.consumed+g.bytes ≤ maxCursor := by simpa only [pending] using guard + simp only [SpongefishCurrentPhysicalModeCompiler.replayProgram,zero,↓reduceDIte,guard,runReal, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeeze,cursor, + exhausted,↓reduceIte,LinkedResult] + exact ⟨⟨same,physical,represented,good⟩,rfl⟩ + +inductive Error where + | replay (error : SpongefishCurrentPrimitiveEventCompiler.ReplayError) + | invalidShape + | fieldMismatch (kind : WireKind) + | anchorDecode + +abbrev Step (S : Type) (A : Type) := Except (S × Error) (S × A) + +def StepLinked {A : Type} (C : PrimitiveOracle) (iv : Digest32) : + Step Physical A → Step Actual A → Prop + | .ok (p,x), .ok (a,y) => Linked C iv p a ∧ x = y + | .error (p,e), .error (a,f) => Linked C iv p a ∧ e = f + | _, _ => False + +def chain {S A B : Type} (p : Step S A) (next : S → A → Step S B) : Step S B := + match p with + | .error e => .error e + | .ok (s,a) => next s a + +def chainProgram {A B : Type} (p : Program (Step Physical A)) + (next : Physical → A → Program (Step Physical B)) : Program (Step Physical B) := + seq p (fun result => match result with + | .error e => .done (.error e) + | .ok (s,a) => next s a) + +theorem chain_linked {A B : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program (Step Physical A)) (a : Step Actual A) + (next : Physical → A → Program (Step Physical B)) (actualNext : Actual → A → Step Actual B) + (before : StepLinked C iv (runReal C iv p).view.result a) + (after : ∀ p a x, Linked C iv p a → + StepLinked C iv (runReal C iv (next p x)).view.result (actualNext a x)) : + StepLinked C iv (runReal C iv (chainProgram p next)).view.result (chain a actualNext) := by + rw [chainProgram,seq,WHIRModeFinal.bind_real_result] + cases hp : (runReal C iv p).view.result with + | error e => + cases a with + | error f => simpa [hp,chain,runReal,StepLinked] using before + | ok pair => simp [hp,StepLinked] at before + | ok pair => + obtain ⟨p,x⟩ := pair + cases a with + | error e => simp [hp,StepLinked] at before + | ok pair => + obtain ⟨a,y⟩ := pair + have h : Linked C iv p a ∧ x = y := by simpa [hp,StepLinked] using before + simpa [hp,chain,← h.2] using after p a x h.1 + +/-- Decode before any observed absorb, retaining the typed value. -/ +def readProgram (cur : Physical) (kind : WireKind) : Program (Step Physical kind.Value) := + match kind.codec.parse cur.semantic.data.narg with + | none => .done (.error (cur,.replay (.readRejected kind))) + | some (value,rest) => + seq (SpongefishCurrentPrimitiveEventCompiler.absorbProgram cur.physical (kind.codec.bytes value)) + (fun state => .done (.ok + (⟨SpongefishCurrentMixedModeCompiler.readNext cur.semantic kind value rest,state⟩,value))) + +def actualRead (c : Compression) (cur : Actual) (kind : WireKind) : Step Actual kind.Value := + match SpongefishPCSRoundFrames.read c cur kind with + | none => .error (cur,.replay (.readRejected kind)) + | some pair => .ok pair + +theorem read_linked (C : PrimitiveOracle) (iv : Digest32) (cur : Physical) (actual : Actual) + (linked : Linked C iv cur actual) (kind : WireKind) : + StepLinked C iv (runReal C iv (readProgram cur kind)).view.result + (actualRead (compressionOf C) actual kind) := by + obtain ⟨same,physical,represented,good⟩ := linked + have narg : cur.semantic.data.narg = actual.narg := congrArg (fun d => d.narg) same + cases parsed : kind.codec.parse actual.narg with + | none => + simp only [readProgram,narg,actualRead,SpongefishPCSRoundFrames.read,parsed,runReal,StepLinked] + exact ⟨⟨same,physical,represented,good⟩,rfl⟩ + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [readProgram,narg,parsed,seq,WHIRModeFinal.bind_real_result, + SpongefishCurrentPrimitiveEventCompiler.absorbProgram_real,runReal, + actualRead,SpongefishPCSRoundFrames.read,StepLinked,Linked] + refine ⟨⟨?_,SpongefishCurrentPhysicalModeCompiler.same_absorb _ _ _ physical _, + bind_bridge _ _ _ _ represented _,good⟩,rfl⟩ + simp [SpongefishCurrentMixedModeCompiler.readNext, + SpongefishCurrentMixedModeCompiler.boundData,same,SpongefishCurrentMixedModeCompiler.forget] + +/-- Comparison is deliberately in the read's continuation, not a preflight. -/ +def verifyFieldsProgram : Physical → List SpongefishRecordBindingParser.Message → + Program (Step Physical Unit) + | cur, [] => .done (.ok (cur,())) + | cur, message :: rest => + chainProgram (readProgram cur message.1) (fun next value => + if message.1.codec.bytes value = message.bytes then verifyFieldsProgram next rest + else .done (.error (next,.fieldMismatch message.1))) + +def actualVerifyFields (c : Compression) : Actual → List SpongefishRecordBindingParser.Message → + Step Actual Unit + | cur, [] => .ok (cur,()) + | cur, message :: rest => + chain (actualRead c cur message.1) (fun next value => + if message.1.codec.bytes value = message.bytes then actualVerifyFields c next rest + else .error (next,.fieldMismatch message.1)) + +theorem verifyFields_linked (C : PrimitiveOracle) (iv : Digest32) (cur : Physical) + (actual : Actual) (linked : Linked C iv cur actual) (fields : List SpongefishRecordBindingParser.Message) : + StepLinked C iv (runReal C iv (verifyFieldsProgram cur fields)).view.result + (actualVerifyFields (compressionOf C) actual fields) := by + induction fields generalizing cur actual with + | nil => exact ⟨linked,rfl⟩ + | cons message fields ih => + apply chain_linked _ _ _ _ _ _ (read_linked C iv cur actual linked message.1) + intro p a value h + split + · exact ih p a h + · exact ⟨h,rfl⟩ + +/-- Erasing diagnostic reached cursors recovers the existing current parser. -/ +theorem actualVerifyFields_erases (c : Compression) (cur : Actual) + (fields : List SpongefishRecordBindingParser.Message) : + (actualVerifyFields c cur fields).toOption.map Prod.fst = + SpongefishRecordBindingParser.verifyFields c cur fields := by + induction fields generalizing cur with + | nil => rfl + | cons message fields ih => + simp only [actualVerifyFields,actualRead,SpongefishRecordBindingParser.verifyFields, + SpongefishRecordBindingParser.checkedRead] + cases SpongefishPCSRoundFrames.read c cur message.1 with + | none => rfl + | some pair => + obtain ⟨next,value⟩ := pair + simp only [chain] + split + · exact ih next + · rfl + +/-- Values come directly from cached construction replies; the ordinary +finalization answer alone updates the captured CV. -/ +def drawProgram (cur : Physical) (g : Group) : Program (Step Physical (List Byte)) := + if _zero : g.bytes = 0 then + .done (.ok ({cur with semantic := {cur.semantic with data := + {cur.semantic.data with events := cur.semantic.data.events ++ [.verifier []]}}},[])) + else if guard : cur.semantic.data.pending.consumed+g.bytes ≤ maxCursor then + seq (SpongefishCurrentPrimitiveEventCompiler.finishProgram cur.physical) (fun state => + seq (SpongefishCurrentMixedModeCompiler.collect cur.semantic.data.pending + (SpongefishCurrentMixedModeCompiler.positions cur.semantic.data.pending g.bytes) + (SpongefishCurrentMixedModeCompiler.positions_valid _ cur.semantic.framed _ guard) cur.semantic.cache) + (fun (cache,bytes) => .done (.ok + (⟨SpongefishCurrentMixedModeCompiler.drawn cur.semantic g.bytes guard cache bytes, + {state with consumed := cur.semantic.data.pending.consumed+g.bytes}⟩,bytes)))) + else .done (.error (cur,.replay (.drawRejected .cursorExhausted))) + +def actualDraw (c : Compression) (cur : Actual) (g : Group) : Step Actual (List Byte) := + match squeezeGroup c cur g with + | .error e => .error (cur,.replay (.drawRejected e)) + | .ok pair => .ok pair + +theorem draw_linked (C : PrimitiveOracle) (iv : Digest32) (cur : Physical) (actual : Actual) + (linked : Linked C iv cur actual) (g : Group) : + StepLinked C iv (runReal C iv (drawProgram cur g)).view.result + (actualDraw (compressionOf C) actual g) := by + obtain ⟨same,physical,represented,good⟩ := linked + have pending : cur.semantic.data.pending = actual.pending := congrArg (fun d => d.pending) same + have cursor := SpongefishCurrentMixedModeCompiler.cursor_eq (compressionOf C) iv actual represented + by_cases zero : g.bytes = 0 + · simp only [drawProgram,zero,↓reduceDIte,runReal,actualDraw,squeezeGroup,squeeze, + ↓reduceIte,draw,StepLinked,Linked] + exact ⟨⟨by simp [same,SpongefishCurrentMixedModeCompiler.forget],physical,represented,good⟩,rfl⟩ + · by_cases guard : cur.semantic.data.pending.consumed+g.bytes ≤ maxCursor + · have actualGuard : actual.pending.consumed+g.bytes ≤ maxCursor := by simpa only [pending] using guard + let result := squeezeLoop (compressionOf C) g.bytes (finish (compressionOf C) actual.state) + have squeezed : squeeze (compressionOf C) actual.state g.bytes = .ok result := by + simp [squeeze,zero,cursor,actualGuard,result] + let collected := (runReal C iv (SpongefishCurrentMixedModeCompiler.collect cur.semantic.data.pending + (SpongefishCurrentMixedModeCompiler.positions cur.semantic.data.pending g.bytes) + (SpongefishCurrentMixedModeCompiler.positions_valid _ cur.semantic.framed _ guard) + cur.semantic.cache)).view.result + have source : SpongefishCurrentMixedModeCompiler.GoodCache (compressionOf C) iv collected.1 ∧ + collected.2 = result.2 := by + have h := SpongefishCurrentMixedModeCompiler.collect_source C iv actual represented + (by simpa only [pending] using cur.semantic.framed) cur.semantic.cache good g.bytes zero + actualGuard result.1 result.2 squeezed + simpa only [collected,pending] using h + simp only [drawProgram,zero,↓reduceDIte,guard,seq,WHIRModeFinal.bind_real_result, + SpongefishCurrentPrimitiveEventCompiler.finishProgram_real,actualDraw,squeezeGroup, + squeezed,runReal,StepLinked,Linked] + refine ⟨⟨?_,?_,draw_bridge _ _ _ _ _ represented _ _ squeezed,source.1⟩,source.2⟩ + · change (SpongefishCurrentMixedModeCompiler.drawn cur.semantic g.bytes guard + collected.1 collected.2).data = + SpongefishCurrentMixedModeCompiler.forget {actual with + state := result.1 + pending := draw actual.pending g.bytes + events := actual.events ++ [.verifier result.2]} + simp only [SpongefishCurrentMixedModeCompiler.drawn,source.2,same, + SpongefishCurrentMixedModeCompiler.forget] + · exact SpongefishCurrentPhysicalModeCompiler.same_draw _ _ _ physical _ _ (by rw [pending,cursor]) + · have exhausted : ¬actual.pending.consumed+g.bytes ≤ maxCursor := by simpa only [pending] using guard + simp only [drawProgram,zero,↓reduceDIte,guard,runReal,actualDraw,squeezeGroup, + squeeze,cursor,exhausted,↓reduceIte,StepLinked] + exact ⟨⟨same,physical,represented,good⟩,rfl⟩ + +def receiveProgram (cur : Physical) (shape : Shape) : Program (Step Physical Record) := + if ¬shape.Valid then .done (.error (cur,.invalidShape)) else + chainProgram + (verifyFieldsProgram cur (SpongefishRecordBindingParser.scalarMessages + (constants AnchoredHeaderCodec.anchorMarker shape))) (fun header _ => + chainProgram (readProgram header .root) (fun header root => + chainProgram (drawProgram header (.anchor (shape.logN-1))) (fun sampled bytes => + match (vectorCodec shape.logN).parse bytes with + | none => .done (.error (sampled,.anchorDecode)) + | some (point,rest) => + if rest ≠ [] then .done (.error (sampled,.anchorDecode)) else + chainProgram (readProgram sampled .scalar) (fun next value => + .done (.ok (next,{shape,root,context := capture cur.physical,point := List.ofFn point,value})))))) + +def actualReceive (c : Compression) (cur : Actual) (shape : Shape) : Step Actual Record := + if ¬shape.Valid then .error (cur,.invalidShape) else + chain (actualVerifyFields c cur (SpongefishRecordBindingParser.scalarMessages + (constants AnchoredHeaderCodec.anchorMarker shape))) (fun header _ => + chain (actualRead c header .root) (fun header root => + chain (actualDraw c header (.anchor (shape.logN-1))) (fun sampled bytes => + match (vectorCodec shape.logN).parse bytes with + | none => .error (sampled,.anchorDecode) + | some (point,rest) => + if rest ≠ [] then .error (sampled,.anchorDecode) else + chain (actualRead c sampled .scalar) (fun next value => + .ok (next,{shape,root,context := capture cur.state,point := List.ofFn point,value}))))) + +theorem receive_linked (C : PrimitiveOracle) (iv : Digest32) (cur : Physical) (actual : Actual) + (linked : Linked C iv cur actual) (shape : Shape) : + StepLinked C iv (runReal C iv (receiveProgram cur shape)).view.result + (actualReceive (compressionOf C) actual shape) := by + unfold receiveProgram actualReceive + split + · exact ⟨linked,rfl⟩ + · apply chain_linked _ _ _ _ _ _ (verifyFields_linked C iv cur actual linked _) + intro p a _ h + apply chain_linked _ _ _ _ _ _ (read_linked C iv p a h .root) + intro p a root h + apply chain_linked _ _ _ _ _ _ (draw_linked C iv p a h _) + intro p a bytes h + cases (vectorCodec shape.logN).parse bytes with + | none => exact ⟨h,rfl⟩ + | some pair => + obtain ⟨point,rest⟩ := pair + dsimp only + split + · exact ⟨h,rfl⟩ + · apply chain_linked _ _ _ _ _ _ (read_linked C iv p a h .scalar) + intro p a value h + exact ⟨h,congrArg (fun context => ({shape,root,context,point := List.ofFn point,value} : Record)) + (SpongefishCurrentPhysicalModeCompiler.same_capture _ _ linked.2.1)⟩ + +theorem chain_toOption {S A B : Type} (p : Step S A) (next : S → A → Step S B) : + (chain p next).toOption = p.toOption.bind (fun (s,x) => (next s x).toOption) := by + cases p <;> rfl + +theorem actualRead_toOption (c : Compression) (cur : Actual) (kind : WireKind) : + (actualRead c cur kind).toOption = SpongefishPCSRoundFrames.read c cur kind := by + unfold actualRead + cases SpongefishPCSRoundFrames.read c cur kind <;> rfl + +theorem actualDraw_toOption (c : Compression) (cur : Actual) (g : Group) : + (actualDraw c cur g).toOption = (squeezeGroup c cur g).toOption := by + unfold actualDraw + cases squeezeGroup c cur g <;> rfl + +theorem actualVerifyFields_toOption (c : Compression) (cur : Actual) + (fields : List SpongefishRecordBindingParser.Message) : + (actualVerifyFields c cur fields).toOption = + (SpongefishRecordBindingParser.verifyFields c cur fields).map (fun next => (next,())) := by + have h := actualVerifyFields_erases c cur fields + cases result : actualVerifyFields c cur fields with + | error e => simpa [result,Except.toOption] using congrArg (Option.map (fun next => (next,()))) h + | ok pair => + obtain ⟨next,u⟩ := pair + cases u + simpa [result,Except.toOption] using congrArg (Option.map (fun next => (next,()))) h + +theorem actualReceive_erases (c : Compression) (cur : Actual) (shape : Shape) : + (actualReceive c cur shape).toOption = SpongefishCurrentCommitmentReceive.receive c cur shape := by + unfold actualReceive SpongefishCurrentCommitmentReceive.receive SpongefishCurrentAnchorHeader.readHeader + dsimp only [Bind.bind,Option.bind] + by_cases invalid : ¬shape.Valid + · simp [invalid,Except.toOption] + · simp only [invalid,↓reduceIte,chain_toOption,actualVerifyFields_toOption] + cases fields : SpongefishRecordBindingParser.verifyFields c cur + (SpongefishRecordBindingParser.scalarMessages (constants AnchoredHeaderCodec.anchorMarker shape)) with + | none => rfl + | some header => + dsimp only [Option.map,Option.bind] + unfold actualRead + cases readRoot : SpongefishPCSRoundFrames.read c header .root with + | none => dsimp only [Except.toOption] + | some pair => + obtain ⟨header,root⟩ := pair + dsimp only [Except.toOption,Option.bind] + unfold actualDraw + cases drawn : squeezeGroup c header (.anchor (shape.logN-1)) with + | error e => dsimp only [Except.toOption] + | ok pair => + obtain ⟨sampled,bytes⟩ := pair + dsimp only [Except.toOption,Option.bind] + cases decoded : (vectorCodec shape.logN).parse bytes with + | none => dsimp only [Except.toOption] + | some pair => + obtain ⟨point,rest⟩ := pair + dsimp only [Option.bind] + by_cases nonempty : rest ≠ [] + · simp_all + · simp only [nonempty,↓reduceIte] + unfold chain + cases SpongefishPCSRoundFrames.read c sampled .scalar <;> dsimp only [Except.toOption,Pure.pure] + +def replayStage (cur : Physical) (calls : List Call) : Program (Step Physical Unit) := + seq (SpongefishCurrentPhysicalModeCompiler.replayProgram cur calls) (fun result => + .done (match result with + | .error (next,e) => .error (next,.replay e) + | .ok next => .ok (next,()))) + +def actualReplayStage (c : Compression) (cur : Actual) (calls : List Call) : Step Actual Unit := + match SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur calls with + | .error (next,e) => .error (next,.replay e) + | .ok next => .ok (next,()) + +theorem replayStage_linked (C : PrimitiveOracle) (iv : Digest32) (cur : Physical) (actual : Actual) + (linked : Linked C iv cur actual) (calls : List Call) : + StepLinked C iv (runReal C iv (replayStage cur calls)).view.result + (actualReplayStage (compressionOf C) actual calls) := by + have h := replay_linked C iv cur actual linked calls + simp only [replayStage,seq,WHIRModeFinal.bind_real_result,actualReplayStage] + cases p : (runReal C iv (SpongefishCurrentPhysicalModeCompiler.replayProgram cur calls)).view.result <;> + cases a : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) actual calls <;> + simp [p,a,LinkedResult,StepLinked,runReal] at h ⊢ + · exact h + · exact h + +/-- The prefix and payload are literal source Call lists, not synthetic tape +certificates. The record passed to expected-field verification is the received +record, including the observed pre-header context and complete anchor point. -/ +def bodyProgram (cur : Physical) (shape : Shape) (preCalls middle : List Call) : + Program (Step Physical Record) := + chainProgram (replayStage cur preCalls) (fun pre _ => + chainProgram (receiveProgram pre shape) (fun received record => + chainProgram (replayStage received middle) (fun payload _ => + chainProgram (verifyFieldsProgram payload (SpongefishRecordBindingParser.messages record)) (fun next _ => + .done (.ok (next,record)))))) + +def actualBody (c : Compression) (cur : Actual) (shape : Shape) (preCalls middle : List Call) : + Step Actual Record := + chain (actualReplayStage c cur preCalls) (fun pre _ => + chain (actualReceive c pre shape) (fun received record => + chain (actualReplayStage c received middle) (fun payload _ => + chain (actualVerifyFields c payload (SpongefishRecordBindingParser.messages record)) (fun next _ => + .ok (next,record))))) + +theorem body_linked (C : PrimitiveOracle) (iv : Digest32) (cur : Physical) (actual : Actual) + (linked : Linked C iv cur actual) (shape : Shape) (preCalls middle : List Call) : + StepLinked C iv (runReal C iv (bodyProgram cur shape preCalls middle)).view.result + (actualBody (compressionOf C) actual shape preCalls middle) := by + apply chain_linked _ _ _ _ _ _ (replayStage_linked C iv cur actual linked preCalls) + intro p a _ h + apply chain_linked _ _ _ _ _ _ (receive_linked C iv p a h shape) + intro p a record h + apply chain_linked _ _ _ _ _ _ (replayStage_linked C iv p a h middle) + intro p a _ h + apply chain_linked _ _ _ _ _ _ (verifyFields_linked C iv p a h _) + intro p a _ h + exact ⟨h,rfl⟩ + +def captureStep {S A B : Type} (f : S → B) : Step S A → Step B A + | .error (cur,e) => .error (f cur,e) + | .ok (cur,x) => .ok (f cur,x) + +theorem linked_capture {A : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Step Physical A) (a : Step Actual A) (h : StepLinked C iv p a) : + captureStep SpongefishCurrentPhysicalModeCompiler.captureCursor p = + captureStep SpongefishCurrentPhysicalModeCompiler.captureActual a := by + cases p with + | error pair => + obtain ⟨p,e⟩ := pair + cases a with + | ok pair => contradiction + | error pair => + obtain ⟨a,f⟩ := pair + obtain ⟨⟨same,physical,_,_⟩,equal⟩ := h + cases equal + exact congrArg (fun cur => Except.error (cur,e)) + (Prod.ext same (SpongefishCurrentPhysicalModeCompiler.same_capture _ _ physical)) + | ok pair => + obtain ⟨p,x⟩ := pair + cases a with + | error pair => contradiction + | ok pair => + obtain ⟨a,y⟩ := pair + obtain ⟨⟨same,physical,_,_⟩,equal⟩ := h + cases equal + exact congrArg (fun cur => Except.ok (cur,x)) + (Prod.ext same (SpongefishCurrentPhysicalModeCompiler.same_capture _ _ physical)) + +def program (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (shape : Shape) (preCalls middle : List Call) : + Program (Option (Step SpongefishCurrentPhysicalModeCompiler.Captured Record)) := + seq (SpongefishCurrentObservedSessionEntry.setupProgram parameter tag instanceBytes narg hints) + (fun result => match result with + | none => .done none + | some actual => + seq (bodyProgram (SpongefishCurrentPhysicalModeCompiler.initial actual instanceBytes narg hints) + shape preCalls middle) (fun result => + .done (some (captureStep SpongefishCurrentPhysicalModeCompiler.captureCursor result)))) + +def actualEntry (c : Compression) (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (shape : Shape) (preCalls middle : List Call) := + (SpongefishCurrentObservedSessionEntry.actualSetup c parameter tag instanceBytes narg hints).map + (fun cur => captureStep SpongefishCurrentPhysicalModeCompiler.captureActual + (actualBody c cur shape preCalls middle)) + +theorem program_real (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (shape : Shape) + (preCalls middle : List Call) : + (runReal C parameter (program parameter tag instanceBytes narg hints shape preCalls middle)).view.result = + actualEntry (compressionOf C) parameter tag instanceBytes narg hints shape preCalls middle := by + rw [program,seq,WHIRModeFinal.bind_real_result,SpongefishCurrentObservedSessionEntry.setupProgram_real] + by_cases empty : instanceBytes = [] + · simp [actualEntry,SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty,runReal] + · simp only [SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty,↓reduceIte, + Option.map_some,seq,WHIRModeFinal.bind_real_result,runReal] + let actual := SpongefishCurrentObservedSessionEntry.cursor (derive (compressionOf C) parameter tag) + instanceBytes narg hints (absorb (compressionOf C) (init (compressionOf C) parameter + (derive (compressionOf C) parameter tag)) instanceBytes) + have linked : Linked C parameter + (SpongefishCurrentPhysicalModeCompiler.initial actual instanceBytes narg hints) actual := by + refine ⟨?_,rfl,session_bridge (compressionOf C) parameter _ instanceBytes,?_⟩ + · simp [SpongefishCurrentPhysicalModeCompiler.initial,SpongefishCurrentInitializedMode.initial, + actual,SpongefishCurrentObservedSessionEntry.cursor,SpongefishCurrentMixedModeCompiler.forget, + SpongefishPCSRoundFrames.bind,empty] + · intro q d found + cases found + have h := linked_capture C parameter _ _ (body_linked C parameter _ actual linked shape preCalls middle) + simpa [actualEntry,SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty,actual] + using congrArg some h + +/-- Syntactic postconditions quantify over EVERY oracle answer, not only C. -/ +def Returns {A : Type} (P : A → Prop) : Program A → Prop + | .done a => P a + | .ask _ next => ∀ answer, Returns P (next answer) + +theorem returns_all {A : Type} (p : Program A) : Returns (fun _ => True) p := by + induction p with + | done => trivial + | ask q next ih => exact ih + +theorem returns_mono {A : Type} (p : Program A) (P Q : A → Prop) + (h : Returns P p) (imp : ∀ a, P a → Q a) : Returns Q p := by + induction p with + | done a => exact imp a h + | ask q next ih => exact fun d => ih d (h d) + +theorem returns_seq {A B : Type} (p : Program A) (next : A → Program B) + (P : A → Prop) (Q : B → Prop) (before : Returns P p) + (after : ∀ a, P a → Returns Q (next a)) : Returns Q (seq p next) := by + induction p with + | done a => exact after a before + | ask q cont ih => exact fun d => ih d (before d) + +theorem seq_counted_returns {A B : Type} (p : Program A) (next : A → Program B) + (P : A → Prop) (a b : Nat) (counted : Counts a p) (post : Returns P p) + (after : ∀ r, P r → Counts b (next r)) : Counts (a+b) (seq p next) := by + induction p generalizing a with + | done r => exact WHIRModeFinal.counts_mono (after r post) (by omega) + | ask q cont ih => + refine ⟨by have := counted.1; omega,fun d => ?_⟩ + have h := ih d (a-q.cost) (counted.2 d) (post d) + have equal : a+b-q.cost = (a-q.cost)+b := by have := counted.1; omega + simpa only [equal] using h + +def Envelope (w : Nat) (cur : Physical) : Prop := + SpongefishCurrentMixedModeCompiler.weight cur.semantic.data.pending ≤ w ∧ cur.physical.pending.size ≤ 64 + +def StepEnvelope {A : Type} (w : Nat) : Step Physical A → Prop + | .error (p,_) => Envelope w p + | .ok (p,_) => Envelope w p + +def replayCursor : SpongefishCurrentPhysicalModeCompiler.Result → Physical + | .error (p,_) => p + | .ok p => p + +def growth : List Call → Nat + | [] => 0 + | .read kind :: calls => kind.codec.size + growth calls + | .draw _ :: calls => 1 + growth calls + | .hint :: calls => growth calls + +theorem envelope_mono (p : Physical) (a b : Nat) (h : Envelope a p) (le : a ≤ b) : Envelope b p := + ⟨h.1.trans le,h.2⟩ + +theorem absorb_returns (s : State) (bytes : List Byte) (bounded : s.pending.size ≤ 64) : + Returns (fun t => t.pending.size ≤ 64) + (SpongefishCurrentPrimitiveEventCompiler.absorbProgram s bytes) := by + induction bytes generalizing s with + | nil => exact bounded + | cons b bs ih => + apply returns_seq _ _ (fun t => t.pending.size ≤ 64) _ + · unfold SpongefishCurrentPrimitiveEventCompiler.absorbByteProgram + split <;> dsimp only <;> split + all_goals + first + | exact fun _ => by dsimp only [Returns,WHIRModeFinal.bind]; simp + | simp only [Returns,Array.size_push]; omega + · intro t h + exact ih t h + +theorem finish_returns (s : State) (bounded : s.pending.size ≤ 64) : + Returns (fun t => t.pending.size ≤ 64) + (SpongefishCurrentPrimitiveEventCompiler.finishProgram s) := by + unfold SpongefishCurrentPrimitiveEventCompiler.finishProgram + split + · exact bounded + · intro d + dsimp only [Returns,WHIRModeFinal.bind] + simp + +theorem read_returns (cur : Physical) (w : Nat) (h : Envelope w cur) (kind : WireKind) : + Returns (StepEnvelope (w+kind.codec.size)) (readProgram cur kind) := by + unfold readProgram + cases kind.codec.parse cur.semantic.data.narg with + | none => exact envelope_mono cur _ _ h (by omega) + | some pair => + obtain ⟨value,rest⟩ := pair + apply returns_seq _ _ (fun t => t.pending.size ≤ 64) _ (absorb_returns _ _ h.2) + intro t bounded + refine ⟨?_,bounded⟩ + change SpongefishCurrentMixedModeCompiler.weight + (bind cur.semantic.data.pending (kind.codec.bytes value)) ≤ w+kind.codec.size + rw [SpongefishCurrentMixedModeCompiler.bind_weight] + simp only [Codec.bytes,List.length_ofFn] + exact Nat.add_le_add_right h.1 _ + +theorem draw_returns (cur : Physical) (w : Nat) (h : Envelope w cur) (g : Group) : + Returns (StepEnvelope (w+1)) (drawProgram cur g) := by + unfold drawProgram + split + · exact envelope_mono cur _ _ h (by omega) + · split + · apply returns_seq _ _ (fun t => t.pending.size ≤ 64) _ (finish_returns _ h.2) + intro t bounded + apply returns_seq _ _ (fun _ => True) _ (returns_all _) + intro pair _ + exact ⟨(SpongefishCurrentMixedModeCompiler.draw_weight _ _).trans + (Nat.add_le_add_right h.1 1),bounded⟩ + · exact envelope_mono cur _ _ h (by omega) + +def fieldsSize (fields : List SpongefishRecordBindingParser.Message) : Nat := + (fields.map fun m => m.1.codec.size).sum + +theorem read_counted (cur : Physical) (kind : WireKind) : + Counts kind.codec.size (readProgram cur kind) := by + unfold readProgram + cases kind.codec.parse cur.semantic.data.narg with + | none => trivial + | some pair => + exact SpongefishCurrentPrimitiveEventCompiler.seq_done_counted _ _ + (by simpa only [Codec.bytes,List.length_ofFn] using + (SpongefishCurrentPrimitiveEventCompiler.absorbProgram_certified cur.physical + (kind.codec.bytes pair.1)).1) + +theorem verifyFields_counted (cur : Physical) (fields : List SpongefishRecordBindingParser.Message) : + Counts (fieldsSize fields) (verifyFieldsProgram cur fields) := by + induction fields generalizing cur with + | nil => trivial + | cons message fields ih => + apply WHIRModeFinal.bind_counted _ _ message.1.codec.size (fieldsSize fields) (read_counted _ _) + intro result + cases result with + | error e => trivial + | ok pair => + dsimp only + split + · exact ih pair.1 + · trivial + +theorem verifyFields_returns (cur : Physical) (w : Nat) (h : Envelope w cur) + (fields : List SpongefishRecordBindingParser.Message) : + Returns (StepEnvelope (w+fieldsSize fields)) (verifyFieldsProgram cur fields) := by + induction fields generalizing cur w with + | nil => exact h + | cons message fields ih => + apply returns_seq _ _ (StepEnvelope (w+message.1.codec.size)) _ (read_returns _ _ h _) + intro result bounded + cases result with + | error e => + exact envelope_mono e.1 _ _ bounded (by simp only [fieldsSize,List.map_cons,List.sum_cons]; omega) + | ok pair => + dsimp only + split + · simpa only [fieldsSize,List.map_cons,List.sum_cons,Nat.add_assoc] using ih pair.1 _ bounded + · exact envelope_mono pair.1 _ _ bounded (by simp only [fieldsSize,List.map_cons,List.sum_cons]; omega) + +theorem draw_counted (cur : Physical) (w : Nat) (h : Envelope w cur) (g : Group) : + Counts (1+g.bytes*w) (drawProgram cur g) := by + unfold drawProgram + split + · trivial + · split + · apply WHIRModeFinal.bind_counted _ _ 1 (g.bytes*w) + (SpongefishCurrentPrimitiveEventCompiler.finishProgram_certified _).1 + intro state + apply SpongefishCurrentPrimitiveEventCompiler.seq_done_counted + apply WHIRModeFinal.counts_mono (SpongefishCurrentMixedModeCompiler.collect_counted _ _ _ _) + simp only [SpongefishCurrentMixedModeCompiler.positions,List.length_map,List.length_range] + exact Nat.mul_le_mul_left _ ((SpongefishCurrentMixedModeCompiler.path_weight _ 0).trans h.1) + · trivial + +theorem replay_returns (cur : Physical) (w : Nat) (h : Envelope w cur) (calls : List Call) : + Returns (fun result => Envelope (w+growth calls) (replayCursor result)) + (SpongefishCurrentPhysicalModeCompiler.replayProgram cur calls) := by + induction calls generalizing cur w with + | nil => exact h + | cons call calls ih => + cases call with + | read kind => + simp only [SpongefishCurrentPhysicalModeCompiler.replayProgram] + cases cur.semantic.data.narg |> kind.codec.parse with + | none => exact envelope_mono _ _ _ h (by simp only [growth]; omega) + | some pair => + obtain ⟨value,rest⟩ := pair + apply returns_seq _ _ (fun t => t.pending.size ≤ 64) _ (absorb_returns _ _ h.2) + intro state bounded + have next : Envelope (w+kind.codec.size) + ⟨SpongefishCurrentMixedModeCompiler.readNext cur.semantic kind value rest,state⟩ := by + refine ⟨?_,bounded⟩ + change SpongefishCurrentMixedModeCompiler.weight + (bind cur.semantic.data.pending (kind.codec.bytes value)) ≤ w+kind.codec.size + rw [SpongefishCurrentMixedModeCompiler.bind_weight] + simpa only [Codec.bytes,List.length_ofFn] using Nat.add_le_add_right h.1 kind.codec.size + simpa only [growth,Nat.add_assoc] using ih _ _ next + | hint => + simp only [SpongefishCurrentPhysicalModeCompiler.replayProgram] + cases cur.semantic.data.hints with + | nil => exact envelope_mono _ _ _ h (by simp only [growth]; omega) + | cons bytes rest => exact ih _ w h + | draw g => + simp only [SpongefishCurrentPhysicalModeCompiler.replayProgram] + split + · have next : Envelope (w+1) {cur with semantic := {cur.semantic with data := + {cur.semantic.data with events := cur.semantic.data.events ++ [.verifier []]}}} := + ⟨h.1.trans (by omega),h.2⟩ + simpa only [growth,Nat.add_assoc] using ih _ _ next + · split + · apply returns_seq _ _ (fun t => t.pending.size ≤ 64) _ (finish_returns _ h.2) + intro state bounded + apply returns_seq _ _ (fun _ => True) _ (returns_all _) + intro pair _ + have next : Envelope (w+1) + ⟨SpongefishCurrentMixedModeCompiler.drawn cur.semantic g.bytes (by assumption) pair.1 pair.2, + {state with consumed := cur.semantic.data.pending.consumed+g.bytes}⟩ := + ⟨(SpongefishCurrentMixedModeCompiler.draw_weight _ _).trans + (Nat.add_le_add_right h.1 1),bounded⟩ + simpa only [growth,Nat.add_assoc] using ih _ _ next + · exact envelope_mono _ _ _ h (by simp only [growth]; omega) + +theorem replayStage_returns (cur : Physical) (w : Nat) (h : Envelope w cur) (calls : List Call) : + Returns (StepEnvelope (w+growth calls)) (replayStage cur calls) := by + apply returns_seq _ _ (fun result => Envelope (w+growth calls) (replayCursor result)) _ + (replay_returns cur w h calls) + intro result bounded + cases result <;> exact bounded + +theorem replayStage_counted (cur : Physical) (w : Nat) (h : Envelope w cur) (calls : List Call) : + Counts (SpongefishCurrentPhysicalModeCompiler.resource w calls) (replayStage cur calls) := + SpongefishCurrentPrimitiveEventCompiler.seq_done_counted _ _ + (SpongefishCurrentPhysicalModeCompiler.replay_counted cur calls w h.1) + +theorem header_fieldsSize (shape : Shape) : + fieldsSize (SpongefishRecordBindingParser.scalarMessages + (constants AnchoredHeaderCodec.anchorMarker shape)) = 72 := rfl + +def receiveBudget (w : Nat) (shape : Shape) : Nat := + 72 + (32 + ((1+(Group.anchor (shape.logN-1)).bytes*(w+104))+24)) + +theorem chain_done_counted {A B : Type} (p : Program (Step Physical A)) + (f : Physical → A → Step Physical B) (a : Nat) (h : Counts a p) : + Counts a (chainProgram p (fun cur x => .done (f cur x))) := by + unfold chainProgram + apply WHIRModeFinal.counts_mono (WHIRModeFinal.bind_counted _ _ a 0 h ?_) (by omega) + intro result + cases result <;> trivial + +theorem receive_counted (cur : Physical) (w : Nat) (h : Envelope w cur) (shape : Shape) : + Counts (receiveBudget w shape) (receiveProgram cur shape) := by + unfold receiveProgram + split + · trivial + · apply seq_counted_returns _ _ (StepEnvelope (w+72)) 72 + (32+((1+(Group.anchor (shape.logN-1)).bytes*(w+104))+24)) + (by simpa only [header_fieldsSize] using (verifyFields_counted cur + (SpongefishRecordBindingParser.scalarMessages (constants AnchoredHeaderCodec.anchorMarker shape)))) + (by simpa only [header_fieldsSize] using (verifyFields_returns cur w h + (SpongefishRecordBindingParser.scalarMessages (constants AnchoredHeaderCodec.anchorMarker shape)))) + intro result bounded + cases result with + | error e => trivial + | ok pair => + dsimp only + apply seq_counted_returns _ _ (StepEnvelope (w+72+32)) 32 + ((1+(Group.anchor (shape.logN-1)).bytes*(w+104))+24) + (read_counted _ .root) (read_returns _ _ bounded .root) + intro result bounded + cases result with + | error e => trivial + | ok pair => + dsimp only + apply WHIRModeFinal.bind_counted _ _ (1+(Group.anchor (shape.logN-1)).bytes*(w+104)) 24 + (draw_counted _ _ bounded _) + intro result + cases result with + | error e => trivial + | ok pair => + dsimp only + cases (vectorCodec shape.logN).parse pair.2 with + | none => trivial + | some value => + dsimp only + split + · trivial + · exact chain_done_counted _ _ 24 (read_counted _ .scalar) + +def ReceivePost (w : Nat) (shape : Shape) : Step Physical Record → Prop + | .error (p,_) => Envelope w p + | .ok (p,r) => Envelope w p ∧ r.shape = shape ∧ r.context.pending.length ≤ 64 ∧ + r.point.length = shape.logN + +theorem receive_returns (cur : Physical) (w : Nat) (h : Envelope w cur) (shape : Shape) : + Returns (ReceivePost (w+129) shape) (receiveProgram cur shape) := by + unfold receiveProgram + split + · exact envelope_mono _ _ _ h (by omega) + · apply returns_seq _ _ (StepEnvelope (w+72)) _ + (by simpa only [header_fieldsSize] using (verifyFields_returns cur w h + (SpongefishRecordBindingParser.scalarMessages (constants AnchoredHeaderCodec.anchorMarker shape)))) + intro result bounded + cases result with + | error e => exact envelope_mono _ _ _ bounded (by omega) + | ok pair => + dsimp only + apply returns_seq _ _ (StepEnvelope (w+72+32)) _ (read_returns _ _ bounded .root) + intro result bounded + cases result with + | error e => exact envelope_mono _ _ _ bounded (by omega) + | ok pair => + dsimp only + apply returns_seq _ _ (StepEnvelope (w+72+32+1)) _ (draw_returns _ _ bounded _) + intro result bounded + cases result with + | error e => exact envelope_mono _ _ _ bounded (by omega) + | ok pair => + dsimp only + cases (vectorCodec shape.logN).parse pair.2 with + | none => exact envelope_mono _ _ _ bounded (by omega) + | some value => + dsimp only + split + · exact envelope_mono _ _ _ bounded (by omega) + · apply returns_seq _ _ (StepEnvelope (w+72+32+1+24)) _ (read_returns _ _ bounded .scalar) + intro result bounded + cases result with + | error e => exact envelope_mono _ _ _ bounded (by omega) + | ok pair => + refine ⟨envelope_mono _ _ _ bounded (by omega),rfl,?_,List.length_ofFn⟩ + simpa only [capture,Array.length_toList] using h.2 + +theorem fieldsSize_bytes (fields : List SpongefishRecordBindingParser.Message) : + fieldsSize fields = (fields.flatMap SpongefishRecordBindingParser.Message.bytes).length := by + induction fields with + | nil => rfl + | cons m fields ih => + simpa only [fieldsSize,List.map_cons,List.sum_cons,List.flatMap_cons,List.length_append, + SpongefishRecordBindingParser.Message.bytes,Codec.bytes,List.length_ofFn] using congrArg (m.1.codec.size+·) ih + +def openingBudget (shape : Shape) : Nat := 208+24*(3+shape.logN) + +theorem opening_counted (cur : Physical) (record : Record) (shape : Shape) + (_same : record.shape = shape) (pending : record.context.pending.length ≤ 64) + (point : record.point.length = shape.logN) : + Counts (openingBudget shape) (verifyFieldsProgram cur (SpongefishRecordBindingParser.messages record)) := by + apply WHIRModeFinal.counts_mono (verifyFields_counted _ _) + rw [fieldsSize_bytes,SpongefishRecordBindingParser.messages_bytes,openingBytes_length,point] + have chunks : (record.context.pending.length+23)/24 ≤ 3 := by omega + unfold openingBudget + omega + +def bodyBudget (w : Nat) (shape : Shape) (preCalls middle : List Call) : Nat := + SpongefishCurrentPhysicalModeCompiler.resource w preCalls + + (receiveBudget (w+growth preCalls) shape + + (SpongefishCurrentPhysicalModeCompiler.resource (w+growth preCalls+129) middle + openingBudget shape)) + +theorem body_counted (cur : Physical) (w : Nat) (h : Envelope w cur) (shape : Shape) + (preCalls middle : List Call) : Counts (bodyBudget w shape preCalls middle) + (bodyProgram cur shape preCalls middle) := by + apply seq_counted_returns _ _ (StepEnvelope (w+growth preCalls)) + (SpongefishCurrentPhysicalModeCompiler.resource w preCalls) + (receiveBudget (w+growth preCalls) shape + + (SpongefishCurrentPhysicalModeCompiler.resource (w+growth preCalls+129) middle + openingBudget shape)) + (replayStage_counted _ _ h _) (replayStage_returns _ _ h _) + intro result bounded + cases result with + | error e => trivial + | ok pair => + dsimp only + apply seq_counted_returns _ _ (ReceivePost (w+growth preCalls+129) shape) + (receiveBudget (w+growth preCalls) shape) + (SpongefishCurrentPhysicalModeCompiler.resource (w+growth preCalls+129) middle + openingBudget shape) + (receive_counted _ _ bounded _) (receive_returns _ _ bounded _) + intro result received + cases result with + | error e => trivial + | ok pair => + dsimp only + obtain ⟨bounded,same,pending,point⟩ := received + apply WHIRModeFinal.bind_counted _ _ + (SpongefishCurrentPhysicalModeCompiler.resource (w+growth preCalls+129) middle) (openingBudget shape) + (replayStage_counted _ _ bounded _) + intro result + cases result with + | error e => trivial + | ok payload => + dsimp only + exact chain_done_counted _ _ (openingBudget shape) + (opening_counted payload.1 pair.2 shape same pending point) + +def SetupPost : Option Actual → Prop + | none => True + | some cur => cur.state.pending.size ≤ 64 + +theorem setup_returns (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) : + Returns SetupPost + (SpongefishCurrentObservedSessionEntry.setupProgram parameter tag instanceBytes narg hints) := by + unfold SpongefishCurrentObservedSessionEntry.setupProgram + split + · trivial + · apply returns_seq _ _ (fun _ => True) _ (returns_all _) + intro session _ + apply returns_seq _ _ (fun cur : Actual => cur.state.pending.size ≤ 64) _ + · unfold SpongefishCurrentObservedSessionEntry.sessionProgram + apply returns_seq _ _ (fun s => s.pending.size ≤ 64) _ + · intro cv + simp [Returns,WHIRModeFinal.bind] + · intro s bounded + apply returns_seq _ _ (fun s => s.pending.size ≤ 64) _ (absorb_returns _ _ bounded) + intro t ht + exact ht + · intro cur bounded + exact bounded + +def budget (tag instanceBytes : List Byte) (shape : Shape) (preCalls middle : List Call) : Nat := + SpongefishCurrentObservedSessionEntry.setupBudget tag instanceBytes + + bodyBudget (instanceBytes.length+3) shape preCalls middle + +theorem program_counted (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (shape : Shape) (preCalls middle : List Call) : + Counts (budget tag instanceBytes shape preCalls middle) + (program parameter tag instanceBytes narg hints shape preCalls middle) := by + apply seq_counted_returns _ _ SetupPost + (SpongefishCurrentObservedSessionEntry.setupBudget tag instanceBytes) + (bodyBudget (instanceBytes.length+3) shape preCalls middle) + (SpongefishCurrentObservedSessionEntry.setupProgram_certified parameter tag instanceBytes narg hints).1 + (setup_returns parameter tag instanceBytes narg hints) + intro result bounded + cases result with + | none => trivial + | some actual => + apply SpongefishCurrentPrimitiveEventCompiler.seq_done_counted + apply body_counted + exact ⟨by simp [SpongefishCurrentPhysicalModeCompiler.initial],bounded⟩ + +theorem program_work (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (shape : Shape) + (preCalls middle : List Call) : + (runReal C parameter (program parameter tag instanceBytes narg hints shape preCalls middle)).primitiveCost ≤ + budget tag instanceBytes shape preCalls middle := + runReal_counts C parameter _ _ (program_counted parameter tag instanceBytes narg hints shape preCalls middle) + +def sourceBody (c : Compression) (cur : Actual) (shape : Shape) (preCalls middle : List Call) : + Option (Actual × Record) := do + let pre ← (SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur preCalls).toOption + let (received,record) ← SpongefishCurrentCommitmentReceive.receive c pre shape + let payload ← (SpongefishCurrentPrimitiveEventCompiler.actualReplay c received middle).toOption + let next ← SpongefishRecordBindingParser.verify c payload record + pure (next,record) + +theorem actualReplayStage_toOption (c : Compression) (cur : Actual) (calls : List Call) : + (actualReplayStage c cur calls).toOption = + (SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur calls).toOption.map (fun next => (next,())) := by + unfold actualReplayStage + cases SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur calls <;> rfl + +/-- All rejection paths erase to the existing receive and expected-record +verification; the stronger initialized equality also preserves diagnostics. -/ +theorem actualBody_erases (c : Compression) (cur : Actual) (shape : Shape) (preCalls middle : List Call) : + (actualBody c cur shape preCalls middle).toOption = sourceBody c cur shape preCalls middle := by + unfold actualBody sourceBody + dsimp only [Bind.bind,Option.bind] + rw [chain_toOption,actualReplayStage_toOption] + cases (SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur preCalls).toOption with + | none => rfl + | some pre => + dsimp only [Option.map,Option.bind] + rw [chain_toOption,actualReceive_erases] + cases SpongefishCurrentCommitmentReceive.receive c pre shape with + | none => rfl + | some pair => + obtain ⟨received,record⟩ := pair + dsimp only [Option.bind] + rw [chain_toOption,actualReplayStage_toOption] + cases (SpongefishCurrentPrimitiveEventCompiler.actualReplay c received middle).toOption with + | none => rfl + | some payload => + dsimp only [Option.map,Option.bind] + rw [chain_toOption,actualVerifyFields_toOption] + unfold SpongefishRecordBindingParser.verify + cases SpongefishRecordBindingParser.verifyFields c payload (SpongefishRecordBindingParser.messages record) <;> rfl + +theorem captureStep_toOption {S A B : Type} (f : S → B) (result : Step S A) : + (captureStep f result).toOption = result.toOption.map (fun (cur,x) => (f cur,x)) := by + cases result <;> rfl + +def sourceEntry (c : Compression) (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (shape : Shape) (preCalls middle : List Call) : + Option (SpongefishCurrentPhysicalModeCompiler.Captured × Record) := + (SpongefishCurrentObservedSessionEntry.actualSetup c parameter tag instanceBytes narg hints).bind + (fun cur => (sourceBody c cur shape preCalls middle).map + (fun (next,record) => (SpongefishCurrentPhysicalModeCompiler.captureActual next,record))) + +theorem program_source (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (shape : Shape) + (preCalls middle : List Call) : + ((runReal C parameter (program parameter tag instanceBytes narg hints shape preCalls middle)).view.result.bind + (fun result => result.toOption)) = + sourceEntry (compressionOf C) parameter tag instanceBytes narg hints shape preCalls middle := by + rw [program_real] + unfold actualEntry sourceEntry + cases SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) parameter tag instanceBytes narg hints with + | none => rfl + | some cur => + dsimp only [Option.map,Option.bind] + rw [captureStep_toOption,actualBody_erases] + cases sourceBody (compressionOf C) cur shape preCalls middle with + | none => rfl + | some pair => cases pair; rfl + +/-- The saved context is recovered from a genuine received record, not assumed +as a supplied record/context equality. No whole native verifier is asserted. -/ +theorem sourceBody_accepted (c : Compression) (cur next : Actual) (shape : Shape) + (preCalls middle : List Call) (record : Record) + (accepted : sourceBody c cur shape preCalls middle = some (next,record)) : + ∃ pre received payload, + SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur preCalls = .ok pre ∧ + SpongefishCurrentCommitmentReceive.receive c pre shape = some (received,record) ∧ + SpongefishCurrentPrimitiveEventCompiler.actualReplay c received middle = .ok payload ∧ + SpongefishRecordBindingParser.verify c payload record = some next ∧ + record.context = capture pre.state := by + unfold sourceBody at accepted + obtain ⟨pre,preRun,accepted⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨⟨received,saved⟩,receivedRun,accepted⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨payload,payloadRun,accepted⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨after,verifyRun,equal⟩ := Option.bind_eq_some_iff.mp accepted + have pairEq : (after,saved) = (next,record) := Option.some.inj equal + cases pairEq + have replay_ok (result : SpongefishCurrentPrimitiveEventCompiler.ReplayResult) (a : Actual) + (h : result.toOption = some a) : result = .ok a := by + cases result with + | error e => contradiction + | ok b => exact congrArg Except.ok (Option.some.inj h) + exact ⟨pre,received,payload,replay_ok _ _ preRun,receivedRun,replay_ok _ _ payloadRun, + verifyRun,(SpongefishCurrentCommitmentReceive.receive_retains c pre received shape record receivedRun).2.1⟩ + +/-- An accepted observed composition exposes the actual source setup, prefix, +receive, payload and expected-record verification, with derived saved context. -/ +theorem program_accepted (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (shape : Shape) + (preCalls middle : List Call) (snapshot : SpongefishCurrentPhysicalModeCompiler.Captured) + (record : Record) + (accepted : (runReal C parameter + (program parameter tag instanceBytes narg hints shape preCalls middle)).view.result = + some (.ok (snapshot,record))) : + ∃ initial pre received payload next, + SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) parameter + tag instanceBytes narg hints = some initial ∧ + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial preCalls = .ok pre ∧ + SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre shape = some (received,record) ∧ + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received middle = .ok payload ∧ + SpongefishRecordBindingParser.verify (compressionOf C) payload record = some next ∧ + snapshot = SpongefishCurrentPhysicalModeCompiler.captureActual next ∧ + record.context = capture pre.state := by + have source := program_source C parameter tag instanceBytes narg hints shape preCalls middle + rw [accepted] at source + have reached : sourceEntry (compressionOf C) parameter tag instanceBytes narg hints shape preCalls middle = + some (snapshot,record) := source.symm + unfold sourceEntry at reached + obtain ⟨initial,setup,mapped⟩ := Option.bind_eq_some_iff.mp reached + obtain ⟨⟨next,saved⟩,body,pairEq⟩ := Option.map_eq_some_iff.mp mapped + have savedEq : saved = record := congrArg Prod.snd pairEq + subst saved + obtain ⟨pre,received,payload,preRun,receivedRun,payloadRun,verifyRun,context⟩ := + sourceBody_accepted (compressionOf C) initial next shape preCalls middle record body + exact ⟨initial,pre,received,payload,next,setup,preRun,receivedRun,payloadRun,verifyRun, + (congrArg Prod.fst pairEq).symm,context⟩ + +#print axioms program_accepted + +#print axioms program_source +#print axioms sourceBody_accepted + +#print axioms program_real +#print axioms program_counted +#print axioms program_work +#print axioms actualReceive_erases +#print axioms actualVerifyFields_erases + +end Whir.SpongefishCurrentObservedRecordBinding diff --git a/verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean b/verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean index dfc6dca78..edb5cc287 100644 --- a/verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean +++ b/verification/whir/Whir/SpongefishCurrentObservedSessionEntry.lean @@ -67,6 +67,20 @@ def actualSetup (c : Compression) (parameter : Digest32) (tag instanceBytes narg let session := derive c parameter tag (newSession c parameter session instanceBytes).map (cursor session instanceBytes narg hints) +/-- The reference adapter bypasses runReal. Share its derived session across +the initialization node and pending-frame domain at the Option boundary. +The existing constructor guard still rejects before any derived work. -/ +private def actualSetupStored (c : Compression) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) : Option Cursor := + if instanceBytes = [] then none else + withDerived c parameter tag (fun session => + (newSession c parameter session instanceBytes).map (cursor session instanceBytes narg hints)) + +@[csimp] private theorem actualSetup_stored : actualSetup = actualSetupStored := by + funext c parameter tag instanceBytes narg hints + simp only [actualSetup,actualSetupStored,withDerived_eq] + by_cases empty : instanceBytes = [] <;> simp [newSession,empty] + @[simp] theorem setupProgram_real (C : PrimitiveOracle) (iv parameter : Digest32) (tag instanceBytes narg : List Byte) (hints : List (List Byte)) : (runReal C iv (setupProgram parameter tag instanceBytes narg hints)).view.result = @@ -249,6 +263,41 @@ theorem entryProgram_trace (C : PrimitiveOracle) (iv parameter : Digest32) cases actualSetup (compressionOf C) parameter tag instanceBytes narg hints <;> simp only [seq_observations,replayProgram_trace,runReal,List.append_nil] +/-- Reference provenance adapters replay one metered execution rather than +computing a separate reply chain beside each stored observation. -/ +private def instructionsTraceStored (C : PrimitiveOracle) (cv : Digest32) + (xs : List DuplexEncoding.Instruction) : List Observation := + (runReal C zeroDigest (instructions cv xs)).view.observations + +@[csimp] private theorem instructionsTrace_stored : instructionsTrace = instructionsTraceStored := by + funext C cv xs + exact (instructions_trace C zeroDigest cv xs).symm + +private def sessionTraceStored (C : PrimitiveOracle) (parameter session : Digest32) + (instanceBytes : List Byte) : List Observation := + (runReal C zeroDigest (sessionProgram parameter session instanceBytes [] [])).view.observations + +@[csimp] private theorem sessionTrace_stored : sessionTrace = sessionTraceStored := by + funext C parameter session instanceBytes + exact (sessionProgram_trace C zeroDigest parameter session instanceBytes [] []).symm + +private def setupTraceStored (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes : List Byte) : List Observation := + (runReal C zeroDigest (setupProgram parameter tag instanceBytes [] [])).view.observations + +@[csimp] private theorem setupTrace_stored : setupTrace = setupTraceStored := by + funext C parameter tag instanceBytes + exact (setupProgram_trace C zeroDigest parameter tag instanceBytes [] []).symm + +private def entryTraceStored (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + List Observation := + (runReal C zeroDigest (entryProgram parameter tag instanceBytes narg hints calls)).view.observations + +@[csimp] private theorem entryTrace_stored : entryTrace = entryTraceStored := by + funext C parameter tag instanceBytes narg hints calls + exact (entryProgram_trace C zeroDigest parameter tag instanceBytes narg hints calls).symm + theorem setupProgram_observation_count (C : PrimitiveOracle) (iv parameter : Digest32) (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (nonempty : instanceBytes ≠ []) : (runReal C iv (setupProgram parameter tag instanceBytes narg hints)).view.observations.length = @@ -291,6 +340,11 @@ theorem compiledEntry_real (C : PrimitiveOracle) (iv parameter : Digest32) runReal C iv (entryProgram parameter tag instanceBytes narg hints calls) := PublicCompressionProgram.compile_eval C iv _ _ _ +#print axioms actualSetup_stored +#print axioms instructionsTrace_stored +#print axioms sessionTrace_stored +#print axioms setupTrace_stored +#print axioms entryTrace_stored #print axioms initProgram_real #print axioms setupProgram_nonempty #print axioms setupProgram_bridge diff --git a/verification/whir/Whir/SpongefishCurrentPhysicalModeCompiler.lean b/verification/whir/Whir/SpongefishCurrentPhysicalModeCompiler.lean new file mode 100644 index 000000000..83b97ad75 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentPhysicalModeCompiler.lean @@ -0,0 +1,337 @@ +import Whir.SpongefishCurrentInitializedMode + +/-! Current byte-source compiler retaining the actual record-capture context. +Seed, absorb and finalization CVs are ordinary observed answers; output bytes +are the existing cached construction replies. Only `State.output` is erased +by the physical-state relation. It is deliberately not a full State equality. +Constructor correspondence excludes Rust's empty-instance panic. This is a +source-inspected byte adapter, not a native PCS/Aeneas/knowledge theorem. -/ +namespace Whir.SpongefishCurrentPhysicalModeCompiler +open Concrete FiatShamirGame DuplexRefinement DuplexModeGame +open SpongefishSessionAdapter SpongefishPCSRoundFrames SpongefishCurrentModeQueries +set_option autoImplicit false + +namespace Semantic +export SpongefishCurrentMixedModeCompiler (Data SemanticCursor Cache GoodCache forget + readNext hintNext drawn collect positions positions_valid collect_source weight + bind_weight draw_weight path_weight collect_counted cursor_eq) +end Semantic + +abbrev seq {A B : Type} := @WHIRModeFinal.bind A B + +structure Cursor where + semantic : Semantic.SemanticCursor + physical : State + +/-- Equality modulo ONLY the output cache, which is absent from capture. -/ +def normalize (s : State) : State := {s with output := zeroDigest} +def SameState (physical actual : State) : Prop := normalize physical = normalize actual + +theorem same_consumed (p a : State) (same : SameState p a) : p.consumed = a.consumed := by + have equal := congrArg State.consumed (show normalize p = normalize a from same) + exact equal + +theorem same_capture (p a : State) (same : SameState p a) : capture p = capture a := by + change capture (normalize p) = capture (normalize a) + rw [same] + +theorem same_absorb (c : Compression) (p a : State) (same : SameState p a) + (bytes : List Byte) : SameState (absorb c p bytes) (absorb c a bytes) := by + unfold SameState normalize at * + rw [← absorb_setOutput,← absorb_setOutput,same] + +theorem same_finish (c : Compression) (p a : State) (same : SameState p a) : + SameState (finish c p) (finish c a) := by + have commute (s : State) : normalize (finish c s) = finish c (normalize s) := by + unfold normalize finish + split <;> rfl + unfold SameState at * + rw [commute,commute,same] + +theorem normalize_squeezeLoop (c : Compression) (n : Nat) (s : State) : + normalize (squeezeLoop c n s).1 = normalize {s with consumed := s.consumed+n} := by + apply state_ext + · exact squeezeLoop_cv c n s + · exact squeezeLoop_pending c n s + · exact squeezeLoop_first c n s + · exact squeezeLoop_previous c n s + · exact squeezeLoop_consumed c n s + · rfl + +theorem same_draw (c : Compression) (p a : State) (same : SameState p a) (n : Nat) + (counter : Nat) (equal : counter = a.consumed+n) : + SameState {finish c p with consumed := counter} + (squeezeLoop c n (finish c a)).1 := by + unfold SameState + rw [normalize_squeezeLoop,finish_consumed,← equal] + exact congrArg (fun s : State => {s with consumed := counter}) (same_finish c p a same) + +abbrev ReplayError := SpongefishCurrentPrimitiveEventCompiler.ReplayError +abbrev Result := Except (Cursor × ReplayError) Cursor +abbrev Captured := Semantic.Data × Context +abbrev CapturedResult := Except (Captured × ReplayError) Captured + +def captureCursor (cur : Cursor) : Captured := (cur.semantic.data,capture cur.physical) +def captureActual (cur : SpongefishPCSRoundFrames.Cursor) : Captured := + (Semantic.forget cur,capture cur.state) + +def eraseResult : Result → CapturedResult + | .ok cur => .ok (captureCursor cur) + | .error (cur,e) => .error (captureCursor cur,e) + +def captureResult : SpongefishCurrentPrimitiveEventCompiler.ReplayResult → CapturedResult + | .ok cur => .ok (captureActual cur) + | .error (cur,e) => .error (captureActual cur,e) + +/-- Parse and both draw guards precede physical observations. Rejection retains +all reached semantic data and capture fields. Hints leave physical state alone. +The stale physical output field is never used to produce verifier bytes. -/ +def replayProgram : Cursor → List Call → Program Result + | cur, [] => .done (.ok cur) + | cur, .read kind :: calls => + match kind.codec.parse cur.semantic.data.narg with + | none => .done (.error (cur,.readRejected kind)) + | some (value,rest) => + seq (SpongefishCurrentPrimitiveEventCompiler.absorbProgram cur.physical (kind.codec.bytes value)) + (fun state => replayProgram ⟨Semantic.readNext cur.semantic kind value rest,state⟩ calls) + | cur, .hint :: calls => + match cur.semantic.data.hints with + | [] => .done (.error (cur,.missingHint)) + | bytes :: rest => replayProgram ⟨Semantic.hintNext cur.semantic bytes rest,cur.physical⟩ calls + | cur, .draw g :: calls => + if _zero : g.bytes = 0 then + replayProgram {cur with semantic := {cur.semantic with data := + {cur.semantic.data with events := cur.semantic.data.events ++ [.verifier []]}}} calls + else if guard : cur.semantic.data.pending.consumed + g.bytes ≤ maxCursor then + seq (SpongefishCurrentPrimitiveEventCompiler.finishProgram cur.physical) (fun state => + seq (Semantic.collect cur.semantic.data.pending + (Semantic.positions cur.semantic.data.pending g.bytes) + (Semantic.positions_valid _ cur.semantic.framed _ guard) cur.semantic.cache) + (fun (cache,bytes) => replayProgram + ⟨Semantic.drawn cur.semantic g.bytes guard cache bytes, + {state with consumed := cur.semantic.data.pending.consumed+g.bytes}⟩ calls)) + else .done (.error (cur,.drawRejected .cursorExhausted)) + +/-- Worst-case work includes ordinary reads/finalization AND every complete +construction path; arbitrary answers and rejecting suffixes are covered. -/ +def resource : Nat → List Call → Nat + | _, [] => 0 + | w, .read kind :: calls => kind.codec.size + resource (w+kind.codec.size) calls + | w, .draw g :: calls => 1 + g.bytes*w + resource (w+1) calls + | w, .hint :: calls => resource w calls + +theorem replay_counted (cur : Cursor) (calls : List Call) (w : Nat) + (cap : Semantic.weight cur.semantic.data.pending ≤ w) : + Counts (resource w calls) (replayProgram cur calls) := by + induction calls generalizing cur w with + | nil => trivial + | cons call calls ih => + cases call with + | read kind => + simp only [replayProgram] + cases kind.codec.parse cur.semantic.data.narg with + | none => trivial + | some pair => + obtain ⟨value,rest⟩ := pair + apply WHIRModeFinal.bind_counted _ _ kind.codec.size (resource (w+kind.codec.size) calls) + · simpa only [Codec.bytes,List.length_ofFn] using + (SpongefishCurrentPrimitiveEventCompiler.absorbProgram_certified cur.physical + (kind.codec.bytes value)).1 + · intro state + apply ih + change Semantic.weight (bind cur.semantic.data.pending (kind.codec.bytes value)) ≤ w+kind.codec.size + rw [Semantic.bind_weight] + simp only [Codec.bytes,List.length_ofFn] + omega + | hint => + simp only [replayProgram] + cases cur.semantic.data.hints with + | nil => trivial + | cons bytes rest => exact ih _ w cap + | draw g => + simp only [replayProgram] + split + · apply WHIRModeFinal.counts_mono (ih _ (w+1) (by dsimp; omega)) + simp only [resource]; omega + · split + · simp only [resource,Nat.add_assoc] + apply WHIRModeFinal.bind_counted _ _ 1 (g.bytes*w+resource (w+1) calls) + · exact (SpongefishCurrentPrimitiveEventCompiler.finishProgram_certified cur.physical).1 + · intro state + apply WHIRModeFinal.bind_counted _ _ (g.bytes*w) (resource (w+1) calls) + · apply WHIRModeFinal.counts_mono (Semantic.collect_counted _ _ _ _) + simp only [Semantic.positions,List.length_map,List.length_range] + exact Nat.mul_le_mul_left _ ((Semantic.path_weight _ 0).trans cap) + · intro pair + apply ih + exact (Semantic.draw_weight _ _).trans (by omega) + · trivial + +theorem replay_real (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) + (actual : SpongefishPCSRoundFrames.Cursor) + (same : cur.semantic.data = Semantic.forget actual) + (physical : SameState cur.physical actual.state) + (represented : RepresentsCurrent (compressionOf C) iv actual.pending actual.state) + (good : Semantic.GoodCache (compressionOf C) iv cur.semantic.cache) (calls : List Call) : + eraseResult (runReal C iv (replayProgram cur calls)).view.result = + captureResult (SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) actual calls) := by + induction calls generalizing cur actual with + | nil => exact congrArg Except.ok (Prod.ext same (same_capture _ _ physical)) + | cons call calls ih => + have pending : cur.semantic.data.pending = actual.pending := congrArg (fun d => d.pending) same + have narg : cur.semantic.data.narg = actual.narg := congrArg (fun d => d.narg) same + have hints : cur.semantic.data.hints = actual.hints := congrArg (fun d => d.hints) same + have cursor := Semantic.cursor_eq (compressionOf C) iv actual represented + have captured : captureCursor cur = captureActual actual := Prod.ext same (same_capture _ _ physical) + cases call with + | read kind => + cases parsed : kind.codec.parse actual.narg with + | none => + simp [replayProgram,narg,parsed,runReal,eraseResult,captureResult, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read,captured] + | some pair => + obtain ⟨value,rest⟩ := pair + let next : SpongefishPCSRoundFrames.Cursor := {actual with + state := absorb (compressionOf C) actual.state (kind.codec.bytes value) + pending := bind actual.pending (kind.codec.bytes value) + narg := rest + bytesRead := actual.bytesRead+kind.codec.size + messagesRead := actual.messagesRead+kind.messages + events := actual.events ++ [.prover kind (kind.codec.bytes value)]} + have h := ih ⟨Semantic.readNext cur.semantic kind value rest, + absorb (compressionOf C) cur.physical (kind.codec.bytes value)⟩ next + (by simp [SpongefishCurrentMixedModeCompiler.readNext, + SpongefishCurrentMixedModeCompiler.boundData,same,Semantic.forget,next]) + (same_absorb _ _ _ physical _) (bind_bridge _ _ _ _ represented _) good + simpa [replayProgram,narg,parsed,seq,WHIRModeFinal.bind_real_result, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read,next] using h + | hint => + cases transport : actual.hints with + | nil => + simp [replayProgram,hints,transport,runReal,eraseResult,captureResult, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint,captured] + | cons bytes rest => + let next : SpongefishPCSRoundFrames.Cursor := {actual with + hints := rest, hintsRead := actual.hintsRead+1, events := actual.events ++ [.hint bytes]} + have h := ih ⟨Semantic.hintNext cur.semantic bytes rest,cur.physical⟩ next + (by simp [SpongefishCurrentMixedModeCompiler.hintNext,same,Semantic.forget,next]) physical represented good + simpa [replayProgram,hints,transport, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint,next] using h + | draw g => + by_cases zero : g.bytes = 0 + · let next : SpongefishPCSRoundFrames.Cursor := {actual with events := actual.events ++ [.verifier []]} + have h := ih {cur with semantic := {cur.semantic with data := + {cur.semantic.data with events := cur.semantic.data.events ++ [.verifier []]}}} + next (by simp [same,Semantic.forget,next]) physical represented good + simpa [replayProgram,zero, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeeze,draw,next] using h + · by_cases guard : cur.semantic.data.pending.consumed+g.bytes ≤ maxCursor + · have actualGuard : actual.pending.consumed+g.bytes ≤ maxCursor := by simpa only [pending] using guard + let result := squeezeLoop (compressionOf C) g.bytes (finish (compressionOf C) actual.state) + have squeezed : squeeze (compressionOf C) actual.state g.bytes = .ok result := by + simp [squeeze,zero,cursor,actualGuard,result] + let collected := (runReal C iv (Semantic.collect cur.semantic.data.pending + (Semantic.positions cur.semantic.data.pending g.bytes) + (Semantic.positions_valid _ cur.semantic.framed _ guard) cur.semantic.cache)).view.result + have source : Semantic.GoodCache (compressionOf C) iv collected.1 ∧ collected.2 = result.2 := by + have h := Semantic.collect_source C iv actual represented + (by simpa only [pending] using cur.semantic.framed) cur.semantic.cache good g.bytes zero + actualGuard result.1 result.2 squeezed + simpa only [collected,pending] using h + let next : SpongefishPCSRoundFrames.Cursor := {actual with + state := result.1, pending := draw actual.pending g.bytes, + events := actual.events ++ [.verifier result.2]} + have h := ih ⟨Semantic.drawn cur.semantic g.bytes guard collected.1 collected.2, + {finish (compressionOf C) cur.physical with consumed := cur.semantic.data.pending.consumed+g.bytes}⟩ next + (by simp [SpongefishCurrentMixedModeCompiler.drawn,same,Semantic.forget,next,source.2]) + (same_draw _ _ _ physical _ _ (by rw [pending,cursor])) + (draw_bridge _ _ _ _ _ represented _ _ squeezed) source.1 + simpa [replayProgram,zero,guard,seq,WHIRModeFinal.bind_real_result, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeezed,next,collected] using h + · have exhausted : ¬actual.pending.consumed+g.bytes ≤ maxCursor := by simpa only [pending] using guard + simp only [replayProgram,zero,↓reduceDIte,guard,runReal,eraseResult, + SpongefishCurrentPrimitiveEventCompiler.actualReplay, + SpongefishCurrentPrimitiveEventCompiler.actualCall,squeezeGroup,squeeze,cursor, + exhausted,↓reduceIte,captureResult] + exact congrArg (fun d => Except.error (d, + SpongefishCurrentPrimitiveEventCompiler.ReplayError.drawRejected .cursorExhausted)) captured + +/-- Initial semantics comes from constructor bytes and the observed session; +physical state comes unchanged from observed setup, never a hidden C call. -/ +def initial (actual : SpongefishPCSRoundFrames.Cursor) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : Cursor := + ⟨SpongefishCurrentInitializedMode.initial actual.pending.domain instanceBytes narg hints,actual.state⟩ + +def program (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : Program (Option CapturedResult) := + seq (SpongefishCurrentObservedSessionEntry.setupProgram parameter tag instanceBytes narg hints) + (fun result => match result with + | none => .done none + | some actual => seq (replayProgram (initial actual instanceBytes narg hints) calls) + (fun result => .done (some (eraseResult result)))) + +def budget (tag instanceBytes : List Byte) (calls : List Call) : Nat := + SpongefishCurrentObservedSessionEntry.setupBudget tag instanceBytes + + resource (instanceBytes.length+3) calls + +theorem program_counted (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (calls : List Call) : + Counts (budget tag instanceBytes calls) (program parameter tag instanceBytes narg hints calls) := by + apply WHIRModeFinal.bind_counted _ _ + (SpongefishCurrentObservedSessionEntry.setupBudget tag instanceBytes) + (resource (instanceBytes.length+3) calls) + (SpongefishCurrentObservedSessionEntry.setupProgram_certified parameter tag instanceBytes narg hints).1 + intro result + cases result with + | none => trivial + | some actual => + exact SpongefishCurrentPrimitiveEventCompiler.seq_done_counted _ _ + (replay_counted _ calls _ (by simp [initial])) + +/-- Full Data AND exact actual capture on accepted and rejected cursors. The +representation premise used by the internal induction is derived from setup; +the initialized endpoint needs no external context/representation certificate. -/ +theorem program_real (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + (runReal C parameter (program parameter tag instanceBytes narg hints calls)).view.result = + (SpongefishCurrentObservedSessionEntry.actualEntry (compressionOf C) parameter + tag instanceBytes narg hints calls).map captureResult := by + rw [program,seq,WHIRModeFinal.bind_real_result,SpongefishCurrentObservedSessionEntry.setupProgram_real] + by_cases empty : instanceBytes = [] + · simp [SpongefishCurrentObservedSessionEntry.actualEntry, + SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty,runReal] + · simp only [SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty,↓reduceIte, + Option.map_some,seq,WHIRModeFinal.bind_real_result,runReal] + have same := replay_real C parameter + (initial (SpongefishCurrentObservedSessionEntry.cursor (derive (compressionOf C) parameter tag) + instanceBytes narg hints (absorb (compressionOf C) (init (compressionOf C) parameter + (derive (compressionOf C) parameter tag)) instanceBytes)) instanceBytes narg hints) + (SpongefishCurrentObservedSessionEntry.cursor (derive (compressionOf C) parameter tag) + instanceBytes narg hints (absorb (compressionOf C) (init (compressionOf C) parameter + (derive (compressionOf C) parameter tag)) instanceBytes)) + (by simp [initial,SpongefishCurrentInitializedMode.initial, + SpongefishCurrentObservedSessionEntry.cursor,Semantic.forget,SpongefishPCSRoundFrames.bind,empty]) + rfl (session_bridge (compressionOf C) parameter _ instanceBytes) + (by intro q d found; cases found) calls + simpa [SpongefishCurrentObservedSessionEntry.actualEntry, + SpongefishCurrentObservedSessionEntry.actualSetup,newSession,empty] using congrArg some same + +theorem program_work (C : PrimitiveOracle) (parameter : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) (calls : List Call) : + (runReal C parameter (program parameter tag instanceBytes narg hints calls)).primitiveCost ≤ + budget tag instanceBytes calls := + runReal_counts C parameter _ _ (program_counted parameter tag instanceBytes narg hints calls) + +#print axioms same_capture +#print axioms replay_real +#print axioms replay_counted +#print axioms program_real +#print axioms program_counted +#print axioms program_work +end Whir.SpongefishCurrentPhysicalModeCompiler diff --git a/verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean b/verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean index f48884b33..26016734c 100644 --- a/verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean +++ b/verification/whir/Whir/SpongefishCurrentPrimitiveEventCompiler.lean @@ -30,7 +30,7 @@ def absorbByteProgram (s : State) (b : Byte) : Program State := let s := if s.consumed = 0 then s else {s with previous := s.consumed, consumed := 0} if s.pending.size = 64 then seq (primitive s.cv (padded s.pending) (absorbTweak s.first false 64 s.previous) true) - (fun d => .done {memoCV s d with pending := #[b], first := false, previous := 0}) + (fun d => .done {s with cv := d, pending := #[b], first := false, previous := 0}) else .done {s with pending := s.pending.push b} def absorbProgram : State → List Byte → Program State @@ -41,11 +41,11 @@ def finishProgram (s : State) : Program State := if s.pending.isEmpty then .done s else seq (primitive s.cv (padded s.pending) (absorbTweak s.first true s.pending.size s.previous) true) - (fun d => .done {memoCV s d with pending := #[], first := true, previous := 0}) + (fun d => .done {s with cv := d, pending := #[], first := true, previous := 0}) def squeezeByteProgram (s : State) : Program (State × Byte) := let next := fun d => Program.done - ({memoOutput s d with consumed := s.consumed + 1}, + ({s with output := d, consumed := s.consumed + 1}, d ⟨s.consumed % 32, Nat.mod_lt _ (by decide)⟩) if s.consumed % 32 = 0 then seq (primitive s.cv (wordsBlock [s.consumed / 32]) (UInt64.ofNat (6*2^56)) true) next @@ -69,7 +69,7 @@ def squeezeProgram (s : State) (n : Nat) : Program (Except Error (State × List (runReal C iv (absorbByteProgram s b)).view.result = absorbByte (compressionOf C) s b := by simp only [absorbByteProgram,absorbByte] split <;> split <;> - simp [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal,memoCV_eq] + simp [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal] @[simp] theorem absorbProgram_real (C : PrimitiveOracle) (iv : Digest32) (s : State) (bs : List Byte) : @@ -83,12 +83,12 @@ def squeezeProgram (s : State) (n : Nat) : Program (Except Error (State × List @[simp] theorem finishProgram_real (C : PrimitiveOracle) (iv : Digest32) (s : State) : (runReal C iv (finishProgram s)).view.result = finish (compressionOf C) s := by simp only [finishProgram,finish,finalized] - split <;> simp_all [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal,memoCV_eq] + split <;> simp_all [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal] @[simp] theorem squeezeByteProgram_real (C : PrimitiveOracle) (iv : Digest32) (s : State) : (runReal C iv (squeezeByteProgram s)).view.result = squeezeByte (compressionOf C) s := by simp only [squeezeByteProgram,squeezeByte,outputBlock] - split <;> simp_all [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal,memoOutput_eq] + split <;> simp_all [seq,WHIRModeFinal.bind_real_result,primitive_real,runReal] @[simp] theorem squeezeLoopProgram_real (C : PrimitiveOracle) (iv : Digest32) (n : Nat) (s : State) : @@ -466,6 +466,13 @@ theorem seq_observations {A B : Type} (C : PrimitiveOracle) (iv : Digest32) def record (C : PrimitiveOracle) (n : DuplexFraming.Node) : List Observation := [⟨.primitive .auxiliary n,C n⟩] +private def recordStored (C : PrimitiveOracle) (n : DuplexFraming.Node) : List Observation := + withDigest (C n) (fun d => [⟨.primitive .auxiliary n,d⟩]) + +@[csimp] private theorem record_stored : record = recordStored := by + funext C n + simp only [record,recordStored,withDigest_eq] + /-- These source traces compute literal nodes from the actual reached states, not from ideal raw keys or an independently supplied opening tape. -/ def absorbByteTrace (C : PrimitiveOracle) (s : State) : List Observation := @@ -577,6 +584,44 @@ theorem replayProgram_trace (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) simp only [replayProgram,seq_observations,callProgram_trace,callProgram_real,replayTrace] cases actualCall (compressionOf C) cur call <;> simp only [runReal,ih] +/-- Reference trace adapters use the same single observed execution as their +programs. Computing a separate state transition beside each record would +retain a second compression history in the returned observations. -/ +private def absorbTraceStored (C : PrimitiveOracle) (s : State) (bs : List Byte) : + List Observation := (runReal C zeroDigest (absorbProgram s bs)).view.observations + +@[csimp] private theorem absorbTrace_stored : absorbTrace = absorbTraceStored := by + funext C s bs + exact (absorbProgram_trace C zeroDigest s bs).symm + +private def squeezeLoopTraceStored (C : PrimitiveOracle) (n : Nat) (s : State) : + List Observation := (runReal C zeroDigest (squeezeLoopProgram n s)).view.observations + +@[csimp] private theorem squeezeLoopTrace_stored : squeezeLoopTrace = squeezeLoopTraceStored := by + funext C n s + exact (squeezeLoopProgram_trace C zeroDigest n s).symm + +private def squeezeTraceStored (C : PrimitiveOracle) (s : State) (n : Nat) : + List Observation := (runReal C zeroDigest (squeezeProgram s n)).view.observations + +@[csimp] private theorem squeezeTrace_stored : squeezeTrace = squeezeTraceStored := by + funext C s n + exact (squeezeProgram_trace C zeroDigest s n).symm + +private def callTraceStored (C : PrimitiveOracle) (cur : Cursor) (call : Call) : + List Observation := (runReal C zeroDigest (callProgram cur call)).view.observations + +@[csimp] private theorem callTrace_stored : callTrace = callTraceStored := by + funext C cur call + exact (callProgram_trace C zeroDigest cur call).symm + +private def replayTraceStored (C : PrimitiveOracle) (cur : Cursor) (calls : List Call) : + List Observation := (runReal C zeroDigest (replayProgram cur calls)).view.observations + +@[csimp] private theorem replayTrace_stored : replayTrace = replayTraceStored := by + funext C cur calls + exact (replayProgram_trace C zeroDigest cur calls).symm + theorem replayProgram_exact_count (C : PrimitiveOracle) (iv : Digest32) (cur : Cursor) (calls : List Call) : (runReal C iv (replayProgram cur calls)).primitiveCost = (replayTrace C cur calls).length := by rw [← replayProgram_trace] @@ -597,6 +642,13 @@ theorem compiledReplay_source (C : PrimitiveOracle) (iv : Digest32) (cur : Curso (TypedOracleCompiler.Sampling.eval C (compiledReplay iv cur calls)).view.result = actualReplay (compressionOf C) cur calls := by rw [compiledReplay_real,replayProgram_real] +#print axioms record_stored +#print axioms absorbTrace_stored +#print axioms squeezeLoopTrace_stored +#print axioms squeezeTrace_stored +#print axioms callTrace_stored +#print axioms replayTrace_stored + #print axioms compiledReplay_real #print axioms compiledReplay_source diff --git a/verification/whir/Whir/SpongefishCurrentReplayProvenance.lean b/verification/whir/Whir/SpongefishCurrentReplayProvenance.lean new file mode 100644 index 000000000..35e62fc41 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentReplayProvenance.lean @@ -0,0 +1,178 @@ +import Whir.SpongefishCurrentCallerGetter +import Whir.PCSBCSIdealConstructionAnswers + +/-! Literal observations of the unchanged Program interpreters. This small +operational relation is proof-only: it neither evaluates nor fills a missing +public answer. Its trace includes precisely asks, never compiler-cache hits. -/ +namespace Whir.SpongefishCurrentReplayProvenance +open Concrete FiatShamirGame DuplexFraming DuplexModeGame +set_option autoImplicit false + +inductive Runs {A : Type} : Program A → List Observation → A → Prop + | done (a : A) : Runs (.done a) [] a + | ask (q : Query) (next : Digest32 → Program A) (d : Digest32) + {os : List Observation} {a : A} (tail : Runs (next d) os a) : + Runs (.ask q next) (⟨q,d⟩ :: os) a + +theorem real_runs {A : Type} (C : PrimitiveOracle) (iv : Digest32) (p : Program A) : + Runs p (runReal C iv p).view.observations (runReal C iv p).view.result := by + induction p with + | done a => exact .done a + | ask q next ih => exact .ask q next (realAnswer C iv q) (ih _) + +theorem ideal_runs {Q : Nat} {Seed State A : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) (p : Program A) + (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p) : + Runs p (runIdeal sim ro iv state p remaining cap counted).view.observations + (runIdeal sim ro iv state p remaining cap counted).view.result := by + induction p generalizing remaining state with + | done a => exact .done a + | ask q next ih => + cases q with + | primitive purpose input => + exact .ask _ _ _ (ih _ _ _ _ (counted.2 _)) + | construction q valid => + exact .ask _ _ _ (ih _ _ _ _ (counted.2 _)) + +theorem bind_runs {A B : Type} (p : Program A) (next : A → Program B) + {os : List Observation} {b : B} (ran : Runs (WHIRModeFinal.bind p next) os b) : + ∃ a before after, os = before ++ after ∧ Runs p before a ∧ Runs (next a) after b := by + induction p generalizing os b with + | done a => exact ⟨a,[],os,rfl,.done a,ran⟩ + | ask q cont ih => + cases ran with + | ask _ _ d tail => + obtain ⟨a,before,after,equal,first,last⟩ := ih d tail + exact ⟨a,⟨q,d⟩ :: before,after,by simp [equal],.ask q cont d first,last⟩ + +theorem observation_cap {A : Type} {p : Program A} {os : List Observation} {a : A} + (ran : Runs p os a) (Q : Nat) (counted : Counts Q p) : + ∀ o ∈ os, o.query.cost ≤ Q := by + induction ran generalizing Q with + | done => simp + | ask q next d tail ih => + intro o member + rcases List.mem_cons.mp member with rfl | later + · exact counted.1 + · exact (ih _ (counted.2 d) o later).trans (Nat.sub_le _ _) + +theorem bind_real_observations {A B : Type} (C : PrimitiveOracle) (iv : Digest32) + (p : Program A) (next : A → Program B) : + (runReal C iv (WHIRModeFinal.bind p next)).view.observations = + (runReal C iv p).view.observations ++ + (runReal C iv (next (runReal C iv p).view.result)).view.observations := by + induction p with + | done a => rfl + | ask q cont ih => + simp only [WHIRModeFinal.bind,runReal,prepend,List.cons_append] + exact congrArg (List.cons ⟨q,realAnswer C iv q⟩) (ih (realAnswer C iv q)) + +/-- Coverage is derived from the actual full execution, not a GetterCovers +certificate. An actual construction-only subrun may use any public prefix or +suffix; its keys inherit the aggregate Program.Counts cap. -/ +theorem actual_getter {A B : Type} (C : PrimitiveOracle) (iv : Digest32) + (whole : Program A) (part : Program B) (Q : Nat) (counted : Counts Q whole) + (included : ∀ o ∈ (runReal C iv part).view.observations, + o ∈ (runReal C iv whole).view.observations) + (construction : ∀ o ∈ (runReal C iv part).view.observations, + ∃ q valid, o.query = .construction q valid) : + ∀ o ∈ (runReal C iv part).view.observations, + SpongefishCurrentCallerGetter.answer (Q := Q) + (runReal C iv whole).view.observations o.query = some o.answer := by + intro o member + obtain ⟨q,valid,equal⟩ := construction o member + have present := included o member + have cap := observation_cap (real_runs C iv whole) Q counted o present + have consistent := SpongefishCurrentCallerGetter.real_consistent C iv whole + have value := consistent o present + rw [equal] at cap value ⊢ + change SpongefishCurrentCallerGetter.bounded (Q := Q) _ q = some o.answer + rw [SpongefishCurrentCallerGetter.bounded_real C iv _ consistent q valid cap + ⟨o,present,equal⟩] + exact congrArg some value.symm + +theorem run_observed {A : Type} {p : Program A} {os : List Observation} {a : A} + (ran : Runs p os a) (get : Query → Option Digest32) + (observed : ∀ o ∈ os, get o.query = some o.answer) : + SpongefishCurrentCallerGetter.run get p = some a := by + induction ran with + | done a => rfl + | ask q next d tail ih => + have first := observed ⟨q,d⟩ List.mem_cons_self + simp only [SpongefishCurrentCallerGetter.run,first,Option.bind_some] + exact ih (fun o h => observed o (List.mem_cons_of_mem _ h)) + +/-- Lookup returns a literal answer, even when a coordinate occurs repeatedly. +Only equality of its observed full replies matters; no oracle is run here. -/ +theorem lookup_literal (os : List Observation) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) (d : Digest32) + (same : ∀ o ∈ os, o.query = .construction q valid → o.answer = d) + (present : ∃ o ∈ os, o.query = .construction q valid) : + SpongefishCurrentCallerGetter.lookup q os = some d := by + induction os with + | nil => simp at present + | cons o os ih => + have tail := ih (fun x h => same x (List.mem_cons_of_mem _ h)) + cases query : o.query with + | primitive purpose input => + simp only [SpongefishCurrentCallerGetter.lookup,query] + apply tail + obtain ⟨x,member,equal⟩ := present + rcases List.mem_cons.mp member with rfl | member + · rw [query] at equal + cases equal + · exact ⟨x,member,equal⟩ + | construction other proof => + simp only [SpongefishCurrentCallerGetter.lookup,query] + split + · rename_i equal + subst other + exact congrArg some (same o List.mem_cons_self query) + · rename_i different + apply tail + obtain ⟨x,member,equal⟩ := present + rcases List.mem_cons.mp member with rfl | member + · rw [query] at equal + cases equal + exact False.elim (different rfl) + · exact ⟨x,member,equal⟩ + +/-- The literal ideal construction answer is recoverable from the full public +view, with its bounded key, irrespective of ordinary simulator work or abort. -/ +theorem ideal_observed_getter {Q : Nat} {Seed State A : Type} + (sim : Simulator Q Seed State) (ro : RawKey Q → Digest32) (iv : Digest32) + (state : State) (p : Program A) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining p) (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (d : Digest32) + (present : (⟨.construction q valid,d⟩ : Observation) ∈ + (runIdeal sim ro iv state p remaining cap counted).view.observations) : + ∃ work : pathCost q ≤ Q, + d = ro (constructionKey Q iv q work) ∧ + SpongefishCurrentCallerGetter.raw iv + (runIdeal sim ro iv state p remaining cap counted).view.observations + (constructionKey Q iv q work) = some d := by + obtain ⟨work,answer⟩ := PCSBCSIdealConstructionAnswers.construction_observations + sim ro iv state p remaining cap counted q valid d present + refine ⟨work,answer,?_⟩ + rw [SpongefishCurrentCallerGetter.raw_construction iv _ q valid work] + apply lookup_literal _ q valid d _ ⟨_,present,rfl⟩ + intro o member equal + have literal : (⟨.construction q valid,o.answer⟩ : Observation) ∈ + (runIdeal sim ro iv state p remaining cap counted).view.observations := by + have observation : o = ⟨.construction q valid,o.answer⟩ := by + cases o + simp_all + exact observation ▸ member + obtain ⟨otherWork,otherAnswer⟩ := PCSBCSIdealConstructionAnswers.construction_observations + sim ro iv state p remaining cap counted q valid o.answer literal + exact otherAnswer.trans answer.symm + +#print axioms real_runs +#print axioms ideal_runs +#print axioms bind_runs +#print axioms observation_cap +#print axioms actual_getter +#print axioms lookup_literal +#print axioms ideal_observed_getter +#print axioms run_observed +end Whir.SpongefishCurrentReplayProvenance diff --git a/verification/whir/Whir/SpongefishCurrentSourceCallerOriginal.lean b/verification/whir/Whir/SpongefishCurrentSourceCallerOriginal.lean new file mode 100644 index 000000000..406bca197 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentSourceCallerOriginal.lean @@ -0,0 +1,591 @@ +import Whir.SpongefishCurrentAbsorbedPrefix +import Whir.SpongefishCurrentCallerGetter +import Whir.AnchoredSourceCaller +import Whir.PCSBCSCallerBinding + +/-! Current #607 original-statement parser/preparation, pinned to +75d4562bde1efe296b4e32d2a195fdfc232b3ead. The deployed parser here is raw32: +the bounded raw-key suffix decoder enumerates at most four records. No trusted +saved record, historical record-byte clone, or supplied decoded claims enter it. +The unchanged logical CPU/rec payload interpreter is reused after current byte +transport. Source byte positions, the literal instance prefix and nonceLE8 are +retained by the existing initialized byte-mode compiler. + +Scope: deterministic parser and physical *byte replay* transport, not the whole +native caller equation machine. Public layout metadata must describe the actual +caller; ProductionLayout geometry is explicit in the geometry theorem. The +shared payload's range-only offset semantics are unchanged. Current stack.rs +Statement::check additionally enforces alignment (155-157,207,214); this parser +does not prove that native guard join or extend a lower-level range-only API's +acceptance to malformed offsets. Preparation rejects invalid geometry. The +supported tape has individual E192 reads/draws and positive PoW of at most 64 bits. +Nonce transport is parsed, but PoW/equation acceptance is NOT asserted. The +bijective codec hand-port does not prove Rust's malformed-field/poison behavior. +Read/draw replay errors retain their reached cursor; semantic/header/payload +rejection is Option none and does not assert a native failure cursor. Rows and +Aeneas equivalence, and original-capture-to-binding native joins remain outside +this parser slice. -/ +namespace Whir.SpongefishCurrentSourceCallerOriginal +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishSessionAdapter SpongefishRecordBindingParser +open WHIRCallerClaims PCSBCSCallerBinding +set_option autoImplicit false +set_option maxRecDepth 10000 + +deriving instance DecidableEq for WireKind +deriving instance DecidableEq for SourceEvent + +abbrev Payload := List RingPCSGame.FamilyClaim × Array RingPCSGame.PointClaim + +/-- No historical Scalar24 nonce is absorbed. Its logical token's unused value +is zero; the actual nonce read/bind remains eight literal little-endian bytes. -/ +def shapeCalls : List WHIRCallerShape.EventShape → Option (List Call) + | [] => some [] + | .absorb n :: rest => if n = 24 then + (shapeCalls rest).map (.read .scalar :: ·) else none + | .squeeze n :: rest => if n = 24 then + (shapeCalls rest).map (.draw .fold :: ·) else none + | .nonce bits :: rest => if 0 < bits ∧ bits ≤ 64 then + (shapeCalls rest).map ([.draw .positivePow,.read .nonce] ++ ·) else none + + def preludeShape (layout : CallerLayout) : List WHIRCallerShape.EventShape := + AnchoredSourceCaller.reads (rootScalarCount layout-2) + + def payloadShape (layout : CallerLayout) : List WHIRCallerShape.EventShape := + (WHIRCallerClaims.callerShape layout).drop (rootScalarCount layout) + + def calls (layout : CallerLayout) (r : Record) : Option (List Call) := do + let before ← shapeCalls (preludeShape layout) + let payload ← shapeCalls (payloadShape layout) + pure (before ++ [.read .scalar,.read .scalar,.read .scalar,.read .root, + .draw (.anchor (r.shape.logN-1)),.read .scalar] ++ payload ++ + (messages r).map (fun message => .read message.1)) + + def scalar (bytes : List Byte) : Option E := do + let (value,rest) ← scalarCodec.parse bytes + if rest = [] then some value else none + + def tokens : List WHIRCallerShape.EventShape → List SourceEvent → + Option (List CallerToken × List SourceEvent) + | [], events => some ([],events) + | .absorb n :: shape, .prover .scalar bytes :: events => do + if n ≠ 24 then none else do + let value ← scalar bytes + let (tail,rest) ← tokens shape events + pure (.sent value :: tail,rest) + | .squeeze n :: shape, .verifier bytes :: events => do + if n ≠ 24 then none else do + let value ← scalar bytes + let (tail,rest) ← tokens shape events + pure (.draw value :: tail,rest) + | .nonce bits :: shape, .verifier challenge :: .prover .nonce bytes :: events => do + if ¬ (0 < bits ∧ bits ≤ 64) ∨ challenge.length ≠ 32 then none else do + let (_,after) ← nonceCodec.parse bytes + if after ≠ [] then none else do + let (tail,rest) ← tokens shape events + pure (.nonce bits (fun _ => 0) :: tail,rest) + | _, _ => none + + def prelude (layout : CallerLayout) (events : List SourceEvent) : Option (List SourceEvent) := do + let (ts,events) ← tokens (preludeShape layout) events + let (_,rest) ← AnchoredSourceCaller.prelude layout ts + if rest = [] then some events else none + +/-- Root, point and value are read from source events, not metadata. Equality to +one raw-decoded candidate is checked only after the literal receive fields parse. -/ + def header (r : Record) : List SourceEvent → Option (List SourceEvent) + | .prover .scalar a :: .prover .scalar b :: .prover .scalar c :: + .prover .root root :: .verifier point :: .prover .scalar value :: events => do + let (decodedRoot,rest) ← SpongefishCurrentAnchorHeader.decode r.shape (a ++ b ++ c ++ root) + if rest ≠ [] ∨ decodedRoot ≠ r.root then none else do + let (decodedPoint,rest) ← (vectorCodec r.shape.logN).parse point + if rest ≠ [] ∨ List.ofFn decodedPoint ≠ r.point then none else do + let decodedValue ← scalar value + if decodedValue = r.value then some events else none + | _ => none + + theorem header_source (r : Record) (events after : List SourceEvent) + (accepted : header r events = some after) : + ∃ a b c root pointBytes valueBytes, ∃ (point : Fin r.shape.logN → E), + events = .prover .scalar a :: .prover .scalar b :: .prover .scalar c :: + .prover .root root :: .verifier pointBytes :: .prover .scalar valueBytes :: after ∧ + SpongefishCurrentAnchorHeader.decode r.shape (a ++ b ++ c ++ root) = some (r.root,[]) ∧ + (vectorCodec r.shape.logN).parse pointBytes = some (point,[]) ∧ + List.ofFn point = r.point ∧ scalar valueBytes = some r.value := by + unfold header at accepted + split at accepted + · rename_i a b c root pointBytes valueBytes tail + obtain ⟨⟨decodedRoot,rest⟩,rootEq,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · contradiction + · rename_i rootGuards + have rootFields : rest = [] ∧ decodedRoot = r.root := by + simpa only [not_or,ne_eq,not_not] using rootGuards + obtain ⟨⟨point,rest⟩,pointEq,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · contradiction + · rename_i pointGuards + have pointFields : rest = [] ∧ List.ofFn point = r.point := by + simpa only [not_or,ne_eq,not_not] using pointGuards + obtain ⟨value,valueEq,accepted⟩ := Option.bind_eq_some_iff.mp accepted + split at accepted + · rename_i valueFields + cases Option.some.inj accepted + exact ⟨a,b,c,root,pointBytes,valueBytes,point,rfl, + by simpa only [rootFields.1,rootFields.2] using rootEq, + by simpa only [pointFields.1] using pointEq,pointFields.2, + by simpa only [valueFields] using valueEq⟩ + · contradiction + · contradiction + + def receiveEvents (r : Record) (pointBytes : List Byte) : List SourceEvent := + (SpongefishCurrentAnchorHeader.fields r.shape r.root).map + (fun message => .prover message.1 message.bytes) ++ + [.verifier pointBytes,.prover .scalar (scalarCodec.bytes r.value)] + + theorem header_encoded (r : Record) (valid : r.shape.Valid) + (point : Fin r.shape.logN → E) (pointEq : List.ofFn point = r.point) + (after : List SourceEvent) : + header r (receiveEvents r ((vectorCodec r.shape.logN).bytes point) ++ after) = some after := by + have encodedHeader := SpongefishCurrentAnchorHeader.decode_encoded r.shape valid r.root [] + simp only [List.append_nil] at encodedHeader + have headerBytes : + scalarCodec.bytes AnchoredHeaderCodec.anchorMarker ++ + scalarCodec.bytes (AnchoredHeaderCodec.shapeScalar r.shape) ++ + scalarCodec.bytes (AnchoredHeaderCodec.lanesScalar r.shape) ++ rootCodec.bytes r.root = + SpongefishCurrentAnchorHeader.bytes r.shape r.root := by + simp [SpongefishCurrentAnchorHeader.bytes,commitPrefix,constants,scalarsBytes, + scalarBytes,rawRoot,Codec.bytes,scalarCodec,rootCodec] + change (do + let (root,rest) ← SpongefishCurrentAnchorHeader.decode r.shape + (scalarCodec.bytes AnchoredHeaderCodec.anchorMarker ++ + scalarCodec.bytes (AnchoredHeaderCodec.shapeScalar r.shape) ++ + scalarCodec.bytes (AnchoredHeaderCodec.lanesScalar r.shape) ++ rootCodec.bytes r.root) + if rest ≠ [] ∨ root ≠ r.root then none else do + let (point',rest) ← (vectorCodec r.shape.logN).parse ((vectorCodec r.shape.logN).bytes point) + if rest ≠ [] ∨ List.ofFn point' ≠ r.point then none else do + let value ← scalar (scalarCodec.bytes r.value) + if value = r.value then some after else none) = some after + have pointRead := Codec.parse_append (vectorCodec r.shape.logN) point [] + have valueRead := Codec.parse_append scalarCodec r.value [] + simp only [List.append_nil] at pointRead valueRead + rw [headerBytes,encodedHeader] + simp [pointRead,valueRead,pointEq,scalar] + +/-- Successful actual receive supplies the very bytes the current parser uses. +The point, root and value are consequences of receive, never input certificates. -/ + theorem header_from_receive (c : Compression) (before received : Cursor) + (shape : AnchoredHeaderCodec.Shape) (r : Record) + (accepted : SpongefishCurrentCommitmentReceive.receive c before shape = some (received,r)) + (after : List SourceEvent) : + ∃ receivedHeader sampled bytes, + SpongefishCurrentAnchorHeader.readHeader c before shape = some (receivedHeader,r.root) ∧ + squeezeGroup c receivedHeader (.anchor (shape.logN-1)) = .ok (sampled,bytes) ∧ + read c sampled .scalar = some (received,r.value) ∧ + header r (receiveEvents r bytes ++ after) = some after := by + obtain ⟨shapeEq,_,_,receivedHeader,sampled,bytes,point,readHeader,drawn,encoded,pointEq,readValue⟩ := + SpongefishCurrentCommitmentReceive.receive_retains c before received shape r accepted + have valid := ((SpongefishCurrentAnchorHeader.readHeader_exact + c before receivedHeader shape r.root).mp readHeader).1 + refine ⟨receivedHeader,sampled,bytes,readHeader,drawn,readValue,?_⟩ + subst shape + rw [encoded] + exact header_encoded r valid point pointEq.symm after + + def payload (layout : CallerLayout) (events : List SourceEvent) : + Option (Payload × List SourceEvent) := do + let (ts,events) ← tokens (payloadShape layout) events + let (claims,rest) ← AnchoredSourceCaller.payload layout ts + if rest = [] then some (claims,events) else none + + def bindingEvents (r : Record) : List SourceEvent := + (messages r).map (fun message => .prover message.1 message.bytes) + + def parseEvents (layout : CallerLayout) (r : Record) (events : List SourceEvent) : Option Payload := do + if r.shape ≠ AnchoredSourceCaller.shape layout then none else do + let events ← prelude layout events + let events ← header r events + let (claims,events) ← payload layout events + if events = bindingEvents r then some claims else none + + def indexedFamily (claims : Payload) : Fin claims.1.length → RingPCSGame.FamilyClaim := + fun j => claims.1[j] + + def prepare (p : ParameterBounds.Profile) (r : Record) (claims : Payload) : + Option (CallerInput p) := do + if familyCap : claims.1.length ≤ 2^64 then + if claimCap : claims.2.size + 2 ≤ 2^64 then do + let prepared ← OriginalClaimsChecker.prepare (ParameterBounds.config p) r.shape.lanes + (indexedFamily claims) claims.2 r.point.toArray r.value + pure ⟨r.shape.lanes,claims.1.length,indexedFamily claims,claims.2, + r.point.toArray,r.value,prepared,familyCap,claimCap⟩ + else none + else none + +/-- The initialized session records one public instance before any caller +traffic. Reject other event shapes rather than erasing arbitrary events. -/ +def callerEvents : List SourceEvent → Option (List SourceEvent) + | .publicBytes _ :: events => some events + | _ => none + +/-- Semantic data, including raw errors and reached transport, is preserved +before any original-claims preparation. -/ + def finish (p : ParameterBounds.Profile) (layout : CallerLayout) (q : Coordinate) (r : Record) + (result : Except (SpongefishCurrentMixedModeCompiler.Data × + SpongefishCurrentPrimitiveEventCompiler.ReplayError) SpongefishCurrentMixedModeCompiler.Data) : + Option (CallerInput p) := do + let data ← match result with | .error _ => none | .ok data => some data + if (close data.pending).core.history ≠ q.history ∨ data.narg ≠ [] then none else do + let events ← callerEvents data.events + let claims ← parseEvents layout r events + prepare p r claims + + def historyBytes (q : Coordinate) : List Byte := + ((SpongefishCurrentAbsorbedPrefix.parse q.history).map + SpongefishCurrentAbsorbedPrefix.Prefix.bytes).getD [] + +/-- The exact current instance prefix is caller metadata, not an invented seed. +Non-byte history, nonzero historical statement seeds and non-output terminals +are outside this current ordinary-byte grammar. -/ + def supported (q : Coordinate) (instanceBytes : List Byte) : Bool := + match SpongefishCurrentAbsorbedPrefix.parse q.history with + | none => false + | some source => !instanceBytes.isEmpty && + (match q.terminal with | .output _ => true | _ => false) && + decide (source.bytes.take instanceBytes.length = instanceBytes) + + def replay {Q : Nat} (layout : CallerLayout) (q : Coordinate) (r : Record) + (instanceBytes : List Byte) (observations : List Observation) : + Option SpongefishCurrentMixedModeCompiler.Result := do + if supported q instanceBytes = false then none else do + let tape ← calls layout r + let initial := SpongefishCurrentInitializedMode.initial q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) [] + SpongefishCurrentCallerGetter.run (SpongefishCurrentCallerGetter.answer (Q := Q) observations) + (SpongefishCurrentMixedModeCompiler.replayProgram initial tape) + + def candidate {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) + (q : Coordinate) (r : Record) (instanceBytes : List Byte) (observations : List Observation) : + Option (CallerInput p) := do + let result ← replay (Q := Q) layout q r instanceBytes observations + finish p layout q r (SpongefishCurrentMixedModeCompiler.eraseResult result) + +/-- Keep every bounded candidate, including ambiguity; do not silently select +an unproved unique suffix. This is the complete dependent prepared result. -/ + def original {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) (iv : Digest32) + (key : RawKey Q) (instanceBytes : List Byte) (observations : List Observation) : + List (CallerInput p) := + match WHIRHeaderRoots.decodeRaw iv key with + | none => [] + | some q => (SpongefishCurrentRecordModeCapture.rawRecords + (AnchoredSourceCaller.shape layout) iv key).filterMap + (fun r => candidate (Q := Q) p layout q r instanceBytes observations) + + theorem original_length {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) + (iv : Digest32) (key : RawKey Q) (instanceBytes : List Byte) (observations : List Observation) : + (original p layout iv key instanceBytes observations).length ≤ 4 := by + unfold original + split + · simp + · exact (List.length_filterMap_le _ _).trans + (SpongefishCurrentRecordModeCapture.rawRecords_length _ _ _) + + theorem original_same_view {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) + (iv : Digest32) (a b : RawKey Q) (instanceA instanceB : List Byte) + (observationsA observationsB : List Observation) (keys : a = b) + (instances : instanceA = instanceB) (observed : observationsA = observationsB) : + original p layout iv a instanceA observationsA = original p layout iv b instanceB observationsB := by + cases keys; cases instances; cases observed; rfl + + theorem prepare_exact (p : ParameterBounds.Profile) (r : Record) (claims : Payload) + (input : CallerInput p) (accepted : prepare p r claims = some input) : + input.lanes = r.shape.lanes ∧ input.anchorPoint = r.point.toArray ∧ input.anchorValue = r.value ∧ + ∃ (fc : claims.1.length ≤ 2^64) (cc : claims.2.size + 2 ≤ 2^64) + (prepared : OriginalClaimsChecker.Prepared (ParameterBounds.config p) r.shape.lanes + claims.1.length (indexedFamily claims) claims.2 r.point.toArray r.value), + OriginalClaimsChecker.prepare (ParameterBounds.config p) r.shape.lanes (indexedFamily claims) + claims.2 r.point.toArray r.value = some prepared ∧ + input = ⟨r.shape.lanes,claims.1.length,indexedFamily claims,claims.2,r.point.toArray, + r.value,prepared,fc,cc⟩ := by + unfold prepare at accepted + split at accepted + next fc => + split at accepted + next cc => + obtain ⟨prepared,computed,equal⟩ := Option.bind_eq_some_iff.mp accepted + cases Option.some.inj equal + exact ⟨rfl,rfl,rfl,fc,cc,prepared,computed,rfl⟩ + next => cases accepted + next => cases accepted + + theorem prepare_computed (p : ParameterBounds.Profile) (r : Record) (claims : Payload) + (input : CallerInput p) (accepted : prepare p r claims = some input) : + OriginalClaimsChecker.prepare (ParameterBounds.config p) input.lanes input.family input.points + input.anchorPoint input.anchorValue = some input.prepared := by + obtain ⟨_,_,_,fc,cc,prepared,computed,rfl⟩ := prepare_exact p r claims input accepted + exact computed + + theorem payload_geometry (model : WHIRCallerSupport.ProductionLayout) + (events after : List SourceEvent) (claims : Payload) + (accepted : payload model.layout events = some (claims,after)) : + WHIRCallerGeometry.PayloadValid + (fun i d => WHIRCallerSupport.columnFits model.sources i d = true) + (fun o d => WHIRCallerSupport.ringFits model.sources o d = true) + (callerPlacements model.layout) claims := by + unfold payload at accepted + obtain ⟨⟨ts,remaining⟩,_,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + obtain ⟨⟨parsed,rest⟩,parsedEq,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · cases Option.some.inj accepted + exact AnchoredSourceCaller.payload_geometry _ _ + (WHIRCallerSupport.columnFits_mono model.sources) (WHIRCallerSupport.ringFits_mono model.sources) + model.layout model.geometry ts claims rest parsedEq + · contradiction + + theorem header_rejected (r : Record) (events : List SourceEvent) + (missing : header r events = none) (layout : CallerLayout) (initial : List SourceEvent) + (before : prelude layout initial = some events) : parseEvents layout r initial = none := by + simp [parseEvents,before,missing] + + theorem missing_reply {A : Type} (q : Query) (next : Digest32 → Program A) + (get : Query → Option Digest32) (missing : get q = none) : + SpongefishCurrentCallerGetter.run get (.ask q next) = none := by + simp [SpongefishCurrentCallerGetter.run,missing] + +/-- Physical source replay is independent of the public getter. This retains the +entire cursor/error transport of actualReplay before preparation. -/ + def physicalReplay (C : PrimitiveOracle) (iv : Digest32) (layout : CallerLayout) + (q : Coordinate) (r : Record) (instanceBytes : List Byte) : + Option (Except (SpongefishCurrentMixedModeCompiler.Data × + SpongefishCurrentPrimitiveEventCompiler.ReplayError) SpongefishCurrentMixedModeCompiler.Data) := do + if supported q instanceBytes = false then none else do + let tape ← calls layout r + let actual := SpongefishCurrentObservedSessionEntry.cursor q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) [] + (absorb (compressionOf C) (init (compressionOf C) iv q.history.domain) instanceBytes) + pure (SpongefishCurrentMixedModeCompiler.forgetResult + (SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) actual tape)) + + def physicalCandidate (C : PrimitiveOracle) (iv : Digest32) (p : ParameterBounds.Profile) + (layout : CallerLayout) (q : Coordinate) (r : Record) (instanceBytes : List Byte) : + Option (CallerInput p) := do + let result ← physicalReplay C iv layout q r instanceBytes + finish p layout q r result + +/-- Exact successes AND failures, with full byte transport. The hypothesis is +only coverage of actually requested public construction replies, not decoded +caller fields, checker success, or saved-record equality. -/ + theorem candidate_physical {Q : Nat} (C : PrimitiveOracle) (iv : Digest32) + (p : ParameterBounds.Profile) (layout : CallerLayout) (q : Coordinate) (r : Record) + (instanceBytes : List Byte) (observations : List Observation) + (observed : ∀ tape, calls layout r = some tape → + ∀ o ∈ (runReal C iv (SpongefishCurrentMixedModeCompiler.replayProgram + (SpongefishCurrentInitializedMode.initial q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) []) tape)).view.observations, + SpongefishCurrentCallerGetter.answer (Q := Q) observations o.query = some o.answer) : + candidate (Q := Q) p layout q r instanceBytes observations = + physicalCandidate C iv p layout q r instanceBytes := by + unfold candidate replay physicalCandidate physicalReplay + by_cases invalid : supported q instanceBytes = false + · simp [invalid] + · simp only [invalid] + cases tapeEq : calls layout r with + | none => rfl + | some tape => + dsimp only [Bind.bind,Option.bind] + rw [SpongefishCurrentCallerGetter.run_real C iv _ _ (observed tape tapeEq)] + have transport := SpongefishCurrentMixedModeCompiler.replay_real C iv + (SpongefishCurrentInitializedMode.initial q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) []) + (SpongefishCurrentObservedSessionEntry.cursor q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) [] + (absorb (compressionOf C) (init (compressionOf C) iv q.history.domain) instanceBytes)) + rfl (session_bridge (compressionOf C) iv q.history.domain instanceBytes) + (by intro other d found; cases found) tape + simp [transport] + + def physicalOriginal {Q : Nat} (C : PrimitiveOracle) (p : ParameterBounds.Profile) + (layout : CallerLayout) (iv : Digest32) (key : RawKey Q) (instanceBytes : List Byte) : + List (CallerInput p) := + match WHIRHeaderRoots.decodeRaw iv key with + | none => [] + | some q => (SpongefishCurrentRecordModeCapture.rawRecords + (AnchoredSourceCaller.shape layout) iv key).filterMap + (fun r => physicalCandidate C iv p layout q r instanceBytes) + +/-- The complete prepared result list, not merely decoded fields, transports. +This equality covers unsupported geometry, bad headers, missing transport, +leftovers, failed replay and failed OriginalClaimsChecker preparation. -/ + theorem original_physical {Q : Nat} (C : PrimitiveOracle) (p : ParameterBounds.Profile) + (layout : CallerLayout) (iv : Digest32) (key : RawKey Q) (instanceBytes : List Byte) + (observations : List Observation) + (observed : ∀ q, WHIRHeaderRoots.decodeRaw iv key = some q → + ∀ r ∈ SpongefishCurrentRecordModeCapture.rawRecords + (AnchoredSourceCaller.shape layout) iv key, + ∀ tape, calls layout r = some tape → + ∀ o ∈ (runReal C iv (SpongefishCurrentMixedModeCompiler.replayProgram + (SpongefishCurrentInitializedMode.initial q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) []) tape)).view.observations, + SpongefishCurrentCallerGetter.answer (Q := Q) observations o.query = some o.answer) : + original p layout iv key instanceBytes observations = + physicalOriginal C p layout iv key instanceBytes := by + unfold original physicalOriginal + cases decoded : WHIRHeaderRoots.decodeRaw iv key with + | none => rfl + | some q => + apply List.filterMap_congr + intro r member + exact candidate_physical C iv p layout q r instanceBytes observations + (observed q decoded r member) + + theorem original_getter_congr {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) + (iv : Digest32) (key : RawKey Q) (instanceBytes : List Byte) (a b : List Observation) + (agree : ∀ q, SpongefishCurrentCallerGetter.bounded (Q := Q) a q = + SpongefishCurrentCallerGetter.bounded (Q := Q) b q) : + original p layout iv key instanceBytes a = original p layout iv key instanceBytes b := by + have getter : SpongefishCurrentCallerGetter.answer (Q := Q) a = + SpongefishCurrentCallerGetter.answer (Q := Q) b := by + funext query + cases query with + | primitive => rfl + | construction q valid => exact agree q + simp only [original,candidate,replay,getter] + + theorem parseEvents_geometry (model : WHIRCallerSupport.ProductionLayout) (r : Record) + (events : List SourceEvent) (claims : Payload) + (accepted : parseEvents model.layout r events = some claims) : + WHIRCallerGeometry.PayloadValid + (fun i d => WHIRCallerSupport.columnFits model.sources i d = true) + (fun o d => WHIRCallerSupport.ringFits model.sources o d = true) + (callerPlacements model.layout) claims := by + unfold parseEvents at accepted + split at accepted + · contradiction + · obtain ⟨afterPrelude,_,accepted⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨afterHeader,_,accepted⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨⟨parsed,remaining⟩,parsedEq,accepted⟩ := Option.bind_eq_some_iff.mp accepted + dsimp only at accepted + split at accepted + · cases Option.some.inj accepted + exact payload_geometry model afterHeader remaining claims parsedEq + · contradiction + + theorem finish_exact (p : ParameterBounds.Profile) (layout : CallerLayout) (q : Coordinate) + (r : Record) + (result : Except (SpongefishCurrentMixedModeCompiler.Data × + SpongefishCurrentPrimitiveEventCompiler.ReplayError) SpongefishCurrentMixedModeCompiler.Data) + (input : CallerInput p) (accepted : finish p layout q r result = some input) : + ∃ data claims, result = .ok data ∧ (close data.pending).core.history = q.history ∧ + data.narg = [] ∧ (∃ instanceBytes events, + data.events = .publicBytes instanceBytes :: events ∧ + parseEvents layout r events = some claims) ∧ + prepare p r claims = some input := by + cases result with + | error error => simp [finish] at accepted + | ok data => + dsimp only [finish,Bind.bind,Option.bind] at accepted + split at accepted + · contradiction + · rename_i guards + obtain ⟨events,instanceRead,accepted⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨claims,parsed,prepared⟩ := Option.bind_eq_some_iff.mp accepted + have valid : (close data.pending).core.history = q.history ∧ data.narg = [] := by + simpa only [not_or,ne_eq,not_not] using guards + have literal : ∃ instanceBytes, data.events = .publicBytes instanceBytes :: events := by + cases sourceEq : data.events with + | nil => simp [callerEvents,sourceEq] at instanceRead + | cons event rest => + cases event <;> simp [callerEvents,sourceEq] at instanceRead + subst events + exact ⟨_,rfl⟩ + obtain ⟨instanceBytes,literal⟩ := literal + exact ⟨data,claims,rfl,valid.1,valid.2,⟨instanceBytes,events,literal,parsed⟩,prepared⟩ + + theorem candidate_prepared {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) + (q : Coordinate) (r : Record) (instanceBytes : List Byte) (observations : List Observation) + (input : CallerInput p) + (accepted : candidate (Q := Q) p layout q r instanceBytes observations = some input) : + input.lanes = r.shape.lanes ∧ input.anchorPoint = r.point.toArray ∧ input.anchorValue = r.value ∧ + OriginalClaimsChecker.prepare (ParameterBounds.config p) input.lanes input.family input.points + input.anchorPoint input.anchorValue = some input.prepared := by + obtain ⟨result,_,accepted⟩ := Option.bind_eq_some_iff.mp accepted + obtain ⟨_,claims,_,_,_,_,prepared⟩ := finish_exact p layout q r _ input accepted + obtain ⟨lanes,point,value,_,_,_,_,_⟩ := prepare_exact p r claims input prepared + exact ⟨lanes,point,value,prepare_computed p r claims input prepared⟩ + + theorem original_exact {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) + (iv : Digest32) (key : RawKey Q) (instanceBytes : List Byte) (observations : List Observation) + (input : CallerInput p) (member : input ∈ original p layout iv key instanceBytes observations) : + ∃ q r, WHIRHeaderRoots.decodeRaw iv key = some q ∧ + r ∈ SpongefishCurrentRecordModeCapture.rawRecords (AnchoredSourceCaller.shape layout) iv key ∧ + candidate (Q := Q) p layout q r instanceBytes observations = some input ∧ + input.lanes = r.shape.lanes ∧ input.anchorPoint = r.point.toArray ∧ input.anchorValue = r.value ∧ + OriginalClaimsChecker.prepare (ParameterBounds.config p) input.lanes input.family input.points + input.anchorPoint input.anchorValue = some input.prepared := by + unfold original at member + cases decoded : WHIRHeaderRoots.decodeRaw iv key with + | none => simp [decoded] at member + | some q => + rw [decoded] at member + obtain ⟨r,inRecords,parsed⟩ := List.mem_filterMap.mp member + exact ⟨q,r,rfl,inRecords,parsed, + candidate_prepared p layout q r instanceBytes observations input parsed⟩ + + theorem wrong_instance_rejected {Q : Nat} (p : ParameterBounds.Profile) (layout : CallerLayout) + (q : Coordinate) (r : Record) (instanceBytes : List Byte) (observations : List Observation) + (unsupported : supported q instanceBytes = false) : + candidate (Q := Q) p layout q r instanceBytes observations = none := by + simp [candidate,replay,unsupported] + +/-- Native receive+binding supplies suffix membership without any record-byte +certificate. Every advertised anchor field is then a literal receive result. +`SpongefishCurrentAcceptedJoin.accepted_original` joins the accepted payload +subrun to `calls`; native equation acceptance is not asserted here. -/ + theorem receive_binding_candidate {Q : Nat} (c : Compression) (iv : Digest32) + (before received payloadEnd bound : Cursor) (shape : AnchoredHeaderCodec.Shape) (r : Record) + (receivedEq : SpongefishCurrentCommitmentReceive.receive c before shape = some (received,r)) + (bindingEq : verify c payloadEnd r = some bound) (valid : r.shape.Valid) + (pending : r.context.pending.length ≤ 64) + (framed : SpongefishCurrentModeQueries.FrameDomain bound.pending) (block : Nat) + (blockBound : block < 2^44) + (work : pathCost (SpongefishCurrentModeQueries.coordinate bound.pending block) ≤ Q) : + r ∈ SpongefishCurrentRecordModeCapture.rawRecords shape iv + (constructionKey Q iv (SpongefishCurrentModeQueries.coordinate bound.pending block) work) ∧ + r.context = capture before.state ∧ r.point.length = shape.logN ∧ + ∃ header sampled bytes, ∃ (point : Fin shape.logN → E), + SpongefishCurrentAnchorHeader.readHeader c before shape = some (header,r.root) ∧ + squeezeGroup c header (.anchor (shape.logN-1)) = .ok (sampled,bytes) ∧ + bytes = (vectorCodec shape.logN).bytes point ∧ r.point = List.ofFn point ∧ + read c sampled .scalar = some (received,r.value) := by + obtain ⟨shapeEq,contextEq,pointLength,header,sampled,bytes,point,readHeader,drawn,encoded,pointEq,readValue⟩ := + SpongefishCurrentCommitmentReceive.receive_retains c before received shape r receivedEq + refine ⟨?_,contextEq,pointLength,header,sampled,bytes,point,?_⟩ + · rw [← shapeEq] + exact SpongefishCurrentRecordModeCapture.verified_raw_record c payloadEnd bound r bindingEq + valid pending (by rw [shapeEq]; exact pointLength) block iv framed blockBound work + · exact ⟨readHeader,drawn,encoded,pointEq,readValue⟩ + +#print axioms original_length +#print axioms original_same_view +#print axioms prepare_exact +#print axioms prepare_computed +#print axioms payload_geometry +#print axioms header_rejected +#print axioms missing_reply +#print axioms candidate_physical +#print axioms receive_binding_candidate +#print axioms original_physical +#print axioms original_getter_congr +#print axioms parseEvents_geometry +#print axioms finish_exact +#print axioms candidate_prepared +#print axioms original_exact +#print axioms wrong_instance_rejected +#print axioms header_source +#print axioms header_encoded +#print axioms header_from_receive +end Whir.SpongefishCurrentSourceCallerOriginal diff --git a/verification/whir/Whir/SpongefishOrdinarySession.lean b/verification/whir/Whir/SpongefishOrdinarySession.lean index af93030bc..a4bd67f68 100644 --- a/verification/whir/Whir/SpongefishOrdinarySession.lean +++ b/verification/whir/Whir/SpongefishOrdinarySession.lean @@ -20,6 +20,10 @@ def instructions (cv : Digest32) : List DuplexEncoding.Instruction → Program D | i :: rest => .ask (.primitive .auxiliary ⟨cv,i.1,i.2,true⟩) (fun answer => instructions answer rest) +/- Reply materialization belongs to the data-valued executable interpreters, +not this instruction syntax: duplicating it here would snapshot every ordinary +answer twice. The same stored reply becomes the next input and final result. -/ + theorem instructions_counted (cv : Digest32) (xs : List DuplexEncoding.Instruction) : Counts xs.length (instructions cv xs) := by induction xs generalizing cv with diff --git a/verification/whir/Whir/SpongefishPCSRoundFrames.lean b/verification/whir/Whir/SpongefishPCSRoundFrames.lean index 9586ff2cb..b20fe33cc 100644 --- a/verification/whir/Whir/SpongefishPCSRoundFrames.lean +++ b/verification/whir/Whir/SpongefishPCSRoundFrames.lean @@ -1,4 +1,5 @@ import Whir.SpongefishPowAdapter +import Whir.PublicMerkleProgram import Whir.RawOracleCoupling /-! Current #607 PCS round/cursor bridge, source-inspected at @@ -758,6 +759,24 @@ def powCursor (C : DuplexModeGame.PrimitiveOracle) (cur : Cursor) (bits : Fin 64 let challenge : Digest32 := fun i => bytes[i.val]?.getD 0 pure (next,SpongefishPowAdapter.clears bits (SpongefishPowAdapter.trial C challenge nonce)) +/-- The PoW predicate consumes the boxed ordinary hash at its Option boundary, +instead of repeatedly entering a function-valued trial hash for word bytes. -/ +def powCursorStored (C : DuplexModeGame.PrimitiveOracle) (cur : Cursor) (bits : Fin 64) : + Option (Cursor × Bool) := + if bits.val = 0 then some (cur,true) else + match squeezeGroup (DuplexModeGame.compressionOf C) cur .positivePow with + | .error _ => none + | .ok (challenged,bytes) => do + let (next,nonce) ← read (DuplexModeGame.compressionOf C) challenged .nonce + let challenge : Digest32 := fun i => bytes[i.val]?.getD 0 + PublicMerkleProgram.withHashStored C (SpongefishPowAdapter.trialBytes challenge nonce) + (fun digest => pure (next,SpongefishPowAdapter.clears bits digest)) + +@[csimp] theorem powCursor_stored : powCursor = powCursorStored := by + funext C cur bits + simp only [powCursor,powCursorStored,PublicMerkleProgram.withHashStored_eq, + SpongefishPowAdapter.trial] + theorem zero_pow_cursor (C : DuplexModeGame.PrimitiveOracle) (cur : Cursor) : powCursor C cur ⟨0,by decide⟩ = some (cur,true) := rfl diff --git a/verification/whir/Whir/SpongefishPowAdapter.lean b/verification/whir/Whir/SpongefishPowAdapter.lean index c78ff894d..652632315 100644 --- a/verification/whir/Whir/SpongefishPowAdapter.lean +++ b/verification/whir/Whir/SpongefishPowAdapter.lean @@ -1,5 +1,5 @@ import Whir.SpongefishSessionAdapter -import Whir.PublicMerkleLog +import Whir.PublicMerkleProgram /-! Hand-ported positive-PoW byte adapter for the current source pin in SpongefishSessionAdapter. The trial uses ordinary BLAKE2s-256, not the old @@ -70,6 +70,24 @@ def check (C : PrimitiveOracle) (s : State) (bits : Fin 64) (nonce : UInt64) : let challenge : Digest32 := fun i => bytes[i.val]?.getD 0 .ok (absorb (compressionOf C) t (nonceBytes nonce),clears bits (trial C challenge nonce)) +/-- The standalone verifier predicate consumes the ordinary boxed hash fold +directly. Its trial wrapper alone can be eta-expanded once per first-word byte. -/ +private def checkStored (C : PrimitiveOracle) (s : State) (bits : Fin 64) + (nonce : UInt64) : Except Error (State × Bool) := + if bits.val = 0 then .ok (s,true) else + match squeeze (compressionOf C) s 32 with + | .error e => .error e + | .ok (t,bytes) => + let challenge : Digest32 := fun i => bytes[i.val]?.getD 0 + PublicMerkleProgram.withHashStored C (trialBytes challenge nonce) (fun digest => + .ok (absorb (compressionOf C) t (nonceBytes nonce),clears bits digest)) + +@[csimp] private theorem check_stored : check = checkStored := by + funext C s bits nonce + simp only [check,checkStored,PublicMerkleProgram.withHashStored_eq,trial] + +#print axioms check_stored + theorem zero_no_event (C : PrimitiveOracle) (s : State) (nonce : UInt64) : check C s ⟨0,by decide⟩ nonce = .ok (s,true) := rfl diff --git a/verification/whir/Whir/SpongefishSessionAdapter.lean b/verification/whir/Whir/SpongefishSessionAdapter.lean index bdf878424..e9f1d58e2 100644 --- a/verification/whir/Whir/SpongefishSessionAdapter.lean +++ b/verification/whir/Whir/SpongefishSessionAdapter.lean @@ -54,6 +54,18 @@ open FiatShamirGame Concrete DuplexRefinement let bs := (squeezeLoop c 32 (finish c (absorb c (init c parameter derivationIV) tag))).2 fun i => bs[i.val]'(by simp only [bs, squeezeLoop_length]; exact i.isLt) + /-- Evaluate the complete ordinary draw before handing its list-backed digest +to a data-valued consumer. A Digest32-returning derivation wrapper alone can +be eta-expanded and repeat initialization and absorption for every byte. -/ + def withDerived {Result : Type} (c : Compression) (parameter : Digest32) + (tag : List Byte) (next : Digest32 → Result) : Result := + let bs := (squeezeLoop c 32 (finish c (absorb c (init c parameter derivationIV) tag))).2 + next (fun i => bs[i.val]'(by simp only [bs,squeezeLoop_length]; exact i.isLt)) + + theorem withDerived_eq {Result : Type} (c : Compression) (parameter : Digest32) + (tag : List Byte) (next : Digest32 → Result) : + withDerived c parameter tag next = next (derive c parameter tag) := rfl + theorem derive_checked (c : Compression) (parameter : Digest32) (tag : List Byte) : squeeze c (absorb c (init c parameter derivationIV) tag) 32 = .ok ((squeezeLoop c 32 (finish c (absorb c (init c parameter derivationIV) tag))).1, @@ -341,11 +353,12 @@ BLAKE2s implementation. Each output line is compared byte-for-byte. -/ let mut lines := ["init|" ++ DuplexCompression.hex (rawRoot (init c parameter root).cv)] for n in [0,1,31,32,63,64,65,129] do let tag : List Byte := (List.range n).map fun i => ⟨i%256, Nat.mod_lt _ (by decide)⟩ - lines := lines ++ ["derive" ++ toString n ++ "|" ++ DuplexCompression.hex (rawRoot (derive c parameter tag))] + lines := lines ++ [withDerived c parameter tag fun session => + "derive" ++ toString n ++ "|" ++ DuplexCompression.hex (rawRoot session)] let tag : List Byte := "607-runtime-fixture".toUTF8.toList.map fun b => ⟨b.toNat%256, Nat.mod_lt _ (by decide)⟩ - let session := derive c parameter tag - let s := absorb c (init c parameter session) (littleWord 0x0102030405060708) + let s := withDerived c parameter tag fun session => + absorb c (init c parameter session) (littleWord 0x0102030405060708) lines := lines ++ ["session|" ++ DuplexCompression.hex (rawRoot s.cv)] let shape : Shape := ⟨3,1,1,2⟩ let value : E := ⟨1,2,3⟩ @@ -363,4 +376,6 @@ BLAKE2s implementation. Each output line is compared byte-for-byte. -/ | .error e => return lines ++ ["error|" ++ reprStr e] | .ok (_,bytes) => return lines ++ ["final32|" ++ DuplexCompression.hex bytes] +#print axioms withDerived_eq + end Whir.SpongefishSessionAdapter diff --git a/verification/whir/Whir/WHIRCallerSource.lean b/verification/whir/Whir/WHIRCallerSource.lean index 0e317dbe6..b5390d949 100644 --- a/verification/whir/Whir/WHIRCallerSource.lean +++ b/verification/whir/Whir/WHIRCallerSource.lean @@ -78,6 +78,22 @@ def sourceFrameTokens (c : Compression) (iv : Digest32) (entry : FramedHistory) tokensFromFrame f (stream c (evalHistory c iv {entry with frames := entry.frames.take i}) 0 (previousConsumed f)) +/-- Share the physical prior-history replay before the cached stream consumes +its CV; a digest-returning replay wrapper can otherwise restart on each byte. -/ +private def sourceFrameTokensStored (c : Compression) (iv : Digest32) + (entry : FramedHistory) (i : Nat) (f : Frame) : Option (List CallerToken) := + if previousConsumed f = 0 then tokensFromFrame f [] else + withHistory c iv {entry with frames := entry.frames.take i} (fun cv => + tokensFromFrame f (stream c cv 0 (previousConsumed f))) + +@[csimp] private theorem sourceFrameTokens_stored : + sourceFrameTokens = sourceFrameTokensStored := by + funext c iv entry i f + simp only [sourceFrameTokens,sourceFrameTokensStored,withHistory_eq] + by_cases empty : previousConsumed f = 0 <;> simp [empty,stream] + +#print axioms sourceFrameTokens_stored + theorem frameTokens_source (c : Compression) (iv : Digest32) (entry : FramedHistory) (answers : Coordinate → Digest32) (observed : ∀ q ∈ callerOutputs entry, answers q = evalCoordinate c iv q) diff --git a/verification/whir/Whir/WHIRModeFinal.lean b/verification/whir/Whir/WHIRModeFinal.lean index 13ba37dd4..5420c5878 100644 --- a/verification/whir/Whir/WHIRModeFinal.lean +++ b/verification/whir/Whir/WHIRModeFinal.lean @@ -106,6 +106,24 @@ def append (ctx : Context) (Q : Nat) (p : Program R) (final : R → Option (Pack def realHistory (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) (ps : List (Packet ctx Q)) : List (Sigma (GroupAnswer ctx Q)) := ps.map (fun p => ⟨.inl p,realPacket ctx Q oracle p⟩) +/-- The packet reader requests exactly blocks, not a capacity or work cap. +Keep each coordinate result boxed while constructing the data-valued history, +then close the packet getter over that array rather than a replay function. -/ +private def realHistoryStored (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (ps : List (Packet ctx Q)) : List (Sigma (GroupAnswer ctx Q)) := + ps.map fun p => + let replies := Array.ofFn (fun i : Fin (RawWHIRKeys.blocks ctx p.val) => + withCoordinate (compressionOf oracle) ctx.iv + (RawWHIRKeys.coordinate ctx p.val i.val) Option.some) + ⟨.inl p,fun i => (replies[i.val]'(by simp [replies])).get (by + simp [replies,withCoordinate_eq])⟩ + +@[csimp] private theorem realHistory_stored : realHistory = realHistoryStored := by + funext ctx Q oracle ps + simp [realHistory,realHistoryStored,withCoordinate_eq] + intro data valid member + rfl + def idealHistory (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) (ps : List (Packet ctx Q)) : List (Sigma (GroupAnswer ctx Q)) := ps.map (fun p => ⟨.inl p,idealPacket ctx Q ro p⟩) @@ -114,6 +132,21 @@ def realCallers (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) (p : Packet qs.map (fun q => ⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property), evalCoordinate (compressionOf oracle) ctx.iv q.val⟩) +/-- Singleton caller replies are also direct reference computations, outside +the mode interpreter's central reply store. -/ +private def realCallersStored (ctx : Context) (Q : Nat) (oracle : PrimitiveOracle) + (p : Packet ctx Q) (qs : List (CallerPosition ctx Q p)) : + List (Sigma (GroupAnswer ctx Q)) := + qs.map fun q => withCoordinate (compressionOf oracle) ctx.iv q.val (fun d => + ⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property),d⟩) + +@[csimp] private theorem realCallers_stored : realCallers = realCallersStored := by + funext ctx Q oracle p qs + simp only [realCallers,realCallersStored,withCoordinate_eq] + +#print axioms realHistory_stored +#print axioms realCallers_stored + def idealCallers (ctx : Context) (Q : Nat) (ro : RawKey Q → Digest32) (p : Packet ctx Q) (qs : List (CallerPosition ctx Q p)) : List (Sigma (GroupAnswer ctx Q)) := qs.map (fun q => ⟨.inr (RawWHIRKeys.callerOutputKey ctx Q p q.val q.property), diff --git a/verification/whir/Whir/WHIRPowProgram.lean b/verification/whir/Whir/WHIRPowProgram.lean index ce629bb10..dc80a8423 100644 --- a/verification/whir/Whir/WHIRPowProgram.lean +++ b/verification/whir/Whir/WHIRPowProgram.lean @@ -15,15 +15,6 @@ variable {R S : Type} def askPow (n : Node) (next : Digest32 → Program R) : Program R := .ask (.primitive .pow n) next -private def askPowStored (n : Node) (next : Digest32 → Program R) : Program R := - .ask (.primitive .pow n) fun answer => - let bytes := Array.ofFn answer - next (fun i => bytes[i.val]'(by simp only [bytes,Array.size_ofFn]; exact i.isLt)) - -@[csimp] theorem askPow_stored : @askPow = @askPowStored := by - funext R n next - simp [askPow,askPowStored] - theorem askPow_counted (n : Node) (next : Digest32 → Program R) (budget : Nat) (after : ∀ d, Counts budget (next d)) : Counts (1+budget) (askPow n next) := by simpa [askPow,Counts,Query.cost] using And.intro (by omega : 1 ≤ 1+budget) after @@ -43,6 +34,15 @@ def passed (digest : Digest32) (bits : Nat) : Bool := def powOK (C : PrimitiveOracle) (base : Digest32) (nonce : Scalar24) (bits : Nat) : Bool := passed (C (powNode base nonce)) bits +/-- The standalone reference predicate bypasses the observed interpreter. -/ +private def powOKStored (C : PrimitiveOracle) (base : Digest32) + (nonce : Scalar24) (bits : Nat) : Bool := + withDigest (C (powNode base nonce)) (fun digest => passed digest bits) + +@[csimp] private theorem powOK_stored : powOK = powOKStored := by + funext C base nonce bits + simp only [powOK,powOKStored,withDigest_eq] + theorem powOK_blake (base : Digest32) (nonce : Scalar24) (bits : Nat) : powOK blake2sOracle base nonce bits = DuplexCompression.powOK base nonce bits := by simp [powOK,passed,powNode,payload,PublicMerkleLog.node,blake2sOracle, @@ -486,4 +486,6 @@ theorem replay_ideal {G : Nat} {Seed SimState : Type} (sim : Simulator G Seed Si some ((runIdeal sim ro iv state p remaining cap counted).view.result,suffix) := replay_runs only (runIdeal_runs sim ro iv state p remaining cap counted) suffix +#print axioms powOK_stored + end Whir.WHIRPowProgram diff --git a/verification/whir/Whir/WHIRROM.lean b/verification/whir/Whir/WHIRROM.lean index 9024a5a2b..8721a24d3 100644 --- a/verification/whir/Whir/WHIRROM.lean +++ b/verification/whir/Whir/WHIRROM.lean @@ -75,6 +75,20 @@ def modeOracle (p : Profile) (compression : DuplexRefinement.Compression) (DuplexRefinement.evalHistory compression iv (DuplexRefinement.closeRun m).history) m.consumed (24 * WHIRHistory.scalarCount q))) +/-- Share the complete prior-history CV before the data-valued codec consumes +the cached stream, rather than re-entering the history through each byte. -/ +def modeOracleStored (p : Profile) (compression : DuplexRefinement.Compression) + (iv domain : Digest32) : TypedFiatShamirGame.Oracle (A := Sample) (query p) := fun key => + let m := beforeModel p domain key + let q := query p (key.statement,key.messages) + DuplexRefinement.withHistory compression iv (DuplexRefinement.closeRun m).history fun cv => + codec q (slices q (DuplexRefinement.stream compression cv + m.consumed (24*WHIRHistory.scalarCount q))) + +@[csimp] theorem modeOracle_stored : modeOracle = modeOracleStored := by + funext p compression iv domain key + simp only [modeOracle,modeOracleStored,DuplexRefinement.withHistory_eq] + /-- This is an equality to the actual checked streaming operation, not a parser or mode-correctness hypothesis. Reachability/limits are checked separately. -/ theorem modeOracle_squeeze (p : Profile) (compression : DuplexRefinement.Compression) diff --git a/verification/whir/lakefile.toml b/verification/whir/lakefile.toml index f233df471..dead10d6d 100644 --- a/verification/whir/lakefile.toml +++ b/verification/whir/lakefile.toml @@ -118,3 +118,11 @@ root = "Whir.SpongefishCurrentAdapterSmoke" [[lean_exe]] name = "spongefishCurrentRecordCodecSmoke" root = "Whir.SpongefishCurrentRecordCodecSmoke" + +[[lean_exe]] +name = "spongefishCurrentCallerSmoke" +root = "Whir.SpongefishCurrentCallerSmoke" + +[[lean_exe]] +name = "pcsbcsSourceRootReferencesSmoke" +root = "Whir.PCSBCSSourceRootReferencesSmoke" From b9a2369ea9c85cb1cc7d097de804b4f23c923b46 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 13:45:22 +0100 Subject: [PATCH 23/28] proof: current opening adapter, distributional source join and basic full-prefix BCS endpoint --- verification/whir/README.md | 12 +- verification/whir/Whir.lean | 4 + .../Whir/SpongefishCurrentBCSKnowledge.lean | 487 +++++++++++ .../SpongefishCurrentOpeningAcceptance.lean | 790 ++++++++++++++++++ .../Whir/SpongefishCurrentRoundPackets.lean | 224 +++++ ...pongefishCurrentSourceJoinProbability.lean | 191 +++++ 6 files changed, 1705 insertions(+), 3 deletions(-) create mode 100644 verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean create mode 100644 verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRoundPackets.lean create mode 100644 verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index f4c3366d8..12b1c4bdf 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -154,6 +154,12 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentSourceCallerOriginal` is the deterministic current original-statement parser: for a raw construction key it enumerates at most four raw records, replays the caller tape `calls layout r` on the key's own history bytes using only public construction replies, and prepares the original claims. `SpongefishCurrentCallerGetterCoverage` proves that public replies cover the actual source replay, including rejected prefixes. `SpongefishCurrentAcceptedJoin.accepted_original` joins this parser to an accepted native caller path. Given accepted setup, prelude, receive, payload and binding, followed by any verifier suffix that queries the post-binding coordinate, the received record is among that key's raw-decoded candidates, the parser's public result equals the physical replay, and every prepared original is in the public original list. `accepted_original_next` derives that query when the suffix begins with a positive challenge draw, as the PCS opening does after binding: the draw either requests the first output block of the post-binding coordinate or finds it already recorded. The parser's call order, derived domain, reconstructed proof bytes and empty hints are consequences of the accepted replay rather than hypotheses: `composition_replay` shows that receive and binding are one accepted replay of the caller tape, and `shift_replay` shows that a hint-free replay accepted with unread proof bytes makes the same queries on its consumed prefix. Header validity follows from the accepted receive, and `actualReplay_bounded` derives the received context's one-block pending-buffer bound. `observed_original` states the same result for the observed physical compiler. Native PCS equation, proof-of-work and original-claim acceptance remain explicit; this is not a deployed Fiat-Shamir knowledge endpoint. +`SpongefishCurrentOpeningAcceptance` is the current native PCS opening after expected-record binding. It walks the configured coordinate schedule over the actual byte cursor: positive query proof of work (raw32 challenge, then the UInt64 nonce), the grouped verifier draw, decoded with the same grouped E codec as the historical packets, the Merkle hint and the prover reply in native order (fold coefficients, then the raw32 root or the full residual at a level end; OOD value and intro; query intro). Query rows come from the actual pruned opening of the decoded hint against the level root; the hint wire decoder is an explicit parameter, so every theorem holds for any decoder. Its equation check `anchoredVerify` is literally `AnchoredPhysicalAnchor.sourceVerify` on the record's shape, point and value (`anchoredVerify_historical` is `rfl`), so the existing anchored dense refinement applies unchanged. `run_replay` shows that an accepted opening is one accepted actual replay of the literal call list `openingCalls`, and `accepted_pow` that every ground query level executed its work on the actual raw32 challenge and cleared the configured difficulty. `accepted_opening_original` composes these with `SpongefishCurrentAcceptedJoin.accepted_original_next`, deriving the first-draw cursor guard (`first_draw_guard`): an accepted caller path followed by an accepted opening is one accepted replay of the caller tape and opening, satisfies the anchored native equations for the prepared original claims, and places that original in the public original list of the post-binding construction key. + +`SpongefishCurrentSourceJoinProbability.native_ideal_bound` is the distributional source join. For an arbitrary counted adaptive attacker prefix and any property `Bad` of the prepared original and the whole source view, the real probability of native acceptance of the whole current caller path and opening with `Bad` is at most the ideal raw-oracle probability of the public event that some construction key's public original list contains an original with `Bad`, plus `min(1,(2Q^2-Q)/2^256)`. Its pointwise step `native_public` is the accepted join. The source replays one fixed caller tape followed by the opening call list; the record-binding message calls are a parameter that the real event matches. + +`SpongefishCurrentRoundPackets` defines the current PCS round packets in the basic full-prefix form: a closed key history (session domain, zero statement seed and the complete absorbed prover prefix, with no earlier coin value) together with the opening coordinate selected by a fixed public frame-count classifier. Its blocks are the history's 32-byte output blocks under the same grouped decoder. `blockKey_injective` makes this a partition of the raw source keys, and `conditional_hazard` proves the additive RBR hazard `rbrError` for every caller-data builder. `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript: the real probability of native acceptance with `Bad` is at most `Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256`, where `Q` is the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. It is **conditional** on two named refinement obligations that are hypotheses, not probability premises, and are not yet discharged for the current transcript: `Reduction` (real native acceptance with `Bad` implies a public good event or the complete Merkle trace alarm for a root policy capped by `Q(Q+1)`) and `Refines` (on every ideal table where the good event fires, the current node model has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. `current_knowledge_level` states the endpoint at the deployed grinding with this numeric bound. The reduction obligation is further narrowed: `collision_alarm` proves for any program that an ordinary output collision in the public log of the real view raises the complete trace alarm, and `reduction_of_openingCover` derives `Reduction` for the canonical good event (public join, no public ordinary collision, a public opening predicate) from native acceptance alone, except for opening coverage. `current_knowledge_cover` is the endpoint with the remaining obligations `openingCover` (an accepted opening whose public opening predicate fails raises the alarm) and `Refines` for that canonical good event. + Executable paths that previously returned or retained a digest or squeeze output as a closure, and so recomputed earlier compressions at each use, now store the computed values as data. Each stored form is selected for compiled code by `@[csimp]` with a kernel-checked equality to the unchanged semantic definition (for example `DuplexRefinement.materialize_memo`, `stream_memo`, `DuplexFraming.evalPlan_stored`, `PublicMerkleLog.ordinaryPlan_stored` and the observed session traces), so every theorem about the semantic definitions applies to the executed code unchanged. `AnchoredMixedAttackerPrefix` preserves the unchanged mixed source lowering and its entire public view while freezing the literal strict-prefix Merkle table before the first anchor reply. Repeated grouped queries reuse the first prepared root and point. The exact ambiguity bound is `n/2^124` for the aggregate mixed draw cap, or `remaining/2^124` under the source `Counts` work bound; allocations, lookup requests and full construction-path work are not equated. The wrapper uses the historical pre-#607 header grammar. @@ -208,11 +214,11 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: -- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native PCS equation and accepted-opening adapter, its distributional source join and the basic full-prefix BCS knowledge endpoint for the deployed transcript remain open. +- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native opening adapter (`SpongefishCurrentOpeningAcceptance.accepted_opening_original`) and its distributional source join (`SpongefishCurrentSourceJoinProbability.native_ideal_bound`) are proved, and the basic full-prefix endpoint `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is proved conditional on its two named refinement obligations `Reduction` and `Refines`. Those obligations, the Merkle hint wire codec and the adaptive union over record-binding message shapes remain open. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. -- **Deployment/security target:** the public mode theorem models the pre-#607 #552 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not currently apply to the #607 session-IV and raw-byte transcript, cover the new anchor frames or establish deterministic BLAKE2s security. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. +- **Deployment/security target:** the public mode theorem models the pre-#607 #552 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not currently apply to the #607 session-IV and raw-byte transcript, cover the new anchor frames or establish deterministic BLAKE2s security. For #607, `current_knowledge_bound` gives the explicit three-term bound conditional on its two refinement obligations; numerically it is at most `Q/2^51` for `Q <= 2^64`. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the historical #552 byte-duplex framing and the proved adaptive ideal-compression coupling. The #607 session-IV seed and raw-byte root absorption, additional anchor inputs, their cursor-based sampling, updated source-event refinement and Fiat-Shamir knowledge extraction remain separate composition obligations. @@ -256,7 +262,7 @@ Its checked `random_compression_failure_probability` bounds acceptance with no o `PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. -The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15221 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. +The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15333 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index 7d6e72634..c7662a1c8 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -257,3 +257,7 @@ import Whir.SpongefishCurrentReplayProvenance import Whir.SpongefishCurrentObservedRecordBinding import Whir.SpongefishCurrentByteTransport import Whir.SpongefishCurrentAcceptedJoin +import Whir.SpongefishCurrentOpeningAcceptance +import Whir.SpongefishCurrentSourceJoinProbability +import Whir.SpongefishCurrentRoundPackets +import Whir.SpongefishCurrentBCSKnowledge diff --git a/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean new file mode 100644 index 000000000..72602bf14 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean @@ -0,0 +1,487 @@ +import Whir.SpongefishCurrentRoundPackets +import Whir.SpongefishCurrentSourceJoinProbability +import Whir.PCSBCSSourceKnowledgeComposition +import Whir.PCSBCSChallengeOracleEnteredGames +import Whir.PCSBCSPublicPrimitiveOpening +import Whir.PCSBCSNativePhysicalMerkleBad + +/-! Basic full-prefix BCS knowledge composition for the current #607 transcript +(`remark:bcs-with-basic-fs` of the pinned book source). The basic variant has +no hash-chain term, so the final bound has exactly three summands: + +* the additive source RBR term `Q * rbrError` on the current round packets, +* the initialized byte-mode coupling `min(1,(2Q^2-Q)/2^256)`, +* the complete public Merkle trace alarm `(Q^3+3Q^2-2Q)/2^256`. + +The generic part holds for any packet partition and node model with a proved +conditional hazard. The current instance uses `SpongefishCurrentRoundPackets`. +Two refinement obligations remain explicit hypotheses of the current endpoint: +real native acceptance with extraction failure reduces to a public good event +or the Merkle alarm, and the good event in every ideal table yields a state +path of the current node model. Neither is an assumed probability bound. -/ +namespace Whir.SpongefishCurrentBCSKnowledge +open Concrete FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling +open PCSBCSChallengeOracle PCSStateRestoration.Latent TypedOracleCompiler SpongefishPCSRoundFrames +set_option autoImplicit false +set_option maxRecDepth 100000 + +/-! ## Generic packet composition -/ + +section Generic +variable {Packet : Type} [Fintype Packet] [DecidableEq Packet] {Block : Packet → Type} + [∀ x, Fintype (Block x)] {Q : Nat} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + +/-- The compiled source program with one grouped packet allocation at first +physical disclosure, exactly as in the whole-view coupling. -/ +noncomputable def source {R : Type} (iv : Digest32) (program : Program R) (counted : Counts Q program) : + Sampling part.Key (part.Answer (D := Digest32)) (View R) Q := + Atomic.program part (PublicCompressionCouplingMixed.compile Q iv [] program Q (by rfl) counted) + +/-- Every ideal table on which the observer fires exposes a state path from an +undoomed to a doomed state. -/ +def Refines {P R : Type} (model : NodeModel part.Key (part.Answer (D := Digest32)) P) + (iv : Digest32) (program : Program R) (counted : Counts Q program) (observe : View R → Bool) : + Prop := + ∀ table, observe (Sampling.eval table (source part iv program counted)) = true → + StatePath model table (Sampling.execute table (source part iv program counted)).2 false true + +private theorem average_indicator {T : Type} [Fintype T] (test : T → Bool) : + average (fun t => if test t then (1 : ℚ) else 0) = + Soundness.uniformProb (Finset.univ.filter fun t => test t = true) := by + classical + simp only [average,Soundness.uniformProb,Finset.card_filter,Nat.cast_sum, + Nat.cast_ite,Nat.cast_one,Nat.cast_zero] + +variable [Fintype part.Key] [DecidableEq part.Key] + [∀ key, Fintype (part.Answer (D := Digest32) key)] [∀ key, Nonempty (part.Answer (D := Digest32) key)] + +open Classical in +/-- Ideal packet experiment: at most `Q * epsilon`. -/ +theorem ideal_bound {P AdvCoins R : Type} [Fintype AdvCoins] [Nonempty AdvCoins] + (model : NodeModel part.Key (part.Answer (D := Digest32)) P) (epsilon : ℚ) + (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard model epsilon) (iv : Digest32) + (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) + (observe : View R → Bool) + (refines : ∀ a, Refines part model iv (adversary a) (counted a) observe) : + atomicIdealProbability part iv adversary counted observe ≤ (Q : ℚ) * epsilon := by + unfold atomicIdealProbability + have each (a : AdvCoins) : + Sampling.expectation (fun result => if observe result.1 then (1 : ℚ) else 0) + (RawOracleCoupling.memo (source part iv (adversary a) (counted a)) (fun _ => none)) ≤ + (Q : ℚ) * epsilon := by + have tableMemo := RawOracleCoupling.empty_table_eq_memo + (source part iv (adversary a) (counted a)) (fun view => if observe view then (1 : ℚ) else 0) + rw [← tableMemo,average_indicator] + have bound := accepted_path_failure_probability model Q 0 (source part iv (adversary a) (counted a)) + epsilon nonnegative hazard + (fun table => observe (Sampling.eval table (source part iv (adversary a) (counted a))) = true) + (refines a) + simp only [Nat.add_zero] at bound + convert bound using 2 + ext t + simp only [Finset.mem_filter] + have summed := average_mono each + rw [average_const] at summed + convert summed using 1 + congr 1 + funext a + unfold source + congr 2 <;> exact Subsingleton.elim _ _ + +/-- Real primitive experiment: ideal packet bound plus the whole-view coupling. -/ +theorem real_bound {P AdvCoins R : Type} [Fintype AdvCoins] [Nonempty AdvCoins] + (model : NodeModel part.Key (part.Answer (D := Digest32)) P) (epsilon : ℚ) + (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard model epsilon) (iv : Digest32) + (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) + (observe : View R → Bool) + (refines : ∀ a, Refines part model iv (adversary a) (counted a) observe) : + realProbability iv adversary observe ≤ (Q : ℚ) * epsilon + duplexModeLoss Q := by + have coupling := actual_source_atomic_game_bound part iv adversary counted observe + have deviation := (abs_le.mp coupling).2 + have ideal := ideal_bound part model epsilon nonnegative hazard iv adversary counted observe refines + linarith + +end Generic + +/-! ## Complete public Merkle trace alarm for an arbitrary root policy -/ + +noncomputable def merkleProbability {Coins R : Type} [Fintype Coins] {Q : Nat} + (roots : PublicMerkleProbability.RootPolicy) (iv : Digest32) + (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) : ℚ := + average fun coins => average fun C : PrimitiveOracle => + if PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv (adversary coins) Q (counted coins)) then 1 else 0 + +theorem merkle_bound {Coins R : Type} [Fintype Coins] [Nonempty Coins] {Q : Nat} + (roots : PublicMerkleProbability.RootPolicy) + (rootCap : ∀ log : PublicMerkleLog.PublicLog, log.length ≤ Q → (roots log).card ≤ Q*(Q+1)) + (iv : Digest32) (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) : + merkleProbability roots iv adversary counted ≤ ((Q : ℚ)^3+3*(Q : ℚ)^2-2*(Q : ℚ))/2^256 := by + unfold merkleProbability + have each (coins : Coins) := PublicMerkleProbability.random_compression_bound roots Q (Q*(Q+1)) + rootCap (PublicCompressionProgram.compile iv (adversary coins) Q (counted coins)) + simp only [PublicMerkleProbability.alarm_trace] at each + have bound := average_mono each + rw [average_const,PCSBCSActualMerkleBound.exact_merkle_loss] at bound + exact bound + +/-- Pointwise reduction of an arbitrary real event to the public good event or +the complete Merkle trace alarm. -/ +def Reduction {Coins R : Type} {Q : Nat} (roots : PublicMerkleProbability.RootPolicy) (iv : Digest32) + (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) + (event : PrimitiveOracle → Coins → Prop) (good : View R → Bool) : Prop := + ∀ C coins, event C coins → + good (runReal C iv (adversary coins)).view = true ∨ + PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv (adversary coins) Q (counted coins)) = true + +open Classical in +theorem reduction_union {Coins R : Type} [Fintype Coins] [Nonempty Coins] {Q : Nat} + (roots : PublicMerkleProbability.RootPolicy) (iv : Digest32) + (adversary : Coins → Program R) (counted : ∀ coins, Counts Q (adversary coins)) + (event : PrimitiveOracle → Coins → Prop) (good : View R → Bool) + (reduction : Reduction roots iv adversary counted event good) : + average (fun coins : PrimitiveOracle × Coins => if event coins.1 coins.2 then (1 : ℚ) else 0) ≤ + realProbability iv adversary good + merkleProbability roots iv adversary counted := by + unfold realProbability + rw [distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins))] + simp only [WHIRObservableSecurity.average_product] + rw [RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins), + RawOracleCoupling.average_comm (X := PrimitiveOracle) (Y := Coins)] + unfold merkleProbability + rw [← average_add] + apply average_mono + intro coins + rw [← average_add] + apply average_mono + intro C + by_cases happened : event C coins + · rcases reduction C coins happened with publicGood | alarm + · simp only [happened,publicGood,↓reduceIte] + split <;> norm_num + · simp only [happened,alarm,↓reduceIte] + split <;> norm_num + · simp only [happened,↓reduceIte] + split <;> split <;> norm_num + +/-- Any program: an ordinary output collision in the PUBLIC log of the real view +raises the complete primitive trace alarm, for every root policy. The historical +packet partition is used only as a proof device; it is not part of the claim. -/ +theorem collision_alarm {R : Type} (C : PrimitiveOracle) (iv : Digest32) (program : Program R) + (Q : Nat) (counted : Counts Q program) (roots : PublicMerkleProbability.RootPolicy) + (collision : PublicMerkleLog.OutputCollision + (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog Q iv (runReal C iv program).view)) : + PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv program Q counted) = true := by + have ordinary := PCSBCSPublicPrimitiveOpening.publicOrdinaryLog_actual + (p := (⟨0,by decide⟩,⟨0,by decide⟩)) (iv := iv) (boundary := 0) + C (WHIRRealSimulator.rawTable Q C) program Q (le_refl Q) counted + simp only [Atomic.eval_program,Partition.join_split] at ordinary + have view : Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable Q C)) + (PublicCompressionCouplingMixed.compile Q iv [] program Q (le_refl Q) counted) = + (runReal C iv program).view := by + rw [PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C iv _ ⟨rfl,by simp⟩ _ _ (le_refl Q) _ + rw [view] at ordinary + rw [ordinary] at collision + exact PCSBCSNativePhysicalMerkleBad.mixed_atomic_collision_alarm + (p := (⟨0,by decide⟩,⟨0,by decide⟩)) (boundary := 0) C iv program Q (le_refl Q) counted roots + collision + +/-! ## Current #607 endpoint -/ + +section Current +open SpongefishCurrentRoundPackets SpongefishCurrentSourceJoinProbability +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +noncomputable local instance (Q : Nat) (iv : Digest32) (grinding : Fin (cfg).folds.size → Fin 64) + (boundary : Nat) (key : SpongefishCurrentRoundPackets.Key p Q iv grinding boundary) : + Fintype (SpongefishCurrentRoundPackets.Answer p Q iv grinding boundary key) := + match key with + | .inl _ => inferInstance + | .inr _ => inferInstance + +open Classical in +/-- The current #607 basic full-prefix knowledge endpoint. The real event is +native acceptance of the whole current caller path and opening, with the +property `Bad` (for example failed public extraction) of the prepared original. +Every summand of the bound is explicit; the two refinement obligations are +named hypotheses, not probability premises. -/ +theorem current_knowledge_bound {Coins : Type} [Fintype Coins] [Nonempty Coins] + (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (boundary : Nat) + (build : Builder p (budget tag instanceBytes layout before payloadCalls messages grinding A) iv + grinding boundary) + (good : View SourceResult → Bool) + (roots : PublicMerkleProbability.RootPolicy) + (rootCap : ∀ log : PublicMerkleLog.PublicLog, + log.length ≤ budget tag instanceBytes layout before payloadCalls messages grinding A → + (roots log).card ≤ budget tag instanceBytes layout before payloadCalls messages grinding A * + (budget tag instanceBytes layout before payloadCalls messages grinding A + 1)) + (reduction : Reduction roots iv + (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin)) + (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) + (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages + decode grinding (prefixProgram coin) Bad) good) + (refines : ∀ coin, Refines (partition p (budget tag instanceBytes layout before payloadCalls + messages grinding A) iv grinding boundary) + (model p _ iv grinding boundary build) iv + (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) + good) : + let Q := budget tag instanceBytes layout before payloadCalls messages grinding A + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode + grinding (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + (Q : ℚ) * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) + + ((Q : ℚ)^3+3*(Q : ℚ)^2-2*(Q : ℚ))/2^256 := by + dsimp only + classical + have union := reduction_union roots iv _ _ _ good reduction + have merkle := merkle_bound roots rootCap iv + (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin)) + (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) + have nonnegative : (0 : ℚ) ≤ PCSRoundByRoundKnowledge.rbrError := by + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + have real := real_bound _ _ PCSRoundByRoundKnowledge.rbrError nonnegative + (conditional_hazard p _ iv grinding boundary build) iv _ _ good refines + have rbr : PCSRoundByRoundKnowledge.rbrError = (17/32 : ℚ)^56 + 1/2^78 := by + simp only [PCSRoundByRoundKnowledge.rbrError,SupportedCandidateExtraction.radiusEnvelope] + rw [rbr,duplexModeLoss_eq] at real + exact union.trans (add_le_add real merkle) + +open Classical in +/-- Canonical public good event: the public original join with `Bad`, no +ordinary output collision in the public log, and a public opening predicate. -/ +noncomputable def canonicalGood (Q : Nat) (iv : Digest32) (instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (quiet : View SourceResult → Bool) (view : View SourceResult) : Bool := + publicObserver Q iv instanceBytes layout Bad view && + decide (¬ PublicMerkleLog.OutputCollision + (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog Q iv view)) && quiet view + +/-- The reduction obligation narrows to opening coverage: native acceptance +with `Bad` already gives the public join (`native_public`) and every public +ordinary collision raises the alarm (`collision_alarm`). -/ +theorem reduction_of_openingCover {Coins : Type} + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (roots : PublicMerkleProbability.RootPolicy) (quiet : View SourceResult → Bool) + (openingCover : ∀ C coin, NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls + messages decode grinding (prefixProgram coin) Bad → + quiet (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin))).view = false → + PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv + (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) + (budget tag instanceBytes layout before payloadCalls messages grinding A) + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin))) = + true) : + Reduction roots iv + (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin)) + (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) + (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages + decode grinding (prefixProgram coin) Bad) + (canonicalGood (budget tag instanceBytes layout before payloadCalls messages grinding A) iv + instanceBytes layout Bad quiet) := by + classical + intro C coin native + have joined := native_public C iv tag instanceBytes nonempty layout before payloadCalls messages + beforeEq payloadEq decode grinding (prefixProgram coin) A (attacker coin) Bad native + by_cases collision : PublicMerkleLog.OutputCollision + (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog + (budget tag instanceBytes layout before payloadCalls messages grinding A) iv + (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin))).view) + · exact Or.inr (collision_alarm C iv _ _ _ roots collision) + · cases quietEq : quiet (runReal C iv (program iv tag instanceBytes layout before payloadCalls + messages grinding (prefixProgram coin))).view with + | false => exact Or.inr (openingCover C coin native quietEq) + | true => + left + simp only [canonicalGood,quietEq,Bool.and_true,Bool.and_eq_true,decide_eq_true_eq] + exact ⟨decide_eq_true joined,collision⟩ + +open Classical in +/-- The current endpoint with the reduction narrowed to opening coverage. The +remaining obligations are `openingCover` (a native accepted opening whose +public opening predicate fails raises the Merkle trace alarm) and `Refines` for +the canonical good event. -/ +theorem current_knowledge_cover {Coins : Type} [Fintype Coins] [Nonempty Coins] + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (boundary : Nat) + (build : Builder p (budget tag instanceBytes layout before payloadCalls messages grinding A) iv + grinding boundary) + (quiet : View SourceResult → Bool) + (roots : PublicMerkleProbability.RootPolicy) + (rootCap : ∀ log : PublicMerkleLog.PublicLog, + log.length ≤ budget tag instanceBytes layout before payloadCalls messages grinding A → + (roots log).card ≤ budget tag instanceBytes layout before payloadCalls messages grinding A * + (budget tag instanceBytes layout before payloadCalls messages grinding A + 1)) + (openingCover : ∀ C coin, NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls + messages decode grinding (prefixProgram coin) Bad → + quiet (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin))).view = false → + PublicMerkleProbability.traceAlarm roots [] + (PublicCompressionProgram.primitiveLog C iv + (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) + (budget tag instanceBytes layout before payloadCalls messages grinding A) + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin))) = + true) + (refines : ∀ coin, Refines (partition p (budget tag instanceBytes layout before payloadCalls + messages grinding A) iv grinding boundary) + (model p _ iv grinding boundary build) iv + (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) + (canonicalGood (budget tag instanceBytes layout before payloadCalls messages grinding A) iv + instanceBytes layout Bad quiet)) : + let Q := budget tag instanceBytes layout before payloadCalls messages grinding A + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode + grinding (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + (Q : ℚ) * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) + + ((Q : ℚ)^3+3*(Q : ℚ)^2-2*(Q : ℚ))/2^256 := + current_knowledge_bound iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram A attacker Bad boundary build _ roots rootCap + (reduction_of_openingCover iv tag instanceBytes nonempty layout before payloadCalls messages + beforeEq payloadEq decode grinding prefixProgram A attacker Bad roots quiet openingCover) + refines + +end Current + +/-! ## Concrete level from the deployed parameters -/ + +/-- The three explicit summands of the current endpoint. -/ +def finalBound (Q : ℚ) : ℚ := + Q * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*Q^2-Q)/2^256) + (Q^3+3*Q^2-2*Q)/2^256 + +/-- For every aggregate budget up to `2^64` primitive-work units the complete +bound is at most `Q / 2^51`: each unit of attacker plus verifier work buys at +most `2^-51` knowledge error, with no proof-of-work credit. -/ +theorem finalBound_le (Q : ℚ) (positive : 0 ≤ Q) (cap : Q ≤ 2^64) : finalBound Q ≤ Q / 2^51 := by + unfold finalBound + have square : Q^2 ≤ 2^64 * Q := by nlinarith + have cube : Q^3 ≤ 2^128 * Q := by nlinarith + have coupling : min 1 ((2*Q^2-Q)/2^256) ≤ (2*Q^2-Q)/2^256 := min_le_right _ _ + have numeric : (17/32 : ℚ)^56 + 1/2^78 + 2*2^64/2^256 + (2^128+3*2^64)/2^256 ≤ 1/2^51 := by + norm_num + nlinarith + +/-- Concrete levels: `2^20` units give at most `2^-31`, `2^40` units at most `2^-11`. -/ +theorem finalBound_levels : + finalBound (2^20) ≤ 1/2^31 ∧ finalBound (2^40) ≤ 1/2^11 := by + constructor + · have h := finalBound_le (2^20) (by norm_num) (by norm_num) + calc finalBound (2^20) ≤ 2^20/2^51 := h + _ = 1/2^31 := by norm_num + · have h := finalBound_le (2^40) (by norm_num) (by norm_num) + calc finalBound (2^40) ≤ 2^40/2^51 := h + _ = 1/2^11 := by norm_num + +/-- Deployed query grinding: `QUERY_GRINDING_BITS = 17` at every level. -/ +def deployedGrinding (p : ParameterBounds.Profile) : Fin (ParameterBounds.config p).folds.size → Fin 64 := + fun _ => ⟨17,by decide⟩ + +open Classical SpongefishCurrentRoundPackets SpongefishCurrentSourceJoinProbability in +/-- The current endpoint at the deployed grinding, evaluated numerically: with +an aggregate budget of at most `2^64` units the real probability of native +acceptance with `Bad` is at most `Q / 2^51`, under the same two refinement +obligations. -/ +theorem current_knowledge_level {p : ParameterBounds.Profile} {Coins : Type} [Fintype Coins] + [Nonempty Coins] (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (boundary : Nat) + (build : Builder p (budget tag instanceBytes layout before payloadCalls messages + (deployedGrinding p) A) iv (deployedGrinding p) boundary) + (good : View SourceResult → Bool) + (roots : PublicMerkleProbability.RootPolicy) + (rootCap : ∀ log : PublicMerkleLog.PublicLog, + log.length ≤ budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A → + (roots log).card ≤ budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A * + (budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A + 1)) + (reduction : Reduction roots iv + (fun coin => program iv tag instanceBytes layout before payloadCalls messages (deployedGrinding p) + (prefixProgram coin)) + (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages (deployedGrinding p)) A + (attacker coin)) + (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages + decode (deployedGrinding p) (prefixProgram coin) Bad) good) + (refines : ∀ coin, Refines (partition p (budget tag instanceBytes layout before payloadCalls + messages (deployedGrinding p) A) iv (deployedGrinding p) boundary) + (model p _ iv (deployedGrinding p) boundary build) iv + (program iv tag instanceBytes layout before payloadCalls messages (deployedGrinding p) + (prefixProgram coin)) + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages (deployedGrinding p)) A + (attacker coin)) + good) + (cap : budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A ≤ 2^64) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode + (deployedGrinding p) (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + (budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A : ℚ) / 2^51 := by + have bound := current_knowledge_bound iv tag instanceBytes layout before payloadCalls messages decode + (deployedGrinding p) prefixProgram A attacker Bad boundary build good roots rootCap reduction refines + have numeric := finalBound_le + (budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A : ℚ) + (by positivity) (by exact_mod_cast cap) + unfold finalBound at numeric + exact bound.trans numeric + +#print axioms ideal_bound +#print axioms real_bound +#print axioms merkle_bound +#print axioms reduction_union +#print axioms current_knowledge_bound +#print axioms finalBound_le +#print axioms finalBound_levels +#print axioms current_knowledge_level +#print axioms collision_alarm +#print axioms reduction_of_openingCover +#print axioms current_knowledge_cover + +end Whir.SpongefishCurrentBCSKnowledge diff --git a/verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean b/verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean new file mode 100644 index 000000000..945490e1f --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean @@ -0,0 +1,790 @@ +import Whir.SpongefishCurrentAcceptedJoin +import Whir.WHIRPhysicalVerifier +import Whir.AnchorPrefixRefinementCaller +import Whir.PCSBCSChallengeOracle + +/-! Current #607 native PCS opening after expected-record binding. The verifier +walks the configured coordinate schedule over the actual byte cursor: query +proof of work, the grouped verifier draw, the decoded Merkle hint and the +prover reply. Each draw is decoded with the same grouped E codec as the +historical packets, each reply with the native wire order (fold coefficients, +raw32 root or full residual, OOD value and intro, query intro), and the +accepted opening is checked by the anchored native equation verifier on the +original family and point claims of the caller and the received record. + +The Merkle hint wire codec is an explicit parameter: every theorem below holds +for an arbitrary decoder. This module is the deterministic adapter; it is not +a probability or knowledge statement. -/ +namespace Whir.SpongefishCurrentOpeningAcceptance +open Concrete Protocol CausalGame CausalProbability FiatShamirGame DuplexModeGame +open DuplexRefinement SpongefishPCSRoundFrames +set_option autoImplicit false +set_option maxRecDepth 10000 + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +abbrev Coord (p : ParameterBounds.Profile) := Coordinate (ParameterBounds.config p) + +/-! ## Current wire schedule of one coordinate -/ + +/-- Current draw group carrying a PCS coordinate. -/ +def group : Coord p → Group + | .initial => .stackFamilyAndLambda + | .fold _ _ => .fold + | .ood i _ => .ood (remaining cfg i.val - 1) + | .query i => .queryAndLambda (remaining cfg i.val + (cfg).rates[i.val]!) (cfg).queries[i.val]! + | .tail _ => .residualFold + +/-- A zero-dimensional OOD point issues no verifier call. -/ +def drawCalls (q : Coord p) : List Call := + if PCSBCSRounds.rawWidth q = 0 then [] else [.draw (group q)] + +def isLastFold (i : Fin (cfg).folds.size) (j : Fin (cfg).folds[i.val]!) : Bool := + decide (j.val + 1 = (cfg).folds[i.val]!) + +def isVisibleTail (j : Fin ((cfg).logN - (cfg).folds.toList.sum)) : Bool := + decide (j.val + 1 < (cfg).logN - (cfg).folds.toList.sum) + +/-- Native reply order. A level-ending fold carries the next raw32 root, or the +full residual at the last level; the final tail draw has no reply. -/ +def replyCalls : Coord p → List Call + | .initial => [.read (.vector 2)] + | .fold i j => [.read (.vector 2)] ++ + (if isLastFold i j then + (if i.val + 1 < (cfg).folds.size then [.read .root] + else [.read (.vector (2^remaining cfg i.val))]) + else []) + | .ood _ _ => [.read .scalar,.read (.vector 2)] + | .query _ => [.hint,.read (.vector 2)] + | .tail j => if isVisibleTail j then [.read (.vector 2)] else [] + +/-- Query proof of work precedes its query draw; other coordinates have none. -/ +def powCalls (grinding : Fin (cfg).folds.size → Fin 64) : Coord p → List Call + | .query i => powSchedule (grinding i) + | _ => [] + +def callsOf (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) : List Call := + powCalls grinding q ++ drawCalls q ++ replyCalls q + +/-- The complete current opening call list after expected-record binding. -/ +def openingCalls (grinding : Fin (cfg).folds.size → Fin 64) : List Call := + (WHIRHistory.schedule cfg).flatMap (callsOf grinding) + +/-! ## Typed decoding -/ + +/-- The historical grouped decoder applied to the literal drawn bytes. -/ +def decodeSample (q : Coord p) (bytes : List Byte) : PCSBCSRounds.Raw q := + (PCSBCSChallengeOracle.rawVector q).symm + (fun k => ByteCodec.decodeE (fun i => bytes[24*k.val+i.val]?.getD 0)) + +def vectorList (n : Nat) (xs : Fin n → E) : List E := List.ofFn xs + +/-- One Merkle query opening recorded for later authentication arguments. -/ +structure QueryOpening (p : ParameterBounds.Profile) where + level : Fin (ParameterBounds.config p).folds.size + root : Digest32 + hint : List Byte + proof : MerkleTransport.PrunedMerklePaths + opened : WHIRPhysicalVerifier.Opened + +/-- One positive query proof-of-work check, with its actual raw32 challenge. -/ +structure PowCheck (p : ParameterBounds.Profile) where + level : Fin (ParameterBounds.config p).folds.size + bits : Fin 64 + challenge : Digest32 + nonce : UInt64 + +structure Collected (p : ParameterBounds.Profile) where + tape : CausalGame.Tape (ParameterBounds.config p) + seed : Option (RingPCSGame.Prefix × E) + replies : Array Reply + roots : Array Digest32 + openings : List (QueryOpening p) + pows : List (PowCheck p) + +def Collected.start (root : Digest32) : Collected p := + ⟨WHIRReplay.zeroTape p,none,#[],#[root],[],[]⟩ + +/-- Proof of work before a query draw, through the actual source operations. -/ +def powStep (C : PrimitiveOracle) (grinding : Fin (cfg).folds.size → Fin 64) + (cur : Cursor) (col : Collected p) : Coord p → Option (Cursor × Collected p) + | .query i => + if (grinding i).val = 0 then some (cur,col) else + match squeezeGroup (compressionOf C) cur .positivePow with + | .error _ => none + | .ok (challenged,bytes) => + match read (compressionOf C) challenged .nonce with + | none => none + | some (next,nonce) => + some (next,{col with pows := col.pows ++ + [⟨i,grinding i,fun k => bytes[k.val]?.getD 0,nonce⟩]}) + | _ => some (cur,col) + +def drawStep (C : PrimitiveOracle) (cur : Cursor) (q : Coord p) : + Option (Cursor × PCSBCSRounds.Raw q) := + if PCSBCSRounds.rawWidth q = 0 then some (cur,decodeSample q []) else + match squeezeGroup (compressionOf C) cur (group q) with + | .error _ => none + | .ok (next,bytes) => some (next,decodeSample q bytes) + +def recordSample (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) : Collected p := + let sampled := {col with tape := CausalProbability.set q col.tape (StackWHIRReplay.projectSample q x)} + match q, x with + | .initial, x => {sampled with seed := some x} + | _, _ => sampled + +def readMessage (C : PrimitiveOracle) (cur : Cursor) : Option (Cursor × Message E) := + match read (compressionOf C) cur (.vector 2) with + | none => none + | some (next,xs) => some (next,⟨xs 0,xs 1⟩) + +/-- Merkle authentication of one query batch on the decoded hint. -/ +def openQuery (C : PrimitiveOracle) (lanes : Nat) (i : Fin (cfg).folds.size) (root : Digest32) + (proof : MerkleTransport.PrunedMerklePaths) (x : CausalProbability.Sample (Coordinate.query i)) : + Option WHIRPhysicalVerifier.Opened := + WHIRPhysicalVerifier.finishRows (i.val == 0) + (if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val) + (WHIRPhysicalVerifier.leafWords p i.val) + (proof.open (PublicMerkleLog.hash C) root (ParameterBounds.length cfg i.val) + (WHIRPhysicalVerifier.queryIndices p i x) + (if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val) + (WHIRPhysicalVerifier.leafWords p i.val)) + +/-- The prover reply at a coordinate, in native wire order. -/ +def replyStep (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (lanes : Nat) (cur : Cursor) (col : Collected p) : Coord p → Option (Cursor × Collected p) + | .initial => do + let (next,m) ← readMessage C cur + pure (next,{col with replies := col.replies.push (.initial m)}) + | .fold i j => do + let (next,m) ← readMessage C cur + if isLastFold i j then + if i.val + 1 < (cfg).folds.size then do + let (after,root) ← read (compressionOf C) next .root + let replies := col.replies.push (.fold m (some #[]) #[]) + pure (after,{col with replies := replies, roots := col.roots.push root}) + else do + let (after,residual) ← read (compressionOf C) next (.vector (2^remaining cfg i.val)) + pure (after,{col with replies := col.replies.push (.fold m none (Array.ofFn residual))}) + else pure (next,{col with replies := col.replies.push (.fold m none #[])}) + | .ood _ _ => do + let (next,y) ← read (compressionOf C) cur .scalar + let (after,m) ← readMessage C next + pure (after,{col with replies := col.replies.push (.ood ⟨y,m⟩)}) + | .query i => do + let hint ← cur.hints.head? + let hinted ← takeHint cur + let proof ← decode hint + let root ← col.roots[i.val]? + let opened ← openQuery C lanes i root proof (CausalProbability.get (.query i) col.tape) + let (next,m) ← readMessage C hinted + let replies := col.replies.push (.query opened.rows m) + pure (next,{col with replies := replies, openings := col.openings ++ [⟨i,root,hint,proof,opened⟩]}) + | .tail j => + if isVisibleTail j then do + let (next,m) ← readMessage C cur + pure (next,{col with replies := col.replies.push (.tail m)}) + else some (cur,col) + +def step (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (state : Cursor × Collected p) (q : Coord p) : Option (Cursor × Collected p) := do + let (powed,col) ← powStep C grinding state.1 state.2 q + let (drawn,x) ← drawStep C powed q + replyStep C decode lanes drawn (recordSample col q x) q + +def run (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + List (Coord p) → Cursor × Collected p → Option (Cursor × Collected p) + | [], state => some state + | q :: qs, state => do + let next ← step C decode grinding lanes state q + run C decode grinding lanes qs next + +/-! ## Anchored native equations -/ + +/-- The anchored native equation verifier of `AnchoredPhysicalAnchor`, stated on +the current record's shape, point and value. -/ +def anchoredVerify {m : Nat} (r : SpongefishSessionAdapter.Record) + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) (c : Config) (ch : Challenges) (proof : Opening) : + Except String Unit := + WHIRNativeArithmetic.nativeVerify c ch r.shape.lanes + (WHIRNativeArithmetic.initialClaim family points seed lambda + lambda^(points.size+1)*r.value) + (fun x => SuccinctRingGroups.sourceStackWeightAt family points seed lambda x + + lambda^(points.size+1)*AnchoredPhysicalAnchor.anchorAt r.shape r.point.toArray x) proof + +/-- The current check is literally the historical anchored native verifier on +any historical record with the same shape, point and value. -/ +theorem anchoredVerify_historical {m : Nat} (r : SpongefishSessionAdapter.Record) + (context : AnchoredHeaderCodec.Context) (family : Fin m → RingPCSGame.FamilyClaim) + (points : Array RingPCSGame.PointClaim) (seed : RingPCSGame.Prefix) (lambda : E) + (c : Config) (ch : Challenges) (proof : Opening) : + anchoredVerify r family points seed lambda c ch proof = + AnchoredPhysicalAnchor.sourceVerify ⟨r.shape,r.root,context,r.point,r.value⟩ + family points seed lambda c ch proof := rfl + +/-- Accepted native opening: every proof of work clears, the replies parse at +the configured shape, and the anchored native equations hold for the original +caller claims. Merkle hints authenticated inside `run`. -/ +structure Accepted (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) + (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) where + final : Cursor + collected : Collected p + ran : run C decode grinding r.shape.lanes (WHIRHistory.schedule cfg) + (cur,Collected.start r.root) = some (final,collected) + pow : ∀ check ∈ collected.pows, + SpongefishPowAdapter.clears check.bits (SpongefishPowAdapter.trial C check.challenge check.nonce) = true + seed : RingPCSGame.Prefix × E + seeded : collected.seed = some seed + proof : Opening + parsed : CausalGame.opening cfg (challenges cfg collected.tape) collected.replies = .ok proof + equations : anchoredVerify r input.family input.points seed.1 seed.2 cfg + (challenges cfg collected.tape) proof = .ok () + +/-- Executable acceptance decision with exactly the fields of `Accepted`. -/ +def verify (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) + (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) : Bool := + match run C decode grinding r.shape.lanes (WHIRHistory.schedule cfg) (cur,Collected.start r.root) with + | none => false + | some (_,collected) => + collected.pows.all (fun check => + SpongefishPowAdapter.clears check.bits (SpongefishPowAdapter.trial C check.challenge check.nonce)) && + match collected.seed with + | none => false + | some seed => + match CausalGame.opening cfg (challenges cfg collected.tape) collected.replies with + | .error _ => false + | .ok proof => + match anchoredVerify r input.family input.points seed.1 seed.2 cfg + (challenges cfg collected.tape) proof with + | .error _ => false + | .ok () => true + +theorem verify_accepted (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) + (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) + (accepted : verify C decode grinding r input cur = true) : + Nonempty (Accepted C decode grinding r input cur) := by + unfold verify at accepted + split at accepted + · cases accepted + next final collected ran => + rw [Bool.and_eq_true] at accepted + obtain ⟨pows,rest⟩ := accepted + split at rest + · cases rest + next seed seeded => + split at rest + · cases rest + next proof parsed => + split at rest + · cases rest + next equations => + exact ⟨⟨final,collected,ran, + fun check member => List.all_eq_true.mp pows check member, + seed,seeded,proof,parsed,equations⟩⟩ + +/-! ## Byte-level replay of the accepted opening -/ + +theorem squeezeGroup_call (c : Compression) (cur next : Cursor) (g : Group) (bytes : List Byte) + (ok : squeezeGroup c cur g = .ok (next,bytes)) : + SpongefishCurrentPrimitiveEventCompiler.actualCall c cur (.draw g) = .ok next := by + simp [SpongefishCurrentPrimitiveEventCompiler.actualCall,ok] + +theorem read_call (c : Compression) (cur next : Cursor) (kind : WireKind) (value : kind.Value) + (ok : read c cur kind = some (next,value)) : + SpongefishCurrentPrimitiveEventCompiler.actualCall c cur (.read kind) = .ok next := by + simp [SpongefishCurrentPrimitiveEventCompiler.actualCall,ok] + +theorem hint_call (c : Compression) (cur next : Cursor) (ok : takeHint cur = some next) : + SpongefishCurrentPrimitiveEventCompiler.actualCall c cur .hint = .ok next := by + simp [SpongefishCurrentPrimitiveEventCompiler.actualCall,ok] + +theorem replay_cons (c : Compression) (cur mid next : Cursor) (call : Call) (calls : List Call) + (first : SpongefishCurrentPrimitiveEventCompiler.actualCall c cur call = .ok mid) + (rest : SpongefishCurrentPrimitiveEventCompiler.actualReplay c mid calls = .ok next) : + SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur (call :: calls) = .ok next := by + simp only [SpongefishCurrentPrimitiveEventCompiler.actualReplay,first] + exact rest + +theorem replay_nil (c : Compression) (cur : Cursor) : + SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur [] = .ok cur := rfl + +theorem readMessage_call (C : PrimitiveOracle) (cur next : Cursor) (m : Message E) + (ok : readMessage C cur = some (next,m)) : + SpongefishCurrentPrimitiveEventCompiler.actualCall (compressionOf C) cur (.read (.vector 2)) = + .ok next := by + unfold readMessage at ok + split at ok + · cases ok + next mid xs h => + cases ok + exact read_call _ _ _ _ xs h + +theorem powStep_replay (C : PrimitiveOracle) (grinding : Fin (cfg).folds.size → Fin 64) + (cur next : Cursor) (col col' : Collected p) (q : Coord p) + (ok : powStep C grinding cur col q = some (next,col')) : + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) cur + (powCalls grinding q) = .ok next := by + cases q with + | query i => + simp only [powStep] at ok + simp only [powCalls,powSchedule] + split at ok + next zero => + simp only [zero,↓reduceIte] + cases ok + rfl + next positive => + simp only [positive,↓reduceIte] + split at ok + · cases ok + next challenged bytes squeezed => + split at ok + · cases ok + next after nonce readOk => + cases ok + exact replay_cons _ _ _ _ _ _ (squeezeGroup_call _ _ _ _ _ squeezed) + (replay_cons _ _ _ _ _ _ (read_call _ _ _ _ _ readOk) (replay_nil _ _)) + | initial => cases ok; rfl + | fold i j => cases ok; rfl + | ood i j => cases ok; rfl + | tail j => cases ok; rfl + +theorem drawStep_replay (C : PrimitiveOracle) (cur next : Cursor) (q : Coord p) + (x : PCSBCSRounds.Raw q) (ok : drawStep C cur q = some (next,x)) : + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) cur (drawCalls q) = + .ok next := by + unfold drawStep at ok + unfold drawCalls + split at ok + next zero => + simp only [zero,↓reduceIte] + cases ok + rfl + next positive => + simp only [positive,↓reduceIte] + split at ok + · cases ok + next after bytes squeezed => + cases ok + exact replay_cons _ _ _ _ _ _ (squeezeGroup_call _ _ _ _ _ squeezed) (replay_nil _ _) + +theorem replyStep_replay (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) (lanes : Nat) + (cur next : Cursor) (col col' : Collected p) (q : Coord p) + (ok : replyStep C decode lanes cur col q = some (next,col')) : + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) cur (replyCalls q) = + .ok next := by + cases q with + | initial => + simp only [replyStep] at ok + obtain ⟨⟨mid,m⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact replay_cons _ _ _ _ _ _ (readMessage_call C _ _ _ first) (replay_nil _ _) + | fold i j => + simp only [replyStep] at ok + obtain ⟨⟨mid,m⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + have head := readMessage_call C _ _ _ first + simp only [replyCalls] + split at ok + next last => + simp only [last,↓reduceIte] + split at ok + next more => + simp only [more,↓reduceIte] + obtain ⟨⟨after,root⟩,rootRead,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact replay_cons _ _ _ _ _ _ head + (replay_cons _ _ _ _ _ _ (read_call _ _ _ _ _ rootRead) (replay_nil _ _)) + next final => + simp only [final,↓reduceIte] + obtain ⟨⟨after,residual⟩,residualRead,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact replay_cons _ _ _ _ _ _ head + (replay_cons _ _ _ _ _ _ (read_call _ _ _ _ _ residualRead) (replay_nil _ _)) + next notLast => + simp only [notLast,Bool.false_eq_true,↓reduceIte,List.append_nil] + cases ok + exact replay_cons _ _ _ _ _ _ head (replay_nil _ _) + | ood i j => + simp only [replyStep] at ok + obtain ⟨⟨mid,y⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨after,m⟩,second,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact replay_cons _ _ _ _ _ _ (read_call _ _ _ _ _ first) + (replay_cons _ _ _ _ _ _ (readMessage_call C _ _ _ second) (replay_nil _ _)) + | query i => + simp only [replyStep] at ok + obtain ⟨hint,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨hinted,taken,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨proof,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨root,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨opened,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨after,m⟩,second,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact replay_cons _ _ _ _ _ _ (hint_call _ _ _ taken) + (replay_cons _ _ _ _ _ _ (readMessage_call C _ _ _ second) (replay_nil _ _)) + | tail j => + change (if isVisibleTail j then (do + let (next,m) ← readMessage C cur + pure (next,{col with replies := col.replies.push (.tail m)})) else some (cur,col)) = + some (next,col') at ok + simp only [replyCalls] + split at ok + next visible => + simp only [visible,↓reduceIte] + obtain ⟨⟨after,m⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact replay_cons _ _ _ _ _ _ (readMessage_call C _ _ _ first) (replay_nil _ _) + next hidden => + simp only [hidden,Bool.false_eq_true,↓reduceIte] + cases ok + rfl + +theorem step_replay (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (state next : Cursor × Collected p) (q : Coord p) + (ok : step C decode grinding lanes state q = some next) : + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) state.1 + (callsOf grinding q) = .ok next.1 := by + unfold step at ok + obtain ⟨⟨powed,col⟩,powOk,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨drawn,x⟩,drawOk,ok⟩ := Option.bind_eq_some_iff.mp ok + have first := powStep_replay C grinding _ _ _ _ q powOk + have second := drawStep_replay C _ _ q x drawOk + have third := replyStep_replay C decode lanes _ next.1 _ next.2 q ok + unfold callsOf + rw [SpongefishCurrentAcceptedJoin.actualReplay_append _ _ _ _ _ + (by rw [SpongefishCurrentAcceptedJoin.actualReplay_append _ _ _ _ _ first]; exact second)] + exact third + +/-- The accepted native opening is one accepted actual replay of the literal +opening call list. -/ +theorem run_replay (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (qs : List (Coord p)) (state final : Cursor × Collected p), + run C decode grinding lanes qs state = some final → + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) state.1 + (qs.flatMap (callsOf grinding)) = .ok final.1 + | [], state, final, ok => by + simp only [run,Option.some.injEq] at ok + subst ok + rfl + | q :: qs, state, final, ok => by + simp only [run] at ok + obtain ⟨mid,first,rest⟩ := Option.bind_eq_some_iff.mp ok + rw [List.flatMap_cons,SpongefishCurrentAcceptedJoin.actualReplay_append _ _ _ _ _ + (step_replay C decode grinding lanes state mid q first)] + exact run_replay C decode grinding lanes qs mid final rest + +#print axioms run_replay + +/-! ## Composition with the accepted caller path -/ + +theorem schedule_head : ∃ qs, WHIRHistory.schedule cfg = Coordinate.initial :: qs := by + exact ⟨(visibleCoordinates cfg).tail ++ WHIRHistory.hiddenTail cfg, + by simp [WHIRHistory.schedule,visibleCoordinates]⟩ + +theorem openingCalls_head (grinding : Fin (cfg).folds.size → Fin 64) : + ∃ rest, openingCalls grinding = .draw .stackFamilyAndLambda :: rest := by + obtain ⟨qs,head⟩ := schedule_head (p := p) + refine ⟨replyCalls (p := p) .initial ++ qs.flatMap (callsOf grinding),?_⟩ + simp only [openingCalls,head,List.flatMap_cons,callsOf,powCalls,drawCalls,group, + List.nil_append] + rfl + +/-! ## Proof of work at every ground query level -/ + +theorem powStep_pows (C : PrimitiveOracle) (grinding : Fin (cfg).folds.size → Fin 64) + (cur next : Cursor) (col col' : Collected p) (q : Coord p) + (ok : powStep C grinding cur col q = some (next,col')) : + ∃ extra, col'.pows = col.pows ++ extra := by + cases q with + | query i => + simp only [powStep] at ok + split at ok + · cases ok; exact ⟨[],by simp⟩ + · split at ok + · cases ok + · split at ok + · cases ok + · cases ok; exact ⟨_,rfl⟩ + | initial => cases ok; exact ⟨[],by simp⟩ + | fold i j => cases ok; exact ⟨[],by simp⟩ + | ood i j => cases ok; exact ⟨[],by simp⟩ + | tail j => cases ok; exact ⟨[],by simp⟩ + +theorem powStep_query (C : PrimitiveOracle) (grinding : Fin (cfg).folds.size → Fin 64) + (cur next : Cursor) (col col' : Collected p) (i : Fin (cfg).folds.size) + (positive : (grinding i).val ≠ 0) + (ok : powStep C grinding cur col (.query i) = some (next,col')) : + ∃ check ∈ col'.pows, check.level = i ∧ check.bits = grinding i := by + simp only [powStep,positive,↓reduceIte] at ok + split at ok + · cases ok + · split at ok + · cases ok + · cases ok + exact ⟨_,List.mem_append_right _ (List.mem_singleton_self _),rfl,rfl⟩ + +theorem recordSample_pows (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) : + (recordSample col q x).pows = col.pows := by + cases q <;> rfl + +theorem replyStep_pows (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) (lanes : Nat) + (cur next : Cursor) (col col' : Collected p) (q : Coord p) + (ok : replyStep C decode lanes cur col q = some (next,col')) : col'.pows = col.pows := by + cases q with + | initial => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + | fold i j => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + split at ok + · split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + · cases ok; rfl + | ood i j => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + | query i => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + | tail j => + change (if isVisibleTail j then (do + let (next,m) ← readMessage C cur + pure (next,{col with replies := col.replies.push (.tail m)})) else some (cur,col)) = + some (next,col') at ok + split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + · cases ok; rfl + +theorem step_pows (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (state next : Cursor × Collected p) (q : Coord p) + (ok : step C decode grinding lanes state q = some next) : + ∃ extra, next.2.pows = state.2.pows ++ extra := by + unfold step at ok + obtain ⟨⟨powed,col⟩,powOk,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨drawn,x⟩,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨extra,grown⟩ := powStep_pows C grinding _ _ _ _ q powOk + refine ⟨extra,?_⟩ + rw [replyStep_pows C decode lanes _ next.1 _ next.2 q ok,recordSample_pows,grown] + +theorem run_pows (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (qs : List (Coord p)) (state final : Cursor × Collected p), + run C decode grinding lanes qs state = some final → + ∃ extra, final.2.pows = state.2.pows ++ extra + | [], state, final, ok => by + simp only [run,Option.some.injEq] at ok + subst ok + exact ⟨[],by simp⟩ + | q :: qs, state, final, ok => by + simp only [run] at ok + obtain ⟨mid,first,rest⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨a,ha⟩ := step_pows C decode grinding lanes state mid q first + obtain ⟨b,hb⟩ := run_pows C decode grinding lanes qs mid final rest + exact ⟨a ++ b,by rw [hb,ha,List.append_assoc]⟩ + +theorem run_query_pow (C : PrimitiveOracle) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (i : Fin (cfg).folds.size) + (positive : (grinding i).val ≠ 0) : + ∀ (qs : List (Coord p)) (state final : Cursor × Collected p), .query i ∈ qs → + run C decode grinding lanes qs state = some final → + ∃ check ∈ final.2.pows, check.level = i ∧ check.bits = grinding i + | [], _, _, member, _ => by cases member + | q :: qs, state, final, member, ok => by + simp only [run] at ok + obtain ⟨mid,first,rest⟩ := Option.bind_eq_some_iff.mp ok + rcases List.mem_cons.mp member with same | later + · subst same + unfold step at first + obtain ⟨⟨powed,col⟩,powOk,first⟩ := Option.bind_eq_some_iff.mp first + obtain ⟨⟨drawn,x⟩,_,first⟩ := Option.bind_eq_some_iff.mp first + obtain ⟨check,checkMember,level,bits⟩ := powStep_query C grinding _ _ _ _ i positive powOk + have midPows : mid.2.pows = col.pows := by + rw [replyStep_pows C decode lanes _ mid.1 _ mid.2 _ first,recordSample_pows] + obtain ⟨extra,grown⟩ := run_pows C decode grinding lanes qs mid final rest + refine ⟨check,?_,level,bits⟩ + rw [grown,midPows] + exact List.mem_append_left _ checkMember + · exact run_query_pow C decode grinding lanes i positive qs mid final later rest + +/-- Every ground query level of an accepted opening executed its proof of work +on the actual raw32 challenge, and that work cleared the configured difficulty. -/ +theorem accepted_pow {C : PrimitiveOracle} + {decode : List Byte → Option MerkleTransport.PrunedMerklePaths} + {grinding : Fin (cfg).folds.size → Fin 64} {r : SpongefishSessionAdapter.Record} + {input : PCSBCSCallerBinding.CallerInput p} {cur : Cursor} + (a : Accepted C decode grinding r input cur) (i : Fin (cfg).folds.size) + (positive : (grinding i).val ≠ 0) : + ∃ check ∈ a.collected.pows, check.level = i ∧ check.bits = grinding i ∧ + SpongefishPowAdapter.clears (grinding i) + (SpongefishPowAdapter.trial C check.challenge check.nonce) = true := by + obtain ⟨check,member,level,bits⟩ := run_query_pow C decode grinding r.shape.lanes i positive + (WHIRHistory.schedule cfg) _ _ (WHIRHistory.coordinate_mem_schedule _) a.ran + refine ⟨check,member,level,bits,?_⟩ + rw [← bits] + exact a.pow check member + +/-! ## Accepted caller path followed by the accepted opening -/ + +/-- The first opening draw passes the source cursor guard. -/ +theorem first_draw_guard (C : PrimitiveOracle) (iv : Digest32) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) + (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) + (represented : RepresentsCurrent (compressionOf C) iv cur.pending cur.state) + (a : Accepted C decode grinding r input cur) : + cur.pending.consumed + Group.stackFamilyAndLambda.bytes ≤ maxCursor := by + obtain ⟨qs,head⟩ := schedule_head (p := p) + have ran := a.ran + rw [head] at ran + simp only [run] at ran + obtain ⟨mid,first,_⟩ := Option.bind_eq_some_iff.mp ran + unfold step at first + obtain ⟨⟨powed,col⟩,powOk,first⟩ := Option.bind_eq_some_iff.mp first + obtain ⟨⟨drawn,x⟩,drawOk,_⟩ := Option.bind_eq_some_iff.mp first + simp only [powStep,Option.some.injEq,Prod.mk.injEq] at powOk + obtain ⟨rfl,rfl⟩ := powOk + unfold drawStep at drawOk + have width : PCSBCSRounds.rawWidth (Coordinate.initial : Coord p) ≠ 0 := by + simp [PCSBCSRounds.rawWidth,WHIRHistory.stackScalarCount] + simp only [width,↓reduceIte] at drawOk + split at drawOk + · cases drawOk + next next bytes squeezed => + unfold squeezeGroup at squeezed + cases sq : squeeze (compressionOf C) cur.state (group (p := p) .initial).bytes with + | error e => simp [sq] at squeezed + | ok pair => + have bound : cur.state.consumed + (group (p := p) .initial).bytes ≤ maxCursor := by + unfold squeeze at sq + split at sq + next zero => simp [group,Group.bytes,Group.elements] at zero + next => + split at sq + next fits => exact fits + next => cases sq + rw [SpongefishCurrentMixedModeCompiler.cursor_eq (compressionOf C) iv cur represented] at bound + exact bound + +open SpongefishCurrentAcceptedJoin DuplexFraming SpongefishCurrentModeQueries in +/-- An accepted #607 caller path (setup, prelude, commitment receive, payload and +expected-record binding) followed by an accepted native opening: the received +record is among the raw-decoded candidates of the post-binding construction key, +the public parser's prepared original equals the physical one, every prepared +original is in the public original list, the whole tape and opening are one +accepted actual replay, every ground query level's proof of work cleared, and +the anchored native equations hold for the prepared original claims. -/ +theorem accepted_opening_original (C : PrimitiveOracle) (iv : Digest32) + (layout : WHIRCallerClaims.CallerLayout) + (r : SpongefishSessionAdapter.Record) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (A : Nat) (attacker : Counts A prefixProgram) (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (initial pre received payload next : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) iv tag instanceBytes + (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints = some initial) + (preRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial before = + .ok pre) + (receivedEq : SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre + (AnchoredSourceCaller.shape layout) = some (received, r)) + (payloadRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received + payloadCalls = .ok payload) + (bindingEq : SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (input : PCSBCSCallerBinding.CallerInput p) + (opened : Accepted C decode grinding r input next) : + let tape := before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r + let Q := A + SpongefishCurrentInitializedMode.budget tag instanceBytes (tape ++ openingCalls grinding) + let q := coordinate next.pending (next.pending.consumed / 32) + let observations := (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag + instanceBytes prefixProgram (tape ++ openingCalls grinding))).view.observations + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial + (tape ++ openingCalls grinding) = .ok opened.final ∧ + (∀ i : Fin (cfg).folds.size, (grinding i).val ≠ 0 → + ∃ check ∈ opened.collected.pows, check.level = i ∧ check.bits = grinding i ∧ + SpongefishPowAdapter.clears (grinding i) + (SpongefishPowAdapter.trial C check.challenge check.nonce) = true) ∧ + anchoredVerify r input.family input.points opened.seed.1 opened.seed.2 cfg + (challenges cfg opened.collected.tape) opened.proof = .ok () ∧ + ∃ work : pathCost q ≤ Q, + r ∈ SpongefishCurrentRecordModeCapture.rawRecords (AnchoredSourceCaller.shape layout) iv + (constructionKey Q iv q work) ∧ + SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q r instanceBytes observations = + SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r instanceBytes ∧ + ∀ prepared, SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r + instanceBytes = some prepared → + prepared ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv + (constructionKey Q iv q work) instanceBytes observations := by + intro tape Q q observations + have tapeRun := composition_replay (compressionOf C) layout r before payloadCalls initial pre + received payload next preRun receivedEq payloadRun bindingEq + have openRun := run_replay C decode grinding r.shape.lanes (WHIRHistory.schedule cfg) _ _ opened.ran + have whole : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial + (tape ++ openingCalls grinding) = .ok opened.final := by + rw [actualReplay_append (compressionOf C) _ _ initial next tapeRun] + exact openRun + have initialRep : RepresentsCurrent (compressionOf C) iv initial.pending initial.state := by + have initialEq : SpongefishCurrentObservedSessionEntry.cursor + (SpongefishSessionAdapter.derive (compressionOf C) iv tag) instanceBytes + (runReal C iv prefixProgram).view.result.narg (runReal C iv prefixProgram).view.result.hints + (absorb (compressionOf C) (SpongefishSessionAdapter.init (compressionOf C) iv + (SpongefishSessionAdapter.derive (compressionOf C) iv tag)) instanceBytes) = initial := by + simpa [SpongefishCurrentObservedSessionEntry.actualSetup, SpongefishSessionAdapter.newSession, + nonempty] using setup + rw [← initialEq] + simpa [SpongefishCurrentObservedSessionEntry.cursor,nonempty] using + session_bridge (compressionOf C) iv (SpongefishSessionAdapter.derive (compressionOf C) iv tag) + instanceBytes + have nextRep : RepresentsCurrent (compressionOf C) iv next.pending next.state := by + have erased := SpongefishCurrentPrimitiveEventCompiler.actualReplay_erases (compressionOf C) + initial tape + rw [tapeRun] at erased + exact all_round_replay_bridge (compressionOf C) iv initial next tape initialRep erased.symm + have guard := first_draw_guard C iv decode grinding r input next nextRep opened + obtain ⟨rest,head⟩ := openingCalls_head (p := p) grinding + have joined := accepted_original_next C iv p layout r tag instanceBytes prefixProgram + .stackFamilyAndLambda rest A attacker nonempty before payloadCalls beforeEq payloadEq + initial pre received payload next setup preRun receivedEq payloadRun bindingEq + (by decide) guard + rw [← head] at joined + exact ⟨whole,accepted_pow opened,opened.equations,joined⟩ + +#print axioms accepted_pow +#print axioms accepted_opening_original + +end Whir.SpongefishCurrentOpeningAcceptance diff --git a/verification/whir/Whir/SpongefishCurrentRoundPackets.lean b/verification/whir/Whir/SpongefishCurrentRoundPackets.lean new file mode 100644 index 000000000..d2b1980cb --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRoundPackets.lean @@ -0,0 +1,224 @@ +import Whir.SpongefishCurrentOpeningAcceptance +import Whir.PCSBCSChallengeOracleRestoration + +/-! Current #607 PCS round packets in the basic full-prefix form. A current +construction key carries the session domain, the zero statement seed and the +complete absorbed prover prefix (`SpongefishCurrentAbsorbedPrefix`), not earlier +coin values. A packet is one closed key history together with the opening +coordinate it draws, selected by a fixed public classifier from the number of +absorbed frames after the caller boundary. Its blocks are the 32-byte output +blocks of that history; the grouped E decoder is the same as for the historical +packets. Every other raw key stays in the garbage summand. + +The node model reads its caller data through an arbitrary builder of the +erased table and applies the additive source RBR certificate. Its conditional +hazard is the proved `rbrError` for EVERY builder; connecting a builder to +accepted current executions is a separate refinement obligation. -/ +namespace Whir.SpongefishCurrentRoundPackets +open Concrete FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling +open PCSBCSChallengeOracle PCSBCSCallerBinding SpongefishCurrentOpeningAcceptance +set_option autoImplicit false +set_option maxRecDepth 100000 + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-- The verifier draws after expected-record binding, in order. A positive +query proof of work is a draw but not a PCS round (`none`); a zero-dimensional +OOD point issues no draw. -/ +def openingDraws (grinding : Fin (cfg).folds.size → Fin 64) : List (Option (Coord p)) := + (WHIRHistory.schedule cfg).flatMap fun q => + (match q with + | .query i => if (grinding i).val = 0 then [] else [none] + | _ => []) ++ + (if PCSBCSRounds.rawWidth q = 0 then [] else [some q]) + +/-- Fixed public classifier: a closed history with `boundary + k + 1` frames is +the `k`-th opening draw. -/ +def classify (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) (h : FramedHistory) : + Option (Coord p) := + if boundary < h.frames.length then + ((openingDraws grinding)[h.frames.length - boundary - 1]?).bind id + else none + +theorem openingDraws_width (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) + (member : some q ∈ openingDraws grinding) : PCSBCSRounds.rawWidth q ≠ 0 := by + obtain ⟨r,_,member⟩ := List.mem_flatMap.mp member + rcases List.mem_append.mp member with pow | draw + · cases r <;> simp_all + · by_cases zero : PCSBCSRounds.rawWidth r = 0 + · simp [zero] at draw + · simp only [zero,↓reduceIte,List.mem_singleton,Option.some.injEq] at draw + subst draw + exact zero + +theorem classify_width (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) + (h : FramedHistory) (q : Coord p) (classified : classify grinding boundary h = some q) : + PCSBCSRounds.rawWidth q ≠ 0 := by + unfold classify at classified + split at classified + · obtain ⟨draw,found,same⟩ := Option.bind_eq_some_iff.mp classified + cases same + exact openingDraws_width grinding q (List.mem_of_getElem? found) + · cases classified + +theorem blocks_positive (q : Coord p) (width : PCSBCSRounds.rawWidth q ≠ 0) : + 0 < blocks (PCSBCSRounds.rawWidth q) := by + unfold blocks + omega + +/-- One current round packet: a closed key history and its classified coordinate. -/ +structure Packet (p : ParameterBounds.Profile) (Q : Nat) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) (boundary : Nat) where + history : FramedHistory + coord : Coord p + classified : classify grinding boundary history = some coord + admissible : ∀ b : Fin (blocks (PCSBCSRounds.rawWidth coord)), + DuplexEncoding.Admissible ⟨history,.output b.val⟩ + bounded : ∀ b : Fin (blocks (PCSBCSRounds.rawWidth coord)), pathCost ⟨history,.output b.val⟩ ≤ Q + +section PacketKeys +variable {Q : Nat} {grinding : Fin (ParameterBounds.config p).folds.size → Fin 64} {boundary : Nat} + +abbrev PacketBlock (packet : Packet p Q grinding boundary) := Fin (blocks (PCSBCSRounds.rawWidth packet.coord)) + +def packetKey (iv : Digest32) (packet : Packet p Q grinding boundary) (b : PacketBlock packet) : RawKey Q := + constructionKey Q iv ⟨packet.history,.output b.val⟩ (packet.bounded b) + +def firstBlock (packet : Packet p Q grinding boundary) : PacketBlock packet := + ⟨0,blocks_positive packet.coord (classify_width grinding boundary _ _ packet.classified)⟩ + +theorem packet_ext_history (a b : Packet p Q grinding boundary) (same : a.history = b.history) : a = b := by + cases a with + | mk ha ca cla ada ba => + cases b with + | mk hb cb clb adb bb => + dsimp only at same + subst same + have coords : ca = cb := Option.some.inj (cla.symm.trans clb) + subst coords + rfl + +theorem key_coordinates (iv : Digest32) (a b : Packet p Q grinding boundary) (ia : PacketBlock a) + (ib : PacketBlock b) (same : packetKey iv a ia = packetKey iv b ib) : a.history = b.history ∧ ia.val = ib.val := by + have coordinates := constructionKey_injective Q iv (a.admissible ia) (b.admissible ib) + (a.bounded ia) (b.bounded ib) same + have history := congrArg FiatShamirGame.Coordinate.history coordinates + have terminal := congrArg FiatShamirGame.Coordinate.terminal coordinates + dsimp only at history terminal + exact ⟨history,by simpa using terminal⟩ + +def blockKey (iv : Digest32) (block : Sigma (PacketBlock (p := p) (Q := Q) (grinding := grinding) + (boundary := boundary))) : PublicCompressionCouplingMixed.Key Q := + .inr (packetKey iv block.1 block.2) + +theorem blockKey_injective (iv : Digest32) : + Function.Injective (blockKey (p := p) (Q := Q) (grinding := grinding) (boundary := boundary) iv) := by + intro a b same + rcases a with ⟨a,ia⟩ + rcases b with ⟨b,ib⟩ + obtain ⟨history,index⟩ := key_coordinates iv a b ia ib (Sum.inr.inj same) + have packets := packet_ext_history a b history + subst packets + have blocksSame : ia = ib := Fin.ext index + subst blocksSame + rfl + +theorem firstKey_injective (iv : Digest32) : + Function.Injective (fun packet : Packet p Q grinding boundary => packetKey iv packet (firstBlock packet)) := by + intro a b same + exact packet_ext_history a b (key_coordinates iv a b _ _ same).1 + +noncomputable instance : Fintype (Packet p Q grinding boundary) := by + classical + letI := rawKeyFintype Q + exact Fintype.ofInjective _ (firstKey_injective (p := p) (Q := Q) (grinding := grinding) + (boundary := boundary) (fun _ => 0)) + +end PacketKeys + +variable (p : ParameterBounds.Profile) (Q : Nat) (iv : Digest32) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) (boundary : Nat) + +/-- Raw source keys: current round packet blocks, every other key garbage. -/ +noncomputable def partition : + Partition (PublicCompressionCouplingMixed.Key Q) (Packet p Q grinding boundary) PacketBlock := + partitionOfInjection (blockKey iv) (blockKey_injective iv) + +abbrev Key := (partition p Q iv grinding boundary).Key +abbrev Answer := (partition p Q iv grinding boundary).Answer (D := Digest32) + +noncomputable local instance (key : Key p Q iv grinding boundary) : + Fintype (Answer p Q iv grinding boundary key) := + match key with + | .inl _ => inferInstance + | .inr _ => inferInstance + +/-- Caller data reconstructed from the table with the selected packet erased. -/ +abbrev Builder := (packet : Packet p Q grinding boundary) → + PCSStateRestoration.Latent.Erased (Answer p Q iv grinding boundary) (.inl packet) → + Option (CallerData p) + +/-- Additive RBR node model on the current round packets. -/ +noncomputable def model (build : Builder p Q iv grinding boundary) : + PCSStateRestoration.Latent.NodeModel (Key p Q iv grinding boundary) + (Answer p Q iv grinding boundary) (Option (CallerData p)) where + reconstruct key other := match key with + | .inl packet => build packet other + | .inr _ => none + before data key := match key, data with + | .inl packet, some caller => (callerCertificate p).before caller packet.coord + | _, _ => false + after data key answer := match key with + | .inl packet => match data with + | some caller => (callerCertificate p).after caller packet.coord (grouped packet.coord answer) + | none => false + | .inr _ => false + +/-- The current whole output blocks of one packet induce exactly the checked +RBR alphabet; the incoming state is fixed before every bit of the packet. -/ +theorem packet_fiber (caller : CallerData p) (packet : Packet p Q grinding boundary) + (undoomed : (callerCertificate p).before caller packet.coord = false) : + Soundness.uniformProb (Finset.univ.filter fun full : + Fin (blocks (PCSBCSRounds.rawWidth packet.coord)) → Digest32 => + (callerCertificate p).after caller packet.coord (grouped packet.coord full) = true) ≤ + PCSRoundByRoundKnowledge.rbrError := by + classical + have law := grouped_uniform packet.coord (fun answer => + (callerCertificate p).after caller packet.coord answer = true) + rw [SamplingProbability.probability_eq_uniformProb, + SamplingProbability.probability_eq_uniformProb] at law + have exactLaw := (Rat.cast_inj (α := ℝ)).mp law + exact exactLaw.trans_le (caller_fiber p caller packet.coord undoomed) + +/-- Proved conditional hazard on the current packets, for every builder. -/ +theorem conditional_hazard (build : Builder p Q iv grinding boundary) : + PCSStateRestoration.Latent.ConditionalHazard (model p Q iv grinding boundary build) + PCSRoundByRoundKnowledge.rbrError := by + classical + intro key other undoomed + cases key with + | inl packet => + cases recovered : build packet other with + | none => + simp only [model,recovered,Bool.false_eq_true,Finset.filter_false, + Soundness.uniformProb,Finset.card_empty,Nat.cast_zero,zero_div] + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + | some caller => + simp only [model,recovered] at undoomed + have bound := packet_fiber p Q grinding boundary caller packet undoomed + unfold Soundness.uniformProb at bound ⊢ + simp only [model,recovered,Fintype.card_eq_nat_card] at bound ⊢ + exact bound + | inr garbage => + simp only [model,Bool.false_eq_true,Finset.filter_false,Soundness.uniformProb, + Finset.card_empty,Nat.cast_zero,zero_div] + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + +#print axioms blockKey_injective +#print axioms packet_fiber +#print axioms conditional_hazard + +end Whir.SpongefishCurrentRoundPackets diff --git a/verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean b/verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean new file mode 100644 index 000000000..88e45a745 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean @@ -0,0 +1,191 @@ +import Whir.SpongefishCurrentOpeningAcceptance + +/-! Distributional current #607 source join. The accepted caller path and +native opening of `SpongefishCurrentOpeningAcceptance.accepted_opening_original` +are a deterministic consequence of every real primitive and attacker coin. The +public event below reads only the whole source view: some public construction +key's public original list contains a prepared original with the selected +property. The initialized byte-mode coupling then transfers the real accepted +event to the ideal raw-oracle experiment with loss `min(1,(2Q^2-Q)/2^256)`. + +The source program replays one fixed caller tape followed by the opening call +list. Its record-binding message calls are a fixed parameter `messages`; the +real event requires the received record to have exactly these message calls. -/ +namespace Whir.SpongefishCurrentSourceJoinProbability +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentModeQueries +open SpongefishCurrentAcceptedJoin SpongefishCurrentOpeningAcceptance +set_option autoImplicit false + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +abbrev SourceResult := Option SpongefishCurrentInitializedMode.Result + +/-- Fixed caller tape followed by the native opening call list. -/ +def calls (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (grinding : Fin (cfg).folds.size → Fin 64) : List Call := + before ++ headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ messages ++ + openingCalls grinding + +def budget (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (grinding : Fin (cfg).folds.size → Fin 64) + (A : Nat) : Nat := + A + SpongefishCurrentInitializedMode.budget tag instanceBytes + (calls layout before payloadCalls messages grinding) + +def program (iv : Digest32) (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) : Program SourceResult := + SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram + (calls layout before payloadCalls messages grinding) + +/-- Real native acceptance of the whole current caller path and opening, with +the prepared original used by the opening equations. `Bad` may inspect the +whole source view, for example a failed public extraction. -/ +def NativeAcceptedBad (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) : Prop := + ∃ (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (initial pre received payload next : Cursor), + SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) iv tag instanceBytes + (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints = some initial ∧ + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial before = .ok pre ∧ + SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre + (AnchoredSourceCaller.shape layout) = some (received,r) ∧ + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received payloadCalls = + .ok payload ∧ + SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next ∧ + messageCalls r = messages ∧ + Nonempty (Accepted C decode grinding r input next) ∧ + SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout + (coordinate next.pending (next.pending.consumed / 32)) r instanceBytes = some input ∧ + Bad input (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages + grinding prefixProgram)).view + +/-- Public view event: some construction key's public original list contains +an original with the property. No hidden primitive or coin is read. -/ +def PublicBad (Q : Nat) (iv : Digest32) (instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (view : View SourceResult) : Prop := + ∃ (q : FiatShamirGame.Coordinate) (work : pathCost q ≤ Q) (input : PCSBCSCallerBinding.CallerInput p), + input ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv (constructionKey Q iv q work) + instanceBytes view.observations ∧ Bad input view + +open Classical in +noncomputable def publicObserver (Q : Nat) (iv : Digest32) (instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (view : View SourceResult) : Bool := + decide (PublicBad Q iv instanceBytes layout Bad view) + +/-- Pointwise join: real native acceptance places its prepared original in a +public original list of the same source view. -/ +theorem native_public (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (nonempty : instanceBytes ≠ []) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (native : NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram Bad) : + PublicBad (budget tag instanceBytes layout before payloadCalls messages grinding A) iv instanceBytes + layout Bad (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages + grinding prefixProgram)).view := by + obtain ⟨r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,payloadRun,bindingEq, + messagesEq,⟨opened⟩,physical,bad⟩ := native + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 + have joined := accepted_opening_original C iv layout r tag instanceBytes prefixProgram A attacker + nonempty before payloadCalls beforeEq payloadEq initial pre received payload next setup preRun + receivedEq payloadRun bindingEq decode grinding input opened + obtain ⟨_,_,_,work,_,_,member⟩ := joined + subst messagesEq + have sameCalls : calls layout before payloadCalls (messageCalls r) grinding = + before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r ++ + openingCalls grinding := by + rw [calls,shapeEq] + unfold budget program at * + rw [sameCalls] at bad ⊢ + exact ⟨_,work,input,member input physical,bad⟩ + +open Classical in +/-- Distributional source join: the real probability of native acceptance with +the selected property is at most the IDEAL probability of the public join event +plus the initialized current byte-mode coupling loss. -/ +theorem native_ideal_bound {Coins : Type} [Fintype Coins] [Nonempty Coins] + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) : + let Q := budget tag instanceBytes layout before payloadCalls messages grinding A + letI := DuplexPublicSimulator.seedFintype + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode + grinding (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + idealProbability (DuplexPublicSimulator.simulator Q) iv + (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin)) + (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) + (publicObserver Q iv instanceBytes layout Bad) + + min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) := by + intro Q + let _ := DuplexPublicSimulator.seedFintype + have subset : average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode + grinding (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + realProbability iv (fun coin => program iv tag instanceBytes layout before payloadCalls messages + grinding (prefixProgram coin)) (publicObserver Q iv instanceBytes layout Bad) := by + unfold realProbability + rw [distinguish_average (inferInstance : Fintype (PrimitiveOracle × Coins))] + apply average_mono + intro coins + by_cases native : NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls + messages decode grinding (prefixProgram coins.2) Bad + · have published := decide_eq_true (native_public coins.1 iv tag instanceBytes nonempty layout before + payloadCalls messages beforeEq payloadEq decode grinding (prefixProgram coins.2) A + (attacker coins.2) Bad native) + simp only [native,↓reduceIte] + change (1 : ℚ) ≤ if publicObserver Q iv instanceBytes layout Bad _ = true then 1 else 0 + have observed : publicObserver Q iv instanceBytes layout Bad (runReal coins.1 iv + (program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coins.2))).view = true := published + rw [observed] + norm_num + · simp only [native,↓reduceIte] + split <;> norm_num + have coupling : ModeAdv (DuplexPublicSimulator.simulator Q) iv + (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding + (prefixProgram coin)) + (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) + (publicObserver Q iv instanceBytes layout Bad) ≤ min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) := + SpongefishCurrentInitializedMode.afterPrefix_mode_bound iv tag instanceBytes + prefixProgram (calls layout before payloadCalls messages grinding) A attacker + (publicObserver Q iv instanceBytes layout Bad) + unfold ModeAdv at coupling + have deviation := (abs_le.mp coupling).2 + linarith + +#print axioms native_public +#print axioms native_ideal_bound + +end Whir.SpongefishCurrentSourceJoinProbability From 50b2e8c8d77f8b63ed732f479f0dbe5abd4c3d83 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 13:46:33 +0100 Subject: [PATCH 24/28] docs: record the opening-coverage prerequisite of the current endpoint --- verification/whir/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 12b1c4bdf..5e95257df 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -158,7 +158,7 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentSourceJoinProbability.native_ideal_bound` is the distributional source join. For an arbitrary counted adaptive attacker prefix and any property `Bad` of the prepared original and the whole source view, the real probability of native acceptance of the whole current caller path and opening with `Bad` is at most the ideal raw-oracle probability of the public event that some construction key's public original list contains an original with `Bad`, plus `min(1,(2Q^2-Q)/2^256)`. Its pointwise step `native_public` is the accepted join. The source replays one fixed caller tape followed by the opening call list; the record-binding message calls are a parameter that the real event matches. -`SpongefishCurrentRoundPackets` defines the current PCS round packets in the basic full-prefix form: a closed key history (session domain, zero statement seed and the complete absorbed prover prefix, with no earlier coin value) together with the opening coordinate selected by a fixed public frame-count classifier. Its blocks are the history's 32-byte output blocks under the same grouped decoder. `blockKey_injective` makes this a partition of the raw source keys, and `conditional_hazard` proves the additive RBR hazard `rbrError` for every caller-data builder. `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript: the real probability of native acceptance with `Bad` is at most `Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256`, where `Q` is the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. It is **conditional** on two named refinement obligations that are hypotheses, not probability premises, and are not yet discharged for the current transcript: `Reduction` (real native acceptance with `Bad` implies a public good event or the complete Merkle trace alarm for a root policy capped by `Q(Q+1)`) and `Refines` (on every ideal table where the good event fires, the current node model has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. `current_knowledge_level` states the endpoint at the deployed grinding with this numeric bound. The reduction obligation is further narrowed: `collision_alarm` proves for any program that an ordinary output collision in the public log of the real view raises the complete trace alarm, and `reduction_of_openingCover` derives `Reduction` for the canonical good event (public join, no public ordinary collision, a public opening predicate) from native acceptance alone, except for opening coverage. `current_knowledge_cover` is the endpoint with the remaining obligations `openingCover` (an accepted opening whose public opening predicate fails raises the alarm) and `Refines` for that canonical good event. +`SpongefishCurrentRoundPackets` defines the current PCS round packets in the basic full-prefix form: a closed key history (session domain, zero statement seed and the complete absorbed prover prefix, with no earlier coin value) together with the opening coordinate selected by a fixed public frame-count classifier. Its blocks are the history's 32-byte output blocks under the same grouped decoder. `blockKey_injective` makes this a partition of the raw source keys, and `conditional_hazard` proves the additive RBR hazard `rbrError` for every caller-data builder. `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript: the real probability of native acceptance with `Bad` is at most `Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256`, where `Q` is the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. It is **conditional** on two named refinement obligations that are hypotheses, not probability premises, and are not yet discharged for the current transcript: `Reduction` (real native acceptance with `Bad` implies a public good event or the complete Merkle trace alarm for a root policy capped by `Q(Q+1)`) and `Refines` (on every ideal table where the good event fires, the current node model has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. `current_knowledge_level` states the endpoint at the deployed grinding with this numeric bound. The reduction obligation is further narrowed: `collision_alarm` proves for any program that an ordinary output collision in the public log of the real view raises the complete trace alarm, and `reduction_of_openingCover` derives `Reduction` for the canonical good event (public join, no public ordinary collision, a public opening predicate) from native acceptance alone, except for opening coverage. `current_knowledge_cover` is the endpoint with the remaining obligations `openingCover` (an accepted opening whose public opening predicate fails raises the alarm) and `Refines` for that canonical good event. The opening's Merkle and proof-of-work hashes are evaluated by the deterministic verifier with the same primitive, but they are not observations of the counted source program; discharging `openingCover` therefore first requires adding them to that program, as the historical `WHIRPhysicalVerifier.openRows` program does. Executable paths that previously returned or retained a digest or squeeze output as a closure, and so recomputed earlier compressions at each use, now store the computed values as data. Each stored form is selected for compiled code by `@[csimp]` with a kernel-checked equality to the unchanged semantic definition (for example `DuplexRefinement.materialize_memo`, `stream_memo`, `DuplexFraming.evalPlan_stored`, `PublicMerkleLog.ordinaryPlan_stored` and the observed session traces), so every theorem about the semantic definitions applies to the executed code unchanged. From f529308a439b2736e93ccced04a3c42c387c88b0 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 13:57:50 +0100 Subject: [PATCH 25/28] proof: cover every binding message shape and pass query positions to the hint decoder --- verification/whir/README.md | 8 +- .../Whir/SpongefishCurrentBCSKnowledge.lean | 192 +++++++++++++++++- .../SpongefishCurrentOpeningAcceptance.lean | 40 ++-- ...pongefishCurrentSourceJoinProbability.lean | 6 +- 4 files changed, 212 insertions(+), 34 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 5e95257df..2f6776e49 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -154,11 +154,11 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentSourceCallerOriginal` is the deterministic current original-statement parser: for a raw construction key it enumerates at most four raw records, replays the caller tape `calls layout r` on the key's own history bytes using only public construction replies, and prepares the original claims. `SpongefishCurrentCallerGetterCoverage` proves that public replies cover the actual source replay, including rejected prefixes. `SpongefishCurrentAcceptedJoin.accepted_original` joins this parser to an accepted native caller path. Given accepted setup, prelude, receive, payload and binding, followed by any verifier suffix that queries the post-binding coordinate, the received record is among that key's raw-decoded candidates, the parser's public result equals the physical replay, and every prepared original is in the public original list. `accepted_original_next` derives that query when the suffix begins with a positive challenge draw, as the PCS opening does after binding: the draw either requests the first output block of the post-binding coordinate or finds it already recorded. The parser's call order, derived domain, reconstructed proof bytes and empty hints are consequences of the accepted replay rather than hypotheses: `composition_replay` shows that receive and binding are one accepted replay of the caller tape, and `shift_replay` shows that a hint-free replay accepted with unread proof bytes makes the same queries on its consumed prefix. Header validity follows from the accepted receive, and `actualReplay_bounded` derives the received context's one-block pending-buffer bound. `observed_original` states the same result for the observed physical compiler. Native PCS equation, proof-of-work and original-claim acceptance remain explicit; this is not a deployed Fiat-Shamir knowledge endpoint. -`SpongefishCurrentOpeningAcceptance` is the current native PCS opening after expected-record binding. It walks the configured coordinate schedule over the actual byte cursor: positive query proof of work (raw32 challenge, then the UInt64 nonce), the grouped verifier draw, decoded with the same grouped E codec as the historical packets, the Merkle hint and the prover reply in native order (fold coefficients, then the raw32 root or the full residual at a level end; OOD value and intro; query intro). Query rows come from the actual pruned opening of the decoded hint against the level root; the hint wire decoder is an explicit parameter, so every theorem holds for any decoder. Its equation check `anchoredVerify` is literally `AnchoredPhysicalAnchor.sourceVerify` on the record's shape, point and value (`anchoredVerify_historical` is `rfl`), so the existing anchored dense refinement applies unchanged. `run_replay` shows that an accepted opening is one accepted actual replay of the literal call list `openingCalls`, and `accepted_pow` that every ground query level executed its work on the actual raw32 challenge and cleared the configured difficulty. `accepted_opening_original` composes these with `SpongefishCurrentAcceptedJoin.accepted_original_next`, deriving the first-draw cursor guard (`first_draw_guard`): an accepted caller path followed by an accepted opening is one accepted replay of the caller tape and opening, satisfies the anchored native equations for the prepared original claims, and places that original in the public original list of the post-binding construction key. +`SpongefishCurrentOpeningAcceptance` is the current native PCS opening after expected-record binding. It walks the configured coordinate schedule over the actual byte cursor: positive query proof of work (raw32 challenge, then the UInt64 nonce), the grouped verifier draw, decoded with the same grouped E codec as the historical packets, the Merkle hint and the prover reply in native order (fold coefficients, then the raw32 root or the full residual at a level end; OOD value and intro; query intro). Query rows come from the actual pruned opening of the decoded hint against the level root; the hint wire decoder is an explicit parameter receiving the query positions and row width, as the native `PrunedMerklePaths::from_hint` does, so every theorem holds for any such decoder. Its equation check `anchoredVerify` is literally `AnchoredPhysicalAnchor.sourceVerify` on the record's shape, point and value (`anchoredVerify_historical` is `rfl`), so the existing anchored dense refinement applies unchanged. `run_replay` shows that an accepted opening is one accepted actual replay of the literal call list `openingCalls`, and `accepted_pow` that every ground query level executed its work on the actual raw32 challenge and cleared the configured difficulty. `accepted_opening_original` composes these with `SpongefishCurrentAcceptedJoin.accepted_original_next`, deriving the first-draw cursor guard (`first_draw_guard`): an accepted caller path followed by an accepted opening is one accepted replay of the caller tape and opening, satisfies the anchored native equations for the prepared original claims, and places that original in the public original list of the post-binding construction key. `SpongefishCurrentSourceJoinProbability.native_ideal_bound` is the distributional source join. For an arbitrary counted adaptive attacker prefix and any property `Bad` of the prepared original and the whole source view, the real probability of native acceptance of the whole current caller path and opening with `Bad` is at most the ideal raw-oracle probability of the public event that some construction key's public original list contains an original with `Bad`, plus `min(1,(2Q^2-Q)/2^256)`. Its pointwise step `native_public` is the accepted join. The source replays one fixed caller tape followed by the opening call list; the record-binding message calls are a parameter that the real event matches. -`SpongefishCurrentRoundPackets` defines the current PCS round packets in the basic full-prefix form: a closed key history (session domain, zero statement seed and the complete absorbed prover prefix, with no earlier coin value) together with the opening coordinate selected by a fixed public frame-count classifier. Its blocks are the history's 32-byte output blocks under the same grouped decoder. `blockKey_injective` makes this a partition of the raw source keys, and `conditional_hazard` proves the additive RBR hazard `rbrError` for every caller-data builder. `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript: the real probability of native acceptance with `Bad` is at most `Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256`, where `Q` is the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. It is **conditional** on two named refinement obligations that are hypotheses, not probability premises, and are not yet discharged for the current transcript: `Reduction` (real native acceptance with `Bad` implies a public good event or the complete Merkle trace alarm for a root policy capped by `Q(Q+1)`) and `Refines` (on every ideal table where the good event fires, the current node model has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. `current_knowledge_level` states the endpoint at the deployed grinding with this numeric bound. The reduction obligation is further narrowed: `collision_alarm` proves for any program that an ordinary output collision in the public log of the real view raises the complete trace alarm, and `reduction_of_openingCover` derives `Reduction` for the canonical good event (public join, no public ordinary collision, a public opening predicate) from native acceptance alone, except for opening coverage. `current_knowledge_cover` is the endpoint with the remaining obligations `openingCover` (an accepted opening whose public opening predicate fails raises the alarm) and `Refines` for that canonical good event. The opening's Merkle and proof-of-work hashes are evaluated by the deterministic verifier with the same primitive, but they are not observations of the counted source program; discharging `openingCover` therefore first requires adding them to that program, as the historical `WHIRPhysicalVerifier.openRows` program does. +`SpongefishCurrentRoundPackets` defines the current PCS round packets in the basic full-prefix form: a closed key history (session domain, zero statement seed and the complete absorbed prover prefix, with no earlier coin value) together with the opening coordinate selected by a fixed public frame-count classifier. Its blocks are the history's 32-byte output blocks under the same grouped decoder. `blockKey_injective` makes this a partition of the raw source keys, and `conditional_hazard` proves the additive RBR hazard `rbrError` for every caller-data builder. `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript: the real probability of native acceptance with `Bad` is at most `Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256`, where `Q` is the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. It is **conditional** on two named refinement obligations that are hypotheses, not probability premises, and are not yet discharged for the current transcript: `Reduction` (real native acceptance with `Bad` implies a public good event or the complete Merkle trace alarm for a root policy capped by `Q(Q+1)`) and `Refines` (on every ideal table where the good event fires, the current node model has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. `current_knowledge_level` states the endpoint at the deployed grinding with this numeric bound. The reduction obligation is further narrowed: `collision_alarm` proves for any program that an ordinary output collision in the public log of the real view raises the complete trace alarm, and `reduction_of_openingCover` derives `Reduction` for the canonical good event (public join, no public ordinary collision, a public opening predicate) from native acceptance alone, except for opening coverage. `current_knowledge_cover` is the endpoint with the remaining obligations `openingCover` (an accepted opening whose public opening predicate fails raises the alarm) and `Refines` for that canonical good event. The opening's Merkle and proof-of-work hashes are evaluated by the deterministic verifier with the same primitive, but they are not observations of the counted source program; discharging `openingCover` therefore first requires adding them to that program, as the historical `WHIRPhysicalVerifier.openRows` program does. A received record has at most three normalized pending packs (`accepted_packs`), so its binding calls are one of four literal lists (`messageCalls_binding`); `nativeAny_of_native` and `nativeAny_union` give `current_knowledge_all`, which bounds native acceptance with `Bad` for every received record by the sum of the four per-shape three-term bounds, under the per-shape obligations. Executable paths that previously returned or retained a digest or squeeze output as a closure, and so recomputed earlier compressions at each use, now store the computed values as data. Each stored form is selected for compiled code by `@[csimp]` with a kernel-checked equality to the unchanged semantic definition (for example `DuplexRefinement.materialize_memo`, `stream_memo`, `DuplexFraming.evalPlan_stored`, `PublicMerkleLog.ordinaryPlan_stored` and the observed session traces), so every theorem about the semantic definitions applies to the executed code unchanged. @@ -214,7 +214,7 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: -- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native opening adapter (`SpongefishCurrentOpeningAcceptance.accepted_opening_original`) and its distributional source join (`SpongefishCurrentSourceJoinProbability.native_ideal_bound`) are proved, and the basic full-prefix endpoint `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is proved conditional on its two named refinement obligations `Reduction` and `Refines`. Those obligations, the Merkle hint wire codec and the adaptive union over record-binding message shapes remain open. +- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native opening adapter (`SpongefishCurrentOpeningAcceptance.accepted_opening_original`) and its distributional source join (`SpongefishCurrentSourceJoinProbability.native_ideal_bound`) are proved, and the basic full-prefix endpoint `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is proved conditional on its two named refinement obligations `Reduction` and `Refines`. Those obligations and the Merkle hint wire codec remain open; `current_knowledge_all` removes the fixed record-binding message shape by a union over its four possible shapes. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. @@ -262,7 +262,7 @@ Its checked `random_compression_failure_probability` bounds acceptance with no o `PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. -The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15333 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. +The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15341 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. diff --git a/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean index 72602bf14..d72ff7f91 100644 --- a/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean +++ b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean @@ -189,6 +189,10 @@ theorem collision_alarm {R : Type} (C : PrimitiveOracle) (iv : Digest32) (progra (p := (⟨0,by decide⟩,⟨0,by decide⟩)) (boundary := 0) C iv program Q (le_refl Q) counted roots collision +/-- The three explicit summands of the current endpoint. -/ +def finalBound (Q : ℚ) : ℚ := + Q * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*Q^2-Q)/2^256) + (Q^3+3*Q^2-2*Q)/2^256 + /-! ## Current #607 endpoint -/ section Current @@ -212,7 +216,7 @@ named hypotheses, not probability premises. -/ theorem current_knowledge_bound {Coins : Type} [Fintype Coins] [Nonempty Coins] (iv : Digest32) (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) (attacker : ∀ coin, Counts A (prefixProgram coin)) @@ -285,7 +289,7 @@ theorem reduction_of_openingCover {Coins : Type} (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) (attacker : ∀ coin, Counts A (prefixProgram coin)) @@ -341,7 +345,7 @@ theorem current_knowledge_cover {Coins : Type} [Fintype Coins] [Nonempty Coins] (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) (attacker : ∀ coin, Counts A (prefixProgram coin)) @@ -386,14 +390,182 @@ theorem current_knowledge_cover {Coins : Type} [Fintype Coins] [Nonempty Coins] beforeEq payloadEq decode grinding prefixProgram A attacker Bad roots quiet openingCover) refines +/-! ### Every record-binding message shape -/ + +/-- Literal binding read calls of a record with `packs` normalized pending E. -/ +def bindingCalls (shape : AnchoredHeaderCodec.Shape) (packs : Nat) : List Call := + List.replicate 3 (.read .scalar) ++ [.read .root,.read .root] ++ List.replicate 2 (.read .scalar) ++ + List.replicate packs (.read .scalar) ++ List.replicate shape.logN (.read .scalar) ++ [.read .scalar] + +theorem messageCalls_binding (r : SpongefishSessionAdapter.Record) + (pointLength : r.point.length = r.shape.logN) : + SpongefishCurrentAcceptedJoin.messageCalls r = + bindingCalls r.shape ((r.context.pending.length+23)/24) := by + simp only [SpongefishCurrentAcceptedJoin.messageCalls,SpongefishRecordBindingParser.messages, + SpongefishRecordBindingParser.scalarMessages,List.map_append,List.map_map,List.map_cons, + List.map_nil,bindingCalls,SpongefishSessionAdapter.constants,SpongefishSessionAdapter.contextScalars, + SpongefishSessionAdapter.pendingPacks,Function.comp_def,List.map_const',List.length_ofFn, + pointLength] + rfl + +/-- The received record of an accepted caller path has at most three pending packs. -/ +theorem accepted_packs (c : DuplexRefinement.Compression) (iv : Digest32) + (tag instanceBytes narg : List Byte) (hints : List (List Byte)) + (layout : WHIRCallerClaims.CallerLayout) (before : List Call) + (r : SpongefishSessionAdapter.Record) (initial pre received : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup c iv tag instanceBytes narg hints = + some initial) + (preRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay c initial before = .ok pre) + (receivedEq : SpongefishCurrentCommitmentReceive.receive c pre + (AnchoredSourceCaller.shape layout) = some (received,r)) : + (r.context.pending.length+23)/24 < 4 ∧ r.point.length = r.shape.logN := by + obtain ⟨shapeEq,contextEq,pointLength,_⟩ := + SpongefishCurrentCommitmentReceive.receive_retains c pre received _ r receivedEq + have bounded := SpongefishCurrentAcceptedJoin.actualReplay_bounded c before initial pre + (SpongefishCurrentAcceptedJoin.setup_bounded c iv tag instanceBytes narg hints initial setup) preRun + have pendingBound : r.context.pending.length ≤ 64 := by + rw [contextEq] + simpa [SpongefishSessionAdapter.capture] using bounded + refine ⟨by omega,?_⟩ + rw [shapeEq] + exact pointLength + +/-- Native acceptance with `Bad` for SOME received record, without fixing its +binding message shape in advance. -/ +def NativeAcceptedAny (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) : Prop := + ∃ k : Fin 4, NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding prefixProgram Bad + +/-- Every natively accepted run, whatever its received record, has one of the +four binding message shapes. -/ +theorem nativeAny_of_native (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (native : NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram Bad) : + NativeAcceptedAny C iv tag instanceBytes layout before payloadCalls decode grinding + prefixProgram Bad := by + obtain ⟨r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,rest⟩ := native + obtain ⟨packs,pointLength⟩ := accepted_packs _ iv tag instanceBytes _ _ layout before r initial pre + received setup preRun receivedEq + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 + obtain ⟨payloadRun,bindingEq,messagesEq,rest⟩ := rest + have exact := messageCalls_binding r pointLength + rw [shapeEq] at exact + subst messagesEq + refine ⟨⟨_,packs⟩,r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,payloadRun, + bindingEq,exact,?_⟩ + rw [← exact] + exact rest + +open Classical in +/-- Union over the four binding message shapes: the probability of native +acceptance with `Bad` for any received record is at most the sum of the four +per-shape probabilities, each bounded by `current_knowledge_bound`. -/ +theorem nativeAny_union {Coins : Type} [Fintype Coins] + (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode grinding + (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + ∑ k : Fin 4, average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding + (prefixProgram coins.2) Bad then (1 : ℚ) else 0) := by + unfold average + rw [← Finset.sum_div] + apply div_le_div_of_nonneg_right _ (by positivity) + rw [Finset.sum_comm] + apply Finset.sum_le_sum + intro coins _ + by_cases any : NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode + grinding (prefixProgram coins.2) Bad + · obtain ⟨k,hk⟩ := any + simp only [show NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode + grinding (prefixProgram coins.2) Bad from ⟨k,hk⟩,↓reduceIte] + calc (1 : ℚ) = if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding + (prefixProgram coins.2) Bad then 1 else 0 := by simp only [hk,↓reduceIte] + _ ≤ _ := Finset.single_le_sum (f := fun k : Fin 4 => + if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding + (prefixProgram coins.2) Bad then (1 : ℚ) else 0) + (fun _ _ => by split <;> norm_num) (Finset.mem_univ k) + · simp only [any,↓reduceIte] + exact Finset.sum_nonneg (fun _ _ => by split <;> norm_num) + +open Classical in +/-- The current endpoint for EVERY received record: the four binding message +shapes each satisfy their own refinement obligations, and the bound is the sum +of the four explicit three-term bounds. -/ +theorem current_knowledge_all {Coins : Type} [Fintype Coins] [Nonempty Coins] + (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (boundary : Nat) + (build : ∀ k : Fin 4, Builder p (budget tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv grinding boundary) + (good : Fin 4 → View SourceResult → Bool) + (roots : Fin 4 → PublicMerkleProbability.RootPolicy) + (rootCap : ∀ (k : Fin 4) (log : PublicMerkleLog.PublicLog), + log.length ≤ budget tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A → + (roots k log).card ≤ budget tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A * + (budget tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A + 1)) + (reduction : ∀ k : Fin 4, Reduction (roots k) iv + (fun coin => program iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding (prefixProgram coin)) + (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding) A (attacker coin)) + (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding (prefixProgram coin) Bad) + (good k)) + (refines : ∀ (k : Fin 4) coin, Refines (partition p (budget tag instanceBytes layout before + payloadCalls (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv grinding + boundary) + (model p _ iv grinding boundary (build k)) iv + (program iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding (prefixProgram coin)) + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes + (prefixProgram coin) (calls layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding) A (attacker coin)) + (good k)) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode grinding + (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + ∑ k : Fin 4, finalBound (budget tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A : ℚ) := by + refine (nativeAny_union iv tag instanceBytes layout before payloadCalls decode grinding + prefixProgram Bad).trans (Finset.sum_le_sum fun k _ => ?_) + have bound := current_knowledge_bound iv tag instanceBytes layout before payloadCalls + (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding prefixProgram A attacker + Bad boundary (build k) (good k) (roots k) (rootCap k) (reduction k) (refines k) + unfold finalBound + exact bound + end Current /-! ## Concrete level from the deployed parameters -/ -/-- The three explicit summands of the current endpoint. -/ -def finalBound (Q : ℚ) : ℚ := - Q * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*Q^2-Q)/2^256) + (Q^3+3*Q^2-2*Q)/2^256 - /-- For every aggregate budget up to `2^64` primitive-work units the complete bound is at most `Q / 2^51`: each unit of attacker plus verifier work buys at most `2^-51` knowledge error, with no proof-of-work credit. -/ @@ -429,7 +601,7 @@ obligations. -/ theorem current_knowledge_level {p : ParameterBounds.Profile} {Coins : Type} [Fintype Coins] [Nonempty Coins] (iv : Digest32) (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) (attacker : ∀ coin, Counts A (prefixProgram coin)) (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) @@ -483,5 +655,9 @@ theorem current_knowledge_level {p : ParameterBounds.Profile} {Coins : Type} [Fi #print axioms collision_alarm #print axioms reduction_of_openingCover #print axioms current_knowledge_cover +#print axioms messageCalls_binding +#print axioms nativeAny_of_native +#print axioms nativeAny_union +#print axioms current_knowledge_all end Whir.SpongefishCurrentBCSKnowledge diff --git a/verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean b/verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean index 945490e1f..5d23f7288 100644 --- a/verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean +++ b/verification/whir/Whir/SpongefishCurrentOpeningAcceptance.lean @@ -12,8 +12,9 @@ raw32 root or full residual, OOD value and intro, query intro), and the accepted opening is checked by the anchored native equation verifier on the original family and point claims of the caller and the received record. -The Merkle hint wire codec is an explicit parameter: every theorem below holds -for an arbitrary decoder. This module is the deterministic adapter; it is not +The Merkle hint wire codec is an explicit parameter receiving the query +positions and row width, as the native `PrunedMerklePaths::from_hint` does: +every theorem below holds for an arbitrary decoder. This module is the deterministic adapter; it is not a probability or knowledge statement. -/ namespace Whir.SpongefishCurrentOpeningAcceptance open Concrete Protocol CausalGame CausalProbability FiatShamirGame DuplexModeGame @@ -152,7 +153,7 @@ def openQuery (C : PrimitiveOracle) (lanes : Nat) (i : Fin (cfg).folds.size) (ro (WHIRPhysicalVerifier.leafWords p i.val)) /-- The prover reply at a coordinate, in native wire order. -/ -def replyStep (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) +def replyStep (C : PrimitiveOracle) (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (lanes : Nat) (cur : Cursor) (col : Collected p) : Coord p → Option (Cursor × Collected p) | .initial => do let (next,m) ← readMessage C cur @@ -175,7 +176,8 @@ def replyStep (C : PrimitiveOracle) (decode : List Byte → Option MerkleTranspo | .query i => do let hint ← cur.hints.head? let hinted ← takeHint cur - let proof ← decode hint + let proof ← decode (WHIRPhysicalVerifier.queryIndices p i (CausalProbability.get (.query i) col.tape)) + (if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val) hint let root ← col.roots[i.val]? let opened ← openQuery C lanes i root proof (CausalProbability.get (.query i) col.tape) let (next,m) ← readMessage C hinted @@ -187,14 +189,14 @@ def replyStep (C : PrimitiveOracle) (decode : List Byte → Option MerkleTranspo pure (next,{col with replies := col.replies.push (.tail m)}) else some (cur,col) -def step (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) +def step (C : PrimitiveOracle) (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (state : Cursor × Collected p) (q : Coord p) : Option (Cursor × Collected p) := do let (powed,col) ← powStep C grinding state.1 state.2 q let (drawn,x) ← drawStep C powed q replyStep C decode lanes drawn (recordSample col q x) q -def run (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) +def run (C : PrimitiveOracle) (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : List (Coord p) → Cursor × Collected p → Option (Cursor × Collected p) | [], state => some state @@ -228,7 +230,7 @@ theorem anchoredVerify_historical {m : Nat} (r : SpongefishSessionAdapter.Record /-- Accepted native opening: every proof of work clears, the replies parse at the configured shape, and the anchored native equations hold for the original caller claims. Merkle hints authenticated inside `run`. -/ -structure Accepted (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) +structure Accepted (C : PrimitiveOracle) (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) where final : Cursor @@ -245,7 +247,7 @@ structure Accepted (C : PrimitiveOracle) (decode : List Byte → Option MerkleTr (challenges cfg collected.tape) proof = .ok () /-- Executable acceptance decision with exactly the fields of `Accepted`. -/ -def verify (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) +def verify (C : PrimitiveOracle) (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) : Bool := match run C decode grinding r.shape.lanes (WHIRHistory.schedule cfg) (cur,Collected.start r.root) with @@ -265,7 +267,7 @@ def verify (C : PrimitiveOracle) (decode : List Byte → Option MerkleTransport. | .ok () => true theorem verify_accepted (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) (accepted : verify C decode grinding r input cur = true) : @@ -376,7 +378,7 @@ theorem drawStep_replay (C : PrimitiveOracle) (cur next : Cursor) (q : Coord p) exact replay_cons _ _ _ _ _ _ (squeezeGroup_call _ _ _ _ _ squeezed) (replay_nil _ _) theorem replyStep_replay (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) (lanes : Nat) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (lanes : Nat) (cur next : Cursor) (col col' : Collected p) (q : Coord p) (ok : replyStep C decode lanes cur col q = some (next,col')) : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) cur (replyCalls q) = @@ -448,7 +450,7 @@ theorem replyStep_replay (C : PrimitiveOracle) rfl theorem step_replay (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (state next : Cursor × Collected p) (q : Coord p) (ok : step C decode grinding lanes state q = some next) : @@ -468,7 +470,7 @@ theorem step_replay (C : PrimitiveOracle) /-- The accepted native opening is one accepted actual replay of the literal opening call list. -/ theorem run_replay (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : ∀ (qs : List (Coord p)) (state final : Cursor × Collected p), run C decode grinding lanes qs state = some final → @@ -540,7 +542,7 @@ theorem recordSample_pows (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Ra cases q <;> rfl theorem replyStep_pows (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) (lanes : Nat) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (lanes : Nat) (cur next : Cursor) (col col' : Collected p) (q : Coord p) (ok : replyStep C decode lanes cur col q = some (next,col')) : col'.pows = col.pows := by cases q with @@ -583,7 +585,7 @@ theorem replyStep_pows (C : PrimitiveOracle) · cases ok; rfl theorem step_pows (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (state next : Cursor × Collected p) (q : Coord p) (ok : step C decode grinding lanes state q = some next) : @@ -596,7 +598,7 @@ theorem step_pows (C : PrimitiveOracle) rw [replyStep_pows C decode lanes _ next.1 _ next.2 q ok,recordSample_pows,grown] theorem run_pows (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : ∀ (qs : List (Coord p)) (state final : Cursor × Collected p), run C decode grinding lanes qs state = some final → @@ -613,7 +615,7 @@ theorem run_pows (C : PrimitiveOracle) exact ⟨a ++ b,by rw [hb,ha,List.append_assoc]⟩ theorem run_query_pow (C : PrimitiveOracle) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (i : Fin (cfg).folds.size) (positive : (grinding i).val ≠ 0) : ∀ (qs : List (Coord p)) (state final : Cursor × Collected p), .query i ∈ qs → @@ -640,7 +642,7 @@ theorem run_query_pow (C : PrimitiveOracle) /-- Every ground query level of an accepted opening executed its proof of work on the actual raw32 challenge, and that work cleared the configured difficulty. -/ theorem accepted_pow {C : PrimitiveOracle} - {decode : List Byte → Option MerkleTransport.PrunedMerklePaths} + {decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths} {grinding : Fin (cfg).folds.size → Fin 64} {r : SpongefishSessionAdapter.Record} {input : PCSBCSCallerBinding.CallerInput p} {cur : Cursor} (a : Accepted C decode grinding r input cur) (i : Fin (cfg).folds.size) @@ -658,7 +660,7 @@ theorem accepted_pow {C : PrimitiveOracle} /-- The first opening draw passes the source cursor guard. -/ theorem first_draw_guard (C : PrimitiveOracle) (iv : Digest32) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) (cur : Cursor) (represented : RepresentsCurrent (compressionOf C) iv cur.pending cur.state) @@ -725,7 +727,7 @@ theorem accepted_opening_original (C : PrimitiveOracle) (iv : Digest32) (payloadRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received payloadCalls = .ok payload) (bindingEq : SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (input : PCSBCSCallerBinding.CallerInput p) (opened : Accepted C decode grinding r input next) : let tape := before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r diff --git a/verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean b/verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean index 88e45a745..d568291e2 100644 --- a/verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean +++ b/verification/whir/Whir/SpongefishCurrentSourceJoinProbability.lean @@ -45,7 +45,7 @@ the prepared original used by the opening equations. `Bad` may inspect the whole source view, for example a failed public extraction. -/ def NativeAcceptedBad (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) : Prop := @@ -93,7 +93,7 @@ theorem native_public (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) (attacker : Counts A prefixProgram) @@ -130,7 +130,7 @@ theorem native_ideal_bound {Coins : Type} [Fintype Coins] [Nonempty Coins] (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) - (decode : List Byte → Option MerkleTransport.PrunedMerklePaths) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) (grinding : Fin (cfg).folds.size → Fin 64) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) (attacker : ∀ coin, Counts A (prefixProgram coin)) From b196f891d703aaee561d73b5d254718f14a61629 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 14:31:00 +0100 Subject: [PATCH 26/28] proof: deployed opening call list equals the inspected current loop layout --- verification/whir/README.md | 4 +- .../Whir/SpongefishCurrentBCSKnowledge.lean | 41 +++++++++++++++++++ 2 files changed, 43 insertions(+), 2 deletions(-) diff --git a/verification/whir/README.md b/verification/whir/README.md index 2f6776e49..a3fe08799 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -154,7 +154,7 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentSourceCallerOriginal` is the deterministic current original-statement parser: for a raw construction key it enumerates at most four raw records, replays the caller tape `calls layout r` on the key's own history bytes using only public construction replies, and prepares the original claims. `SpongefishCurrentCallerGetterCoverage` proves that public replies cover the actual source replay, including rejected prefixes. `SpongefishCurrentAcceptedJoin.accepted_original` joins this parser to an accepted native caller path. Given accepted setup, prelude, receive, payload and binding, followed by any verifier suffix that queries the post-binding coordinate, the received record is among that key's raw-decoded candidates, the parser's public result equals the physical replay, and every prepared original is in the public original list. `accepted_original_next` derives that query when the suffix begins with a positive challenge draw, as the PCS opening does after binding: the draw either requests the first output block of the post-binding coordinate or finds it already recorded. The parser's call order, derived domain, reconstructed proof bytes and empty hints are consequences of the accepted replay rather than hypotheses: `composition_replay` shows that receive and binding are one accepted replay of the caller tape, and `shift_replay` shows that a hint-free replay accepted with unread proof bytes makes the same queries on its consumed prefix. Header validity follows from the accepted receive, and `actualReplay_bounded` derives the received context's one-block pending-buffer bound. `observed_original` states the same result for the observed physical compiler. Native PCS equation, proof-of-work and original-claim acceptance remain explicit; this is not a deployed Fiat-Shamir knowledge endpoint. -`SpongefishCurrentOpeningAcceptance` is the current native PCS opening after expected-record binding. It walks the configured coordinate schedule over the actual byte cursor: positive query proof of work (raw32 challenge, then the UInt64 nonce), the grouped verifier draw, decoded with the same grouped E codec as the historical packets, the Merkle hint and the prover reply in native order (fold coefficients, then the raw32 root or the full residual at a level end; OOD value and intro; query intro). Query rows come from the actual pruned opening of the decoded hint against the level root; the hint wire decoder is an explicit parameter receiving the query positions and row width, as the native `PrunedMerklePaths::from_hint` does, so every theorem holds for any such decoder. Its equation check `anchoredVerify` is literally `AnchoredPhysicalAnchor.sourceVerify` on the record's shape, point and value (`anchoredVerify_historical` is `rfl`), so the existing anchored dense refinement applies unchanged. `run_replay` shows that an accepted opening is one accepted actual replay of the literal call list `openingCalls`, and `accepted_pow` that every ground query level executed its work on the actual raw32 challenge and cleared the configured difficulty. `accepted_opening_original` composes these with `SpongefishCurrentAcceptedJoin.accepted_original_next`, deriving the first-draw cursor guard (`first_draw_guard`): an accepted caller path followed by an accepted opening is one accepted replay of the caller tape and opening, satisfies the anchored native equations for the prepared original claims, and places that original in the public original list of the post-binding construction key. +`SpongefishCurrentOpeningAcceptance` is the current native PCS opening after expected-record binding. It walks the configured coordinate schedule over the actual byte cursor: positive query proof of work (raw32 challenge, then the UInt64 nonce), the grouped verifier draw, decoded with the same grouped E codec as the historical packets, the Merkle hint and the prover reply in native order (fold coefficients, then the raw32 root or the full residual at a level end; OOD value and intro; query intro). Query rows come from the actual pruned opening of the decoded hint against the level root; the hint wire decoder is an explicit parameter receiving the query positions and row width, as the native `PrunedMerklePaths::from_hint` does, so every theorem holds for any such decoder. Its equation check `anchoredVerify` is literally `AnchoredPhysicalAnchor.sourceVerify` on the record's shape, point and value (`anchoredVerify_historical` is `rfl`), so the existing anchored dense refinement applies unchanged. `SpongefishCurrentBCSKnowledge.deployed_schedule` checks by kernel computation, for all 56 production profiles at the deployed grinding, that `openingCalls` is exactly the separately inspected current source loop layout `OpeningLayout.schedule`, so `deployed_opening_between` inherits its round separation. `run_replay` shows that an accepted opening is one accepted actual replay of the literal call list `openingCalls`, and `accepted_pow` that every ground query level executed its work on the actual raw32 challenge and cleared the configured difficulty. `accepted_opening_original` composes these with `SpongefishCurrentAcceptedJoin.accepted_original_next`, deriving the first-draw cursor guard (`first_draw_guard`): an accepted caller path followed by an accepted opening is one accepted replay of the caller tape and opening, satisfies the anchored native equations for the prepared original claims, and places that original in the public original list of the post-binding construction key. `SpongefishCurrentSourceJoinProbability.native_ideal_bound` is the distributional source join. For an arbitrary counted adaptive attacker prefix and any property `Bad` of the prepared original and the whole source view, the real probability of native acceptance of the whole current caller path and opening with `Bad` is at most the ideal raw-oracle probability of the public event that some construction key's public original list contains an original with `Bad`, plus `min(1,(2Q^2-Q)/2^256)`. Its pointwise step `native_public` is the accepted join. The source replays one fixed caller tape followed by the opening call list; the record-binding message calls are a parameter that the real event matches. @@ -262,7 +262,7 @@ Its checked `random_compression_failure_probability` bounds acceptance with no o `PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. -The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15341 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. +The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15368 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. diff --git a/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean index d72ff7f91..70c40b706 100644 --- a/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean +++ b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean @@ -593,6 +593,45 @@ theorem finalBound_levels : def deployedGrinding (p : ParameterBounds.Profile) : Fin (ParameterBounds.config p).folds.size → Fin 64 := fun _ => ⟨17,by decide⟩ +deriving instance DecidableEq for WireKind +deriving instance DecidableEq for Call + +/-- The predecessor's literal current source loop layout for a configuration. -/ +def boundaryOf (c : Protocol.Config) (grinding : Nat → Fin 64) (i : Nat) : Boundary := + ⟨CausalGame.remaining c i,CausalGame.oodCount c i,CausalGame.remaining c i + c.rates[i]!, + c.queries[i]!,grinding i⟩ + +def layoutOf (c : Protocol.Config) (grinding : Nat → Fin 64) : OpeningLayout where + initialRounds := c.folds[0]! + firstBoundary := boundaryOf c grinding 0 + intermediate := (List.range (c.folds.size - 2)).map fun k => + (c.folds[k+1]!,boundaryOf c grinding (k+1)) + finalFoldRounds := c.folds[c.folds.size - 1]! + residualDimension := CausalGame.remaining c (c.folds.size - 1) + finalDepth := CausalGame.remaining c (c.folds.size - 1) + c.rates[c.folds.size - 1]! + finalCount := c.queries[c.folds.size - 1]! + finalGrinding := grinding (c.folds.size - 1) + +set_option maxRecDepth 100000 in +set_option maxHeartbeats 0 in +/-- Kernel computation for all 56 production profiles at the deployed grinding: +the per-coordinate opening call list is exactly the separately inspected +current source loop layout `SpongefishPCSRoundFrames.OpeningLayout.schedule`. -/ +theorem deployed_schedule : ∀ p : ParameterBounds.Profile, + SpongefishCurrentOpeningAcceptance.openingCalls (p := p) (deployedGrinding p) = + (layoutOf (ParameterBounds.config p) (fun _ => ⟨17,by decide⟩)).schedule := by + decide +kernel + +/-- Consequently any two verifier draws of the deployed opening are separated +by a nonempty canonical prover payload. -/ +theorem deployed_opening_between (p : ParameterBounds.Profile) (pre middle suffix : List Call) + (first second : Group) + (scheduled : SpongefishCurrentOpeningAcceptance.openingCalls (p := p) (deployedGrinding p) = + pre ++ (Call.draw first :: (middle ++ Call.draw second :: suffix))) : + ∃ kind, Call.read kind ∈ middle ∧ ∀ value : kind.Value, kind.codec.bytes value ≠ [] := by + rw [deployed_schedule p] at scheduled + exact SpongefishCurrentRoundSeparation.opening_between _ pre middle suffix first second scheduled + open Classical SpongefishCurrentRoundPackets SpongefishCurrentSourceJoinProbability in /-- The current endpoint at the deployed grinding, evaluated numerically: with an aggregate budget of at most `2^64` units the real probability of native @@ -659,5 +698,7 @@ theorem current_knowledge_level {p : ParameterBounds.Profile} {Coins : Type} [Fi #print axioms nativeAny_of_native #print axioms nativeAny_union #print axioms current_knowledge_all +#print axioms deployed_schedule +#print axioms deployed_opening_between end Whir.SpongefishCurrentBCSKnowledge From d14924fa49f26d66e2c2f0cdbb60e21e3dffeff7 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 16:37:38 +0100 Subject: [PATCH 27/28] proof: count the opening Merkle hashes and discharge current opening coverage The full current source program re-walks the opening over the replay events and authenticates every query batch with counted hash programs. A current root policy (cap Q(Q+1)) and the ported physical freeze give opening_cover, and reduction_full proves the reduction to the public good event. The endpoint full_knowledge_bound is conditional only on Refines. --- verification/whir/README.md | 12 +- verification/whir/Whir.lean | 8 + .../Whir/SpongefishCurrentBCSKnowledge.lean | 428 +----- .../SpongefishCurrentCallerOriginalTable.lean | 775 ++++++++++ .../whir/Whir/SpongefishCurrentGoodEvent.lean | 79 + .../SpongefishCurrentKnowledgeEndpoint.lean | 744 ++++++++++ .../SpongefishCurrentOpeningExperiment.lean | 789 ++++++++++ .../Whir/SpongefishCurrentOpeningPackets.lean | 1249 ++++++++++++++++ .../Whir/SpongefishCurrentOpeningProgram.lean | 1321 +++++++++++++++++ .../SpongefishCurrentPartitionCapture.lean | 286 ++++ .../Whir/SpongefishCurrentRootPolicy.lean | 685 +++++++++ 11 files changed, 5958 insertions(+), 418 deletions(-) create mode 100644 verification/whir/Whir/SpongefishCurrentCallerOriginalTable.lean create mode 100644 verification/whir/Whir/SpongefishCurrentGoodEvent.lean create mode 100644 verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean create mode 100644 verification/whir/Whir/SpongefishCurrentOpeningExperiment.lean create mode 100644 verification/whir/Whir/SpongefishCurrentOpeningPackets.lean create mode 100644 verification/whir/Whir/SpongefishCurrentOpeningProgram.lean create mode 100644 verification/whir/Whir/SpongefishCurrentPartitionCapture.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRootPolicy.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index a3fe08799..52fb7ed15 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -158,7 +158,11 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentSourceJoinProbability.native_ideal_bound` is the distributional source join. For an arbitrary counted adaptive attacker prefix and any property `Bad` of the prepared original and the whole source view, the real probability of native acceptance of the whole current caller path and opening with `Bad` is at most the ideal raw-oracle probability of the public event that some construction key's public original list contains an original with `Bad`, plus `min(1,(2Q^2-Q)/2^256)`. Its pointwise step `native_public` is the accepted join. The source replays one fixed caller tape followed by the opening call list; the record-binding message calls are a parameter that the real event matches. -`SpongefishCurrentRoundPackets` defines the current PCS round packets in the basic full-prefix form: a closed key history (session domain, zero statement seed and the complete absorbed prover prefix, with no earlier coin value) together with the opening coordinate selected by a fixed public frame-count classifier. Its blocks are the history's 32-byte output blocks under the same grouped decoder. `blockKey_injective` makes this a partition of the raw source keys, and `conditional_hazard` proves the additive RBR hazard `rbrError` for every caller-data builder. `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript: the real probability of native acceptance with `Bad` is at most `Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256`, where `Q` is the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. It is **conditional** on two named refinement obligations that are hypotheses, not probability premises, and are not yet discharged for the current transcript: `Reduction` (real native acceptance with `Bad` implies a public good event or the complete Merkle trace alarm for a root policy capped by `Q(Q+1)`) and `Refines` (on every ideal table where the good event fires, the current node model has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. `current_knowledge_level` states the endpoint at the deployed grinding with this numeric bound. The reduction obligation is further narrowed: `collision_alarm` proves for any program that an ordinary output collision in the public log of the real view raises the complete trace alarm, and `reduction_of_openingCover` derives `Reduction` for the canonical good event (public join, no public ordinary collision, a public opening predicate) from native acceptance alone, except for opening coverage. `current_knowledge_cover` is the endpoint with the remaining obligations `openingCover` (an accepted opening whose public opening predicate fails raises the alarm) and `Refines` for that canonical good event. The opening's Merkle and proof-of-work hashes are evaluated by the deterministic verifier with the same primitive, but they are not observations of the counted source program; discharging `openingCover` therefore first requires adding them to that program, as the historical `WHIRPhysicalVerifier.openRows` program does. A received record has at most three normalized pending packs (`accepted_packs`), so its binding calls are one of four literal lists (`messageCalls_binding`); `nativeAny_of_native` and `nativeAny_union` give `current_knowledge_all`, which bounds native acceptance with `Bad` for every received record by the sum of the four per-shape three-term bounds, under the per-shape obligations. +`SpongefishCurrentRoundPackets` defines the current PCS round packets in the basic full-prefix form: a closed key history (session domain, zero statement seed and the complete absorbed prover prefix, with no earlier coin value) together with the opening coordinate selected by a fixed public frame-count classifier. Its blocks are the history's 32-byte output blocks under the same grouped decoder. `blockKey_injective` makes this a partition of the raw source keys, and `conditional_hazard` proves the additive RBR hazard `rbrError` for every caller-data builder. + +`SpongefishCurrentOpeningProgram.fullProgram` is the counted current source program followed by a public opening walk: after an accepted replay it re-walks the opening schedule over the replay's recorded source events (exactly one event per call, `actualReplay_events`, `program_events`) and authenticates every query batch with the existing `WHIRPhysicalVerifier.openRows` hash programs, so the opening's Merkle hashes are observations of the counted program. Its budget `fullBudget` is the previous budget plus a uniform public Merkle budget (`fullProgram_counted`), and the initialized byte-mode coupling applies unchanged (`fullProgram_mode_bound`). `walk_native` and `fullProgram_native` show that on the real primitive the walk returns exactly the native `Accepted.collected`, with every hashed input's compression plan in the program's primitive log and shorter than `2^56` bytes. `SpongefishCurrentRootPolicy.targets` is the current root policy: it recovers construction coordinates from the newest-first public primitive log and collects Root0 (the commitment header frame) and every announced level root (bytes 48 to 80 of the reply frame after a level-ending fold); `targets_grow` and `targets_cap` (`Q(Q+1)`) hold, and `actual_firstMention_admitted` and `captured_opening_quiet` port the historical physical freeze and admission to current raw keys. + +`SpongefishCurrentKnowledgeEndpoint.full_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript. Its real event is native acceptance of the whole current caller path and opening while the public straight-line extractor fails (`SpongefishCurrentGoodEvent.ExtractionFails`: Root0 frozen at the first key whose history mentions it, then the source extractor on the frozen image). Its probability is at most `finalBound Q = Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256` with `Q = fullBudget`, the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. The reduction is proved (`reduction_full`): real native acceptance with extraction failure is the public good event `SpongefishCurrentGoodEvent.GoodFull` (accepted replay and walk, the caller original reconstructed publicly at the post-binding coordinate, the native opening equations, extraction failure, no public ordinary output collision, every query opening quiet against the frozen first-mention log of its root) or raises the complete Merkle trace alarm. Opening coverage (`opening_cover`) and collisions (`SpongefishCurrentBCSKnowledge.collision_alarm`) both reach the alarm; `postBinding_native` proves the static frame boundary of the post-binding coordinate. The endpoint is **conditional** on exactly one named refinement obligation, a hypothesis and not a probability premise: `Refines` (on every ideal table where the good event fires, the current node model with some per-coin caller-data builder has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. A received record has at most three normalized pending packs (`accepted_packs`), so its binding calls are one of four literal lists (`messageCalls_binding`); `messages_binding_full` and `nativeAnyFull_union` give `full_knowledge_all`, which bounds native acceptance with extraction failure for every received record by the sum of the four per-shape bounds, and `full_knowledge_level` evaluates it at the deployed grinding as at most the sum of the four `Q_k/2^51` when each per-shape budget is at most `2^64`. Executable paths that previously returned or retained a digest or squeeze output as a closure, and so recomputed earlier compressions at each use, now store the computed values as data. Each stored form is selected for compiled code by `@[csimp]` with a kernel-checked equality to the unchanged semantic definition (for example `DuplexRefinement.materialize_memo`, `stream_memo`, `DuplexFraming.evalPlan_stored`, `PublicMerkleLog.ordinaryPlan_stored` and the observed session traces), so every theorem about the semantic definitions applies to the executed code unchanged. @@ -214,11 +218,11 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: -- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native opening adapter (`SpongefishCurrentOpeningAcceptance.accepted_opening_original`) and its distributional source join (`SpongefishCurrentSourceJoinProbability.native_ideal_bound`) are proved, and the basic full-prefix endpoint `SpongefishCurrentBCSKnowledge.current_knowledge_bound` is proved conditional on its two named refinement obligations `Reduction` and `Refines`. Those obligations and the Merkle hint wire codec remain open; `current_knowledge_all` removes the fixed record-binding message shape by a union over its four possible shapes. +- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native opening adapter (`SpongefishCurrentOpeningAcceptance.accepted_opening_original`) and its distributional source join (`SpongefishCurrentSourceJoinProbability.native_ideal_bound`) are proved, and the basic full-prefix endpoint `SpongefishCurrentKnowledgeEndpoint.full_knowledge_bound`, for the full source program whose opening Merkle hashes are counted observations, is proved with the reduction (including opening coverage under the current root policy) discharged and conditional on the single named refinement obligation `Refines`. `Refines` and the Merkle hint wire codec remain open; `full_knowledge_all` removes the fixed record-binding message shape by a union over its four possible shapes. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. -- **Deployment/security target:** the public mode theorem models the pre-#607 #552 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not currently apply to the #607 session-IV and raw-byte transcript, cover the new anchor frames or establish deterministic BLAKE2s security. For #607, `current_knowledge_bound` gives the explicit three-term bound conditional on its two refinement obligations; numerically it is at most `Q/2^51` for `Q <= 2^64`. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. +- **Deployment/security target:** the public mode theorem models the pre-#607 #552 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not currently apply to the #607 session-IV and raw-byte transcript, cover the new anchor frames or establish deterministic BLAKE2s security. For #607, `full_knowledge_bound` gives the explicit three-term bound conditional on its one refinement obligation `Refines`; numerically it is at most `Q/2^51` per binding message shape for `Q <= 2^64`. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the historical #552 byte-duplex framing and the proved adaptive ideal-compression coupling. The #607 session-IV seed and raw-byte root absorption, additional anchor inputs, their cursor-based sampling, updated source-event refinement and Fiat-Shamir knowledge extraction remain separate composition obligations. @@ -262,7 +266,7 @@ Its checked `random_compression_failure_probability` bounds acceptance with no o `PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. -The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15368 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. +The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15794 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index c7662a1c8..841c72ae5 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -261,3 +261,11 @@ import Whir.SpongefishCurrentOpeningAcceptance import Whir.SpongefishCurrentSourceJoinProbability import Whir.SpongefishCurrentRoundPackets import Whir.SpongefishCurrentBCSKnowledge +import Whir.SpongefishCurrentOpeningProgram +import Whir.SpongefishCurrentRootPolicy +import Whir.SpongefishCurrentOpeningPackets +import Whir.SpongefishCurrentOpeningExperiment +import Whir.SpongefishCurrentCallerOriginalTable +import Whir.SpongefishCurrentPartitionCapture +import Whir.SpongefishCurrentGoodEvent +import Whir.SpongefishCurrentKnowledgeEndpoint diff --git a/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean index 70c40b706..c5426021b 100644 --- a/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean +++ b/verification/whir/Whir/SpongefishCurrentBCSKnowledge.lean @@ -5,20 +5,9 @@ import Whir.PCSBCSChallengeOracleEnteredGames import Whir.PCSBCSPublicPrimitiveOpening import Whir.PCSBCSNativePhysicalMerkleBad -/-! Basic full-prefix BCS knowledge composition for the current #607 transcript -(`remark:bcs-with-basic-fs` of the pinned book source). The basic variant has -no hash-chain term, so the final bound has exactly three summands: - -* the additive source RBR term `Q * rbrError` on the current round packets, -* the initialized byte-mode coupling `min(1,(2Q^2-Q)/2^256)`, -* the complete public Merkle trace alarm `(Q^3+3Q^2-2Q)/2^256`. - -The generic part holds for any packet partition and node model with a proved -conditional hazard. The current instance uses `SpongefishCurrentRoundPackets`. -Two refinement obligations remain explicit hypotheses of the current endpoint: -real native acceptance with extraction failure reduces to a public good event -or the Merkle alarm, and the good event in every ideal table yields a state -path of the current node model. Neither is an assumed probability bound. -/ +/-! Basic full-prefix BCS knowledge composition for the current #607 transcript (`remark:bcs-with-basic-fs` of the pinned book source). The basic variant has no hash-chain term, so the final bound `finalBound` has exactly three summands: the additive source RBR term `Q * rbrError` on the round packets, the initialized byte-mode coupling `min(1,(2Q^2-Q)/2^256)` and the complete public Merkle trace alarm `(Q^3+3Q^2-2Q)/2^256`. + +The generic part holds for any packet partition and any per-coin node model with a proved conditional hazard. The module also supplies the pointwise reduction to a public good event or the Merkle alarm (`Reduction`, `reduction_union`), the ordinary output collision alarm (`collision_alarm`), the four record-binding message shapes, the deployed opening schedule and the numeric level. The current endpoint for the full source program with the opening walk is `SpongefishCurrentKnowledgeEndpoint.full_knowledge_bound`. -/ namespace Whir.SpongefishCurrentBCSKnowledge open Concrete FiatShamirGame DuplexModeGame DuplexFraming RawOracleCoupling open PCSBCSChallengeOracle PCSStateRestoration.Latent TypedOracleCompiler SpongefishPCSRoundFrames @@ -57,13 +46,13 @@ variable [Fintype part.Key] [DecidableEq part.Key] [∀ key, Fintype (part.Answer (D := Digest32) key)] [∀ key, Nonempty (part.Answer (D := Digest32) key)] open Classical in -/-- Ideal packet experiment: at most `Q * epsilon`. -/ +/-- Ideal packet experiment: at most `Q * epsilon`, for a node model chosen per attacker coin. -/ theorem ideal_bound {P AdvCoins R : Type} [Fintype AdvCoins] [Nonempty AdvCoins] - (model : NodeModel part.Key (part.Answer (D := Digest32)) P) (epsilon : ℚ) - (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard model epsilon) (iv : Digest32) + (model : AdvCoins → NodeModel part.Key (part.Answer (D := Digest32)) P) (epsilon : ℚ) + (nonnegative : 0 ≤ epsilon) (hazard : ∀ a, ConditionalHazard (model a) epsilon) (iv : Digest32) (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) (observe : View R → Bool) - (refines : ∀ a, Refines part model iv (adversary a) (counted a) observe) : + (refines : ∀ a, Refines part (model a) iv (adversary a) (counted a) observe) : atomicIdealProbability part iv adversary counted observe ≤ (Q : ℚ) * epsilon := by unfold atomicIdealProbability have each (a : AdvCoins) : @@ -73,8 +62,8 @@ theorem ideal_bound {P AdvCoins R : Type} [Fintype AdvCoins] [Nonempty AdvCoins] have tableMemo := RawOracleCoupling.empty_table_eq_memo (source part iv (adversary a) (counted a)) (fun view => if observe view then (1 : ℚ) else 0) rw [← tableMemo,average_indicator] - have bound := accepted_path_failure_probability model Q 0 (source part iv (adversary a) (counted a)) - epsilon nonnegative hazard + have bound := accepted_path_failure_probability (model a) Q 0 (source part iv (adversary a) (counted a)) + epsilon nonnegative (hazard a) (fun table => observe (Sampling.eval table (source part iv (adversary a) (counted a))) = true) (refines a) simp only [Nat.add_zero] at bound @@ -89,13 +78,13 @@ theorem ideal_bound {P AdvCoins R : Type} [Fintype AdvCoins] [Nonempty AdvCoins] unfold source congr 2 <;> exact Subsingleton.elim _ _ -/-- Real primitive experiment: ideal packet bound plus the whole-view coupling. -/ +/-- Real primitive experiment: ideal packet bound plus the whole-view coupling, for a node model chosen per attacker coin. -/ theorem real_bound {P AdvCoins R : Type} [Fintype AdvCoins] [Nonempty AdvCoins] - (model : NodeModel part.Key (part.Answer (D := Digest32)) P) (epsilon : ℚ) - (nonnegative : 0 ≤ epsilon) (hazard : ConditionalHazard model epsilon) (iv : Digest32) + (model : AdvCoins → NodeModel part.Key (part.Answer (D := Digest32)) P) (epsilon : ℚ) + (nonnegative : 0 ≤ epsilon) (hazard : ∀ a, ConditionalHazard (model a) epsilon) (iv : Digest32) (adversary : AdvCoins → Program R) (counted : ∀ a, Counts Q (adversary a)) (observe : View R → Bool) - (refines : ∀ a, Refines part model iv (adversary a) (counted a) observe) : + (refines : ∀ a, Refines part (model a) iv (adversary a) (counted a) observe) : realProbability iv adversary observe ≤ (Q : ℚ) * epsilon + duplexModeLoss Q := by have coupling := actual_source_atomic_game_bound part iv adversary counted observe have deviation := (abs_le.mp coupling).2 @@ -193,204 +182,7 @@ theorem collision_alarm {R : Type} (C : PrimitiveOracle) (iv : Digest32) (progra def finalBound (Q : ℚ) : ℚ := Q * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*Q^2-Q)/2^256) + (Q^3+3*Q^2-2*Q)/2^256 -/-! ## Current #607 endpoint -/ - -section Current -open SpongefishCurrentRoundPackets SpongefishCurrentSourceJoinProbability -variable {p : ParameterBounds.Profile} -local notation "cfg" => ParameterBounds.config p - -noncomputable local instance (Q : Nat) (iv : Digest32) (grinding : Fin (cfg).folds.size → Fin 64) - (boundary : Nat) (key : SpongefishCurrentRoundPackets.Key p Q iv grinding boundary) : - Fintype (SpongefishCurrentRoundPackets.Answer p Q iv grinding boundary key) := - match key with - | .inl _ => inferInstance - | .inr _ => inferInstance - -open Classical in -/-- The current #607 basic full-prefix knowledge endpoint. The real event is -native acceptance of the whole current caller path and opening, with the -property `Bad` (for example failed public extraction) of the prepared original. -Every summand of the bound is explicit; the two refinement obligations are -named hypotheses, not probability premises. -/ -theorem current_knowledge_bound {Coins : Type} [Fintype Coins] [Nonempty Coins] - (iv : Digest32) (tag instanceBytes : List Byte) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (grinding : Fin (cfg).folds.size → Fin 64) - (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) - (attacker : ∀ coin, Counts A (prefixProgram coin)) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) - (boundary : Nat) - (build : Builder p (budget tag instanceBytes layout before payloadCalls messages grinding A) iv - grinding boundary) - (good : View SourceResult → Bool) - (roots : PublicMerkleProbability.RootPolicy) - (rootCap : ∀ log : PublicMerkleLog.PublicLog, - log.length ≤ budget tag instanceBytes layout before payloadCalls messages grinding A → - (roots log).card ≤ budget tag instanceBytes layout before payloadCalls messages grinding A * - (budget tag instanceBytes layout before payloadCalls messages grinding A + 1)) - (reduction : Reduction roots iv - (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding - (prefixProgram coin)) - (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) - (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages - decode grinding (prefixProgram coin) Bad) good) - (refines : ∀ coin, Refines (partition p (budget tag instanceBytes layout before payloadCalls - messages grinding A) iv grinding boundary) - (model p _ iv grinding boundary build) iv - (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) - (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) - good) : - let Q := budget tag instanceBytes layout before payloadCalls messages grinding A - average (fun coins : PrimitiveOracle × Coins => - if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode - grinding (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ - (Q : ℚ) * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) + - ((Q : ℚ)^3+3*(Q : ℚ)^2-2*(Q : ℚ))/2^256 := by - dsimp only - classical - have union := reduction_union roots iv _ _ _ good reduction - have merkle := merkle_bound roots rootCap iv - (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding - (prefixProgram coin)) - (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) - have nonnegative : (0 : ℚ) ≤ PCSRoundByRoundKnowledge.rbrError := by - unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope - positivity - have real := real_bound _ _ PCSRoundByRoundKnowledge.rbrError nonnegative - (conditional_hazard p _ iv grinding boundary build) iv _ _ good refines - have rbr : PCSRoundByRoundKnowledge.rbrError = (17/32 : ℚ)^56 + 1/2^78 := by - simp only [PCSRoundByRoundKnowledge.rbrError,SupportedCandidateExtraction.radiusEnvelope] - rw [rbr,duplexModeLoss_eq] at real - exact union.trans (add_le_add real merkle) - -open Classical in -/-- Canonical public good event: the public original join with `Bad`, no -ordinary output collision in the public log, and a public opening predicate. -/ -noncomputable def canonicalGood (Q : Nat) (iv : Digest32) (instanceBytes : List Byte) - (layout : WHIRCallerClaims.CallerLayout) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) - (quiet : View SourceResult → Bool) (view : View SourceResult) : Bool := - publicObserver Q iv instanceBytes layout Bad view && - decide (¬ PublicMerkleLog.OutputCollision - (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog Q iv view)) && quiet view - -/-- The reduction obligation narrows to opening coverage: native acceptance -with `Bad` already gives the public join (`native_public`) and every public -ordinary collision raises the alarm (`collision_alarm`). -/ -theorem reduction_of_openingCover {Coins : Type} - (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls - (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) - (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls - (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (grinding : Fin (cfg).folds.size → Fin 64) - (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) - (attacker : ∀ coin, Counts A (prefixProgram coin)) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) - (roots : PublicMerkleProbability.RootPolicy) (quiet : View SourceResult → Bool) - (openingCover : ∀ C coin, NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls - messages decode grinding (prefixProgram coin) Bad → - quiet (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages grinding - (prefixProgram coin))).view = false → - PublicMerkleProbability.traceAlarm roots [] - (PublicCompressionProgram.primitiveLog C iv - (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) - (budget tag instanceBytes layout before payloadCalls messages grinding A) - (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin))) = - true) : - Reduction roots iv - (fun coin => program iv tag instanceBytes layout before payloadCalls messages grinding - (prefixProgram coin)) - (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) - (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages - decode grinding (prefixProgram coin) Bad) - (canonicalGood (budget tag instanceBytes layout before payloadCalls messages grinding A) iv - instanceBytes layout Bad quiet) := by - classical - intro C coin native - have joined := native_public C iv tag instanceBytes nonempty layout before payloadCalls messages - beforeEq payloadEq decode grinding (prefixProgram coin) A (attacker coin) Bad native - by_cases collision : PublicMerkleLog.OutputCollision - (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog - (budget tag instanceBytes layout before payloadCalls messages grinding A) iv - (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages grinding - (prefixProgram coin))).view) - · exact Or.inr (collision_alarm C iv _ _ _ roots collision) - · cases quietEq : quiet (runReal C iv (program iv tag instanceBytes layout before payloadCalls - messages grinding (prefixProgram coin))).view with - | false => exact Or.inr (openingCover C coin native quietEq) - | true => - left - simp only [canonicalGood,quietEq,Bool.and_true,Bool.and_eq_true,decide_eq_true_eq] - exact ⟨decide_eq_true joined,collision⟩ - -open Classical in -/-- The current endpoint with the reduction narrowed to opening coverage. The -remaining obligations are `openingCover` (a native accepted opening whose -public opening predicate fails raises the Merkle trace alarm) and `Refines` for -the canonical good event. -/ -theorem current_knowledge_cover {Coins : Type} [Fintype Coins] [Nonempty Coins] - (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls - (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) - (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls - (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (grinding : Fin (cfg).folds.size → Fin 64) - (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) - (attacker : ∀ coin, Counts A (prefixProgram coin)) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) - (boundary : Nat) - (build : Builder p (budget tag instanceBytes layout before payloadCalls messages grinding A) iv - grinding boundary) - (quiet : View SourceResult → Bool) - (roots : PublicMerkleProbability.RootPolicy) - (rootCap : ∀ log : PublicMerkleLog.PublicLog, - log.length ≤ budget tag instanceBytes layout before payloadCalls messages grinding A → - (roots log).card ≤ budget tag instanceBytes layout before payloadCalls messages grinding A * - (budget tag instanceBytes layout before payloadCalls messages grinding A + 1)) - (openingCover : ∀ C coin, NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls - messages decode grinding (prefixProgram coin) Bad → - quiet (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages grinding - (prefixProgram coin))).view = false → - PublicMerkleProbability.traceAlarm roots [] - (PublicCompressionProgram.primitiveLog C iv - (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) - (budget tag instanceBytes layout before payloadCalls messages grinding A) - (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin))) = - true) - (refines : ∀ coin, Refines (partition p (budget tag instanceBytes layout before payloadCalls - messages grinding A) iv grinding boundary) - (model p _ iv grinding boundary build) iv - (program iv tag instanceBytes layout before payloadCalls messages grinding (prefixProgram coin)) - (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages grinding) A (attacker coin)) - (canonicalGood (budget tag instanceBytes layout before payloadCalls messages grinding A) iv - instanceBytes layout Bad quiet)) : - let Q := budget tag instanceBytes layout before payloadCalls messages grinding A - average (fun coins : PrimitiveOracle × Coins => - if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode - grinding (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ - (Q : ℚ) * ((17/32 : ℚ)^56 + 1/2^78) + min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) + - ((Q : ℚ)^3+3*(Q : ℚ)^2-2*(Q : ℚ))/2^256 := - current_knowledge_bound iv tag instanceBytes layout before payloadCalls messages decode grinding - prefixProgram A attacker Bad boundary build _ roots rootCap - (reduction_of_openingCover iv tag instanceBytes nonempty layout before payloadCalls messages - beforeEq payloadEq decode grinding prefixProgram A attacker Bad roots quiet openingCover) - refines - -/-! ### Every record-binding message shape -/ +/-! ## Every record-binding message shape -/ /-- Literal binding read calls of a record with `packs` normalized pending E. -/ def bindingCalls (shape : AnchoredHeaderCodec.Shape) (packs : Nat) : List Call := @@ -430,140 +222,6 @@ theorem accepted_packs (c : DuplexRefinement.Compression) (iv : Digest32) rw [shapeEq] exact pointLength -/-- Native acceptance with `Bad` for SOME received record, without fixing its -binding message shape in advance. -/ -def NativeAcceptedAny (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (grinding : Fin (cfg).folds.size → Fin 64) - (prefixProgram : Program SpongefishCurrentInitializedMode.Input) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) : Prop := - ∃ k : Fin 4, NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding prefixProgram Bad - -/-- Every natively accepted run, whatever its received record, has one of the -four binding message shapes. -/ -theorem nativeAny_of_native (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (grinding : Fin (cfg).folds.size → Fin 64) - (prefixProgram : Program SpongefishCurrentInitializedMode.Input) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) - (native : NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages decode - grinding prefixProgram Bad) : - NativeAcceptedAny C iv tag instanceBytes layout before payloadCalls decode grinding - prefixProgram Bad := by - obtain ⟨r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,rest⟩ := native - obtain ⟨packs,pointLength⟩ := accepted_packs _ iv tag instanceBytes _ _ layout before r initial pre - received setup preRun receivedEq - have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 - obtain ⟨payloadRun,bindingEq,messagesEq,rest⟩ := rest - have exact := messageCalls_binding r pointLength - rw [shapeEq] at exact - subst messagesEq - refine ⟨⟨_,packs⟩,r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,payloadRun, - bindingEq,exact,?_⟩ - rw [← exact] - exact rest - -open Classical in -/-- Union over the four binding message shapes: the probability of native -acceptance with `Bad` for any received record is at most the sum of the four -per-shape probabilities, each bounded by `current_knowledge_bound`. -/ -theorem nativeAny_union {Coins : Type} [Fintype Coins] - (iv : Digest32) (tag instanceBytes : List Byte) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (grinding : Fin (cfg).folds.size → Fin 64) - (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) : - average (fun coins : PrimitiveOracle × Coins => - if NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode grinding - (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ - ∑ k : Fin 4, average (fun coins : PrimitiveOracle × Coins => - if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding - (prefixProgram coins.2) Bad then (1 : ℚ) else 0) := by - unfold average - rw [← Finset.sum_div] - apply div_le_div_of_nonneg_right _ (by positivity) - rw [Finset.sum_comm] - apply Finset.sum_le_sum - intro coins _ - by_cases any : NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode - grinding (prefixProgram coins.2) Bad - · obtain ⟨k,hk⟩ := any - simp only [show NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode - grinding (prefixProgram coins.2) Bad from ⟨k,hk⟩,↓reduceIte] - calc (1 : ℚ) = if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding - (prefixProgram coins.2) Bad then 1 else 0 := by simp only [hk,↓reduceIte] - _ ≤ _ := Finset.single_le_sum (f := fun k : Fin 4 => - if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding - (prefixProgram coins.2) Bad then (1 : ℚ) else 0) - (fun _ _ => by split <;> norm_num) (Finset.mem_univ k) - · simp only [any,↓reduceIte] - exact Finset.sum_nonneg (fun _ _ => by split <;> norm_num) - -open Classical in -/-- The current endpoint for EVERY received record: the four binding message -shapes each satisfy their own refinement obligations, and the bound is the sum -of the four explicit three-term bounds. -/ -theorem current_knowledge_all {Coins : Type} [Fintype Coins] [Nonempty Coins] - (iv : Digest32) (tag instanceBytes : List Byte) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (grinding : Fin (cfg).folds.size → Fin 64) - (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) - (attacker : ∀ coin, Counts A (prefixProgram coin)) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) - (boundary : Nat) - (build : ∀ k : Fin 4, Builder p (budget tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv grinding boundary) - (good : Fin 4 → View SourceResult → Bool) - (roots : Fin 4 → PublicMerkleProbability.RootPolicy) - (rootCap : ∀ (k : Fin 4) (log : PublicMerkleLog.PublicLog), - log.length ≤ budget tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A → - (roots k log).card ≤ budget tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A * - (budget tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A + 1)) - (reduction : ∀ k : Fin 4, Reduction (roots k) iv - (fun coin => program iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding (prefixProgram coin)) - (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding) A (attacker coin)) - (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding (prefixProgram coin) Bad) - (good k)) - (refines : ∀ (k : Fin 4) coin, Refines (partition p (budget tag instanceBytes layout before - payloadCalls (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv grinding - boundary) - (model p _ iv grinding boundary (build k)) iv - (program iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding (prefixProgram coin)) - (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding) A (attacker coin)) - (good k)) : - average (fun coins : PrimitiveOracle × Coins => - if NativeAcceptedAny coins.1 iv tag instanceBytes layout before payloadCalls decode grinding - (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ - ∑ k : Fin 4, finalBound (budget tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A : ℚ) := by - refine (nativeAny_union iv tag instanceBytes layout before payloadCalls decode grinding - prefixProgram Bad).trans (Finset.sum_le_sum fun k _ => ?_) - have bound := current_knowledge_bound iv tag instanceBytes layout before payloadCalls - (bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding prefixProgram A attacker - Bad boundary (build k) (good k) (roots k) (rootCap k) (reduction k) (refines k) - unfold finalBound - exact bound - -end Current - /-! ## Concrete level from the deployed parameters -/ /-- For every aggregate budget up to `2^64` primitive-work units the complete @@ -632,72 +290,14 @@ theorem deployed_opening_between (p : ParameterBounds.Profile) (pre middle suffi rw [deployed_schedule p] at scheduled exact SpongefishCurrentRoundSeparation.opening_between _ pre middle suffix first second scheduled -open Classical SpongefishCurrentRoundPackets SpongefishCurrentSourceJoinProbability in -/-- The current endpoint at the deployed grinding, evaluated numerically: with -an aggregate budget of at most `2^64` units the real probability of native -acceptance with `Bad` is at most `Q / 2^51`, under the same two refinement -obligations. -/ -theorem current_knowledge_level {p : ParameterBounds.Profile} {Coins : Type} [Fintype Coins] - [Nonempty Coins] (iv : Digest32) (tag instanceBytes : List Byte) - (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) - (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) - (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) - (attacker : ∀ coin, Counts A (prefixProgram coin)) - (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) - (boundary : Nat) - (build : Builder p (budget tag instanceBytes layout before payloadCalls messages - (deployedGrinding p) A) iv (deployedGrinding p) boundary) - (good : View SourceResult → Bool) - (roots : PublicMerkleProbability.RootPolicy) - (rootCap : ∀ log : PublicMerkleLog.PublicLog, - log.length ≤ budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A → - (roots log).card ≤ budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A * - (budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A + 1)) - (reduction : Reduction roots iv - (fun coin => program iv tag instanceBytes layout before payloadCalls messages (deployedGrinding p) - (prefixProgram coin)) - (fun coin => SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages (deployedGrinding p)) A - (attacker coin)) - (fun C coin => NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls messages - decode (deployedGrinding p) (prefixProgram coin) Bad) good) - (refines : ∀ coin, Refines (partition p (budget tag instanceBytes layout before payloadCalls - messages (deployedGrinding p) A) iv (deployedGrinding p) boundary) - (model p _ iv (deployedGrinding p) boundary build) iv - (program iv tag instanceBytes layout before payloadCalls messages (deployedGrinding p) - (prefixProgram coin)) - (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes - (prefixProgram coin) (calls layout before payloadCalls messages (deployedGrinding p)) A - (attacker coin)) - good) - (cap : budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A ≤ 2^64) : - average (fun coins : PrimitiveOracle × Coins => - if NativeAcceptedBad coins.1 iv tag instanceBytes layout before payloadCalls messages decode - (deployedGrinding p) (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ - (budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A : ℚ) / 2^51 := by - have bound := current_knowledge_bound iv tag instanceBytes layout before payloadCalls messages decode - (deployedGrinding p) prefixProgram A attacker Bad boundary build good roots rootCap reduction refines - have numeric := finalBound_le - (budget tag instanceBytes layout before payloadCalls messages (deployedGrinding p) A : ℚ) - (by positivity) (by exact_mod_cast cap) - unfold finalBound at numeric - exact bound.trans numeric - #print axioms ideal_bound #print axioms real_bound #print axioms merkle_bound #print axioms reduction_union -#print axioms current_knowledge_bound #print axioms finalBound_le #print axioms finalBound_levels -#print axioms current_knowledge_level #print axioms collision_alarm -#print axioms reduction_of_openingCover -#print axioms current_knowledge_cover #print axioms messageCalls_binding -#print axioms nativeAny_of_native -#print axioms nativeAny_union -#print axioms current_knowledge_all #print axioms deployed_schedule #print axioms deployed_opening_between diff --git a/verification/whir/Whir/SpongefishCurrentCallerOriginalTable.lean b/verification/whir/Whir/SpongefishCurrentCallerOriginalTable.lean new file mode 100644 index 000000000..dda039835 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentCallerOriginalTable.lean @@ -0,0 +1,775 @@ +import Whir.SpongefishCurrentBCSKnowledge +import Whir.PCSBCSNativePublicCapture + +/-! Table-getter form of the current #607 public caller reconstruction. + +`tableCandidate` is the computation of `SpongefishCurrentSourceCallerOriginal.candidate` +with construction queries of the caller replay answered by an arbitrary coordinate getter. +The getter carries any budget restriction itself. Results: + +* `candidate_tableCandidate`: an accepted observation-list candidate is accepted with + every getter that agrees with the in-budget construction observations. +* `tableCandidate_local`: the candidate reads the getter only at coordinates whose + history has strictly fewer frames than the post-binding history `q.history`. With + `boundary + 1 = q.history.frames.length`, every opening packet (more than `boundary` + frames) is outside the queried set (`tableCandidate_boundary`). +* `recordOf`: unique selection of the received record among the raw-key record + candidates by its binding message calls. +* `physicalCandidate_tableCandidate`, `candidate_table`, `candidate_packets`: the real + construction oracle, any raw table, and any joined packet table are admissible getters. +* `native_selected`: all of the above at the post-binding coordinate of `NativeAcceptedBad`. -/ +namespace Whir.SpongefishCurrentCallerOriginalTable +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentModeQueries SpongefishCurrentMixedModeCompiler +open SpongefishCurrentSourceCallerOriginal +set_option autoImplicit false + +abbrev run {A : Type} := @SpongefishCurrentCallerGetter.run A + +/-! ## Generic getter lemmas for `SpongefishCurrentCallerGetter.run` -/ + +theorem run_seq {A B : Type} (get : Query → Option Digest32) (p : Program A) + (f : A → Program B) : + run get (WHIRModeFinal.bind p f) = (run get p).bind (fun a => run get (f a)) := by + induction p with + | done a => simp [WHIRModeFinal.bind,run,SpongefishCurrentCallerGetter.run] + | ask q next ih => + simp only [WHIRModeFinal.bind,run,SpongefishCurrentCallerGetter.run] at ih ⊢ + cases get q with + | none => rfl + | some d => simpa only [Option.bind_some] using ih d + +/-- A getter extending another getter on every answered query preserves every +successful run. Only queries actually issued matter. -/ +theorem run_extend {A : Type} (a b : Query → Option Digest32) + (extends_ : ∀ query d, a query = some d → b query = some d) (p : Program A) (x : A) + (accepted : run a p = some x) : run b p = some x := by + induction p with + | done => exact accepted + | ask q next ih => + simp only [run,SpongefishCurrentCallerGetter.run] at accepted ⊢ + obtain ⟨d,found,rest⟩ := Option.bind_eq_some_iff.mp accepted + rw [extends_ q d found,Option.bind_some] + exact ih d rest + +/-! ## Cursor rank -/ + +/-- Twice the closed frame count, minus one while a prover run is still open. -/ +def rank (m : Pending) : Nat := 2 * m.frames.length + if m.run = [] then 0 else 1 + +theorem rank_bind (m : Pending) (bytes : List Byte) : + rank m ≤ rank (SpongefishPCSRoundFrames.bind m bytes) := by + by_cases empty : bytes = [] + · simp [SpongefishPCSRoundFrames.bind,empty] + · simp only [rank,SpongefishPCSRoundFrames.bind,empty,↓reduceIte,List.append_eq_nil_iff, + and_false] + split <;> omega + +theorem rank_draw (m : Pending) (n : Nat) : rank m ≤ rank (draw m n) := by + by_cases zero : n = 0 + · simp [draw,zero] + · by_cases open_ : m.run = [] + · simp [rank,draw,close,zero,open_] + · simp [rank,draw,close,zero,open_] + +theorem rank_draw_positive (m : Pending) (n : Nat) (positive : n ≠ 0) : + rank (draw m n) = 2 * (close m).frames.length := by + by_cases open_ : m.run = [] + · simp [rank,draw,close,positive,open_] + · simp [rank,draw,close,positive,open_] + +theorem rank_open (m : Pending) (open_ : m.run ≠ []) : + rank m + 1 = 2 * (close m).frames.length := by + simp [rank,close,open_] + omega + +theorem coordinate_frames (m : Pending) (block : Nat) : + (coordinate m block).history.frames.length = (close m).frames.length := by + simp [coordinate,Pending.core] + +/-! ## Replay structure -/ + +theorem request_congr (a b : Query → Option Digest32) (cache : Cache) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) + (agree : a (.construction q valid) = b (.construction q valid)) : + run a (request cache q valid) = run b (request cache q valid) := by + unfold request + cases cache q with + | some d => rfl + | none => simp only [run,SpongefishCurrentCallerGetter.run,agree] + +theorem collect_congr (a b : Query → Option Digest32) (m : Pending) + (agree : ∀ block valid, a (.construction (coordinate m block) valid) = + b (.construction (coordinate m block) valid)) : + ∀ (ps : List Nat) (valid : ∀ p ∈ ps, DuplexEncoding.Admissible (coordinate m (p/32))) + (cache : Cache), run a (collect m ps valid cache) = run b (collect m ps valid cache) + | [], _, _ => rfl + | p :: ps, valid, cache => by + simp only [collect,seq,run_seq,request_congr a b cache _ _ (agree _ _)] + congr 1 + funext x + obtain ⟨next,d⟩ := x + rw [collect_congr a b m agree ps] + rfl + +theorem replay_mono (get : Query → Option Digest32) : + ∀ (calls : List Call) (cur last : SemanticCursor), + run get (replayProgram cur calls) = some (.ok last) → + rank cur.data.pending ≤ rank last.data.pending + | [], cur, last, accepted => by + simp only [replayProgram,run,SpongefishCurrentCallerGetter.run,Option.some.injEq, + Except.ok.injEq] at accepted + rw [accepted] + | .read kind :: calls, cur, last, accepted => by + simp only [replayProgram] at accepted + split at accepted + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + · rename_i value rest _ + exact (rank_bind _ _).trans (replay_mono get calls _ last accepted) + | .hint :: calls, cur, last, accepted => by + simp only [replayProgram] at accepted + split at accepted + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + · have grown := replay_mono get calls _ last accepted + exact grown + | .draw g :: calls, cur, last, accepted => by + simp only [replayProgram] at accepted + split at accepted + · have grown := replay_mono get calls _ last accepted + exact grown + · split at accepted + · rw [run_seq] at accepted + obtain ⟨⟨cache,bytes⟩,_,rest⟩ := Option.bind_eq_some_iff.mp accepted + exact (rank_draw _ _).trans (replay_mono get calls _ last rest) + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + +/-- Transfer of an accepted replay between getters that agree on every +construction coordinate of rank-bounded history. -/ +theorem replay_transfer (a b : Query → Option Digest32) (N : Nat) + (agree : ∀ q valid, 2 * q.history.frames.length < N → + a (.construction q valid) = b (.construction q valid)) : + ∀ (calls : List Call) (cur last : SemanticCursor), + run a (replayProgram cur calls) = some (.ok last) → rank last.data.pending < N → + run b (replayProgram cur calls) = some (.ok last) + | [], cur, last, accepted, _ => accepted + | .read kind :: calls, cur, last, accepted, small => by + simp only [replayProgram] at accepted ⊢ + split at accepted + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + · rename_i value rest _ + exact replay_transfer a b N agree calls _ last accepted small + | .hint :: calls, cur, last, accepted, small => by + simp only [replayProgram] at accepted ⊢ + split at accepted + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + · rename_i bytes rest _ + exact replay_transfer a b N agree calls _ last accepted small + | .draw g :: calls, cur, last, accepted, small => by + simp only [replayProgram] at accepted ⊢ + split at accepted + · rename_i zero + simp only [zero,↓reduceDIte] + exact replay_transfer a b N agree calls _ last accepted small + · rename_i zero + simp only [zero,↓reduceDIte] + split at accepted + · rename_i guard + simp only [guard,↓reduceDIte] + rw [run_seq] at accepted ⊢ + obtain ⟨⟨cache,bytes⟩,collected,rest⟩ := Option.bind_eq_some_iff.mp accepted + have grown := replay_mono a calls _ last rest + have level : 2 * (close cur.data.pending).frames.length < N := by + have drawn := rank_draw_positive cur.data.pending g.bytes zero + simp only [SpongefishCurrentMixedModeCompiler.drawn] at grown + omega + rw [← collect_congr a b cur.data.pending (fun block valid => agree _ valid + (by rw [coordinate_frames]; exact level)), collected,Option.bind_some] + exact replay_transfer a b N agree calls _ last rest small + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + +/-- A replay whose tape ends with a read of positive width ends with an open run. -/ +theorem replay_last_read (get : Query → Option Digest32) (kind : WireKind) + (positive : kind.codec.size ≠ 0) : + ∀ (pre : List Call) (cur last : SemanticCursor), + run get (replayProgram cur (pre ++ [.read kind])) = some (.ok last) → + last.data.pending.run ≠ [] + | [], cur, last, accepted => by + simp only [List.nil_append,replayProgram] at accepted + split at accepted + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + · rename_i value rest _ + simp only [run,SpongefishCurrentCallerGetter.run,Option.some.injEq,Except.ok.injEq] at accepted + subst last + simp only [readNext,boundData,SpongefishCurrentRecordModeCapture.bind_run] + intro empty + have len := congrArg List.length empty + simp [Codec.bytes] at len + omega + | .read k :: pre, cur, last, accepted => by + simp only [List.cons_append,replayProgram] at accepted + split at accepted + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + · exact replay_last_read get kind positive pre _ last accepted + | .hint :: pre, cur, last, accepted => by + simp only [List.cons_append,replayProgram] at accepted + split at accepted + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + · exact replay_last_read get kind positive pre _ last accepted + | .draw g :: pre, cur, last, accepted => by + simp only [List.cons_append,replayProgram] at accepted + split at accepted + · exact replay_last_read get kind positive pre _ last accepted + · split at accepted + · rw [run_seq] at accepted + obtain ⟨⟨cache,bytes⟩,_,rest⟩ := Option.bind_eq_some_iff.mp accepted + exact replay_last_read get kind positive pre _ last rest + · simp [run,SpongefishCurrentCallerGetter.run] at accepted + +/-! ## Getter-parametric caller candidate -/ + +/-- The literal caller replay start of `SpongefishCurrentSourceCallerOriginal.replay`. -/ +def start (q : Coordinate) (instanceBytes : List Byte) : SemanticCursor := + SpongefishCurrentInitializedMode.initial q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) [] + +/-- `SpongefishCurrentSourceCallerOriginal.replay` with an arbitrary query getter. -/ +def replayWith (get : Query → Option Digest32) (layout : WHIRCallerClaims.CallerLayout) + (q : Coordinate) (r : SpongefishSessionAdapter.Record) (instanceBytes : List Byte) : + Option Result := do + if supported q instanceBytes = false then none else do + let tape ← calls layout r + SpongefishCurrentCallerGetter.run get (replayProgram (start q instanceBytes) tape) + +/-- `SpongefishCurrentSourceCallerOriginal.candidate` with an arbitrary query getter. -/ +def candidateWith (get : Query → Option Digest32) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) : Option (PCSBCSCallerBinding.CallerInput p) := do + let result ← replayWith get layout q r instanceBytes + finish p layout q r (eraseResult result) + +theorem candidate_with {Q : Nat} (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (observations : List Observation) : + candidate (Q := Q) p layout q r instanceBytes observations = + candidateWith (SpongefishCurrentCallerGetter.answer (Q := Q) observations) p layout q r + instanceBytes := rfl + +/-- Construction queries are answered by a coordinate getter; primitive queries +(never issued by the caller replay) are rejected. -/ +def tableAnswer (getter : Coordinate → Option Digest32) : Query → Option Digest32 + | .construction q _ => getter q + | .primitive _ _ => none + +/-- Table-getter caller reconstruction. Budget restrictions belong to the getter. -/ +def tableCandidate (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (q : Coordinate) (r : SpongefishSessionAdapter.Record) (instanceBytes : List Byte) + (getter : Coordinate → Option Digest32) : Option (PCSBCSCallerBinding.CallerInput p) := + candidateWith (tableAnswer getter) p layout q r instanceBytes + +theorem candidateWith_eq_some (get : Query → Option Digest32) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (input : PCSBCSCallerBinding.CallerInput p) : + candidateWith get p layout q r instanceBytes = some input ↔ + ∃ tape last, supported q instanceBytes = true ∧ calls layout r = some tape ∧ + run get (replayProgram (start q instanceBytes) tape) = some (.ok last) ∧ + finish p layout q r (.ok last.data) = some input := by + constructor + · intro accepted + obtain ⟨result,replayed,finished⟩ := Option.bind_eq_some_iff.mp accepted + unfold replayWith at replayed + by_cases unsupported : supported q instanceBytes = false + · simp [unsupported] at replayed + · have sup : supported q instanceBytes = true := by simpa using unsupported + simp only [sup,Bool.true_eq_false,↓reduceIte] at replayed + obtain ⟨tape,tapeEq,ran⟩ := Option.bind_eq_some_iff.mp replayed + obtain ⟨data,_,ok,_⟩ := finish_exact p layout q r _ input finished + cases result with + | error e => cases ok + | ok last => exact ⟨tape,last,sup,tapeEq,ran,finished⟩ + · rintro ⟨tape,last,sup,tapeEq,ran,finished⟩ + have replayed : replayWith get layout q r instanceBytes = some (.ok last) := by + unfold replayWith + simp only [sup,Bool.true_eq_false,↓reduceIte] + rw [tapeEq] + exact ran + unfold candidateWith + rw [replayed] + exact finished + +theorem candidateWith_extend (a b : Query → Option Digest32) + (extends_ : ∀ query d, a query = some d → b query = some d) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (input : PCSBCSCallerBinding.CallerInput p) + (accepted : candidateWith a p layout q r instanceBytes = some input) : + candidateWith b p layout q r instanceBytes = some input := by + obtain ⟨tape,last,sup,tapeEq,ran,finished⟩ := + (candidateWith_eq_some a p layout q r instanceBytes input).mp accepted + exact (candidateWith_eq_some b p layout q r instanceBytes input).mpr + ⟨tape,last,sup,tapeEq,run_extend a b extends_ _ _ ran,finished⟩ + +/-- Getters agreeing on every construction query accept the same candidates. -/ +theorem candidateWith_constructions (a b : Query → Option Digest32) + (agree : ∀ c valid, a (.construction c valid) = b (.construction c valid)) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) + (r : SpongefishSessionAdapter.Record) (instanceBytes : List Byte) + (input : PCSBCSCallerBinding.CallerInput p) + (accepted : candidateWith a p layout q r instanceBytes = some input) : + candidateWith b p layout q r instanceBytes = some input := by + obtain ⟨tape,last,sup,tapeEq,ran,finished⟩ := + (candidateWith_eq_some a p layout q r instanceBytes input).mp accepted + exact (candidateWith_eq_some b p layout q r instanceBytes input).mpr + ⟨tape,last,sup,tapeEq,replay_transfer a b (rank last.data.pending + 1) + (fun c valid _ => agree c valid) _ _ last ran (by omega),finished⟩ + +theorem lookup_sound (c : Coordinate) : ∀ (observations : List Observation) (d : Digest32), + SpongefishCurrentCallerGetter.lookup c observations = some d → + ∃ o ∈ observations, ∃ valid, o.query = .construction c valid ∧ o.answer = d + | [], d, found => by simp [SpongefishCurrentCallerGetter.lookup] at found + | o :: os, d, found => by + simp only [SpongefishCurrentCallerGetter.lookup] at found + split at found + · rename_i other valid query + split at found + · rename_i same + subst same + exact ⟨o,List.mem_cons_self,valid,query,Option.some.inj found⟩ + · obtain ⟨x,member,rest⟩ := lookup_sound c os d found + exact ⟨x,List.mem_cons_of_mem _ member,rest⟩ + · obtain ⟨x,member,rest⟩ := lookup_sound c os d found + exact ⟨x,List.mem_cons_of_mem _ member,rest⟩ + +/-- Item 1: an accepted observation-list candidate is accepted by every coordinate +getter that returns the recorded answer at each in-budget construction observation. -/ +theorem candidate_tableCandidate {Q : Nat} (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (observations : List Observation) + (getter : Coordinate → Option Digest32) (input : PCSBCSCallerBinding.CallerInput p) + (accepted : candidate (Q := Q) p layout q r instanceBytes observations = some input) + (agree : ∀ o ∈ observations, ∀ c valid, o.query = .construction c valid → pathCost c ≤ Q → + getter c = some o.answer) : + tableCandidate p layout q r instanceBytes getter = some input := by + apply candidateWith_extend _ _ _ p layout q r instanceBytes input accepted + intro query d found + cases query with + | primitive => cases found + | construction c valid => + simp only [SpongefishCurrentCallerGetter.answer,SpongefishCurrentCallerGetter.bounded] at found + split at found + · rename_i work + obtain ⟨o,member,v,query,answer⟩ := lookup_sound c observations d found + rw [← answer] + exact agree o member c v query work + · cases found + +/-! ## Locality: only histories strictly shorter than the post-binding history -/ + +/-- The caller tape ends with the record value read. -/ +theorem calls_last (layout : WHIRCallerClaims.CallerLayout) (r : SpongefishSessionAdapter.Record) + (tape : List Call) (tapeEq : calls layout r = some tape) : + ∃ pre, tape = pre ++ [.read .scalar] := by + unfold calls at tapeEq + obtain ⟨before,_,tapeEq⟩ := Option.bind_eq_some_iff.mp tapeEq + obtain ⟨payload,_,tapeEq⟩ := Option.bind_eq_some_iff.mp tapeEq + obtain ⟨M,messagesEq⟩ : ∃ M, SpongefishRecordBindingParser.messages r = + M ++ [⟨.scalar,r.value⟩] := ⟨_,rfl⟩ + refine ⟨before ++ [.read .scalar,.read .scalar,.read .scalar,.read .root, + .draw (.anchor (r.shape.logN-1)),.read .scalar] ++ payload ++ + M.map (fun message => .read message.1),?_⟩ + rw [← Option.some.inj tapeEq,messagesEq,List.map_append] + simp + +theorem tableCandidate_local_some (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (g h : Coordinate → Option Digest32) + (agree : ∀ c, c.history.frames.length < q.history.frames.length → g c = h c) + (input : PCSBCSCallerBinding.CallerInput p) + (accepted : tableCandidate p layout q r instanceBytes g = some input) : + tableCandidate p layout q r instanceBytes h = some input := by + obtain ⟨tape,last,sup,tapeEq,ran,finished⟩ := + (candidateWith_eq_some _ p layout q r instanceBytes input).mp accepted + obtain ⟨data,_,ok,history,_⟩ := finish_exact p layout q r _ input finished + cases ok + obtain ⟨pre,rfl⟩ := calls_last layout r tape tapeEq + have open_ := replay_last_read _ .scalar (by decide) pre _ last ran + have closed := rank_open _ open_ + have frames : (close last.data.pending).frames.length = q.history.frames.length := by + rw [← history] + simp [Pending.core] + refine (candidateWith_eq_some _ p layout q r instanceBytes input).mpr + ⟨_,last,sup,tapeEq,?_,finished⟩ + exact replay_transfer _ _ (2 * q.history.frames.length) + (fun c valid small => agree c (by omega)) _ _ last ran (by omega) + +/-- Item 2: `tableCandidate` reads its getter only at coordinates whose history has +strictly fewer frames than the post-binding history `q.history`. -/ +theorem tableCandidate_local (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (g h : Coordinate → Option Digest32) + (agree : ∀ c, c.history.frames.length < q.history.frames.length → g c = h c) : + tableCandidate p layout q r instanceBytes g = tableCandidate p layout q r instanceBytes h := by + cases hg : tableCandidate p layout q r instanceBytes g with + | some input => + exact (tableCandidate_local_some p layout q r instanceBytes g h agree input hg).symm + | none => + cases hh : tableCandidate p layout q r instanceBytes h with + | none => rfl + | some input => + have back := tableCandidate_local_some p layout q r instanceBytes h g + (fun c small => (agree c small).symm) input hh + rw [hg] at back + cases back + +/-- With `q.history.frames.length ≤ boundary + 1` (the post-binding history is the +history of the first opening packet, index `0` of `classify`, so equality holds there), +the candidate reads only histories with at most `boundary` frames. -/ +theorem tableCandidate_boundary (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (g h : Coordinate → Option Digest32) (boundary : Nat) + (atBoundary : q.history.frames.length ≤ boundary + 1) + (agree : ∀ c, c.history.frames.length ≤ boundary → g c = h c) : + tableCandidate p layout q r instanceBytes g = tableCandidate p layout q r instanceBytes h := + tableCandidate_local p layout q r instanceBytes g h (fun c small => agree c (by omega)) + +/-- Every current round packet history has more than `boundary` frames. -/ +theorem packet_frames {p : ParameterBounds.Profile} {Q : Nat} + {grinding : Fin (ParameterBounds.config p).folds.size → Fin 64} {boundary : Nat} + (packet : SpongefishCurrentRoundPackets.Packet p Q grinding boundary) : + boundary < packet.history.frames.length := by + have classified := packet.classified + unfold SpongefishCurrentRoundPackets.classify at classified + split at classified + · assumption + · cases classified + +/-! ## Record selection -/ + +/-- Byte width of a read call; draws and hints carry no prover bytes. -/ +def callBytes : Call → Nat + | .read kind => kind.codec.size + | _ => 0 + +theorem messages_width (ms : List SpongefishRecordBindingParser.Message) : + (ms.flatMap SpongefishRecordBindingParser.Message.bytes).length = + ((ms.map (fun message => Call.read message.1)).map callBytes).sum := by + induction ms with + | nil => rfl + | cons m ms ih => + simp [List.flatMap_cons,ih,callBytes,SpongefishRecordBindingParser.Message.bytes,Codec.bytes] + +theorem opening_width (r : SpongefishSessionAdapter.Record) : + (SpongefishSessionAdapter.openingBytes r).length = + ((SpongefishCurrentAcceptedJoin.messageCalls r).map callBytes).sum := by + rw [← SpongefishRecordBindingParser.messages_bytes,messages_width] + rfl + +theorem suffix_decode (shape : AnchoredHeaderCodec.Shape) (source : List Byte) + (r : SpongefishSessionAdapter.Record) + (member : r ∈ SpongefishCurrentRecordDecoder.suffixCandidates shape source) : + SpongefishCurrentRecordDecoder.decode shape (SpongefishSessionAdapter.openingBytes r) = + some (r,[]) := by + obtain ⟨packs,_,accepted⟩ := List.mem_filterMap.mp member + unfold SpongefishCurrentRecordDecoder.suffixAt at accepted + cases read : SpongefishCurrentRecordDecoder.decode shape + (source.drop (source.length-(208+24*(packs+shape.logN)))) with + | none => simp [read] at accepted + | some pair => + obtain ⟨s,rest⟩ := pair + simp only [read] at accepted + change (if rest = [] then some s else none) = some r at accepted + split at accepted + · rename_i empty + cases accepted + subst empty + have canonical := SpongefishCurrentRecordDecoder.decode_source shape _ [] r read + rw [List.append_nil] at canonical + rw [← canonical] + exact read + · contradiction + +theorem suffix_unique (shape : AnchoredHeaderCodec.Shape) (source : List Byte) + (r s : SpongefishSessionAdapter.Record) + (hr : r ∈ SpongefishCurrentRecordDecoder.suffixCandidates shape source) + (hs : s ∈ SpongefishCurrentRecordDecoder.suffixCandidates shape source) + (same : SpongefishCurrentAcceptedJoin.messageCalls r = + SpongefishCurrentAcceptedJoin.messageCalls s) : r = s := by + have dr := suffix_decode shape source r hr + have ds := suffix_decode shape source s hs + have sr := SpongefishCurrentRecordDecoder.suffixCandidates_source shape source r hr + have ss := SpongefishCurrentRecordDecoder.suffixCandidates_source shape source s hs + have len : (SpongefishSessionAdapter.openingBytes r).length = + (SpongefishSessionAdapter.openingBytes s).length := by + rw [opening_width,opening_width,same] + have image : SpongefishSessionAdapter.openingBytes r = SpongefishSessionAdapter.openingBytes s := by + rw [List.suffix_iff_eq_drop] at sr ss + rw [sr,ss,len] + rw [image,ds] at dr + exact (congrArg Prod.fst (Option.some.inj dr)).symm + +theorem records_unique (shape : AnchoredHeaderCodec.Shape) (history : FramedHistory) + (r s : SpongefishSessionAdapter.Record) + (hr : r ∈ SpongefishCurrentRecordModeCapture.records shape history) + (hs : s ∈ SpongefishCurrentRecordModeCapture.records shape history) + (same : SpongefishCurrentAcceptedJoin.messageCalls r = + SpongefishCurrentAcceptedJoin.messageCalls s) : r = s := by + unfold SpongefishCurrentRecordModeCapture.records at hr hs + split at hr + · rename_i previous bytes last + rw [last] at hs + exact suffix_unique shape bytes r s hr hs same + · simp at hr + +theorem rawRecords_unique {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) + (key : RawKey Q) (r s : SpongefishSessionAdapter.Record) + (hr : r ∈ SpongefishCurrentRecordModeCapture.rawRecords shape iv key) + (hs : s ∈ SpongefishCurrentRecordModeCapture.rawRecords shape iv key) + (same : SpongefishCurrentAcceptedJoin.messageCalls r = + SpongefishCurrentAcceptedJoin.messageCalls s) : r = s := by + unfold SpongefishCurrentRecordModeCapture.rawRecords at hr hs + split at hr + · simp at hr + · rename_i q decoded + rw [decoded] at hs + exact records_unique shape q.history r s hr hs same + +/-- Item 3: the raw-key record candidate whose binding message calls are those of +`k` normalized pending packs. -/ +def recordOf {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) (k : Nat) + (key : RawKey Q) : Option SpongefishSessionAdapter.Record := + (SpongefishCurrentRecordModeCapture.rawRecords shape iv key).find? + (fun r => decide (SpongefishCurrentAcceptedJoin.messageCalls r = + SpongefishCurrentBCSKnowledge.bindingCalls shape k)) + +theorem recordOf_sound {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) (k : Nat) + (key : RawKey Q) (r : SpongefishSessionAdapter.Record) (selected : recordOf shape iv k key = some r) : + r ∈ SpongefishCurrentRecordModeCapture.rawRecords shape iv key ∧ + SpongefishCurrentAcceptedJoin.messageCalls r = SpongefishCurrentBCSKnowledge.bindingCalls shape k := by + refine ⟨List.mem_of_find?_eq_some selected,?_⟩ + simpa using List.find?_some selected + +theorem recordOf_eq {Q : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) (k : Nat) + (key : RawKey Q) (r : SpongefishSessionAdapter.Record) + (member : r ∈ SpongefishCurrentRecordModeCapture.rawRecords shape iv key) + (messagesEq : SpongefishCurrentAcceptedJoin.messageCalls r = + SpongefishCurrentBCSKnowledge.bindingCalls shape k) : + recordOf shape iv k key = some r := by + cases found : recordOf shape iv k key with + | none => + have missing := List.find?_eq_none.mp found r member + simp [messagesEq] at missing + | some s => + obtain ⟨hs,sCalls⟩ := recordOf_sound shape iv k key s found + exact congrArg some (rawRecords_unique shape iv key s r hs member (sCalls.trans messagesEq.symm)) + +/-! ## Real and ideal getters -/ + +/-- Answers of the real construction oracle. -/ +def realGetter (C : PrimitiveOracle) (iv : Digest32) (q : Coordinate) : Option Digest32 := + some (evalCoordinate (compressionOf C) iv q) + +theorem physicalCandidate_real (C : PrimitiveOracle) (iv : Digest32) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (input : PCSBCSCallerBinding.CallerInput p) + (accepted : physicalCandidate C iv p layout q r instanceBytes = some input) : + candidateWith (fun query => some (realAnswer C iv query)) p layout q r instanceBytes = + some input := by + obtain ⟨result,replayed,finished⟩ := Option.bind_eq_some_iff.mp accepted + unfold physicalReplay at replayed + by_cases unsupported : supported q instanceBytes = false + · simp [unsupported] at replayed + · have sup : supported q instanceBytes = true := by simpa using unsupported + simp only [sup,Bool.true_eq_false,↓reduceIte] at replayed + obtain ⟨tape,tapeEq,ran⟩ := Option.bind_eq_some_iff.mp replayed + have transport := SpongefishCurrentMixedModeCompiler.replay_real C iv (start q instanceBytes) + (SpongefishCurrentObservedSessionEntry.cursor q.history.domain instanceBytes + ((historyBytes q).drop instanceBytes.length) [] + (absorb (compressionOf C) (SpongefishSessionAdapter.init (compressionOf C) iv q.history.domain) + instanceBytes)) + rfl (session_bridge (compressionOf C) iv q.history.domain instanceBytes) + (by intro other d found; cases found) tape + have realRun := SpongefishCurrentCallerGetter.run_real C iv + (replayProgram (start q instanceBytes) tape) (fun query => some (realAnswer C iv query)) + (fun o member => by rw [SpongefishCurrentCallerGetter.real_consistent C iv _ o member]) + have resultEq : result = eraseResult (runReal C iv (replayProgram (start q instanceBytes) + tape)).view.result := by + rw [transport] + exact (Option.some.inj ran).symm + obtain ⟨data,_,ok,_⟩ := finish_exact p layout q r _ input finished + rw [resultEq] at ok finished + cases final : (runReal C iv (replayProgram (start q instanceBytes) tape)).view.result with + | error e => rw [final] at ok; cases ok + | ok last => + rw [final] at realRun finished + exact (candidateWith_eq_some _ p layout q r instanceBytes input).mpr + ⟨tape,last,sup,tapeEq,realRun,finished⟩ + +/-- Item 4 (real): the physical caller candidate is the table candidate of the real +construction oracle. -/ +theorem physicalCandidate_tableCandidate (C : PrimitiveOracle) (iv : Digest32) + (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) + (r : SpongefishSessionAdapter.Record) (instanceBytes : List Byte) + (input : PCSBCSCallerBinding.CallerInput p) + (accepted : physicalCandidate C iv p layout q r instanceBytes = some input) : + tableCandidate p layout q r instanceBytes (realGetter C iv) = some input := + candidateWith_constructions (fun query => some (realAnswer C iv query)) (tableAnswer (realGetter C iv)) + (fun _ _ => rfl) p layout q r instanceBytes input + (physicalCandidate_real C iv p layout q r instanceBytes input accepted) + +/-- In-budget construction answers of a raw table. -/ +def tableGetter (Q : Nat) (iv : Digest32) (table : PublicCompressionCouplingMixed.Key Q → Digest32) + (q : Coordinate) : Option Digest32 := + if work : pathCost q ≤ Q then some (table (.inr (constructionKey Q iv q work))) else none + +theorem execute_trace {K D R : Type} {n : Nat} (oracle : K → D) : + ∀ (t : TypedOracleCompiler.Sampling K (fun _ => D) R n), + ∀ e ∈ (TypedOracleCompiler.Sampling.execute oracle t).2, e.2 = oracle e.1 + | .ret _ => by simp [TypedOracleCompiler.Sampling.execute] + | .draw k next => by + intro e member + simp only [TypedOracleCompiler.Sampling.execute,List.mem_cons] at member + rcases member with rfl | member + · rfl + · exact execute_trace oracle (next (oracle k)) e member + +theorem mixedTrace_construction (B : Nat) (iv : Digest32) : + ∀ (log : DuplexPublicSimulator.PublicLog) (os : List Observation) (o : Observation), + o ∈ os → ∀ c valid, o.query = .construction c valid → ∀ work : pathCost c ≤ B, + (⟨.inr (constructionKey B iv c work),o.answer⟩ : + Sigma (fun _ : PublicCompressionCouplingMixed.Key B => Digest32)) ∈ + PCSBCSNativePublicCapture.mixedTrace B iv log os + | _, [], _, member, _, _, _, _ => by cases member + | log, x :: xs, o, member, c, valid, query, work => by + simp only [PCSBCSNativePublicCapture.mixedTrace,List.mem_append] + rcases List.mem_cons.mp member with rfl | member + · left + simp [PCSBCSNativePublicCapture.observationDraw,query,work] + · right + exact mixedTrace_construction B iv _ xs o member c valid query work + +/-- Every in-budget construction observation of a compiled program carries the raw +table answer at its construction key, for an arbitrary raw table. -/ +theorem table_observed {R : Type} (Q : Nat) (table : PublicCompressionCouplingMixed.Key Q → Digest32) + (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) (program : Program R) (remaining : Nat) + (limit : remaining ≤ Q) (counted : Counts remaining program) : + ∀ o ∈ (TypedOracleCompiler.Sampling.eval table + (PublicCompressionCouplingMixed.compile Q iv log program remaining limit counted)).observations, + ∀ c valid, o.query = .construction c valid → pathCost c ≤ Q → + tableGetter Q iv table c = some o.answer := by + intro o member c valid query work + have split : table = PublicCompressionCouplingMixed.oracle (fun input => table (.inl input)) + (fun key => table (.inr key)) := by + funext key + cases key <;> rfl + rw [split] at member ⊢ + have traced := mixedTrace_construction Q iv log _ o member c valid query work + rw [← PCSBCSNativePublicCapture.mixedTrace_actual] at traced + have answered := execute_trace _ _ _ traced + simp only [tableGetter,work,↓reduceDIte] + exact congrArg some answered.symm + +/-- Item 4 (ideal): a candidate accepted on the observations of a compiled program +run on any raw table is the table candidate of that table. -/ +theorem candidate_table {R : Type} (Q : Nat) (table : PublicCompressionCouplingMixed.Key Q → Digest32) + (iv : Digest32) (log : DuplexPublicSimulator.PublicLog) (program : Program R) (remaining : Nat) + (limit : remaining ≤ Q) (counted : Counts remaining program) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (input : PCSBCSCallerBinding.CallerInput p) + (accepted : candidate (Q := Q) p layout q r instanceBytes (TypedOracleCompiler.Sampling.eval table + (PublicCompressionCouplingMixed.compile Q iv log program remaining limit counted)).observations = + some input) : + tableCandidate p layout q r instanceBytes (tableGetter Q iv table) = some input := + candidate_tableCandidate p layout q r instanceBytes _ _ input accepted + (table_observed Q table iv log program remaining limit counted) + +/-- Item 4 (ideal, packet source): on a packet table, the source view of +`SpongefishCurrentBCSKnowledge.source` is the compiled view on the joined raw table. -/ +theorem candidate_packets {Packet : Type} {Block : Packet → Type} {R : Type} (Q : Nat) + (part : RawOracleCoupling.Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + (iv : Digest32) (program : Program R) (counted : Counts Q program) (p : ParameterBounds.Profile) + (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (input : PCSBCSCallerBinding.CallerInput p) + (accepted : candidate (Q := Q) p layout q r instanceBytes (TypedOracleCompiler.Sampling.eval table + (SpongefishCurrentBCSKnowledge.source part iv program counted)).observations = some input) : + tableCandidate p layout q r instanceBytes (tableGetter Q iv (part.join table)) = some input := by + unfold SpongefishCurrentBCSKnowledge.source at accepted + rw [PCSBCSChallengeOracle.Atomic.eval_program] at accepted + exact candidate_table Q _ iv [] program Q (le_refl Q) counted p layout q r instanceBytes input accepted + +/-! ## Native accepted witnesses -/ + +open SpongefishCurrentSourceJoinProbability in +/-- Items 3 and 4 under `NativeAcceptedBad` with binding message calls of `k` packs: +the received record is the selected record of the post-binding construction key, and +the prepared original is both the real-oracle table candidate and the public candidate +of the source view at that coordinate. -/ +theorem native_selected {p : ParameterBounds.Profile} (C : PrimitiveOracle) (iv : Digest32) + (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) (k : Nat) + (beforeEq : shapeCalls (preludeShape layout) = some before) + (payloadEq : shapeCalls (payloadShape layout) = some payloadCalls) + (decode : List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) + (Bad : PCSBCSCallerBinding.CallerInput p → View SourceResult → Prop) + (native : NativeAcceptedBad C iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) decode + grinding prefixProgram Bad) : + let messages := SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k + let Q := budget tag instanceBytes layout before payloadCalls messages grinding A + let view := (runReal C iv (program iv tag instanceBytes layout before payloadCalls messages + grinding prefixProgram)).view + ∃ (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (next : Cursor) (work : pathCost (coordinate next.pending (next.pending.consumed / 32)) ≤ Q), + recordOf (AnchoredSourceCaller.shape layout) iv k + (constructionKey Q iv (coordinate next.pending (next.pending.consumed / 32)) work) = some r ∧ + tableCandidate p layout (coordinate next.pending (next.pending.consumed / 32)) r instanceBytes + (realGetter C iv) = some input ∧ + candidate (Q := Q) p layout (coordinate next.pending (next.pending.consumed / 32)) r + instanceBytes view.observations = some input ∧ + Bad input view := by + intro messages Q view + obtain ⟨r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,payloadRun,bindingEq, + messagesEq,⟨opened⟩,physical,bad⟩ := native + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 + obtain ⟨_,_,_,work,member,publicEq,_⟩ := + SpongefishCurrentOpeningAcceptance.accepted_opening_original C iv layout r tag instanceBytes + prefixProgram A attacker nonempty before payloadCalls beforeEq payloadEq initial pre received + payload next setup preRun receivedEq payloadRun bindingEq decode grinding input opened + have sameCalls : SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) grinding = + before ++ SpongefishCurrentAcceptedJoin.headerCalls r.shape.logN ++ payloadCalls ++ + SpongefishCurrentAcceptedJoin.messageCalls r ++ + SpongefishCurrentOpeningAcceptance.openingCalls grinding := by + rw [SpongefishCurrentSourceJoinProbability.calls,shapeEq,messagesEq] + simp only [messages,Q,view,budget,program] at bad ⊢ + rw [sameCalls] at bad ⊢ + exact ⟨r,input,next,work,recordOf_eq _ iv k _ r member messagesEq, + physicalCandidate_tableCandidate C iv p layout _ r instanceBytes input physical, + publicEq.trans physical,bad⟩ + +#print axioms run_seq +#print axioms run_extend +#print axioms replay_mono +#print axioms replay_transfer +#print axioms replay_last_read +#print axioms candidateWith_eq_some +#print axioms candidateWith_extend +#print axioms candidateWith_constructions +#print axioms candidate_tableCandidate +#print axioms calls_last +#print axioms tableCandidate_local +#print axioms tableCandidate_boundary +#print axioms packet_frames +#print axioms records_unique +#print axioms rawRecords_unique +#print axioms recordOf_sound +#print axioms recordOf_eq +#print axioms physicalCandidate_real +#print axioms physicalCandidate_tableCandidate +#print axioms table_observed +#print axioms candidate_table +#print axioms candidate_packets +#print axioms native_selected + +end Whir.SpongefishCurrentCallerOriginalTable diff --git a/verification/whir/Whir/SpongefishCurrentGoodEvent.lean b/verification/whir/Whir/SpongefishCurrentGoodEvent.lean new file mode 100644 index 000000000..135f6350e --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentGoodEvent.lean @@ -0,0 +1,79 @@ +import Whir.SpongefishCurrentOpeningProgram +import Whir.SpongefishCurrentRootPolicy +import Whir.SpongefishCurrentCallerOriginalTable + +/-! Public events of the current #607 knowledge endpoint, read from the whole view of the full source program (`SpongefishCurrentOpeningProgram.fullProgram`). The public extractor freezes Root0 at the first key whose history mentions it (`SpongefishCurrentRootPolicy.publicCapture`) and runs the straight-line source extractor on the frozen image. The good event joins the accepted replay and opening walk, the caller original reconstructed publicly at the post-binding coordinate, the native opening equations, extraction failure, absence of ordinary output collisions and Merkle quietness of every query opening against the frozen first-mention log of its root. No hidden primitive or coin is read. -/ +namespace Whir.SpongefishCurrentGoodEvent +open Concrete Protocol CausalGame FiatShamirGame DuplexModeGame DuplexFraming SpongefishPCSRoundFrames +open PCSBCSSourceRootReferences SpongefishCurrentOpeningAcceptance SpongefishCurrentOpeningProgram +set_option autoImplicit false + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-- Merkle reference of a query opening: Root0 at level 0 and the announced level root otherwise. -/ +def openingReference (shape : SpongefishSessionAdapter.Shape) (o : QueryOpening p) : Reference := + if o.level.val = 0 then SpongefishCurrentPhysicalRootCapture.reference shape o.root + else ⟨o.root,SpongefishCurrentRootPolicy.levelShape p o.level.val⟩ + +/-- Every query opening of the returned walk is clean against the frozen first-mention log of its root, judged with the public seed of the view. -/ +def Quiet (grinding : Fin (cfg).folds.size → Fin 64) (shape : SpongefishSessionAdapter.Shape) + (headerFrames boundary B : Nat) (iv : Digest32) (view : View (FullResult p)) : Prop := + ∀ col, view.result.2 = some col → ∀ o ∈ col.openings, ∀ frozen, + SpongefishCurrentRootPolicy.publicCapture (B := B) p grinding shape headerFrames boundary iv + (openingReference shape o) view = some frozen → + ¬ PublicMerkleBinding.OpenPrimitiveBad (PCSBCSPublicPrimitiveOpening.publicSeed view) + frozen.queryPrefix o.root o.opened.paths + +/-- The commitment root returned by the opening walk. -/ +def publicRoot0 (view : View (FullResult p)) : Option Digest32 := + view.result.2.bind fun col => col.roots[0]? + +/-- The public straight-line extractor does not return a witness explaining the original claims on the frozen Root0 image. -/ +def ExtractionFails (grinding : Fin (cfg).folds.size → Fin 64) (shape : SpongefishSessionAdapter.Shape) + (headerFrames boundary B : Nat) (iv : Digest32) (input : PCSBCSCallerBinding.CallerInput p) + (view : View (FullResult p)) : Prop := + ¬ ∃ root frozen w, publicRoot0 view = some root ∧ + SpongefishCurrentRootPolicy.publicCapture (B := B) p grinding shape headerFrames boundary iv + (SpongefishCurrentPhysicalRootCapture.reference shape root) view = some frozen ∧ + PCSRoundByRoundKnowledge.extract p input.lanes input.family input.points input.anchorPoint + input.anchorValue frozen.raw = some w ∧ + PCSRewindSource.ExplainsOriginal cfg input.lanes frozen.raw input.family input.points + input.anchorPoint input.anchorValue w + +/-- Post-binding coordinate of a successful replay: the first `boundary + 1` closed frames, block 0. -/ +def postBinding (boundary : Nat) (data : SpongefishCurrentMixedModeCompiler.Data) : Coordinate := + let h := (close data.pending).core.history + ⟨{h with frames := h.frames.take (boundary+1)},.output 0⟩ + +/-- The native opening equations on the returned walk. -/ +def Verdict (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (col : Collected p) : Prop := + ∃ (seed : RingPCSGame.Prefix × E) (proof : Opening), col.seed = some seed ∧ + CausalGame.opening cfg (challenges cfg col.tape) col.replies = .ok proof ∧ + anchoredVerify r input.family input.points seed.1 seed.2 cfg (challenges cfg col.tape) proof = .ok () + +/-- The public good event for the binding message shape with `k` pending packs. -/ +def GoodFull (Q : Nat) (iv : Digest32) (instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (grinding : Fin (cfg).folds.size → Fin 64) + (headerFrames boundary k : Nat) (view : View (FullResult p)) : Prop := + ∃ (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p), + view.result = (some (.ok data),some col) ∧ + (∃ work : pathCost (postBinding boundary data) ≤ Q, + SpongefishCurrentCallerOriginalTable.recordOf (AnchoredSourceCaller.shape layout) iv k + (constructionKey Q iv (postBinding boundary data) work) = some r) ∧ + SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout (postBinding boundary data) r + instanceBytes view.observations = some input ∧ + Verdict r input col ∧ + ExtractionFails grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q iv input view ∧ + ¬ PublicMerkleLog.OutputCollision (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog Q iv view) ∧ + Quiet grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q iv view + +open Classical in +noncomputable def goodFull (Q : Nat) (iv : Digest32) (instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (grinding : Fin (cfg).folds.size → Fin 64) + (headerFrames boundary k : Nat) (view : View (FullResult p)) : Bool := + decide (GoodFull Q iv instanceBytes layout grinding headerFrames boundary k view) + +end Whir.SpongefishCurrentGoodEvent diff --git a/verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean b/verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean new file mode 100644 index 000000000..fefa0a68f --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean @@ -0,0 +1,744 @@ +import Whir.SpongefishCurrentGoodEvent +import Whir.SpongefishCurrentOpeningPackets + +/-! The current #607 basic full-prefix knowledge endpoint for the full source program (`SpongefishCurrentOpeningProgram.fullProgram`), which runs the counted caller and opening replay and then re-walks the opening with whole-hash Merkle authentication. + +A natively accepted run whose public opening predicate fails raises the complete Merkle trace alarm under the current root policy (`opening_cover`): the first-mention capture of the opening's root reference is an exact physical freeze, and the public seed agrees with the real oracle on every hashed path input. Otherwise, without an ordinary output collision, the run is the public good event on its real view (`native_goodFull`): real-world frame counting identifies the post-binding coordinate, the received record is the selected raw record of that key and the prepared original is the public candidate. The endpoint `full_knowledge_bound` therefore has the three summands of `finalBound` and the single obligation `refines`; `full_knowledge_all` and `full_knowledge_level` cover every received record through the four binding message shapes. -/ +namespace Whir.SpongefishCurrentKnowledgeEndpoint +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open SpongefishPCSRoundFrames SpongefishCurrentOpeningPackets +set_option autoImplicit false + +/-! ## Real-world frame counting -/ + +/-- The pending update of one accepted actual call. -/ +theorem actualCall_pending (c : Compression) (cur next : Cursor) (call : Call) + (ok : SpongefishCurrentPrimitiveEventCompiler.actualCall c cur call = .ok next) : + (∃ (kind : WireKind) (value : kind.Value), call = .read kind ∧ + next.pending = SpongefishPCSRoundFrames.bind cur.pending (kind.codec.bytes value)) ∨ + (∃ g, call = .draw g ∧ next.pending = SpongefishPCSRoundFrames.draw cur.pending g.bytes) ∨ + (call = .hint ∧ next.pending = cur.pending) := by + cases call with + | read kind => + left + cases parsed : kind.codec.parse cur.narg with + | none => simp [SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read,parsed] at ok + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [SpongefishCurrentPrimitiveEventCompiler.actualCall,SpongefishPCSRoundFrames.read,parsed] at ok + simp only [Option.bind_eq_bind,Option.bind_some,Option.pure_def,Except.ok.injEq] at ok + subst ok + exact ⟨kind,value,rfl,rfl⟩ + | draw g => + right; left + simp only [SpongefishCurrentPrimitiveEventCompiler.actualCall] at ok + cases hs : squeezeGroup c cur g with + | error e => simp [hs] at ok + | ok pair => + rcases pair with ⟨mid,bytes⟩ + simp only [hs,Except.ok.injEq] at ok + subst ok + refine ⟨g,rfl,?_⟩ + cases hq : squeeze c cur.state g.bytes with + | error e => simp [squeezeGroup,hq] at hs + | ok out => + rcases out with ⟨s,drawn⟩ + simp only [squeezeGroup,hq] at hs + cases hs + rfl + | hint => + right; right + cases hints : cur.hints with + | nil => simp [SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint,hints] at ok + | cons bytes rest => + simp only [SpongefishCurrentPrimitiveEventCompiler.actualCall,takeHint,hints,Except.ok.injEq] at ok + subst ok + exact ⟨rfl,rfl⟩ + +theorem bind_shaped (m : Pending) (s : Nat × Bool) (kind : WireKind) (value : kind.Value) + (shaped : Shaped m s) : + Shaped (SpongefishPCSRoundFrames.bind m (kind.codec.bytes value)) + (s.1,s.2 || decide (kind.codec.size ≠ 0)) := by + obtain ⟨frames,ready,zeroed⟩ := shaped + by_cases zero : kind.codec.size = 0 + · have empty := (codec_bytes_eq_nil kind value).mpr zero + rw [empty] + simpa [Shaped,SpongefishPCSRoundFrames.bind,zero] using (⟨frames,ready,zeroed⟩ : Shaped m s) + · have nonempty : kind.codec.bytes value ≠ [] := fun h => zero ((codec_bytes_eq_nil kind value).mp h) + obtain ⟨run,consumed⟩ := bind_nonempty m _ nonempty + refine ⟨by rw [bind_frames]; exact frames,?_,fun _ => consumed⟩ + simp [zero,run] + +theorem draw_shaped (m : Pending) (s : Nat × Bool) (n : Nat) (positive : n ≠ 0) + (shaped : Shaped m s) : + Shaped (SpongefishPCSRoundFrames.draw m n) (if s.2 then s.1+1 else s.1,false) := by + obtain ⟨frames,ready,_⟩ := shaped + obtain ⟨drawFrames,drawRun,_⟩ := draw_facts m n positive + refine ⟨?_,by simp [drawRun],fun h => (h drawRun).elim⟩ + rw [drawFrames] + by_cases empty : m.run = [] + · have notReady : s.2 = false := by simpa [empty] using ready + simp [SpongefishPCSRoundFrames.close,empty,notReady,frames] + · have isReady : s.2 = true := ready.mpr empty + simp [close_frames _ empty,isReady,frames] + +/-- One accepted actual call follows the static frame shape, keeps the domain and extends the closed frames. -/ +theorem actualCall_shape (c : Compression) (cur next : Cursor) (call : Call) + (ok : SpongefishCurrentPrimitiveEventCompiler.actualCall c cur call = .ok next) : + (∀ s, Shaped cur.pending s → Shaped next.pending (frameShape s [call])) ∧ + next.pending.domain = cur.pending.domain ∧ cur.pending.frames <+: next.pending.frames := by + rcases actualCall_pending c cur next call ok with ⟨kind,value,rfl,pending⟩ | ⟨g,rfl,pending⟩ | + ⟨rfl,pending⟩ <;> rw [pending] + · exact ⟨fun s shaped => bind_shaped _ s kind value shaped,bind_domain _ _, + by rw [bind_frames]⟩ + · obtain ⟨drawFrames,_,drawDomain⟩ := draw_facts cur.pending g.bytes (group_bytes_pos g) + refine ⟨fun s shaped => draw_shaped _ s _ (group_bytes_pos g) shaped,drawDomain,?_⟩ + rw [drawFrames] + exact close_prefix _ + · exact ⟨fun _ shaped => shaped,rfl,List.prefix_refl _⟩ + +theorem frameShape_cons (s : Nat × Bool) (call : Call) (calls : List Call) : + frameShape s (call :: calls) = frameShape (frameShape s [call]) calls := by + cases call <;> rfl + +/-- An accepted actual replay follows the static frame shape, keeps the domain and extends the closed frames. -/ +theorem actualReplay_shape (c : Compression) : + ∀ (calls : List Call) (cur fin : Cursor), + SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur calls = .ok fin → + (∀ s, Shaped cur.pending s → Shaped fin.pending (frameShape s calls)) ∧ + fin.pending.domain = cur.pending.domain ∧ cur.pending.frames <+: fin.pending.frames + | [], cur, fin, ok => by + simp only [SpongefishCurrentPrimitiveEventCompiler.actualReplay,Except.ok.injEq] at ok + subst ok + exact ⟨fun _ shaped => shaped,rfl,List.prefix_refl _⟩ + | call :: calls, cur, fin, ok => by + simp only [SpongefishCurrentPrimitiveEventCompiler.actualReplay] at ok + cases step : SpongefishCurrentPrimitiveEventCompiler.actualCall c cur call with + | error e => rw [step] at ok; cases ok + | ok mid => + rw [step] at ok + obtain ⟨shape₁,domain₁,prefix₁⟩ := actualCall_shape c cur mid call step + obtain ⟨shape₂,domain₂,prefix₂⟩ := actualReplay_shape c calls mid fin ok + refine ⟨fun s shaped => ?_,domain₂.trans domain₁,prefix₁.trans prefix₂⟩ + rw [frameShape_cons] + exact shape₂ _ (shape₁ s shaped) + +theorem setup_shaped (c : Compression) (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (initial : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup c parameter tag instanceBytes narg hints = + some initial) : + Shaped initial.pending (0,decide (instanceBytes ≠ [])) := by + unfold SpongefishCurrentObservedSessionEntry.actualSetup at setup + obtain ⟨_,_,same⟩ := Option.map_eq_some_iff.mp setup + subst same + by_cases empty : instanceBytes = [] <;> + simp [Shaped,SpongefishCurrentObservedSessionEntry.cursor,SpongefishPCSRoundFrames.bind,empty] + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-- Real-world frame counting: when the opening starts with `boundary` closed frames and a pending prover run, the post-binding coordinate of the full view's replay data is the native post-binding coordinate. -/ +theorem postBinding_native (c : Compression) (instanceBytes : List Byte) (tape : List Call) + (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) (initial next final : Cursor) + (start : Shaped initial.pending (0,decide (instanceBytes ≠ []))) + (ready : openingShape instanceBytes tape = (boundary,true)) + (tapeRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay c initial tape = .ok next) + (openRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay c next + (SpongefishCurrentOpeningAcceptance.openingCalls grinding) = .ok final) : + SpongefishCurrentGoodEvent.postBinding boundary (SpongefishCurrentMixedModeCompiler.forget final) = + SpongefishCurrentModeQueries.coordinate next.pending (next.pending.consumed / 32) := by + obtain ⟨shapes,_,_⟩ := actualReplay_shape c tape initial next tapeRun + have shaped := shapes _ start + unfold openingShape at ready + rw [ready] at shaped + obtain ⟨frames,run,zeroed⟩ := shaped + have nonempty : next.pending.run ≠ [] := run.mp rfl + have consumed := zeroed nonempty + obtain ⟨rest,head⟩ := SpongefishCurrentOpeningAcceptance.openingCalls_head (p := p) grinding + rw [head] at openRun + simp only [SpongefishCurrentPrimitiveEventCompiler.actualReplay] at openRun + cases step : SpongefishCurrentPrimitiveEventCompiler.actualCall c next (.draw .stackFamilyAndLambda) with + | error e => rw [step] at openRun; cases openRun + | ok mid => + rw [step] at openRun + obtain ⟨_,domainRest,prefixRest⟩ := actualReplay_shape c rest mid final openRun + rcases actualCall_pending c next mid _ step with ⟨_,_,bad,_⟩ | ⟨g,same,pending⟩ | ⟨bad,_⟩ + · cases bad + · cases same + obtain ⟨drawFrames,_,drawDomain⟩ := draw_facts next.pending _ (group_bytes_pos .stackFamilyAndLambda) + have closedPrefix : (SpongefishPCSRoundFrames.close next.pending).frames <+: + (SpongefishPCSRoundFrames.close final.pending).frames := by + rw [← drawFrames,← pending] + exact prefixRest.trans (close_prefix _) + have domainEq : final.pending.domain = next.pending.domain := by + rw [domainRest,pending,drawDomain] + have closedLength : (SpongefishPCSRoundFrames.close next.pending).frames.length = boundary + 1 := by + rw [close_frames _ nonempty,List.length_append,frames] + rfl + obtain ⟨tail,tailEq⟩ := closedPrefix + have takeEq : ((SpongefishPCSRoundFrames.close final.pending).frames.map + ByteFrame.historicalCore).take (boundary+1) = + (SpongefishPCSRoundFrames.close next.pending).frames.map ByteFrame.historicalCore := by + rw [← tailEq,List.map_append] + exact List.take_left' (by rw [List.length_map,closedLength]) + unfold SpongefishCurrentGoodEvent.postBinding SpongefishCurrentModeQueries.coordinate + rw [consumed] + simp only [SpongefishCurrentMixedModeCompiler.forget,Pending.core,close_domain,domainEq,takeEq, + Nat.zero_div] + · cases bad + +/-! ## Opening cover -/ + +open SpongefishCurrentOpeningProgram in +/-- The real view of a counted program is the evaluation of its compiled mixed program on the real table. -/ +theorem compiled_view {R : Type} (C : PrimitiveOracle) (iv : Digest32) (program : Program R) (Q : Nat) + (counted : Counts Q program) : + Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable Q C)) + (PublicCompressionCouplingMixed.compile Q iv [] program Q (le_refl Q) counted) = + (runReal C iv program).view := by + rw [PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C iv _ ⟨rfl,by simp⟩ _ _ (le_refl Q) _ + +/-- The public seed of a real view agrees with the oracle on every ordinary primitive-log entry. -/ +theorem publicSeed_ordinary {R : Type} (C : PrimitiveOracle) (iv : Digest32) (program : Program R) (Q : Nat) + (counted : Counts Q program) (n : Node) (d : Digest32) (ordinary : tag n = 0) + (logged : (n,d) ∈ PublicCompressionProgram.primitiveLog C iv program Q counted) : + PCSBCSPublicPrimitiveOpening.publicSeed (runReal C iv program).view n = C n := by + have public_ := PublicCompressionProgram.ordinary_public C iv program Q counted n d ordinary logged + obtain ⟨o,member,found⟩ := List.mem_filterMap.mp public_ + rcases o with ⟨query,answer⟩ + cases query with + | construction => simp at found + | primitive purpose input => + simp only [Option.some.injEq,Prod.mk.injEq] at found + obtain ⟨rfl,rfl⟩ := found + have seeded := PCSBCSPublicPrimitiveOpening.publicSeed_observed C (WHIRRealSimulator.rawTable Q C) + program Q (le_refl Q) counted purpose input answer (by rw [compiled_view]; exact member) + rw [compiled_view] at seeded + rw [seeded] + exact (PublicCompressionProgram.primitiveLog_authentic C iv program Q counted input answer logged).symm + +open SpongefishCurrentOpeningProgram in +/-- Item 1: a natively accepted full run whose public opening predicate fails raises the complete Merkle trace alarm under the current root policy. -/ +theorem opening_cover (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) (headerFrames boundary : Nat) + (Bad : PCSBCSCallerBinding.CallerInput p → View (FullResult p) → Prop) + (native : NativeAcceptedBadFull C iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram Bad) + (loud : ¬ SpongefishCurrentGoodEvent.Quiet grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view) : + PublicMerkleProbability.traceAlarm + (SpongefishCurrentRootPolicy.targets p grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv) [] + (PublicCompressionProgram.primitiveLog C iv + (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram) + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram A attacker)) = true := by + obtain ⟨r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,payloadRun,bindingEq, + messagesEq,⟨opened⟩,_,_⟩ := native + obtain ⟨resultEq,authenticated⟩ := fullProgram_native C iv tag instanceBytes layout before payloadCalls + messages decode grinding prefixProgram A attacker r input initial pre received payload next setup + preRun receivedEq payloadRun bindingEq messagesEq opened + cases quiet : PublicMerkleProbability.traceAlarm + (SpongefishCurrentRootPolicy.targets p grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv) [] + (PublicCompressionProgram.primitiveLog C iv + (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram) + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram A attacker)) with + | true => rfl + | false => + exfalso + apply loud + intro col colEq o member frozen captured bad + rw [resultEq] at colEq + cases colEq + obtain ⟨_,paths⟩ := authenticated o member + rw [← compiled_view C iv _ _ (fullProgram_counted iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram A attacker),SpongefishCurrentRootPolicy.publicCapture_source] at captured + have refRoot : (SpongefishCurrentGoodEvent.openingReference (AnchoredSourceCaller.shape layout) o).root = + o.root := by + unfold SpongefishCurrentGoodEvent.openingReference + split <;> rfl + obtain ⟨_,clean⟩ := SpongefishCurrentRootPolicy.captured_opening_quiet p grinding + (AnchoredSourceCaller.shape layout) headerFrames boundary _ iv C _ _ (le_refl _) _ _ frozen captured + quiet o.opened.paths (fun path inPaths bytes input => (paths path inPaths bytes input).1) + (fun path inPaths bytes input => (paths path inPaths bytes input).2) + rw [refRoot] at clean + apply clean + refine (PCSBCSPublicPrimitiveOpening.openPrimitiveBad_locality C _ frozen.queryPrefix o.root + o.opened.paths ?_).mp bad + rintro path inPaths bytes input ⟨n,d⟩ planned + obtain ⟨small,logged⟩ := paths path inPaths bytes input + exact publicSeed_ordinary C iv _ _ _ n d (PublicMerkleLog.plan_tag_zero C bytes small n d planned) + (logged _ planned) + +/-! ## Reduction to the public good event -/ + +/-- Raw construction keys depend only on the expanded mode key. -/ +theorem constructionKey_congr {Q : Nat} (iv : Digest32) (a b : Coordinate) (ha : pathCost a ≤ Q) + (hb : pathCost b ≤ Q) (same : modeKey iv a = modeKey iv b) : + constructionKey Q iv a ha = constructionKey Q iv b hb := by + have restrict : ∀ (x y : Extracted) (equal : x = y) (hx : x.message.length ≤ Q) + (tx : x.template.length ≤ Q) (hy : y.message.length ≤ Q) (ty : y.template.length ≤ Q), + restrictKey Q x hx tx = restrictKey Q y hy ty := by + intro x y equal _ _ _ _ + subst equal + rfl + exact restrict _ _ same _ _ _ _ + +/-- A raw record of a construction key stays a raw record of the same coordinate at every larger budget. -/ +theorem rawRecords_lift {Q Q' : Nat} (shape : AnchoredHeaderCodec.Shape) (iv : Digest32) (q : Coordinate) + (work : pathCost q ≤ Q) (work' : pathCost q ≤ Q') (le : Q ≤ Q') (r : SpongefishSessionAdapter.Record) + (member : r ∈ SpongefishCurrentRecordModeCapture.rawRecords shape iv (constructionKey Q iv q work)) : + r ∈ SpongefishCurrentRecordModeCapture.rawRecords shape iv (constructionKey Q' iv q work') := by + obtain ⟨q',bound,valid,keyEq,inRecords⟩ := + SpongefishCurrentRecordModeCapture.rawRecords_sound shape iv _ r member + have modeEq : modeKey iv q' = modeKey iv q := by + simpa only [expand_constructionKey] using congrArg expandKey keyEq + rw [constructionKey_congr iv q q' work' (le_trans bound le) modeEq.symm, + SpongefishCurrentRecordModeCapture.rawRecords_construction shape iv q' valid] + exact inRecords + +/-- The binding messages end with a positive read, so the opening starts with a pending prover run. -/ +theorem binding_ready (instanceBytes : List Byte) (pre : List Call) (shape : AnchoredHeaderCodec.Shape) + (k : Nat) : + openingShape instanceBytes (pre ++ SpongefishCurrentBCSKnowledge.bindingCalls shape k) = + ((openingShape instanceBytes (pre ++ SpongefishCurrentBCSKnowledge.bindingCalls shape k)).1,true) := + openingShape_ready instanceBytes _ _ .scalar + (by rw [SpongefishCurrentBCSKnowledge.bindingCalls]; exact (List.append_assoc _ _ _).symm) (by decide) + +open SpongefishCurrentOpeningProgram in +/-- Native acceptance with public extraction failure, without an ordinary output collision and with a quiet opening, is the public good event on the real full view. -/ +theorem native_goodFull (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (nonempty : instanceBytes ≠ []) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (k : Nat) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (messagesEq : messages = SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) (headerFrames boundary : Nat) + (boundaryEq : boundary = (openingShape instanceBytes (before ++ + SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ + messages)).1) + (native : NativeAcceptedBadFull C iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram (SpongefishCurrentGoodEvent.ExtractionFails grinding + (AnchoredSourceCaller.shape layout) headerFrames boundary + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv)) + (collision : ¬ PublicMerkleLog.OutputCollision (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view)) + (quiet : SpongefishCurrentGoodEvent.Quiet grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view) : + SpongefishCurrentGoodEvent.GoodFull (fullBudget tag instanceBytes layout before payloadCalls messages + grinding A) iv instanceBytes layout grinding headerFrames boundary k + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view := by + obtain ⟨r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,payloadRun,bindingEq, + messagesCalls,⟨opened⟩,physical,bad⟩ := native + have resultEq := (fullProgram_native C iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram A attacker r input initial pre received payload next setup preRun receivedEq + payloadRun bindingEq messagesCalls opened).1 + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 + obtain ⟨_,_,_,work0,member0,publicEq,_⟩ := + SpongefishCurrentOpeningAcceptance.accepted_opening_original C iv layout r tag instanceBytes + prefixProgram A attacker nonempty before payloadCalls beforeEq payloadEq initial pre received + payload next setup preRun receivedEq payloadRun bindingEq decode grinding input opened + -- the post-binding coordinate, by real-world frame counting + have tapeRun := SpongefishCurrentAcceptedJoin.composition_replay (compressionOf C) layout r before + payloadCalls initial pre received payload next preRun receivedEq payloadRun bindingEq + rw [shapeEq,messagesCalls] at tapeRun + have ready : openingShape instanceBytes (before ++ SpongefishCurrentAcceptedJoin.headerCalls + (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ messages) = (boundary,true) := by + rw [boundaryEq,messagesEq] + exact binding_ready instanceBytes _ _ k + have postEq := postBinding_native (compressionOf C) instanceBytes _ grinding boundary initial next + opened.final (setup_shaped _ _ _ _ _ _ initial setup) ready tapeRun + (SpongefishCurrentOpeningAcceptance.run_replay C decode grinding r.shape.lanes _ _ _ opened.ran) + -- the full view's caller lookups are the old program's, at a larger budget + have sameCalls : SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding = + before ++ SpongefishCurrentAcceptedJoin.headerCalls r.shape.logN ++ payloadCalls ++ + SpongefishCurrentAcceptedJoin.messageCalls r ++ + SpongefishCurrentOpeningAcceptance.openingCalls grinding := by + rw [SpongefishCurrentSourceJoinProbability.calls,shapeEq,messagesCalls] + have capped := SpongefishCurrentReplayProvenance.observation_cap + (SpongefishCurrentReplayProvenance.real_runs C iv _) _ + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram + (before ++ SpongefishCurrentAcceptedJoin.headerCalls r.shape.logN ++ payloadCalls ++ + SpongefishCurrentAcceptedJoin.messageCalls r ++ SpongefishCurrentOpeningAcceptance.openingCalls grinding) + A attacker) + have le : A + SpongefishCurrentInitializedMode.budget tag instanceBytes + (before ++ SpongefishCurrentAcceptedJoin.headerCalls r.shape.logN ++ payloadCalls ++ + SpongefishCurrentAcceptedJoin.messageCalls r ++ SpongefishCurrentOpeningAcceptance.openingCalls grinding) ≤ + fullBudget tag instanceBytes layout before payloadCalls messages grinding A := by + unfold fullBudget SpongefishCurrentSourceJoinProbability.budget + rw [sameCalls] + exact Nat.le_add_right _ _ + have fullObservations := PrunedMerkleProgram.HashProgram.bind_real_observations C iv + (SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes layout before payloadCalls + messages grinding prefixProgram) + (openingPhase decode grinding (AnchoredSourceCaller.shape layout).lanes (rootIndex before) + (openingOffset layout before payloadCalls messages)) + have oldObservations : (runReal C iv (SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes + layout before payloadCalls messages grinding prefixProgram)).view.observations = + (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram + (before ++ SpongefishCurrentAcceptedJoin.headerCalls r.shape.logN ++ payloadCalls ++ + SpongefishCurrentAcceptedJoin.messageCalls r ++ + SpongefishCurrentOpeningAcceptance.openingCalls grinding))).view.observations := by + unfold SpongefishCurrentSourceJoinProbability.program + rw [sameCalls] + rw [oldObservations] at fullObservations + have same : ∀ q, SpongefishCurrentCallerGetter.lookup q + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view.observations = + SpongefishCurrentCallerGetter.lookup q (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv + tag instanceBytes prefixProgram (before ++ SpongefishCurrentAcceptedJoin.headerCalls r.shape.logN ++ + payloadCalls ++ SpongefishCurrentAcceptedJoin.messageCalls r ++ + SpongefishCurrentOpeningAcceptance.openingCalls grinding))).view.observations := by + intro q + rw [fullProgram,fullObservations] + exact lookup_append_primitive q _ (openingPhase_primitive C iv decode grinding _ _ _ _) _ + have candidateEq : SpongefishCurrentSourceCallerOriginal.candidate + (Q := fullBudget tag instanceBytes layout before payloadCalls messages grinding A) p layout + (SpongefishCurrentModeQueries.coordinate next.pending (next.pending.consumed / 32)) r instanceBytes + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view.observations = some input := by + rw [← physical,← publicEq] + unfold SpongefishCurrentSourceCallerOriginal.candidate SpongefishCurrentSourceCallerOriginal.replay + rw [answer_lift _ _ le capped same] + have work := le_trans work0 le + refine ⟨SpongefishCurrentMixedModeCompiler.forget opened.final,opened.collected,r,input,resultEq,?_,?_, + ⟨opened.seed,opened.proof,opened.seeded,opened.parsed,opened.equations⟩,bad,collision,quiet⟩ + · rw [postEq] + exact ⟨work,SpongefishCurrentCallerOriginalTable.recordOf_eq _ iv k _ r + (rawRecords_lift _ iv _ work0 work le r member0) (messagesCalls.trans messagesEq)⟩ + · rw [postEq] + exact candidateEq + +open SpongefishCurrentOpeningProgram in +/-- Item 2: real native acceptance with public extraction failure reduces pointwise to the public good event or the complete Merkle trace alarm under the current root policy. -/ +theorem reduction_full {Coins : Type} (iv : Digest32) (tag instanceBytes : List Byte) + (nonempty : instanceBytes ≠ []) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (k : Nat) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (messagesEq : messages = SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (headerFrames boundary : Nat) + (boundaryEq : boundary = (openingShape instanceBytes (before ++ + SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ + messages)).1) : + SpongefishCurrentBCSKnowledge.Reduction + (SpongefishCurrentRootPolicy.targets p grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv) iv + (fun coin => fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin)) + (fun coin => fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode + grinding (prefixProgram coin) A (attacker coin)) + (fun C coin => NativeAcceptedBadFull C iv tag instanceBytes layout before payloadCalls messages decode + grinding (prefixProgram coin) (SpongefishCurrentGoodEvent.ExtractionFails grinding + (AnchoredSourceCaller.shape layout) headerFrames boundary + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv)) + (SpongefishCurrentGoodEvent.goodFull (fullBudget tag instanceBytes layout before payloadCalls messages + grinding A) iv instanceBytes layout grinding headerFrames boundary k) := by + intro C coin native + by_cases collision : PublicMerkleLog.OutputCollision (PCSBCSPublicPrimitiveOpening.publicOrdinaryLog + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin))).view) + · exact Or.inr (SpongefishCurrentBCSKnowledge.collision_alarm C iv _ _ _ _ collision) + · by_cases quiet : SpongefishCurrentGoodEvent.Quiet grinding (AnchoredSourceCaller.shape layout) + headerFrames boundary (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin))).view + · left + simp only [SpongefishCurrentGoodEvent.goodFull,decide_eq_true_eq] + exact native_goodFull C iv tag instanceBytes nonempty layout before payloadCalls messages k beforeEq + payloadEq messagesEq decode grinding (prefixProgram coin) A (attacker coin) headerFrames boundary + boundaryEq native collision quiet + · exact Or.inr (opening_cover C iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin) A (attacker coin) headerFrames boundary _ native quiet) + +/-! ## Endpoint -/ + +noncomputable local instance (Q : Nat) (iv : Digest32) (grinding : Fin (cfg).folds.size → Fin 64) + (boundary : Nat) (key : SpongefishCurrentRoundPackets.Key p Q iv grinding boundary) : + Fintype (SpongefishCurrentRoundPackets.Answer p Q iv grinding boundary key) := + match key with + | .inl _ => inferInstance + | .inr _ => inferInstance + +open Classical SpongefishCurrentOpeningProgram in +/-- Item 3: the current #607 basic full-prefix knowledge bound for one binding message shape. The real event is native acceptance of the whole current caller path and opening whose prepared original fails public straight-line extraction on the frozen Root0 image. The bound has the three explicit summands of `finalBound`; the only remaining obligation is `refines`, a state path of the current round node model on every ideal table where the public good event fires. -/ +theorem full_knowledge_bound {Coins : Type} [Fintype Coins] [Nonempty Coins] + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) (k : Nat) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (messagesEq : messages = SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (headerFrames boundary : Nat) + (boundaryEq : boundary = (openingShape instanceBytes (before ++ + SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ + messages)).1) + (build : Coins → SpongefishCurrentRoundPackets.Builder p + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv grinding boundary) + (refines : ∀ coin, SpongefishCurrentBCSKnowledge.Refines + (SpongefishCurrentRoundPackets.partition p + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv grinding boundary) + (SpongefishCurrentRoundPackets.model p + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv grinding boundary + (build coin)) iv + (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding (prefixProgram coin)) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin) A (attacker coin)) + (SpongefishCurrentGoodEvent.goodFull (fullBudget tag instanceBytes layout before payloadCalls messages + grinding A) iv instanceBytes layout grinding headerFrames boundary k)) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBadFull coins.1 iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coins.2) (SpongefishCurrentGoodEvent.ExtractionFails grinding + (AnchoredSourceCaller.shape layout) headerFrames boundary + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv) + then (1 : ℚ) else 0) ≤ + SpongefishCurrentBCSKnowledge.finalBound + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A : ℚ) := by + have union := SpongefishCurrentBCSKnowledge.reduction_union _ iv _ _ _ _ + (reduction_full iv tag instanceBytes nonempty layout before payloadCalls messages k beforeEq payloadEq + messagesEq decode grinding prefixProgram A attacker headerFrames boundary boundaryEq) + have merkle := SpongefishCurrentBCSKnowledge.merkle_bound + (SpongefishCurrentRootPolicy.targets p grinding (AnchoredSourceCaller.shape layout) headerFrames boundary + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv) + (SpongefishCurrentRootPolicy.targets_cap p grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv) iv + (fun coin => fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin)) + (fun coin => fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin) A (attacker coin)) + have nonnegative : (0 : ℚ) ≤ PCSRoundByRoundKnowledge.rbrError := by + unfold PCSRoundByRoundKnowledge.rbrError SupportedCandidateExtraction.radiusEnvelope + positivity + have real := SpongefishCurrentBCSKnowledge.real_bound _ + (fun coin => SpongefishCurrentRoundPackets.model p _ iv grinding boundary (build coin)) + PCSRoundByRoundKnowledge.rbrError nonnegative + (fun coin => SpongefishCurrentRoundPackets.conditional_hazard p _ iv grinding boundary (build coin)) + iv _ _ _ refines + have rbr : PCSRoundByRoundKnowledge.rbrError = (17/32 : ℚ)^56 + 1/2^78 := by + simp only [PCSRoundByRoundKnowledge.rbrError,SupportedCandidateExtraction.radiusEnvelope] + rw [rbr,duplexModeLoss_eq] at real + unfold SpongefishCurrentBCSKnowledge.finalBound + exact union.trans (add_le_add real merkle) + +/-! ### Every record-binding message shape -/ + +/-- Closed frames at the opening start for binding message shape `k`. -/ +def fullBoundary (instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls : List Call) (k : Nat) : Nat := + (openingShape instanceBytes (before ++ + SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ + SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k)).1 + +open SpongefishCurrentOpeningProgram in +/-- Native full acceptance for SOME binding message shape, with a property chosen per shape. -/ +def NativeAcceptedAnyFull (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (Bad : Fin 4 → PCSBCSCallerBinding.CallerInput p → View (FullResult p) → Prop) : Prop := + ∃ k : Fin 4, NativeAcceptedBadFull C iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding + prefixProgram (Bad k) + +open SpongefishCurrentOpeningProgram in +/-- Every natively accepted full run, whatever its received record, has one of the four binding message shapes. -/ +theorem messages_binding_full (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (Bad : PCSBCSCallerBinding.CallerInput p → View (FullResult p) → Prop) + (native : NativeAcceptedBadFull C iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram Bad) : + ∃ k : Fin 4, messages = SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val := by + obtain ⟨r,_,initial,pre,received,_,_,setup,preRun,receivedEq,_,_,messagesEq,_⟩ := native + obtain ⟨packs,pointLength⟩ := SpongefishCurrentBCSKnowledge.accepted_packs _ iv tag instanceBytes _ _ + layout before r initial pre received setup preRun receivedEq + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 + have exact := SpongefishCurrentBCSKnowledge.messageCalls_binding r pointLength + rw [shapeEq] at exact + exact ⟨⟨_,packs⟩,messagesEq.symm.trans exact⟩ + +open Classical SpongefishCurrentOpeningProgram in +/-- Union over the four binding message shapes. -/ +theorem nativeAnyFull_union {Coins : Type} [Fintype Coins] + (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) + (Bad : Fin 4 → PCSBCSCallerBinding.CallerInput p → View (FullResult p) → Prop) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode grinding + (prefixProgram coins.2) Bad then (1 : ℚ) else 0) ≤ + ∑ k : Fin 4, average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedBadFull coins.1 iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode + grinding (prefixProgram coins.2) (Bad k) then (1 : ℚ) else 0) := by + unfold average + rw [← Finset.sum_div] + apply div_le_div_of_nonneg_right _ (by positivity) + rw [Finset.sum_comm] + apply Finset.sum_le_sum + intro coins _ + by_cases any : NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode + grinding (prefixProgram coins.2) Bad + · obtain ⟨k,hk⟩ := any + simp only [show NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode + grinding (prefixProgram coins.2) Bad from ⟨k,hk⟩,↓reduceIte] + calc (1 : ℚ) = if NativeAcceptedBadFull coins.1 iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode + grinding (prefixProgram coins.2) (Bad k) then 1 else 0 := by simp only [hk,↓reduceIte] + _ ≤ _ := Finset.single_le_sum (f := fun k : Fin 4 => + if NativeAcceptedBadFull coins.1 iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode + grinding (prefixProgram coins.2) (Bad k) then (1 : ℚ) else 0) + (fun _ _ => by split <;> norm_num) (Finset.mem_univ k) + · simp only [any,↓reduceIte] + exact Finset.sum_nonneg (fun _ _ => by split <;> norm_num) + +open Classical SpongefishCurrentOpeningProgram in +/-- The current endpoint for EVERY received record: each of the four binding message shapes carries its own builder and `refines` obligation, and the bound is the sum of the four three-summand bounds. -/ +theorem full_knowledge_all {Coins : Type} [Fintype Coins] [Nonempty Coins] + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (headerFrames : Nat) + (build : ∀ k : Fin 4, Coins → SpongefishCurrentRoundPackets.Builder p + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv + grinding (fullBoundary instanceBytes layout before payloadCalls k.val)) + (refines : ∀ (k : Fin 4) coin, SpongefishCurrentBCSKnowledge.Refines + (SpongefishCurrentRoundPackets.partition p + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv + grinding (fullBoundary instanceBytes layout before payloadCalls k.val)) + (SpongefishCurrentRoundPackets.model p _ iv grinding + (fullBoundary instanceBytes layout before payloadCalls k.val) (build k coin)) iv + (fullProgram iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding + (prefixProgram coin)) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode grinding + (prefixProgram coin) A (attacker coin)) + (SpongefishCurrentGoodEvent.goodFull (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv + instanceBytes layout grinding headerFrames (fullBoundary instanceBytes layout before payloadCalls k.val) + k.val)) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode grinding + (prefixProgram coins.2) (fun k => SpongefishCurrentGoodEvent.ExtractionFails grinding + (AnchoredSourceCaller.shape layout) headerFrames + (fullBoundary instanceBytes layout before payloadCalls k.val) + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv) + then (1 : ℚ) else 0) ≤ + ∑ k : Fin 4, SpongefishCurrentBCSKnowledge.finalBound (fullBudget tag instanceBytes layout before + payloadCalls (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + grinding A : ℚ) := + (nativeAnyFull_union iv tag instanceBytes layout before payloadCalls decode grinding prefixProgram _).trans + (Finset.sum_le_sum fun k _ => full_knowledge_bound iv tag instanceBytes nonempty layout before + payloadCalls _ k.val beforeEq payloadEq rfl decode grinding prefixProgram A attacker headerFrames _ rfl + (build k) (refines k)) + +open Classical SpongefishCurrentOpeningProgram in +/-- The current endpoint at the deployed grinding, evaluated numerically: if every binding message shape has an aggregate budget of at most `2^64` units, the real probability of native acceptance with public extraction failure is at most the sum over the four shapes of `Q / 2^51`, under the same `refines` obligations. -/ +theorem full_knowledge_level {Coins : Type} [Fintype Coins] [Nonempty Coins] + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : Decoder) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (headerFrames : Nat) + (build : ∀ k : Fin 4, Coins → SpongefishCurrentRoundPackets.Builder p + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A) iv + (SpongefishCurrentBCSKnowledge.deployedGrinding p) (fullBoundary instanceBytes layout before payloadCalls k.val)) + (refines : ∀ (k : Fin 4) coin, SpongefishCurrentBCSKnowledge.Refines + (SpongefishCurrentRoundPackets.partition p + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A) iv + (SpongefishCurrentBCSKnowledge.deployedGrinding p) + (fullBoundary instanceBytes layout before payloadCalls k.val)) + (SpongefishCurrentRoundPackets.model p _ iv (SpongefishCurrentBCSKnowledge.deployedGrinding p) + (fullBoundary instanceBytes layout before payloadCalls k.val) (build k coin)) iv + (fullProgram iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode + (SpongefishCurrentBCSKnowledge.deployedGrinding p) (prefixProgram coin)) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) decode + (SpongefishCurrentBCSKnowledge.deployedGrinding p) (prefixProgram coin) A (attacker coin)) + (SpongefishCurrentGoodEvent.goodFull (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A) iv instanceBytes layout + (SpongefishCurrentBCSKnowledge.deployedGrinding p) headerFrames + (fullBoundary instanceBytes layout before payloadCalls k.val) k.val)) + (cap : ∀ k : Fin 4, fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A ≤ 2^64) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode + (SpongefishCurrentBCSKnowledge.deployedGrinding p) (prefixProgram coins.2) + (fun k => SpongefishCurrentGoodEvent.ExtractionFails (SpongefishCurrentBCSKnowledge.deployedGrinding p) + (AnchoredSourceCaller.shape layout) headerFrames + (fullBoundary instanceBytes layout before payloadCalls k.val) + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A) iv) + then (1 : ℚ) else 0) ≤ + ∑ k : Fin 4, (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A : ℚ) / 2^51 := + (full_knowledge_all iv tag instanceBytes nonempty layout before payloadCalls beforeEq payloadEq decode + (SpongefishCurrentBCSKnowledge.deployedGrinding p) prefixProgram A attacker headerFrames build + refines).trans (Finset.sum_le_sum fun k _ => + SpongefishCurrentBCSKnowledge.finalBound_le _ (by positivity) (by exact_mod_cast cap k)) + +#print axioms actualReplay_shape +#print axioms postBinding_native +#print axioms publicSeed_ordinary +#print axioms opening_cover +#print axioms rawRecords_lift +#print axioms native_goodFull +#print axioms reduction_full +#print axioms full_knowledge_bound +#print axioms messages_binding_full +#print axioms nativeAnyFull_union +#print axioms full_knowledge_all +#print axioms full_knowledge_level + +end Whir.SpongefishCurrentKnowledgeEndpoint diff --git a/verification/whir/Whir/SpongefishCurrentOpeningExperiment.lean b/verification/whir/Whir/SpongefishCurrentOpeningExperiment.lean new file mode 100644 index 000000000..6066f46ed --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentOpeningExperiment.lean @@ -0,0 +1,789 @@ +import Whir.SpongefishCurrentOpeningAcceptance +import Whir.WHIRNativeRestoration +import Whir.WHIRPhysicalSoundness +import Whir.CausalPositions +import Whir.CausalBoundary +import Whir.CountedCandidateCheckOriginalCorrectness + +/-! Current #607 native opening acceptance as an abstract causal experiment. Pure algebra: no primitive oracle, Merkle table or partition appears in the main statement. The native opening carries empty placeholders for the next commitment oracles; `restoredReplies` replaces each present placeholder by a supplied ghost oracle `next (i+1)`, leaving every physical field unchanged. Row authentication is an explicit hypothesis in the native Merkle opening form that binding against frozen first-mention captures discharges: level 0 opened rows are rows of the base oracle `root`, and level `i > 0` opened rows are rows of `next i`, at the native query indices of the tape. -/ +namespace Whir.SpongefishCurrentOpeningExperiment +open Concrete Protocol CausalGame CausalProbability +open SpongefishCurrentOpeningAcceptance +set_option autoImplicit false + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-! ## Restored replies -/ + +/-- Level of the visible fold coordinate at reply position `n`, zero elsewhere. -/ +def replyLevel (c : Config) (n : Nat) : Nat := + match (visibleCoordinates c)[n]? with + | some (.fold i _) => i.val + | _ => 0 + +/-- A present next-oracle placeholder at reply position `n` becomes the ghost oracle of the following level; every other field is kept. -/ +def restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) : Reply → Reply + | .fold m o residual => .fold m (o.map fun _ => next (replyLevel c n + 1)) residual + | r => r + +def restore (c : Config) (next : Nat → Oracle) (replies : Array Reply) : Array Reply := + replies.mapIdx fun n r => restoreReply c next n r + +/-- Native replies with the ghost next oracles restored. -/ +def restoredReplies (col : Collected p) (next : Nat → Oracle) : Array Reply := + restore cfg next col.replies + +/-- Base oracle at level zero, supplied next oracle at every later level. -/ +def levelOracle (root : BaseOracle) (next : Nat → Oracle) (i : Nat) : Oracle := + if i = 0 then liftRoot root else next i + +theorem erase_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + WHIRPhysicalErasure.eraseReply (restoreReply c next n r) = WHIRPhysicalErasure.eraseReply r := by + cases r <;> simp [restoreReply, WHIRPhysicalErasure.eraseReply, Option.map_map, Function.comp_def] + +theorem rootField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + rootField (restoreReply c next n r) = (rootField r).map fun _ => next (replyLevel c n + 1) := by + cases r <;> rfl + +theorem restore_size (c : Config) (next : Nat → Oracle) (replies : Array Reply) : + (restore c next replies).size = replies.size := by + simp [restore] + +theorem restore_getElem? (c : Config) (next : Nat → Oracle) (replies : Array Reply) (n : Nat) : + (restore c next replies)[n]? = replies[n]?.map (restoreReply c next n) := by + simp [restore, Array.getElem?_mapIdx] + +theorem restore_getElem! (c : Config) (next : Nat → Oracle) (replies : Array Reply) (n : Nat) : + (restore c next replies)[n]! = restoreReply c next n replies[n]! := by + by_cases h : n < replies.size + · rw [_root_.getElem!_pos (restore c next replies) n (by rwa [restore_size]), + _root_.getElem!_pos replies n h] + simp [restore] + · rw [_root_.getElem!_neg (restore c next replies) n (by rwa [restore_size]), + _root_.getElem!_neg replies n h] + rfl + +theorem restore_erase (c : Config) (next : Nat → Oracle) (replies : Array Reply) : + (restore c next replies).map WHIRPhysicalErasure.eraseReply = + replies.map WHIRPhysicalErasure.eraseReply := by + apply Array.ext + · simp [restore_size] + · intro n h₁ h₂ + simp [restore, erase_restoreReply] + +/-- Prefix law: entry `n` of the restored replies is a function of the native entry `n` and the ghost oracles only. -/ +theorem restoredReplies_getElem? (col : Collected p) (next : Nat → Oracle) (n : Nat) : + (restoredReplies col next)[n]? = col.replies[n]?.map (restoreReply cfg next n) := + restore_getElem? cfg next col.replies n + +theorem restoredReplies_prefix (col col' : Collected p) (next : Nat → Oracle) (n : Nat) + (same : col.replies[n]? = col'.replies[n]?) : + (restoredReplies col next)[n]? = (restoredReplies col' next)[n]? := by + rw [restoredReplies_getElem?, restoredReplies_getElem?, same] + +/-- Restoration agrees with the native replies except for the next-oracle field. -/ +theorem restoredReplies_agree (col : Collected p) (next : Nat → Oracle) : + (restoredReplies col next).size = col.replies.size ∧ + (restoredReplies col next).map WHIRPhysicalErasure.eraseReply = + col.replies.map WHIRPhysicalErasure.eraseReply ∧ + ∀ n, rootField (restoredReplies col next)[n]! = + (rootField col.replies[n]!).map fun _ => next (replyLevel cfg n + 1) := by + refine ⟨restore_size _ _ _,restore_erase _ _ _,fun n => ?_⟩ + rw [restoredReplies,restore_getElem!,rootField_restoreReply] + +/-! ## Parsing the restored replies -/ + +@[simp] theorem initialField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + initialField (restoreReply c next n r) = initialField r := by cases r <;> rfl +@[simp] theorem foldField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + foldField (restoreReply c next n r) = foldField r := by cases r <;> rfl +@[simp] theorem residualField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + residualField (restoreReply c next n r) = residualField r := by cases r <;> rfl +@[simp] theorem oodField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + oodField (restoreReply c next n r) = oodField r := by cases r <;> rfl +@[simp] theorem rowsField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + rowsField (restoreReply c next n r) = rowsField r := by cases r <;> rfl +@[simp] theorem introField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + introField (restoreReply c next n r) = introField r := by cases r <;> rfl +@[simp] theorem tailField_restoreReply (c : Config) (next : Nat → Oracle) (n : Nat) (r : Reply) : + tailField (restoreReply c next n r) = tailField r := by cases r <;> rfl + +theorem fold_visible {c : Config} (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) : + Coordinate.fold i j ∈ visibleCoordinates c := by + apply List.mem_append_left + apply List.mem_append_right + apply List.mem_flatMap.mpr + refine ⟨i.val,List.mem_range.mpr i.isLt,?_⟩ + unfold levelCoordinates + rw [dite_eq_left i.isLt] + exact List.mem_append_left _ (List.mem_append_left _ (List.mem_ofFn.mpr ⟨j,rfl⟩)) + +theorem replyLevel_fold {c : Config} (i : Fin c.folds.size) (j : Fin c.folds[i.val]!) : + replyLevel c (position (Coordinate.fold i j)) = i.val := by + have mem := fold_visible i j + have found : (visibleCoordinates c)[position (Coordinate.fold i j)]? = some (Coordinate.fold i j) := by + unfold position + rw [List.getElem?_eq_getElem (List.idxOf_lt_length_of_mem mem), List.getElem_idxOf] + simp [replyLevel, found] + +theorem challenges_folds_size (c : Config) (t : Tape c) (i : Nat) (hi : i < c.folds.size) : + (challenges c t).levels[i]!.folds.size = c.folds[i]! := by + simp [challenges, _root_.getElem!_pos, hi] + +theorem decodedLevel_restore (c : Config) (t : Tape c) (next : Nat → Oracle) + (replies : Array Reply) (i : Nat) (hi : i < c.folds.size) : + decodedLevel c (challenges c t) (restore c next replies) i = + { decodedLevel c (challenges c t) replies i with + nextOracle := (decodedLevel c (challenges c t) replies i).nextOracle.map + fun _ => next (i+1) } := by + unfold decodedLevel + simp only [restore_getElem!, foldField_restoreReply, oodField_restoreReply, + rowsField_restoreReply, introField_restoreReply] + congr 1 + split_ifs with h + · rw [rootField_restoreReply] + congr 2 + have size := challenges_folds_size c t i hi + have positive : 0 < c.folds[i]! := size ▸ h.2 + have bound : c.folds[i]! - 1 < c.folds[(⟨i,hi⟩ : Fin c.folds.size).val]! := by + change c.folds[i]! - 1 < c.folds[i]! + omega + have pos := CausalPositions.position_fold (c := c) ⟨i,hi⟩ ⟨c.folds[i]! - 1,bound⟩ t + have level := replyLevel_fold (c := c) ⟨i,hi⟩ ⟨c.folds[i]! - 1,bound⟩ + rw [pos] at level + have level' : replyLevel c (levelStart (challenges c t) i + (c.folds[i]! - 1)) = i := level + rw [size, show levelStart (challenges c t) i + c.folds[i]! - 1 = + levelStart (challenges c t) i + (c.folds[i]! - 1) by omega, level'] + · rfl + +theorem decodedOpening_restore (c : Config) (t : Tape c) (next : Nat → Oracle) + (replies : Array Reply) : + decodedOpening c (challenges c t) (restore c next replies) = + WHIRNativeErasure.restoreOracles (decodedOpening c (challenges c t) replies) next := by + unfold decodedOpening WHIRNativeErasure.restoreOracles + simp only [restore_getElem!, initialField_restoreReply, residualField_restoreReply, + tailField_restoreReply] + congr 1 + apply Array.ext + · simp + · intro i h₁ h₂ + simp only [Fin.getElem_fin, Array.getElem_ofFn] + rw [decodedLevel_restore c t next replies i (by simpa using h₁)] + +theorem opening_restore (c : Config) (t : Tape c) (next : Nat → Oracle) + (replies : Array Reply) (proof : Opening) + (parsed : opening c (challenges c t) replies = .ok proof) : + opening c (challenges c t) (restore c next replies) = + .ok (WHIRNativeErasure.restoreOracles proof next) := by + have checks : checkReplies (visibleBatches c E.zero (challenges c t)) (restore c next replies).toList = + checkReplies (visibleBatches c E.zero (challenges c t)) replies.toList := by + rw [← WHIRPhysicalErasure.checkReplies_erase _ (restore c next replies).toList, + ← WHIRPhysicalErasure.checkReplies_erase _ replies.toList, ← Array.toList_map, + ← Array.toList_map, restore_erase] + unfold opening at parsed ⊢ + rw [checks] + cases hc : checkReplies (visibleBatches c E.zero (challenges c t)) replies.toList with + | error e => simp [hc] at parsed + | ok u => + simp only [hc] at parsed ⊢ + have same : decodedOpening c (challenges c t) replies = proof := by + simpa using parsed + rw [decodedOpening_restore, same] + rfl + +theorem opening_decoded (c : Config) (ch : Challenges) (replies : Array Reply) (proof : Opening) + (parsed : opening c ch replies = .ok proof) : proof = decodedOpening c ch replies := by + unfold opening at parsed + cases hc : checkReplies (visibleBatches c E.zero ch) replies.toList with + | error e => simp [hc] at parsed + | ok u => + simp only [hc] at parsed + exact (by simpa using parsed : decodedOpening c ch replies = proof).symm + +theorem restoreOracles_level (proof : Opening) (lookup : Nat → Oracle) (i : Nat) + (hi : i < proof.levels.size) : + (WHIRNativeErasure.restoreOracles proof lookup).levels[i]! = + { proof.levels[i]! with nextOracle := proof.levels[i]!.nextOracle.map fun _ => lookup (i+1) } := by + unfold WHIRNativeErasure.restoreOracles + rw [_root_.getElem!_pos _ i (by simpa using hi), _root_.getElem!_pos proof.levels i hi] + simp + +theorem decodedOpening_level (c : Config) (ch : Challenges) (replies : Array Reply) (i : Nat) + (hi : i < c.folds.size) : + (decodedOpening c ch replies).levels[i]! = decodedLevel c ch replies i := by + unfold decodedOpening + rw [_root_.getElem!_pos _ i (by simpa using hi)] + simp + +/-! ## Commitments, root shapes and authenticated rows -/ + +/-- An accepted native opening carries a commitment at every non-final level. -/ +theorem nativeVerify_present (c : Config) (ch : Challenges) (lanes : Nat) (initialClaim : E) + (callerAt : Array E → E) (proof : Opening) + (success : WHIRNativeArithmetic.nativeVerify c ch lanes initialClaim callerAt proof = .ok ()) : + ∀ k, k + 1 < c.folds.size → (proof.levels[k]!.nextOracle).isSome = true := by + obtain ⟨_,_,_,s,run,_⟩ := + WHIRNativeArithmetic.nativeVerify_success c ch lanes initialClaim callerAt proof success + have inv := OperationalRefinement.runChecked_invariant (WHIRNativeArithmetic.verifyLevel c ch proof) + (fun i _ => ∀ k, k < i → k + 1 < c.folds.size → (proof.levels[k]!.nextOracle).isSome = true) + c.folds.size 0 _ s (by intro k hk; omega) (by + intro i t u _ _ before step k hk more + by_cases same : k = i + · subst same + have boundary := (WHIRNativeArithmetic.verifyLevel_success c ch proof k t u step).2.2.1 + simpa only [more,↓reduceIte] using boundary + · exact before k (by omega) more) run + intro k more + exact inv k (by omega) more + +/-- Supplied next oracles have the rectangular shape of their code level. -/ +def NextShapes (c : Config) (next : Nat → Oracle) : Prop := + ∀ j, 0 < j → j < c.folds.size → + oracleValid (next j) (ParameterBounds.length c j) (2^c.folds[j]!) = true + +/-- Verifier-side row agreement in the arithmetic `AuthenticatedRows` form, read at the reply position of each query coordinate. -/ +def DerivedRows (c : Config) (t : Tape c) (replies : Array Reply) + (root : BaseOracle) (next : Nat → Oracle) : Prop := + ∀ i : Fin c.folds.size, ∀ qs, + deriveQueries (remaining c i.val + c.rates[i.val]!) c.queries[i.val]! + (challenges c t).levels[i.val]!.querySqueezes = some qs → + ∀ j, j < qs.size → + (rowsField replies[position (Coordinate.query i)]!)[j]! = (levelOracle root next i.val)[qs[j]!]! + +/-- Row authentication in the native Merkle opening form: at every level the rows of the native query reply are the rows of `levelOracle root next i` (the base oracle at level 0, the supplied next oracle at later levels) at the native query indices of the tape's query sample. -/ +def RowsAuthenticated (t : Tape cfg) (replies : Array Reply) + (root : BaseOracle) (next : Nat → Oracle) : Prop := + ∀ i : Fin (cfg).folds.size, + rowsField replies[position (Coordinate.query i)]! = + WHIRPhysicalVerifier.atQueries (levelOracle root next i.val) + (WHIRPhysicalVerifier.queryIndices p i (get (Coordinate.query i) t)) + +theorem queryIndices_derived (i : Fin (cfg).folds.size) (x : Sample (Coordinate.query i)) : + deriveQueries (remaining cfg i.val + (cfg).rates[i.val]!) (cfg).queries[i.val]! (Array.ofFn x.1) = + some (WHIRPhysicalVerifier.queryIndices p i x).toArray := by + have depth := TapeValidity.config_query_depth cfg (ParameterBounds.production_config_valid p).1 + i.val i.isLt + unfold WHIRPhysicalVerifier.queryIndices + rw [Array.toArray_toList] + exact QueryBatchSoundness.queries_actual _ _ x.1 (by omega) depth.2 + +theorem rowsAuthenticated_derived (t : Tape cfg) (replies : Array Reply) + (root : BaseOracle) (next : Nat → Oracle) (rows : RowsAuthenticated t replies root next) : + DerivedRows cfg t replies root next := by + intro i qs derived j hj + have squeezes : (challenges cfg t).levels[i.val]!.querySqueezes = + Array.ofFn (get (Coordinate.query i) t).1 := by + simp [challenges, _root_.getElem!_pos, i.isLt] + rfl + rw [squeezes, queryIndices_derived] at derived + have same := Option.some.inj derived + subst same + have inside : j < (WHIRPhysicalVerifier.queryIndices p i (get (Coordinate.query i) t)).length := by + simpa using hj + rw [rows i] + simp [WHIRPhysicalVerifier.atQueries, _root_.getElem!_pos, inside] + +theorem restored_rootShapes (next : Nat → Oracle) (proof : Opening) + (sizes : proof.levels.size = (cfg).folds.size) (shapes : NextShapes cfg next) : + WHIRNativeArithmetic.RootShapes cfg (WHIRNativeErasure.restoreOracles proof next) := by + intro i bound hasNext nxt found + rw [restoreOracles_level proof next i (sizes ▸ bound)] at found + obtain ⟨_,_,equal⟩ := Option.map_eq_some_iff.mp found + subst nxt + have shape := shapes (i+1) (by omega) hasNext + have dimensions := ((CausalBoundary.production_boundary_facts p ⟨i,bound⟩).2.2 hasNext).1 + change remaining cfg (i+1) + (cfg).folds[i+1]! = remaining cfg i at dimensions + have rest : remaining cfg (i+1) = remaining cfg i - (cfg).folds[i+1]! := by omega + simpa only [ParameterBounds.length,rest] using shape + +theorem challenges_ood_size (c : Config) (t : Tape c) (i : Nat) (hi : i < c.folds.size) : + (challenges c t).levels[i]!.oodPoints.size = oodCount c i := by + simp [challenges, _root_.getElem!_pos, hi] + +theorem restored_authenticated (c : Config) (t : Tape c) (replies : Array Reply) + (proof : Opening) (root : BaseOracle) (next : Nat → Oracle) + (parsed : opening c (challenges c t) replies = .ok proof) + (present : ∀ k, k + 1 < c.folds.size → (proof.levels[k]!.nextOracle).isSome = true) + (rows : DerivedRows c t replies root next) : + WHIRNativeArithmetic.AuthenticatedRows c (challenges c t) + (WHIRNativeErasure.restoreOracles proof next) (liftRoot root) := by + have decoded := opening_decoded c _ replies proof parsed + have sizes : proof.levels.size = c.folds.size := by rw [decoded]; simp [decodedOpening] + intro i hi qs derived j hj + have opened := rows ⟨i,hi⟩ qs derived j hj + rw [restoreOracles_level proof next i (sizes ▸ hi)] + dsimp only + have rowsEq : proof.levels[i]!.rows = rowsField replies[position (Coordinate.query (⟨i,hi⟩ : Fin c.folds.size))]! := by + rw [decoded, decodedOpening_level c _ replies i hi, CausalPositions.position_query ⟨i,hi⟩ t] + simp only [decodedLevel, challenges_folds_size c t i hi, challenges_ood_size c t i hi] + rw [rowsEq, opened] + unfold WHIRNativeArithmetic.oracleBefore levelOracle + by_cases zero : i = 0 + · simp [zero] + · simp only [zero, ↓reduceIte] + rw [restoreOracles_level proof next (i-1) (by omega)] + have some := present (i-1) (by omega) + obtain ⟨o,ho⟩ := Option.isSome_iff_exists.mp some + simp only [ho, Option.map_some, Option.getD_some, show i - 1 + 1 = i by omega] + +/-! ## Original claims shapes from the prepared guards -/ + +theorem guards_occupied {c : Config} {lanes m : Nat} {family : Fin m → RingPCSGame.FamilyClaim} + {points : Array RingPCSGame.PointClaim} {anchorPoint : Array E} + (guards : OriginalClaimsChecker.Guards c lanes family points anchorPoint) : + lanes * 2^(c.logN - c.folds[0]!) ≤ 2^c.logN := by + calc lanes * 2^(c.logN - c.folds[0]!) ≤ 2^c.folds[0]! * 2^(c.logN - c.folds[0]!) := + Nat.mul_le_mul_right _ guards.2.2.2.1 + _ = 2^c.logN := by rw [← Nat.pow_add, Nat.add_sub_of_le guards.1] + +theorem guards_nativeShapes {c : Config} {lanes m : Nat} {family : Fin m → RingPCSGame.FamilyClaim} + {points : Array RingPCSGame.PointClaim} {anchorPoint : Array E} + (guards : OriginalClaimsChecker.Guards c lanes family points anchorPoint) : + SuccinctRingWeight.FamilyShape c.logN family ∧ + (∀ i : Fin points.size, SuccinctPointWeight.Shape c.logN points[i]) ∧ + (∀ point ∈ points.toList, ∀ v, lanes * 2^(c.logN - c.folds[0]!) ≤ v → + RingPCSGame.pointWeight point v = 0) := by + have occupied := guards_occupied guards + obtain ⟨_,_,_,_,_,families,pointGuards⟩ := guards + refine ⟨fun j => ⟨(families j).1,(families j).2.1,(families j).2.2.trans occupied⟩,?_,?_⟩ + · intro i + have g := pointGuards i + generalize points[i] = claim at g ⊢ + cases claim with + | point offset point value => + exact ⟨g.2.1,g.2.2.trans occupied⟩ + | strided offset slot stride point value => + exact ⟨g.2.2.1,g.2.2.2.trans occupied,g.2.1⟩ + · intro claim member v lower + obtain ⟨i,hi,rfl⟩ := List.getElem_of_mem member + have g := pointGuards ⟨i,by simpa using hi⟩ + simp only [Array.getElem_toList] at g ⊢ + generalize points[i] = claim at g ⊢ + cases claim with + | point offset point value => + have far := g.2.2 + simp only [RingPCSGame.pointWeight, RingPCSGame.regionWeight] + rw [ite_eq_right (by omega)] + | strided offset slot stride point value => + have far := g.2.2.2 + simp only [RingPCSGame.pointWeight] + rw [ite_eq_right (by omega)] + +theorem guards_claims_shapes {lanes m : Nat} {family : Fin m → RingPCSGame.FamilyClaim} + {points : Array RingPCSGame.PointClaim} {anchorPoint : Array E} + (guards : OriginalClaimsChecker.Guards cfg lanes family points anchorPoint) + (seed : RingPCSGame.Prefix) (lambda : E) (point : Array E) (value : E) : + ((((RingPCSGame.transformedClaims (2^(cfg).logN) family points seed).push + ⟨CommitmentAnchor.weight cfg lanes point,value⟩).all + (fun claim => Protocol.shapeValid cfg lanes claim.weight)) = true) ∧ + Protocol.shapeValid cfg lanes (CausalGame.batchClaims (2^(cfg).logN) + ((RingPCSGame.transformedClaims (2^(cfg).logN) family points seed).push + ⟨CommitmentAnchor.weight cfg lanes point,value⟩) lambda).weight = true := by + let claims := (RingPCSGame.transformedClaims (2^(cfg).logN) family points seed).push + ⟨CommitmentAnchor.weight cfg lanes point,value⟩ + change (claims.all fun claim => Protocol.shapeValid cfg lanes claim.weight) = true ∧ + Protocol.shapeValid cfg lanes (CausalGame.batchClaims (2^(cfg).logN) claims lambda).weight = true + have families := guards.2.2.2.2.2.1 + have positive := guards.2.2.1 + have laneBound := guards.2.2.2.1 + obtain ⟨_,_,pointSupport⟩ := guards_nativeShapes guards + have supported : ∀ claim ∈ claims.toList, claim.weight.size = 2^(cfg).logN ∧ + ∀ i, lanes*2^((cfg).logN-(cfg).folds[0]!) ≤ i → i < 2^(cfg).logN → claim.weight[i]! = 0 := by + intro claim member + simp only [claims,Array.toList_push,List.mem_append,List.mem_singleton] at member + rcases member with member | last + · refine ⟨WHIRCallerSupport.transformed_claim_size _ _ _ _ claim member,?_⟩ + intro i lower upper + exact WHIRCallerSupport.transformed_claim_support _ _ _ _ seed + (fun j => (families j).2.2) pointSupport claim member i lower upper + · subst claim + refine ⟨by simp [CommitmentAnchor.weight],?_⟩ + intro i lower upper + simp [CommitmentAnchor.weight,ArrayLayout.getElem!_tab _ _ _ upper,Nat.not_lt_of_le lower] + rfl + constructor + · apply Array.all_eq_true'.mpr + intro claim member + have supported := supported claim (by simpa [claims] using member) + exact WHIRCallerSupport.shapeValid_of_support cfg lanes claim.weight + (ParameterBounds.production_config_valid p).1 positive laneBound supported.1 + (fun i lower upper => supported.2 i lower (by simpa [supported.1] using upper)) + · apply WHIRCallerSupport.shapeValid_of_support cfg lanes _ + (ParameterBounds.production_config_valid p).1 positive laneBound + (InitialBatching.batchClaims_size _ _ _) + intro i lower upper + apply InitialBatching.batchClaims_zero_tail (2^(cfg).logN) (lanes*2^((cfg).logN-(cfg).folds[0]!)) + claims lambda _ i lower (by simpa only [InitialBatching.batchClaims_size] using upper) + intro j i lower upper + exact (supported claims[j] (by simp)).2 i lower upper + +/-! ## Anchored native equations refine the dense verifier -/ + +theorem callerAt_dense (c : Config) (record : AnchoredHeaderCodec.Record) {m : Nat} + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) + (hN : record.shape.logN = c.logN) (hB : record.shape.logBatch = c.folds[0]!) + (occupied : 0 < record.shape.lanes ∧ record.shape.lanes ≤ 2^record.shape.logBatch) + (dimensions : record.shape.logBatch < record.shape.logN) + (pointSize : record.point.length = record.shape.logN) + (familyShape : SuccinctRingWeight.FamilyShape c.logN family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape c.logN points[i]) + (x : Array E) (hx : x.size = c.logN) : + AnchoredPhysicalAnchor.callerAt record family points seed lambda x = + Concrete.mle (batchClaims (2^c.logN) + (AnchorPrefixRefinement.anchoredClaims c record family points seed) lambda).weight x := by + rw [AnchorPrefixRefinement.anchoredClaims, AnchorPrefixRefinement.batchClaims_push] + rw [AccumulatedTerminalAlgebra.mle_weightGlue _ _ _ _ + (by simp [hx]) (by simp [CommitmentAnchor.weight])] + rw [AnchoredPhysicalAnchor.callerAt, AnchorPrefixRefinement.anchorAt_dense c record.shape + record.point.toArray x hN hB occupied dimensions (by simpa using pointSize) (hx.trans hN.symm)] + have old := SuccinctRingGroups.sourceStackWeightAt_eq_batch_mle family points seed lambda x + (by simpa [hx] using familyShape) (by simpa [hx] using pointShapes) + rw [old] + simp only [RingPCSGame.transformedClaims, Array.size_append, Array.size_map] + simp [hx, Nat.add_comm] + +theorem anchored_refines (c : Config) (record : AnchoredHeaderCodec.Record) {m : Nat} + (family : Fin m → RingPCSGame.FamilyClaim) (points : Array RingPCSGame.PointClaim) + (seed : RingPCSGame.Prefix) (lambda : E) (ch : Challenges) (proof : Opening) (root : Oracle) + (hN : record.shape.logN = c.logN) (hB : record.shape.logBatch = c.folds[0]!) + (occupied : 0 < record.shape.lanes ∧ record.shape.lanes ≤ 2^record.shape.logBatch) + (dimensions : record.shape.logBatch < record.shape.logN) + (pointSize : record.point.length = record.shape.logN) + (familyShape : SuccinctRingWeight.FamilyShape c.logN family) + (pointShapes : ∀ i : Fin points.size, SuccinctPointWeight.Shape c.logN points[i]) + (weightShape : shapeValid c record.shape.lanes + (batchClaims (2^c.logN) (AnchorPrefixRefinement.anchoredClaims c record family points seed) + lambda).weight = true) + (rootShape : oracleValid root (2^(c.logN-c.folds[0]!+c.rates[0]!)) record.shape.lanes = true) + (roots : WHIRNativeArithmetic.RootShapes c proof) + (authenticated : WHIRNativeArithmetic.AuthenticatedRows c ch proof root) + (success : AnchoredPhysicalAnchor.sourceVerify record family points seed lambda c ch proof = .ok ()) : + Protocol.verify c ch record.shape.lanes root + (batchClaims (2^c.logN) (AnchorPrefixRefinement.anchoredClaims c record family points seed) lambda).weight + (batchClaims (2^c.logN) (AnchorPrefixRefinement.anchoredClaims c record family points seed) lambda).value + proof = .ok () := by + have refined := WHIRNativeArithmetic.nativeVerify_refines c ch record.shape.lanes + (AnchoredPhysicalAnchor.initialClaim record family points seed lambda) + (AnchoredPhysicalAnchor.callerAt record family points seed lambda) proof _ root weightShape rootShape + roots authenticated + (callerAt_dense c record family points seed lambda hN hB occupied dimensions pointSize + familyShape pointShapes) success + rwa [AnchorPrefixRefinement.initialClaim_dense c] at refined + +/-! ## The accepted batching scalar is the tape's initial sample -/ + +/-- Once a seed is recorded, the tape's initial coordinate is its batching scalar. -/ +def SeedTape (col : Collected p) : Prop := ∀ s, col.seed = some s → col.tape.1 = s.2 + +theorem powStep_keeps (C : DuplexModeGame.PrimitiveOracle) (grinding : Fin (cfg).folds.size → Fin 64) + (cur next : SpongefishPCSRoundFrames.Cursor) (col col' : Collected p) (q : Coord p) + (ok : powStep C grinding cur col q = some (next,col')) : + col'.seed = col.seed ∧ col'.tape = col.tape := by + cases q with + | query i => + simp only [powStep] at ok + split at ok + · cases ok; exact ⟨rfl,rfl⟩ + · split at ok + · cases ok + · split at ok + · cases ok + · cases ok; exact ⟨rfl,rfl⟩ + | initial => cases ok; exact ⟨rfl,rfl⟩ + | fold i j => cases ok; exact ⟨rfl,rfl⟩ + | ood i j => cases ok; exact ⟨rfl,rfl⟩ + | tail j => cases ok; exact ⟨rfl,rfl⟩ + +theorem recordSample_seedTape (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) + (kept : SeedTape col) : SeedTape (recordSample col q x) := by + intro s found + cases q with + | initial => + have same : x = s := Option.some.inj found + subst same + change get Coordinate.initial + (set Coordinate.initial col.tape (StackWHIRReplay.projectSample Coordinate.initial x)) = x.2 + rw [get_set] + rfl + | fold i j => + change get Coordinate.initial (set (Coordinate.fold i j) col.tape _) = s.2 + rw [get_set_ne _ _ _ _ (by intro h; cases h)] + exact kept s found + | ood i j => + change get Coordinate.initial (set (Coordinate.ood i j) col.tape _) = s.2 + rw [get_set_ne _ _ _ _ (by intro h; cases h)] + exact kept s found + | query i => + change get Coordinate.initial (set (Coordinate.query i) col.tape _) = s.2 + rw [get_set_ne _ _ _ _ (by intro h; cases h)] + exact kept s found + | tail j => + change get Coordinate.initial (set (Coordinate.tail j) col.tape _) = s.2 + rw [get_set_ne _ _ _ _ (by intro h; cases h)] + exact kept s found + +theorem replyStep_keeps (C : DuplexModeGame.PrimitiveOracle) + (decode : List Nat → Nat → List FiatShamirGame.Byte → Option MerkleTransport.PrunedMerklePaths) + (lanes : Nat) (cur next : SpongefishPCSRoundFrames.Cursor) (col col' : Collected p) (q : Coord p) + (ok : replyStep C decode lanes cur col q = some (next,col')) : + col'.seed = col.seed ∧ col'.tape = col.tape := by + cases q with + | initial => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; exact ⟨rfl,rfl⟩ + | fold i j => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + split at ok + · split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; exact ⟨rfl,rfl⟩ + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; exact ⟨rfl,rfl⟩ + · cases ok; exact ⟨rfl,rfl⟩ + | ood i j => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; exact ⟨rfl,rfl⟩ + | query i => + simp only [replyStep] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; exact ⟨rfl,rfl⟩ + | tail j => + change (if isVisibleTail j then (do + let (next,m) ← readMessage C cur + pure (next,{col with replies := col.replies.push (.tail m)})) else some (cur,col)) = + some (next,col') at ok + split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; exact ⟨rfl,rfl⟩ + · cases ok; exact ⟨rfl,rfl⟩ + +theorem run_seedTape (C : DuplexModeGame.PrimitiveOracle) + (decode : List Nat → Nat → List FiatShamirGame.Byte → Option MerkleTransport.PrunedMerklePaths) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (qs : List (Coord p)) (state final : SpongefishPCSRoundFrames.Cursor × Collected p), + SeedTape state.2 → SpongefishCurrentOpeningAcceptance.run C decode grinding lanes qs state = + some final → SeedTape final.2 + | [], state, final, kept, ok => by + simp only [SpongefishCurrentOpeningAcceptance.run,Option.some.injEq] at ok + subst ok + exact kept + | q :: qs, state, final, kept, ok => by + simp only [SpongefishCurrentOpeningAcceptance.run] at ok + obtain ⟨mid,first,rest⟩ := Option.bind_eq_some_iff.mp ok + apply run_seedTape C decode grinding lanes qs mid final _ rest + unfold SpongefishCurrentOpeningAcceptance.step at first + obtain ⟨⟨powed,col⟩,powOk,first⟩ := Option.bind_eq_some_iff.mp first + obtain ⟨⟨drawn,x⟩,_,first⟩ := Option.bind_eq_some_iff.mp first + obtain ⟨powSeed,powTape⟩ := powStep_keeps C grinding _ _ _ _ q powOk + obtain ⟨replySeed,replyTape⟩ := replyStep_keeps C decode lanes _ mid.1 _ mid.2 q first + have recorded := recordSample_seedTape col q x (by + intro s found + rw [powTape] + exact kept s (powSeed ▸ found)) + intro s found + rw [replyTape] + exact recorded s (replySeed ▸ found) + +/-- The accepted batching scalar of the native seed is the initial tape sample. -/ +theorem accepted_lambda {C : DuplexModeGame.PrimitiveOracle} + {decode : List Nat → Nat → List FiatShamirGame.Byte → Option MerkleTransport.PrunedMerklePaths} + {grinding : Fin (cfg).folds.size → Fin 64} {r : SpongefishSessionAdapter.Record} + {input : PCSBCSCallerBinding.CallerInput p} {cur : SpongefishPCSRoundFrames.Cursor} + (a : Accepted C decode grinding r input cur) : a.collected.tape.1 = a.seed.2 := + run_seedTape C decode grinding r.shape.lanes (WHIRHistory.schedule cfg) _ _ + (fun _ found => by cases found) a.ran a.seed a.seeded + +/-! ## Caller binding facts guaranteed by the current original reconstruction -/ + +theorem prepare_binding (r : SpongefishSessionAdapter.Record) + (claims : SpongefishCurrentSourceCallerOriginal.Payload) (input : PCSBCSCallerBinding.CallerInput p) + (prepared : SpongefishCurrentSourceCallerOriginal.prepare p r claims = some input) : + input.lanes = r.shape.lanes ∧ input.anchorPoint = r.point.toArray ∧ input.anchorValue = r.value := by + unfold SpongefishCurrentSourceCallerOriginal.prepare at prepared + split at prepared + · split at prepared + · obtain ⟨_,_,built⟩ := Option.bind_eq_some_iff.mp prepared + cases built + exact ⟨rfl,rfl,rfl⟩ + · cases prepared + · cases prepared + +theorem finish_binding (layout : WHIRCallerClaims.CallerLayout) (q : FiatShamirGame.Coordinate) + (r : SpongefishSessionAdapter.Record) + (result : Except (SpongefishCurrentMixedModeCompiler.Data × + SpongefishCurrentPrimitiveEventCompiler.ReplayError) SpongefishCurrentMixedModeCompiler.Data) + (input : PCSBCSCallerBinding.CallerInput p) + (finished : SpongefishCurrentSourceCallerOriginal.finish p layout q r result = some input) : + r.shape = AnchoredSourceCaller.shape layout ∧ input.lanes = r.shape.lanes ∧ + input.anchorPoint = r.point.toArray ∧ input.anchorValue = r.value := by + cases result with + | error e => cases finished + | ok data => + change (if (SpongefishPCSRoundFrames.close data.pending).core.history ≠ q.history ∨ + data.narg ≠ [] then none else do + let events ← SpongefishCurrentSourceCallerOriginal.callerEvents data.events + let claims ← SpongefishCurrentSourceCallerOriginal.parseEvents layout r events + SpongefishCurrentSourceCallerOriginal.prepare p r claims) = some input at finished + split at finished + · cases finished + obtain ⟨_,_,finished⟩ := Option.bind_eq_some_iff.mp finished + obtain ⟨claims,parsed,finished⟩ := Option.bind_eq_some_iff.mp finished + refine ⟨?_,prepare_binding r claims input finished⟩ + unfold SpongefishCurrentSourceCallerOriginal.parseEvents at parsed + split at parsed + · cases parsed + · next same => exact not_not.mp same + +/-- A physically reconstructed original fixes lanes, anchor point and value from the received record, and the record carries the caller layout's shape, whose batch dimension is the configured first fold. -/ +theorem physicalCandidate_binding (C : DuplexModeGame.PrimitiveOracle) (iv : FiatShamirGame.Digest32) + (layout : WHIRCallerClaims.CallerLayout) (q : FiatShamirGame.Coordinate) + (r : SpongefishSessionAdapter.Record) (instanceBytes : List FiatShamirGame.Byte) + (input : PCSBCSCallerBinding.CallerInput p) + (found : SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r instanceBytes = + some input) : + r.shape = AnchoredSourceCaller.shape layout ∧ r.shape.logBatch = (cfg).folds[0]! ∧ + input.lanes = r.shape.lanes ∧ input.anchorPoint = r.point.toArray ∧ input.anchorValue = r.value := by + unfold SpongefishCurrentSourceCallerOriginal.physicalCandidate at found + obtain ⟨result,_,finished⟩ := Option.bind_eq_some_iff.mp found + obtain ⟨shape,binding⟩ := finish_binding layout q r result input finished + refine ⟨shape,?_,binding⟩ + rw [shape,(WHIRCallerSupport.config_initial_geometry p).2] + rfl + +/-! ## Native acceptance is abstract experiment acceptance -/ + +/-- An accepted native opening (seed, parsed replies, anchored native equations) for an original bound to the received record is an accepted causal experiment on the original claims, for the base oracle `root` and the indexed strategy of the replies with restored ghost next oracles, provided the opened rows are authenticated against `root` and `next` and these oracles have their public shapes. -/ +theorem experiment_accepts (r : SpongefishSessionAdapter.Record) + (input : PCSBCSCallerBinding.CallerInput p) (col : Collected p) + (seed : RingPCSGame.Prefix × E) (proof : Opening) + (lambda : col.tape.1 = seed.2) + (parsed : CausalGame.opening cfg (challenges cfg col.tape) col.replies = .ok proof) + (equations : anchoredVerify r input.family input.points seed.1 seed.2 cfg + (challenges cfg col.tape) proof = .ok ()) + (lanes : input.lanes = r.shape.lanes) (anchorPoint : input.anchorPoint = r.point.toArray) + (anchorValue : input.anchorValue = r.value) + (dimension : r.shape.logN = (cfg).logN) (batch : r.shape.logBatch = (cfg).folds[0]!) + (root : BaseOracle) (next : Nat → Oracle) + (rootShape : oracleValid (liftRoot root) (2^((cfg).logN-(cfg).folds[0]!+(cfg).rates[0]!)) + r.shape.lanes = true) + (nextShapes : NextShapes cfg next) + (rows : RowsAuthenticated col.tape col.replies root next) : + experiment (OriginalClaimsChecker.input input.prepared root seed.1) + (CausalStrategy.indexedStrategy (restoredReplies col next)) col.tape = true := by + let record : AnchoredHeaderCodec.Record := + ⟨r.shape,r.root,⟨DuplexRefinement.zeroDigest,fun _ => none,0,false,0,0⟩,r.point,r.value⟩ + have native : AnchoredPhysicalAnchor.sourceVerify record input.family input.points seed.1 seed.2 cfg + (challenges cfg col.tape) proof = .ok () := equations + have present := nativeVerify_present cfg _ _ _ _ proof native + have restored := opening_restore cfg col.tape next col.replies proof parsed + have sizes : proof.levels.size = (cfg).folds.size := by + rw [opening_decoded _ _ _ proof parsed] + simp [decodedOpening] + have nativeRestored : AnchoredPhysicalAnchor.sourceVerify record input.family input.points seed.1 + seed.2 cfg (challenges cfg col.tape) (WHIRNativeErasure.restoreOracles proof next) = .ok () := by + unfold AnchoredPhysicalAnchor.sourceVerify + rw [WHIRNativeErasure.nativeVerify_restored] + exact native + have guards := input.prepared.guards + obtain ⟨familyShape,pointShapes,_⟩ := guards_nativeShapes guards + obtain ⟨allShapes,batchShape⟩ := guards_claims_shapes guards seed.1 seed.2 r.point.toArray r.value + rw [lanes] at allShapes batchShape + have claimsEq : (OriginalClaimsChecker.input input.prepared root seed.1).claims = + AnchorPrefixRefinement.anchoredClaims cfg record input.family input.points seed.1 := by + rw [OriginalClaimsChecker.input_claims, AnchorPrefixRefinement.anchoredClaims, lanes, anchorPoint, + anchorValue] + have occupied : 0 < r.shape.lanes ∧ r.shape.lanes ≤ 2^r.shape.logBatch := by + rw [← lanes,batch] + exact ⟨guards.2.2.1,guards.2.2.2.1⟩ + have dimensions : r.shape.logBatch < r.shape.logN := by + rw [batch,dimension,(WHIRCallerSupport.config_initial_geometry p).1, + (WHIRCallerSupport.config_initial_geometry p).2] + omega + have pointSize : r.point.length = r.shape.logN := by + have size := guards.2.2.2.2.1 + rw [anchorPoint] at size + simpa [dimension] using size + apply WHIRPhysicalSoundness.experiment_indexed_accepts (OriginalClaimsChecker.input input.prepared root seed.1) + col.tape (restoredReplies col next) (WHIRNativeErasure.restoreOracles proof next) restored + · change ((OriginalClaimsChecker.input input.prepared root seed.1).claims.all + fun claim => shapeValid cfg input.lanes claim.weight) = true + rw [claimsEq,lanes] + exact allShapes + · change Protocol.verify cfg (challenges cfg col.tape) input.lanes (liftRoot root) + (batchClaims (2^(cfg).logN) (OriginalClaimsChecker.input input.prepared root seed.1).claims + col.tape.1).weight + (batchClaims (2^(cfg).logN) (OriginalClaimsChecker.input input.prepared root seed.1).claims + col.tape.1).value (WHIRNativeErasure.restoreOracles proof next) = .ok () + rw [claimsEq,lambda,lanes] + exact anchored_refines cfg record input.family input.points seed.1 seed.2 (challenges cfg col.tape) + _ (liftRoot root) dimension batch occupied dimensions pointSize familyShape pointShapes + batchShape rootShape (restored_rootShapes next proof sizes nextShapes) + (restored_authenticated cfg col.tape col.replies proof root next parsed present + (rowsAuthenticated_derived col.tape col.replies root next rows)) + nativeRestored + +/-- The same conclusion read off an `Accepted` native opening: the seed, the parsed replies, the anchored equations and the batching scalar all come from the accepted run. -/ +theorem accepted_experiment {C : DuplexModeGame.PrimitiveOracle} + {decode : List Nat → Nat → List FiatShamirGame.Byte → Option MerkleTransport.PrunedMerklePaths} + {grinding : Fin (cfg).folds.size → Fin 64} {r : SpongefishSessionAdapter.Record} + {input : PCSBCSCallerBinding.CallerInput p} {cur : SpongefishPCSRoundFrames.Cursor} + (a : Accepted C decode grinding r input cur) + (lanes : input.lanes = r.shape.lanes) (anchorPoint : input.anchorPoint = r.point.toArray) + (anchorValue : input.anchorValue = r.value) + (dimension : r.shape.logN = (cfg).logN) (batch : r.shape.logBatch = (cfg).folds[0]!) + (root : BaseOracle) (next : Nat → Oracle) + (rootShape : oracleValid (liftRoot root) (2^((cfg).logN-(cfg).folds[0]!+(cfg).rates[0]!)) + r.shape.lanes = true) + (nextShapes : NextShapes cfg next) + (rows : RowsAuthenticated a.collected.tape a.collected.replies root next) : + experiment (OriginalClaimsChecker.input input.prepared root a.seed.1) + (CausalStrategy.indexedStrategy (restoredReplies a.collected next)) a.collected.tape = true := + experiment_accepts r input a.collected a.seed a.proof (accepted_lambda a) a.parsed a.equations + lanes anchorPoint anchorValue dimension batch root next rootShape nextShapes rows + +/-- With the original reconstructed by `physicalCandidate` on the received record, only the record dimension, the oracle shapes and row authentication remain. -/ +theorem candidate_experiment {C : DuplexModeGame.PrimitiveOracle} + {decode : List Nat → Nat → List FiatShamirGame.Byte → Option MerkleTransport.PrunedMerklePaths} + {grinding : Fin (cfg).folds.size → Fin 64} {r : SpongefishSessionAdapter.Record} + {input : PCSBCSCallerBinding.CallerInput p} {cur : SpongefishPCSRoundFrames.Cursor} + (a : Accepted C decode grinding r input cur) (iv : FiatShamirGame.Digest32) + (layout : WHIRCallerClaims.CallerLayout) (q : FiatShamirGame.Coordinate) + (instanceBytes : List FiatShamirGame.Byte) + (found : SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout q r instanceBytes = + some input) + (dimension : r.shape.logN = (cfg).logN) + (root : BaseOracle) (next : Nat → Oracle) + (rootShape : oracleValid (liftRoot root) (2^((cfg).logN-(cfg).folds[0]!+(cfg).rates[0]!)) + r.shape.lanes = true) + (nextShapes : NextShapes cfg next) + (rows : RowsAuthenticated a.collected.tape a.collected.replies root next) : + experiment (OriginalClaimsChecker.input input.prepared root a.seed.1) + (CausalStrategy.indexedStrategy (restoredReplies a.collected next)) a.collected.tape = true := by + obtain ⟨_,batch,lanes,anchorPoint,anchorValue⟩ := + physicalCandidate_binding C iv layout q r instanceBytes input found + exact accepted_experiment a lanes anchorPoint anchorValue dimension batch root next rootShape + nextShapes rows + +#print axioms restoredReplies_prefix +#print axioms restoredReplies_agree +#print axioms opening_restore +#print axioms restored_authenticated +#print axioms restored_rootShapes +#print axioms accepted_lambda +#print axioms physicalCandidate_binding +#print axioms experiment_accepts +#print axioms accepted_experiment +#print axioms candidate_experiment + +end Whir.SpongefishCurrentOpeningExperiment diff --git a/verification/whir/Whir/SpongefishCurrentOpeningPackets.lean b/verification/whir/Whir/SpongefishCurrentOpeningPackets.lean new file mode 100644 index 000000000..4771e809e --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentOpeningPackets.lean @@ -0,0 +1,1249 @@ +import Whir.SpongefishCurrentBCSKnowledge + +/-! Current #607 opening draws as exposed round packets in the IDEAL world, on every table of the current round packet partition. + +The counted current source replays a fixed call list `pre ++ openingCalls grinding` through the semantic replay (`SpongefishCurrentMixedModeCompiler.replayProgram`), possibly followed by an arbitrary continuation. The replay contains only construction queries; on an ideal table every one of them is answered by the raw table at its literal construction key. The opening schedule never has two verifier draws without a nonempty prover payload between them (for every grinding), so the `j`-th opening draw closes a history with exactly `boundary + j + 1` frames when the opening starts with `boundary` closed frames and a pending prover run. The first block of every draw is cached or observed by the replay, hence recorded in the atomic trace with its whole packet, and the literal drawn bytes decode to the grouped packet value. This is a deterministic statement on every table; it contains no probability or acceptance assumption. -/ +namespace Whir.SpongefishCurrentOpeningPackets +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame RawOracleCoupling +open TypedOracleCompiler SpongefishPCSRoundFrames SpongefishCurrentModeQueries +open SpongefishCurrentMixedModeCompiler +set_option autoImplicit false +set_option maxRecDepth 100000 + +/-! ## Construction-only programs answered by a fixed coordinate function -/ + +/-- Answer every construction query by `ans`; primitive queries get zero. -/ +def answerOf (ans : Coordinate → Digest32) : Query → Digest32 + | .construction q _ => ans q + | .primitive _ _ => zeroDigest + +def runWith (ans : Coordinate → Digest32) {R : Type} : Program R → View R + | .done r => ⟨[],r⟩ + | .ask q next => + let rest := runWith ans (next (answerOf ans q)) + ⟨⟨q,answerOf ans q⟩ :: rest.observations,rest.result⟩ + +def ConstructionOnly {R : Type} : Program R → Prop + | .done _ => True + | .ask (.construction _ _) next => ∀ d, ConstructionOnly (next d) + | .ask (.primitive _ _) _ => False + +/-- The ideal answer of a construction coordinate within the raw-key budget. -/ +def idealAnswer (Q : Nat) (iv : Digest32) (ro : RawKey Q → Digest32) (q : Coordinate) : Digest32 := + if h : pathCost q ≤ Q then ro (constructionKey Q iv q h) else zeroDigest + +theorem runWith_bind (ans : Coordinate → Digest32) {R S : Type} (p : Program R) + (k : R → Program S) : + runWith ans (WHIRModeFinal.bind p k) = + ⟨(runWith ans p).observations ++ (runWith ans (k (runWith ans p).result)).observations, + (runWith ans (k (runWith ans p).result)).result⟩ := by + induction p with + | done r => rfl + | ask q next ih => + simp only [WHIRModeFinal.bind,runWith,ih,List.cons_append] + +theorem constructionOnly_bind {R S : Type} (p : Program R) (k : R → Program S) + (first : ConstructionOnly p) (rest : ∀ r, ConstructionOnly (k r)) : + ConstructionOnly (WHIRModeFinal.bind p k) := by + induction p with + | done r => exact rest r + | ask q next ih => + cases q with + | primitive => exact first.elim + | construction c valid => exact fun d => ih d (first d) + +theorem ideal_runWith {Q : Nat} {Seed State R : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (p : Program R) (only : ConstructionOnly p) : + ∀ (state : State) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p), + (runIdeal sim ro iv state p remaining cap counted).view = runWith (idealAnswer Q iv ro) p := by + induction p with + | done r => intro _ _ _ _; rfl + | ask q next ih => + cases q with + | primitive => exact only.elim + | construction c valid => + intro state remaining cap counted + have bound : pathCost c ≤ Q := counted.1.trans cap + have answer : ro (constructionKey Q iv c bound) = idealAnswer Q iv ro c := by + simp only [idealAnswer,bound,↓reduceDIte] + have rest := ih (ro (constructionKey Q iv c bound)) (only _) state (remaining-pathCost c) + (by omega) (counted.2 _) + simp only [runIdeal,prepend,runWith,answerOf] + rw [rest,answer] + +theorem ideal_cost {Q : Nat} {Seed State R : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (p : Program R) : + ∀ (state : State) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining p), + ∀ o ∈ (runIdeal sim ro iv state p remaining cap counted).view.observations, + o.query.cost ≤ remaining := by + induction p with + | done r => intro _ _ _ _ o member; cases member + | ask q next ih => + cases q with + | primitive purpose input => + intro state remaining cap counted o member + simp only [runIdeal,prepend,List.mem_cons] at member + rcases member with rfl | later + · exact counted.1 + · exact (ih _ _ _ _ _ o later).trans (Nat.sub_le _ _) + | construction c valid => + intro state remaining cap counted o member + simp only [runIdeal,prepend,List.mem_cons] at member + rcases member with rfl | later + · exact counted.1 + · exact (ih _ _ _ _ _ o later).trans (Nat.sub_le _ _) + +/-- Ideal runs of an appended program split at the first program's result. -/ +theorem ideal_bind {Q : Nat} {Seed State R S : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (p : Program R) (k : R → Program S) : + ∀ (state : State) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (WHIRModeFinal.bind p k)), + ∃ (state' : State) (rest : Nat) (cap' : rest ≤ Q) + (counted' : Counts rest (k (runIdeal sim ro iv state p remaining cap + (WHIRModeFinal.bind_prefix_counted p k remaining counted)).view.result)), + (runIdeal sim ro iv state (WHIRModeFinal.bind p k) remaining cap counted).view = + ⟨(runIdeal sim ro iv state p remaining cap + (WHIRModeFinal.bind_prefix_counted p k remaining counted)).view.observations ++ + (runIdeal sim ro iv state' (k (runIdeal sim ro iv state p remaining cap + (WHIRModeFinal.bind_prefix_counted p k remaining counted)).view.result) rest cap' + counted').view.observations, + (runIdeal sim ro iv state' (k (runIdeal sim ro iv state p remaining cap + (WHIRModeFinal.bind_prefix_counted p k remaining counted)).view.result) rest cap' + counted').view.result⟩ := by + induction p with + | done r => intro state remaining cap counted; exact ⟨state,remaining,cap,counted,rfl⟩ + | ask q next ih => + cases q with + | primitive purpose input => + intro state remaining cap counted + obtain ⟨state',rest,cap',counted',same⟩ := ih (runRO ro (sim.answer state input)).1.2 + (runRO ro (sim.answer state input)).1.1 (remaining-1) (by omega) (counted.2 _) + refine ⟨state',rest,cap',counted',?_⟩ + simp only [WHIRModeFinal.bind,runIdeal,prepend] + rw [same] + rfl + | construction c valid => + intro state remaining cap counted + obtain ⟨state',rest,cap',counted',same⟩ := ih (ro (constructionKey Q iv c (counted.1.trans cap))) + state (remaining-pathCost c) (by omega) (counted.2 _) + refine ⟨state',rest,cap',counted',?_⟩ + simp only [WHIRModeFinal.bind,runIdeal,prepend] + rw [same] + rfl + +/-! ## The semantic replay under a fixed coordinate answer -/ + +section Replay +variable (ans : Coordinate → Digest32) + +/-- Every cached reply is the fixed answer of its coordinate. -/ +def CacheOK (cache : Cache) : Prop := ∀ q d, cache q = some d → d = ans q + +/-- A construction coordinate observed with its answer. -/ +def Observed (obs : List Observation) (q : Coordinate) : Prop := + ∃ valid, (⟨.construction q valid,ans q⟩ : Observation) ∈ obs + +/-- Every coordinate cached after a phase was cached before or observed in it. -/ +def Known (before : Cache) (obs : List Observation) (after : Cache) : Prop := + ∀ q, after q ≠ none → before q ≠ none ∨ Observed ans obs q + +theorem request_only (cache : Cache) (q : Coordinate) (valid : DuplexEncoding.Admissible q) : + ConstructionOnly (SpongefishCurrentMixedModeCompiler.request cache q valid) := by + unfold SpongefishCurrentMixedModeCompiler.request + cases cache q with + | none => exact fun _ => trivial + | some => trivial + +theorem collect_only (m : Pending) (positions : List Nat) + (valid : ∀ p ∈ positions, DuplexEncoding.Admissible (coordinate m (p/32))) (cache : Cache) : + ConstructionOnly (collect m positions valid cache) := by + induction positions generalizing cache with + | nil => trivial + | cons p ps ih => + exact constructionOnly_bind _ _ (request_only _ _ _) + (fun r => constructionOnly_bind _ _ (ih _ _) (fun _ => trivial)) + +theorem replay_only (cur : SemanticCursor) (calls : List Call) : + ConstructionOnly (replayProgram cur calls) := by + induction calls generalizing cur with + | nil => trivial + | cons call calls ih => + cases call with + | read kind => + simp only [replayProgram] + cases kind.codec.parse cur.data.narg with + | none => trivial + | some pair => exact ih _ + | hint => + simp only [replayProgram] + cases cur.data.hints with + | nil => trivial + | cons bytes rest => exact ih _ + | draw g => + simp only [replayProgram] + split + · exact ih _ + · split + · exact constructionOnly_bind _ _ (collect_only _ _ _ _) (fun _ => ih _) + · trivial + +theorem request_with (cache : Cache) (good : CacheOK ans cache) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) : + let v := runWith ans (SpongefishCurrentMixedModeCompiler.request cache q valid) + CacheOK ans v.result.1 ∧ v.result.2 = ans q ∧ v.result.1 q ≠ none ∧ + (∀ c, cache c ≠ none → v.result.1 c ≠ none) ∧ Known ans cache v.observations v.result.1 := by + unfold SpongefishCurrentMixedModeCompiler.request + cases found : cache q with + | some d => + simp only [runWith] + exact ⟨good,good q d found,by simp [found],fun _ h => h,fun c h => Or.inl h⟩ + | none => + simp only [runWith,answerOf] + refine ⟨?_,by trivial,by simp [store],?_,?_⟩ + · intro c d stored + unfold store at stored + split at stored + · rename_i same + subst same + exact (Option.some.inj stored).symm + · exact good c d stored + · intro c cached + unfold store + split + · simp + · exact cached + · intro c cached + unfold store at cached + split at cached + · rename_i same + subst same + exact Or.inr ⟨valid,List.mem_singleton_self _⟩ + · exact Or.inl cached + +theorem collect_with (m : Pending) (positions : List Nat) + (valid : ∀ p ∈ positions, DuplexEncoding.Admissible (coordinate m (p/32))) (cache : Cache) + (good : CacheOK ans cache) : + let v := runWith ans (collect m positions valid cache) + CacheOK ans v.result.1 ∧ + v.result.2 = positions.map (fun p => ans (coordinate m (p/32)) ⟨p%32,Nat.mod_lt _ (by decide)⟩) ∧ + (∀ p ∈ positions, v.result.1 (coordinate m (p/32)) ≠ none) ∧ + (∀ c, cache c ≠ none → v.result.1 c ≠ none) ∧ Known ans cache v.observations v.result.1 := by + induction positions generalizing cache with + | nil => exact ⟨good,rfl,by simp,fun _ h => h,fun c h => Or.inl h⟩ + | cons p ps ih => + dsimp only + simp only [collect,seq,runWith_bind] + obtain ⟨good₁,answer₁,hit₁,mono₁,known₁⟩ := request_with ans cache good + (coordinate m (p/32)) (valid p List.mem_cons_self) + generalize (runWith ans (SpongefishCurrentMixedModeCompiler.request cache (coordinate m (p/32)) + (valid p List.mem_cons_self))) = first at * + obtain ⟨obs₁,next,d⟩ := first + dsimp only at good₁ answer₁ hit₁ mono₁ known₁ ⊢ + obtain ⟨good₂,answer₂,hit₂,mono₂,known₂⟩ := ih (fun j h => valid j (List.mem_cons_of_mem _ h)) + next good₁ + simp only [runWith] at good₂ answer₂ hit₂ mono₂ known₂ ⊢ + generalize (runWith ans (collect m ps (fun j h => valid j (List.mem_cons_of_mem _ h)) next)) = rest at * + obtain ⟨obs₂,last,bs⟩ := rest + dsimp only at good₂ answer₂ hit₂ mono₂ known₂ ⊢ + refine ⟨good₂,by rw [answer₁,answer₂]; rfl,?_,fun c h => mono₂ c (mono₁ c h),?_⟩ + · intro j member + rcases List.mem_cons.mp member with rfl | later + · exact mono₂ _ hit₁ + · exact hit₂ j later + · intro c cached + rcases known₂ c cached with before | seen + · rcases known₁ c before with older | seen + · exact Or.inl older + · obtain ⟨v,member⟩ := seen + exact Or.inr ⟨v,by simp [member]⟩ + · obtain ⟨v,member⟩ := seen + exact Or.inr ⟨v,by simp [member]⟩ + +theorem observed_mono (obs obs' : List Observation) (q : Coordinate) + (sub : ∀ o ∈ obs, o ∈ obs') (seen : Observed ans obs q) : Observed ans obs' q := by + obtain ⟨valid,member⟩ := seen + exact ⟨valid,sub _ member⟩ + +theorem group_bytes_pos (g : Group) : g.bytes ≠ 0 := by + cases g <;> simp [Group.bytes,Group.elements] + +theorem bind_frames (m : Pending) (bytes : List Byte) : + (SpongefishPCSRoundFrames.bind m bytes).frames = m.frames := by + unfold SpongefishPCSRoundFrames.bind; split <;> rfl + +theorem bind_domain (m : Pending) (bytes : List Byte) : + (SpongefishPCSRoundFrames.bind m bytes).domain = m.domain := by + unfold SpongefishPCSRoundFrames.bind; split <;> rfl + +theorem bind_nonempty (m : Pending) (bytes : List Byte) (nonempty : bytes ≠ []) : + (SpongefishPCSRoundFrames.bind m bytes).run ≠ [] ∧ + (SpongefishPCSRoundFrames.bind m bytes).consumed = 0 := by + simp [SpongefishPCSRoundFrames.bind,nonempty] + +theorem codec_bytes_eq_nil (kind : WireKind) (value : kind.Value) : + kind.codec.bytes value = [] ↔ kind.codec.size = 0 := by + constructor + · intro empty + have length := congrArg List.length empty + simpa only [Codec.bytes,List.length_ofFn,List.length_nil] using length + · intro zero + apply List.eq_nil_of_length_eq_zero + simpa only [Codec.bytes,List.length_ofFn] using zero + +theorem draw_facts (m : Pending) (n : Nat) (positive : n ≠ 0) : + (draw m n).frames = (close m).frames ∧ (draw m n).run = [] ∧ (draw m n).domain = m.domain := by + by_cases empty : m.run = [] <;> simp [draw,positive,close,empty] + +theorem close_frames (m : Pending) (nonempty : m.run ≠ []) : + (close m).frames = m.frames ++ [.absorb m.previous m.run] := by + simp [close,nonempty] + +theorem close_prefix (m : Pending) : m.frames <+: (close m).frames := by + by_cases empty : m.run = [] + · simp [close,empty] + · rw [close_frames m empty] + exact List.prefix_append _ _ + +/-- Static frame shape of a call list: closed frames and whether a prover run is pending. Every group draws a positive number of bytes. -/ +def frameShape : Nat × Bool → List Call → Nat × Bool + | s, [] => s + | s, .read kind :: rest => frameShape (s.1,s.2 || decide (kind.codec.size ≠ 0)) rest + | s, .hint :: rest => frameShape s rest + | s, .draw _ :: rest => frameShape (if s.2 then s.1+1 else s.1,false) rest + +def Shaped (m : Pending) (s : Nat × Bool) : Prop := + m.frames.length = s.1 ∧ (s.2 = true ↔ m.run ≠ []) ∧ (m.run ≠ [] → m.consumed = 0) + +theorem replay_shape (cur : SemanticCursor) (calls : List Call) (s : Nat × Bool) + (shaped : Shaped cur.data.pending s) (good : CacheOK ans cur.cache) (fin : SemanticCursor) + (ok : (runWith ans (replayProgram cur calls)).result = .ok fin) : + Shaped fin.data.pending (frameShape s calls) ∧ CacheOK ans fin.cache ∧ + Known ans cur.cache (runWith ans (replayProgram cur calls)).observations fin.cache := by + induction calls generalizing cur s with + | nil => + simp only [replayProgram,runWith,Except.ok.injEq] at ok + subst ok + exact ⟨shaped,good,fun c h => Or.inl h⟩ + | cons call calls ih => + cases call with + | read kind => + cases parsed : kind.codec.parse cur.data.narg with + | none => simp [replayProgram,parsed,runWith] at ok + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [replayProgram,parsed] at ok ⊢ + refine ih (readNext cur kind value rest) _ ?_ good ok + obtain ⟨frames,ready,zeroed⟩ := shaped + change Shaped (SpongefishPCSRoundFrames.bind cur.data.pending (kind.codec.bytes value)) _ + by_cases zero : kind.codec.size = 0 + · have empty := (codec_bytes_eq_nil kind value).mpr zero + rw [empty] + simpa [Shaped,SpongefishPCSRoundFrames.bind,zero] using + (⟨frames,ready,zeroed⟩ : Shaped cur.data.pending s) + · have nonempty : kind.codec.bytes value ≠ [] := fun h => zero ((codec_bytes_eq_nil kind value).mp h) + obtain ⟨run,consumed⟩ := bind_nonempty cur.data.pending _ nonempty + refine ⟨by rw [bind_frames]; exact frames,?_,fun _ => consumed⟩ + simp [zero,run] + | hint => + cases hints : cur.data.hints with + | nil => simp [replayProgram,hints,runWith] at ok + | cons bytes rest => + simp only [replayProgram,hints] at ok ⊢ + exact ih (hintNext cur bytes rest) s shaped good ok + | draw g => + have positive := group_bytes_pos g + by_cases guard : cur.data.pending.consumed + g.bytes ≤ maxCursor + · simp only [replayProgram,positive,guard,↓reduceDIte,seq,runWith_bind] at ok ⊢ + obtain ⟨good₁,_,_,_,known₁⟩ := collect_with ans cur.data.pending + (positions cur.data.pending g.bytes) (positions_valid _ cur.framed _ guard) cur.cache good + generalize (runWith ans (collect cur.data.pending (positions cur.data.pending g.bytes) + (positions_valid _ cur.framed _ guard) cur.cache)) = first at * + obtain ⟨obs₁,cache,bytes⟩ := first + dsimp only at good₁ known₁ ok ⊢ + obtain ⟨frames,ready,zeroed⟩ := shaped + obtain ⟨drawFrames,drawRun,_⟩ := draw_facts cur.data.pending g.bytes positive + have next : Shaped (draw cur.data.pending g.bytes) (if s.2 then s.1+1 else s.1,false) := by + refine ⟨?_,by simp [drawRun],fun h => (h drawRun).elim⟩ + rw [drawFrames] + by_cases empty : cur.data.pending.run = [] + · have notReady : s.2 = false := by simpa [empty] using ready + simp [close,empty,notReady,frames] + · have isReady : s.2 = true := ready.mpr empty + simp [close_frames _ empty,isReady,frames] + obtain ⟨shaped',good',known'⟩ := ih (drawn cur g.bytes guard cache bytes) _ next good₁ ok + refine ⟨shaped',good',fun c cached => ?_⟩ + rcases known' c cached with before | seen + · rcases known₁ c before with older | seen + · exact Or.inl older + · exact Or.inr (observed_mono ans _ _ c (fun o h => List.mem_append_left _ h) seen) + · exact Or.inr (observed_mono ans _ _ c (fun o h => List.mem_append_right _ h) seen) + · simp [replayProgram,positive,guard,runWith] at ok + +/-- Successful replay of an appended call list splits at the cursor reached by the first part; observations split accordingly. -/ +theorem replay_append (cur : SemanticCursor) (xs ys : List Call) (fin : SemanticCursor) + (ok : (runWith ans (replayProgram cur (xs ++ ys))).result = .ok fin) : + ∃ mid, (runWith ans (replayProgram cur xs)).result = .ok mid ∧ + (runWith ans (replayProgram mid ys)).result = .ok fin ∧ + (runWith ans (replayProgram cur (xs ++ ys))).observations = + (runWith ans (replayProgram cur xs)).observations ++ + (runWith ans (replayProgram mid ys)).observations := by + induction xs generalizing cur with + | nil => exact ⟨cur,rfl,ok,rfl⟩ + | cons call xs ih => + cases call with + | read kind => + cases parsed : kind.codec.parse cur.data.narg with + | none => simp [replayProgram,parsed,runWith] at ok + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [List.cons_append,replayProgram,parsed] at ok ⊢ + exact ih _ ok + | hint => + cases hints : cur.data.hints with + | nil => simp [replayProgram,hints,runWith] at ok + | cons bytes rest => + simp only [List.cons_append,replayProgram,hints] at ok ⊢ + exact ih _ ok + | draw g => + have positive := group_bytes_pos g + by_cases guard : cur.data.pending.consumed + g.bytes ≤ maxCursor + · simp only [List.cons_append,replayProgram,positive,guard,↓reduceDIte,seq,runWith_bind] + at ok ⊢ + generalize (runWith ans (collect cur.data.pending (positions cur.data.pending g.bytes) + (positions_valid _ cur.framed _ guard) cur.cache)) = first at * + obtain ⟨obs₁,cache,bytes⟩ := first + dsimp only at ok ⊢ + obtain ⟨mid,first,second,split⟩ := ih (drawn cur g.bytes guard cache bytes) ok + exact ⟨mid,first,second,by rw [split,List.append_assoc]⟩ + · simp [List.cons_append,replayProgram,positive,guard,runWith] at ok + +/-- Groups of the draw calls, in order. -/ +def drawGroups (calls : List Call) : List Group := + calls.filterMap fun call => match call with | .draw g => some g | _ => none + +/-- Drawn bytes of the verifier events, in order. -/ +def verifierBytes (events : List SourceEvent) : List (List Byte) := + events.filterMap fun event => match event with | .verifier bytes => some bytes | _ => none + +/-- Facts about the `k`-th positive draw of a separated replay segment: its pending cursor `m`, group `g` and drawn bytes. -/ +structure DrawFact (domain : Digest32) (base : Nat) (cache : Cache) (final : List ByteFrame) + (obs : List Observation) (k : Nat) (g : Group) (m : Pending) (bytes : List Byte) : Prop where + domain_eq : m.domain = domain + run_ne : m.run ≠ [] + consumed_eq : m.consumed = 0 + framed : FrameDomain m + guard : g.bytes ≤ maxCursor + frames_eq : m.frames.length = base + k + closed : (close m).frames <+: final + bytes_eq : bytes = + (positions m g.bytes).map (fun p => ans (coordinate m (p/32)) ⟨p%32,Nat.mod_lt _ (by decide)⟩) + first : cache (coordinate m 0) ≠ none ∨ Observed ans obs (coordinate m 0) + +/-- A replay segment without two verifier draws in a row (the source `scan`) adds one history frame per draw: the `k`-th draw closes the pending run into `base + k + 1` frames, its bytes are the fixed answers of its coordinates, and its first coordinate is cached at the start or observed in the segment. -/ +theorem replay_draws (cur : SemanticCursor) (calls : List Call) (waiting : Bool) + (ready : waiting = true ↔ cur.data.pending.run = []) + (zeroed : cur.data.pending.run ≠ [] → cur.data.pending.consumed = 0) + (separated : SpongefishCurrentRoundSeparation.scan waiting calls ≠ none) + (good : CacheOK ans cur.cache) (fin : SemanticCursor) + (ok : (runWith ans (replayProgram cur calls)).result = .ok fin) : + ∃ (evs : List SourceEvent) (ms : List Pending), + fin.data.events = cur.data.events ++ evs ∧ evs.length = calls.length ∧ + cur.data.pending.frames <+: fin.data.pending.frames ∧ + ms.length = (drawGroups calls).length ∧ + (verifierBytes evs).length = (drawGroups calls).length ∧ + ∀ k g m bytes, (drawGroups calls)[k]? = some g → ms[k]? = some m → + (verifierBytes evs)[k]? = some bytes → + DrawFact ans cur.data.pending.domain cur.data.pending.frames.length cur.cache + fin.data.pending.frames (runWith ans (replayProgram cur calls)).observations k g m bytes := by + induction calls generalizing cur waiting with + | nil => + simp only [replayProgram,runWith,Except.ok.injEq] at ok + subst ok + refine ⟨[],[],by simp,rfl,List.prefix_refl _,rfl,rfl,?_⟩ + intro k g m bytes found + simp [drawGroups] at found + | cons call calls ih => + cases call with + | read kind => + cases parsed : kind.codec.parse cur.data.narg with + | none => simp [replayProgram,parsed,runWith] at ok + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [replayProgram,parsed] at ok ⊢ + have nextReady : (if kind.codec.size = 0 then waiting else false) = true ↔ + (readNext cur kind value rest).data.pending.run = [] := by + change _ ↔ (SpongefishPCSRoundFrames.bind cur.data.pending (kind.codec.bytes value)).run = [] + by_cases zero : kind.codec.size = 0 + · rw [(codec_bytes_eq_nil kind value).mpr zero] + simpa [zero,SpongefishPCSRoundFrames.bind] using ready + · have nonempty : kind.codec.bytes value ≠ [] := + fun h => zero ((codec_bytes_eq_nil kind value).mp h) + simp [zero,(bind_nonempty cur.data.pending _ nonempty).1] + have nextZeroed : (readNext cur kind value rest).data.pending.run ≠ [] → + (readNext cur kind value rest).data.pending.consumed = 0 := by + change (SpongefishPCSRoundFrames.bind cur.data.pending (kind.codec.bytes value)).run ≠ [] → + (SpongefishPCSRoundFrames.bind cur.data.pending (kind.codec.bytes value)).consumed = 0 + by_cases empty : kind.codec.bytes value = [] + · rw [empty] + simpa [SpongefishPCSRoundFrames.bind] using zeroed + · exact fun _ => (bind_nonempty cur.data.pending _ empty).2 + obtain ⟨evs,ms,events,length,prefixed,msLength,bytesLength,facts⟩ := + ih (readNext cur kind value rest) _ nextReady nextZeroed separated good ok + have sameFrames : (readNext cur kind value rest).data.pending.frames = cur.data.pending.frames := + bind_frames _ _ + have sameDomain : (readNext cur kind value rest).data.pending.domain = cur.data.pending.domain := + bind_domain _ _ + refine ⟨.prover kind (kind.codec.bytes value) :: evs,ms,?_,by simp [length], + sameFrames ▸ prefixed,by simpa [drawGroups] using msLength, + by simpa [verifierBytes,drawGroups] using bytesLength,?_⟩ + · rw [events] + simp [readNext,boundData] + · intro k g m bytes found member drawn + have fact := facts k g m bytes (by simpa [drawGroups] using found) member + (by simpa [verifierBytes] using drawn) + rw [sameDomain,sameFrames] at fact + exact fact + | hint => + cases hints : cur.data.hints with + | nil => simp [replayProgram,hints,runWith] at ok + | cons bytes rest => + simp only [replayProgram,hints] at ok ⊢ + obtain ⟨evs,ms,events,length,prefixed,msLength,bytesLength,facts⟩ := + ih (hintNext cur bytes rest) waiting ready zeroed separated good ok + refine ⟨.hint bytes :: evs,ms,?_,by simp [length],prefixed, + by simpa [drawGroups] using msLength,by simpa [verifierBytes,drawGroups] using bytesLength,?_⟩ + · rw [events] + simp [hintNext] + · intro k g m drawnBytes found member drawn + exact facts k g m drawnBytes (by simpa [drawGroups] using found) member + (by simpa [verifierBytes] using drawn) + | draw g => + have positive := group_bytes_pos g + have notWaiting : waiting = false := by + cases waiting + · rfl + · simp [SpongefishCurrentRoundSeparation.scan] at separated + subst notWaiting + have nonempty : cur.data.pending.run ≠ [] := fun h => by simpa using ready.mpr h + have consumed := zeroed nonempty + have rest : SpongefishCurrentRoundSeparation.scan true calls ≠ none := by + simpa [SpongefishCurrentRoundSeparation.scan] using separated + by_cases guard : cur.data.pending.consumed + g.bytes ≤ maxCursor + · simp only [replayProgram,positive,guard,↓reduceDIte,seq,runWith_bind] at ok ⊢ + obtain ⟨good₁,answer₁,hit₁,_,known₁⟩ := collect_with ans cur.data.pending + (positions cur.data.pending g.bytes) (positions_valid _ cur.framed _ guard) cur.cache good + generalize (runWith ans (collect cur.data.pending (positions cur.data.pending g.bytes) + (positions_valid _ cur.framed _ guard) cur.cache)) = first at * + obtain ⟨obs₁,cache,bytes⟩ := first + dsimp only at good₁ answer₁ hit₁ known₁ ok ⊢ + obtain ⟨drawFrames,drawRun,drawDomain⟩ := draw_facts cur.data.pending g.bytes positive + obtain ⟨evs,ms,events,length,prefixed,msLength,bytesLength,facts⟩ := + ih (drawn cur g.bytes guard cache bytes) true (by simp [drawn,drawRun]) + (fun h => (h drawRun).elim) rest good₁ ok + have nextFrames : (drawn cur g.bytes guard cache bytes).data.pending.frames = + cur.data.pending.frames ++ [.absorb cur.data.pending.previous cur.data.pending.run] := + drawFrames.trans (close_frames _ nonempty) + refine ⟨.verifier bytes :: evs,cur.data.pending :: ms,?_,by simp [length], + (List.prefix_append _ _).trans (nextFrames ▸ prefixed), + by simp [drawGroups,msLength],by simpa [verifierBytes,drawGroups] using bytesLength,?_⟩ + · rw [events] + simp [drawn] + · intro k g' m drawnBytes found member drawnAt + cases k with + | zero => + simp only [drawGroups,List.filterMap_cons,List.getElem?_cons_zero,Option.some.injEq] + at found + simp only [List.getElem?_cons_zero,Option.some.injEq] at member + simp only [verifierBytes,List.filterMap_cons,List.getElem?_cons_zero,Option.some.injEq] + at drawnAt + subst found member drawnAt + have zeroPosition : 0 ∈ positions cur.data.pending g.bytes := by + simp only [positions,consumed,List.mem_map,List.mem_range] + exact ⟨0,Nat.pos_of_ne_zero positive,rfl⟩ + have hit := hit₁ 0 zeroPosition + refine ⟨rfl,nonempty,consumed,cur.framed,by omega,by simp,?_,answer₁,?_⟩ + · rw [← drawFrames] + exact prefixed + · rcases known₁ _ hit with before | seen + · exact Or.inl before + · exact Or.inr (observed_mono ans _ _ _ (fun o h => List.mem_append_left _ h) seen) + | succ k => + have fact := facts k g' m drawnBytes (by simpa [drawGroups] using found) + (by simpa using member) (by simpa [verifierBytes] using drawnAt) + refine ⟨fact.domain_eq.trans drawDomain,fact.run_ne,fact.consumed_eq,fact.framed, + fact.guard,?_,fact.closed,fact.bytes_eq,?_⟩ + · rw [fact.frames_eq,nextFrames] + simp only [List.length_append,List.length_singleton] + omega + · rcases fact.first with before | seen + · rcases known₁ _ before with older | seen + · exact Or.inl older + · exact Or.inr (observed_mono ans _ _ _ (fun o h => List.mem_append_left _ h) seen) + · exact Or.inr (observed_mono ans _ _ _ (fun o h => List.mem_append_right _ h) seen) + · simp [replayProgram,positive,guard,runWith] at ok + +end Replay + +/-! ## The opening schedule: separation, draw order and group widths -/ + +section Schedule +open SpongefishCurrentOpeningAcceptance SpongefishCurrentRoundSeparation +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +theorem scan_reads (xs : List Call) (reads : ∀ c ∈ xs, ∃ kind, c = .read kind) : + scan false xs = some false := by + induction xs with + | nil => rfl + | cons c xs ih => + obtain ⟨kind,rfl⟩ := reads c List.mem_cons_self + simp only [scan,ite_self] + exact ih (fun d h => reads d (List.mem_cons_of_mem _ h)) + +/-- Every coordinate block but an invisible final tail ends with a nonempty prover payload after its draws. -/ +theorem scan_callsOf (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) : + scan false (callsOf grinding q) = some false ∨ + ∃ j, q = .tail j ∧ isVisibleTail j = false ∧ scan false (callsOf grinding q) = some true := by + cases q with + | initial => + left + simp [callsOf,powCalls,drawCalls,replyCalls,PCSBCSRounds.rawWidth,WHIRHistory.stackScalarCount, + scan,WireKind.codec,vectorCodec] + | fold i j => + left + simp only [callsOf,powCalls,drawCalls,replyCalls,List.nil_append,scan_append] + have width : PCSBCSRounds.rawWidth (CausalProbability.Coordinate.fold (c := cfg) i j) = 1 := rfl + rw [width] + simp only [one_ne_zero,↓reduceIte,scan,Option.bind_some,Bool.false_eq_true] + have size : (WireKind.vector 2).codec.size ≠ 0 := by simp [WireKind.codec,vectorCodec] + simp only [size,↓reduceIte] + apply scan_reads + intro c member + split_ifs at member <;> simp_all + | ood i j => + left + simp only [callsOf,powCalls,drawCalls,replyCalls,List.nil_append] + split_ifs <;> simp [scan,WireKind.codec,vectorCodec] + | query i => + left + simp only [callsOf,powCalls,drawCalls,replyCalls,scan_append,scan_pow] + split_ifs <;> simp_all [scan,WireKind.codec,vectorCodec] + | tail j => + cases visible : isVisibleTail j with + | true => + left + simp [callsOf,powCalls,drawCalls,replyCalls,visible,PCSBCSRounds.rawWidth, + WHIRHistory.stackScalarCount,WHIRHistory.scalarCount,scan,WireKind.codec,vectorCodec] + | false => + right + refine ⟨j,rfl,visible,?_⟩ + simp [callsOf,powCalls,drawCalls,replyCalls,visible,PCSBCSRounds.rawWidth, + WHIRHistory.stackScalarCount,WHIRHistory.scalarCount,scan] + +theorem scan_flatMap_false {A : Type} (xs : List A) (f : A → List Call) + (reset : ∀ x ∈ xs, scan false (f x) = some false) : + scan false (xs.flatMap f) = some false := by + induction xs with + | nil => rfl + | cons x xs ih => + simp only [List.flatMap_cons,scan_append,reset x List.mem_cons_self,Option.bind_some] + exact ih (fun y h => reset y (List.mem_cons_of_mem _ h)) + +/-- The whole opening, for every grinding, never has two verifier draws without a nonempty prover payload between them. -/ +theorem scan_opening_calls (grinding : Fin (cfg).folds.size → Fin 64) : + scan false (openingCalls grinding) ≠ none := by + have visible : ∀ q ∈ CausalProbability.visibleCoordinates cfg, + scan false (callsOf grinding q) = some false := by + intro q member + rcases scan_callsOf grinding q with reset | ⟨j,rfl,invisible,_⟩ + · exact reset + · exfalso + simp only [CausalProbability.visibleCoordinates,List.mem_append,List.mem_cons, + List.mem_flatMap,List.mem_ofFn,List.not_mem_nil] at member + rcases member with ((same | none) | ⟨i,_,inLevel⟩) | ⟨k,same⟩ + · cases same + · exact none.elim + · unfold CausalProbability.levelCoordinates at inLevel + split at inLevel + · simp [List.mem_ofFn] at inLevel + · cases inLevel + · cases same + simp only [isVisibleTail,decide_eq_false_iff_not] at invisible + omega + unfold openingCalls WHIRHistory.schedule + rw [List.flatMap_append,scan_append,scan_flatMap_false _ _ visible,Option.bind_some] + unfold WHIRHistory.hiddenTail + split + · simp only [List.flatMap_cons,List.flatMap_nil,List.append_nil] + rcases scan_callsOf grinding (.tail ⟨(cfg).logN - (cfg).folds.toList.sum - 1,by omega⟩) with + reset | ⟨_,_,_,final⟩ + · rw [reset]; simp + · rw [final]; simp + · simp [scan] + +/-- Draw-call groups match the opening draw list: a PCS draw of `q` uses `group q`. -/ +def Matches : Option (Coord p) → Group → Prop + | some q, g => g = group q + | none, _ => True + +theorem drawGroups_append (xs ys : List Call) : + drawGroups (xs ++ ys) = drawGroups xs ++ drawGroups ys := by + simp [drawGroups,List.filterMap_append] + +theorem forall₂_flatMap {A B C : Type} (R : B → C → Prop) (xs : List A) (f : A → List B) + (g : A → List C) (each : ∀ x ∈ xs, List.Forall₂ R (f x) (g x)) : + List.Forall₂ R (xs.flatMap f) (xs.flatMap g) := by + induction xs with + | nil => exact List.Forall₂.nil + | cons x xs ih => + simp only [List.flatMap_cons] + exact List.rel_append (each x List.mem_cons_self) (ih (fun y h => each y (List.mem_cons_of_mem _ h))) + +theorem forall₂_getElem? {B C : Type} {R : B → C → Prop} : + ∀ {xs : List B} {ys : List C}, List.Forall₂ R xs ys → ∀ (k : Nat) (a : B), xs[k]? = some a → + ∃ b, ys[k]? = some b ∧ R a b + | _,_,.nil,_,_,found => by simp at found + | _,_,.cons head _,0,_,found => by + simp only [List.getElem?_cons_zero,Option.some.injEq] at found + subst found + exact ⟨_,rfl,head⟩ + | _,_,.cons _ rest,k+1,a,found => by + simp only [List.getElem?_cons_succ] at found ⊢ + exact forall₂_getElem? rest k a found + +theorem opening_matches (grinding : Fin (cfg).folds.size → Fin 64) : + List.Forall₂ Matches (SpongefishCurrentRoundPackets.openingDraws grinding) + (drawGroups (openingCalls grinding)) := by + have flat : ∀ xs : List (Coord p), drawGroups (xs.flatMap (callsOf grinding)) = + xs.flatMap (fun q => drawGroups (callsOf grinding q)) := by + intro xs + induction xs with + | nil => rfl + | cons x xs ih => simp only [List.flatMap_cons,drawGroups_append,ih] + unfold openingCalls SpongefishCurrentRoundPackets.openingDraws + rw [flat] + apply forall₂_flatMap + intro q _ + cases q with + | initial => + simp [callsOf,powCalls,drawCalls,replyCalls,drawGroups,PCSBCSRounds.rawWidth, + WHIRHistory.stackScalarCount,Matches] + | fold i j => + simp only [callsOf,powCalls,drawCalls,replyCalls,drawGroups_append] + split_ifs <;> simp_all [drawGroups,Matches] + | ood i j => + simp only [callsOf,powCalls,drawCalls,replyCalls,drawGroups_append] + split_ifs <;> simp_all [drawGroups,Matches] + | query i => + simp only [callsOf,powCalls,drawCalls,replyCalls,drawGroups_append,powSchedule] + split_ifs <;> simp_all [drawGroups,Matches] + | tail j => + simp only [callsOf,powCalls,drawCalls,replyCalls,drawGroups_append] + split_ifs <;> simp_all [drawGroups,Matches] + +theorem group_bytes (q : Coord p) (width : PCSBCSRounds.rawWidth q ≠ 0) : + (group q).bytes = 24 * PCSBCSRounds.rawWidth q := by + cases q with + | initial => rfl + | fold i j => rfl + | ood i j => + simp only [PCSBCSRounds.rawWidth,WHIRHistory.stackScalarCount,WHIRHistory.scalarCount] at width ⊢ + simp only [group,Group.bytes,Group.elements] + congr 1 + omega + | query i => rfl + | tail j => rfl + +theorem openingDraws_complete (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) + (scheduled : q ∈ WHIRHistory.schedule cfg) (width : PCSBCSRounds.rawWidth q ≠ 0) : + ∃ k : Nat, (SpongefishCurrentRoundPackets.openingDraws grinding)[k]? = some (some q) := by + have member : some q ∈ SpongefishCurrentRoundPackets.openingDraws grinding := by + unfold SpongefishCurrentRoundPackets.openingDraws + refine List.mem_flatMap.mpr ⟨q,scheduled,?_⟩ + simp [width] + obtain ⟨k,found,same⟩ := List.getElem_of_mem member + exact ⟨k,by rw [List.getElem?_eq_getElem found,same]⟩ + +end Schedule + +/-! ## Grouped decoding of literal drawn bytes -/ + +section Decode +open SpongefishCurrentOpeningAcceptance PCSBCSChallengeOracle +variable {p : ParameterBounds.Profile} + +/-- Drawn bytes agreeing with the concatenated packet blocks on the payload prefix decode to the grouped packet value. -/ +theorem decode_grouped (q : Coord p) (packet : Fin (blocks (PCSBCSRounds.rawWidth q)) → Digest32) + (bytes : List Byte) + (agree : ∀ j (within : j < 24 * PCSBCSRounds.rawWidth q), bytes[j]? = some + (packet ⟨j/32,by unfold blocks; omega⟩ ⟨j%32,Nat.mod_lt _ (by decide)⟩)) : + decodeSample q bytes = grouped q packet := by + have payload := grouped_payload_bytes q packet + simp only [grouped,Equiv.apply_symm_apply] at payload + unfold decodeSample grouped + apply congrArg (rawVector q).symm + funext k + rw [← ByteCodec.decodeE_encodeE ((packetEquiv (PCSBCSRounds.rawWidth q) packet).1 k)] + apply congrArg ByteCodec.decodeE + funext i + have index : (finProdFinEquiv (k,i) : Fin (PCSBCSRounds.rawWidth q * 24)).val = 24*k.val+i.val := by + rw [finProdFinEquiv_apply_val] + dsimp only + omega + have byteAt := payload (finProdFinEquiv (k,i)) + have flat : vectorBytes (PCSBCSRounds.rawWidth q) (packetEquiv (PCSBCSRounds.rawWidth q) packet).1 + (finProdFinEquiv (k,i)) = ByteCodec.encodeE ((packetEquiv (PCSBCSRounds.rawWidth q) packet).1 k) i := by + simp [vectorBytes,flatten,scalarBytesEquiv] + rw [agree (24*k.val+i.val) (by have := k.isLt; have := i.isLt; omega)] + simp only [Option.getD_some] + rw [← flat,byteAt] + simp only [index] + +end Decode + +/-! ## Ideal sources on an arbitrary table -/ + +section Source +variable {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + +/-- Fallback seed and raw oracle carried by a typed table. -/ +def seedOf (table : (key : part.Key) → part.Answer (D := Digest32) key) : DuplexPublicSimulator.Seed := + fun n => part.join table (.inl n) + +def roOf (table : (key : part.Key) → part.Answer (D := Digest32) key) : RawKey Q → Digest32 := + fun key => part.join table (.inr key) + +theorem join_oracle (table : (key : part.Key) → part.Answer (D := Digest32) key) : + part.join table = PublicCompressionCouplingMixed.oracle (seedOf part table) (roOf part table) := by + funext key + cases key <;> rfl + +theorem join_encode (table : (key : part.Key) → part.Answer (D := Digest32) key) (c : Sigma Block) : + part.join table (part.encode c) = table (.inl c.1) c.2 := + congrFun (congrFun (Partition.split_join part table) (.inl c.1)) c.2 + +theorem eval_source {R : Type} (iv : Digest32) (program : Program R) (counted : Counts Q program) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : + Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program counted) = + (runIdeal (DuplexPublicSimulator.simulator Q) (roOf part table) iv ⟨seedOf part table,[]⟩ + program Q (Nat.le_refl Q) counted).view := by + unfold SpongefishCurrentBCSKnowledge.source + rw [PCSBCSChallengeOracle.Atomic.eval_program,join_oracle,PublicCompressionCouplingMixed.compile_actual] + +/-- The source view of an appended program starts with the source view of its first part, at the same budget and partition, and continues with an ideal run of the continuation on that part's result. -/ +theorem source_bind {R S : Type} (iv : Digest32) (program : Program R) (k : R → Program S) + (counted : Counts Q (WHIRModeFinal.bind program k)) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : + ∃ (state : DuplexPublicSimulator.State) (rest : Nat) (cap : rest ≤ Q) + (counted' : Counts rest (k (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program + (WHIRModeFinal.bind_prefix_counted program k Q counted))).result)), + Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv (WHIRModeFinal.bind program k) counted) = + ⟨(Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program + (WHIRModeFinal.bind_prefix_counted program k Q counted))).observations ++ + (runIdeal (DuplexPublicSimulator.simulator Q) (roOf part table) iv state _ rest cap + counted').view.observations, + (runIdeal (DuplexPublicSimulator.simulator Q) (roOf part table) iv state _ rest cap + counted').view.result⟩ := by + rw [eval_source,eval_source] + exact ideal_bind _ _ iv program k _ Q (Nat.le_refl Q) counted + +theorem mixedTrace_construction (iv : Digest32) (c : Coordinate) (valid : DuplexEncoding.Admissible c) + (answer : Digest32) (bound : pathCost c ≤ Q) : + ∀ (log : DuplexPublicSimulator.PublicLog) (obs : List Observation), + (⟨.construction c valid,answer⟩ : Observation) ∈ obs → + (⟨.inr (constructionKey Q iv c bound),answer⟩ : + Sigma (fun _ : PublicCompressionCouplingMixed.Key Q => Digest32)) ∈ + PCSBCSNativePublicCapture.mixedTrace Q iv log obs + | _,[],member => by cases member + | log,o :: rest,member => by + simp only [PCSBCSNativePublicCapture.mixedTrace,List.mem_append] + rcases List.mem_cons.mp member with same | later + · left + subst same + simp [PCSBCSNativePublicCapture.observationDraw,bound] + · right + exact mixedTrace_construction iv c valid answer bound _ rest later + +/-- A construction observation of the source view whose raw key is a block of a packet records that whole packet in the atomic trace. -/ +theorem observed_recorded {R : Type} (iv : Digest32) (program : Program R) (counted : Counts Q program) + (table : (key : part.Key) → part.Answer (D := Digest32) key) (c : Coordinate) + (valid : DuplexEncoding.Admissible c) (answer : Digest32) + (member : (⟨.construction c valid,answer⟩ : Observation) ∈ + (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program counted)).observations) + (block : Sigma Block) + (recognized : ∀ bound, part.recognize (.inr (constructionKey Q iv c bound)) = some block) : + (⟨.inl block.1,table (.inl block.1)⟩ : Sigma (part.Answer (D := Digest32))) ∈ + (Sampling.execute table (SpongefishCurrentBCSKnowledge.source part iv program counted)).2 := by + have bound : pathCost c ≤ Q := by + rw [eval_source] at member + exact ideal_cost _ _ _ _ _ _ _ _ _ member + unfold SpongefishCurrentBCSKnowledge.source + apply PCSBCSAtomicAllocationTrace.recognized_recorded part table _ _ answer block _ (recognized bound) + rw [join_oracle,PCSBCSNativePublicCapture.mixedTrace_actual] + apply mixedTrace_construction iv c valid answer bound + rw [← join_oracle,← PCSBCSChallengeOracle.Atomic.eval_program] + exact member + +end Source + +/-! ## The semantic replay inside the initialized source program -/ + +theorem ideal_bind_parts {Q : Nat} {Seed State R S : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (p : Program R) (k : R → Program S) + (state : State) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (WHIRModeFinal.bind p k)) : + (∀ o ∈ (runIdeal sim ro iv state p remaining cap + (WHIRModeFinal.bind_prefix_counted p k remaining counted)).view.observations, + o ∈ (runIdeal sim ro iv state (WHIRModeFinal.bind p k) remaining cap counted).view.observations) ∧ + ∃ (state' : State) (rest : Nat) (cap' : rest ≤ Q) + (counted' : Counts rest (k (runIdeal sim ro iv state p remaining cap + (WHIRModeFinal.bind_prefix_counted p k remaining counted)).view.result)), + (runIdeal sim ro iv state (WHIRModeFinal.bind p k) remaining cap counted).view.result = + (runIdeal sim ro iv state' _ rest cap' counted').view.result ∧ + ∀ o ∈ (runIdeal sim ro iv state' _ rest cap' counted').view.observations, + o ∈ (runIdeal sim ro iv state (WHIRModeFinal.bind p k) remaining cap counted).view.observations := by + obtain ⟨state',rest,cap',counted',same⟩ := ideal_bind sim ro iv p k state remaining cap counted + rw [same] + exact ⟨fun o h => List.mem_append_left _ h,state',rest,cap',counted',rfl, + fun o h => List.mem_append_right _ h⟩ + +/-- A successful initialized source run contains the semantic replay of its whole call list from the literal initial cursor, answered by the ideal raw oracle, with all of its observations. -/ +theorem afterPrefix_replay {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (tag instanceBytes : List Byte) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (calls : List Call) + (state : State) (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls)) + (data : Data) + (success : (runIdeal sim ro iv state + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls) + remaining cap counted).view.result = some (.ok data)) : + ∃ (session : Digest32) (narg : List Byte) (hints : List (List Byte)) (fin : SemanticCursor), + (runWith (idealAnswer Q iv ro) (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) calls)).result = + .ok fin ∧ fin.data = data ∧ + ∀ o ∈ (runWith (idealAnswer Q iv ro) (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) calls)).observations, + o ∈ (runIdeal sim ro iv state + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram calls) + remaining cap counted).view.observations := by + change (runIdeal sim ro iv state (WHIRModeFinal.bind prefixProgram (fun input => + SpongefishCurrentInitializedMode.program iv tag instanceBytes input.narg input.hints calls)) + remaining cap counted).view.result = _ at success + obtain ⟨_,state₁,rest₁,cap₁,counted₁,result₁,inside₁⟩ := ideal_bind_parts sim ro iv prefixProgram + (fun input => SpongefishCurrentInitializedMode.program iv tag instanceBytes input.narg input.hints calls) + state remaining cap counted + generalize (runIdeal sim ro iv state prefixProgram remaining cap _).view.result = input at * + change _ = (runIdeal sim ro iv state₁ (WHIRModeFinal.bind + (SpongefishCurrentObservedSessionEntry.setupProgram iv tag instanceBytes input.narg input.hints) _) + rest₁ cap₁ counted₁).view.result at result₁ + obtain ⟨_,state₂,rest₂,cap₂,counted₂,result₂,inside₂⟩ := ideal_bind_parts sim ro iv _ _ + state₁ rest₁ cap₁ counted₁ + generalize (runIdeal sim ro iv state₁ + (SpongefishCurrentObservedSessionEntry.setupProgram iv tag instanceBytes input.narg input.hints) + rest₁ cap₁ _).view.result = setup at * + cases setup with + | none => + change _ = (runIdeal sim ro iv state₂ (.done none) rest₂ cap₂ counted₂).view.result at result₂ + rw [result₁,result₂] at success + cases success + | some actual => + change _ = (runIdeal sim ro iv state₂ (WHIRModeFinal.bind (replayProgram + (SpongefishCurrentInitializedMode.initial actual.pending.domain instanceBytes input.narg input.hints) + calls) _) rest₂ cap₂ counted₂).view.result at result₂ + obtain ⟨inside₃,state₃,rest₃,cap₃,counted₃,result₃,_⟩ := ideal_bind_parts sim ro iv _ _ + state₂ rest₂ cap₂ counted₂ + rw [ideal_runWith sim ro iv _ (replay_only _ _)] at inside₃ result₃ + generalize replayEq : (runWith (idealAnswer Q iv ro) (replayProgram + (SpongefishCurrentInitializedMode.initial actual.pending.domain instanceBytes input.narg input.hints) + calls)).result = replayed at * + rw [result₁,result₂,result₃] at success + cases replayed with + | error failure => cases success + | ok fin => + refine ⟨actual.pending.domain,input.narg,input.hints,fin,replayEq,?_,?_⟩ + · simpa [runIdeal,eraseResult] using success + · intro o member + exact inside₁ o (inside₂ o (inside₃ o member)) + +/-! ## Opening packets of the counted current source -/ + +section Packets +open SpongefishCurrentOpeningAcceptance SpongefishCurrentRoundPackets +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-- Static frame shape at the opening start after replaying `pre` from the literal initial cursor: `(boundary,true)` means `boundary` closed frames and a pending nonempty prover run. -/ +def openingShape (instanceBytes : List Byte) (pre : List Call) : Nat × Bool := + frameShape (0,decide (instanceBytes ≠ [])) pre + +theorem frameShape_append (s : Nat × Bool) (xs ys : List Call) : + frameShape s (xs ++ ys) = frameShape (frameShape s xs) ys := by + induction xs generalizing s with + | nil => rfl + | cons call xs ih => cases call <;> exact ih _ + +/-- A call list ending with a positive read leaves a pending prover run, so its static shape is `(boundary,true)` for `boundary := (openingShape instanceBytes pre).1`. -/ +theorem openingShape_ready (instanceBytes : List Byte) (pre pre' : List Call) (kind : WireKind) + (ends : pre = pre' ++ [.read kind]) (positive : kind.codec.size ≠ 0) : + openingShape instanceBytes pre = ((openingShape instanceBytes pre).1,true) := by + unfold openingShape + rw [ends,frameShape_append] + simp [frameShape,positive] + +/-- The events of the opening calls: the suffix of one event per opening call. -/ +def openingEvents (grinding : Fin (cfg).folds.size → Fin 64) (events : List SourceEvent) : + List SourceEvent := + events.drop (events.length - (openingCalls grinding).length) + +theorem close_domain (m : Pending) : (close m).domain = m.domain := by + unfold close; split <;> rfl + +theorem initial_shaped (session : Digest32) (instanceBytes narg : List Byte) + (hints : List (List Byte)) : + Shaped (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints).data.pending + (0,decide (instanceBytes ≠ [])) := by + by_cases empty : instanceBytes = [] <;> + simp [Shaped,SpongefishCurrentInitializedMode.initial,forget, + SpongefishCurrentObservedSessionEntry.cursor,SpongefishPCSRoundFrames.bind,empty] + +/-- Opening draws of the counted current source as exposed round packets, on an arbitrary ideal table. The source is the initialized current program of `pre ++ openingCalls grinding` followed by an arbitrary continuation `k`. If its initialized part returns a successful replay with data `data`, then the `j`-th opening draw has a history with `boundary + j + 1` frames whose output blocks supply its literal drawn bytes, earlier histories are frame prefixes of later ones, and every PCS draw of `q` is a packet with coordinate `q` whose complete answer is recorded in the atomic trace and whose grouped value is the decoded literal drawn bytes. -/ +theorem opening_packets {S : Type} (Q : Nat) (iv : Digest32) + (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) + (tag instanceBytes : List Byte) (pre : List Call) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (k : Option SpongefishCurrentInitializedMode.Result → Program S) + (counted : Counts Q (WHIRModeFinal.bind (SpongefishCurrentInitializedMode.afterPrefix iv tag + instanceBytes prefixProgram (pre ++ openingCalls grinding)) k)) + (shape : openingShape instanceBytes pre = (boundary,true)) + (table : (key : Key p Q iv grinding boundary) → Answer p Q iv grinding boundary key) + (data : Data) + (success : (Sampling.eval table (SpongefishCurrentBCSKnowledge.source + (partition p Q iv grinding boundary) iv + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram + (pre ++ openingCalls grinding)) + (WHIRModeFinal.bind_prefix_counted _ k Q counted))).result = some (.ok data)) : + ∃ histories : List FramedHistory, + histories.length = (openingDraws grinding).length ∧ + (∀ (j : Nat) (h : FramedHistory), histories[j]? = some h → h.frames.length = boundary + j + 1) ∧ + (∀ (i j : Nat) (hi hj : FramedHistory), i ≤ j → histories[i]? = some hi → + histories[j]? = some hj → hi = {hj with frames := hj.frames.take (boundary + i + 1)}) ∧ + (verifierBytes (openingEvents grinding data.events)).length = (openingDraws grinding).length ∧ + (∀ (j : Nat) (h : FramedHistory) (bytes : List Byte), histories[j]? = some h → + (verifierBytes (openingEvents grinding data.events))[j]? = some bytes → + ∃ g, (drawGroups (openingCalls grinding))[j]? = some g ∧ + bytes = (List.range g.bytes).map (fun i => idealAnswer Q iv + (roOf (partition p Q iv grinding boundary) table) ⟨h,.output (i/32)⟩ + ⟨i%32,Nat.mod_lt _ (by decide)⟩)) ∧ + ∀ (j : Nat) (q : Coord p), (openingDraws grinding)[j]? = some (some q) → + ∃ (packet : Packet p Q grinding boundary) (bytes : List Byte), + packet.coord = q ∧ histories[j]? = some packet.history ∧ + (verifierBytes (openingEvents grinding data.events))[j]? = some bytes ∧ + decodeSample packet.coord bytes = + PCSBCSChallengeOracle.grouped packet.coord (table (.inl packet)) ∧ + (⟨.inl packet,table (.inl packet)⟩ : Sigma (Answer p Q iv grinding boundary)) ∈ + (Sampling.execute table (SpongefishCurrentBCSKnowledge.source + (partition p Q iv grinding boundary) iv + (WHIRModeFinal.bind (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes + prefixProgram (pre ++ openingCalls grinding)) k) counted)).2 := by + let part := partition p Q iv grinding boundary + let ro := roOf part table + let ans := idealAnswer Q iv ro + rw [eval_source] at success + obtain ⟨session,narg,hints,fin,replayOk,finData,replayInside⟩ := afterPrefix_replay + (DuplexPublicSimulator.simulator Q) ro iv tag instanceBytes prefixProgram + (pre ++ openingCalls grinding) _ Q (Nat.le_refl Q) _ data success + obtain ⟨oldInside,_⟩ := ideal_bind_parts (DuplexPublicSimulator.simulator Q) ro iv _ k + ⟨seedOf part table,[]⟩ Q (Nat.le_refl Q) counted + have inFinal : ∀ o ∈ (runWith ans (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) + (pre ++ openingCalls grinding))).observations, + o ∈ (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv _ counted)).observations := by + rw [eval_source] + exact fun o h => oldInside o (replayInside o h) + obtain ⟨mid,preOk,openOk,obsSplit⟩ := replay_append ans _ pre (openingCalls grinding) fin replayOk + obtain ⟨midShaped,midGood,midKnown⟩ := replay_shape ans _ pre _ + (initial_shaped session instanceBytes narg hints) (fun _ _ h => by cases h) mid preOk + rw [show frameShape (0,decide (instanceBytes ≠ [])) pre = (boundary,true) from shape] at midShaped + obtain ⟨midFrames,midReady,midZeroed⟩ := midShaped + have midRun : mid.data.pending.run ≠ [] := midReady.mp rfl + obtain ⟨evs,ms,events,evLength,_,msLength,bytesLength,facts⟩ := replay_draws ans mid + (openingCalls grinding) false (by simpa using midRun) midZeroed (scan_opening_calls grinding) + midGood fin openOk + have openEvents : openingEvents grinding data.events = evs := by + rw [← finData,events] + unfold openingEvents + rw [List.length_append,evLength,Nat.add_sub_cancel] + exact List.drop_left + have matched := opening_matches grinding (p := p) + have drawLength : (drawGroups (openingCalls grinding)).length = (openingDraws grinding).length := + matched.length_eq.symm + have factAt : ∀ j m, ms[j]? = some m → ∃ g bytes, (drawGroups (openingCalls grinding))[j]? = some g ∧ + (verifierBytes evs)[j]? = some bytes ∧ + DrawFact ans mid.data.pending.domain mid.data.pending.frames.length mid.cache + fin.data.pending.frames (runWith ans (replayProgram mid (openingCalls grinding))).observations + j g m bytes := by + intro j m found + have within : j < ms.length := (List.getElem?_eq_some_iff.mp found).1 + obtain ⟨g,hg⟩ : ∃ g, (drawGroups (openingCalls grinding))[j]? = some g := + ⟨_,List.getElem?_eq_getElem (by omega)⟩ + obtain ⟨bytes,hb⟩ : ∃ bytes, (verifierBytes evs)[j]? = some bytes := + ⟨_,List.getElem?_eq_getElem (by omega)⟩ + exact ⟨g,bytes,hg,hb,facts j g m bytes hg found hb⟩ + have historyLength : ∀ j m, ms[j]? = some m → + ((close m).core.history.frames).length = boundary + j + 1 := by + intro j m found + obtain ⟨g,bytes,_,_,fact⟩ := factAt j m found + simp only [Pending.core,List.length_map,close_frames m fact.run_ne,List.length_append, + List.length_singleton,fact.frames_eq,midFrames] + refine ⟨ms.map (fun m => (close m).core.history),by simp [msLength,drawLength],?_,?_, + by rw [openEvents,bytesLength,drawLength],?_,?_⟩ + · intro j h found + rw [List.getElem?_map] at found + obtain ⟨m,member,rfl⟩ := Option.map_eq_some_iff.mp found + exact historyLength j m member + · intro i j hi hj order foundI foundJ + rw [List.getElem?_map] at foundI foundJ + obtain ⟨mi,memberI,rfl⟩ := Option.map_eq_some_iff.mp foundI + obtain ⟨mj,memberJ,rfl⟩ := Option.map_eq_some_iff.mp foundJ + obtain ⟨_,_,_,_,factI⟩ := factAt i mi memberI + obtain ⟨_,_,_,_,factJ⟩ := factAt j mj memberJ + have lengthI := historyLength i mi memberI + have lengthJ := historyLength j mj memberJ + simp only [Pending.core,List.length_map] at lengthI lengthJ + have nested : (close mi).frames <+: (close mj).frames := + List.prefix_of_prefix_length_le factI.closed factJ.closed (by omega) + have taken := List.prefix_iff_eq_take.mp nested + rw [lengthI] at taken + simp only [Pending.core,close_domain,factI.domain_eq,factJ.domain_eq,← List.map_take,← taken] + · intro j h bytes found bytesAt + rw [List.getElem?_map] at found + obtain ⟨m,member,rfl⟩ := Option.map_eq_some_iff.mp found + obtain ⟨g,bytes',groupAt,bytesAt',fact⟩ := factAt j m member + rw [openEvents,bytesAt'] at bytesAt + cases bytesAt + refine ⟨g,groupAt,?_⟩ + rw [fact.bytes_eq] + simp only [positions,fact.consumed_eq,Nat.zero_add,List.map_map] + rfl + · intro j q found + obtain ⟨g,groupAt,groupEq⟩ := forall₂_getElem? matched j (some q) found + change g = group q at groupEq + have within : j < ms.length := by + have := (List.getElem?_eq_some_iff.mp groupAt).1 + omega + obtain ⟨m,member⟩ : ∃ m, ms[j]? = some m := ⟨_,List.getElem?_eq_getElem within⟩ + obtain ⟨g',bytes,groupAt',bytesAt,fact⟩ := factAt j m member + rw [groupAt] at groupAt' + cases groupAt' + subst groupEq + have width := openingDraws_width grinding q (List.mem_of_getElem? found) + have groupBytes := group_bytes q width + have seen : Observed ans (runWith ans (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) + (pre ++ openingCalls grinding))).observations (coordinate m 0) := by + rw [obsSplit] + rcases fact.first with cached | observed + · rcases midKnown _ cached with impossible | observed + · exact (impossible rfl).elim + · exact observed_mono ans _ _ _ (fun o h => List.mem_append_left _ h) observed + · exact observed_mono ans _ _ _ (fun o h => List.mem_append_right _ h) observed + obtain ⟨valid0,seenAt⟩ := seen + have bound0 : pathCost (coordinate m 0) ≤ Q := by + have final := inFinal _ seenAt + rw [eval_source] at final + exact ideal_cost _ _ _ _ _ _ _ _ _ final + have bound : ∀ b, pathCost (coordinate m b) ≤ Q := fun b => (coordinate_cost m b).le.trans bound0 + have small : ∀ b : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth q)), b.val < 2^44 := by + intro b + have := b.isLt + have guard := fact.guard + simp only [PCSBCSChallengeOracle.blocks,maxCursor] at this guard + omega + let packet : Packet p Q grinding boundary := + { history := (close m).core.history + coord := q + classified := by + unfold classify + rw [historyLength j m member] + simp [show boundary < boundary + j + 1 by omega, + show boundary + j + 1 - boundary - 1 = j by omega,found] + admissible := fun b => coordinate_admissible m fact.framed b.val (small b) + bounded := fun b => bound b.val } + have blockAnswer : ∀ b : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth q)), + ans (coordinate m b.val) = table (.inl packet) b := by + intro b + have encoded : part.encode ⟨packet,b⟩ = .inr (constructionKey Q iv (coordinate m b.val) (bound b.val)) := + rfl + simp only [ans,idealAnswer,bound b.val,↓reduceDIte,ro,roOf] + rw [← encoded] + exact join_encode part table ⟨packet,b⟩ + refine ⟨packet,bytes,rfl,by simp [member,packet],by rw [openEvents]; exact bytesAt,?_,?_⟩ + · apply decode_grouped + intro i within + rw [fact.bytes_eq] + change i < 24 * PCSBCSRounds.rawWidth q at within + have inGroup : i < (group q).bytes := by omega + simp only [positions,fact.consumed_eq,Nat.zero_add,List.map_map,List.getElem?_map, + List.getElem?_range inGroup,Option.map_some,Function.comp_apply] + exact congrArg some (congrFun (blockAnswer ⟨i/32,by unfold PCSBCSChallengeOracle.blocks; omega⟩) _) + · apply observed_recorded part iv _ counted table (coordinate m 0) valid0 (ans (coordinate m 0)) + (inFinal _ seenAt) ⟨packet,firstBlock packet⟩ + intro bound' + have encoded : part.encode ⟨packet,firstBlock packet⟩ = .inr (constructionKey Q iv (coordinate m 0) bound') := + rfl + rw [← encoded] + exact part.recognize_encode _ + +/-- Every PCS coordinate of the schedule with a positive draw width is an exposed packet of the successful counted current source. -/ +theorem opening_packet_exposed {S : Type} (Q : Nat) (iv : Digest32) + (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) + (tag instanceBytes : List Byte) (pre : List Call) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (k : Option SpongefishCurrentInitializedMode.Result → Program S) + (counted : Counts Q (WHIRModeFinal.bind (SpongefishCurrentInitializedMode.afterPrefix iv tag + instanceBytes prefixProgram (pre ++ openingCalls grinding)) k)) + (shape : openingShape instanceBytes pre = (boundary,true)) + (table : (key : Key p Q iv grinding boundary) → Answer p Q iv grinding boundary key) + (data : Data) + (success : (Sampling.eval table (SpongefishCurrentBCSKnowledge.source + (partition p Q iv grinding boundary) iv + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram + (pre ++ openingCalls grinding)) + (WHIRModeFinal.bind_prefix_counted _ k Q counted))).result = some (.ok data)) + (q : Coord p) (scheduled : q ∈ WHIRHistory.schedule cfg) (width : PCSBCSRounds.rawWidth q ≠ 0) : + ∃ (packet : Packet p Q grinding boundary) (j : Nat) (bytes : List Byte), + packet.coord = q ∧ packet.history.frames.length = boundary + j + 1 ∧ + (verifierBytes (openingEvents grinding data.events))[j]? = some bytes ∧ + decodeSample packet.coord bytes = + PCSBCSChallengeOracle.grouped packet.coord (table (.inl packet)) ∧ + (⟨.inl packet,table (.inl packet)⟩ : Sigma (Answer p Q iv grinding boundary)) ∈ + (Sampling.execute table (SpongefishCurrentBCSKnowledge.source + (partition p Q iv grinding boundary) iv + (WHIRModeFinal.bind (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes + prefixProgram (pre ++ openingCalls grinding)) k) counted)).2 := by + obtain ⟨j,found⟩ := openingDraws_complete grinding q scheduled width + obtain ⟨histories,_,frames,_,_,_,packets⟩ := opening_packets Q iv grinding boundary tag instanceBytes + pre prefixProgram k counted shape table data success + obtain ⟨packet,bytes,coord,history,bytesAt,value,recorded⟩ := packets j q found + exact ⟨packet,j,bytes,coord,frames j _ history,bytesAt,value,recorded⟩ + +end Packets + +#print axioms ideal_runWith +#print axioms ideal_bind +#print axioms replay_shape +#print axioms replay_append +#print axioms replay_draws +#print axioms scan_opening_calls +#print axioms opening_matches +#print axioms decode_grouped +#print axioms observed_recorded +#print axioms afterPrefix_replay +#print axioms opening_packets +#print axioms opening_packet_exposed +#print axioms source_bind +#print axioms openingShape_ready + +end Whir.SpongefishCurrentOpeningPackets diff --git a/verification/whir/Whir/SpongefishCurrentOpeningProgram.lean b/verification/whir/Whir/SpongefishCurrentOpeningProgram.lean new file mode 100644 index 000000000..28d0d4aa0 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentOpeningProgram.lean @@ -0,0 +1,1321 @@ +import Whir.SpongefishCurrentSourceJoinProbability +import Whir.PrunedMerkleCoverage +import Whir.SpongefishCurrentReplayProvenance +import Whir.PCSBCSConstructionReplayTrace + +/-! Current #607 opening walk inside the counted source program. The replay of the static call list records exactly one `SourceEvent` per call, both in the actual cursor replay and in the semantic mode replay under arbitrary answers. The opening walk re-reads the opening segment of those events exactly like `SpongefishCurrentOpeningAcceptance.run` and authenticates each query batch with the existing whole-hash Merkle program. The full source program runs the old counted source program and then this walk as public verification hashing, so its real run returns the native `Collected` and every hashed opening input is in the program's primitive log. -/ +namespace Whir.SpongefishCurrentOpeningProgram +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentModeQueries +open SpongefishCurrentAcceptedJoin SpongefishCurrentOpeningAcceptance +set_option autoImplicit false + +/-! ## One source event per replayed call -/ + +/-- The event appended by one successful call. -/ +def CallEvent : Call → SourceEvent → Prop + | .read kind, e => ∃ value : kind.Value, e = .prover kind (kind.codec.bytes value) + | .draw g, e => ∃ bytes : List Byte, bytes.length = g.bytes ∧ e = .verifier bytes + | .hint, e => ∃ bytes : List Byte, e = .hint bytes + +theorem read_events (c : Compression) (cur next : Cursor) (kind : WireKind) (value : kind.Value) + (ok : SpongefishPCSRoundFrames.read c cur kind = some (next,value)) : + next.events = cur.events ++ [.prover kind (kind.codec.bytes value)] := by + unfold SpongefishPCSRoundFrames.read at ok + cases hp : kind.codec.parse cur.narg with + | none => simp [hp] at ok + | some pair => + rcases pair with ⟨v,rest⟩ + simp only [hp] at ok + rcases ok with ⟨rfl,rfl⟩ + rfl + +theorem squeezeGroup_events (c : Compression) (cur next : Cursor) (g : Group) (bytes : List Byte) + (ok : squeezeGroup c cur g = .ok (next,bytes)) : + next.events = cur.events ++ [.verifier bytes] ∧ bytes.length = g.bytes := by + cases hs : squeeze c cur.state g.bytes with + | error e => simp [squeezeGroup,hs] at ok + | ok pair => + rcases pair with ⟨s,out⟩ + simp only [squeezeGroup,hs] at ok + cases ok + exact ⟨rfl,(squeeze_exact_cursor c cur.state s g.bytes out hs).2⟩ + +theorem takeHint_events (cur next : Cursor) (ok : takeHint cur = some next) : + ∃ bytes, cur.hints.head? = some bytes ∧ next.events = cur.events ++ [.hint bytes] := by + unfold takeHint at ok + cases hh : cur.hints with + | nil => simp [hh] at ok + | cons bytes rest => + simp only [hh,Option.some.injEq] at ok + subst ok + exact ⟨bytes,rfl,rfl⟩ + +theorem actualCall_events (c : Compression) (cur next : Cursor) (call : Call) + (ok : SpongefishCurrentPrimitiveEventCompiler.actualCall c cur call = .ok next) : + ∃ e, next.events = cur.events ++ [e] ∧ CallEvent call e := by + cases call with + | read kind => + simp only [SpongefishCurrentPrimitiveEventCompiler.actualCall] at ok + cases hr : SpongefishPCSRoundFrames.read c cur kind with + | none => simp [hr] at ok + | some pair => + rcases pair with ⟨mid,value⟩ + simp only [hr,Except.ok.injEq] at ok + subst ok + exact ⟨_,read_events c cur mid kind value hr,value,rfl⟩ + | draw g => + simp only [SpongefishCurrentPrimitiveEventCompiler.actualCall] at ok + cases hs : squeezeGroup c cur g with + | error e => simp [hs] at ok + | ok pair => + rcases pair with ⟨mid,bytes⟩ + simp only [hs,Except.ok.injEq] at ok + subst ok + obtain ⟨events,length⟩ := squeezeGroup_events c cur mid g bytes hs + exact ⟨_,events,bytes,length,rfl⟩ + | hint => + simp only [SpongefishCurrentPrimitiveEventCompiler.actualCall] at ok + cases ht : takeHint cur with + | none => simp [ht] at ok + | some mid => + simp only [ht,Except.ok.injEq] at ok + subst ok + obtain ⟨bytes,_,events⟩ := takeHint_events cur mid ht + exact ⟨_,events,bytes,rfl⟩ + +/-- An accepted actual replay appends exactly one event per call, of the call's shape: reads append their canonical prover bytes, draws their squeezed bytes of the group's length, hints their hint bytes. -/ +theorem actualReplay_events (c : Compression) : + ∀ (calls : List Call) (cur next : Cursor), + SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur calls = .ok next → + ∃ evs, next.events = cur.events ++ evs ∧ List.Forall₂ CallEvent calls evs + | [], cur, next, ok => by + simp only [SpongefishCurrentPrimitiveEventCompiler.actualReplay,Except.ok.injEq] at ok + subst ok + exact ⟨[],by simp,.nil⟩ + | call :: calls, cur, next, ok => by + simp only [SpongefishCurrentPrimitiveEventCompiler.actualReplay] at ok + cases hc : SpongefishCurrentPrimitiveEventCompiler.actualCall c cur call with + | error e => simp [hc] at ok + | ok mid => + simp only [hc] at ok + obtain ⟨e,first,shape⟩ := actualCall_events c cur mid call hc + obtain ⟨evs,rest,shapes⟩ := actualReplay_events c calls mid next ok + exact ⟨e :: evs,by rw [rest,first,List.append_assoc]; rfl,.cons shape shapes⟩ + +theorem actualReplay_events_length (c : Compression) (calls : List Call) (cur next : Cursor) + (ok : SpongefishCurrentPrimitiveEventCompiler.actualReplay c cur calls = .ok next) : + ∃ evs, next.events = cur.events ++ evs ∧ evs.length = calls.length := by + obtain ⟨evs,events,shapes⟩ := actualReplay_events c calls cur next ok + exact ⟨evs,events,shapes.length_eq.symm⟩ + +/-! ## The same count in the semantic replay under arbitrary answers -/ + +open SpongefishCurrentMixedModeCompiler in +theorem collect_length (m : Pending) (positions : List Nat) + (valid : ∀ p ∈ positions, DuplexEncoding.Admissible (coordinate m (p/32))) + (cache : Cache) (trace : List Observation) (result : Cache × List Byte) + (run : PublicMerkleProgram.Runs (collect m positions valid cache) trace result) : + result.2.length = positions.length := by + induction positions generalizing cache trace result with + | nil => + cases run + rfl + | cons p ps ih => + simp only [collect] at run + obtain ⟨_,⟨next,d⟩,after,_,_,rest⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp run + obtain ⟨_,⟨last,bs⟩,_,_,tail,final⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp rest + cases final + simp [ih _ _ _ _ tail] + +open SpongefishCurrentMixedModeCompiler in +/-- Every accepted semantic replay, under every sequence of construction answers (in particular every ideal simulator), appends exactly one event per call with the call's shape. -/ +theorem replayProgram_events : + ∀ (calls : List Call) (cur next : SemanticCursor) (trace : List Observation), + PublicMerkleProgram.Runs (replayProgram cur calls) trace (.ok next) → + ∃ evs, next.data.events = cur.data.events ++ evs ∧ List.Forall₂ CallEvent calls evs + | [], cur, next, trace, run => by + simp only [replayProgram] at run + cases run + exact ⟨[],by simp,.nil⟩ + | .read kind :: calls, cur, next, trace, run => by + simp only [replayProgram] at run + cases hp : kind.codec.parse cur.data.narg with + | none => + simp only [hp] at run + cases run + | some pair => + rcases pair with ⟨value,rest⟩ + simp only [hp] at run + obtain ⟨evs,events,shapes⟩ := replayProgram_events calls _ next trace run + refine ⟨.prover kind (kind.codec.bytes value) :: evs,?_,.cons ⟨value,rfl⟩ shapes⟩ + rw [events] + simp [readNext,boundData] + | .hint :: calls, cur, next, trace, run => by + simp only [replayProgram] at run + cases hh : cur.data.hints with + | nil => + simp only [hh] at run + cases run + | cons bytes rest => + simp only [hh] at run + obtain ⟨evs,events,shapes⟩ := replayProgram_events calls _ next trace run + refine ⟨.hint bytes :: evs,?_,.cons ⟨bytes,rfl⟩ shapes⟩ + rw [events] + simp [hintNext] + | .draw g :: calls, cur, next, trace, run => by + simp only [replayProgram] at run + split at run + next zero => + obtain ⟨evs,events,shapes⟩ := replayProgram_events calls _ next trace run + refine ⟨.verifier [] :: evs,?_,.cons ⟨[],by simp [zero],rfl⟩ shapes⟩ + rw [events] + simp + next => + split at run + next guard => + obtain ⟨_,⟨cache,bytes⟩,after,_,collected,rest⟩ := + (PublicMerkleProgram.Runs.bind_iff _ _).mp run + have length := collect_length _ _ _ _ _ _ collected + obtain ⟨evs,events,shapes⟩ := replayProgram_events calls _ next after rest + refine ⟨.verifier bytes :: evs,?_,.cons ⟨bytes,?_,rfl⟩ shapes⟩ + · rw [events] + simp [drawn] + · simpa [positions] using length + next => cases run + +theorem replayProgram_ideal_events {Q : Nat} {Seed State : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (state : State) + (cur : SpongefishCurrentMixedModeCompiler.SemanticCursor) (calls : List Call) + (remaining : Nat) (cap : remaining ≤ Q) + (counted : Counts remaining (SpongefishCurrentMixedModeCompiler.replayProgram cur calls)) + (next : SpongefishCurrentMixedModeCompiler.SemanticCursor) + (ok : (runIdeal sim ro iv state (SpongefishCurrentMixedModeCompiler.replayProgram cur calls) + remaining cap counted).view.result = .ok next) : + ∃ evs, next.data.events = cur.data.events ++ evs ∧ List.Forall₂ CallEvent calls evs := by + have run := PublicMerkleProgram.runIdeal_runs sim ro iv state _ remaining cap counted + rw [ok] at run + exact replayProgram_events calls cur next _ run + +/-- The old counted source program, under arbitrary answers: an accepted replay result carries the constructor's instance event followed by exactly one event per call of the static call list. -/ +theorem program_events {p : ParameterBounds.Profile} (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (trace : List Observation) + (data : SpongefishCurrentMixedModeCompiler.Data) + (run : PublicMerkleProgram.Runs (SpongefishCurrentSourceJoinProbability.program iv tag + instanceBytes layout before payloadCalls messages grinding prefixProgram) trace (some (.ok data))) : + ∃ evs, data.events = .publicBytes instanceBytes :: evs ∧ + List.Forall₂ CallEvent + (SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding) evs := by + unfold SpongefishCurrentSourceJoinProbability.program SpongefishCurrentInitializedMode.afterPrefix at run + obtain ⟨_,input,_,_,_,rest⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp run + unfold SpongefishCurrentInitializedMode.program at rest + obtain ⟨_,result,_,_,_,rest⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp rest + cases result with + | none => cases rest + | some actual => + obtain ⟨_,replayed,_,_,replayRun,final⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp rest + cases replayed with + | error failure => cases final + | ok cur => + cases final + obtain ⟨evs,events,shapes⟩ := replayProgram_events _ _ cur _ replayRun + exact ⟨evs,events,shapes⟩ + +/-! ## The opening walk over recorded events -/ + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +abbrev Decoder := List Nat → Nat → List Byte → Option MerkleTransport.PrunedMerklePaths + +open PrunedMerkleProgram + +/-- A prover event decoded with the expected codec. -/ +def takeProver (kind : WireKind) : List SourceEvent → Option (kind.Value × List SourceEvent) + | .prover _ bytes :: rest => (kind.codec.parse bytes).map fun parsed => (parsed.1,rest) + | _ => none + +def takeVerifier : List SourceEvent → Option (List Byte × List SourceEvent) + | .verifier bytes :: rest => some (bytes,rest) + | _ => none + +def takeHintBytes : List SourceEvent → Option (List Byte × List SourceEvent) + | .hint bytes :: rest => some (bytes,rest) + | _ => none + +def takeMessage (evs : List SourceEvent) : Option (Protocol.Message E × List SourceEvent) := + (takeProver (.vector 2) evs).map fun parsed => (⟨parsed.1 0,parsed.1 1⟩,parsed.2) + +/-- Query proof of work read from its challenge and nonce events. -/ +def powWalk (grinding : Fin (cfg).folds.size → Fin 64) (evs : List SourceEvent) + (col : Collected p) : Coord p → Option (List SourceEvent × Collected p) + | .query i => + if (grinding i).val = 0 then some (evs,col) else do + let (bytes,rest) ← takeVerifier evs + let (nonce,after) ← takeProver .nonce rest + pure (after,{col with pows := col.pows ++ + [⟨i,grinding i,fun k => bytes[k.val]?.getD 0,nonce⟩]}) + | .initial => some (evs,col) + | .fold _ _ => some (evs,col) + | .ood _ _ => some (evs,col) + | .tail _ => some (evs,col) + +def drawWalk (evs : List SourceEvent) (q : Coord p) : + Option (List SourceEvent × PCSBCSRounds.Raw q) := + if PCSBCSRounds.rawWidth q = 0 then some (evs,decodeSample q []) else + (takeVerifier evs).map fun drawn => (drawn.2,decodeSample q drawn.1) + +/-- Replies that hash nothing, in native wire order. -/ +def replyPure (evs : List SourceEvent) (col : Collected p) : Coord p → Option (List SourceEvent × Collected p) + | .initial => do + let (m,rest) ← takeMessage evs + pure (rest,{col with replies := col.replies.push (.initial m)}) + | .fold i j => do + let (m,rest) ← takeMessage evs + if isLastFold i j then + if i.val + 1 < (cfg).folds.size then do + let (root,after) ← takeProver .root rest + let replies := col.replies.push (.fold m (some #[]) #[]) + pure (after,{col with replies := replies, roots := col.roots.push root}) + else do + let (residual,after) ← takeProver (.vector (2^CausalGame.remaining cfg i.val)) rest + pure (after,{col with replies := col.replies.push (.fold m none (Array.ofFn residual))}) + else pure (rest,{col with replies := col.replies.push (.fold m none #[])}) + | .ood _ _ => do + let (y,rest) ← takeProver .scalar evs + let (m,after) ← takeMessage rest + pure (after,{col with replies := col.replies.push (.ood ⟨y,m⟩)}) + | .query _ => none + | .tail j => + if isVisibleTail j then do + let (m,rest) ← takeMessage evs + pure (rest,{col with replies := col.replies.push (.tail m)}) + else some (evs,col) + +def rowWords (lanes : Nat) (i : Fin (cfg).folds.size) : Nat := + if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val + +/-- The whole-hash version of `SpongefishCurrentOpeningAcceptance.openQuery`: the same pruned Merkle plan and the same row decoder. -/ +def openProgram (lanes : Nat) (i : Fin (cfg).folds.size) (root : Digest32) + (proof : MerkleTransport.PrunedMerklePaths) (x : CausalProbability.Sample (.query i)) : + HashProgram (Option WHIRPhysicalVerifier.Opened) := + (plan proof root (ParameterBounds.length cfg i.val) (WHIRPhysicalVerifier.queryIndices p i x) + (rowWords lanes i) (WHIRPhysicalVerifier.leafWords p i.val)).map + (WHIRPhysicalVerifier.finishRows (i.val == 0) (rowWords lanes i) (WHIRPhysicalVerifier.leafWords p i.val)) + +/-- Query reply: hint event, decoded proof, authenticated rows, prover message. -/ +def replyQuery (decode : Decoder) (lanes : Nat) (evs : List SourceEvent) (col : Collected p) + (i : Fin (cfg).folds.size) : HashProgram (Option (List SourceEvent × Collected p)) := + match takeHintBytes evs with + | none => .done none + | some (hint,rest) => + match decode (WHIRPhysicalVerifier.queryIndices p i (CausalProbability.get (.query i) col.tape)) + (rowWords lanes i) hint with + | none => .done none + | some proof => + match col.roots[i.val]? with + | none => .done none + | some root => + (openProgram lanes i root proof (CausalProbability.get (.query i) col.tape)).map fun result => + match result with + | none => none + | some opened => (takeMessage rest).map fun read => + let replies := col.replies.push (.query opened.rows read.1) + (read.2,{col with replies := replies, openings := col.openings ++ [⟨i,root,hint,proof,opened⟩]}) + +def replyWalk (decode : Decoder) (lanes : Nat) (evs : List SourceEvent) (col : Collected p) : + Coord p → HashProgram (Option (List SourceEvent × Collected p)) + | .query i => replyQuery decode lanes evs col i + | .initial => .done (replyPure evs col .initial) + | .fold i j => .done (replyPure evs col (.fold i j)) + | .ood i j => .done (replyPure evs col (.ood i j)) + | .tail j => .done (replyPure evs col (.tail j)) + +def stepWalk (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (state : List SourceEvent × Collected p) (q : Coord p) : + HashProgram (Option (List SourceEvent × Collected p)) := + match powWalk grinding state.1 state.2 q with + | none => .done none + | some (evs,col) => + match drawWalk evs q with + | none => .done none + | some (rest,x) => replyWalk decode lanes rest (recordSample col q x) q + +def walkFrom (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + List (Coord p) → List SourceEvent × Collected p → + HashProgram (Option (List SourceEvent × Collected p)) + | [], state => .done (some state) + | q :: qs, state => (stepWalk decode grinding lanes state q).bind fun result => + match result with + | none => .done none + | some next => walkFrom decode grinding lanes qs next + +/-- The opening walk: the native opening schedule over recorded events, from the commitment root, with every query batch authenticated by whole-hash calls. -/ +def walk (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (root : Digest32) (evs : List SourceEvent) : HashProgram (Option (Collected p)) := + (walkFrom decode grinding lanes (WHIRHistory.schedule cfg) (evs,Collected.start root)).map + (Option.map Prod.snd) + +/-! ## Lowering is the existing Merkle row program -/ + +theorem program_bind_assoc {R S T : Type} (a : Program R) (f : R → Program S) (g : S → Program T) : + WHIRModeFinal.bind (WHIRModeFinal.bind a f) g = WHIRModeFinal.bind a (fun r => WHIRModeFinal.bind (f r) g) := by + induction a with + | done r => rfl + | ask q next ih => simp only [WHIRModeFinal.bind,ih] + +theorem lower_map {R S : Type} (f : R → S) (h : HashProgram R) : + (h.map f).lower = WHIRModeFinal.bind h.lower (fun r => .done (f r)) := by + induction h with + | done r => rfl + | hash bytes next ih => + simp only [HashProgram.map,HashProgram.bind,HashProgram.lower,program_bind_assoc] at ih ⊢ + simp only [ih] + +/-- The lowered query authentication is literally `WHIRPhysicalVerifier.openQuery`. -/ +theorem openProgram_lower (lanes : Nat) (i : Fin (cfg).folds.size) (root : Digest32) + (proof : MerkleTransport.PrunedMerklePaths) (x : CausalProbability.Sample (.query i)) : + (openProgram lanes i root proof x).lower = WHIRPhysicalVerifier.openQuery p i lanes proof root x := by + rw [openProgram,lower_map] + rfl + +theorem openProgram_eval (C : PrimitiveOracle) (lanes : Nat) (i : Fin (cfg).folds.size) (root : Digest32) + (proof : MerkleTransport.PrunedMerklePaths) (x : CausalProbability.Sample (.query i)) : + HashProgram.eval (PublicMerkleLog.hash C) (openProgram lanes i root proof x) = + openQuery C lanes i root proof x := by + rw [openProgram,HashProgram.eval_map,plan_eval] + rfl + +/-! ## The walk evaluates exactly like the native opening -/ + +theorem parse_bytes {A : Type} (codec : Codec A) (a : A) : codec.parse (codec.bytes a) = some (a,[]) := by + simpa using Codec.parse_append codec a [] + +theorem readMessage_events (C : PrimitiveOracle) (cur next : Cursor) (m : Protocol.Message E) + (ok : readMessage C cur = some (next,m)) : + ∃ xs : Fin 2 → E, next.events = cur.events ++ [.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs)] ∧ + m = ⟨xs 0,xs 1⟩ := by + unfold readMessage at ok + split at ok + · cases ok + next mid xs h => + cases ok + exact ⟨xs,read_events _ _ _ _ _ h,rfl⟩ + +theorem powWalk_native (C : PrimitiveOracle) (grinding : Fin (cfg).folds.size → Fin 64) + (cur next : Cursor) (col col' : Collected p) (q : Coord p) + (ok : powStep C grinding cur col q = some (next,col')) : + ∃ evs, next.events = cur.events ++ evs ∧ + ∀ suffix, powWalk grinding (evs ++ suffix) col q = some (suffix,col') := by + cases q with + | query i => + simp only [powStep] at ok + split at ok + next zero => + cases ok + exact ⟨[],by simp,fun suffix => by simp [powWalk,zero]⟩ + next positive => + split at ok + · cases ok + next challenged bytes squeezed => + split at ok + · cases ok + next after nonce readOk => + cases ok + obtain ⟨first,_⟩ := squeezeGroup_events _ _ _ _ _ squeezed + have second := read_events _ _ _ _ _ readOk + refine ⟨[.verifier bytes,.prover .nonce (WireKind.nonce.codec.bytes nonce)],?_,fun suffix => ?_⟩ + · rw [second,first] + simp + · simp [powWalk,positive,takeVerifier,takeProver,parse_bytes] + | initial => cases ok; exact ⟨[],by simp,fun _ => rfl⟩ + | fold i j => cases ok; exact ⟨[],by simp,fun _ => rfl⟩ + | ood i j => cases ok; exact ⟨[],by simp,fun _ => rfl⟩ + | tail j => cases ok; exact ⟨[],by simp,fun _ => rfl⟩ + +theorem drawWalk_native (C : PrimitiveOracle) (cur next : Cursor) (q : Coord p) + (x : PCSBCSRounds.Raw q) (ok : drawStep C cur q = some (next,x)) : + ∃ evs, next.events = cur.events ++ evs ∧ ∀ suffix, drawWalk (evs ++ suffix) q = some (suffix,x) := by + unfold drawStep at ok + split at ok + next zero => + cases ok + exact ⟨[],by simp,fun suffix => by simp [drawWalk,zero]⟩ + next positive => + split at ok + · cases ok + next after bytes squeezed => + cases ok + obtain ⟨events,_⟩ := squeezeGroup_events _ _ _ _ _ squeezed + exact ⟨[.verifier bytes],events,fun suffix => by simp [drawWalk,positive,takeVerifier]⟩ + +theorem replyWalk_native (C : PrimitiveOracle) (decode : Decoder) (lanes : Nat) + (cur next : Cursor) (col col' : Collected p) (q : Coord p) + (ok : replyStep C decode lanes cur col q = some (next,col')) : + ∃ evs, next.events = cur.events ++ evs ∧ ∀ suffix, + HashProgram.eval (PublicMerkleLog.hash C) (replyWalk decode lanes (evs ++ suffix) col q) = + some (suffix,col') := by + cases q with + | initial => + simp only [replyStep] at ok + obtain ⟨⟨mid,m⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + obtain ⟨xs,events,rfl⟩ := readMessage_events C _ _ _ first + exact ⟨_,events,fun suffix => by simp [replyWalk,replyPure,HashProgram.eval,takeMessage,takeProver,parse_bytes]⟩ + | fold i j => + simp only [replyStep] at ok + obtain ⟨⟨mid,m⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨xs,events,rfl⟩ := readMessage_events C _ _ _ first + split at ok + next last => + split at ok + next more => + obtain ⟨⟨after,root⟩,rootRead,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + have second := read_events _ _ _ _ _ rootRead + refine ⟨[.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs), + .prover .root (WireKind.root.codec.bytes root)],?_,fun suffix => ?_⟩ + · rw [second,events] + simp + · simp [replyWalk,replyPure,HashProgram.eval,last,more,takeMessage,takeProver,parse_bytes] + next final => + obtain ⟨⟨after,residual⟩,residualRead,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + have second := read_events _ _ _ _ _ residualRead + refine ⟨[.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs), + .prover (.vector (2^CausalGame.remaining cfg i.val)) + ((WireKind.vector (2^CausalGame.remaining cfg i.val)).codec.bytes residual)],?_, + fun suffix => ?_⟩ + · rw [second,events] + simp + · simp [replyWalk,replyPure,HashProgram.eval,last,final,takeMessage,takeProver,parse_bytes] + next notLast => + cases ok + exact ⟨_,events,fun suffix => by + simp [replyWalk,replyPure,HashProgram.eval,notLast,takeMessage,takeProver,parse_bytes]⟩ + | ood i j => + simp only [replyStep] at ok + obtain ⟨⟨mid,y⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨after,m⟩,second,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + have firstEvents := read_events _ _ _ _ _ first + obtain ⟨xs,secondEvents,rfl⟩ := readMessage_events C _ _ _ second + refine ⟨[.prover .scalar (WireKind.scalar.codec.bytes y), + .prover (.vector 2) ((WireKind.vector 2).codec.bytes xs)],?_,fun suffix => ?_⟩ + · rw [secondEvents,firstEvents] + simp + · simp [replyWalk,replyPure,HashProgram.eval,takeMessage,takeProver,parse_bytes] + | query i => + simp only [replyStep] at ok + obtain ⟨hint,headEq,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨hinted,taken,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨proof,decoded,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨root,rootAt,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨opened,openOk,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨after,m⟩,second,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + obtain ⟨bytes,head,firstEvents⟩ := takeHint_events _ _ taken + rw [headEq] at head + cases head + obtain ⟨xs,secondEvents,rfl⟩ := readMessage_events C _ _ _ second + have decoded' : decode (WHIRPhysicalVerifier.queryIndices p i + (CausalProbability.get (.query i) col.tape)) (rowWords lanes i) hint = some proof := decoded + refine ⟨[.hint hint,.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs)],?_,fun suffix => ?_⟩ + · rw [secondEvents,firstEvents] + simp + · simp [replyWalk,replyQuery,takeHintBytes,decoded',rootAt,HashProgram.eval_map,openProgram_eval,openOk, + takeMessage,takeProver,parse_bytes] + | tail j => + change (if isVisibleTail j then (do + let (next,m) ← readMessage C cur + pure (next,{col with replies := col.replies.push (.tail m)})) else some (cur,col)) = + some (next,col') at ok + split at ok + next visible => + obtain ⟨⟨after,m⟩,first,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + obtain ⟨xs,events,rfl⟩ := readMessage_events C _ _ _ first + exact ⟨_,events,fun suffix => by + simp [replyWalk,replyPure,HashProgram.eval,visible,takeMessage,takeProver,parse_bytes]⟩ + next hidden => + cases ok + exact ⟨[],by simp,fun suffix => by simp [replyWalk,replyPure,HashProgram.eval,hidden]⟩ + +theorem stepWalk_native (C : PrimitiveOracle) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (state next : Cursor × Collected p) (q : Coord p) + (ok : step C decode grinding lanes state q = some next) : + ∃ evs, next.1.events = state.1.events ++ evs ∧ ∀ suffix, + HashProgram.eval (PublicMerkleLog.hash C) (stepWalk decode grinding lanes (evs ++ suffix,state.2) q) = + some (suffix,next.2) := by + unfold step at ok + obtain ⟨⟨powed,col⟩,powOk,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨drawn,x⟩,drawOk,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨first,firstEvents,firstWalk⟩ := powWalk_native C grinding _ _ _ _ q powOk + obtain ⟨second,secondEvents,secondWalk⟩ := drawWalk_native C _ _ q x drawOk + obtain ⟨third,thirdEvents,thirdWalk⟩ := replyWalk_native C decode lanes _ next.1 _ next.2 q ok + refine ⟨first ++ second ++ third,?_,fun suffix => ?_⟩ + · rw [thirdEvents,secondEvents,firstEvents] + simp + · simp only [stepWalk,List.append_assoc,firstWalk,secondWalk] + exact thirdWalk suffix + +theorem walkFrom_native (C : PrimitiveOracle) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (qs : List (Coord p)) (state final : Cursor × Collected p), + run C decode grinding lanes qs state = some final → + ∃ evs, final.1.events = state.1.events ++ evs ∧ ∀ suffix, + HashProgram.eval (PublicMerkleLog.hash C) (walkFrom decode grinding lanes qs (evs ++ suffix,state.2)) = + some (suffix,final.2) + | [], state, final, ok => by + simp only [run,Option.some.injEq] at ok + subst ok + exact ⟨[],by simp,fun suffix => by simp [walkFrom,HashProgram.eval]⟩ + | q :: qs, state, final, ok => by + simp only [run] at ok + obtain ⟨mid,first,rest⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨front,frontEvents,frontWalk⟩ := stepWalk_native C decode grinding lanes state mid q first + obtain ⟨back,backEvents,backWalk⟩ := walkFrom_native C decode grinding lanes qs mid final rest + refine ⟨front ++ back,by rw [backEvents,frontEvents,List.append_assoc],fun suffix => ?_⟩ + simp only [walkFrom,HashProgram.eval_bind,List.append_assoc,frontWalk] + exact backWalk suffix + +/-- The native accepted opening is the pure evaluation of the walk on its own recorded events, with the ordinary Merkle hash. -/ +theorem walk_native (C : PrimitiveOracle) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (cur final : Cursor) (root : Digest32) + (col : Collected p) + (ran : run C decode grinding lanes (WHIRHistory.schedule cfg) (cur,Collected.start root) = + some (final,col)) : + ∃ evs, final.events = cur.events ++ evs ∧ + HashProgram.eval (PublicMerkleLog.hash C) (walk decode grinding lanes root evs) = some col := by + obtain ⟨evs,events,walked⟩ := walkFrom_native C decode grinding lanes _ _ _ ran + refine ⟨evs,events,?_⟩ + have closed := walked [] + simp only [List.append_nil] at closed + simp [walk,HashProgram.eval_map,closed] + +/-! ## Every returned opening was authenticated by the walk's own hash calls -/ + +/-- A query opening whose proof opens at its root with the level geometry, and every hashed input of whose opened paths is among `calls`. -/ +def Authenticated (H : MerkleTransport.Primitive) (o : QueryOpening p) (calls : List (List Byte)) : Prop := + (∃ queries width, o.proof.open H o.root (ParameterBounds.length cfg o.level.val) queries width + (WHIRPhysicalVerifier.leafWords p o.level.val) = some o.opened.paths) ∧ + ∀ path ∈ o.opened.paths, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing H), bytes ∈ calls + +theorem Authenticated.mono {H : MerkleTransport.Primitive} {o : QueryOpening p} {a b : List (List Byte)} + (h : Authenticated H o a) (sub : ∀ bytes ∈ a, bytes ∈ b) : Authenticated H o b := + ⟨h.1,fun path member bytes input => sub bytes (h.2 path member bytes input)⟩ + +theorem powWalk_openings (grinding : Fin (cfg).folds.size → Fin 64) (evs evs' : List SourceEvent) + (col col' : Collected p) (q : Coord p) (ok : powWalk grinding evs col q = some (evs',col')) : + col'.openings = col.openings := by + cases q with + | query i => + simp only [powWalk] at ok + split at ok + · cases ok; rfl + · obtain ⟨⟨bytes,rest⟩,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨nonce,after⟩,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + | initial => cases ok; rfl + | fold i j => cases ok; rfl + | ood i j => cases ok; rfl + | tail j => cases ok; rfl + +theorem recordSample_openings (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) : + (recordSample col q x).openings = col.openings := by + cases q <;> rfl + +theorem replyPure_openings (evs evs' : List SourceEvent) (col col' : Collected p) (q : Coord p) + (ok : replyPure evs col q = some (evs',col')) : col'.openings = col.openings := by + cases q with + | initial => + simp only [replyPure] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + | fold i j => + simp only [replyPure] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + split at ok + · split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + · cases ok; rfl + | ood i j => + simp only [replyPure] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + | query i => cases ok + | tail j => + simp only [replyPure] at ok + split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok; rfl + · cases ok; rfl + +theorem replyQuery_openings (H : MerkleTransport.Primitive) (decode : Decoder) (lanes : Nat) + (evs evs' : List SourceEvent) (col col' : Collected p) (i : Fin (cfg).folds.size) + (ok : HashProgram.eval H (replyQuery decode lanes evs col i) = some (evs',col')) : + ∀ o ∈ col'.openings, o ∈ col.openings ∨ + Authenticated H o (HashProgram.calls H (replyQuery decode lanes evs col i)) := by + cases hh : takeHintBytes evs with + | none => simp [replyQuery,hh,HashProgram.eval] at ok + | some hinted => + obtain ⟨hint,rest⟩ := hinted + cases hd : decode (WHIRPhysicalVerifier.queryIndices p i (CausalProbability.get (.query i) col.tape)) + (rowWords lanes i) hint with + | none => simp [replyQuery,hh,hd,HashProgram.eval] at ok + | some proof => + cases hr : col.roots[i.val]? with + | none => simp [replyQuery,hh,hd,hr,HashProgram.eval] at ok + | some root => + simp only [replyQuery,hh,hd,hr,HashProgram.eval_map] at ok ⊢ + rw [HashProgram.calls_map] + cases ho : HashProgram.eval H (openProgram lanes i root proof (CausalProbability.get (.query i) col.tape)) with + | none => simp [ho] at ok + | some opened => + simp only [ho] at ok + obtain ⟨read,_,ok⟩ := Option.map_eq_some_iff.mp ok + cases ok + intro o member + rcases List.mem_append.mp member with old | new + · exact .inl old + · right + rw [List.mem_singleton] at new + subst new + rw [openProgram,HashProgram.eval_map,plan_eval] at ho + unfold WHIRPhysicalVerifier.finishRows at ho + obtain ⟨paths,opens,decoded⟩ := Option.bind_eq_some_iff.mp ho + obtain ⟨rows,_,same⟩ := Option.map_eq_some_iff.mp decoded + subst same + refine ⟨⟨_,_,opens⟩,fun path member bytes input => ?_⟩ + unfold openProgram + rw [HashProgram.calls_map] + exact plan_opening_inputs H proof root _ _ _ _ paths opens path member bytes input + +theorem stepWalk_openings (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (state final : List SourceEvent × Collected p) (q : Coord p) + (ok : HashProgram.eval H (stepWalk decode grinding lanes state q) = some final) : + ∀ o ∈ final.2.openings, o ∈ state.2.openings ∨ + Authenticated H o (HashProgram.calls H (stepWalk decode grinding lanes state q)) := by + cases hp : powWalk grinding state.1 state.2 q with + | none => simp [stepWalk,hp,HashProgram.eval] at ok + | some powed => + obtain ⟨evs,col⟩ := powed + have powEq := powWalk_openings grinding _ _ _ _ q hp + cases hd : drawWalk evs q with + | none => simp [stepWalk,hp,hd,HashProgram.eval] at ok + | some drawn => + obtain ⟨rest,x⟩ := drawn + simp only [stepWalk,hp,hd] at ok ⊢ + have sampled := recordSample_openings col q x + cases q with + | query i => + intro o member + rcases replyQuery_openings H decode lanes _ _ _ _ i ok o member with old | new + · left + rw [← powEq,← sampled] + exact old + · exact .inr new + | initial => + have same := replyPure_openings _ _ _ _ _ ok + intro o member + left + rw [← powEq,← sampled,← same] + exact member + | fold i j => + have same := replyPure_openings _ _ _ _ _ ok + intro o member + left + rw [← powEq,← sampled,← same] + exact member + | ood i j => + have same := replyPure_openings _ _ _ _ _ ok + intro o member + left + rw [← powEq,← sampled,← same] + exact member + | tail j => + have same := replyPure_openings _ _ _ _ _ ok + intro o member + left + rw [← powEq,← sampled,← same] + exact member + +theorem walkFrom_openings (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (qs : List (Coord p)) (state final : List SourceEvent × Collected p), + HashProgram.eval H (walkFrom decode grinding lanes qs state) = some final → + ∀ o ∈ final.2.openings, o ∈ state.2.openings ∨ + Authenticated H o (HashProgram.calls H (walkFrom decode grinding lanes qs state)) + | [], state, final, ok => by + simp only [walkFrom,HashProgram.eval,Option.some.injEq] at ok + subst ok + exact fun o member => .inl member + | q :: qs, state, final, ok => by + simp only [walkFrom,HashProgram.eval_bind] at ok + simp only [walkFrom,HashProgram.calls_bind] + cases hs : HashProgram.eval H (stepWalk decode grinding lanes state q) with + | none => simp [hs,HashProgram.eval] at ok + | some mid => + simp only [hs] at ok ⊢ + intro o member + rcases walkFrom_openings H decode grinding lanes qs mid final ok o member with old | new + · rcases stepWalk_openings H decode grinding lanes state mid q hs o old with older | first + · exact .inl older + · exact .inr (first.mono fun bytes h => List.mem_append_left _ h) + · exact .inr (new.mono fun bytes h => List.mem_append_right _ h) + +/-- Every query opening returned by the walk is authenticated by the walk's own whole-hash calls. -/ +theorem walk_openings (H : MerkleTransport.Primitive) (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (lanes : Nat) (root : Digest32) (evs : List SourceEvent) (col : Collected p) + (ok : HashProgram.eval H (walk decode grinding lanes root evs) = some col) : + ∀ o ∈ col.openings, Authenticated H o (HashProgram.calls H (walk decode grinding lanes root evs)) := by + unfold walk at ok ⊢ + rw [HashProgram.eval_map] at ok + rw [HashProgram.calls_map] + obtain ⟨final,walked,same⟩ := Option.map_eq_some_iff.mp ok + subst same + intro o member + rcases walkFrom_openings H decode grinding lanes _ _ final walked o member with start | done + · cases start + · exact done + +/-! ## Uniform public Merkle budget -/ + +def walkBudget (p : ParameterBounds.Profile) : Nat := + ((WHIRHistory.schedule (ParameterBounds.config p)).map (WHIRPhysicalVerifier.sampleBudget p)).sum + +theorem openProgram_certified (lanes : Nat) (i : Fin (cfg).folds.size) (root : Digest32) + (proof : MerkleTransport.PrunedMerklePaths) (x : CausalProbability.Sample (.query i)) : + HashProgram.Certified (WHIRPhysicalVerifier.queryBudget p i.val) (fun _ => True) + (openProgram lanes i root proof x) := by + have size : (WHIRPhysicalVerifier.queryIndices p i x).length = (cfg).queries[i.val]! := by + unfold WHIRPhysicalVerifier.queryIndices + rw [Array.length_toList] + exact QueryBatchSoundness.queries_size _ _ _ + have uniform := plan_certified_uniform proof root (ParameterBounds.length cfg i.val) + (WHIRPhysicalVerifier.queryIndices p i x) (rowWords lanes i) (WHIRPhysicalVerifier.leafWords p i.val) + rw [uniformBudget,size] at uniform + exact HashProgram.Certified.map uniform _ (fun _ _ => trivial) + +theorem replyQuery_certified (decode : Decoder) (lanes : Nat) (evs : List SourceEvent) + (col : Collected p) (i : Fin (cfg).folds.size) : + HashProgram.Certified (WHIRPhysicalVerifier.queryBudget p i.val) (fun _ => True) + (replyQuery decode lanes evs col i) := by + unfold replyQuery + split + · trivial + · split + · trivial + · split + · trivial + · exact HashProgram.Certified.map (openProgram_certified _ _ _ _ _) _ (fun _ _ => trivial) + +theorem stepWalk_certified (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (lanes : Nat) (state : List SourceEvent × Collected p) (q : Coord p) : + HashProgram.Certified (WHIRPhysicalVerifier.sampleBudget p q) (fun _ => True) + (stepWalk decode grinding lanes state q) := by + unfold stepWalk + split + · trivial + · split + · trivial + · cases q with + | query i => exact replyQuery_certified decode lanes _ _ i + | initial => trivial + | fold i j => trivial + | ood i j => trivial + | tail j => trivial + +theorem walkFrom_certified (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (qs : List (Coord p)) (state : List SourceEvent × Collected p), + HashProgram.Certified ((qs.map (WHIRPhysicalVerifier.sampleBudget p)).sum) (fun _ => True) + (walkFrom decode grinding lanes qs state) + | [], _ => trivial + | q :: qs, state => by + rw [List.map_cons,List.sum_cons] + apply HashProgram.Certified.bind (stepWalk_certified decode grinding lanes state q) + intro result _ + cases result with + | none => trivial + | some next => exact walkFrom_certified decode grinding lanes qs next + +/-- Every hash path of the walk, on every reply, is within the uniform budget. -/ +theorem walk_certified (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) + (root : Digest32) (evs : List SourceEvent) : + HashProgram.Certified (walkBudget p) (fun _ => True) (walk decode grinding lanes root evs) := + HashProgram.Certified.map (walkFrom_certified decode grinding lanes _ _) _ (fun _ _ => trivial) + +/-! ## The full counted source program -/ + +abbrev FullResult (p : ParameterBounds.Profile) := + SpongefishCurrentSourceJoinProbability.SourceResult × Option (Collected p) + +/-- Events before the first opening call: the constructor's instance event and one event per caller call (prelude, commitment header, payload, binding messages). -/ +def openingOffset (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) : Nat := + 1 + (before ++ headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ messages).length + +/-- Position of the commitment header's raw32 root read. -/ +def rootIndex (before : List Call) : Nat := 1 + before.length + 3 + +/-- The commitment root decoded from the header's root event. -/ +def headerRoot (index : Nat) (events : List SourceEvent) : Option Digest32 := + match events[index]? with + | some (.prover .root bytes) => (WireKind.root.codec.parse bytes).map Prod.fst + | _ => none + +def openingEvents (offset : Nat) (data : SpongefishCurrentMixedModeCompiler.Data) : List SourceEvent := + data.events.drop offset + +/-- After an accepted replay, walk the opening events from the header root; otherwise return the source result unchanged. -/ +def openingPhase (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) (lanes index offset : Nat) + (res : SpongefishCurrentSourceJoinProbability.SourceResult) : Program (FullResult p) := + match res with + | some (.ok data) => + match headerRoot index data.events with + | none => .done (res,none) + | some root => WHIRModeFinal.bind (walk decode grinding lanes root (openingEvents offset data)).lower + (fun col => .done (res,col)) + | _ => .done (res,none) + +/-- The old counted source program followed by the public opening walk. -/ +def fullProgram (iv : Digest32) (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) : Program (FullResult p) := + WHIRModeFinal.bind (SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes layout before + payloadCalls messages grinding prefixProgram) + (openingPhase decode grinding (AnchoredSourceCaller.shape layout).lanes (rootIndex before) + (openingOffset layout before payloadCalls messages)) + +def fullBudget (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (grinding : Fin (cfg).folds.size → Fin 64) (A : Nat) : Nat := + SpongefishCurrentSourceJoinProbability.budget tag instanceBytes layout before payloadCalls messages + grinding A + walkBudget p + +theorem openingPhase_counted (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (lanes index offset : Nat) (res : SpongefishCurrentSourceJoinProbability.SourceResult) : + Counts (walkBudget p) (openingPhase decode grinding lanes index offset res) := by + unfold openingPhase + split + · split + · trivial + · exact WHIRModeFinal.counts_mono (WHIRModeFinal.bind_counted _ _ (walkBudget p) 0 + (walk_certified _ _ _ _ _).counts (fun _ => trivial)) (by omega) + · trivial + +/-- All-reply count of the full program for every counted attacker prefix. -/ +theorem fullProgram_counted (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) : + Counts (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) + (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram) := + WHIRModeFinal.bind_counted _ _ _ _ + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram + (SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding) A attacker) + (fun res => openingPhase_counted decode grinding _ _ _ res) + +/-- Initialized byte-source coupling of the full program, with arbitrary adaptive attacker prefix and rejection behavior. -/ +theorem fullProgram_mode_bound {Coins : Type} [Fintype Coins] (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (D : View (FullResult p) → Bool) : + let Q := fullBudget tag instanceBytes layout before payloadCalls messages grinding A + letI := DuplexPublicSimulator.seedFintype + ModeAdv (DuplexPublicSimulator.simulator Q) iv + (fun coin => fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin)) + (fun coin => fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin) A (attacker coin)) D ≤ min 1 ((2*(Q : ℚ)^2-(Q : ℚ))/2^256) := by + simpa only [duplexModeLoss_eq] using + PublicCompressionCouplingActualJoint.actual_modeAdv_le_duplexModeLoss + (AdvCoins := Coins) (R := FullResult p) (fullBudget tag instanceBytes layout before payloadCalls messages + grinding A) iv + (fun coin => fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin)) + (fun coin => fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + (prefixProgram coin) A (attacker coin)) D + +/-! ## The real run returns the native opening -/ + +theorem getElem?_prefix {α : Type} : + ∀ (xs ys : List α) (n : Nat) (a : α), xs[n]? = some a → (xs ++ ys)[n]? = some a + | [], _, _, _, h => by simp at h + | _ :: _, _, 0, _, h => by simpa using h + | _ :: xs, ys, n+1, a, h => by simpa using getElem?_prefix xs ys n a (by simpa using h) + +theorem setup_events (c : Compression) (parameter : Digest32) (tag instanceBytes narg : List Byte) + (hints : List (List Byte)) (initial : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup c parameter tag instanceBytes narg hints = + some initial) : + initial.events = [.publicBytes instanceBytes] := by + unfold SpongefishCurrentObservedSessionEntry.actualSetup at setup + obtain ⟨_,_,same⟩ := Option.map_eq_some_iff.mp setup + subst same + rfl + +/-- The commitment receive's fourth event is the raw32 root read of the record root. -/ +theorem receive_root_event (c : Compression) (pre received : Cursor) (shape : AnchoredHeaderCodec.Shape) + (r : SpongefishSessionAdapter.Record) + (accepted : SpongefishCurrentCommitmentReceive.receive c pre shape = some (received,r)) : + received.events[pre.events.length + 3]? = some (.prover .root (WireKind.root.codec.bytes r.root)) := by + obtain ⟨_,_,_,header,sampled,bytes,_,readHeader,drawn,_,_,readValue⟩ := + SpongefishCurrentCommitmentReceive.receive_retains c pre received shape r accepted + obtain ⟨_,_,_,_,headerEvents,_⟩ := + SpongefishCurrentAnchorHeader.readHeader_facts c pre header shape r.root readHeader + have sampledEvents := (squeezeGroup_events c header sampled _ bytes drawn).1 + have valueEvents := read_events c sampled received .scalar r.value readValue + rw [valueEvents,sampledEvents,headerEvents,List.append_assoc,List.append_assoc, + List.getElem?_append_right (Nat.le_add_right _ _),Nat.add_sub_cancel_left] + simp [SpongefishCurrentAnchorHeader.fields,SpongefishRecordBindingParser.scalarMessages, + SpongefishSessionAdapter.constants,SpongefishRecordBindingParser.Message.bytes] + +/-- Under the witnesses of `SpongefishCurrentSourceJoinProbability.NativeAcceptedBad`, the real run of the full program returns the accepted replay and the native opening's `Collected`; every opening authenticates at its root with the level geometry, and every hashed input of every opened path is shorter than `2^56` bytes and has its complete primitive plan in the full program's primitive log. -/ +theorem fullProgram_native (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) + (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (initial pre received payload next : Cursor) + (setup : SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) iv tag instanceBytes + (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints = some initial) + (preRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial before = .ok pre) + (receivedEq : SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre + (AnchoredSourceCaller.shape layout) = some (received,r)) + (payloadRun : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received payloadCalls = + .ok payload) + (bindingEq : SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next) + (messagesEq : messageCalls r = messages) + (opened : Accepted C decode grinding r input next) : + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view.result = + (some (.ok (SpongefishCurrentMixedModeCompiler.forget opened.final)),some opened.collected) ∧ + ∀ o ∈ opened.collected.openings, + (∃ queries width, o.proof.open (PublicMerkleLog.hash C) o.root (ParameterBounds.length cfg o.level.val) + queries width (WHIRPhysicalVerifier.leafWords p o.level.val) = some o.opened.paths) ∧ + ∀ path ∈ o.opened.paths, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (PublicMerkleLog.hash C)), + bytes.length < 2^56 ∧ ∀ e ∈ PublicMerkleLog.plan C bytes, + e ∈ PublicCompressionProgram.primitiveLog C iv + (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram) + (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram A attacker) := by + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 + have tapeRun := composition_replay (compressionOf C) layout r before payloadCalls initial pre received + payload next preRun receivedEq payloadRun bindingEq + have sameCalls : SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding = + (before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r) ++ openingCalls grinding := by + rw [SpongefishCurrentSourceJoinProbability.calls,shapeEq,messagesEq] + have whole : SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial + (SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding) = + .ok opened.final := by + rw [sameCalls,actualReplay_append _ _ _ initial next tapeRun] + exact run_replay C decode grinding r.shape.lanes _ _ _ opened.ran + have programReal : (runReal C iv (SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes + layout before payloadCalls messages grinding prefixProgram)).view.result = + some (.ok (SpongefishCurrentMixedModeCompiler.forget opened.final)) := by + unfold SpongefishCurrentSourceJoinProbability.program SpongefishCurrentInitializedMode.afterPrefix + rw [WHIRModeFinal.bind_real_result,SpongefishCurrentInitializedMode.program_real] + simp [SpongefishCurrentObservedSessionEntry.actualEntry,setup,whole, + SpongefishCurrentMixedModeCompiler.forgetResult] + -- event bookkeeping + have initialEvents := setup_events _ _ _ _ _ _ initial setup + obtain ⟨preEvs,preEvents,preLength⟩ := + actualReplay_events_length _ before initial pre preRun + have rootEvent := receive_root_event _ pre received _ r receivedEq + obtain ⟨payloadEvs,payloadEvents,_⟩ := actualReplay_events _ payloadCalls received payload payloadRun + obtain ⟨bindingEvs,bindingEvents,_⟩ := actualReplay_events _ _ payload next + (verifyFields_replay _ (SpongefishRecordBindingParser.messages r) payload next bindingEq) + have ran := opened.ran + rw [shapeEq] at ran + obtain ⟨evs,finalEvents,walked⟩ := walk_native C decode grinding (AnchoredSourceCaller.shape layout).lanes + next opened.final r.root opened.collected ran + obtain ⟨tapeEvs,tapeEvents,tapeLength⟩ := actualReplay_events_length _ _ initial next tapeRun + have rootAt : headerRoot (rootIndex before) opened.final.events = some r.root := by + have index : rootIndex before = pre.events.length + 3 := by + rw [rootIndex,preEvents,initialEvents,List.length_append,preLength] + simp only [List.length_singleton] + have located : opened.final.events[rootIndex before]? = + some (.prover .root (WireKind.root.codec.bytes r.root)) := by + rw [finalEvents,bindingEvents,payloadEvents,index] + exact getElem?_prefix _ _ _ _ (getElem?_prefix _ _ _ _ (getElem?_prefix _ _ _ _ rootEvent)) + simp [headerRoot,located,parse_bytes] + have offsetEq : openingEvents (openingOffset layout before payloadCalls messages) + (SpongefishCurrentMixedModeCompiler.forget opened.final) = evs := by + have length : openingOffset layout before payloadCalls messages = next.events.length := by + rw [tapeEvents,initialEvents,List.length_append,tapeLength,openingOffset,← shapeEq,← messagesEq] + simp only [List.length_singleton] + change opened.final.events.drop _ = evs + rw [length,finalEvents,List.drop_left] + have phaseReal : (runReal C iv (openingPhase decode grinding (AnchoredSourceCaller.shape layout).lanes + (rootIndex before) (openingOffset layout before payloadCalls messages) + (some (.ok (SpongefishCurrentMixedModeCompiler.forget opened.final))))).view.result = + (some (.ok (SpongefishCurrentMixedModeCompiler.forget opened.final)),some opened.collected) := by + simp only [openingPhase] + change (runReal C iv (match headerRoot (rootIndex before) opened.final.events with + | none => _ | some root => _)).view.result = _ + rw [rootAt] + dsimp only + rw [WHIRModeFinal.bind_real_result,HashProgram.lower_real,offsetEq,walked] + rfl + refine ⟨?_,?_⟩ + · rw [fullProgram,WHIRModeFinal.bind_real_result,programReal] + exact phaseReal + · intro o member + obtain ⟨⟨queries,width,accepted⟩,covered⟩ := + walk_openings (PublicMerkleLog.hash C) decode grinding _ r.root evs opened.collected walked o member + refine ⟨⟨queries,width,accepted⟩,fun path pathMember bytes input => ⟨?_,?_⟩⟩ + · exact WHIRPhysicalVerifier.path_input_bounds_lt C o.proof o.root _ queries width + (WHIRPhysicalVerifier.leafWords p o.level.val) (2^56) o.opened.paths accepted + (WHIRPhysicalVerifier.production_leaf_byte_tag_zero p o.level) (by norm_num) path pathMember + bytes input + · intro e present + have observed : (⟨.primitive .verification e.1,e.2⟩ : Observation) ∈ + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view.observations := by + rw [fullProgram,HashProgram.bind_real_observations,programReal] + apply List.mem_append_right + simp only [openingPhase] + change _ ∈ (runReal C iv (match headerRoot (rootIndex before) opened.final.events with + | none => _ | some root => _)).view.observations + rw [rootAt] + dsimp only + rw [HashProgram.bind_real_observations,HashProgram.real_observations,offsetEq] + apply List.mem_append_left + exact List.mem_flatMap.mpr ⟨bytes,covered path pathMember bytes input,List.mem_map.mpr ⟨e,present,rfl⟩⟩ + have included := PCSBCSConstructionReplayTrace.observation_trace_membership C iv _ _ + (fullProgram_counted iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram A attacker) _ observed + have answer := PCSBCSConstructionReplayTrace.observation_answer C iv _ _ observed + change e.2 = C e.1 at answer + apply included e + change e ∈ [(e.1,C e.1)] + exact List.mem_singleton.mpr (Prod.ext rfl answer) + +/-! ## The public original list is unchanged by the primitive-only phase -/ + +theorem openingPhase_primitive (C : PrimitiveOracle) (iv : Digest32) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes index offset : Nat) + (res : SpongefishCurrentSourceJoinProbability.SourceResult) : + ∀ o ∈ (runReal C iv (openingPhase decode grinding lanes index offset res)).view.observations, + ∃ purpose n, o.query = .primitive purpose n := by + unfold openingPhase + split + · split + · simp [runReal] + · rw [HashProgram.bind_real_observations,HashProgram.real_observations] + intro o member + rcases List.mem_append.mp member with walked | final + · obtain ⟨_,_,mapped⟩ := List.mem_flatMap.mp walked + obtain ⟨e,_,rfl⟩ := List.mem_map.mp mapped + exact ⟨_,_,rfl⟩ + · simp [runReal] at final + · simp [runReal] + +theorem lookup_primitive (q : Coordinate) : + ∀ (ys : List Observation), (∀ o ∈ ys, ∃ purpose n, o.query = .primitive purpose n) → + SpongefishCurrentCallerGetter.lookup q ys = none + | [], _ => rfl + | y :: ys, primitive => by + obtain ⟨purpose,n,hy⟩ := primitive y List.mem_cons_self + simp only [SpongefishCurrentCallerGetter.lookup,hy] + exact lookup_primitive q ys (fun o h => primitive o (List.mem_cons_of_mem _ h)) + +theorem lookup_append_primitive (q : Coordinate) (ys : List Observation) + (primitive : ∀ o ∈ ys, ∃ purpose n, o.query = .primitive purpose n) : + ∀ (xs : List Observation), + SpongefishCurrentCallerGetter.lookup q (xs ++ ys) = SpongefishCurrentCallerGetter.lookup q xs + | [] => lookup_primitive q ys primitive + | x :: xs => by + simp only [List.cons_append,SpongefishCurrentCallerGetter.lookup] + split + · split + · rfl + · exact lookup_append_primitive q ys primitive xs + · exact lookup_append_primitive q ys primitive xs + +theorem lookup_over_budget (q : Coordinate) (Q : Nat) (big : ¬ pathCost q ≤ Q) : + ∀ (obs : List Observation), (∀ o ∈ obs, o.query.cost ≤ Q) → + SpongefishCurrentCallerGetter.lookup q obs = none + | [], _ => rfl + | o :: os, capped => by + simp only [SpongefishCurrentCallerGetter.lookup] + split + next other valid same => + split + next equal => + have cost := capped o List.mem_cons_self + rw [same] at cost + subst equal + exact absurd cost big + next => exact lookup_over_budget q Q big os (fun o' h => capped o' (List.mem_cons_of_mem _ h)) + next => exact lookup_over_budget q Q big os (fun o' h => capped o' (List.mem_cons_of_mem _ h)) + +theorem answer_lift {Q Q' : Nat} (obs obs' : List Observation) (le : Q ≤ Q') + (capped : ∀ o ∈ obs, o.query.cost ≤ Q) + (same : ∀ q, SpongefishCurrentCallerGetter.lookup q obs' = SpongefishCurrentCallerGetter.lookup q obs) : + SpongefishCurrentCallerGetter.answer (Q := Q') obs' = SpongefishCurrentCallerGetter.answer (Q := Q) obs := by + funext query + cases query with + | primitive => rfl + | construction q valid => + simp only [SpongefishCurrentCallerGetter.answer,SpongefishCurrentCallerGetter.bounded] + by_cases small : pathCost q ≤ Q + · simp [small,le_trans small le,same] + · by_cases fits : pathCost q ≤ Q' + · simp [small,fits,same,lookup_over_budget q Q small obs capped] + · simp [small,fits] + +/-- A public original at budget `Q` remains a public original at any larger budget, read from any observation list with the same construction lookups, provided every observation of the original list was within `Q`. -/ +theorem original_lift {Q Q' : Nat} (layout : WHIRCallerClaims.CallerLayout) (iv : Digest32) + (key : RawKey Q) (instanceBytes : List Byte) (obs obs' : List Observation) (le : Q ≤ Q') + (capped : ∀ o ∈ obs, o.query.cost ≤ Q) + (same : ∀ q, SpongefishCurrentCallerGetter.lookup q obs' = SpongefishCurrentCallerGetter.lookup q obs) + (input : PCSBCSCallerBinding.CallerInput p) + (member : input ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv key instanceBytes obs) : + ∃ (q : Coordinate) (work : pathCost q ≤ Q'), + input ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv (constructionKey Q' iv q work) + instanceBytes obs' := by + unfold SpongefishCurrentSourceCallerOriginal.original at member + cases decoded : WHIRHeaderRoots.decodeRaw iv key with + | none => simp [decoded] at member + | some q => + simp only [decoded] at member + obtain ⟨bound,valid,exactKey⟩ := WHIRHeaderRoots.decodeRaw_sound iv key q decoded + refine ⟨q,le_trans bound le,?_⟩ + unfold SpongefishCurrentSourceCallerOriginal.original + rw [WHIRHeaderRoots.decodeRaw_construction iv q valid, + SpongefishCurrentRecordModeCapture.rawRecords_construction _ _ _ valid] + rw [← exactKey,SpongefishCurrentRecordModeCapture.rawRecords_construction _ _ _ valid] at member + have candidates : ∀ r, SpongefishCurrentSourceCallerOriginal.candidate (Q := Q') p layout q r + instanceBytes obs' = + SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q r instanceBytes obs := by + intro r + unfold SpongefishCurrentSourceCallerOriginal.candidate SpongefishCurrentSourceCallerOriginal.replay + rw [answer_lift obs obs' le capped same] + simp only [candidates] + exact member + +/-- Real native acceptance with a property of the full program's view. -/ +def NativeAcceptedBadFull (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (Bad : PCSBCSCallerBinding.CallerInput p → View (FullResult p) → Prop) : Prop := + ∃ (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (initial pre received payload next : Cursor), + SpongefishCurrentObservedSessionEntry.actualSetup (compressionOf C) iv tag instanceBytes + (runReal C iv prefixProgram).view.result.narg + (runReal C iv prefixProgram).view.result.hints = some initial ∧ + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) initial before = .ok pre ∧ + SpongefishCurrentCommitmentReceive.receive (compressionOf C) pre + (AnchoredSourceCaller.shape layout) = some (received,r) ∧ + SpongefishCurrentPrimitiveEventCompiler.actualReplay (compressionOf C) received payloadCalls = + .ok payload ∧ + SpongefishRecordBindingParser.verify (compressionOf C) payload r = some next ∧ + messageCalls r = messages ∧ + Nonempty (Accepted C decode grinding r input next) ∧ + SpongefishCurrentSourceCallerOriginal.physicalCandidate C iv p layout + (coordinate next.pending (next.pending.consumed / 32)) r instanceBytes = some input ∧ + Bad input (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram)).view + +/-- Public full-view event: some construction key's public original list contains an original with the property. -/ +def PublicBadFull (Q : Nat) (iv : Digest32) (instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) + (Bad : PCSBCSCallerBinding.CallerInput p → View (FullResult p) → Prop) + (view : View (FullResult p)) : Prop := + ∃ (q : Coordinate) (work : pathCost q ≤ Q) (input : PCSBCSCallerBinding.CallerInput p), + input ∈ SpongefishCurrentSourceCallerOriginal.original p layout iv (constructionKey Q iv q work) + instanceBytes view.observations ∧ Bad input view + +/-- Pointwise join for the full program: real native acceptance places its prepared original in a public original list of the same full view, at the full budget. The appended opening phase only adds primitive observations. -/ +theorem native_public_full (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (nonempty : instanceBytes ≠ []) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) + (Bad : PCSBCSCallerBinding.CallerInput p → View (FullResult p) → Prop) + (native : NativeAcceptedBadFull C iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram Bad) : + PublicBadFull (fullBudget tag instanceBytes layout before payloadCalls messages grinding A) iv + instanceBytes layout Bad (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls + messages decode grinding prefixProgram)).view := by + obtain ⟨r,input,initial,pre,received,payload,next,setup,preRun,receivedEq,payloadRun,bindingEq, + messagesEq,⟨opened⟩,physical,bad⟩ := native + have shapeEq := (SpongefishCurrentCommitmentReceive.receive_retains _ pre received _ r receivedEq).1 + have joined := accepted_opening_original C iv layout r tag instanceBytes prefixProgram A attacker + nonempty before payloadCalls beforeEq payloadEq initial pre received payload next setup preRun + receivedEq payloadRun bindingEq decode grinding input opened + obtain ⟨_,_,_,work,_,_,member⟩ := joined + have sameCalls : SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding = + before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r ++ openingCalls grinding := by + rw [SpongefishCurrentSourceJoinProbability.calls,shapeEq,messagesEq] + have oldObservations : (runReal C iv (SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes + layout before payloadCalls messages grinding prefixProgram)).view.observations = + (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram + (before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r ++ + openingCalls grinding))).view.observations := by + unfold SpongefishCurrentSourceJoinProbability.program + rw [sameCalls] + have capped := SpongefishCurrentReplayProvenance.observation_cap + (SpongefishCurrentReplayProvenance.real_runs C iv _) _ + (SpongefishCurrentInitializedMode.afterPrefix_counted iv tag instanceBytes prefixProgram + (before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r ++ openingCalls grinding) + A attacker) + have le : A + SpongefishCurrentInitializedMode.budget tag instanceBytes + (before ++ headerCalls r.shape.logN ++ payloadCalls ++ messageCalls r ++ openingCalls grinding) ≤ + fullBudget tag instanceBytes layout before payloadCalls messages grinding A := by + unfold fullBudget SpongefishCurrentSourceJoinProbability.budget + rw [sameCalls] + exact Nat.le_add_right _ _ + have fullObservations := HashProgram.bind_real_observations C iv + (SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes layout before payloadCalls + messages grinding prefixProgram) + (openingPhase decode grinding (AnchoredSourceCaller.shape layout).lanes (rootIndex before) + (openingOffset layout before payloadCalls messages)) + rw [oldObservations] at fullObservations + have same : ∀ q, SpongefishCurrentCallerGetter.lookup q + (runReal C iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)).view.observations = + SpongefishCurrentCallerGetter.lookup q (runReal C iv (SpongefishCurrentInitializedMode.afterPrefix iv + tag instanceBytes prefixProgram (before ++ headerCalls r.shape.logN ++ payloadCalls ++ + messageCalls r ++ openingCalls grinding))).view.observations := by + intro q + rw [fullProgram,fullObservations] + exact lookup_append_primitive q _ (openingPhase_primitive C iv decode grinding _ _ _ _) _ + obtain ⟨q,lifted,liftedMember⟩ := original_lift layout iv _ instanceBytes _ _ le capped same input + (member input physical) + exact ⟨q,lifted,input,liftedMember,bad⟩ + +#print axioms actualReplay_events +#print axioms replayProgram_events +#print axioms replayProgram_ideal_events +#print axioms program_events +#print axioms openProgram_lower +#print axioms walk_native +#print axioms walk_openings +#print axioms walk_certified +#print axioms fullProgram_counted +#print axioms fullProgram_mode_bound +#print axioms fullProgram_native +#print axioms native_public_full + +end Whir.SpongefishCurrentOpeningProgram diff --git a/verification/whir/Whir/SpongefishCurrentPartitionCapture.lean b/verification/whir/Whir/SpongefishCurrentPartitionCapture.lean new file mode 100644 index 000000000..d18200a69 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentPartitionCapture.lean @@ -0,0 +1,286 @@ +import Whir.SpongefishCurrentPhysicalRootCapture +import Whir.SpongefishCurrentRoundPackets + +/-! Partition-level first-mention root capture for the current #607 source, +generic in the raw address function and in the packet partition of raw mixed +keys. A packet key mentions every reference of every one of its block raw keys; +a garbage key mentions the references of its raw key. The captured image is the +existing `freeze` of the ordinary primitive records preceding the first mention, +newest first, exactly as `SpongefishCurrentPhysicalRootCapture.ordinaryLog`. + +On atomic packet programs this capture agrees with the raw capture on the joined +raw trace, provided the raw address is uniform across the blocks of a packet +(true for addresses derived from the shared key history) and no ordinary +primitive input is a packet block. The capture never reads the answer of a packet +that mentions the reference, so it is a function of the erased table, and on +compiled counted programs it is the public capture read from the view. -/ +namespace Whir.SpongefishCurrentPartitionCapture +open Concrete FiatShamirGame DuplexModeGame TypedOracleCompiler RawOracleCoupling +open PCSBCSChallengeOracle PCSBCSSourceRootReferences PCSBCSMerkleRootCache PublicMerkleLog +open PCSBCSAtomicAllocationTrace +set_option autoImplicit false + +abbrev Event (B : Nat) := SpongefishCurrentPhysicalRootCapture.Event B + +variable {B : Nat} {Packet : Type} {Block : Packet → Type} + +section Address +variable (part : Partition (PublicCompressionCouplingMixed.Key B) Packet Block) + (addr : PublicCompressionCouplingMixed.Key B → List Reference) + +/-- The raw address does not depend on which block of a packet is requested. -/ +def Uniform : Prop := + ∀ (packet : Packet) (b c : Block packet) (ref : Reference), + ref ∈ addr (part.encode ⟨packet,b⟩) → ref ∈ addr (part.encode ⟨packet,c⟩) + +/-- No ordinary primitive input is recognized as a packet block. -/ +def Plain : Prop := ∀ node, part.recognize (.inl node) = none + +/-- Ordinary records are garbage keys whose raw key is a primitive input. -/ +def ordinaryStep (log : PublicLog) (event : Sigma (part.Answer (D := Digest32))) : PublicLog := + match event with + | ⟨.inl _,_⟩ => log + | ⟨.inr garbage,answer⟩ => + match garbage.val with + | .inl input => (input,answer) :: log + | .inr _ => log + +/-- Newest first, the same convention as the raw `ordinaryLog`. -/ +def ordinaryLog (events : List (Sigma (part.Answer (D := Digest32)))) : PublicLog := + events.foldl (ordinaryStep part) [] + +variable [∀ packet, Fintype (Block packet)] + +/-- A packet mentions the references of all its block raw keys; a garbage key +mentions the references of its raw key. -/ +noncomputable def paddr : part.Key → List Reference + | .inl packet => (Finset.univ : Finset (Block packet)).toList.flatMap + fun b => addr (part.encode ⟨packet,b⟩) + | .inr garbage => addr garbage.val + +theorem mem_paddr_packet (packet : Packet) (ref : Reference) : + ref ∈ paddr part addr (.inl packet) ↔ ∃ b, ref ∈ addr (part.encode ⟨packet,b⟩) := by + simp [paddr] + +theorem mem_paddr_garbage (garbage : part.Garbage) (ref : Reference) : + ref ∈ paddr part addr (.inr garbage) ↔ ref ∈ addr garbage.val := Iff.rfl + +/-- Partition-level capture: freeze the ordinary prefix before the first mention. -/ +noncomputable def pcapture (ref : Reference) {R : Type} {n : Nat} + (source : Sampling part.Key (part.Answer (D := Digest32)) R n) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : Option Frozen := + (PCSBCSFirstRootDisclosure.firstMention (paddr part addr) ref source table).map + fun before => freeze (ordinaryLog part before) ref.root ref.shape + +end Address + +/-- Raw capture on a raw mixed trace with an arbitrary raw address. -/ +def rawCapture (addr : PublicCompressionCouplingMixed.Key B → List Reference) + (ref : Reference) (events : List (Event B)) : Option Frozen := + (PCSBCSNativePublicCapture.firstPrefix addr ref events).map + fun before => freeze (SpongefishCurrentPhysicalRootCapture.ordinaryLog before) ref.root ref.shape + +/-- Public capture read from a view: the raw capture of the decoded mixed trace. -/ +def viewCapture {R : Type} (addr : PublicCompressionCouplingMixed.Key B → List Reference) + (iv : Digest32) (ref : Reference) (view : View R) : Option Frozen := + rawCapture addr ref (PCSBCSNativePublicCapture.mixedTrace B iv [] view.observations) + +section Raw +variable (part : Partition (PublicCompressionCouplingMixed.Key B) Packet Block) + (addr : PublicCompressionCouplingMixed.Key B → List Reference) +variable [∀ packet, Fintype (Block packet)] + +theorem mem_paddr_allocation (uniform : Uniform part addr) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + (raw : PublicCompressionCouplingMixed.Key B) (ref : Reference) : + ref ∈ paddr part addr (allocation part table raw).1 ↔ ref ∈ addr raw := by + unfold allocation + split + · rename_i block found + have encoded := part.encode_recognize raw block found + rw [mem_paddr_packet] + constructor + · rintro ⟨b,member⟩ + rw [← encoded] + exact uniform block.1 b block.2 ref member + · intro member + refine ⟨block.2,?_⟩ + rw [← encoded] at member + exact member + · exact Iff.rfl + +theorem firstPrefix_allocation (uniform : Uniform part addr) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + (ref : Reference) (events : List (Event B)) : + PCSBCSNativePublicCapture.firstPrefix (paddr part addr) ref + (events.map fun event => allocation part table event.1) = + (PCSBCSNativePublicCapture.firstPrefix addr ref events).map + (List.map fun event => allocation part table event.1) := by + induction events with + | nil => rfl + | cons event rest ih => + by_cases hit : ref ∈ addr event.1 + · have mapped : ref ∈ paddr part addr (allocation part table event.1).1 := + (mem_paddr_allocation part addr uniform table event.1 ref).mpr hit + simp only [List.map_cons,PCSBCSNativePublicCapture.firstPrefix,hit,mapped, + ↓reduceIte,Option.map_some,List.map_nil] + · have mapped : ref ∉ paddr part addr (allocation part table event.1).1 := + fun member => hit ((mem_paddr_allocation part addr uniform table event.1 ref).mp member) + simp only [List.map_cons,PCSBCSNativePublicCapture.firstPrefix,hit,mapped, + ↓reduceIte,ih,Option.map_map] + rfl + +omit [∀ packet, Fintype (Block packet)] in +theorem join_garbage (table : (key : part.Key) → part.Answer (D := Digest32) key) + (raw : PublicCompressionCouplingMixed.Key B) (missing : part.recognize raw = none) : + part.join table raw = table (.inr ⟨raw,missing⟩) := by + unfold Partition.join + split + · rename_i block found + rw [missing] at found + cases found + · rfl + +omit [∀ packet, Fintype (Block packet)] in +theorem ordinaryStep_allocation (plain : Plain part) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + (log : PublicLog) (event : Event B) (correct : event.2 = part.join table event.1) : + ordinaryStep part log (allocation part table event.1) = + SpongefishCurrentPhysicalRootCapture.ordinaryStep log event := by + rcases event with ⟨raw,answer⟩ + dsimp only at correct + cases raw with + | inl node => + rw [correct,join_garbage part table (.inl node) (plain node)] + unfold allocation + split + · rename_i block found + rw [plain node] at found + cases found + · rfl + | inr key => + unfold allocation + split <;> rfl + +omit [∀ packet, Fintype (Block packet)] in +theorem ordinaryLog_allocation (plain : Plain part) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + (events : List (Event B)) (correct : ∀ event ∈ events, event.2 = part.join table event.1) : + ordinaryLog part (events.map fun event => allocation part table event.1) = + SpongefishCurrentPhysicalRootCapture.ordinaryLog events := by + unfold ordinaryLog SpongefishCurrentPhysicalRootCapture.ordinaryLog + generalize ([] : PublicLog) = log + induction events generalizing log with + | nil => rfl + | cons event rest ih => + simp only [List.map_cons,List.foldl_cons] + rw [ordinaryStep_allocation part plain table log event (correct event List.mem_cons_self)] + exact ih (fun other member => correct other (List.mem_cons_of_mem _ member)) _ + +/-- Atomic packet programs: the partition capture is the raw capture on the +joined raw trace. -/ +theorem pcapture_raw (uniform : Uniform part addr) (plain : Plain part) (ref : Reference) + {R : Type} {n : Nat} (prog : Sampling (PublicCompressionCouplingMixed.Key B) (fun _ => Digest32) R n) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : + pcapture part addr ref (Atomic.program part prog) table = + rawCapture addr ref (Sampling.execute (part.join table) prog).2 := by + unfold pcapture rawCapture + rw [PCSBCSNativePublicCapture.firstPrefix_execute,execute_program, + firstPrefix_allocation part addr uniform table] + cases found : PCSBCSNativePublicCapture.firstPrefix addr ref + (Sampling.execute (part.join table) prog).2 with + | none => rfl + | some before => + simp only [Option.map_some] + rw [ordinaryLog_allocation part plain table before fun event member => + PCSBCSNativePublicCapture.execute_answers (part.join table) prog event + (PCSBCSNativePublicCapture.firstPrefix_subset addr ref _ before found event member)] + +end Raw + +section Erased +variable (part : Partition (PublicCompressionCouplingMixed.Key B) Packet Block) + (addr : PublicCompressionCouplingMixed.Key B → List Reference) + +open Classical in +/-- Ghost completion of the erased packet entry by zero blocks. -/ +noncomputable def otherTable (packet : Packet) + (other : PCSStateRestoration.Latent.Erased (part.Answer (D := Digest32)) (.inl packet)) : + (key : part.Key) → part.Answer (D := Digest32) key := + PCSStateRestoration.Latent.fill (.inl packet) other (fun _ => 0) + +variable [∀ packet, Fintype (Block packet)] + +/-- A packet that mentions the reference is never read before the capture. -/ +theorem pcapture_erased (packet : Packet) (ref : Reference) + (mentioned : ref ∈ paddr part addr (.inl packet)) {R : Type} {n : Nat} + (source : Sampling part.Key (part.Answer (D := Digest32)) R n) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : + pcapture part addr ref source + (otherTable part packet (PCSStateRestoration.Latent.erase (.inl packet) table)) = + pcapture part addr ref source table := by + classical + unfold otherTable pcapture + rw [PCSStateRestoration.Latent.fill_erase, + PCSBCSFirstRootDisclosure.first_mention_answer_independent (paddr part addr) + (.inl packet) ref mentioned source table] + +end Erased + +section View +variable (part : Partition (PublicCompressionCouplingMixed.Key B) Packet Block) + (addr : PublicCompressionCouplingMixed.Key B → List Reference) +variable [∀ packet, Fintype (Block packet)] + +/-- Compiled counted programs: the partition capture is the public capture read +from the view of the atomic program, for every partition-level table. -/ +theorem pcapture_view (uniform : Uniform part addr) (plain : Plain part) + (iv : Digest32) (ref : Reference) {R : Type} (program : Program R) (remaining : Nat) + (limit : remaining ≤ B) (counted : Counts remaining program) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : + let source := Atomic.program part + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + pcapture part addr ref source table = viewCapture addr iv ref (Sampling.eval table source) := by + dsimp only + have joined : PublicCompressionCouplingMixed.oracle + ((PublicCompressionCouplingMixed.tableEquiv B) (part.join table)).1 + ((PublicCompressionCouplingMixed.tableEquiv B) (part.join table)).2 = part.join table := + (PublicCompressionCouplingMixed.tableEquiv B).left_inv (part.join table) + rw [pcapture_raw part addr uniform plain ref _ table,viewCapture,Atomic.eval_program,← joined, + PCSBCSNativePublicCapture.mixedTrace_actual] + +/-- The builder's capture from the erased table is the public capture of the +full-table view, whenever the erased packet mentions the reference. -/ +theorem pcapture_erased_view (uniform : Uniform part addr) (plain : Plain part) + (iv : Digest32) (packet : Packet) (ref : Reference) + (mentioned : ref ∈ paddr part addr (.inl packet)) {R : Type} (program : Program R) + (remaining : Nat) (limit : remaining ≤ B) (counted : Counts remaining program) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : + let source := Atomic.program part + (PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted) + pcapture part addr ref source + (otherTable part packet (PCSStateRestoration.Latent.erase (.inl packet) table)) = + viewCapture addr iv ref (Sampling.eval table source) := by + dsimp only + rw [pcapture_erased part addr packet ref mentioned, + pcapture_view part addr uniform plain iv ref program remaining limit counted table] + +end View + +/-- The current round partition recognizes no ordinary primitive input. -/ +theorem round_plain (p : ParameterBounds.Profile) (Q : Nat) (iv : Digest32) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) (boundary : Nat) : + Plain (SpongefishCurrentRoundPackets.partition p Q iv grinding boundary) := by + intro node + simp [SpongefishCurrentRoundPackets.partition,partitionOfInjection, + SpongefishCurrentRoundPackets.blockKey] + +#print axioms mem_paddr_allocation +#print axioms firstPrefix_allocation +#print axioms ordinaryLog_allocation +#print axioms pcapture_raw +#print axioms pcapture_erased +#print axioms pcapture_view +#print axioms pcapture_erased_view +#print axioms round_plain +end Whir.SpongefishCurrentPartitionCapture diff --git a/verification/whir/Whir/SpongefishCurrentRootPolicy.lean b/verification/whir/Whir/SpongefishCurrentRootPolicy.lean new file mode 100644 index 000000000..a2bc65b62 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRootPolicy.lean @@ -0,0 +1,685 @@ +import Whir.SpongefishCurrentRoundPackets +import Whir.SpongefishCurrentAnchorAttackerPrefix +import Whir.PCSBCSSourceRootAdmission + +/-! Current #607 root references, public root policy, first-mention capture and physical freeze for the opening phase. + +A decoded current output key mentions Root0 when its history extends the commitment header frame (`headerFrames` closed frames, the last of which carries the literal current header), and it mentions the level root announced after the level-ending fold of every earlier opening draw. The opening draw with index `j` closes a history of `boundary + j + 1` frames (the convention of `SpongefishCurrentRoundPackets.classify`); its reply is absorbed into the next run, which is closed by the following draw as frame `boundary + j + 1`. A run is only closed by a positive draw (`SpongefishPCSRoundFrames.draw`), so after a level-ending fold the frame starts with the 48-byte fold message followed by the raw32 root (`SpongefishCurrentOpeningAcceptance.replyCalls`), possibly followed by later reads of a zero-width OOD round. The level root is therefore bytes 48..80 of that frame, with the Merkle geometry of `SpongefishCurrentOpeningAcceptance.openQuery` at the next level. + +The root policy recovers coordinates from the newest-first primitive log, each entry reading only strictly older entries, and announces the roots of their references. Its target count is at most `Q*(Q+1)` and it only grows. Any real counted execution whose compiled mixed trace first mentions a reference has an exact physical freeze of the primitive log in which the reference root is already a target; under the same quiet trace alarm no primitive opening event is retained against the frozen ordinary log. -/ +namespace Whir.SpongefishCurrentRootPolicy +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame TypedOracleCompiler +open PublicMerkleLog PCSBCSSourceRootReferences PCSBCSMerkleRootCache +set_option autoImplicit false + +/-! ## Level geometry -/ + +section Geometry +variable (p : ParameterBounds.Profile) +local notation "cfg" => ParameterBounds.config p + +/-- Merkle geometry of `openQuery` at level `i`: `length cfg i` leaves, full leaf width and row width `leafWords p i`. -/ +def levelShape (i : Nat) : PCSBCSMerkleRootCache.Shape := + ⟨(ParameterBounds.length cfg i).log2,WHIRPhysicalVerifier.leafWords p i, + WHIRPhysicalVerifier.leafWords p i⟩ + +theorem levelShape_geometry (i : Nat) : + 2^(levelShape p i).height = ParameterBounds.length cfg i ∧ + (levelShape p i).leafWords = WHIRPhysicalVerifier.leafWords p i ∧ + (levelShape p i).occupied = WHIRPhysicalVerifier.leafWords p i := by + refine ⟨?_,rfl,rfl⟩ + simp only [levelShape,ParameterBounds.length,Nat.log2_two_pow] + +/-- At every later level the geometry is the historical phase shape. -/ +theorem levelShape_phase (i : Nat) : levelShape p (i+1) = phaseShape cfg (i+1) := by + simp only [levelShape,phaseShape,ParameterBounds.length,Nat.log2_two_pow, + WHIRPhysicalVerifier.leafWords,Nat.add_one_ne_zero,↓reduceIte] + +private theorem take_one_sum (a : Array Nat) : (a.toList.take 1).sum = a[0]! := by + rcases a with ⟨l⟩ + cases l <;> simp + +/-- Root0's physical shape is the level-0 geometry of `openQuery` with row width `shape.lanes`. -/ +theorem root0_geometry (shape : SpongefishSessionAdapter.Shape) + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p shape) : + 2^(SpongefishCurrentPhysicalRootCapture.physicalShape shape).height = ParameterBounds.length cfg 0 ∧ + (SpongefishCurrentPhysicalRootCapture.physicalShape shape).leafWords = + WHIRPhysicalVerifier.leafWords p 0 ∧ + (SpongefishCurrentPhysicalRootCapture.physicalShape shape).occupied = shape.lanes := by + obtain ⟨heights,widths,lanes⟩ := SpongefishCurrentPhysicalRootCapture.physical_shape shape + refine ⟨?_,?_,lanes⟩ + · rw [heights,supported.dimension,supported.batch,supported.rate] + simp only [ParameterBounds.length,CausalGame.remaining,Nat.zero_add,take_one_sum] + · rw [widths,supported.batch] + simp [WHIRPhysicalVerifier.leafWords] +end Geometry + +/-- The raw32 root read after the 48-byte fold message of a level-ending fold. -/ +def levelRoot (bytes : List Byte) : Option Digest32 := + (SpongefishPCSRoundFrames.rootCodec.parse (bytes.drop 48)).map Prod.fst + +theorem levelRoot_reply (message rest : List Byte) (width : message.length = 48) (root : Digest32) : + levelRoot (message ++ SpongefishPCSRoundFrames.rootCodec.bytes root ++ rest) = some root := by + simp only [levelRoot,List.append_assoc,List.drop_left' width, + SpongefishPCSRoundFrames.Codec.parse_append,Option.map_some] + +/-- The literal native reply of a level-ending fold: `[.read (.vector 2), .read .root]`. -/ +theorem levelRoot_fold_reply (xs : Fin 2 → E) (root : Digest32) (rest : List Byte) : + levelRoot ((SpongefishPCSRoundFrames.vectorCodec 2).bytes xs ++ + SpongefishPCSRoundFrames.rootCodec.bytes root ++ rest) = some root := by + apply levelRoot_reply + simp [SpongefishPCSRoundFrames.Codec.bytes,SpongefishPCSRoundFrames.vectorCodec] + +/-! ## Frame count of a coordinate -/ + +private theorem chunks_ne_nil (first : Bool) (previous : Nat) (pending bytes : List Byte) + (nonempty : pending ≠ []) : DuplexEncoding.chunks first previous pending bytes ≠ [] := by + induction bytes generalizing first previous pending with + | nil => simp [DuplexEncoding.chunks,nonempty] + | cons b bs ih => + simp only [DuplexEncoding.chunks] + split + · simp + · exact ih first previous (pending ++ [b]) (by simp) + +private theorem framePlan_ne_nil (f : Frame) (valid : DuplexEncoding.FrameValid f) : + DuplexEncoding.framePlan f ≠ [] := by + cases f with + | absorb previous bytes => + cases bytes with + | nil => exact absurd rfl valid.2 + | cons b bs => + simp only [DuplexEncoding.framePlan,DuplexEncoding.chunks] + split + · simp + · exact chunks_ne_nil true previous ([] ++ [b]) bs (by simp) + | nonce previous bits nonce => simp [DuplexEncoding.framePlan] + +/-- Every valid frame costs at least one compression, besides the seed and terminal calls. -/ +theorem frames_pathCost (q : Coordinate) (valid : DuplexEncoding.Admissible q) : + q.history.frames.length + 2 ≤ pathCost q := by + have frames : ∀ fs : List Frame, (∀ f ∈ fs, DuplexEncoding.FrameValid f) → + fs.length ≤ (fs.flatMap DuplexEncoding.framePlan).length := by + intro fs + induction fs with + | nil => intro _; simp + | cons f fs ih => + intro allValid + have head := framePlan_ne_nil f (allValid f List.mem_cons_self) + have tail := ih (fun g member => allValid g (List.mem_cons_of_mem _ member)) + have positive := List.length_pos_iff.mpr head + simp only [List.flatMap_cons,List.length_append,List.length_cons] + omega + have bound := frames q.history.frames valid.1 + simp only [pathCost,DuplexEncoding.plan,List.length_cons,List.length_append] + omega + +/-! ## References -/ + +section References +variable (p : ParameterBounds.Profile) (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (shape : SpongefishSessionAdapter.Shape) (headerFrames boundary : Nat) + +/-- Root0, read from the commitment header frame of a history that extends it. -/ +def anchorReference (h : FramedHistory) : Option Reference := + if headerFrames ≤ h.frames.length then + (SpongefishCurrentAnchorHeader.fromHistory shape {h with frames := h.frames.take headerFrames}).map + (SpongefishCurrentPhysicalRootCapture.reference shape) + else none + +/-- The level root announced in the reply frame of opening draw `j`, when that draw is the last fold of a non-final level. -/ +def levelAt (h : FramedHistory) (j : Nat) : Option Reference := + match (SpongefishCurrentRoundPackets.openingDraws grinding)[j]? with + | some (some (.fold i k)) => + if SpongefishCurrentOpeningAcceptance.isLastFold i k = true ∧ + i.val + 1 < (ParameterBounds.config p).folds.size then + match h.frames[boundary + j + 1]? with + | some (.absorb _ bytes) => (levelRoot bytes).map (fun root => ⟨root,levelShape p (i.val+1)⟩) + | _ => none + else none + | _ => none + +/-- All root references disclosed by a history: Root0 and the level roots of completed opening replies. -/ +def references (h : FramedHistory) : List Reference := + (anchorReference shape headerFrames h).toList ++ + (List.range h.frames.length).filterMap (levelAt p grinding boundary h) + +theorem references_length (h : FramedHistory) : + (references p grinding shape headerFrames boundary h).length ≤ h.frames.length + 1 := by + have anchor : (anchorReference shape headerFrames h).toList.length ≤ 1 := by + cases anchorReference shape headerFrames h <;> simp + have levels := List.length_filterMap_le (levelAt p grinding boundary h) (List.range h.frames.length) + simp only [references,List.length_append,List.length_range] at levels ⊢ + omega + +theorem anchor_mem (h : FramedHistory) (root : Digest32) (enough : headerFrames ≤ h.frames.length) + (header : SpongefishCurrentAnchorHeader.fromHistory shape + {h with frames := h.frames.take headerFrames} = some root) : + SpongefishCurrentPhysicalRootCapture.reference shape root ∈ + references p grinding shape headerFrames boundary h := by + apply List.mem_append_left + simp [anchorReference,enough,header] + +theorem level_mem (h : FramedHistory) (j : Nat) (i : Fin (ParameterBounds.config p).folds.size) + (k : Fin (ParameterBounds.config p).folds[i.val]!) + (draw : (SpongefishCurrentRoundPackets.openingDraws grinding)[j]? = some (some (.fold i k))) + (last : SpongefishCurrentOpeningAcceptance.isLastFold i k = true) + (later : i.val + 1 < (ParameterBounds.config p).folds.size) + (previous : Nat) (bytes : List Byte) + (frame : h.frames[boundary + j + 1]? = some (.absorb previous bytes)) + (root : Digest32) (parsed : levelRoot bytes = some root) : + (⟨root,levelShape p (i.val+1)⟩ : Reference) ∈ references p grinding shape headerFrames boundary h := by + apply List.mem_append_right + obtain ⟨inside,_⟩ := List.getElem?_eq_some_iff.mp frame + refine List.mem_filterMap.mpr ⟨j,List.mem_range.mpr (by omega),?_⟩ + simp only [levelAt,draw,last,later,and_self,↓reduceIte,frame,parsed,Option.map_some] + +/-- References of a decoded coordinate; only output keys disclose roots. -/ +def coordinateReferences (q : Coordinate) : List Reference := + match q.terminal with + | .output _ => references p grinding shape headerFrames boundary q.history + | _ => [] + +theorem coordinateReferences_length (q : Coordinate) (valid : DuplexEncoding.Admissible q) : + (coordinateReferences p grinding shape headerFrames boundary q).length + 1 ≤ pathCost q := by + have frames := frames_pathCost q valid + have refs := references_length p grinding shape headerFrames boundary q.history + unfold coordinateReferences + split + · omega + · simp only [List.length_nil] + omega + +/-! ## Root policy -/ + +variable (Q : Nat) (iv : Digest32) + +/-- Roots announced by one primitive entry, reading only the strictly older log. -/ +def rootsAt (older : PublicLog) (input : Node) : List Digest32 := + ((PCSBCSSourceCoordinateDecoder.recover Q iv older input).map + (fun q => (coordinateReferences p grinding shape headerFrames boundary q).map Reference.root)).getD [] + +/-- Newest-first log; announcements of older entries come first. -/ +def scan : PublicLog → List Digest32 + | [] => [] + | (input,_) :: older => scan older ++ rootsAt p grinding shape headerFrames boundary Q iv older input + +def targets : PublicMerkleProbability.RootPolicy := fun log => + (scan p grinding shape headerFrames boundary Q iv log).toFinset + +theorem rootsAt_length (older : PublicLog) (input : Node) : + (rootsAt p grinding shape headerFrames boundary Q iv older input).length ≤ Q + 1 := by + unfold rootsAt + cases recovered : PCSBCSSourceCoordinateDecoder.recover Q iv older input with + | none => simp + | some q => + obtain ⟨_,_,_,_,_,_,valid,cost⟩ := PCSBCSSourceCoordinateDecoder.recover_sound recovered + have bound := coordinateReferences_length p grinding shape headerFrames boundary q valid + simp only [Option.map_some,Option.getD_some,List.length_map] + omega + +theorem scan_length (log : PublicLog) : + (scan p grinding shape headerFrames boundary Q iv log).length ≤ log.length * (Q+1) := by + induction log with + | nil => simp [scan] + | cons record older ih => + rcases record with ⟨input,digest⟩ + have bound := rootsAt_length p grinding shape headerFrames boundary Q iv older input + simp only [scan,List.length_append,List.length_cons] + rw [Nat.succ_mul] + omega + +theorem targets_grow : PublicMerkleProbability.RootsGrow + (targets p grinding shape headerFrames boundary Q iv) := by + intro history record root member + rcases record with ⟨input,digest⟩ + simp only [targets,scan,List.mem_toFinset,List.mem_append] at member ⊢ + exact Or.inl member + +theorem targets_cap (log : PublicLog) (budget : log.length ≤ Q) : + (targets p grinding shape headerFrames boundary Q iv log).card ≤ Q*(Q+1) := by + have finite := List.toFinset_card_le (scan p grinding shape headerFrames boundary Q iv log) + have count := scan_length p grinding shape headerFrames boundary Q iv log + have cost := Nat.mul_le_mul_right (Q+1) budget + exact finite.trans (count.trans cost) + +theorem targets_append (newer older : PublicLog) : + targets p grinding shape headerFrames boundary Q iv older ⊆ + targets p grinding shape headerFrames boundary Q iv (newer ++ older) := by + induction newer with + | nil => exact fun _ h => h + | cons record newer ih => + exact fun _ h => targets_grow p grinding shape headerFrames boundary Q iv _ _ (ih h) + +/-! ## First-mention capture -/ + +/-- Root addresses of a mixed key: decoded current output keys only; ordinary nodes have none. -/ +def addresses {B : Nat} : PublicCompressionCouplingMixed.Key B → List Reference + | .inl _ => [] + | .inr key => + match WHIRHeaderRoots.decodeRaw iv key with + | none => [] + | some q => coordinateReferences p grinding shape headerFrames boundary q + +def firstPrefix {B : Nat} (ref : Reference) + (events : List (SpongefishCurrentPhysicalRootCapture.Event B)) : + Option (List (SpongefishCurrentPhysicalRootCapture.Event B)) := + PCSBCSNativePublicCapture.firstPrefix (addresses p grinding shape headerFrames boundary iv) ref events + +/-- Freeze the ordinary log strictly before the first mention, never including the mentioning answer. -/ +def capture {B : Nat} (ref : Reference) + (events : List (SpongefishCurrentPhysicalRootCapture.Event B)) : Option Frozen := + (firstPrefix p grinding shape headerFrames boundary iv ref events).map + (fun before => freeze (SpongefishCurrentPhysicalRootCapture.ordinaryLog before) ref.root ref.shape) + +def publicCapture {B : Nat} {R : Type} (ref : Reference) (view : DuplexModeGame.View R) : Option Frozen := + capture p grinding shape headerFrames boundary iv ref + (PCSBCSNativePublicCapture.mixedTrace B iv [] view.observations) + +theorem firstPrefix_source {B n : Nat} {R : Type} (ref : Reference) + (program : Sampling (PublicCompressionCouplingMixed.Key B) (fun _ => Digest32) R n) + (table : PublicCompressionCouplingMixed.Key B → Digest32) : + PCSBCSFirstRootDisclosure.firstMention (addresses p grinding shape headerFrames boundary iv) ref + program table = + firstPrefix p grinding shape headerFrames boundary iv ref (Sampling.execute table program).2 := + PCSBCSNativePublicCapture.firstPrefix_execute _ _ _ _ + +theorem publicCapture_source {B : Nat} {R : Type} (ref : Reference) + (seed : DuplexPublicSimulator.Seed) (ro : RawKey B → Digest32) + (program : DuplexModeGame.Program R) (remaining : Nat) (limit : remaining ≤ B) + (counted : DuplexModeGame.Counts remaining program) : + let compiled := PublicCompressionCouplingMixed.compile B iv [] program remaining limit counted + publicCapture (B := B) p grinding shape headerFrames boundary iv ref + (Sampling.eval (PublicCompressionCouplingMixed.oracle seed ro) compiled) = + capture p grinding shape headerFrames boundary iv ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle seed ro) compiled).2 := by + dsimp only [publicCapture] + rw [PCSBCSNativePublicCapture.mixedTrace_actual B seed ro iv [] program remaining limit counted] + +end References + +/-! ## Recovery at the first physical occurrence (generic IV) -/ + +section Recovery + +private theorem body_mono {small large : DuplexPublicSimulator.PublicLog} + (sub : ∀ e ∈ small, e ∈ large) {cv : Digest32} {ns : List Node} + (body : DuplexPublicSimulator.PublicBody small cv ns) : + DuplexPublicSimulator.PublicBody large cv ns := by + induction body with + | seed member seed => exact .seed (sub _ member) seed + | step member internal child ih => exact .step (sub _ member) internal ih + +private theorem functional_of_auth (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) : DuplexPublicSimulator.Functional log := by + intro n a b ha hb + exact (auth n a ha).symm.trans (auth n b hb) + +private theorem simulator_lookup_eq (log : PublicLog) (n : Node) : + DuplexPublicSimulator.lookup log n = PublicMerkleLog.lookup log n := by + induction log with + | nil => rfl + | cons record log ih => + rcases record with ⟨m,d⟩ + by_cases same : n = m + · simp [DuplexPublicSimulator.lookup,PublicMerkleLog.lookup,List.find?,same] + · have other : m ≠ n := Ne.symm same + simp [DuplexPublicSimulator.lookup,PublicMerkleLog.lookup,List.find?,same,other] at ih ⊢ + exact ih + +/-- `PCSBCSSourceRootAdmission.first_recovery` for an arbitrary IV: the quiet alarm recovers the coordinate at the first physical occurrence of its terminal, from the strictly older log. -/ +theorem first_recovery (C : PrimitiveOracle) (roots : PublicMerkleProbability.RootPolicy) + (B : Nat) (iv : Digest32) (log : PublicLog) (auth : AuthenticLog C log) + (quiet : PublicMerkleProbability.traceAlarm roots [] log.reverse = false) + (budget : log.length ≤ B) (input : Node) (rest : List Node) + (terminal : isTerminal input) + (body : DuplexPublicSimulator.PublicBody log input.cv rest) + (present : (input,C input) ∈ log) (q : Coordinate) + (valid : DuplexEncoding.Admissible q) + (extracted : extract (input::rest) = some (modeKey iv q)) : + ∃ newer older, log = newer ++ (input,C input)::older ∧ + PCSBCSSourceCoordinateDecoder.recover B iv older input = some q := by + induction log with + | nil => cases present + | cons record log ih => + rcases record with ⟨n,d⟩ + have answer := auth n d List.mem_cons_self + subst d + have oldAuth : AuthenticLog C log := fun n d h => auth n d (List.mem_cons_of_mem _ h) + have oldBudget : log.length ≤ B := by simp only [List.length_cons] at budget; omega + have parts := quiet + rw [List.reverse_cons,PublicMerkleProbability.traceAlarm_append] at parts + simp only [Bool.or_eq_false_iff,List.reverse_reverse,List.append_nil, + PublicMerkleProbability.traceAlarm,Bool.or_false,decide_eq_false_iff_not] at parts + have oldQuiet := parts.1 + have safe := parts.2 + cases hit : PublicMerkleLog.lookup log n with + | some d => + have old := PublicMerkleLog.lookup_mem hit + have same := oldAuth n d old + rw [← same] at old + have oldBody := PublicCompressionCouplingRecognition.PublicBody.erase_repeat old body + have oldPresent : (input,C input) ∈ log := by + rcases List.mem_cons.mp present with equal | member + · cases equal; exact old + · exact member + obtain ⟨newer,older,equal,recovered⟩ := ih oldAuth oldQuiet oldBudget oldBody oldPresent + exact ⟨(n,C n)::newer,older,by simp only [List.cons_append,equal],recovered⟩ + | none => + by_cases same : n = input + · subst n + have oldBody := PublicCompressionCouplingRecognition.PublicBody.erase_terminal terminal body + have clean : ¬ DuplexPublicSimulator.OutputCollision log := by + have h := PublicMerkleProbability.traceAlarm_clean C roots [] log.reverse + (by intro n d h; cases h) + (fun n d h => oldAuth n d (List.mem_reverse.mp h)) + (by rintro ⟨a,b,d,h,_⟩; cases h) oldQuiet + simp only [List.reverse_reverse,List.append_nil] at h + exact fun ⟨a,b,d,ha,hb,ne⟩ => h ⟨a,b,d,ha,hb,ne⟩ + have recognized := DuplexPublicSimulator.recognized_complete + (functional_of_auth C log oldAuth) clean terminal oldBody + obtain ⟨key,found,keyExtracted⟩ := DuplexPublicSimulator.privateKey_of_recognized + (by simpa only [simulator_lookup_eq] using hit) recognized budget + have keySame : expandKey key = modeKey iv q := + Option.some.inj (keyExtracted.symm.trans extracted) + exact ⟨[],log,rfl,PCSBCSSourceCoordinateDecoder.recover_of_modeKey found valid keySame⟩ + · have oldPresent : (input,C input) ∈ log := by + rcases List.mem_cons.mp present with equal | member + · exact False.elim (same (congrArg Prod.fst equal).symm) + · exact member + have avoid : ∀ m d, (m,d) ∈ log → C n ≠ m.cv := by + intro m d member equal + apply safe + refine ⟨hit,?_⟩ + apply Finset.mem_union_right + apply Finset.mem_union_right + rw [equal] + exact List.mem_toFinset.mpr (List.mem_map.mpr ⟨(m,d),member,rfl⟩) + have oldBody := PublicCompressionCouplingRecognition.PublicBody.erase_record body avoid + (avoid input (C input) oldPresent) + obtain ⟨newer,older,equal,recovered⟩ := ih oldAuth oldQuiet oldBudget oldBody oldPresent + exact ⟨(n,C n)::newer,older,by simp only [List.cons_append,equal],recovered⟩ + +end Recovery + +/-! ## Physical freeze and admission -/ + +section Admission +variable (p : ParameterBounds.Profile) (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (shape : SpongefishSessionAdapter.Shape) (headerFrames boundary : Nat) + +/-- A physically recorded terminal with its complete public body announces every reference of its coordinate. -/ +theorem tree_target (Q : Nat) (iv : Digest32) (C : PrimitiveOracle) (log : PublicLog) + (auth : AuthenticLog C log) + (quiet : PublicMerkleProbability.traceAlarm + (targets p grinding shape headerFrames boundary Q iv) [] log.reverse = false) + (budget : log.length ≤ Q) (input : Node) (rest : List Node) + (terminal : isTerminal input) (body : DuplexPublicSimulator.PublicBody log input.cv rest) + (present : (input,C input) ∈ log) (q : Coordinate) (valid : DuplexEncoding.Admissible q) + (extracted : extract (input::rest) = some (modeKey iv q)) + (ref : Reference) (member : ref ∈ coordinateReferences p grinding shape headerFrames boundary q) : + ref.root ∈ targets p grinding shape headerFrames boundary Q iv log := by + obtain ⟨newer,older,equal,recovered⟩ := first_recovery C _ Q iv log auth quiet budget + input rest terminal body present q valid extracted + have announced : ref.root ∈ targets p grinding shape headerFrames boundary Q iv ((input,C input)::older) := by + simp only [targets,scan,List.mem_toFinset,List.mem_append] + right + simp only [rootsAt,recovered,Option.map_some,Option.getD_some,List.mem_map] + exact ⟨ref,member,rfl⟩ + rw [equal] + exact targets_append p grinding shape headerFrames boundary Q iv newer _ announced + +/-- An actual mixed draw mentioning a reference was preceded by the physical calls announcing its root. -/ +theorem draw_admission (B : Nat) (iv : Digest32) (C : PrimitiveOracle) + (earlier cache : PublicLog) (current : Observation) + (event : SpongefishCurrentPhysicalRootCapture.Event B) + (cacheSub : ∀ e ∈ cache, e ∈ earlier) + (auth : AuthenticLog C (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv current.query)) + (quiet : PublicMerkleProbability.traceAlarm + (targets p grinding shape headerFrames boundary B iv) [] + (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv current.query) = false) + (budget : (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv current.query).length ≤ B) + (draw : PCSBCSNativePublicCapture.observationDraw B iv cache current = [event]) + (ref : Reference) + (mentioned : ref ∈ addresses p grinding shape headerFrames boundary iv event.1) : + ref.root ∈ targets p grinding shape headerFrames boundary B iv + (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv current.query).reverse := by + rcases event with ⟨raw,answer⟩ + cases raw with + | inl node => simp [addresses] at mentioned + | inr key => + cases decoded : WHIRHeaderRoots.decodeRaw iv key with + | none => simp [addresses,decoded] at mentioned + | some q => + have member : ref ∈ coordinateReferences p grinding shape headerFrames boundary q := by + simpa only [addresses,decoded] using mentioned + obtain ⟨bound,valid,keyEq⟩ := WHIRHeaderRoots.decodeRaw_sound iv key q decoded + have prefixAuth : AuthenticLog C + (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv current.query).reverse := + fun n d h => auth n d (List.mem_reverse.mp h) + have prefixQuiet : PublicMerkleProbability.traceAlarm + (targets p grinding shape headerFrames boundary B iv) [] + ((earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv current.query).reverse).reverse = + false := by + simpa only [List.reverse_reverse] using quiet + have prefixBudget : + (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv current.query).reverse.length ≤ B := by + simpa only [List.length_reverse] using budget + rcases current with ⟨query,d⟩ + cases query with + | primitive purpose input => + unfold PCSBCSNativePublicCapture.observationDraw at draw + cases hit : DuplexPublicSimulator.lookup cache input with + | some old => simp [hit] at draw + | none => + cases found : DuplexPublicSimulator.privateKey B cache input with + | none => + simp only [hit,found,List.singleton_inj] at draw + have impossible := congrArg Sigma.fst draw + cases impossible + | some actual => + simp only [hit,found,List.singleton_inj] at draw + have keys : actual = key := Sum.inr.inj (congrArg Sigma.fst draw) + subst keys + obtain ⟨nodes,recognized,complete,extracted⟩ := DuplexPublicSimulator.privateKey_sound found + obtain ⟨rest,rfl,body⟩ := DuplexPublicSimulator.recognized_publicBody recognized + have terminal : isTerminal input := by + obtain ⟨n,ns,equal,terminal,_⟩ := complete + cases equal + exact terminal + have publicBody : DuplexPublicSimulator.PublicBody + (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv + (.primitive purpose input)).reverse input.cv rest := + body_mono (fun e he => List.mem_reverse.mpr (List.mem_append_left _ (cacheSub e he))) body + have recorded : (input,C input) ∈ + (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv + (.primitive purpose input)).reverse := + List.mem_reverse.mpr (List.mem_append_right _ List.mem_cons_self) + have sourceExtract : extract (input::rest) = some (modeKey iv q) := by + rw [← keyEq] at extracted + exact extracted.trans (congrArg some (expand_constructionKey B iv q bound)) + exact tree_target p grinding shape headerFrames boundary B iv C _ prefixAuth prefixQuiet + prefixBudget input rest terminal publicBody recorded q valid sourceExtract ref member + | construction coordinate coordinateValid => + by_cases coordinateBound : pathCost coordinate ≤ B + · simp only [PCSBCSNativePublicCapture.observationDraw,coordinateBound,↓reduceDIte, + List.singleton_inj] at draw + have keys : constructionKey B iv coordinate coordinateBound = key := + Sum.inr.inj (congrArg Sigma.fst draw) + have same : q = coordinate := by + rw [← keys,WHIRHeaderRoots.decodeRaw_construction iv coordinate coordinateValid + coordinateBound] at decoded + exact (Option.some.inj decoded).symm + subst same + obtain ⟨body,recorded⟩ := PCSBCSSourceRootAdmission.construction_body C iv q coordinateValid + (earlier ++ PCSBCSConstructionReplayTrace.queryTrace C iv (.construction q coordinateValid)).reverse + (fun e he => List.mem_reverse.mpr (List.mem_append_right _ he)) + have cv : (terminalNode + (traceHistory (compressionOf C) iv q.history).state.cv q.terminal).cv = + (traceHistory (compressionOf C) iv q.history).state.cv := by + cases q.terminal <;> rfl + rw [← cv] at body + have terminal := terminal_node (traceHistory (compressionOf C) iv q.history).state.cv q.terminal + have extracted := coordinateTree_key (compressionOf C) iv q coordinateValid + exact tree_target p grinding shape headerFrames boundary B iv C _ prefixAuth prefixQuiet + prefixBudget _ _ terminal body recorded q valid extracted ref member + · simp [PCSBCSNativePublicCapture.observationDraw,coordinateBound] at draw + +private theorem ordinaryLog_captureFrom {B : Nat} + (events : List (SpongefishCurrentPhysicalRootCapture.Event B)) (prior : PublicLog) : + events.foldl SpongefishCurrentPhysicalRootCapture.ordinaryStep prior = + events.foldl (fun log event => PCSBCSNativePublicCapture.rawOrdinary event ++ log) prior := by + induction events generalizing prior with + | nil => rfl + | cons event rest ih => + simp only [List.foldl_cons] + rw [ih] + congr 1 + rcases event with ⟨raw,answer⟩ + cases raw <;> rfl + +/-- Actual first mention in the compiled real execution: exact physical freeze of the primitive log, with the reference root admitted by the policy before the freeze point. -/ +theorem actual_firstMention_admitted {R : Type} (B : Nat) (iv : Digest32) (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (ref : Reference) (events : List (SpongefishCurrentPhysicalRootCapture.Event B)) + (mentioned : firstPrefix p grinding shape headerFrames boundary iv ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)).2 = some events) + (quiet : PublicMerkleProbability.traceAlarm + (targets p grinding shape headerFrames boundary B iv) [] + (PublicCompressionProgram.primitiveLog C iv program A counted) = false) : + ∃ frozen : PCSBCSNativePhysicalFreeze.PhysicalFreeze + (PublicCompressionProgram.primitiveLog C iv program A counted) + (SpongefishCurrentPhysicalRootCapture.ordinaryLog events), + ref.root ∈ targets p grinding shape headerFrames boundary B iv frozen.before.reverse := by + have realView : + Sampling.eval (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted) = + (runReal C iv program).view := by + rw [PublicCompressionCouplingMixed.compile_actual] + exact WHIRRealSimulator.runIdeal_view C iv _ ⟨rfl,by simp⟩ _ _ limit _ + have trace := PCSBCSNativePublicCapture.mixedTrace_actual B C (WHIRRealSimulator.rawTable B C) + iv [] program A limit counted + rw [realView] at trace + rw [firstPrefix,trace] at mentioned + obtain ⟨earlier,current,later,cache,event,split,draw,addressed,cacheSub,auth,sub,sat⟩ := + PCSBCSNativePhysicalFreeze.firstPrefix_freeze B C iv + (addresses p grinding shape headerFrames boundary iv) ref (fun _ => by simp [addresses]) + (runReal C iv program).view.observations [] [] [] + ⟨by simp [AuthenticLog],by simp,by simp,by simp⟩ (by simp) + (fun o member => PCSBCSConstructionReplayTrace.observation_answer C iv program o member) + events mentioned + have logSplit : PublicCompressionProgram.primitiveLog C iv program A counted = + (PCSBCSNativePhysicalFreeze.physicalTrace C iv earlier ++ + PCSBCSConstructionReplayTrace.queryTrace C iv current.query) ++ + PCSBCSNativePhysicalFreeze.physicalTrace C iv later := by + rw [PCSBCSNativePhysicalFreeze.physicalTrace_actual,split] + simp only [PCSBCSNativePhysicalFreeze.physicalTrace,List.flatMap_append,List.flatMap_cons, + List.append_assoc] + have ordinary : SpongefishCurrentPhysicalRootCapture.ordinaryLog events = + PCSBCSNativePhysicalFreeze.captureFrom events [] := + ordinaryLog_captureFrom events [] + have prefixAuth : AuthenticLog C (PCSBCSNativePhysicalFreeze.physicalTrace C iv earlier ++ + PCSBCSConstructionReplayTrace.queryTrace C iv current.query) := by + intro n d member + apply PublicCompressionProgram.primitiveLog_authentic C iv program A counted n d + rw [logSplit] + exact List.mem_append_left _ member + have prefixQuiet : PublicMerkleProbability.traceAlarm + (targets p grinding shape headerFrames boundary B iv) [] + (PCSBCSNativePhysicalFreeze.physicalTrace C iv earlier ++ + PCSBCSConstructionReplayTrace.queryTrace C iv current.query) = false := by + rw [logSplit,PublicMerkleProbability.traceAlarm_append] at quiet + exact (Bool.or_eq_false_iff.mp quiet).1 + have prefixBudget : (PCSBCSNativePhysicalFreeze.physicalTrace C iv earlier ++ + PCSBCSConstructionReplayTrace.queryTrace C iv current.query).length ≤ B := by + have bound := PublicCompressionProgram.primitiveLog_length C iv program A counted + rw [logSplit,List.length_append] at bound + omega + have target := draw_admission p grinding shape headerFrames boundary B iv C _ cache current event + (by simpa only [List.nil_append] using cacheSub) prefixAuth prefixQuiet prefixBudget draw ref addressed + refine ⟨⟨_,_,logSplit,?_,?_⟩,target⟩ + · rw [ordinary] + simpa only [List.nil_append] using sub + · rw [ordinary] + simpa only [List.nil_append] using sat + +/-- The quiet trace alarm excludes every retained primitive opening event against the first-mention frozen ordinary log, for every counted program. -/ +theorem opening_quiet {R : Type} (B : Nat) (iv : Digest32) (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (ref : Reference) (events : List (SpongefishCurrentPhysicalRootCapture.Event B)) + (mentioned : firstPrefix p grinding shape headerFrames boundary iv ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)).2 = some events) + (quiet : PublicMerkleProbability.traceAlarm + (targets p grinding shape headerFrames boundary B iv) [] + (PublicCompressionProgram.primitiveLog C iv program A counted) = false) + (output : List MerkleTransport.RawPath) + (bounds : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (hash C)), + bytes.length < 2^56) + (plans : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (hash C)), + ∀ e ∈ plan C bytes, e ∈ PublicCompressionProgram.primitiveLog C iv program A counted) : + ¬ PublicMerkleBinding.OpenPrimitiveBad C + (SpongefishCurrentPhysicalRootCapture.ordinaryLog events) ref.root output := by + intro bad + obtain ⟨frozen,registered⟩ := actual_firstMention_admitted p grinding shape headerFrames boundary + B iv C program A limit counted ref events mentioned quiet + have alarm := PublicMerkleProbability.opening_alarm C + (targets p grinding shape headerFrames boundary B iv) + (targets_grow p grinding shape headerFrames boundary B iv) + (PublicCompressionProgram.primitiveLog C iv program A counted) + (PublicCompressionProgram.primitiveLog_authentic C iv program A counted) + ⟨frozen.before,frozen.after,_,ref.root,output,frozen.split,frozen.captured, + frozen.saturated,registered,bounds,plans,bad⟩ + rw [quiet] at alarm + cases alarm + +/-- The same exclusion stated on the frozen capture itself. -/ +theorem captured_opening_quiet {R : Type} (B : Nat) (iv : Digest32) (C : PrimitiveOracle) + (program : Program R) (A : Nat) (limit : A ≤ B) (counted : Counts A program) + (ref : Reference) (frozen : Frozen) + (found : capture p grinding shape headerFrames boundary iv ref + (Sampling.execute (PublicCompressionCouplingMixed.oracle C (WHIRRealSimulator.rawTable B C)) + (PublicCompressionCouplingMixed.compile B iv [] program A limit counted)).2 = some frozen) + (quiet : PublicMerkleProbability.traceAlarm + (targets p grinding shape headerFrames boundary B iv) [] + (PublicCompressionProgram.primitiveLog C iv program A counted) = false) + (output : List MerkleTransport.RawPath) + (bounds : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (hash C)), + bytes.length < 2^56) + (plans : ∀ path ∈ output, ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (hash C)), + ∀ e ∈ plan C bytes, e ∈ PublicCompressionProgram.primitiveLog C iv program A counted) : + frozen = freeze frozen.queryPrefix ref.root ref.shape ∧ + ¬ PublicMerkleBinding.OpenPrimitiveBad C frozen.queryPrefix ref.root output := by + obtain ⟨events,mentioned,equal⟩ := Option.map_eq_some_iff.mp found + subst frozen + exact ⟨rfl,opening_quiet p grinding shape headerFrames boundary B iv C program A limit counted + ref events mentioned quiet output bounds plans⟩ + +end Admission + +#print axioms levelShape_geometry +#print axioms levelShape_phase +#print axioms root0_geometry +#print axioms levelRoot_reply +#print axioms levelRoot_fold_reply +#print axioms frames_pathCost +#print axioms references_length +#print axioms anchor_mem +#print axioms level_mem +#print axioms coordinateReferences_length +#print axioms rootsAt_length +#print axioms scan_length +#print axioms targets_grow +#print axioms targets_cap +#print axioms targets_append +#print axioms firstPrefix_source +#print axioms publicCapture_source +#print axioms first_recovery +#print axioms tree_target +#print axioms draw_admission +#print axioms actual_firstMention_admitted +#print axioms opening_quiet +#print axioms captured_opening_quiet + +end Whir.SpongefishCurrentRootPolicy From 8198d0b29e53a8c04b50d73bc76f4c5c4c4f1343 Mon Sep 17 00:00:00 2001 From: Kevaundray Wedderburn Date: Mon, 12 Oct 2026 17:30:09 +0100 Subject: [PATCH 28/28] proof: discharge Refines for the current opening and state the final knowledge bound A per-coin builder reconstructs each opening packet's incoming caller data from the erased table (caller original, first-mention root captures, earlier packet answers, replies parsed from the packet history). On every ideal table where the public good event fires this gives the state path, so current_knowledge bounds native acceptance with public extraction failure by the sum over the four binding shapes of finalBound, and current_knowledge_bits gives 2^-lambda for per-shape budgets up to 2^(49-lambda). --- verification/whir/README.md | 12 +- verification/whir/Whir.lean | 5 + .../Whir/SpongefishCurrentHeaderGlue.lean | 535 +++++ .../Whir/SpongefishCurrentHistoryReplies.lean | 2003 +++++++++++++++++ .../whir/Whir/SpongefishCurrentIdealRows.lean | 984 ++++++++ .../SpongefishCurrentKnowledgeEndpoint.lean | 2 +- .../Whir/SpongefishCurrentKnowledgeFinal.lean | 187 ++ .../whir/Whir/SpongefishCurrentRefines.lean | 1159 ++++++++++ 8 files changed, 4881 insertions(+), 6 deletions(-) create mode 100644 verification/whir/Whir/SpongefishCurrentHeaderGlue.lean create mode 100644 verification/whir/Whir/SpongefishCurrentHistoryReplies.lean create mode 100644 verification/whir/Whir/SpongefishCurrentIdealRows.lean create mode 100644 verification/whir/Whir/SpongefishCurrentKnowledgeFinal.lean create mode 100644 verification/whir/Whir/SpongefishCurrentRefines.lean diff --git a/verification/whir/README.md b/verification/whir/README.md index 52fb7ed15..c9d150e4b 100644 --- a/verification/whir/README.md +++ b/verification/whir/README.md @@ -162,7 +162,9 @@ The current decoder also recognizes saved records at the end of a public absorb- `SpongefishCurrentOpeningProgram.fullProgram` is the counted current source program followed by a public opening walk: after an accepted replay it re-walks the opening schedule over the replay's recorded source events (exactly one event per call, `actualReplay_events`, `program_events`) and authenticates every query batch with the existing `WHIRPhysicalVerifier.openRows` hash programs, so the opening's Merkle hashes are observations of the counted program. Its budget `fullBudget` is the previous budget plus a uniform public Merkle budget (`fullProgram_counted`), and the initialized byte-mode coupling applies unchanged (`fullProgram_mode_bound`). `walk_native` and `fullProgram_native` show that on the real primitive the walk returns exactly the native `Accepted.collected`, with every hashed input's compression plan in the program's primitive log and shorter than `2^56` bytes. `SpongefishCurrentRootPolicy.targets` is the current root policy: it recovers construction coordinates from the newest-first public primitive log and collects Root0 (the commitment header frame) and every announced level root (bytes 48 to 80 of the reply frame after a level-ending fold); `targets_grow` and `targets_cap` (`Q(Q+1)`) hold, and `actual_firstMention_admitted` and `captured_opening_quiet` port the historical physical freeze and admission to current raw keys. -`SpongefishCurrentKnowledgeEndpoint.full_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript. Its real event is native acceptance of the whole current caller path and opening while the public straight-line extractor fails (`SpongefishCurrentGoodEvent.ExtractionFails`: Root0 frozen at the first key whose history mentions it, then the source extractor on the frozen image). Its probability is at most `finalBound Q = Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256` with `Q = fullBudget`, the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. The reduction is proved (`reduction_full`): real native acceptance with extraction failure is the public good event `SpongefishCurrentGoodEvent.GoodFull` (accepted replay and walk, the caller original reconstructed publicly at the post-binding coordinate, the native opening equations, extraction failure, no public ordinary output collision, every query opening quiet against the frozen first-mention log of its root) or raises the complete Merkle trace alarm. Opening coverage (`opening_cover`) and collisions (`SpongefishCurrentBCSKnowledge.collision_alarm`) both reach the alarm; `postBinding_native` proves the static frame boundary of the post-binding coordinate. The endpoint is **conditional** on exactly one named refinement obligation, a hypothesis and not a probability premise: `Refines` (on every ideal table where the good event fires, the current node model with some per-coin caller-data builder has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. A received record has at most three normalized pending packs (`accepted_packs`), so its binding calls are one of four literal lists (`messageCalls_binding`); `messages_binding_full` and `nativeAnyFull_union` give `full_knowledge_all`, which bounds native acceptance with extraction failure for every received record by the sum of the four per-shape bounds, and `full_knowledge_level` evaluates it at the deployed grinding as at most the sum of the four `Q_k/2^51` when each per-shape budget is at most `2^64`. +`SpongefishCurrentKnowledgeEndpoint.full_knowledge_bound` is the basic full-prefix BCS endpoint (`remark:bcs-with-basic-fs`) for the current transcript. Its real event is: the caller tape replays and the record binding verifies on the real primitive, the PCS opening is natively accepted (query proof of work, Merkle authentication of every query batch, anchored native equations), and the public straight-line extractor fails (`SpongefishCurrentGoodEvent.ExtractionFails`: Root0 frozen at the first key whose history mentions it, then the source extractor on the frozen image). Its probability is at most `finalBound Q = Q*((17/32)^56+2^-78) + min(1,(2Q^2-Q)/2^256) + (Q^3+3Q^2-2Q)/2^256` with `Q = fullBudget`, the aggregate attacker-plus-verifier primitive-work budget, and there is no hash-chain term. The reduction is proved (`reduction_full`): the real event is the public good event `SpongefishCurrentGoodEvent.GoodFull` (accepted replay and walk, the caller original reconstructed publicly at the post-binding coordinate, the native opening equations, extraction failure, no public ordinary output collision, every query opening quiet against the frozen first-mention log of its root) or raises the complete Merkle trace alarm. Opening coverage (`opening_cover`) and collisions (`SpongefishCurrentBCSKnowledge.collision_alarm`) both reach the alarm; `postBinding_native` proves the static frame boundary of the post-binding coordinate. This endpoint takes one named refinement obligation, a hypothesis and not a probability premise: `Refines` (on every ideal table where the good event fires, the current node model with some per-coin caller-data builder has a state path from an undoomed to a doomed state). `finalBound_le` evaluates the bound: for every budget `Q <= 2^64` it is at most `Q/2^51`, so `2^20` units give at most `2^-31` and `2^40` units at most `2^-11` (`finalBound_levels`). The query table is unchanged between the historical source pin and the deployed upstream, and deployed query grinding is 17 bits at every level; the bound takes no grinding credit. A received record has at most three normalized pending packs (`accepted_packs`), so its binding calls are one of four literal lists (`messageCalls_binding`); `messages_binding_full` and `nativeAnyFull_union` give `full_knowledge_all`, which bounds the event for every received record by the sum of the four per-shape bounds, and `full_knowledge_level` evaluates it at the deployed grinding as at most the sum of the four `Q_k/2^51` when each per-shape budget is at most `2^64`. + +`SpongefishCurrentKnowledgeFinal.current_knowledge` discharges `Refines`, so the current #607 knowledge bound holds in the ideal-compression model with only static public premises. For every attacker coin and binding message shape, `SpongefishCurrentRefines.builder` reconstructs the incoming caller data of each opening packet from the table with that packet erased: the caller original by `SpongefishCurrentCallerOriginalTable.tableCandidate` on caller-path answers, Root0 and every announced level root by first-mention captures on the erased table (`SpongefishCurrentPartitionCapture.pcapture_erased`, since every packet history mentions them), the tape from the earlier packets' table entries, and the incoming replies parsed from the packet history by `SpongefishCurrentHistoryReplies.historyReplies`, with query rows and next-level oracles taken from the frozen captures. On every ideal table where the good event fires, `SpongefishCurrentOpeningPackets.opening_packets` exposes one packet per schedule coordinate (every deployed coordinate has a positive raw width, `SpongefishCurrentRefines.widths_deployed`), `builder_exact` identifies each reconstruction with the literal incoming data, Merkle quietness against the frozen first-mention logs authenticates the opened rows (`SpongefishCurrentIdealRows.ideal_rows`), and the native opening equations with public extraction failure make the terminal state doomed (`good_terminal`), so `refines_full` gives the state path. The static premises are a nonempty instance, the caller prelude and payload call shapes, and `Supported p (AnchoredSourceCaller.shape layout)` (a valid caller shape whose dimension, batch and rate match the profile). The bound is the sum over the four binding message shapes of `finalBound Q_k`. At the deployed 17-bit grinding, `current_knowledge_level` gives at most `B/2^49` when every per-shape budget is at most `B <= 2^64`, and `current_knowledge_bits` gives at most `2^-λ` when every per-shape budget is at most `2^(49-λ)`: per-shape budgets of `2^29` units give `2^-20` and `2^39` units give `2^-10`. The level includes the union over the four shapes and takes no grinding credit. Scope: the instance, tag, session IV, caller layout and Merkle hint wire decoder (an arbitrary parameter) are fixed before the attacker runs; caller-side proof of work and caller equations are not part of the event, which only enlarges it; each per-shape budget counts attacker work plus a worst-case charge for verifier replay and Merkle work that is not evaluated here for deployed layouts; and completeness of the opening model (acceptance of an honest prover) is not proved here. Executable paths that previously returned or retained a digest or squeeze output as a closure, and so recomputed earlier compressions at each use, now store the computed values as data. Each stored form is selected for compiled code by `@[csimp]` with a kernel-checked equality to the unchanged semantic definition (for example `DuplexRefinement.materialize_memo`, `stream_memo`, `DuplexFraming.evalPlan_stored`, `PublicMerkleLog.ordinaryPlan_stored` and the observed session traces), so every theorem about the semantic definitions applies to the executed code unchanged. @@ -218,13 +220,13 @@ SHA-256 of the inspected PDF bytes: WHIR `ccacc62cf5529ff95c3cf115cf730b020336f8 The proved mathematical boundary includes concrete K/E field laws, the Lean additive encoder's RS interpretation, actual length-checked verifier refinement, the ring-map error bound, Johnson/MCA and OOD instantiations, adaptive interactive list binding, typed and exact-raw oracle bounds, native scalar arithmetic, original CPU/recursion caller construction, public source reconstruction, first-frozen Merkle transport, and the strengthened shared-compression collision/target-hit probability bound. The remaining categories are separate: -- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are now separately checked. Their actual-source replay and probability composition is not yet complete. In particular, source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values; arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript, an accepted caller path now reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`); the native opening adapter (`SpongefishCurrentOpeningAcceptance.accepted_opening_original`) and its distributional source join (`SpongefishCurrentSourceJoinProbability.native_ideal_bound`) are proved, and the basic full-prefix endpoint `SpongefishCurrentKnowledgeEndpoint.full_knowledge_bound`, for the full source program whose opening Merkle hashes are counted observations, is proved with the reduction (including opening coverage under the current root policy) discharged and conditional on the single named refinement obligation `Refines`. `Refines` and the Merkle hint wire codec remain open; `full_knowledge_all` removes the fixed record-binding message shape by a union over its four possible shapes. +- **Fiat-Shamir knowledge composition:** the checked original reset extractor is interactive only. The additive source RBR knowledge predicate, coin-free full-root decoder, literal public-state lift, frozen Merkle-query-log reconstruction and PCS round grouping are separately checked. For the historical #552 transcript their actual-source replay and probability composition is not complete; source duplex history keys retain prior prover frames and squeeze counts, not previous verifier-answer values, and arbitrary child-prefix prequeries cannot be excluded or silently identified with the book's explicit hash chain. For the current #607 transcript the composition is complete in the basic full-prefix form: an accepted caller path reaches the public original list (`SpongefishCurrentAcceptedJoin.accepted_original`), the native opening adapter (`SpongefishCurrentOpeningAcceptance.accepted_opening_original`) and its distributional source join (`SpongefishCurrentSourceJoinProbability.native_ideal_bound`) are proved, the reduction of `SpongefishCurrentKnowledgeEndpoint.full_knowledge_bound` (including opening coverage under the current root policy) is proved, and `SpongefishCurrentKnowledgeFinal.current_knowledge` discharges `Refines`, so the bound holds under static public premises only. Prequeries are admitted throughout: first-mention captures freeze each root before any packet that mentions it. The Merkle hint wire decoder remains an arbitrary parameter rather than the Rust `from_hint` byte format. - **Concrete cryptography:** `ConcretePrimitiveGap Q registry.iv primitiveLoss Allowed` and membership of the final native event in `Allowed`. The new known-answer theorem prevents a small loss for ordinary efficient full-view classes. The formal concrete endpoint remains conditional; a justified final-event computational assumption or standard-assumption reduction is missing. Neither collision resistance nor arbitrary exclusion of the observer is supplied as a substitute. - **Resource/model domain:** the native endpoint retains `before` (`Counts a` for every attacker coin), `verifierBudget` (reachable `WHIRPhysicalVerifier.sourceBudget <= b`), `paths` (reachable terminal `pathCost <= Mf`), `announcements` (`FreeAnnouncements free`), and `envelope` (`WHIRSourceBackfill.budget context (a+b) Mf <= Q`). Finite coins, caller output caps, valid caller shapes and first-registration semantics belong to the mathematical experiment. These are not small-gap crypto assumptions. - **Implementation/compiler correspondence:** natural-number Lean shape arithmetic does not prove arbitrary malformed `usize` shifts/additions safe. The historical source pin's selector guard is weaker than `Shape`; #599 now adds alignment and strided-slot checks, but its new typed APIs, closed-form lane fold, query normalization and error behavior have not been universally refined by this draft. Valid constructed CPU/recursion layouts and arbitrary public PCS statements must not be conflated. The optimized/streamed Rust NTT/commitment kernels, universal Rust-to-Lean refinement, compilation and runtime remain outside the kernel conclusion. -- **Deployment/security target:** the public mode theorem models the pre-#607 #552 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not currently apply to the #607 session-IV and raw-byte transcript, cover the new anchor frames or establish deterministic BLAKE2s security. For #607, `full_knowledge_bound` gives the explicit three-term bound conditional on its one refinement obligation `Refines`; numerically it is at most `Q/2^51` per binding message shape for `Q <= 2^64`. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. +- **Deployment/security target:** the public mode theorem models the pre-#607 #552 byte duplex at `f11f84f585680cf10f676bb4d9ae1a67e26547ca`. Its conditional `2^-42` endpoint uses the corrected, proved ideal-compression coupling and stated source, valid-state and resource premises, and concerns the modeled unanchored native event. It does not apply to the #607 session-IV and raw-byte transcript, cover the new anchor frames or establish deterministic BLAKE2s security. For #607, `SpongefishCurrentKnowledgeFinal.current_knowledge` gives the explicit bound, the sum over the four binding message shapes of the three-term `finalBound Q_k`, in the ideal-compression model with only static public premises; numerically it is at most `B/2^49` when every per-shape budget is at most `B <= 2^64`, that is `2^-λ` for per-shape budgets up to `2^(49-λ)`. This is a knowledge error for the accepted opening with public straight-line extraction failure, for an instance and caller layout fixed before the attacker runs and with the scope limits stated above (caller-side proof of work and equations not checked, worst-case verifier work charge, opening-model completeness not proved); it is not a concrete BLAKE2s security level. Ground list binding is not unique binding. No grinding amplification or numerical 128 bit whole system security conclusion is asserted. -Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the historical #552 byte-duplex framing and the proved adaptive ideal-compression coupling. The #607 session-IV seed and raw-byte root absorption, additional anchor inputs, their cursor-based sampling, updated source-event refinement and Fiat-Shamir knowledge extraction remain separate composition obligations. +Merkle transport gives a fixed first-registration row oracle or explicit primitive-game failures. It does not assert collision resistance as a field axiom or equate collision resistance with random-oracle behavior. The mathematical production driver, caller geometry, physical source, observable reconstruction and final probability composition are included through the `WHIRNativeSecurity` root import. That chain uses the historical #552 byte-duplex framing and the proved adaptive ideal-compression coupling. The #607 session-IV seed and raw-byte root absorption, additional anchor inputs, cursor-based sampling and Fiat-Shamir knowledge extraction are modeled and composed separately by the hand-ported `SpongefishCurrent` modules, ending at `SpongefishCurrentKnowledgeFinal.current_knowledge`; universal Rust-to-Lean refinement of those adapters remains separate. Malformed proof/query counts, final scalar counts, OOD point dimensions and answers are exercised by the executable model. The ideal transport has explicit structured failure results; it does not claim the same byte decoding error taxonomy or underflow behavior as production `TranscriptError`. The historical Rust smoke separately uses the actual stack opening prover/verifier and its malformed/tampered inputs. No universal Rust source refinement or byte for byte theorem for all deployed callers is claimed. @@ -266,7 +268,7 @@ Its checked `random_compression_failure_probability` bounds acceptance with no o `PCSBCSPublicExtractorCost.extract_polynomial_cost` gives the same implemented output and a closed physical-input polynomial for all supported profiles. It charges actual key recognition, one pending parse, both coordinate encodings, every failed or repeated observation, strict first capture, caller decoding/preparation, a full public-answer scan per actual byte callback, padded Merkle recovery, Gao/base-word decoding and all original checks. The physical endpoint requires the encoded caller-entry cursor domain and declared occupied-lane geometry, not accepted or authentic input; a numeric-cursor-volume bound also covers inputs outside that codec domain. Reached metadata getters and original access retain explicit prices, with linked-list getter traversal charged rather than assumed constant. This is immutable-input/unit-primitive and field-operation accounting, not native machine time or unbounded prover CPU. -The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **15794 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. +The final warning-denied library, Main and compiled-model closure passed, including every registered executable, and `Audit.lean` checked **16213 exported Whir theorem declarations**, including generated declarations, permitting only `propext`, `Classical.choice` and `Quot.sound`. With executable digests stored as data, sixteen compiled scenarios then completed within the bounded runtime invocation: the multilevel model, the current real-BLAKE2s adapter, the current record codec (all 65 pending-buffer lengths with both first flags), the literal current caller reconstruction (actual initialized prelude, raw-root anchor receive, full caller and opening-record fields, foreign-instance and missing-reply rejection), root references, fresh caller, round-by-round decoder, reset extraction, anchor prefix, physical opening, source stream, PCS grouping, Merkle-log extraction, source coordinate decoder, public-log extractor and the captured source executable with real BLAKE2s records. The current adapter exercised observed initialized-session mixed replay across cached and fresh output blocks, reached scalar rejection without later hint consumption, actual PCS message separation, actual header and full-point receipt, the later prover value, literal earliest physical-root capture, rejecting-prefix primitive replay, raw opening-record recovery, foreign/truncated rejection and byte-coordinate agreement. The production-profile public extractor reached actual literal-original decoding, rejected a fake out-of-packet first mention and decoded full zero-prefixed Merkle leaves before compacting. Its remaining Gao/original reconstruction exceeded the bounded runtime invocation after the general shared-nodal and shorter-left multiplication changes. That production run was **not completed**; no further executable optimization or production-performance claim is substituted for its kernel-checked result and cost theorems. The compiled smaller valid `runForConfig` helper used by the same extractor recovered eight nontrivial words from sixteen full-root rows with one corrupted row, checked the actual fifteen-row common support, and rejected malformed root/anchor metadata, wrong originals and a changed retained anchor. This is executable evidence for the same reconstruction path on a valid generic configuration, not production-profile runtime evidence. diff --git a/verification/whir/Whir.lean b/verification/whir/Whir.lean index 841c72ae5..be2b502b0 100644 --- a/verification/whir/Whir.lean +++ b/verification/whir/Whir.lean @@ -269,3 +269,8 @@ import Whir.SpongefishCurrentCallerOriginalTable import Whir.SpongefishCurrentPartitionCapture import Whir.SpongefishCurrentGoodEvent import Whir.SpongefishCurrentKnowledgeEndpoint +import Whir.SpongefishCurrentIdealRows +import Whir.SpongefishCurrentHistoryReplies +import Whir.SpongefishCurrentRefines +import Whir.SpongefishCurrentHeaderGlue +import Whir.SpongefishCurrentKnowledgeFinal diff --git a/verification/whir/Whir/SpongefishCurrentHeaderGlue.lean b/verification/whir/Whir/SpongefishCurrentHeaderGlue.lean new file mode 100644 index 000000000..a4e6966f9 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentHeaderGlue.lean @@ -0,0 +1,535 @@ +import Whir.SpongefishCurrentHistoryReplies + +/-! Glue between the current #607 full source program, its opening phase and the commitment header. + +`openingEvents_full`: on every table, a successful full-program view has the same opening events under the walk offset `openingOffset` and under the opening packets' suffix `SpongefishCurrentOpeningPackets.openingEvents`. + +`headerFrames` is the static number of closed frames right after the anchor draw closes the commitment header frame. `headerFrames_le` bounds it by the post-binding frame count. `header_full`: on every table, if the full-program view succeeds and the caller original at the post-binding coordinate succeeds, then the header frames of the post-binding history decode the root read by the header root event. The caller original is needed: the replay reads the three header scalars without checking them, and only the original's `header` step checks that they are the canonical constants, in a replay whose closed history is the post-binding history. -/ +namespace Whir.SpongefishCurrentHeaderGlue +open Concrete FiatShamirGame DuplexRefinement DuplexFraming DuplexModeGame +open SpongefishPCSRoundFrames SpongefishCurrentModeQueries SpongefishCurrentMixedModeCompiler +open SpongefishCurrentOpeningPackets SpongefishCurrentHistoryReplies RawOracleCoupling TypedOracleCompiler +open SpongefishCurrentOpeningAcceptance +set_option autoImplicit false + +/-- The four reads of the commitment header: three scalars and the raw32 root. -/ +def headerReads : List Call := [.read .scalar,.read .scalar,.read .scalar,.read .root] + +/-- The semantic replay of a call list containing the header reads followed by a draw closes a frame ending with the four header read events. -/ +theorem header_frame (ans : Coordinate → Digest32) (cur : SemanticCursor) (s : Nat × Bool) + (shaped : Shaped cur.data.pending s) (good : CacheOK ans cur.cache) + (B rest : List Call) (g : Group) (fin : SemanticCursor) + (ok : (runWith ans (replayProgram cur (B ++ (headerReads ++ .draw g :: rest)))).result = .ok fin) : + ∃ (evs evsR : List SourceEvent) (a b c rt dr X : List Byte) (root : Digest32), + fin.data.events = cur.data.events ++ evs ++ + (.prover .scalar a :: .prover .scalar b :: .prover .scalar c :: .prover .root rt :: + .verifier dr :: evsR) ∧ + evs.length = B.length ∧ rt = WireKind.root.codec.bytes root ∧ + ((close fin.data.pending).frames.map byteRun)[(frameShape s (B ++ headerReads)).1]? = + some (X ++ (a ++ b ++ c ++ rt)) := by + rw [← List.append_assoc] at ok + obtain ⟨mid4,ok4,okR,_⟩ := replay_append ans cur (B ++ headerReads) (.draw g :: rest) fin ok + obtain ⟨midB,okB,okH,_⟩ := replay_append ans cur B headerReads mid4 ok4 + obtain ⟨evsB,eventsB,shapesB,_⟩ := replay_apply ans cur B good midB okB + obtain ⟨_,goodB,_⟩ := replay_shape ans cur B s shaped good midB okB + obtain ⟨evs4,events4,shapes4,pending4⟩ := replay_apply ans midB headerReads goodB mid4 okH + obtain ⟨shaped4,good4,_⟩ := replay_shape ans cur (B ++ headerReads) s shaped good mid4 ok4 + obtain ⟨evsD,eventsD,shapesD,pendingD⟩ := replay_apply ans mid4 (.draw g :: rest) good4 fin okR + unfold headerReads at shapes4 + rcases shapes4 with _ | ⟨⟨va,rfl⟩,_ | ⟨⟨vb,rfl⟩,_ | ⟨⟨vc,rfl⟩,_ | ⟨⟨vr,rfl⟩,_ | _⟩⟩⟩⟩ + rcases shapesD with _ | @⟨_,_,_,evsR,⟨dr,drLength,rfl⟩,_⟩ + have run4 : mid4.data.pending.run = midB.data.pending.run ++ + (WireKind.scalar.codec.bytes va ++ WireKind.scalar.codec.bytes vb ++ WireKind.scalar.codec.bytes vc ++ + WireKind.root.codec.bytes vr) := by + rw [pending4] + simp [applyEvents,SpongefishCurrentHistoryReplies.bind_run,List.append_assoc] + have nonempty : mid4.data.pending.run ≠ [] := by + rw [run4] + simp [Codec.bytes,WireKind.codec,rootCodec] + have positive : dr.length ≠ 0 := by + rw [drLength] + exact group_bytes_pos g + obtain ⟨drawFrames,drawRun,_⟩ := draw_facts mid4.data.pending dr.length positive + have framesFin : fin.data.pending.frames.map byteRun = + (mid4.data.pending.frames.map byteRun ++ [mid4.data.pending.run]) ++ chunks [] evsR := by + rw [pendingD] + simp only [applyEvents] + rw [apply_frames,drawFrames,drawRun,close_frames _ nonempty] + simp [byteRun] + obtain ⟨t,closeEq⟩ := close_prefix fin.data.pending + refine ⟨evsB,evsR,WireKind.scalar.codec.bytes va,WireKind.scalar.codec.bytes vb, + WireKind.scalar.codec.bytes vc,WireKind.root.codec.bytes vr,dr,midB.data.pending.run,vr,?_, + shapesB.length_eq.symm,rfl,?_⟩ + · rw [eventsD,events4,eventsB] + simp + · rw [← closeEq,List.map_append,framesFin,← shaped4.1,run4] + simp + +/-- Number of closed frames right after the anchor draw that closes the commitment header frame, for the replay of `before` followed by the commitment header from the literal initial cursor. -/ +def headerFrames (instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) (before : List Call) : Nat := + (openingShape instanceBytes + (before ++ (SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN).take 5)).1 + +theorem headerFrames_eq (instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before : List Call) : + headerFrames instanceBytes layout before = + (frameShape (0,decide (instanceBytes ≠ [])) (before ++ headerReads)).1 + 1 := by + unfold headerFrames openingShape + rw [show (SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN).take 5 = + headerReads ++ [.draw (.anchor ((AnchoredSourceCaller.shape layout).logN-1))] from rfl, + ← List.append_assoc,frameShape_append] + have ready : (frameShape (0,decide (instanceBytes ≠ [])) (before ++ headerReads)).2 = true := by + rw [frameShape_append] + simp [headerReads,frameShape,WireKind.codec,rootCodec] + simp only [frameShape,ready,↓reduceIte] + +/-- A successful getter run of a construction-only program is its run under the fixed coordinate answer that agrees with the getter. -/ +theorem run_runWith {A : Type} (get : Query → Option Digest32) (ans : Coordinate → Digest32) + (agree : ∀ c valid d, get (.construction c valid) = some d → d = ans c) : + ∀ (prog : Program A), ConstructionOnly prog → ∀ a, + SpongefishCurrentCallerGetter.run get prog = some a → (runWith ans prog).result = a + | .done x, _, a, ran => Option.some.inj ran + | .ask (.construction c valid) next, only, a, ran => by + obtain ⟨d,got,rest⟩ := Option.bind_eq_some_iff.mp ran + have same := agree c valid d got + subst same + exact run_runWith get ans agree (next (ans c)) (only _) a rest + | .ask (.primitive _ _) _, only, _, _ => only.elim + +/-- The prelude token parser consumes exactly one event per prelude call. -/ +theorem tokens_split : ∀ (shape : List WHIRCallerShape.EventShape) (cs : List Call) + (E R : List SourceEvent) (ts : List WHIRCallerClaims.CallerToken), + SpongefishCurrentSourceCallerOriginal.shapeCalls shape = some cs → + SpongefishCurrentSourceCallerOriginal.tokens shape E = some (ts,R) → + ∃ P, E = P ++ R ∧ P.length = cs.length := by + intro shape + induction shape with + | nil => + intro cs E R ts hc ht + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls,Option.some.injEq] at hc + simp only [SpongefishCurrentSourceCallerOriginal.tokens,Option.some.injEq,Prod.mk.injEq] at ht + subst hc + exact ⟨[],by simp [ht.2],rfl⟩ + | cons sh shape ih => + intro cs E R ts hc ht + cases sh with + | absorb n => + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls] at hc + split at hc + · obtain ⟨cs',hcs',rfl⟩ := Option.map_eq_some_iff.mp hc + rcases E with _ | ⟨e,events⟩ + · simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + · cases e with + | prover kind bytes => + cases kind with + | scalar => + simp only [SpongefishCurrentSourceCallerOriginal.tokens] at ht + split at ht + · contradiction + · obtain ⟨_,_,ht⟩ := Option.bind_eq_some_iff.mp ht + obtain ⟨⟨tail,rest⟩,tailEq,ht⟩ := Option.bind_eq_some_iff.mp ht + cases ht + obtain ⟨P,split,length⟩ := ih cs' events rest tail hcs' tailEq + exact ⟨_ :: P,by rw [split]; rfl,by simp [length]⟩ + | _ => simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + | _ => simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + · contradiction + | squeeze n => + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls] at hc + split at hc + · obtain ⟨cs',hcs',rfl⟩ := Option.map_eq_some_iff.mp hc + rcases E with _ | ⟨e,events⟩ + · simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + · cases e with + | verifier bytes => + simp only [SpongefishCurrentSourceCallerOriginal.tokens] at ht + split at ht + · contradiction + · obtain ⟨_,_,ht⟩ := Option.bind_eq_some_iff.mp ht + obtain ⟨⟨tail,rest⟩,tailEq,ht⟩ := Option.bind_eq_some_iff.mp ht + cases ht + obtain ⟨P,split,length⟩ := ih cs' events rest tail hcs' tailEq + exact ⟨_ :: P,by rw [split]; rfl,by simp [length]⟩ + | _ => simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + · contradiction + | nonce bits => + simp only [SpongefishCurrentSourceCallerOriginal.shapeCalls] at hc + split at hc + · obtain ⟨cs',hcs',rfl⟩ := Option.map_eq_some_iff.mp hc + rcases E with _ | ⟨e,_ | ⟨e',events⟩⟩ + · simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + · cases e <;> simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + · cases e with + | verifier challenge => + cases e' with + | prover kind bytes => + cases kind with + | nonce => + simp only [SpongefishCurrentSourceCallerOriginal.tokens] at ht + split at ht + · contradiction + · obtain ⟨_,_,ht⟩ := Option.bind_eq_some_iff.mp ht + split at ht + · contradiction + · obtain ⟨⟨tail,rest⟩,tailEq,ht⟩ := Option.bind_eq_some_iff.mp ht + cases ht + obtain ⟨P,split,length⟩ := ih cs' events rest tail hcs' tailEq + exact ⟨_ :: _ :: P,by rw [split]; rfl,by simp [length]⟩ + | _ => simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + | _ => simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + | _ => simp [SpongefishCurrentSourceCallerOriginal.tokens] at ht + · contradiction + +/-! ## The caller original reads a canonical header from the post-binding history -/ + +/-- A successful caller original at `q` replays its tape to a closed history equal to `q.history`. In that replay the frame closed by the anchor draw ends with the canonical header bytes of the selected record's root. -/ +theorem candidate_header {Q : Nat} (p : ParameterBounds.Profile) (layout : WHIRCallerClaims.CallerLayout) + (q : Coordinate) (r : SpongefishSessionAdapter.Record) (instanceBytes : List Byte) + (obs : List Observation) (input : PCSBCSCallerBinding.CallerInput p) (before : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (accepted : SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q r instanceBytes obs = + some input) : + r.shape = AnchoredSourceCaller.shape layout ∧ r.shape.Valid ∧ + ∃ (m : Pending) (X : List Byte), (close m).core.history = q.history ∧ + ((close m).frames.map byteRun)[(frameShape (0,decide (instanceBytes ≠ [])) (before ++ headerReads)).1]? = + some (X ++ SpongefishCurrentAnchorHeader.bytes r.shape r.root) := by + unfold SpongefishCurrentSourceCallerOriginal.candidate at accepted + obtain ⟨result,replayed,finished⟩ := Option.bind_eq_some_iff.mp accepted + unfold SpongefishCurrentSourceCallerOriginal.replay at replayed + split at replayed + · contradiction + obtain ⟨tape,tapeEq,ran⟩ := Option.bind_eq_some_iff.mp replayed + unfold SpongefishCurrentSourceCallerOriginal.calls at tapeEq + obtain ⟨before',before'Eq,tapeEq⟩ := Option.bind_eq_some_iff.mp tapeEq + rw [beforeEq] at before'Eq + cases before'Eq + obtain ⟨payload,_,tapeEq⟩ := Option.bind_eq_some_iff.mp tapeEq + cases tapeEq + let ans : Coordinate → Digest32 := fun c => (SpongefishCurrentCallerGetter.bounded (Q := Q) obs c).getD zeroDigest + have agree : ∀ c valid d, SpongefishCurrentCallerGetter.answer (Q := Q) obs (.construction c valid) = some d → + d = ans c := by + intro c valid d got + simp only [SpongefishCurrentCallerGetter.answer] at got + simp [ans,got] + have ok := run_runWith _ ans agree _ (replay_only _ _) result ran + cases result with + | error failure => + simp [SpongefishCurrentSourceCallerOriginal.finish,eraseResult] at finished + | ok fin => + unfold SpongefishCurrentSourceCallerOriginal.finish at finished + obtain ⟨d,dEq,finished⟩ := Option.bind_eq_some_iff.mp finished + simp only [Option.some.injEq] at dEq + subst dEq + dsimp only at finished + split at finished + · contradiction + rename_i guards + have closeEq : (close fin.data.pending).core.history = q.history := by + by_contra differ + exact guards (Or.inl differ) + obtain ⟨events,eventsEq,finished⟩ := Option.bind_eq_some_iff.mp finished + obtain ⟨claims,parsed,_⟩ := Option.bind_eq_some_iff.mp finished + unfold SpongefishCurrentSourceCallerOriginal.parseEvents at parsed + split at parsed + · contradiction + rename_i shapeEq + have shapeEq : r.shape = AnchoredSourceCaller.shape layout := by simpa using shapeEq + obtain ⟨e1,preludeEq,parsed⟩ := Option.bind_eq_some_iff.mp parsed + obtain ⟨e2,headerEq,_⟩ := Option.bind_eq_some_iff.mp parsed + unfold SpongefishCurrentSourceCallerOriginal.prelude at preludeEq + obtain ⟨⟨ts,e1'⟩,tokensEq,preludeEq⟩ := Option.bind_eq_some_iff.mp preludeEq + obtain ⟨⟨_,restP⟩,_,preludeEq⟩ := Option.bind_eq_some_iff.mp preludeEq + have e1Eq : e1' = e1 := by + by_cases empty : restP = [] + · simpa [empty] using preludeEq + · simp [empty] at preludeEq + subst e1Eq + have form : before ++ [.read .scalar,.read .scalar,.read .scalar,.read .root, + .draw (.anchor (r.shape.logN-1)),.read .scalar] ++ payload ++ + (SpongefishRecordBindingParser.messages r).map (fun message => Call.read message.1) = + before ++ (headerReads ++ .draw (.anchor (r.shape.logN-1)) :: (.read .scalar :: (payload ++ + (SpongefishRecordBindingParser.messages r).map (fun message => Call.read message.1)))) := by + simp [headerReads] + rw [form] at ok + obtain ⟨evs,evsR,a,b,c,rt,dr,X,_,events',evsLength,_,frame⟩ := header_frame ans _ _ + (initial_shaped _ _ _ _) (fun _ _ h => by cases h) before _ _ fin ok + simp only [SpongefishCurrentInitializedMode.initial_data (state := {cv := zeroDigest}), + SpongefishCurrentMixedModeCompiler.forget,SpongefishCurrentObservedSessionEntry.cursor] at events' + rw [events'] at eventsEq + simp only [List.cons_append, + SpongefishCurrentSourceCallerOriginal.callerEvents,Option.some.injEq] at eventsEq + subst eventsEq + obtain ⟨P,split,PLength⟩ := tokens_split _ _ _ _ _ beforeEq tokensEq + have tailEq := List.append_inj_right split (by simp [PLength,evsLength]) + subst tailEq + obtain ⟨a',b',c',root',_,_,_,shaped,decoded,_⟩ := + SpongefishCurrentSourceCallerOriginal.header_source r _ e2 headerEq + simp only [List.cons.injEq,SourceEvent.prover.injEq] at shaped + obtain ⟨⟨_,rfl⟩,⟨_,rfl⟩,⟨_,rfl⟩,⟨_,rfl⟩,_⟩ := shaped + obtain ⟨valid,source⟩ := SpongefishCurrentAnchorHeader.decode_source _ _ _ _ decoded + rw [List.append_nil] at source + refine ⟨shapeEq,valid,fin.data.pending,X,closeEq,?_⟩ + rw [frame,← source] + +/-! ## The old source run inside the full program -/ + +/-- Every leaf of a program satisfies `P`. -/ +def Always {S : Type} (P : S → Prop) : Program S → Prop + | .done s => P s + | .ask _ next => ∀ d, Always P (next d) + +theorem ideal_always {Q : Nat} {Seed State S : Type} (sim : Simulator Q Seed State) + (ro : RawKey Q → Digest32) (iv : Digest32) (P : S → Prop) (prog : Program S) (always : Always P prog) : + ∀ (state : State) (remaining : Nat) (cap : remaining ≤ Q) (counted : Counts remaining prog), + P (runIdeal sim ro iv state prog remaining cap counted).view.result := by + induction prog with + | done s => intro _ _ _ _; exact always + | ask q next ih => + cases q with + | primitive purpose input => + intro state remaining cap counted + simp only [runIdeal,prepend] + exact ih _ (always _) _ _ _ _ + | construction c valid => + intro state remaining cap counted + simp only [runIdeal,prepend] + exact ih _ (always _) _ _ _ _ + +theorem always_bind {R S : Type} (P : S → Prop) (prog : Program R) (k : R → Program S) + (later : ∀ r, Always P (k r)) : Always P (WHIRModeFinal.bind prog k) := by + induction prog with + | done r => exact later r + | ask q next ih => exact fun d => ih d + +variable {p : ParameterBounds.Profile} + +theorem openingPhase_always (decode : SpongefishCurrentOpeningProgram.Decoder) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) (lanes index offset : Nat) + (res : SpongefishCurrentSourceJoinProbability.SourceResult) : + Always (fun s : SpongefishCurrentOpeningProgram.FullResult p => s.1 = res) + (SpongefishCurrentOpeningProgram.openingPhase decode grinding lanes index offset res) := by + unfold SpongefishCurrentOpeningProgram.openingPhase + split + · split + · rfl + · exact always_bind _ _ _ (fun _ => rfl) + · rfl + +/-- A successful full-program view on any table contains a successful semantic replay of the whole old call list from a literal initial cursor, under a fixed coordinate answer. -/ +theorem full_success {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) (iv : Digest32) + (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (decode : SpongefishCurrentOpeningProgram.Decoder) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (counted : Counts Q (SpongefishCurrentOpeningProgram.fullProgram iv tag instanceBytes layout before + payloadCalls messages decode grinding prefixProgram)) + (table : (key : part.Key) → part.Answer (D := Digest32) key) (data : Data) (col : Collected p) + (result : (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv + (SpongefishCurrentOpeningProgram.fullProgram iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram) counted)).result = (some (.ok data),some col)) : + ∃ (ans : Coordinate → Digest32) (session : Digest32) (narg : List Byte) (hints : List (List Byte)) + (fin : SemanticCursor), + (runWith ans (replayProgram (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) + (SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding))).result = + .ok fin ∧ fin.data = data := by + let program := SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes layout before + payloadCalls messages grinding prefixProgram + let k := SpongefishCurrentOpeningProgram.openingPhase decode grinding + (AnchoredSourceCaller.shape layout).lanes (SpongefishCurrentOpeningProgram.rootIndex before) + (SpongefishCurrentOpeningProgram.openingOffset layout before payloadCalls messages) + obtain ⟨state,rest,cap,counted',same⟩ := source_bind part iv program k counted table + have kept := ideal_always (DuplexPublicSimulator.simulator Q) (roOf part table) iv _ _ (openingPhase_always (p := p) decode grinding _ _ _ + (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program + (WHIRModeFinal.bind_prefix_counted program k Q counted))).result) state rest cap counted' + have resultEq := congrArg View.result same + change (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv + (SpongefishCurrentOpeningProgram.fullProgram iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram) counted)).result = _ at resultEq + rw [result] at resultEq + rw [← resultEq] at kept + have success := kept.symm + rw [eval_source] at success + obtain ⟨session,narg,hints,fin,replayOk,finData,_⟩ := afterPrefix_replay + (DuplexPublicSimulator.simulator Q) (roOf part table) iv tag instanceBytes prefixProgram + (SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding) _ Q + (Nat.le_refl Q) _ data success + exact ⟨_,session,narg,hints,fin,replayOk,finData⟩ + +/-! ## Opening events and the commitment header in the full program -/ + +/-- The two opening event segments agree on any event list with one call event per call of the old source program after the public instance event. -/ +theorem openingEvents_eq (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) (instanceBytes : List Byte) (data : Data) + (evs : List SourceEvent) (events : data.events = .publicBytes instanceBytes :: evs) + (shapes : List.Forall₂ SpongefishCurrentOpeningProgram.CallEvent + (SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding) evs) : + SpongefishCurrentOpeningProgram.openingEvents + (SpongefishCurrentOpeningProgram.openingOffset layout before payloadCalls messages) data = + SpongefishCurrentOpeningPackets.openingEvents grinding data.events := by + have length := shapes.length_eq + unfold SpongefishCurrentOpeningProgram.openingEvents SpongefishCurrentOpeningPackets.openingEvents + SpongefishCurrentOpeningProgram.openingOffset + congr 1 + rw [events,List.length_cons,← length] + simp only [SpongefishCurrentSourceJoinProbability.calls,List.length_append] + omega + +/-- On every table, a successful full-program view has the same opening events under the offset of the opening walk and under the opening packets. -/ +theorem openingEvents_full {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) (iv : Digest32) + (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (decode : SpongefishCurrentOpeningProgram.Decoder) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (counted : Counts Q (SpongefishCurrentOpeningProgram.fullProgram iv tag instanceBytes layout before + payloadCalls messages decode grinding prefixProgram)) + (table : (key : part.Key) → part.Answer (D := Digest32) key) (data : Data) (col : Collected p) + (result : (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv + (SpongefishCurrentOpeningProgram.fullProgram iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram) counted)).result = (some (.ok data),some col)) : + SpongefishCurrentOpeningProgram.openingEvents + (SpongefishCurrentOpeningProgram.openingOffset layout before payloadCalls messages) data = + SpongefishCurrentOpeningPackets.openingEvents grinding data.events := by + obtain ⟨ans,session,narg,hints,fin,ok,finData⟩ := full_success part iv tag instanceBytes layout before + payloadCalls messages decode grinding prefixProgram counted table data col result + subst finData + obtain ⟨evs,events,shapes,_⟩ := replay_apply ans _ _ (fun _ _ h => by cases h) fin ok + exact openingEvents_eq layout before payloadCalls messages grinding instanceBytes fin.data evs + (by rw [events]; rfl) shapes + +theorem frameShape_mono : ∀ (s : Nat × Bool) (xs : List Call), s.1 ≤ (frameShape s xs).1 + | _, [] => le_rfl + | s, .read kind :: rest => frameShape_mono (s.1,s.2 || decide (kind.codec.size ≠ 0)) rest + | s, .hint :: rest => frameShape_mono s rest + | s, .draw _ :: rest => by + have later := frameShape_mono (if s.2 then s.1+1 else s.1,false) rest + simp only [frameShape] + exact le_trans (b := if s.2 = true then s.1+1 else s.1) (by split <;> omega) later + +/-- The header frame count is at most the post-binding frame count. -/ +theorem headerFrames_le (instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (boundary : Nat) + (opening : openingShape instanceBytes (before ++ + SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ + messages) = (boundary,true)) : + headerFrames instanceBytes layout before ≤ boundary + 1 := by + have split : before ++ SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ + payloadCalls ++ messages = + (before ++ (SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN).take 5) ++ + (.read .scalar :: (payloadCalls ++ messages)) := by + simp [SpongefishCurrentAcceptedJoin.headerCalls] + unfold openingShape at opening + rw [split,frameShape_append] at opening + have grow := frameShape_mono (frameShape (0,decide (instanceBytes ≠ [])) + (before ++ (SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN).take 5)) + (.read .scalar :: (payloadCalls ++ messages)) + rw [opening] at grow + unfold headerFrames openingShape + omega + +/-- On every table, a successful full-program view whose post-binding caller original succeeds decodes the commitment root of the header root event from the header frames of the post-binding history. -/ +theorem header_full {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) (iv : Digest32) + (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (decode : SpongefishCurrentOpeningProgram.Decoder) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (counted : Counts Q (SpongefishCurrentOpeningProgram.fullProgram iv tag instanceBytes layout before + payloadCalls messages decode grinding prefixProgram)) + (table : (key : part.Key) → part.Answer (D := Digest32) key) (data : Data) (col : Collected p) + (result : (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv + (SpongefishCurrentOpeningProgram.fullProgram iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram) counted)).result = (some (.ok data),some col)) + (boundary B : Nat) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (obs : List Observation) + (accepted : SpongefishCurrentSourceCallerOriginal.candidate (Q := B) p layout + (SpongefishCurrentGoodEvent.postBinding boundary data) r instanceBytes obs = some input) + (root0 : Digest32) + (rootEq : SpongefishCurrentOpeningProgram.headerRoot (SpongefishCurrentOpeningProgram.rootIndex before) + data.events = some root0) : + SpongefishCurrentAnchorHeader.fromHistory (AnchoredSourceCaller.shape layout) + {(SpongefishCurrentGoodEvent.postBinding boundary data).history with + frames := (SpongefishCurrentGoodEvent.postBinding boundary data).history.frames.take + (headerFrames instanceBytes layout before)} = some root0 := by + obtain ⟨ans,session,narg,hints,fin,ok,finData⟩ := full_success part iv tag instanceBytes layout before + payloadCalls messages decode grinding prefixProgram counted table data col result + subst finData + have form : SpongefishCurrentSourceJoinProbability.calls layout before payloadCalls messages grinding = + before ++ (headerReads ++ .draw (.anchor ((AnchoredSourceCaller.shape layout).logN-1)) :: + (.read .scalar :: (payloadCalls ++ messages ++ openingCalls grinding))) := by + simp [SpongefishCurrentSourceJoinProbability.calls,SpongefishCurrentAcceptedJoin.headerCalls,headerReads] + rw [form] at ok + obtain ⟨evs,evsR,a,b,c,rt,dr,X,root,events,evsLength,rtEq,frame⟩ := header_frame ans _ _ + (initial_shaped _ _ _ _) (fun _ _ h => by cases h) before _ _ fin ok + obtain ⟨shapeEq,valid,m,X',closeEq,frame'⟩ := candidate_header p layout _ r instanceBytes obs input before + beforeEq accepted + rw [headerFrames_eq] + generalize (frameShape (0,decide (instanceBytes ≠ [])) (before ++ headerReads)).1 = N at frame frame' + have hFrames : (SpongefishCurrentGoodEvent.postBinding boundary fin.data).history.frames = + (close m).frames.map ByteFrame.historicalCore := by + rw [← closeEq] + rfl + have postFrames : (SpongefishCurrentGoodEvent.postBinding boundary fin.data).history.frames = + ((close fin.data.pending).frames.map ByteFrame.historicalCore).take (boundary+1) := rfl + have sameBytes : (close m).frames.map byteRun = ((close fin.data.pending).frames.map byteRun).take (boundary+1) := by + have := congrArg (List.map frameBytes) (hFrames.symm.trans postFrames) + simpa only [List.map_map,← List.map_take, + show frameBytes ∘ ByteFrame.historicalCore = byteRun from funext frameBytes_core] using this + have origAt := frame' + rw [sameBytes,List.getElem?_take] at origAt + split_ifs at origAt + rw [frame,Option.some.injEq] at origAt + have rootBytes : rt = SpongefishSessionAdapter.rawRoot r.root := by + apply List.append_inj_right' (s₁ := X ++ (a ++ b ++ c)) (s₂ := X' ++ + SpongefishSessionAdapter.scalarsBytes + (SpongefishSessionAdapter.constants AnchoredHeaderCodec.anchorMarker r.shape)) + · simpa [SpongefishCurrentAnchorHeader.bytes,SpongefishSessionAdapter.commitPrefix,List.append_assoc] using origAt + · rw [rtEq] + simp [SpongefishSessionAdapter.rawRoot,Codec.bytes,WireKind.codec,rootCodec] + have rootIs : SpongefishCurrentOpeningProgram.headerRoot (SpongefishCurrentOpeningProgram.rootIndex before) + fin.data.events = some r.root := by + rw [events] + unfold SpongefishCurrentOpeningProgram.headerRoot SpongefishCurrentOpeningProgram.rootIndex + simp only [SpongefishCurrentInitializedMode.initial_data (state := {cv := zeroDigest}), + SpongefishCurrentMixedModeCompiler.forget,SpongefishCurrentObservedSessionEntry.cursor] + rw [show 1 + before.length + 3 = ([SourceEvent.publicBytes instanceBytes] ++ evs).length + 3 by + simp [evsLength]; omega] + rw [List.getElem?_append_right (by omega)] + simp only [Nat.add_sub_cancel_left,List.getElem?_cons_succ,List.getElem?_cons_zero,rootBytes] + have parsed := Codec.parse_append rootCodec r.root [] + rw [List.append_nil] at parsed + simp only [WireKind.codec] + rw [show SpongefishSessionAdapter.rawRoot r.root = rootCodec.bytes r.root from rfl,parsed] + rfl + rw [rootIs,Option.some.injEq] at rootEq + subst rootEq + obtain ⟨f,fAt,fBytes⟩ : ∃ f, (close m).frames[N]? = some f ∧ + byteRun f = X' ++ SpongefishCurrentAnchorHeader.bytes r.shape r.root := by + rw [List.getElem?_map] at frame' + obtain ⟨f,fAt,fEq⟩ := Option.map_eq_some_iff.mp frame' + exact ⟨f,fAt,fEq⟩ + cases f with + | absorb previous source => + simp only [byteRun] at fBytes + unfold SpongefishCurrentAnchorHeader.fromHistory + rw [hFrames,List.take_add_one,List.getElem?_map,fAt] + simp only [Option.map_some,Option.toList_some,ByteFrame.historicalCore,List.getLast?_append, + List.getLast?_singleton,Option.some_or] + rw [fBytes,← shapeEq] + exact SpongefishCurrentAnchorHeader.suffix_recovery r.shape valid r.root X' + +#print axioms header_frame +#print axioms headerFrames_eq +#print axioms tokens_split +#print axioms candidate_header +#print axioms full_success +#print axioms openingEvents_eq +#print axioms openingEvents_full +#print axioms headerFrames_le +#print axioms header_full + +end Whir.SpongefishCurrentHeaderGlue diff --git a/verification/whir/Whir/SpongefishCurrentHistoryReplies.lean b/verification/whir/Whir/SpongefishCurrentHistoryReplies.lean new file mode 100644 index 000000000..052630af4 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentHistoryReplies.lean @@ -0,0 +1,2003 @@ +import Whir.SpongefishCurrentOpeningPackets +import Whir.SpongefishCurrentOpeningProgram +import Whir.SpongefishCurrentOpeningExperiment +import Whir.SpongefishCurrentRootPolicy +import Whir.SpongefishCurrentGoodEvent + +/-! Current #607 opening replies parsed from a packet's key history. + +The opening replays one source event per call of `openingCalls`: reads bind their canonical bytes into the pending prover run, every opening draw is positive and closes that run into a frame, and hints absorb nothing. On the ideal tables of `SpongefishCurrentOpeningPackets.opening_packets`, the history of the `j`-th opening draw therefore holds, from frame index `boundary + 1` on, exactly the prover runs after the first `j` opening draws (`opening_frames`). The opening adds no byte before its first draw, and the first history is the post-binding coordinate's history. + +`historyReplies` walks the opening schedule over these frames. It decodes every read with the codec of `replyPure`/`replyQuery` and stops when the frames run out. Query rows are the rows of the supplied level oracle at the tape's query indices, and a level-ending fold carries the oracle of the next level. On the key history of the draw of coordinate `q`, these replies agree before position `q` with the walk's restored replies (`replies_exact`, `replies_exact_local`). The same per-coordinate analysis of the walk gives the reply-position invariant (`reply_positions`, `query_reply`), the tape and seed at every draw (`tape_draw`, `tape_zero`, `seed_draw`), and the level roots (`root_start`, `level_root`, `level_roots_of_frames`). -/ +namespace Whir.SpongefishCurrentHistoryReplies +open Concrete Protocol CausalGame CausalProbability FiatShamirGame +open SpongefishPCSRoundFrames SpongefishCurrentOpeningAcceptance SpongefishCurrentOpeningProgram +open SpongefishCurrentOpeningPackets PrunedMerkleProgram +set_option autoImplicit false + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-! ## Prover runs between verifier draws -/ + +/-- Prover bytes of an event list before its first verifier event. -/ +def leadBytes : List SourceEvent → List Byte + | [] => [] + | .prover _ bytes :: rest => bytes ++ leadBytes rest + | .verifier _ :: _ => [] + | .hint _ :: rest => leadBytes rest + | .publicBytes _ :: rest => leadBytes rest + +/-- For every verifier event, the concatenated prover bytes up to the next verifier event. -/ +def drawRuns : List SourceEvent → List (List Byte) + | [] => [] + | .prover _ _ :: rest => drawRuns rest + | .verifier _ :: rest => leadBytes rest :: drawRuns rest + | .hint _ :: rest => drawRuns rest + | .publicBytes _ :: rest => drawRuns rest + +/-! ## The history parser -/ + +/-- Parser state: unread bytes of the current frame and the later frames. -/ +abbrev Reader := List Byte × List (List Byte) + +def readKind (kind : WireKind) (s : Reader) : Option (kind.Value × Reader) := + (kind.codec.parse s.1).map fun parsed => (parsed.1,(parsed.2,s.2)) + +/-- A positive verifier draw closes the current frame; the next frame holds the following prover bytes. -/ +def nextFrame (s : Reader) : Option Reader := + match s.2 with + | [] => none + | bytes :: more => some (bytes,more) + +def readPair (s : Reader) : Option (Message E × Reader) := + (readKind (.vector 2) s).map fun parsed => (⟨parsed.1 0,parsed.1 1⟩,parsed.2) + +def powRead (grinding : Fin (cfg).folds.size → Fin 64) (s : Reader) : Coord p → Option Reader + | .query i => + if (grinding i).val = 0 then some s else do + let s ← nextFrame s + let (_,s) ← readKind .nonce s + pure s + | .initial => some s + | .fold _ _ => some s + | .ood _ _ => some s + | .tail _ => some s + +def drawRead (s : Reader) (q : Coord p) : Option Reader := + if PCSBCSRounds.rawWidth q = 0 then some s else nextFrame s + +/-- Replies decoded with the codecs of `replyPure`; query rows and next oracles are left empty here. -/ +def replyRead (s : Reader) (replies : Array Reply) : Coord p → Option (Reader × Array Reply) + | .initial => do + let (m,s) ← readPair s + pure (s,replies.push (.initial m)) + | .fold i j => do + let (m,s) ← readPair s + if isLastFold i j then + if i.val + 1 < (cfg).folds.size then do + let (_,s) ← readKind .root s + pure (s,replies.push (.fold m (some #[]) #[])) + else do + let (residual,s) ← readKind (.vector (2^CausalGame.remaining cfg i.val)) s + pure (s,replies.push (.fold m none (Array.ofFn residual))) + else pure (s,replies.push (.fold m none #[])) + | .ood _ _ => do + let (y,s) ← readKind .scalar s + let (m,s) ← readPair s + pure (s,replies.push (.ood ⟨y,m⟩)) + | .query _ => do + let (m,s) ← readPair s + pure (s,replies.push (.query #[] m)) + | .tail j => + if isVisibleTail j then do + let (m,s) ← readPair s + pure (s,replies.push (.tail m)) + else some (s,replies) + +def stepRead (grinding : Fin (cfg).folds.size → Fin 64) (state : Reader × Array Reply) (q : Coord p) : + Option (Reader × Array Reply) := do + let s ← powRead grinding state.1 q + let s ← drawRead s q + replyRead s state.2 q + +/-- Parse coordinates in order until the frames run out; the replies parsed so far are kept. -/ +def walkRead (grinding : Fin (cfg).folds.size → Fin 64) : + List (Coord p) → Reader × Array Reply → Array Reply + | [], state => state.2 + | q :: qs, state => + match stepRead grinding state q with + | none => state.2 + | some next => walkRead grinding qs next + +def frameBytes : Frame → List Byte + | .absorb _ bytes => bytes + | .nonce _ _ _ => [] + +/-- Byte runs of the frames after the opening boundary frame. -/ +def openingFrames (boundary : Nat) (h : FramedHistory) : List (List Byte) := + (h.frames.drop (boundary+1)).map frameBytes + +/-- Replies parsed from the opening frames of a history, without query rows or next oracles. -/ +def frameReplies (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) (h : FramedHistory) : + Array Reply := + walkRead grinding (WHIRHistory.schedule cfg) (([],openingFrames boundary h),#[]) + +/-- Ideal completion of the parsed reply at reply position `n`: query rows are the oracle rows at the tape's query indices, a present next oracle is the oracle of the following level. -/ +def idealReply (t : Tape cfg) (oracle : Nat → Oracle) (n : Nat) : Reply → Reply + | .fold m o residual => + .fold m (o.map fun _ => oracle (SpongefishCurrentOpeningExperiment.replyLevel cfg n + 1)) residual + | .query rows m => + match (visibleCoordinates cfg)[n]? with + | some (.query i) => + .query (WHIRPhysicalVerifier.atQueries (oracle i.val) + (WHIRPhysicalVerifier.queryIndices p i (get (.query i) t))) m + | _ => .query rows m + | r => r + +/-- Every reply whose bytes lie in the opening frames of `h`, in schedule order, decoded as the opening walk decodes it, with query rows read from `oracle` at the indices of `t` and level-end fold replies carrying `oracle (i+1)`. -/ +def historyReplies (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) (h : FramedHistory) + (t : Tape cfg) (oracle : Nat → Oracle) : Array Reply := + (frameReplies grinding boundary h).mapIdx fun n r => idealReply t oracle n r + +/-! ## Reader states agreeing with an event suffix -/ + +/-- The reader holds the prover bytes before the next draw and the first `n` later runs. -/ +def Rel (n : Nat) (evs : List SourceEvent) (s : Reader) : Prop := + s.1 = leadBytes evs ∧ s.2 = (drawRuns evs).take n + +theorem rel_read (n : Nat) (kind : WireKind) (v : kind.Value) (rest : List SourceEvent) (s : Reader) + (rel : Rel n (.prover kind (kind.codec.bytes v) :: rest) s) : + readKind kind s = some (v,(leadBytes rest,s.2)) ∧ Rel n rest (leadBytes rest,s.2) := by + obtain ⟨bytes,frames⟩ := rel + refine ⟨?_,rfl,?_⟩ + · simp [readKind,bytes,leadBytes,Codec.parse_append] + · simpa [drawRuns] using frames + +theorem rel_pair (n : Nat) (xs : Fin 2 → E) (rest : List SourceEvent) (s : Reader) + (rel : Rel n (.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs) :: rest) s) : + readPair s = some (⟨xs 0,xs 1⟩,(leadBytes rest,s.2)) ∧ Rel n rest (leadBytes rest,s.2) := by + obtain ⟨read,next⟩ := rel_read n (.vector 2) xs rest s rel + exact ⟨by simp [readPair,read],next⟩ + +theorem rel_draw (n : Nat) (bytes : List Byte) (rest : List SourceEvent) (s : Reader) + (rel : Rel (n+1) (.verifier bytes :: rest) s) : + nextFrame s = some (leadBytes rest,(drawRuns rest).take n) ∧ + Rel n rest (leadBytes rest,(drawRuns rest).take n) := by + obtain ⟨_,frames⟩ := rel + refine ⟨?_,rfl,rfl⟩ + simp [nextFrame,frames,drawRuns] + +theorem rel_hint (n : Nat) (bytes : List Byte) (rest : List SourceEvent) (s : Reader) + (rel : Rel n (.hint bytes :: rest) s) : Rel n rest s := by + obtain ⟨lead,frames⟩ := rel + exact ⟨by simpa [leadBytes] using lead,by simpa [drawRuns] using frames⟩ + +/-! ## One coordinate of the walk on its own call events -/ + +def powDraws (grinding : Fin (cfg).folds.size → Fin 64) : Coord p → List (Option (Coord p)) + | .query i => if (grinding i).val = 0 then [] else [none] + | _ => [] + +def pcsDraws (q : Coord p) : List (Option (Coord p)) := + if PCSBCSRounds.rawWidth q = 0 then [] else [some q] + +/-- The opening draws of one coordinate. -/ +def drawList (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) : List (Option (Coord p)) := + powDraws grinding q ++ pcsDraws q + +theorem openingDraws_eq (grinding : Fin (cfg).folds.size → Fin 64) : + SpongefishCurrentRoundPackets.openingDraws grinding = + (WHIRHistory.schedule cfg).flatMap (drawList grinding) := by + rfl + +def visibleQ : Coord p → Bool + | .tail j => isVisibleTail j + | _ => true + +/-- Level-ending folds that carry the next commitment root. -/ +def rootFold : Coord p → Bool + | .fold i j => isLastFold i j && decide (i.val + 1 < (cfg).folds.size) + | _ => false + +def isQuery : Coord p → Bool + | .query _ => true + | _ => false + +/-- The reply constructor of a coordinate; a fold carries the empty next-oracle placeholder exactly at a root-carrying level end. -/ +def Fits : Coord p → Reply → Prop + | .initial, .initial _ => True + | .fold i j, .fold _ next _ => next = if rootFold (.fold i j) then some #[] else none + | .ood _ _, .ood _ => True + | .query _, .query _ _ => True + | .tail _, .tail _ => True + | _, _ => False + +def blankRows : Reply → Reply + | .query _ m => .query #[] m + | r => r + +/-- The authenticated query reply of level `i`: hint, decoded proof, the current level root and the opened rows. -/ +def QueryFacts (H : MerkleTransport.Primitive) (decode : Decoder) (lanes : Nat) (i : Fin (cfg).folds.size) + (col col' : Collected p) : Prop := + ∃ (hint : List Byte) (proof : MerkleTransport.PrunedMerklePaths) (root : Digest32) + (opened : WHIRPhysicalVerifier.Opened) (m : Message E), + col'.replies = col.replies.push (.query opened.rows m) ∧ + col'.openings = col.openings ++ [⟨i,root,hint,proof,opened⟩] ∧ + col.roots[i.val]? = some root ∧ + decode (WHIRPhysicalVerifier.queryIndices p i (get (.query i) col.tape)) (rowWords lanes i) hint = + some proof ∧ + HashProgram.eval H (openProgram lanes i root proof (get (.query i) col.tape)) = some opened + +theorem pow_block (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) (Ep X : List SourceEvent) + (col : Collected p) (shape : List.Forall₂ CallEvent (powCalls grinding q) Ep) : + (∃ pows, powWalk grinding (Ep ++ X) col q = some (X,{col with pows := pows})) ∧ + (verifierBytes Ep).length = (powDraws grinding q).length ∧ + ∀ n s, Rel n (Ep ++ X) s → (powDraws grinding q).length ≤ n → + ∃ s', powRead grinding s q = some s' ∧ Rel (n - (powDraws grinding q).length) X s' := by + cases q with + | query i => + by_cases zero : (grinding i).val = 0 + · simp only [powCalls,powSchedule,zero,↓reduceIte] at shape + cases shape + refine ⟨⟨col.pows,by simp [powWalk,zero]⟩,by simp [powDraws,zero,verifierBytes],?_⟩ + intro n s rel _ + exact ⟨s,by simp [powRead,zero],by simpa [powDraws,zero] using rel⟩ + · simp only [powCalls,powSchedule,zero,↓reduceIte] at shape + rcases shape with _ | ⟨⟨bytes,_,rfl⟩,_ | ⟨⟨nonce,rfl⟩,⟨⟩⟩⟩ + refine ⟨⟨_,by simp [powWalk,zero,takeVerifier,takeProver,parse_bytes]; rfl⟩, + by simp [powDraws,zero,verifierBytes],?_⟩ + intro n s rel enough + simp only [powDraws,zero,↓reduceIte,List.length_singleton] at enough ⊢ + obtain ⟨m,rfl⟩ : ∃ m, n = m + 1 := ⟨n-1,by omega⟩ + simp only [List.cons_append,List.nil_append] at rel + obtain ⟨drawn,rel₁⟩ := rel_draw m bytes _ s rel + obtain ⟨read,rel₂⟩ := rel_read m .nonce nonce X _ rel₁ + simp only [drawRuns] at drawn read rel₂ + exact ⟨(leadBytes X,(drawRuns X).take m),by simp [powRead,zero,drawn,read],by simpa using rel₂⟩ + | initial => + cases shape + exact ⟨⟨col.pows,rfl⟩,rfl,fun n s rel _ => ⟨s,rfl,by simpa [powDraws] using rel⟩⟩ + | fold i j => + cases shape + exact ⟨⟨col.pows,rfl⟩,rfl,fun n s rel _ => ⟨s,rfl,by simpa [powDraws] using rel⟩⟩ + | ood i j => + cases shape + exact ⟨⟨col.pows,rfl⟩,rfl,fun n s rel _ => ⟨s,rfl,by simpa [powDraws] using rel⟩⟩ + | tail j => + cases shape + exact ⟨⟨col.pows,rfl⟩,rfl,fun n s rel _ => ⟨s,rfl,by simpa [powDraws] using rel⟩⟩ + +theorem draw_block (q : Coord p) (Ed X : List SourceEvent) + (shape : List.Forall₂ CallEvent (drawCalls q) Ed) : + drawWalk (Ed ++ X) q = some (X,decodeSample q ((verifierBytes Ed).headD [])) ∧ + (verifierBytes Ed).length = (pcsDraws q).length ∧ + ∀ n s, Rel n (Ed ++ X) s → (pcsDraws q).length ≤ n → + ∃ s', drawRead s q = some s' ∧ Rel (n - (pcsDraws q).length) X s' := by + by_cases zero : PCSBCSRounds.rawWidth q = 0 + · simp only [drawCalls,zero,↓reduceIte] at shape + cases shape + refine ⟨by simp [drawWalk,zero,verifierBytes],by simp [pcsDraws,zero,verifierBytes],?_⟩ + intro n s rel _ + exact ⟨s,by simp [drawRead,zero],by simpa [pcsDraws,zero] using rel⟩ + · simp only [drawCalls,zero,↓reduceIte] at shape + rcases shape with _ | ⟨⟨bytes,_,rfl⟩,⟨⟩⟩ + refine ⟨by simp [drawWalk,zero,takeVerifier,verifierBytes],by simp [pcsDraws,zero,verifierBytes],?_⟩ + intro n s rel enough + simp only [pcsDraws,zero,↓reduceIte,List.length_singleton] at enough ⊢ + obtain ⟨m,rfl⟩ : ∃ m, n = m + 1 := ⟨n-1,by omega⟩ + simp only [List.cons_append,List.nil_append] at rel + obtain ⟨drawn,rel₁⟩ := rel_draw m bytes X s rel + exact ⟨(leadBytes X,(drawRuns X).take m),by simp [drawRead,zero,drawn],by simpa using rel₁⟩ + +/-- Facts about one reply segment of the walk on its call events. -/ +def ReplyOutcome (H : MerkleTransport.Primitive) (decode : Decoder) (lanes : Nat) (q : Coord p) + (Er X : List SourceEvent) (col : Collected p) (st : List SourceEvent × Collected p) : Prop := + st.1 = X ∧ verifierBytes Er = [] ∧ st.2.tape = col.tape ∧ st.2.seed = col.seed ∧ + (∀ n s, Rel n (Er ++ X) s → + ∃ s', replyRead s (col.replies.map blankRows) q = some (s',st.2.replies.map blankRows) ∧ + Rel n X s') ∧ + (visibleQ q = true → ∃ r, st.2.replies = col.replies.push r ∧ Fits q r) ∧ + (visibleQ q = false → st.2.replies = col.replies) ∧ + (rootFold q = false → st.2.roots = col.roots) ∧ + (rootFold q = true → ∃ (xs : Fin 2 → E) (r : Digest32), + Er = [.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs),.prover .root (WireKind.root.codec.bytes r)] ∧ + st.2.roots = col.roots.push r) ∧ + (isQuery q = false → st.2.openings = col.openings) ∧ + (∀ i, q = .query i → QueryFacts H decode lanes i col st.2) + +theorem reply_block (H : MerkleTransport.Primitive) (decode : Decoder) (lanes : Nat) (q : Coord p) + (Er X : List SourceEvent) (col : Collected p) (st : List SourceEvent × Collected p) + (shape : List.Forall₂ CallEvent (replyCalls q) Er) + (ok : HashProgram.eval H (replyWalk decode lanes (Er ++ X) col q) = some st) : + ReplyOutcome H decode lanes q Er X col st := by + cases q with + | initial => + simp only [replyCalls] at shape + rcases shape with _ | ⟨⟨xs,rfl⟩,⟨⟩⟩ + simp only [List.cons_append,List.nil_append] at ok ⊢ + simp [replyWalk,replyPure,HashProgram.eval,takeMessage,takeProver,parse_bytes] at ok + subst ok + refine ⟨rfl,by simp [verifierBytes],rfl,rfl,?_,fun _ => ⟨_,rfl,by simp [Fits]⟩, + fun h => by simp [visibleQ] at h,fun _ => rfl,fun h => by simp [rootFold] at h,fun _ => rfl, + fun i h => by cases h⟩ + intro n s rel + obtain ⟨b,f⟩ := s + obtain ⟨lead,frames⟩ := rel + simp only at lead frames + subst lead frames + refine ⟨(leadBytes X,(drawRuns X).take n),?_,rfl,rfl⟩ + simp [replyRead,readPair,readKind,leadBytes,drawRuns,Codec.parse_append,blankRows] + | fold i j => + by_cases last : isLastFold i j = true + · by_cases more : i.val + 1 < (cfg).folds.size + · have root : rootFold (.fold i j) = true := by simp [rootFold,last,more] + simp only [replyCalls,last,more,↓reduceIte] at shape + rcases shape with _ | ⟨⟨xs,rfl⟩,_ | ⟨⟨r,rfl⟩,⟨⟩⟩⟩ + simp only [List.cons_append,List.nil_append] at ok ⊢ + simp [replyWalk,replyPure,HashProgram.eval,last,more,takeMessage,takeProver,parse_bytes] at ok + subst ok + refine ⟨rfl,by simp [verifierBytes],rfl,rfl,?_,fun _ => ⟨_,rfl,by simp [Fits,root]⟩, + fun h => by simp [visibleQ] at h,fun h => by simp [root] at h,fun _ => ⟨xs,r,rfl,rfl⟩, + fun _ => rfl,fun i h => by cases h⟩ + intro n s rel + obtain ⟨b,f⟩ := s + obtain ⟨lead,frames⟩ := rel + simp only at lead frames + subst lead frames + refine ⟨(leadBytes X,(drawRuns X).take n),?_,rfl,rfl⟩ + simp [replyRead,readPair,readKind,leadBytes,drawRuns,Codec.parse_append,blankRows,last,more] + · have root : rootFold (.fold i j) = false := by simp [rootFold,more] + simp only [replyCalls,last,more,↓reduceIte] at shape + rcases shape with _ | ⟨⟨xs,rfl⟩,_ | ⟨⟨res,rfl⟩,⟨⟩⟩⟩ + simp only [List.cons_append,List.nil_append] at ok ⊢ + simp [replyWalk,replyPure,HashProgram.eval,last,more,takeMessage,takeProver,parse_bytes] at ok + subst ok + refine ⟨rfl,by simp [verifierBytes],rfl,rfl,?_,fun _ => ⟨_,rfl,by simp [Fits,root]⟩, + fun h => by simp [visibleQ] at h,fun _ => rfl,fun h => by simp [root] at h, + fun _ => rfl,fun i h => by cases h⟩ + intro n s rel + obtain ⟨b,f⟩ := s + obtain ⟨lead,frames⟩ := rel + simp only at lead frames + subst lead frames + refine ⟨(leadBytes X,(drawRuns X).take n),?_,rfl,rfl⟩ + simp [replyRead,readPair,readKind,leadBytes,drawRuns,Codec.parse_append,blankRows,last,more] + · have root : rootFold (.fold i j) = false := by simp [rootFold,last] + simp only [replyCalls,last] at shape + rcases shape with _ | ⟨⟨xs,rfl⟩,⟨⟩⟩ + simp only [List.cons_append,List.nil_append] at ok ⊢ + simp [replyWalk,replyPure,HashProgram.eval,last,takeMessage,takeProver,parse_bytes] at ok + subst ok + refine ⟨rfl,by simp [verifierBytes],rfl,rfl,?_,fun _ => ⟨_,rfl,by simp [Fits,root]⟩, + fun h => by simp [visibleQ] at h,fun _ => rfl,fun h => by simp [root] at h, + fun _ => rfl,fun i h => by cases h⟩ + intro n s rel + obtain ⟨b,f⟩ := s + obtain ⟨lead,frames⟩ := rel + simp only at lead frames + subst lead frames + refine ⟨(leadBytes X,(drawRuns X).take n),?_,rfl,rfl⟩ + simp [replyRead,readPair,readKind,leadBytes,drawRuns,Codec.parse_append,blankRows,last] + | ood i j => + simp only [replyCalls] at shape + rcases shape with _ | ⟨⟨y,rfl⟩,_ | ⟨⟨xs,rfl⟩,⟨⟩⟩⟩ + simp only [List.cons_append,List.nil_append] at ok ⊢ + simp [replyWalk,replyPure,HashProgram.eval,takeMessage,takeProver,parse_bytes] at ok + subst ok + refine ⟨rfl,by simp [verifierBytes],rfl,rfl,?_,fun _ => ⟨_,rfl,by simp [Fits]⟩, + fun h => by simp [visibleQ] at h,fun _ => rfl,fun h => by simp [rootFold] at h,fun _ => rfl, + fun i h => by cases h⟩ + intro n s rel + obtain ⟨b,f⟩ := s + obtain ⟨lead,frames⟩ := rel + simp only at lead frames + subst lead frames + refine ⟨(leadBytes X,(drawRuns X).take n),?_,rfl,rfl⟩ + simp [replyRead,readPair,readKind,leadBytes,drawRuns,Codec.parse_append,blankRows] + | query i => + simp only [replyCalls] at shape + rcases shape with _ | ⟨⟨hint,rfl⟩,_ | ⟨⟨xs,rfl⟩,⟨⟩⟩⟩ + simp only [List.cons_append,List.nil_append,replyWalk] at ok ⊢ + cases hd : decode (WHIRPhysicalVerifier.queryIndices p i (get (.query i) col.tape)) + (rowWords lanes i) hint with + | none => simp [replyQuery,takeHintBytes,hd,HashProgram.eval] at ok + | some proof => + cases hr : col.roots[i.val]? with + | none => simp [replyQuery,takeHintBytes,hd,hr,HashProgram.eval] at ok + | some root => + simp only [replyQuery,takeHintBytes,hd,hr,HashProgram.eval_map] at ok + cases ho : HashProgram.eval H (openProgram lanes i root proof (get (.query i) col.tape)) with + | none => simp [ho] at ok + | some opened => + simp [ho,takeMessage,takeProver,parse_bytes] at ok + subst ok + refine ⟨rfl,by simp [verifierBytes],rfl,rfl,?_,fun _ => ⟨_,rfl,by simp [Fits]⟩, + fun h => by simp [visibleQ] at h,fun _ => rfl,fun h => by simp [rootFold] at h, + fun h => by simp [isQuery] at h,?_⟩ + · intro n s rel + obtain ⟨b,f⟩ := s + obtain ⟨lead,frames⟩ := rel + simp only at lead frames + subst lead frames + refine ⟨(leadBytes X,(drawRuns X).take n),?_,rfl,rfl⟩ + simp [replyRead,readPair,readKind,leadBytes,drawRuns,Codec.parse_append,blankRows] + · intro i' same + cases same + exact ⟨hint,proof,root,opened,_,rfl,rfl,hr,hd,ho⟩ + | tail j => + by_cases vis : isVisibleTail j = true + · simp only [replyCalls,vis,↓reduceIte] at shape + rcases shape with _ | ⟨⟨xs,rfl⟩,⟨⟩⟩ + simp only [List.cons_append,List.nil_append] at ok ⊢ + simp [replyWalk,replyPure,HashProgram.eval,vis,takeMessage,takeProver,parse_bytes] at ok + subst ok + refine ⟨rfl,by simp [verifierBytes],rfl,rfl,?_,fun _ => ⟨_,rfl,by simp [Fits]⟩, + fun h => by simp [visibleQ,vis] at h,fun _ => rfl,fun h => by simp [rootFold] at h,fun _ => rfl, + fun i h => by cases h⟩ + intro n s rel + obtain ⟨b,f⟩ := s + obtain ⟨lead,frames⟩ := rel + simp only at lead frames + subst lead frames + refine ⟨(leadBytes X,(drawRuns X).take n),?_,rfl,rfl⟩ + simp [replyRead,readPair,readKind,leadBytes,drawRuns,Codec.parse_append,blankRows,vis] + · simp only [replyCalls,vis] at shape + cases shape + simp only [List.nil_append] at ok ⊢ + simp [replyWalk,replyPure,HashProgram.eval,vis] at ok + subst ok + refine ⟨rfl,rfl,rfl,rfl,?_,fun h => by simp [visibleQ,vis] at h,fun _ => rfl,fun _ => rfl, + fun h => by simp [rootFold] at h,fun _ => rfl,fun i h => by cases h⟩ + intro n s rel + exact ⟨s,by simp [replyRead,vis],rel⟩ + +theorem forall₂_split {A B : Type} {R : A → B → Prop} : + ∀ {xs ys : List A} {es : List B}, List.Forall₂ R (xs ++ ys) es → + ∃ e₁ e₂, es = e₁ ++ e₂ ∧ List.Forall₂ R xs e₁ ∧ List.Forall₂ R ys e₂ + | [], _, es, h => ⟨[],es,rfl,.nil,h⟩ + | _ :: xs, ys, _, .cons head rest => by + obtain ⟨e₁,e₂,rfl,left,right⟩ := forall₂_split (xs := xs) (ys := ys) rest + exact ⟨_ :: e₁,e₂,rfl,.cons head left,right⟩ + +theorem verifierBytes_append (xs ys : List SourceEvent) : + verifierBytes (xs ++ ys) = verifierBytes xs ++ verifierBytes ys := by + simp [verifierBytes,List.filterMap_append] + +theorem recordSample_tape (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) : + (recordSample col q x).tape = set q col.tape (StackWHIRReplay.projectSample q x) := by + cases q <;> rfl + +theorem recordSample_fields (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) : + (recordSample col q x).replies = col.replies ∧ (recordSample col q x).roots = col.roots ∧ + (recordSample col q x).openings = col.openings := by + cases q <;> exact ⟨rfl,rfl,rfl⟩ + +theorem recordSample_seed (col : Collected p) (pows : List (PowCheck p)) (q : Coord p) + (x : PCSBCSRounds.Raw q) : + (recordSample {col with pows := pows} q x).seed = (recordSample col q x).seed := by + cases q <;> rfl + +/-- Bytes of the PCS draw of a coordinate block (empty for a zero-width coordinate). -/ +def sampleBytes (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) (evs : List SourceEvent) : + List Byte := + ((verifierBytes evs).drop (powDraws grinding q).length).headD [] + +/-- Everything one step of the opening walk does on the events of its coordinate. -/ +def StepOutcome (H : MerkleTransport.Primitive) (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (lanes : Nat) (q : Coord p) (Eq R : List SourceEvent) (col : Collected p) + (st : List SourceEvent × Collected p) : Prop := + st.1 = R ∧ (verifierBytes Eq).length = (drawList grinding q).length ∧ + (∀ n s, Rel n (Eq ++ R) s → (drawList grinding q).length ≤ n → + ∃ s', stepRead grinding (s,col.replies.map blankRows) q = some (s',st.2.replies.map blankRows) ∧ + Rel (n - (drawList grinding q).length) R s') ∧ + st.2.tape = set q col.tape (StackWHIRReplay.projectSample q (decodeSample q (sampleBytes grinding q Eq))) ∧ + st.2.seed = (recordSample col q (decodeSample q (sampleBytes grinding q Eq))).seed ∧ + (visibleQ q = true → ∃ r, st.2.replies = col.replies.push r ∧ Fits q r) ∧ + (visibleQ q = false → st.2.replies = col.replies) ∧ + (rootFold q = false → st.2.roots = col.roots) ∧ + (rootFold q = true → ∃ (b : List Byte) (xs : Fin 2 → E) (r : Digest32), + Eq = [.verifier b,.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs), + .prover .root (WireKind.root.codec.bytes r)] ∧ + st.2.roots = col.roots.push r) ∧ + (isQuery q = false → st.2.openings = col.openings) ∧ + (∀ i, q = .query i → QueryFacts H decode lanes i {col with tape := st.2.tape} st.2) + +theorem step_block (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (q : Coord p) (Eq R : List SourceEvent) + (col : Collected p) (st : List SourceEvent × Collected p) + (shape : List.Forall₂ CallEvent (callsOf grinding q) Eq) + (ok : HashProgram.eval H (stepWalk decode grinding lanes (Eq ++ R,col) q) = some st) : + StepOutcome H decode grinding lanes q Eq R col st := by + obtain ⟨Epd,Er,rfl,shapePD,shapeR⟩ := forall₂_split shape + obtain ⟨Ep,Ed,rfl,shapeP,shapeD⟩ := forall₂_split shapePD + obtain ⟨⟨pows,powOk⟩,powLen,powRel⟩ := pow_block grinding q Ep (Ed ++ (Er ++ R)) col shapeP + obtain ⟨drawOk,drawLen,drawRel⟩ := draw_block q Ed (Er ++ R) shapeD + simp only [List.append_assoc] at ok ⊢ + simp only [stepWalk,powOk,drawOk] at ok + obtain ⟨rest,vEr,tape,seed,parse,vis,hid,rootsSame,rootsPush,opens,queries⟩ := + reply_block H decode lanes q Er R _ st shapeR ok + obtain ⟨midReplies,midRoots,midOpenings⟩ := recordSample_fields {col with pows := pows} q + (decodeSample q ((verifierBytes Ed).headD [])) + have sample : sampleBytes grinding q (Ep ++ (Ed ++ Er)) = (verifierBytes Ed).headD [] := by + simp [sampleBytes,verifierBytes_append,vEr,← powLen] + have drawLength : (drawList grinding q).length = (powDraws grinding q).length + (pcsDraws q).length := by + simp [drawList] + unfold StepOutcome + rw [sample] + refine ⟨rest,?_,?_,?_,?_,?_,?_,?_,?_,?_,?_⟩ + · simp [verifierBytes_append,vEr,powLen,drawLen,drawList] + · intro n s rel enough + simp only [List.append_assoc] at rel + obtain ⟨s₁,read₁,rel₁⟩ := powRel n s rel (by omega) + obtain ⟨s₂,read₂,rel₂⟩ := drawRel _ s₁ rel₁ (by omega) + obtain ⟨s₃,read₃,rel₃⟩ := parse _ s₂ rel₂ + rw [midReplies] at read₃ + refine ⟨s₃,by simp [stepRead,read₁,read₂,read₃],?_⟩ + rw [drawLength,← Nat.sub_sub] + exact rel₃ + · rw [tape,recordSample_tape] + · rw [seed,recordSample_seed] + · intro visible + obtain ⟨r,same,fits⟩ := vis visible + exact ⟨r,by rw [same,midReplies],fits⟩ + · intro hidden + rw [hid hidden,midReplies] + · intro plain + rw [rootsSame plain,midRoots] + · intro root + obtain ⟨xs,r,rfl,pushed⟩ := rootsPush root + cases q with + | fold i j => + simp only [powCalls] at shapeP + cases shapeP + have width : PCSBCSRounds.rawWidth (CausalProbability.Coordinate.fold (c := cfg) i j) = 1 := rfl + simp only [drawCalls,width,one_ne_zero,↓reduceIte] at shapeD + rcases shapeD with _ | ⟨⟨b,_,rfl⟩,⟨⟩⟩ + exact ⟨b,xs,r,rfl,by rw [pushed,midRoots]⟩ + | initial => simp [rootFold] at root + | ood i j => simp [rootFold] at root + | query i => simp [rootFold] at root + | tail j => simp [rootFold] at root + · intro plain + rw [opens plain,midOpenings] + · intro i same + subst same + obtain ⟨hint,proof,root,opened,m,r₁,r₂,r₃,r₄,r₅⟩ := queries i rfl + rw [midReplies] at r₁ + rw [midOpenings] at r₂ + rw [midRoots] at r₃ + rw [recordSample_tape] at r₄ r₅ + rw [tape,recordSample_tape] + exact ⟨hint,proof,root,opened,m,r₁,r₂,r₃,r₄,r₅⟩ + +/-! ## The walk over consecutive coordinate blocks -/ + +/-- One event block per coordinate, each of the coordinate's call shape. -/ +def Blocks (grinding : Fin (cfg).folds.size → Fin 64) (xs : List (Coord p)) + (bx : List (List SourceEvent)) : Prop := + List.Forall₂ (fun q b => List.Forall₂ CallEvent (callsOf grinding q) b) xs bx + +theorem blocks_of (grinding : Fin (cfg).folds.size → Fin 64) : + ∀ (xs : List (Coord p)) (E : List SourceEvent), + List.Forall₂ CallEvent (xs.flatMap (callsOf grinding)) E → + ∃ bx, E = bx.flatten ∧ Blocks grinding xs bx + | [], E, h => by + rw [List.flatMap_nil] at h + cases h + exact ⟨[],rfl,.nil⟩ + | q :: xs, E, h => by + rw [List.flatMap_cons] at h + obtain ⟨e₁,e₂,rfl,first,rest⟩ := forall₂_split h + obtain ⟨bx,rfl,blocks⟩ := blocks_of grinding xs e₂ rest + exact ⟨e₁ :: bx,by simp,.cons first blocks⟩ + +theorem walk_cons_eval (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (q : Coord p) (qs : List (Coord p)) + (st : List SourceEvent × Collected p) : + HashProgram.eval H (walkFrom decode grinding lanes (q :: qs) st) = + (HashProgram.eval H (stepWalk decode grinding lanes st q)).bind + (fun next => HashProgram.eval H (walkFrom decode grinding lanes qs next)) := by + rw [walkFrom,HashProgram.eval_bind] + cases HashProgram.eval H (stepWalk decode grinding lanes st q) <;> rfl + +theorem push_append_toArray {A : Type} (a : Array A) (r : A) (l : List A) : + a.push r ++ l.toArray = a ++ (r :: l).toArray := by + apply Array.ext' + simp + +theorem recordSample_seed_ne (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) + (other : q ≠ .initial) : (recordSample col q x).seed = col.seed := by + cases q with + | initial => exact (other rfl).elim + | fold i j => rfl + | ood i j => rfl + | query i => rfl + | tail j => rfl + +/-- What the walk over a run of coordinate blocks preserves and produces. -/ +def WalkOutcome (grinding : Fin (cfg).folds.size → Fin 64) (xs : List (Coord p)) + (bx : List (List SourceEvent)) (R : List SourceEvent) (col : Collected p) + (final : List SourceEvent × Collected p) : Prop := + final.1 = R ∧ + (verifierBytes bx.flatten).length = (xs.flatMap (drawList grinding)).length ∧ + (∀ ys n s, Rel n (bx.flatten ++ R) s → (xs.flatMap (drawList grinding)).length ≤ n → + ∃ s', walkRead grinding (xs ++ ys) (s,col.replies.map blankRows) = + walkRead grinding ys (s',final.2.replies.map blankRows) ∧ + Rel (n - (xs.flatMap (drawList grinding)).length) R s') ∧ + (∃ rs : List Reply, final.2.replies = col.replies ++ rs.toArray ∧ + List.Forall₂ Fits (xs.filter visibleQ) rs) ∧ + (∃ rts : List Digest32, final.2.roots = col.roots ++ rts.toArray ∧ + rts.length = (xs.filter rootFold).length) ∧ + (∀ r, r ∉ xs → get r final.2.tape = get r col.tape) ∧ + ((.initial : Coord p) ∉ xs → final.2.seed = col.seed) ∧ + (∀ o ∈ col.openings, o ∈ final.2.openings) + +theorem walk_run (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (xs : List (Coord p)) (bx : List (List SourceEvent)) (R : List SourceEvent) (col : Collected p) + (final : List SourceEvent × Collected p), Blocks grinding xs bx → + HashProgram.eval H (walkFrom decode grinding lanes xs (bx.flatten ++ R,col)) = some final → + WalkOutcome grinding xs bx R col final + | [], bx, R, col, final, blocks, ok => by + cases blocks + simp only [walkFrom,HashProgram.eval,Option.some.injEq,List.flatten_nil,List.nil_append] at ok + subst ok + refine ⟨rfl,rfl,?_,⟨[],by simp,.nil⟩,⟨[],by simp,rfl⟩,fun _ _ => rfl,fun _ => rfl,fun _ h => h⟩ + intro ys n s rel _ + exact ⟨s,rfl,by simpa using rel⟩ + | q :: xs, _, R, col, final, blocks, ok => by + rcases blocks with _ | @⟨_,b,_,bx,shape,blocks⟩ + simp only [List.flatten_cons,List.append_assoc] at ok + rw [walk_cons_eval] at ok + obtain ⟨next,stepOk,restOk⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨rest,vLen,parse,tape,seed,vis,hid,rootsSame,rootsPush,opens,queries⟩ := + step_block H decode grinding lanes q b (bx.flatten ++ R) col next shape stepOk + obtain ⟨n₁,n₂⟩ := next + simp only at rest + subst rest + obtain ⟨fin,vRest,parseRest,⟨rs,repl,fits⟩,⟨rts,rootsEq,rtsLen⟩,tapeRest,seedRest,opensRest⟩ := + walk_run H decode grinding lanes xs bx R n₂ final blocks restOk + refine ⟨fin,?_,?_,?_,?_,?_,?_,?_⟩ + · simp [verifierBytes_append,vLen,vRest] + · intro ys n s rel enough + simp only [List.flatten_cons,List.append_assoc] at rel + simp only [List.flatMap_cons,List.length_append] at enough ⊢ + obtain ⟨s₁,read₁,rel₁⟩ := parse n s rel (by omega) + obtain ⟨s₂,eq₂,rel₂⟩ := parseRest ys _ s₁ rel₁ (by omega) + refine ⟨s₂,?_,by rw [Nat.sub_add_eq]; exact rel₂⟩ + simp only [List.cons_append,walkRead,read₁] + exact eq₂ + · by_cases v : visibleQ q = true + · obtain ⟨r,push,fit⟩ := vis v + refine ⟨r :: rs,by rw [repl,push,push_append_toArray],?_⟩ + rw [List.filter_cons_of_pos v] + exact .cons fit fits + · refine ⟨rs,by rw [repl,hid (by simpa using v)],?_⟩ + rw [List.filter_cons_of_neg v] + exact fits + · by_cases v : rootFold q = true + · obtain ⟨_,_,r,_,push⟩ := rootsPush v + refine ⟨r :: rts,by rw [rootsEq,push,push_append_toArray],?_⟩ + rw [List.filter_cons_of_pos v] + simp [rtsLen] + · refine ⟨rts,by rw [rootsEq,rootsSame (by simpa using v)],?_⟩ + rw [List.filter_cons_of_neg v] + exact rtsLen + · intro r notin + simp only [List.mem_cons,not_or] at notin + rw [tapeRest r notin.2,tape,get_set_ne _ _ _ _ notin.1] + · intro notin + simp only [List.mem_cons,not_or] at notin + rw [seedRest notin.2,seed,recordSample_seed_ne _ _ _ (Ne.symm notin.1)] + · intro o member + apply opensRest + cases hq : isQuery q with + | false => rw [opens hq]; exact member + | true => + cases q with + | query i => + obtain ⟨_,_,_,_,_,_,pushed,_⟩ := queries i rfl + rw [pushed] + exact List.mem_append_left _ member + | initial => simp [isQuery] at hq + | fold i j => simp [isQuery] at hq + | ood i j => simp [isQuery] at hq + | tail j => simp [isQuery] at hq + +theorem walk_split (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) : + ∀ (xs ys : List (Coord p)) (bx : List (List SourceEvent)) (R : List SourceEvent) (col : Collected p) + (final : List SourceEvent × Collected p), Blocks grinding xs bx → + HashProgram.eval H (walkFrom decode grinding lanes (xs ++ ys) (bx.flatten ++ R,col)) = some final → + ∃ mid, HashProgram.eval H (walkFrom decode grinding lanes xs (bx.flatten ++ R,col)) = some (R,mid) ∧ + HashProgram.eval H (walkFrom decode grinding lanes ys (R,mid)) = some final + | [], ys, bx, R, col, final, blocks, ok => by + cases blocks + exact ⟨col,by simp [walkFrom,HashProgram.eval],by simpa using ok⟩ + | q :: xs, ys, _, R, col, final, blocks, ok => by + rcases blocks with _ | @⟨_,b,_,bx,shape,blocks⟩ + simp only [List.flatten_cons,List.append_assoc,List.cons_append] at ok ⊢ + rw [walk_cons_eval] at ok + obtain ⟨next,stepOk,restOk⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨rest,_⟩ := step_block H decode grinding lanes q b (bx.flatten ++ R) col next shape stepOk + obtain ⟨n₁,n₂⟩ := next + simp only at rest + subst rest + obtain ⟨mid,first,second⟩ := walk_split H decode grinding lanes xs ys bx R n₂ final blocks restOk + refine ⟨mid,?_,second⟩ + rw [walk_cons_eval,stepOk] + exact first + +/-! ## Schedule positions of opening draws -/ + +theorem powDraws_none (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) (x : Option (Coord p)) + (member : x ∈ powDraws grinding q) : x = none := by + cases q with + | query i => + simp only [powDraws] at member + split_ifs at member <;> simp_all + | initial => simp [powDraws] at member + | fold i j => simp [powDraws] at member + | ood i j => simp [powDraws] at member + | tail j => simp [powDraws] at member + +/-- The coordinate of an opening draw, its schedule split and its draw index. -/ +theorem flatMap_index (grinding : Fin (cfg).folds.size → Fin 64) : + ∀ (xs : List (Coord p)), xs.Nodup → ∀ (j : Nat) (q : Coord p), + (xs.flatMap (drawList grinding))[j]? = some (some q) → + ∃ pre post, xs = pre ++ q :: post ∧ q ∉ pre ∧ + j = (pre.flatMap (drawList grinding)).length + (powDraws grinding q).length + | [], _, j, q, found => by simp at found + | x :: xs, nd, j, q, found => by + rw [List.flatMap_cons] at found + by_cases within : j < (drawList grinding x).length + · rw [List.getElem?_append_left within] at found + unfold drawList at found within + by_cases inPow : j < (powDraws grinding x).length + · rw [List.getElem?_append_left inPow] at found + have := powDraws_none grinding x _ (List.mem_of_getElem? found) + simp at this + · rw [List.getElem?_append_right (by omega)] at found + unfold pcsDraws at found + split_ifs at found with zero + · simp at found + · have idx : j - (powDraws grinding x).length = 0 := by + have := (List.getElem?_eq_some_iff.mp found).1 + simp only [List.length_singleton] at this + omega + rw [idx] at found + simp only [List.getElem?_cons_zero,Option.some.injEq] at found + subst found + exact ⟨[],xs,rfl,by simp,by simp; omega⟩ + · rw [List.getElem?_append_right (by omega)] at found + obtain ⟨pre,post,split,notin,index⟩ := + flatMap_index grinding xs (List.nodup_cons.mp nd).2 _ q found + have ne : x ≠ q := by + intro same + subst same + exact (List.nodup_cons.mp nd).1 (by rw [split]; simp) + refine ⟨x :: pre,post,by rw [split]; rfl,by simp [Ne.symm ne,notin],?_⟩ + simp only [List.flatMap_cons,List.length_append] + omega + +theorem split_position (q : Coord p) (pre post : List (Coord p)) + (split : WHIRHistory.schedule cfg = pre ++ q :: post) (notin : q ∉ pre) : + position q = pre.length := by + rw [← WHIRHistory.schedule_idxOf,split,List.idxOf_append_of_notMem notin] + simp + +theorem split_visible (q : Coord p) (pre post : List (Coord p)) + (split : WHIRHistory.schedule cfg = pre ++ q :: post) : + ∀ r ∈ pre, r ∈ visibleCoordinates cfg := by + intro r member + have hidden : (WHIRHistory.hiddenTail cfg).length ≤ 1 := by + unfold WHIRHistory.hiddenTail + split <;> simp + have total := congrArg List.length split + simp only [WHIRHistory.schedule,List.length_append,List.length_cons] at total + have taken := congrArg (List.take pre.length) split + rw [WHIRHistory.schedule,List.take_append_of_le_length (by omega),List.take_left] at taken + rw [← taken] at member + exact List.mem_of_mem_take member + +theorem visibleQ_of_mem (r : Coord p) (member : r ∈ visibleCoordinates cfg) : visibleQ r = true := by + cases r with + | tail j => + simp only [visibleQ,isVisibleTail,decide_eq_true_eq] + simp only [CausalProbability.visibleCoordinates,List.mem_append,List.mem_cons, + List.mem_flatMap,List.mem_ofFn,List.not_mem_nil] at member + rcases member with ((same | none) | ⟨i,_,inLevel⟩) | ⟨k,same⟩ + · cases same + · exact none.elim + · unfold CausalProbability.levelCoordinates at inLevel + split at inLevel + · simp [List.mem_ofFn] at inLevel + · cases inLevel + · cases same + have := k.isLt + simp only + omega + | initial => rfl + | fold i j => rfl + | ood i j => rfl + | query i => rfl + +theorem schedule_filter : (WHIRHistory.schedule cfg).filter visibleQ = visibleCoordinates cfg := by + rw [WHIRHistory.schedule,List.filter_append,List.filter_eq_self.mpr (fun r m => visibleQ_of_mem r m)] + unfold WHIRHistory.hiddenTail + split + · rename_i pos + have stop : ¬ ((cfg).logN - (cfg).folds.toList.sum - 1 + 1 < (cfg).logN - (cfg).folds.toList.sum) := by + omega + simp only [List.filter_cons,List.filter_nil,visibleQ,isVisibleTail,decide_eq_false stop, + Bool.false_eq_true,↓reduceIte,List.append_nil] + · simp + +theorem push_eq_append {A : Type} (a : Array A) (r : A) : a.push r = a ++ #[r] := by + apply Array.ext' + simp + +theorem replyRead_prefix (s : Reader) (rs : Array Reply) (q : Coord p) (next : Reader × Array Reply) + (ok : replyRead s rs q = some next) : ∃ extra : Array Reply, next.2 = rs ++ extra := by + cases q with + | initial => + simp only [replyRead] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨_,push_eq_append _ _⟩ + | fold i j => + simp only [replyRead] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + split_ifs at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨_,push_eq_append _ _⟩ + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨_,push_eq_append _ _⟩ + · cases ok + exact ⟨_,push_eq_append _ _⟩ + | ood i j => + simp only [replyRead] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨_,push_eq_append _ _⟩ + | query i => + simp only [replyRead] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨_,push_eq_append _ _⟩ + | tail j => + simp only [replyRead] at ok + split_ifs at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨_,push_eq_append _ _⟩ + · cases ok + exact ⟨#[],by simp⟩ + +theorem walkRead_prefix (grinding : Fin (cfg).folds.size → Fin 64) : + ∀ (qs : List (Coord p)) (s : Reader) (rs : Array Reply), + ∃ extra : Array Reply, walkRead grinding qs (s,rs) = rs ++ extra + | [], s, rs => ⟨#[],by simp [walkRead]⟩ + | q :: qs, s, rs => by + simp only [walkRead] + cases ok : stepRead grinding (s,rs) q with + | none => exact ⟨#[],by simp⟩ + | some next => + simp only + unfold stepRead at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨extra,same⟩ := replyRead_prefix _ _ q next ok + obtain ⟨more,rest⟩ := walkRead_prefix grinding qs next.1 next.2 + refine ⟨extra ++ more,?_⟩ + rw [rest,same,Array.append_assoc] + +/-! ## Reply positions and exactness -/ + +theorem leadBytes_opening (grinding : Fin (cfg).folds.size → Fin 64) (E : List SourceEvent) + (calls : List.Forall₂ CallEvent (openingCalls grinding) E) : leadBytes E = [] := by + obtain ⟨rest,head⟩ := openingCalls_head grinding (p := p) + rw [head] at calls + rcases calls with _ | ⟨⟨bytes,_,rfl⟩,_⟩ + rfl + +/-- A successful walk on the opening call events is a walk over one block per scheduled coordinate. -/ +theorem walk_whole (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) : + ∃ bx fin, E = bx.flatten ∧ Blocks grinding (WHIRHistory.schedule cfg) bx ∧ + HashProgram.eval H (walkFrom decode grinding lanes (WHIRHistory.schedule cfg) + (bx.flatten ++ [],Collected.start root0)) = some (fin,col) := by + obtain ⟨bx,rfl,blocks⟩ := blocks_of grinding (WHIRHistory.schedule cfg) E calls + unfold walk at walked + rw [HashProgram.eval_map] at walked + obtain ⟨⟨fin,col'⟩,ev,same⟩ := Option.map_eq_some_iff.mp walked + cases same + exact ⟨bx,fin,rfl,blocks,by simpa using ev⟩ + +/-- Reply-position invariant: the walk pushes exactly one reply per visible coordinate, in schedule order, of the coordinate's constructor. -/ +theorem reply_positions (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) : + List.Forall₂ Fits (visibleCoordinates cfg) col.replies.toList := by + obtain ⟨bx,fin,rfl,blocks,ev⟩ := walk_whole H decode grinding lanes root0 E col calls walked + obtain ⟨_,_,_,⟨rs,repl,fits⟩,_⟩ := walk_run H decode grinding lanes _ bx [] _ _ blocks ev + rw [schedule_filter] at fits + simp only at repl + rw [repl] + simpa [Collected.start] using fits + +theorem reply_at (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (r : Coord p) (visible : r ∈ visibleCoordinates cfg) : + ∃ reply, col.replies[position r]? = some reply ∧ Fits r reply := by + have fits := reply_positions H decode grinding lanes root0 E col calls walked + obtain ⟨reply,found,fit⟩ := forall₂_getElem? fits (position r) r (List.getElem?_idxOf visible) + exact ⟨reply,by simpa using found,fit⟩ + +theorem forall₂_getElem?_right {B C : Type} {R : B → C → Prop} {xs : List B} {ys : List C} + (h : List.Forall₂ R xs ys) (k : Nat) (b : C) (found : ys[k]? = some b) : + ∃ a, xs[k]? = some a ∧ R a b := by + have flipped : List.Forall₂ (flip R) ys xs := h.flip + obtain ⟨a,at',rel⟩ := forall₂_getElem? flipped k b found + exact ⟨a,at',rel⟩ + +theorem bang_of {A : Type} [Inhabited A] (xs : Array A) (n : Nat) (a : A) (found : xs[n]? = some a) : + xs[n]! = a := by + rw [getElem!_def,found] + +theorem position_at (n : Nat) (c : Coord p) (atN : (visibleCoordinates cfg)[n]? = some c) : + position c = n := by + have within := List.getElem?_eq_some_iff.mp atN + unfold position + rw [← within.2] + exact (WHIRHistory.visibleCoordinates_nodup cfg).idxOf_getElem n within.1 + +theorem idealReply_restore (t : Tape cfg) (root : BaseOracle) (next next' : Nat → Oracle) (col : Collected p) + (n : Nat) (r : Reply) (c : Coord p) (atN : (visibleCoordinates cfg)[n]? = some c) (fits : Fits c r) + (stored : col.replies[n]? = some r) + (rows : SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies root next) + (agree : ∀ i : Fin (cfg).folds.size, position (.query i : Coord p) = n → + get (.query i) t = get (.query i) col.tape) + (levels : ∀ i : Nat, ((∃ (i' : Fin (cfg).folds.size) (k : Fin (cfg).folds[i'.val]!), + isLastFold i' k = true ∧ i'.val + 1 < (cfg).folds.size ∧ i = i'.val + 1 ∧ c = .fold i' k) ∨ + (∃ i' : Fin (cfg).folds.size, 0 < i'.val ∧ i = i'.val ∧ c = .query i')) → next' i = next i) : + idealReply t (SpongefishCurrentOpeningExperiment.levelOracle root next') n (blankRows r) = + SpongefishCurrentOpeningExperiment.restoreReply cfg next n r := by + cases r with + | initial m => rfl + | fold m o residual => + cases o with + | none => rfl + | some x => + cases c with + | fold i' k => + have root : rootFold (.fold i' k : Coord p) = true := by + by_contra hr + simp [Fits,hr] at fits + simp only [rootFold,Bool.and_eq_true,decide_eq_true_eq] at root + have level : SpongefishCurrentOpeningExperiment.replyLevel cfg n = i'.val := by + simp [SpongefishCurrentOpeningExperiment.replyLevel,atN] + have same := levels (i'.val + 1) (.inl ⟨i',k,root.1,root.2,rfl,rfl⟩) + simp [blankRows,idealReply,SpongefishCurrentOpeningExperiment.restoreReply, + SpongefishCurrentOpeningExperiment.levelOracle,level,same] + | initial => simp [Fits] at fits + | ood i j => simp [Fits] at fits + | query i => simp [Fits] at fits + | tail j => simp [Fits] at fits + | ood claim => rfl + | tail m => rfl + | query rowsR m => + cases c with + | query i => + have place : position (.query i : Coord p) = n := position_at n _ atN + have authenticated := rows i + rw [place,bang_of _ _ _ stored] at authenticated + simp only [rowsField] at authenticated + have oracleEq : SpongefishCurrentOpeningExperiment.levelOracle root next' i.val = + SpongefishCurrentOpeningExperiment.levelOracle root next i.val := by + unfold SpongefishCurrentOpeningExperiment.levelOracle + split_ifs with zero + · rfl + · exact levels i.val (.inr ⟨i,by omega,rfl,rfl⟩) + simp only [blankRows,idealReply,atN,SpongefishCurrentOpeningExperiment.restoreReply,oracleEq, + authenticated,agree i place] + | initial => simp [Fits] at fits + | fold i j => simp [Fits] at fits + | ood i j => simp [Fits] at fits + | tail j => simp [Fits] at fits + +/-- Exactness of the history parser with per-level oracles: on the key history of the `j`-th opening draw (coordinate `q`), the replies parsed from the opening frames and completed with `levelOracle root next'` agree, before position `q`, with the walk's replies restored with `next`, as soon as `next'` and `next` agree on every level used by a reply before `q` (the level after a root-carrying fold, and the level of a query with positive level). -/ +theorem replies_exact_local (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (j : Nat) (q : Coord p) + (found : (SpongefishCurrentRoundPackets.openingDraws grinding)[j]? = some (some q)) + (boundary : Nat) (h : FramedHistory) (frames : openingFrames boundary h = (drawRuns E).take j) + (root : BaseOracle) (next : Nat → Oracle) + (rows : SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies root next) + (t : Tape cfg) (agree : ∀ r : Coord p, position r < position q → get r t = get r col.tape) + (next' : Nat → Oracle) + (levels : ∀ i : Nat, ((∃ (i' : Fin (cfg).folds.size) (k : Fin (cfg).folds[i'.val]!), + SpongefishCurrentOpeningAcceptance.isLastFold i' k = true ∧ i'.val + 1 < (cfg).folds.size ∧ + i = i'.val + 1 ∧ position (.fold i' k : Coord p) < position q) ∨ + (∃ i' : Fin (cfg).folds.size, 0 < i'.val ∧ i = i'.val ∧ position (.query i' : Coord p) < position q)) → + next' i = next i) : + PCSRoundByRoundTranscriptState.priorAnswers + (historyReplies grinding boundary h t (SpongefishCurrentOpeningExperiment.levelOracle root next')) + (position q) = + PCSRoundByRoundTranscriptState.priorAnswers + (SpongefishCurrentOpeningExperiment.restoredReplies col next) (position q) := by + have lead := leadBytes_opening grinding E calls + have fitsAll := reply_positions H decode grinding lanes root0 E col calls walked + obtain ⟨bx,fin,rfl,blocks,ev⟩ := walk_whole H decode grinding lanes root0 E col calls walked + obtain ⟨pre,post,split,notin,index⟩ := flatMap_index grinding (WHIRHistory.schedule cfg) + (WHIRHistory.schedule_nodup cfg) j q (by rw [← openingDraws_eq]; exact found) + have place := split_position q pre post split notin + rw [split] at blocks ev + obtain ⟨bpre,brest,rfl,bp,br⟩ := forall₂_split blocks + rw [List.flatten_append,List.append_nil] at ev + obtain ⟨mid,first,second⟩ := walk_split H decode grinding lanes pre (q :: post) bpre brest.flatten + (Collected.start root0) (fin,col) bp (by simpa using ev) + obtain ⟨_,_,parse,⟨rs,repl,fits⟩,_⟩ := walk_run H decode grinding lanes pre bpre brest.flatten + (Collected.start root0) (brest.flatten,mid) bp first + obtain ⟨_,_,_,⟨rs₂,repl₂,_⟩,_⟩ := walk_run H decode grinding lanes (q :: post) brest [] mid (fin,col) br + (by simpa using second) + simp only at repl repl₂ + have allVisible : pre.filter visibleQ = pre := + List.filter_eq_self.mpr (fun r m => visibleQ_of_mem r (split_visible q pre post split r m)) + rw [allVisible] at fits + have midSize : mid.replies.size = position q := by + rw [repl,place,fits.length_eq] + simp [Collected.start] + obtain ⟨s',reads,_⟩ := parse (q :: post) j ([],openingFrames boundary h) + ⟨by rw [List.flatten_append] at lead; exact lead.symm,by rw [frames,List.flatten_append]⟩ + (by omega) + have start : (Collected.start (p := p) root0).replies.map blankRows = #[] := by simp [Collected.start] + rw [start,← split] at reads + obtain ⟨extra,tail⟩ := walkRead_prefix grinding (q :: post) s' (mid.replies.map blankRows) + have parsed : frameReplies grinding boundary h = mid.replies.map blankRows ++ extra := by + rw [frameReplies,reads,tail] + unfold PCSRoundByRoundTranscriptState.priorAnswers + congr 1 + funext n + have small : n.val < mid.replies.size := by omega + have stored : col.replies[n.val]? = mid.replies[n.val]? := by + rw [repl₂,Array.getElem?_append_left small] + obtain ⟨r,midAt⟩ : ∃ r, mid.replies[n.val]? = some r := ⟨_,getElem?_pos mid.replies n.val small⟩ + rw [midAt] at stored + obtain ⟨c,atN,fit⟩ := forall₂_getElem?_right fitsAll n.val r (by simpa using stored) + rw [getElem!_def,getElem!_def,historyReplies,Array.getElem?_mapIdx,parsed, + Array.getElem?_append_left (by simpa using small),Array.getElem?_map,midAt, + SpongefishCurrentOpeningExperiment.restoredReplies_getElem?,stored] + simp only [Option.map_some] + have placeC := position_at n.val c atN + exact idealReply_restore t root next next' col n.val r c atN fit stored rows + (fun i same => agree _ (by rw [same]; omega)) + (fun i used => levels i (by + rcases used with ⟨i',k,last,more,rfl,rfl⟩ | ⟨i',pos,rfl,rfl⟩ + · exact .inl ⟨i',k,last,more,rfl,by omega⟩ + · exact .inr ⟨i',pos,rfl,by omega⟩)) + +/-- Exactness of the history parser: on the key history of the `j`-th opening draw (coordinate `q`), the replies parsed from the opening frames and completed with the ideal oracles agree, before position `q`, with the walk's replies with restored next oracles. -/ +theorem replies_exact (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (j : Nat) (q : Coord p) + (found : (SpongefishCurrentRoundPackets.openingDraws grinding)[j]? = some (some q)) + (boundary : Nat) (h : FramedHistory) (frames : openingFrames boundary h = (drawRuns E).take j) + (root : BaseOracle) (next : Nat → Oracle) + (rows : SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies root next) + (t : Tape cfg) (agree : ∀ r : Coord p, position r < position q → get r t = get r col.tape) : + PCSRoundByRoundTranscriptState.priorAnswers + (historyReplies grinding boundary h t (SpongefishCurrentOpeningExperiment.levelOracle root next)) + (position q) = + PCSRoundByRoundTranscriptState.priorAnswers + (SpongefishCurrentOpeningExperiment.restoredReplies col next) (position q) := + replies_exact_local H decode grinding lanes root0 E col calls walked j q found boundary h frames root next + rows t agree next (fun _ _ => rfl) + +/-! ## Frames of the replayed opening -/ + +/-- The pending absorb state after a list of events: reads bind, positive draws close the run, hints absorb nothing. -/ +def applyEvents : Pending → List SourceEvent → Pending + | m, [] => m + | m, .prover _ bytes :: rest => applyEvents (SpongefishPCSRoundFrames.bind m bytes) rest + | m, .verifier bytes :: rest => applyEvents (SpongefishPCSRoundFrames.draw m bytes.length) rest + | m, .hint _ :: rest => applyEvents m rest + | m, .publicBytes _ :: rest => applyEvents m rest + +/-- Runs closed by the draws of an event list, starting from the pending run `run`. -/ +def chunks (run : List Byte) : List SourceEvent → List (List Byte) + | [] => [] + | .prover _ bytes :: rest => chunks (run ++ bytes) rest + | .verifier bytes :: rest => + if bytes.length = 0 then chunks run rest else if run = [] then chunks [] rest else run :: chunks [] rest + | .hint _ :: rest => chunks run rest + | .publicBytes _ :: rest => chunks run rest + +def byteRun : ByteFrame → List Byte + | .absorb _ bytes => bytes + +theorem applyEvents_domain : ∀ (m : Pending) (E : List SourceEvent), (applyEvents m E).domain = m.domain + | m, [] => rfl + | m, .prover _ bytes :: rest => by rw [applyEvents,applyEvents_domain,bind_domain] + | m, .verifier bytes :: rest => by + rw [applyEvents,applyEvents_domain] + by_cases zero : bytes.length = 0 + · simp [SpongefishPCSRoundFrames.draw,zero] + · exact (draw_facts m _ zero).2.2 + | m, .hint _ :: rest => by rw [applyEvents,applyEvents_domain] + | m, .publicBytes _ :: rest => by rw [applyEvents,applyEvents_domain] + +theorem bind_run (m : Pending) (bytes : List Byte) : + (SpongefishPCSRoundFrames.bind m bytes).run = m.run ++ bytes := by + by_cases empty : bytes = [] <;> simp [SpongefishPCSRoundFrames.bind,empty] + +theorem apply_frames : ∀ (m : Pending) (E : List SourceEvent), + (applyEvents m E).frames.map byteRun = m.frames.map byteRun ++ chunks m.run E + | m, [] => by simp [applyEvents,chunks] + | m, .prover _ bytes :: rest => by + rw [applyEvents,apply_frames,bind_frames,bind_run] + rfl + | m, .verifier bytes :: rest => by + rw [applyEvents,apply_frames] + by_cases zero : bytes.length = 0 + · simp [SpongefishPCSRoundFrames.draw,zero,chunks] + · by_cases empty : m.run = [] + · simp [SpongefishPCSRoundFrames.draw,zero,chunks,close,empty] + · simp [SpongefishPCSRoundFrames.draw,zero,chunks,close,empty,byteRun] + | m, .hint _ :: rest => by + rw [applyEvents,apply_frames] + rfl + | m, .publicBytes _ :: rest => by + rw [applyEvents,apply_frames] + rfl + +theorem chunks_length_le : ∀ (r : List Byte) (E : List SourceEvent), + (chunks r E).length ≤ (drawRuns E).length + | r, [] => by simp [chunks] + | r, .prover _ bytes :: rest => by + simpa [chunks,drawRuns] using chunks_length_le (r ++ bytes) rest + | r, .verifier bytes :: rest => by + have one := chunks_length_le r rest + have two := chunks_length_le [] rest + simp only [chunks,drawRuns,List.length_cons] + split_ifs <;> simp <;> omega + | r, .hint _ :: rest => by + simpa [chunks,drawRuns] using chunks_length_le r rest + | r, .publicBytes _ :: rest => by + simpa [chunks,drawRuns] using chunks_length_le r rest + +/-- When every draw closes a nonempty run, the closed runs are the starting run with the lead bytes, then every run after a draw but the last. -/ +theorem chunks_full : ∀ (r : List Byte) (E : List SourceEvent), + (drawRuns E).length ≤ (chunks r E).length → + chunks r E = ((r ++ leadBytes E) :: drawRuns E).dropLast + | r, [], _ => by simp [chunks,drawRuns] + | r, .prover _ bytes :: rest, full => by + simp only [chunks,drawRuns,leadBytes] at full ⊢ + rw [chunks_full (r ++ bytes) rest full,List.append_assoc] + | r, .verifier bytes :: rest, full => by + have bound := chunks_length_le [] rest + have bound' := chunks_length_le r rest + simp only [chunks,drawRuns,leadBytes,List.length_cons] at full ⊢ + split_ifs at full ⊢ with zero empty + · omega + · omega + · simp only [List.length_cons] at full + rw [chunks_full [] rest (by omega)] + simp + | r, .hint _ :: rest, full => by + simp only [chunks,drawRuns,leadBytes] at full ⊢ + exact chunks_full r rest full + | r, .publicBytes _ :: rest, full => by + simp only [chunks,drawRuns,leadBytes] at full ⊢ + exact chunks_full r rest full + +theorem drawRuns_length : ∀ E : List SourceEvent, (drawRuns E).length = (verifierBytes E).length + | [] => rfl + | .prover _ _ :: rest => by simpa [drawRuns,verifierBytes] using drawRuns_length rest + | .verifier _ :: rest => by simpa [drawRuns,verifierBytes] using drawRuns_length rest + | .hint _ :: rest => by simpa [drawRuns,verifierBytes] using drawRuns_length rest + | .publicBytes _ :: rest => by simpa [drawRuns,verifierBytes] using drawRuns_length rest + +theorem frames_window (pre runs : List (List Byte)) (x : List Byte) (j : Nat) (hj : j < runs.length) : + ((pre ++ (x :: runs).dropLast).take (pre.length + j + 1)).drop (pre.length + 1) = runs.take j := by + have ne : runs ≠ [] := by + rintro rfl + simp at hj + have hmin : min j (runs.length - 1) = j := by omega + rw [List.dropLast_cons_of_ne_nil ne,List.dropLast_eq_take,List.take_append,List.drop_append, + List.take_of_length_le (by omega : pre.length ≤ pre.length + j + 1)] + simp [show pre.length + j + 1 - pre.length = j + 1 by omega,List.take_take,hmin] + +/-- A history whose opening frames are the first `j` draw runs has the `k`-th run as its absorb frame `boundary + k + 1`. -/ +theorem frame_of_openingFrames (boundary j : Nat) (h : FramedHistory) (runs : List (List Byte)) + (frames : openingFrames boundary h = runs.take j) + (absorbs : ∀ f ∈ h.frames, ∃ previous bytes, f = .absorb previous bytes) + (k : Nat) (bytes : List Byte) (before : k < j) (run : runs[k]? = some bytes) : + ∃ previous, h.frames[boundary + k + 1]? = some (.absorb previous bytes) := by + have at' := congrArg (fun l => l[k]?) frames + simp only [openingFrames,List.getElem?_map,List.getElem?_drop,List.getElem?_take,before,↓reduceIte,run] + at at' + obtain ⟨f,found,same⟩ := Option.map_eq_some_iff.mp at' + obtain ⟨previous,run',rfl⟩ := absorbs f (List.mem_of_getElem? found) + simp only [frameBytes] at same + subst same + exact ⟨previous,by rw [← found]; congr 1; omega⟩ + +open SpongefishCurrentMixedModeCompiler in +/-- The semantic replay under fixed answers appends one call event per call and applies exactly those events to the pending absorb state. -/ +theorem replay_apply (ans : Coordinate → Digest32) (cur : SemanticCursor) (calls : List Call) + (good : CacheOK ans cur.cache) (fin : SemanticCursor) + (ok : (runWith ans (replayProgram cur calls)).result = .ok fin) : + ∃ evs, fin.data.events = cur.data.events ++ evs ∧ List.Forall₂ CallEvent calls evs ∧ + fin.data.pending = applyEvents cur.data.pending evs := by + induction calls generalizing cur with + | nil => + simp only [replayProgram,runWith,Except.ok.injEq] at ok + subst ok + exact ⟨[],by simp,.nil,rfl⟩ + | cons call calls ih => + cases call with + | read kind => + cases parsed : kind.codec.parse cur.data.narg with + | none => simp [replayProgram,parsed,runWith] at ok + | some pair => + obtain ⟨value,rest⟩ := pair + simp only [replayProgram,parsed] at ok + obtain ⟨evs,events,shapes,pending⟩ := ih (readNext cur kind value rest) good ok + refine ⟨.prover kind (kind.codec.bytes value) :: evs,?_,.cons ⟨value,rfl⟩ shapes,?_⟩ + · rw [events] + simp [readNext,boundData] + · rw [pending] + rfl + | hint => + cases hints : cur.data.hints with + | nil => simp [replayProgram,hints,runWith] at ok + | cons bytes rest => + simp only [replayProgram,hints] at ok + obtain ⟨evs,events,shapes,pending⟩ := ih (hintNext cur bytes rest) good ok + refine ⟨.hint bytes :: evs,?_,.cons ⟨bytes,rfl⟩ shapes,?_⟩ + · rw [events] + simp [hintNext] + · rw [pending] + rfl + | draw g => + have positive := group_bytes_pos g + by_cases guard : cur.data.pending.consumed + g.bytes ≤ DuplexRefinement.maxCursor + · simp only [replayProgram,positive,guard,↓reduceDIte,seq,runWith_bind] at ok + obtain ⟨good₁,answer₁,_,_,_⟩ := collect_with ans cur.data.pending + (positions cur.data.pending g.bytes) (positions_valid _ cur.framed _ guard) cur.cache good + generalize (runWith ans (collect cur.data.pending (positions cur.data.pending g.bytes) + (positions_valid _ cur.framed _ guard) cur.cache)) = first at * + obtain ⟨obs₁,cache,bytes⟩ := first + dsimp only at good₁ answer₁ ok + obtain ⟨evs,events,shapes,pending⟩ := ih (drawn cur g.bytes guard cache bytes) good₁ ok + have length : bytes.length = g.bytes := by + rw [answer₁] + simp [positions] + refine ⟨.verifier bytes :: evs,?_,.cons ⟨bytes,length,rfl⟩ shapes,?_⟩ + · rw [events] + simp [drawn] + · rw [pending] + simp [applyEvents,length,drawn] + · simp [replayProgram,positive,guard,runWith] at ok + +theorem frameBytes_core (f : ByteFrame) : frameBytes f.historicalCore = byteRun f := by + cases f + rfl + +section Packets +open DuplexRefinement DuplexFraming DuplexModeGame RawOracleCoupling TypedOracleCompiler SpongefishCurrentModeQueries +open SpongefishCurrentMixedModeCompiler SpongefishCurrentRoundPackets + +/-- `SpongefishCurrentOpeningPackets.opening_packets` with the frame content of its histories: the opening events have the call shapes of the opening, and the opening frames (index `boundary + 1` on) of the `j`-th draw history are the first `j` prover runs after the opening draws. Frame `boundary + k + 1` of every later history is the absorb frame of the prover bytes between the `k`-th and `(k+1)`-th verifier events, and the opening adds no byte before its first draw. -/ +theorem opening_frames {S : Type} (Q : Nat) (iv : Digest32) + (grinding : Fin (cfg).folds.size → Fin 64) (boundary : Nat) + (tag instanceBytes : List Byte) (pre : List Call) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (k : Option SpongefishCurrentInitializedMode.Result → Program S) + (counted : Counts Q (WHIRModeFinal.bind (SpongefishCurrentInitializedMode.afterPrefix iv tag + instanceBytes prefixProgram (pre ++ openingCalls grinding)) k)) + (shape : openingShape instanceBytes pre = (boundary,true)) + (table : (key : Key p Q iv grinding boundary) → Answer p Q iv grinding boundary key) + (data : Data) + (success : (Sampling.eval table (SpongefishCurrentBCSKnowledge.source + (partition p Q iv grinding boundary) iv + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram + (pre ++ openingCalls grinding)) + (WHIRModeFinal.bind_prefix_counted _ k Q counted))).result = some (.ok data)) : + ∃ histories : List FramedHistory, + histories.length = (openingDraws grinding).length ∧ + (∀ (j : Nat) (h : FramedHistory), histories[j]? = some h → h.frames.length = boundary + j + 1) ∧ + (∀ (i j : Nat) (hi hj : FramedHistory), i ≤ j → histories[i]? = some hi → + histories[j]? = some hj → hi = {hj with frames := hj.frames.take (boundary + i + 1)}) ∧ + (verifierBytes (SpongefishCurrentOpeningPackets.openingEvents grinding data.events)).length = + (openingDraws grinding).length ∧ + (∀ (j : Nat) (h : FramedHistory) (bytes : List Byte), histories[j]? = some h → + (verifierBytes (SpongefishCurrentOpeningPackets.openingEvents grinding data.events))[j]? = some bytes → + ∃ g, (drawGroups (openingCalls grinding))[j]? = some g ∧ + bytes = (List.range g.bytes).map (fun i => idealAnswer Q iv + (roOf (partition p Q iv grinding boundary) table) ⟨h,.output (i/32)⟩ + ⟨i%32,Nat.mod_lt _ (by decide)⟩)) ∧ + (∀ (j : Nat) (q : Coord p), (openingDraws grinding)[j]? = some (some q) → + ∃ (packet : Packet p Q grinding boundary) (bytes : List Byte), + packet.coord = q ∧ histories[j]? = some packet.history ∧ + (verifierBytes (SpongefishCurrentOpeningPackets.openingEvents grinding data.events))[j]? = + some bytes ∧ + decodeSample packet.coord bytes = + PCSBCSChallengeOracle.grouped packet.coord (table (.inl packet)) ∧ + (⟨.inl packet,table (.inl packet)⟩ : Sigma (Answer p Q iv grinding boundary)) ∈ + (Sampling.execute table (SpongefishCurrentBCSKnowledge.source + (partition p Q iv grinding boundary) iv + (WHIRModeFinal.bind (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes + prefixProgram (pre ++ openingCalls grinding)) k) counted)).2) ∧ + List.Forall₂ CallEvent (openingCalls grinding) + (SpongefishCurrentOpeningPackets.openingEvents grinding data.events) ∧ + leadBytes (SpongefishCurrentOpeningPackets.openingEvents grinding data.events) = [] ∧ + (∀ (j : Nat) (h : FramedHistory), histories[j]? = some h → + openingFrames boundary h = + (drawRuns (SpongefishCurrentOpeningPackets.openingEvents grinding data.events)).take j ∧ + ∀ f ∈ h.frames, ∃ previous bytes, f = .absorb previous bytes) ∧ + (∀ (j : Nat) (h : FramedHistory) (k : Nat) (bytes : List Byte), histories[j]? = some h → k < j → + (drawRuns (SpongefishCurrentOpeningPackets.openingEvents grinding data.events))[k]? = some bytes → + ∃ previous, h.frames[boundary + k + 1]? = some (.absorb previous bytes)) ∧ + (∀ h : FramedHistory, histories[0]? = some h → + SpongefishCurrentGoodEvent.postBinding boundary data = ⟨h,.output 0⟩) := by + let part := partition p Q iv grinding boundary + let ro := roOf part table + let ans := idealAnswer Q iv ro + rw [eval_source] at success + obtain ⟨session,narg,hints,fin,replayOk,finData,replayInside⟩ := afterPrefix_replay + (DuplexPublicSimulator.simulator Q) ro iv tag instanceBytes prefixProgram + (pre ++ openingCalls grinding) _ Q (Nat.le_refl Q) _ data success + obtain ⟨oldInside,_⟩ := ideal_bind_parts (DuplexPublicSimulator.simulator Q) ro iv _ k + ⟨seedOf part table,[]⟩ Q (Nat.le_refl Q) counted + have inFinal : ∀ o ∈ (runWith ans (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) + (pre ++ openingCalls grinding))).observations, + o ∈ (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv _ counted)).observations := by + rw [eval_source] + exact fun o h => oldInside o (replayInside o h) + obtain ⟨mid,preOk,openOk,obsSplit⟩ := replay_append ans _ pre (openingCalls grinding) fin replayOk + obtain ⟨midShaped,midGood,midKnown⟩ := replay_shape ans _ pre _ + (initial_shaped session instanceBytes narg hints) (fun _ _ h => by cases h) mid preOk + rw [show frameShape (0,decide (instanceBytes ≠ [])) pre = (boundary,true) from shape] at midShaped + obtain ⟨midFrames,midReady,midZeroed⟩ := midShaped + have midRun : mid.data.pending.run ≠ [] := midReady.mp rfl + obtain ⟨evs,ms,events,evLength,_,msLength,bytesLength,facts⟩ := replay_draws ans mid + (openingCalls grinding) false (by simpa using midRun) midZeroed (scan_opening_calls grinding) + midGood fin openOk + obtain ⟨evs',events',calls',pending'⟩ := replay_apply ans mid (openingCalls grinding) midGood fin openOk + have sameEvs : evs' = evs := by + rw [events] at events' + exact (List.append_cancel_left events').symm + subst sameEvs + have openEvents : SpongefishCurrentOpeningPackets.openingEvents grinding data.events = evs' := by + rw [← finData,events] + unfold SpongefishCurrentOpeningPackets.openingEvents + rw [List.length_append,evLength,Nat.add_sub_cancel] + exact List.drop_left + have matched := opening_matches grinding (p := p) + have drawLength : (drawGroups (openingCalls grinding)).length = (openingDraws grinding).length := + matched.length_eq.symm + have factAt : ∀ j m, ms[j]? = some m → ∃ g bytes, (drawGroups (openingCalls grinding))[j]? = some g ∧ + (verifierBytes evs')[j]? = some bytes ∧ + DrawFact ans mid.data.pending.domain mid.data.pending.frames.length mid.cache + fin.data.pending.frames (runWith ans (replayProgram mid (openingCalls grinding))).observations + j g m bytes := by + intro j m found + have within : j < ms.length := (List.getElem?_eq_some_iff.mp found).1 + obtain ⟨g,hg⟩ : ∃ g, (drawGroups (openingCalls grinding))[j]? = some g := + ⟨_,List.getElem?_eq_getElem (by omega)⟩ + obtain ⟨bytes,hb⟩ : ∃ bytes, (verifierBytes evs')[j]? = some bytes := + ⟨_,List.getElem?_eq_getElem (by omega)⟩ + exact ⟨g,bytes,hg,hb,facts j g m bytes hg found hb⟩ + have historyLength : ∀ j m, ms[j]? = some m → + ((close m).core.history.frames).length = boundary + j + 1 := by + intro j m found + obtain ⟨g,bytes,_,_,fact⟩ := factAt j m found + simp only [Pending.core,List.length_map,close_frames m fact.run_ne,List.length_append, + List.length_singleton,fact.frames_eq,midFrames] + have closedTake : ∀ j m, ms[j]? = some m → + (close m).frames = fin.data.pending.frames.take (boundary + j + 1) := by + intro j m found + obtain ⟨_,_,_,_,fact⟩ := factAt j m found + have length := historyLength j m found + simp only [Pending.core,List.length_map] at length + rw [List.prefix_iff_eq_take.mp fact.closed,length] + -- every draw closes a nonempty run, so the closed runs are the lead run then the draw runs + have lead := leadBytes_opening grinding evs' calls' + obtain ⟨restCalls,head⟩ := openingCalls_head grinding (p := p) + have positiveDraws : 0 < (openingDraws grinding).length := by + rw [← drawLength,head] + simp [drawGroups] + have runsLength : (drawRuns evs').length = (openingDraws grinding).length := by + rw [drawRuns_length,bytesLength,drawLength] + have applied := apply_frames mid.data.pending evs' + rw [← pending'] at applied + have full : chunks mid.data.pending.run evs' = ((mid.data.pending.run ++ leadBytes evs') :: + drawRuns evs').dropLast := by + apply chunks_full + obtain ⟨m,lastAt⟩ : ∃ m, ms[(openingDraws grinding).length - 1]? = some m := + ⟨_,List.getElem?_eq_getElem (by omega)⟩ + obtain ⟨_,_,_,_,fact⟩ := factAt _ m lastAt + have length := historyLength _ m lastAt + simp only [Pending.core,List.length_map] at length + have bigger := fact.closed.length_le + have total := congrArg List.length applied + simp only [List.length_map,List.length_append,midFrames] at total + omega + have windowAt : ∀ j m, ms[j]? = some m → + openingFrames boundary (close m).core.history = (drawRuns evs').take j := by + intro j m found + have within : j < (drawRuns evs').length := by + have := (List.getElem?_eq_some_iff.mp found).1 + omega + have bytesOf : (fin.data.pending.frames.map byteRun) = + (mid.data.pending.frames.map byteRun) ++ ((mid.data.pending.run ++ leadBytes evs') :: + drawRuns evs').dropLast := by + rw [applied,full] + have preLength : (mid.data.pending.frames.map byteRun).length = boundary := by + simp [midFrames] + unfold openingFrames + simp only [Pending.core,closedTake j m found,List.map_drop,List.map_take,List.map_map] + rw [show (frameBytes ∘ ByteFrame.historicalCore) = byteRun from funext frameBytes_core,bytesOf, + ← preLength] + exact frames_window _ _ _ j within + have absorbsAt : ∀ m : Pending, ∀ f ∈ (close m).core.history.frames, + ∃ previous bytes, f = .absorb previous bytes := by + intro m f member + simp only [Pending.core,List.mem_map] at member + obtain ⟨g,_,rfl⟩ := member + cases g with + | absorb previous bytes => exact ⟨previous,bytes,rfl⟩ + have domainEq : fin.data.pending.domain = mid.data.pending.domain := by + rw [pending'] + exact applyEvents_domain _ _ + have postEq : ∀ m, ms[0]? = some m → + SpongefishCurrentGoodEvent.postBinding boundary data = ⟨(close m).core.history,.output 0⟩ := by + intro m found + obtain ⟨_,_,_,_,fact⟩ := factAt 0 m found + have takeEq := closedTake 0 m found + have length := historyLength 0 m found + simp only [Pending.core,List.length_map] at length + have long : boundary + 0 + 1 ≤ fin.data.pending.frames.length := by + have := fact.closed.length_le + omega + obtain ⟨extra,closeEq⟩ := close_prefix fin.data.pending + unfold SpongefishCurrentGoodEvent.postBinding + rw [← finData] + simp only [Pending.core,close_domain,fact.domain_eq,domainEq,← List.map_take,← closeEq, + List.take_append_of_le_length long,← takeEq] + refine ⟨ms.map (fun m => (close m).core.history),by simp [msLength,drawLength],?_,?_, + by rw [openEvents,bytesLength,drawLength],?_,?_,by rw [openEvents]; exact calls', + by rw [openEvents]; exact lead,?_,?_,?_⟩ + · intro j h found + rw [List.getElem?_map] at found + obtain ⟨m,member,rfl⟩ := Option.map_eq_some_iff.mp found + exact historyLength j m member + · intro i j hi hj order foundI foundJ + rw [List.getElem?_map] at foundI foundJ + obtain ⟨mi,memberI,rfl⟩ := Option.map_eq_some_iff.mp foundI + obtain ⟨mj,memberJ,rfl⟩ := Option.map_eq_some_iff.mp foundJ + obtain ⟨_,_,_,_,factI⟩ := factAt i mi memberI + obtain ⟨_,_,_,_,factJ⟩ := factAt j mj memberJ + have lengthI := historyLength i mi memberI + have lengthJ := historyLength j mj memberJ + simp only [Pending.core,List.length_map] at lengthI lengthJ + have nested : (close mi).frames <+: (close mj).frames := + List.prefix_of_prefix_length_le factI.closed factJ.closed (by omega) + have taken := List.prefix_iff_eq_take.mp nested + rw [lengthI] at taken + simp only [Pending.core,close_domain,factI.domain_eq,factJ.domain_eq,← List.map_take,← taken] + · intro j h bytes found bytesAt + rw [List.getElem?_map] at found + obtain ⟨m,member,rfl⟩ := Option.map_eq_some_iff.mp found + obtain ⟨g,bytes',groupAt,bytesAt',fact⟩ := factAt j m member + rw [openEvents,bytesAt'] at bytesAt + cases bytesAt + refine ⟨g,groupAt,?_⟩ + rw [fact.bytes_eq] + simp only [positions,fact.consumed_eq,Nat.zero_add,List.map_map] + rfl + · intro j q found + obtain ⟨g,groupAt,groupEq⟩ := forall₂_getElem? matched j (some q) found + change g = group q at groupEq + have within : j < ms.length := by + have := (List.getElem?_eq_some_iff.mp groupAt).1 + omega + obtain ⟨m,member⟩ : ∃ m, ms[j]? = some m := ⟨_,List.getElem?_eq_getElem within⟩ + obtain ⟨g',bytes,groupAt',bytesAt,fact⟩ := factAt j m member + rw [groupAt] at groupAt' + cases groupAt' + subst groupEq + have width := openingDraws_width grinding q (List.mem_of_getElem? found) + have groupBytes := group_bytes q width + have seen : Observed ans (runWith ans (replayProgram + (SpongefishCurrentInitializedMode.initial session instanceBytes narg hints) + (pre ++ openingCalls grinding))).observations (coordinate m 0) := by + rw [obsSplit] + rcases fact.first with cached | observed + · rcases midKnown _ cached with impossible | observed + · exact (impossible rfl).elim + · exact observed_mono ans _ _ _ (fun o h => List.mem_append_left _ h) observed + · exact observed_mono ans _ _ _ (fun o h => List.mem_append_right _ h) observed + obtain ⟨valid0,seenAt⟩ := seen + have bound0 : pathCost (coordinate m 0) ≤ Q := by + have final := inFinal _ seenAt + rw [eval_source] at final + exact ideal_cost _ _ _ _ _ _ _ _ _ final + have bound : ∀ b, pathCost (coordinate m b) ≤ Q := fun b => (coordinate_cost m b).le.trans bound0 + have small : ∀ b : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth q)), b.val < 2^44 := by + intro b + have := b.isLt + have guard := fact.guard + simp only [PCSBCSChallengeOracle.blocks,maxCursor] at this guard + omega + let packet : Packet p Q grinding boundary := + { history := (close m).core.history + coord := q + classified := by + unfold classify + rw [historyLength j m member] + simp [show boundary < boundary + j + 1 by omega, + show boundary + j + 1 - boundary - 1 = j by omega,found] + admissible := fun b => coordinate_admissible m fact.framed b.val (small b) + bounded := fun b => bound b.val } + have blockAnswer : ∀ b : Fin (PCSBCSChallengeOracle.blocks (PCSBCSRounds.rawWidth q)), + ans (coordinate m b.val) = table (.inl packet) b := by + intro b + have encoded : part.encode ⟨packet,b⟩ = .inr (constructionKey Q iv (coordinate m b.val) (bound b.val)) := + rfl + simp only [ans,idealAnswer,bound b.val,↓reduceDIte,ro,roOf] + rw [← encoded] + exact join_encode part table ⟨packet,b⟩ + refine ⟨packet,bytes,rfl,by simp [member,packet],by rw [openEvents]; exact bytesAt,?_,?_⟩ + · apply decode_grouped + intro i within + rw [fact.bytes_eq] + change i < 24 * PCSBCSRounds.rawWidth q at within + have inGroup : i < (group q).bytes := by omega + simp only [positions,fact.consumed_eq,Nat.zero_add,List.map_map,List.getElem?_map, + List.getElem?_range inGroup,Option.map_some,Function.comp_apply] + exact congrArg some (congrFun (blockAnswer ⟨i/32,by unfold PCSBCSChallengeOracle.blocks; omega⟩) _) + · apply observed_recorded part iv _ counted table (coordinate m 0) valid0 (ans (coordinate m 0)) + (inFinal _ seenAt) ⟨packet,firstBlock packet⟩ + intro bound' + have encoded : part.encode ⟨packet,firstBlock packet⟩ = .inr (constructionKey Q iv (coordinate m 0) bound') := + rfl + rw [← encoded] + exact part.recognize_encode _ + · intro j h found + rw [List.getElem?_map] at found + obtain ⟨m,member,rfl⟩ := Option.map_eq_some_iff.mp found + rw [openEvents] + exact ⟨windowAt j m member,absorbsAt m⟩ + · intro j h k bytes found before run + rw [List.getElem?_map] at found + obtain ⟨m,member,rfl⟩ := Option.map_eq_some_iff.mp found + rw [openEvents] at run + exact frame_of_openingFrames boundary j _ (drawRuns evs') (windowAt j m member) (absorbsAt m) k bytes + before run + · intro h found + rw [List.getElem?_map] at found + obtain ⟨m,member,rfl⟩ := Option.map_eq_some_iff.mp found + exact postEq m member + +end Packets + +/-! ## Tape, seed, roots and query replies of the walk -/ + +theorem split_post (q : Coord p) (pre post : List (Coord p)) + (split : WHIRHistory.schedule cfg = pre ++ q :: post) : q ∉ post := by + have nd := WHIRHistory.schedule_nodup cfg + rw [split,List.nodup_append,List.nodup_cons] at nd + exact nd.2.1.1 + +theorem split_of_mem (q : Coord p) : + ∃ pre post, WHIRHistory.schedule cfg = pre ++ q :: post ∧ q ∉ pre ∧ q ∉ post := by + obtain ⟨pre,post,split⟩ := List.append_of_mem (WHIRHistory.coordinate_mem_schedule q) + have nd := WHIRHistory.schedule_nodup cfg + rw [split,List.nodup_append,List.nodup_cons] at nd + exact ⟨pre,post,split,fun member => nd.2.2 q member q List.mem_cons_self rfl,nd.2.1.1⟩ + +/-- The walk on the opening call events, split at a scheduled coordinate: the blocks before it, its own block and step, and the blocks after it. -/ +theorem walk_at (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (q : Coord p) (pre post : List (Coord p)) (split : WHIRHistory.schedule cfg = pre ++ q :: post) : + ∃ (bpre : List (List SourceEvent)) (bq : List SourceEvent) (bpost : List (List SourceEvent)) + (mid : Collected p) (st : List SourceEvent × Collected p) (fin : List SourceEvent), + E = bpre.flatten ++ (bq ++ bpost.flatten) ∧ Blocks grinding pre bpre ∧ + List.Forall₂ CallEvent (callsOf grinding q) bq ∧ Blocks grinding post bpost ∧ + WalkOutcome grinding pre bpre (bq ++ bpost.flatten) (Collected.start root0) + (bq ++ bpost.flatten,mid) ∧ + StepOutcome H decode grinding lanes q bq bpost.flatten mid st ∧ + WalkOutcome grinding post bpost [] st.2 (fin,col) := by + obtain ⟨bx,fin,rfl,blocks,ev⟩ := walk_whole H decode grinding lanes root0 E col calls walked + rw [split] at blocks ev + obtain ⟨bpre,brest,rfl,bp,br⟩ := forall₂_split blocks + rcases br with _ | @⟨_,bq,_,bpost,shape,bpo⟩ + simp only [List.flatten_append,List.flatten_cons,List.append_nil] at ev ⊢ + obtain ⟨mid,first,second⟩ := walk_split H decode grinding lanes pre (q :: post) bpre + (bq ++ bpost.flatten) (Collected.start root0) (fin,col) bp ev + have before := walk_run H decode grinding lanes pre bpre _ _ _ bp first + rw [walk_cons_eval] at second + obtain ⟨st,stepOk,restOk⟩ := Option.bind_eq_some_iff.mp second + have step := step_block H decode grinding lanes q bq bpost.flatten mid st shape stepOk + obtain ⟨st₁,st₂⟩ := st + have rest : st₁ = bpost.flatten := step.1 + subst rest + have after := walk_run H decode grinding lanes post bpost [] st₂ (fin,col) bpo (by simpa using restOk) + exact ⟨bpre,bq,bpost,mid,(bpost.flatten,st₂),fin,rfl,bp,shape,bpo,before,step,after⟩ + +theorem mid_size (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) (pre post : List (Coord p)) + (split : WHIRHistory.schedule cfg = pre ++ q :: post) (notin : q ∉ pre) + (bpre : List (List SourceEvent)) (R : List SourceEvent) (root0 : Digest32) (mid : Collected p) + (out : WalkOutcome grinding pre bpre R (Collected.start root0) (R,mid)) : + mid.replies.size = position q := by + obtain ⟨_,_,_,⟨rs,repl,fits⟩,_⟩ := out + have allVisible : pre.filter visibleQ = pre := + List.filter_eq_self.mpr (fun r m => visibleQ_of_mem r (split_visible q pre post split r m)) + rw [allVisible] at fits + simp only at repl + rw [repl,split_position q pre post split notin,fits.length_eq] + simp [Collected.start] + +theorem headD_drop (l : List (List Byte)) (n : Nat) (b : List Byte) (h : l[n]? = some b) : + (l.drop n).headD [] = b := by + rw [List.headD_eq_head?_getD,List.head?_drop,h] + rfl + +/-- The PCS draw bytes of a coordinate block are the verifier bytes of the whole opening at the coordinate's draw index. -/ +theorem sample_eq (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) (bpre : List (List SourceEvent)) + (bq rest : List SourceEvent) (j : Nat) (bytes : List Byte) + (index : j = (verifierBytes bpre.flatten).length + (powDraws grinding q).length) + (vq : (verifierBytes bq).length = (drawList grinding q).length) (width : PCSBCSRounds.rawWidth q ≠ 0) + (drawn : (verifierBytes (bpre.flatten ++ (bq ++ rest)))[j]? = some bytes) : + sampleBytes grinding q bq = bytes := by + have lengthQ : (verifierBytes bq).length = (powDraws grinding q).length + 1 := by + rw [vq] + simp [drawList,pcsDraws,width] + rw [verifierBytes_append,verifierBytes_append,index, + List.getElem?_append_right (by omega),Nat.add_sub_cancel_left, + List.getElem?_append_left (by omega)] at drawn + exact headD_drop _ _ _ drawn + +/-- Tape of the walk at a PCS draw: the coordinate's sample is the decoded verifier bytes of its opening draw. -/ +theorem tape_draw (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (j : Nat) (q : Coord p) (bytes : List Byte) + (found : (SpongefishCurrentRoundPackets.openingDraws grinding)[j]? = some (some q)) + (drawn : (verifierBytes E)[j]? = some bytes) : + get q col.tape = StackWHIRReplay.projectSample q (decodeSample q bytes) := by + obtain ⟨pre,post,split,_,index⟩ := flatMap_index grinding _ (WHIRHistory.schedule_nodup cfg) j q + (by rw [← openingDraws_eq]; exact found) + obtain ⟨bpre,bq,bpost,mid,st,fin,rfl,_,_,_,before,step,after⟩ := + walk_at H decode grinding lanes root0 E col calls walked q pre post split + have width := SpongefishCurrentRoundPackets.openingDraws_width grinding q (List.mem_of_getElem? found) + obtain ⟨_,vPre,_⟩ := before + obtain ⟨_,vq,_,tape,_⟩ := step + obtain ⟨_,_,_,_,_,tapeRest,_⟩ := after + rw [tapeRest q (split_post q pre post split),tape,get_set, + sample_eq grinding q bpre bq bpost.flatten j bytes (by rw [vPre]; exact index) vq width drawn] + +/-- Tape of the walk at a zero-width coordinate. -/ +theorem tape_zero (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (q : Coord p) (zero : PCSBCSRounds.rawWidth q = 0) : + get q col.tape = StackWHIRReplay.projectSample q (decodeSample q []) := by + obtain ⟨pre,post,split,_,later⟩ := split_of_mem q + obtain ⟨bpre,bq,bpost,mid,st,fin,rfl,_,_,_,_,step,after⟩ := + walk_at H decode grinding lanes root0 E col calls walked q pre post split + obtain ⟨_,vq,_,tape,_⟩ := step + obtain ⟨_,_,_,_,_,tapeRest,_⟩ := after + have empty : sampleBytes grinding q bq = [] := by + have : (verifierBytes bq).length ≤ (powDraws grinding q).length := by + rw [vq] + simp [drawList,pcsDraws,zero] + simp [sampleBytes,List.drop_eq_nil_of_le this] + rw [tapeRest q later,tape,get_set,empty] + +/-- Seed of the walk: the decoded verifier bytes of the initial draw. -/ +theorem seed_draw (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (j : Nat) (bytes : List Byte) + (found : (SpongefishCurrentRoundPackets.openingDraws grinding)[j]? = some (some .initial)) + (drawn : (verifierBytes E)[j]? = some bytes) : + col.seed = some (decodeSample (.initial : Coord p) bytes) := by + obtain ⟨pre,post,split,_,index⟩ := flatMap_index grinding _ (WHIRHistory.schedule_nodup cfg) j _ + (by rw [← openingDraws_eq]; exact found) + obtain ⟨bpre,bq,bpost,mid,st,fin,rfl,_,_,_,before,step,after⟩ := + walk_at H decode grinding lanes root0 E col calls walked _ pre post split + have width := SpongefishCurrentRoundPackets.openingDraws_width grinding _ (List.mem_of_getElem? found) + obtain ⟨_,vPre,_⟩ := before + obtain ⟨_,vq,_,_,seed,_⟩ := step + obtain ⟨_,_,_,_,_,_,seedRest,_⟩ := after + rw [seedRest (split_post _ pre post split),seed, + sample_eq grinding _ bpre bq bpost.flatten j bytes (by rw [vPre]; exact index) vq width drawn] + rfl + +/-- The first walk root is the commitment root the walk starts from. -/ +theorem root_start (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) : + col.roots[0]? = some root0 := by + obtain ⟨bx,fin,rfl,blocks,ev⟩ := walk_whole H decode grinding lanes root0 E col calls walked + obtain ⟨_,_,_,_,⟨rts,roots,_⟩,_⟩ := walk_run H decode grinding lanes _ bx [] _ _ blocks ev + simp only at roots + rw [roots] + simp [Collected.start] + +/-- The authenticated query reply of level `i` sits at reply position `position (.query i)`; its opening is recorded, its root is the walk's level root `i`, and its proof and rows come from the decoder and the whole-hash Merkle program at the final tape. -/ +theorem query_reply (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (i : Fin (cfg).folds.size) : + ∃ (hint : List Byte) (proof : MerkleTransport.PrunedMerklePaths) (root : Digest32) + (opened : WHIRPhysicalVerifier.Opened) (m : Message Concrete.E), + col.replies[position (.query i : Coord p)]? = some (.query opened.rows m) ∧ + (⟨i,root,hint,proof,opened⟩ : QueryOpening p) ∈ col.openings ∧ + col.roots[i.val]? = some root ∧ + decode (WHIRPhysicalVerifier.queryIndices p i (get (.query i) col.tape)) (rowWords lanes i) hint = + some proof ∧ + HashProgram.eval H (openProgram lanes i root proof (get (.query i) col.tape)) = some opened := by + obtain ⟨pre,post,split,notin,later⟩ := split_of_mem (.query i : Coord p) + obtain ⟨bpre,bq,bpost,mid,st,fin,rfl,_,_,_,before,step,after⟩ := + walk_at H decode grinding lanes root0 E col calls walked _ pre post split + have size := mid_size grinding _ pre post split notin bpre _ root0 mid before + obtain ⟨_,_,_,_,_,_,_,rootsSame,_,_,queries⟩ := step + obtain ⟨hint,proof,root,opened,m,r₁,r₂,r₃,r₄,r₅⟩ := queries i rfl + obtain ⟨_,_,_,⟨rs,repl,_⟩,⟨rts,roots,_⟩,tapeRest,_,opens⟩ := after + simp only at repl roots tapeRest opens r₁ r₂ r₃ r₄ r₅ + have rootsEq : st.2.roots = mid.roots := rootsSame rfl + have tapeEq := tapeRest _ later + refine ⟨hint,proof,root,opened,m,?_,?_,?_,?_,?_⟩ + · rw [repl,r₁,← size,Array.getElem?_append_left (by simp)] + simp + · apply opens + rw [r₂] + exact List.mem_append_right _ (List.mem_singleton_self _) + · have within : i.val < mid.roots.size := (Array.getElem?_eq_some_iff.mp r₃).1 + rw [roots,rootsEq,Array.getElem?_append_left within] + exact r₃ + · rw [tapeEq] + exact r₄ + · rw [tapeEq] + exact r₅ + +/-! ## Level roots -/ + +theorem mem_level (n : Fin (cfg).folds.size) (x : Coord p) (member : x ∈ levelCoordinates cfg n.val) : + (∃ k, x = .fold n k) ∨ (∃ k, x = .ood n k) ∨ x = .query n := by + unfold levelCoordinates at member + rw [dite_eq_left n.isLt] at member + simp only [List.mem_append,List.mem_ofFn,List.mem_singleton] at member + rcases member with (⟨k,rfl⟩ | ⟨k,rfl⟩) | rfl + · exact .inl ⟨k,rfl⟩ + · exact .inr (.inl ⟨k,rfl⟩) + · exact .inr (.inr rfl) + +theorem fold_mem_level (n : Fin (cfg).folds.size) (k : Fin (cfg).folds[n.val]!) : + (.fold n k : Coord p) ∈ levelCoordinates cfg n.val := by + unfold levelCoordinates + rw [dite_eq_left n.isLt] + exact List.mem_append_left _ (List.mem_append_left _ (List.mem_ofFn.mpr ⟨k,rfl⟩)) + +theorem rootFold_level (n : Fin (cfg).folds.size) (x : Coord p) (member : x ∈ levelCoordinates cfg n.val) + (root : rootFold x = true) : ∃ k, x = .fold n k ∧ isLastFold n k = true := by + rcases mem_level n x member with ⟨k,rfl⟩ | ⟨k,rfl⟩ | rfl + · simp only [rootFold,Bool.and_eq_true] at root + exact ⟨k,rfl,root.1⟩ + · simp [rootFold] at root + · simp [rootFold] at root + +theorem level_count (n : Fin (cfg).folds.size) (more : n.val + 1 < (cfg).folds.size) : + ((levelCoordinates cfg n.val).filter rootFold).length = 1 := by + have pos := WHIRQueryOracleRecurrence.production_folds_positive p n + have mem := fold_mem_level n ⟨(cfg).folds[n.val]! - 1,by omega⟩ + have same : (levelCoordinates cfg n.val).filter rootFold = (levelCoordinates cfg n.val).filter + (· == (.fold n ⟨(cfg).folds[n.val]! - 1,by omega⟩ : Coord p)) := by + apply List.filter_congr + intro x member + rcases mem_level n x member with ⟨k,rfl⟩ | ⟨k,rfl⟩ | rfl + · have := k.isLt + rw [Bool.eq_iff_iff] + simp only [rootFold,isLastFold,Bool.and_eq_true,decide_eq_true_eq,beq_iff_eq, + CausalProbability.Coordinate.fold.injEq,heq_eq_eq,true_and,Fin.ext_iff] + constructor + · intro h + omega + · intro h + exact ⟨by omega,more⟩ + · simp [rootFold] + · simp [rootFold] + rw [same,← List.count_eq_length_filter] + exact (WHIRHistory.levelCoordinates_nodup cfg n.val).count_of_mem mem + +theorem levels_count : ∀ (i : Nat), i + 1 < (cfg).folds.size → + (((List.range i).flatMap (levelCoordinates cfg)).filter (rootFold (p := p))).length = i + | 0, _ => by simp + | m + 1, bound => by + rw [List.range_succ,List.flatMap_append,List.filter_append,List.length_append, + levels_count m (by omega)] + have one := level_count (p := p) ⟨m,by omega⟩ (by simp only; omega) + simp only at one + simp [one] + +theorem split_unique {A : Type} [DecidableEq A] (l a b a' b' : List A) (x : A) + (h : l = a ++ x :: b) (h' : l = a' ++ x :: b') (n : x ∉ a) (n' : x ∉ a') : a = a' := by + have e₁ : l.idxOf x = a.length := by + rw [h,List.idxOf_append_of_notMem n] + simp + have e₂ : l.idxOf x = a'.length := by + rw [h',List.idxOf_append_of_notMem n'] + simp + calc a = l.take a.length := by rw [h]; exact List.take_left.symm + _ = l.take a'.length := by rw [← e₁,← e₂] + _ = a' := by rw [h']; exact List.take_left + +/-- Before the last fold of level `i`, the schedule has exactly `i` root-carrying folds. -/ +theorem fold_prefix_count (i : Fin (cfg).folds.size) (k : Fin (cfg).folds[i.val]!) + (last : isLastFold i k = true) (more : i.val + 1 < (cfg).folds.size) (pre post : List (Coord p)) + (split : WHIRHistory.schedule cfg = pre ++ .fold i k :: post) (notin : (.fold i k : Coord p) ∉ pre) : + (pre.filter rootFold).length = i.val := by + have hr : List.range (cfg).folds.size = List.range i.val ++ [i.val] ++ + (List.range ((cfg).folds.size-(i.val+1))).map (fun x => i.val+1+x) := by + calc + List.range (cfg).folds.size = + List.range ((i.val+1)+((cfg).folds.size-(i.val+1))) := congrArg List.range (by omega) + _ = _ := by rw [List.range_add,List.range_succ] + obtain ⟨X,Y,levelSplit⟩ := List.append_of_mem (fold_mem_level i k) + have decomposed : WHIRHistory.schedule cfg = + ([.initial] ++ (List.range i.val).flatMap (levelCoordinates cfg) ++ X) ++ .fold i k :: + (Y ++ ((List.range ((cfg).folds.size-(i.val+1))).map (fun x => i.val+1+x)).flatMap + (levelCoordinates cfg) ++ + List.ofFn (fun j : Fin ((cfg).logN - (cfg).folds.toList.sum - 1) => + (Coordinate.tail ⟨j.val,by omega⟩ : Coord p)) ++ WHIRHistory.hiddenTail cfg) := by + unfold WHIRHistory.schedule visibleCoordinates + rw [hr] + simp only [List.flatMap_append,List.flatMap_cons,levelSplit, + List.append_assoc,List.cons_append,List.nil_append] + have nd := WHIRHistory.schedule_nodup cfg + rw [decomposed,List.nodup_append] at nd + have notin' : (.fold i k : Coord p) ∉ [.initial] ++ (List.range i.val).flatMap (levelCoordinates cfg) ++ X := + fun member => nd.2.2 _ member _ List.mem_cons_self rfl + rw [split_unique _ _ _ _ _ _ split decomposed notin notin',List.filter_append,List.filter_append, + List.length_append,List.length_append,levels_count i.val more] + have ndLevel := WHIRHistory.levelCoordinates_nodup cfg i.val + rw [levelSplit,List.nodup_append] at ndLevel + have empty : X.filter rootFold = [] := by + rw [List.filter_eq_nil_iff] + intro x member root + obtain ⟨k',rfl,last'⟩ := rootFold_level i x (by rw [levelSplit]; exact List.mem_append_left _ member) + root + have same : k' = k := by + simp only [isLastFold,decide_eq_true_eq] at last last' + exact Fin.ext (by omega) + subst same + exact ndLevel.2.2 _ member _ List.mem_cons_self rfl + simp [empty,rootFold] + +theorem drawRuns_at : ∀ (A C : List SourceEvent) (b : List Byte), + (drawRuns (A ++ .verifier b :: C))[(verifierBytes A).length]? = some (leadBytes C) + | [], C, b => by simp [drawRuns,verifierBytes] + | .prover _ _ :: A, C, b => by simpa [drawRuns,verifierBytes] using drawRuns_at A C b + | .verifier _ :: A, C, b => by simpa [drawRuns,verifierBytes] using drawRuns_at A C b + | .hint _ :: A, C, b => by simpa [drawRuns,verifierBytes] using drawRuns_at A C b + | .publicBytes _ :: A, C, b => by simpa [drawRuns,verifierBytes] using drawRuns_at A C b + +/-- Level root of the walk: at the draw of the last fold of level `i` (with a next level), the prover run after the draw starts with the fold message and the next root, that root is the walk's level root `i+1`, and a later opening draw closes this run into a frame. -/ +theorem level_root (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (j : Nat) (i : Fin (cfg).folds.size) (k : Fin (cfg).folds[i.val]!) + (found : (SpongefishCurrentRoundPackets.openingDraws grinding)[j]? = some (some (.fold i k))) + (last : isLastFold i k = true) (more : i.val + 1 < (cfg).folds.size) : + ∃ (xs : Fin 2 → Concrete.E) (r : Digest32) (rest : List Byte), + (drawRuns E)[j]? = some ((WireKind.vector 2).codec.bytes xs ++ (WireKind.root.codec.bytes r ++ rest)) ∧ + col.roots[i.val + 1]? = some r ∧ j + 1 < (SpongefishCurrentRoundPackets.openingDraws grinding).length := by + obtain ⟨pre,post,split,notin,index⟩ := flatMap_index grinding _ (WHIRHistory.schedule_nodup cfg) j _ + (by rw [← openingDraws_eq]; exact found) + obtain ⟨bpre,bq,bpost,mid,st,fin,rfl,_,_,_,before,step,after⟩ := + walk_at H decode grinding lanes root0 E col calls walked _ pre post split + have count := fold_prefix_count i k last more pre post split notin + obtain ⟨_,vPre,_,_,⟨rts,rootsPre,rtsLen⟩,_⟩ := before + obtain ⟨_,_,_,_,_,_,_,_,rootsPush,_,_⟩ := step + have rootQ : rootFold (.fold i k : Coord p) = true := by simp [rootFold,last,more] + obtain ⟨b,xs,r,rfl,pushed⟩ := rootsPush rootQ + obtain ⟨_,_,_,_,⟨rts₂,rootsPost,_⟩,_⟩ := after + simp only at rootsPre rootsPost pushed + have midSize : mid.roots.size = i.val + 1 := by + rw [rootsPre,← count,← rtsLen] + simp [Collected.start,Nat.add_comm] + refine ⟨xs,r,leadBytes bpost.flatten,?_,?_,?_⟩ + · have pow : (powDraws grinding (.fold i k : Coord p)).length = 0 := rfl + rw [index,pow,Nat.add_zero,← vPre] + simpa [leadBytes] using drawRuns_at bpre.flatten + (.prover (.vector 2) ((WireKind.vector 2).codec.bytes xs) :: + .prover .root (WireKind.root.codec.bytes r) :: bpost.flatten) b + · rw [rootsPost,pushed,Array.getElem?_append_left (by simp [midSize])] + simp [← midSize] + · have place := split_position _ pre post split notin + have pf := CausalPositions.position_fold i k col.tape + have pq := CausalPositions.position_query i col.tape + have kq := k.isLt + have at' := WHIRHistory.schedule_get_position (.query i : Coord p) + rw [split,List.getElem?_append_right (by omega), + show position (.query i : Coord p) - pre.length = (position (.query i : Coord p) - pre.length - 1) + 1 + by omega,List.getElem?_cons_succ] at at' + have queryAfter := List.mem_of_getElem? at' + have queryDraw : some (.query i : Coord p) ∈ post.flatMap (drawList grinding) := by + refine List.mem_flatMap.mpr ⟨_,queryAfter,?_⟩ + have width : PCSBCSRounds.rawWidth (.query i : Coord p) ≠ 0 := by + simp [PCSBCSRounds.rawWidth,WHIRHistory.stackScalarCount,WHIRHistory.scalarCount] + simp [drawList,pcsDraws,width] + have positive := List.length_pos_of_mem queryDraw + have foldDraws : (drawList grinding (.fold i k : Coord p)).length = 1 := rfl + rw [openingDraws_eq,split,List.flatMap_append,List.flatMap_cons,List.length_append, + List.length_append,foldDraws] + rw [index] + simp only [powDraws,List.length_nil,Nat.add_zero] + omega + +/-- Level roots on the opening frames: for histories whose frame `boundary + k + 1` is the `k`-th draw run (as given by `opening_frames`), every root-carrying fold draw `j'` has a later history whose frame `boundary + j' + 1` decodes, through `SpongefishCurrentRootPolicy.levelRoot`, to the walk's level root `i'+1`. -/ +theorem level_roots_of_frames (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) (lanes : Nat) (root0 : Digest32) (E : List SourceEvent) + (col : Collected p) (calls : List.Forall₂ CallEvent (openingCalls grinding) E) + (walked : HashProgram.eval H (walk decode grinding lanes root0 E) = some col) + (boundary : Nat) (histories : List FramedHistory) + (length : histories.length = (SpongefishCurrentRoundPackets.openingDraws grinding).length) + (content : ∀ (j : Nat) (h : FramedHistory) (k : Nat) (bytes : List Byte), histories[j]? = some h → k < j → + (drawRuns E)[k]? = some bytes → ∃ previous, h.frames[boundary + k + 1]? = some (.absorb previous bytes)) + (i' : Fin (cfg).folds.size) (k : Fin (cfg).folds[i'.val]!) (j' : Nat) + (last : isLastFold i' k = true) (more : i'.val + 1 < (cfg).folds.size) + (found : (SpongefishCurrentRoundPackets.openingDraws grinding)[j']? = some (some (.fold i' k))) : + ∃ (root : Digest32) (h : FramedHistory) (previous : Nat) (bytes : List Byte), + col.roots[i'.val + 1]? = some root ∧ histories[j' + 1]? = some h ∧ + h.frames[boundary + j' + 1]? = some (.absorb previous bytes) ∧ + SpongefishCurrentRootPolicy.levelRoot bytes = some root := by + obtain ⟨xs,r,rest,run,rootAt,later⟩ := + level_root H decode grinding lanes root0 E col calls walked j' i' k found last more + obtain ⟨h,hAt⟩ : ∃ h, histories[j' + 1]? = some h := ⟨_,List.getElem?_eq_getElem (by omega)⟩ + obtain ⟨previous,frame⟩ := content (j' + 1) h j' _ hAt (by omega) run + refine ⟨r,h,previous,_,rootAt,hAt,frame,?_⟩ + rw [← List.append_assoc] + exact SpongefishCurrentRootPolicy.levelRoot_fold_reply xs r rest + +#print axioms opening_frames +#print axioms replies_exact_local +#print axioms replies_exact +#print axioms reply_positions +#print axioms reply_at +#print axioms query_reply +#print axioms tape_draw +#print axioms tape_zero +#print axioms seed_draw +#print axioms root_start +#print axioms level_root +#print axioms level_roots_of_frames + +end Whir.SpongefishCurrentHistoryReplies diff --git a/verification/whir/Whir/SpongefishCurrentIdealRows.lean b/verification/whir/Whir/SpongefishCurrentIdealRows.lean new file mode 100644 index 000000000..57d68c8aa --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentIdealRows.lean @@ -0,0 +1,984 @@ +import Whir.SpongefishCurrentGoodEvent +import Whir.SpongefishCurrentOpeningExperiment +import Whir.SpongefishCurrentOpeningPackets +import Whir.PCSBCSCapturedNativePhaseQuery +import Whir.PCSBCSRestorationLiteralPath +import Whir.PCSRoundByRoundPublicEndpoint + +/-! Ideal-world opened rows of the current #607 opening walk. On every table of a packet partition, the full source view's returned walk is the pure evaluation of the opening walk with the view's public seed, and every hashed opening input has its primitive plan among the view's observations. The opening of level `i` sits at reply position `position (.query i)`, reads the walk root `roots[i]` and the tape's query sample. Against the first-mention capture of that root (taken as a hypothesis), the quiet event binds the opened rows to the decoded frozen oracle; together with the native equations of the good event this is an accepted causal experiment, and extraction failure on the frozen Root0 image makes the literal final public state true. -/ +namespace Whir.SpongefishCurrentIdealRows +open Concrete Protocol CausalGame FiatShamirGame DuplexModeGame DuplexFraming SpongefishPCSRoundFrames +open SpongefishCurrentOpeningAcceptance SpongefishCurrentOpeningProgram PrunedMerkleProgram +open PCSBCSSourceRootReferences PCSBCSMerkleRootCache TypedOracleCompiler +set_option autoImplicit false + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-! ## Primitive answers of an ideal source view -/ + +/-- Every primitive observation of a source view, on an arbitrary partition table, is answered by the view's public seed. -/ +theorem source_seed {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : RawOracleCoupling.Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + {R : Type} (iv : Digest32) (program : Program R) (counted : Counts Q program) + (table : (key : part.Key) → part.Answer (D := Digest32) key) (purpose : Purpose) (n : Node) + (a : Digest32) + (member : (⟨.primitive purpose n,a⟩ : Observation) ∈ + (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program counted)).observations) : + PCSBCSPublicPrimitiveOpening.publicSeed + (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program counted)) n = a := by + unfold PCSBCSPublicPrimitiveOpening.publicSeed + rw [SpongefishCurrentOpeningPackets.eval_source] at member ⊢ + exact PCSBCSObservedPrimitiveExtension.extension_of_mem _ + (DuplexPublicSimulator.finalLog_functional (SpongefishCurrentOpeningPackets.roOf part table) iv + ⟨SpongefishCurrentOpeningPackets.seedOf part table,[]⟩ program Q (Nat.le_refl Q) counted (by + intro _ _ _ absent + cases absent)) + (PCSBCSObservedPrimitiveExtension.primitive_in_finalLog [] _ purpose n a member) + +/-- A source view is a run of its program. -/ +theorem source_runs {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : RawOracleCoupling.Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + {R : Type} (iv : Digest32) (program : Program R) (counted : Counts Q program) + (table : (key : part.Key) → part.Answer (D := Digest32) key) : + PublicMerkleProgram.Runs program + (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program counted)).observations + (Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv program counted)).result := by + rw [SpongefishCurrentOpeningPackets.eval_source] + exact PublicMerkleProgram.runIdeal_runs _ _ _ _ _ _ _ _ + +/-! ## Consistent hash-program runs -/ + +/-- A run of a lowered hash program whose primitive answers agree with `C` is the pure evaluation with `hash C`, and its trace contains the real primitive plan of every whole-hash call. -/ +theorem consistent_eval {R : Type} (C : PrimitiveOracle) (h : HashProgram R) + (trace : List Observation) (result : R) (run : PublicMerkleProgram.Runs h.lower trace result) + (answers : ∀ purpose n a, (⟨.primitive purpose n,a⟩ : Observation) ∈ trace → C n = a) : + HashProgram.eval (PublicMerkleLog.hash C) h = result ∧ + ∀ bytes ∈ HashProgram.calls (PublicMerkleLog.hash C) h, ∀ e ∈ PublicMerkleLog.plan C bytes, + (⟨.primitive .verification e.1,e.2⟩ : Observation) ∈ trace := by + have verification := ((HashProgram.lower_runs_iff h trace result).mp run).verification + obtain ⟨real,observed⟩ := run.real_result_trace C DuplexRefinement.zeroDigest (by + intro o member + obtain ⟨n,query⟩ := verification o member + obtain ⟨q,a⟩ := o + dsimp only at query ⊢ + subst query + exact (answers .verification n a member).symm) + refine ⟨(HashProgram.lower_real C DuplexRefinement.zeroDigest h).symm.trans real,?_⟩ + intro bytes call e planned + rw [← observed,HashProgram.real_observations] + exact List.mem_flatMap.mpr ⟨bytes,call,List.mem_map.mpr ⟨e,planned,rfl⟩⟩ + +/-- Any run of the full program returning a walk result, with primitive answers consistent with `C`, read the header root and evaluated the opening walk with `hash C` on the opening events; every whole-hash call's real plan is in the trace. -/ +theorem full_walk (C : PrimitiveOracle) (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (trace : List Observation) + (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (run : PublicMerkleProgram.Runs (fullProgram iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram) trace (some (.ok data),some col)) + (answers : ∀ purpose n a, (⟨.primitive purpose n,a⟩ : Observation) ∈ trace → C n = a) : + ∃ root, headerRoot (rootIndex before) data.events = some root ∧ + HashProgram.eval (PublicMerkleLog.hash C) (walk decode grinding (AnchoredSourceCaller.shape layout).lanes + root (openingEvents (openingOffset layout before payloadCalls messages) data)) = some col ∧ + ∀ bytes ∈ HashProgram.calls (PublicMerkleLog.hash C) (walk decode grinding + (AnchoredSourceCaller.shape layout).lanes root + (openingEvents (openingOffset layout before payloadCalls messages) data)), + ∀ e ∈ PublicMerkleLog.plan C bytes, (⟨.primitive .verification e.1,e.2⟩ : Observation) ∈ trace := by + obtain ⟨first,res,after,split,_,phase⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp run + subst split + rcases res with _ | (failure | replayed) + · cases phase + · cases phase + · cases hroot : headerRoot (rootIndex before) replayed.events with + | none => + simp only [openingPhase,hroot] at phase + cases phase + | some root => + simp only [openingPhase,hroot] at phase + obtain ⟨walkTrace,walked,rest,restEq,walkRun,done⟩ := (PublicMerkleProgram.Runs.bind_iff _ _).mp phase + cases done + have inside : ∀ o ∈ walkTrace, o ∈ first ++ after := by + intro o member + rw [restEq] + exact List.mem_append_right _ (List.mem_append_left _ member) + obtain ⟨evaluated,planned⟩ := consistent_eval C _ walkTrace _ walkRun + (fun purpose n a member => answers purpose n a (inside _ member)) + exact ⟨root,hroot,evaluated,fun bytes call e member => inside _ (planned bytes call e member)⟩ + +/-! ## The ideal full view -/ + +section Ideal +variable {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : RawOracleCoupling.Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + (iv : Digest32) (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (decode : Decoder) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (counted : Counts Q (fullProgram (p := p) iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram)) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + +/-- The ideal source view of the full program on a partition table. -/ +noncomputable def idealView : View (FullResult p) := + Sampling.eval table (SpongefishCurrentBCSKnowledge.source part iv + (fullProgram (p := p) iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram) counted) + +/-- Ideal walk semantics: the returned walk is the evaluation of the opening walk on the opening events with the view's public seed, and every whole-hash call of that walk has its real primitive plan among the view's observations. -/ +theorem ideal_walk (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (result : (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).result = (some (.ok data),some col)) : + ∃ root, headerRoot (rootIndex before) data.events = some root ∧ + HashProgram.eval (PublicMerkleLog.hash (PCSBCSPublicPrimitiveOpening.publicSeed + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table))) + (walk decode grinding (AnchoredSourceCaller.shape layout).lanes root + (openingEvents (openingOffset layout before payloadCalls messages) data)) = some col ∧ + ∀ bytes ∈ HashProgram.calls (PublicMerkleLog.hash (PCSBCSPublicPrimitiveOpening.publicSeed + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table))) + (walk decode grinding (AnchoredSourceCaller.shape layout).lanes root + (openingEvents (openingOffset layout before payloadCalls messages) data)), + ∀ e ∈ PublicMerkleLog.plan (PCSBCSPublicPrimitiveOpening.publicSeed + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table)) bytes, + (⟨.primitive .verification e.1,e.2⟩ : Observation) ∈ + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).observations := by + have run := source_runs part iv _ counted table + have seeded := source_seed part iv _ counted table + unfold idealView at result ⊢ + rw [result] at run + exact full_walk _ iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram _ + data col run seeded + +end Ideal + +/-! ## Opening walk invariants -/ + +section Walk +variable (H : MerkleTransport.Primitive) (decode : Decoder) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) (lanes : Nat) + +theorem array_prefix {α : Type} (a b : Array α) (n : Nat) (x : α) (h : a[n]? = some x) : + (a ++ b)[n]? = some x := by + have lt : n < a.size := (Array.getElem?_eq_some_iff.mp h).1 + rw [Array.getElem?_append_left lt] + exact h + +theorem powWalk_shape (evs evs' : List SourceEvent) (col col' : Collected p) (q : Coord p) + (ok : powWalk grinding evs col q = some (evs',col')) : ∃ pows, col' = {col with pows := pows} := by + cases q with + | query i => + simp only [powWalk] at ok + split at ok + · cases ok + exact ⟨col.pows,rfl⟩ + · obtain ⟨⟨bytes,rest⟩,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨⟨nonce,after⟩,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨_,rfl⟩ + | initial => cases ok; exact ⟨col.pows,rfl⟩ + | fold i j => cases ok; exact ⟨col.pows,rfl⟩ + | ood i j => cases ok; exact ⟨col.pows,rfl⟩ + | tail j => cases ok; exact ⟨col.pows,rfl⟩ + +theorem recordSample_fields (col : Collected p) (q : Coord p) (x : PCSBCSRounds.Raw q) : + (recordSample col q x).tape = CausalProbability.set q col.tape (StackWHIRReplay.projectSample q x) ∧ + (recordSample col q x).replies = col.replies ∧ (recordSample col q x).roots = col.roots ∧ + (recordSample col q x).openings = col.openings := by + cases q <;> exact ⟨rfl,rfl,rfl,rfl⟩ + +/-- A visible tail coordinate carries a prover reply. -/ +theorem tail_visible (j : Fin ((ParameterBounds.config p).logN - (ParameterBounds.config p).folds.toList.sum)) + (member : (CausalProbability.Coordinate.tail j : Coord p) ∈ + CausalProbability.visibleCoordinates (ParameterBounds.config p)) : + isVisibleTail j = true := by + unfold CausalProbability.visibleCoordinates at member + simp only [List.mem_append,List.mem_singleton,List.mem_flatMap,List.mem_ofFn] at member + rcases member with (impossible | ⟨i,_,level⟩) | ⟨k,same⟩ + · cases impossible + · unfold CausalProbability.levelCoordinates at level + split at level <;> simp at level + · injection same with same + subst same + have bound := k.isLt + simp only [isVisibleTail,decide_eq_true_eq] + omega + +theorem replyPure_spec (evs evs' : List SourceEvent) (col col' : Collected p) (q : Coord p) + (ok : replyPure evs col q = some (evs',col')) : + col'.tape = col.tape ∧ col'.seed = col.seed ∧ col'.openings = col.openings ∧ + (∃ extra, col'.roots = col.roots ++ extra) ∧ + ∃ extra : Array Reply, col'.replies = col.replies ++ extra ∧ + (q ∈ CausalProbability.visibleCoordinates (ParameterBounds.config p) → extra.size = 1) := by + cases q with + | initial => + simp only [replyPure] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨rfl,rfl,rfl,⟨#[],by simp⟩,⟨_,Array.push_eq_append,fun _ => rfl⟩⟩ + | fold i j => + simp only [replyPure] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + split at ok + · split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨rfl,rfl,rfl,⟨_,Array.push_eq_append⟩,⟨_,Array.push_eq_append,fun _ => rfl⟩⟩ + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨rfl,rfl,rfl,⟨#[],by simp⟩,⟨_,Array.push_eq_append,fun _ => rfl⟩⟩ + · cases ok + exact ⟨rfl,rfl,rfl,⟨#[],by simp⟩,⟨_,Array.push_eq_append,fun _ => rfl⟩⟩ + | ood i j => + simp only [replyPure] at ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨rfl,rfl,rfl,⟨#[],by simp⟩,⟨_,Array.push_eq_append,fun _ => rfl⟩⟩ + | query i => cases ok + | tail j => + simp only [replyPure] at ok + split at ok + · obtain ⟨_,_,ok⟩ := Option.bind_eq_some_iff.mp ok + cases ok + exact ⟨rfl,rfl,rfl,⟨#[],by simp⟩,⟨_,Array.push_eq_append,fun _ => rfl⟩⟩ + · rename_i hidden + cases ok + exact ⟨rfl,rfl,rfl,⟨#[],by simp⟩,⟨#[],by simp,fun member => absurd (tail_visible j member) hidden⟩⟩ + +theorem replyQuery_spec (evs evs' : List SourceEvent) (col col' : Collected p) + (i : Fin (ParameterBounds.config p).folds.size) + (ok : HashProgram.eval H (replyQuery decode lanes evs col i) = some (evs',col')) : + col'.tape = col.tape ∧ col'.seed = col.seed ∧ col'.roots = col.roots ∧ + ∃ (o : QueryOpening p) (m : Message E), col'.openings = col.openings ++ [o] ∧ + col'.replies = col.replies.push (.query o.opened.rows m) ∧ o.level = i ∧ + col.roots[i.val]? = some o.root ∧ + HashProgram.eval H (openProgram lanes i o.root o.proof + (CausalProbability.get (.query i) col.tape)) = some o.opened := by + cases hh : takeHintBytes evs with + | none => simp [replyQuery,hh,HashProgram.eval] at ok + | some hinted => + obtain ⟨hint,rest⟩ := hinted + cases hd : decode (WHIRPhysicalVerifier.queryIndices p i (CausalProbability.get (.query i) col.tape)) + (rowWords lanes i) hint with + | none => simp [replyQuery,hh,hd,HashProgram.eval] at ok + | some proof => + cases hr : col.roots[i.val]? with + | none => simp [replyQuery,hh,hd,hr,HashProgram.eval] at ok + | some root => + simp only [replyQuery,hh,hd,hr,HashProgram.eval_map] at ok + cases ho : HashProgram.eval H (openProgram lanes i root proof + (CausalProbability.get (.query i) col.tape)) with + | none => simp [ho] at ok + | some opened => + simp only [ho] at ok + obtain ⟨read,_,ok⟩ := Option.map_eq_some_iff.mp ok + cases ok + exact ⟨rfl,rfl,rfl,⟨i,root,hint,proof,opened⟩,read.1,rfl,rfl,rfl,rfl,ho⟩ + +/-- One walk step: the stepped coordinate is the only tape change, the seed invariant is kept, roots, openings and replies only grow, a visible coordinate pushes exactly one reply, and a query step pushes its authenticated rows together with one opening at the current root of its level. -/ +theorem stepWalk_spec (state final : List SourceEvent × Collected p) (q : Coord p) + (ok : HashProgram.eval H (stepWalk decode grinding lanes state q) = some final) : + (∀ r, r ≠ q → CausalProbability.get r final.2.tape = CausalProbability.get r state.2.tape) ∧ + (SpongefishCurrentOpeningExperiment.SeedTape state.2 → + SpongefishCurrentOpeningExperiment.SeedTape final.2) ∧ + (∃ extra, final.2.roots = state.2.roots ++ extra) ∧ + (∃ extra, final.2.openings = state.2.openings ++ extra) ∧ + (∃ extra : Array Reply, final.2.replies = state.2.replies ++ extra ∧ + (q ∈ CausalProbability.visibleCoordinates (ParameterBounds.config p) → extra.size = 1)) ∧ + (∀ i, q = .query i → ∃ (o : QueryOpening p) (m : Message E), + final.2.openings = state.2.openings ++ [o] ∧ + final.2.replies = state.2.replies.push (.query o.opened.rows m) ∧ o.level = i ∧ + state.2.roots[i.val]? = some o.root ∧ + HashProgram.eval H (openProgram lanes i o.root o.proof + (CausalProbability.get (.query i) final.2.tape)) = some o.opened) := by + obtain ⟨evs0,col0⟩ := state + obtain ⟨evsF,colF⟩ := final + cases hp : powWalk grinding evs0 col0 q with + | none => simp [stepWalk,hp,HashProgram.eval] at ok + | some powed => + obtain ⟨evs,col⟩ := powed + obtain ⟨pows,colEq⟩ := powWalk_shape grinding _ _ _ _ q hp + subst colEq + cases hd : drawWalk evs q with + | none => simp [stepWalk,hp,hd,HashProgram.eval] at ok + | some drawn => + obtain ⟨rest,x⟩ := drawn + simp only [stepWalk,hp,hd] at ok + obtain ⟨tapeEq,repliesEq,rootsEq,openingsEq⟩ := recordSample_fields {col0 with pows := pows} q x + have seeded := SpongefishCurrentOpeningExperiment.recordSample_seedTape {col0 with pows := pows} q x + by_cases isQuery : ∃ i, q = .query i + · obtain ⟨i,rfl⟩ := isQuery + obtain ⟨tape,seed,roots,o,m,openings,replies,level,rootAt,opened⟩ := + replyQuery_spec H decode lanes _ _ _ _ i ok + dsimp only + refine ⟨?_,?_,⟨#[],?_⟩,⟨[o],?_⟩,⟨#[.query o.opened.rows m],?_,fun _ => rfl⟩,?_⟩ + · intro r different + rw [tape,tapeEq] + exact CausalProbability.get_set_ne _ _ _ _ different + · intro kept s found + rw [tape] + exact seeded kept s (seed ▸ found) + · rw [roots,rootsEq] + simp + · rw [openings,openingsEq] + · rw [replies,repliesEq,Array.push_eq_append] + · intro i' same + cases same + refine ⟨o,m,?_,?_,level,?_,?_⟩ + · rw [openings,openingsEq] + · rw [replies,repliesEq] + · rw [← rootsEq] + exact rootAt + · rw [tape] + exact opened + · have pure : replyPure rest (recordSample {col0 with pows := pows} q x) q = some (evsF,colF) := by + cases q with + | query i => exact (isQuery ⟨i,rfl⟩).elim + | initial => exact ok + | fold i j => exact ok + | ood i j => exact ok + | tail j => exact ok + obtain ⟨tape,seed,openings,⟨extraRoots,roots⟩,⟨extra,replies,size⟩⟩ := + replyPure_spec _ _ _ _ q pure + dsimp only + refine ⟨?_,?_,⟨extraRoots,?_⟩,⟨[],?_⟩,⟨extra,?_,size⟩,fun i same => (isQuery ⟨i,same⟩).elim⟩ + · intro r different + rw [tape,tapeEq] + exact CausalProbability.get_set_ne _ _ _ _ different + · intro kept s found + rw [tape] + exact seeded kept s (seed ▸ found) + · rw [roots,rootsEq] + · rw [openings,openingsEq] + simp + · rw [replies,repliesEq] + +theorem walkFrom_append (xs ys : List (Coord p)) (state : List SourceEvent × Collected p) : + HashProgram.eval H (walkFrom decode grinding lanes (xs ++ ys) state) = + (HashProgram.eval H (walkFrom decode grinding lanes xs state)).bind + (fun mid => HashProgram.eval H (walkFrom decode grinding lanes ys mid)) := by + induction xs generalizing state with + | nil => rfl + | cons x xs ih => + simp only [List.cons_append,walkFrom,HashProgram.eval_bind] + cases HashProgram.eval H (stepWalk decode grinding lanes state x) with + | none => rfl + | some mid => exact ih mid + +theorem walkFrom_spec : ∀ (qs : List (Coord p)) (state final : List SourceEvent × Collected p), + HashProgram.eval H (walkFrom decode grinding lanes qs state) = some final → + (∀ r, r ∉ qs → CausalProbability.get r final.2.tape = CausalProbability.get r state.2.tape) ∧ + (SpongefishCurrentOpeningExperiment.SeedTape state.2 → + SpongefishCurrentOpeningExperiment.SeedTape final.2) ∧ + (∃ extra, final.2.roots = state.2.roots ++ extra) ∧ + (∃ extra, final.2.openings = state.2.openings ++ extra) ∧ + (∃ extra : Array Reply, final.2.replies = state.2.replies ++ extra ∧ + ((∀ q ∈ qs, q ∈ CausalProbability.visibleCoordinates (ParameterBounds.config p)) → + extra.size = qs.length)) + | [], state, final, ok => by + simp only [walkFrom,HashProgram.eval,Option.some.injEq] at ok + subst ok + exact ⟨fun _ _ => rfl,id,⟨#[],by simp⟩,⟨[],by simp⟩,⟨#[],by simp,fun _ => rfl⟩⟩ + | q :: qs, state, final, ok => by + simp only [walkFrom,HashProgram.eval_bind] at ok + cases hs : HashProgram.eval H (stepWalk decode grinding lanes state q) with + | none => simp [hs,HashProgram.eval] at ok + | some mid => + simp only [hs] at ok + obtain ⟨tape1,seed1,⟨r1,roots1⟩,⟨o1,openings1⟩,⟨e1,replies1,size1⟩,_⟩ := + stepWalk_spec H decode grinding lanes state mid q hs + obtain ⟨tape2,seed2,⟨r2,roots2⟩,⟨o2,openings2⟩,⟨e2,replies2,size2⟩⟩ := walkFrom_spec qs mid final ok + refine ⟨?_,fun kept => seed2 (seed1 kept),⟨r1 ++ r2,?_⟩,⟨o1 ++ o2,?_⟩,⟨e1 ++ e2,?_,?_⟩⟩ + · intro r absent + rw [tape2 r (fun h => absent (List.mem_cons_of_mem _ h)), + tape1 r (fun h => absent (h ▸ List.mem_cons_self))] + · rw [roots2,roots1,Array.append_assoc] + · rw [openings2,openings1,List.append_assoc] + · rw [replies2,replies1,Array.append_assoc] + · intro visible + rw [Array.size_append,size1 (visible q List.mem_cons_self), + size2 (fun q' h => visible q' (List.mem_cons_of_mem _ h)),List.length_cons] + omega + +/-- Reply position invariant of the opening walk: the query reply of level `i` is the reply at index `position (.query i)`; it carries the rows opened at the walk root of level `i` on the tape's query sample, and the corresponding opening is returned. The walk also keeps the commitment root as `roots[0]` and the seed invariant. -/ +theorem walk_spec (root : Digest32) (evs : List SourceEvent) (col : Collected p) + (ok : HashProgram.eval H (walk decode grinding lanes root evs) = some col) : + col.roots[0]? = some root ∧ SpongefishCurrentOpeningExperiment.SeedTape col ∧ + ∀ i : Fin (ParameterBounds.config p).folds.size, ∃ (o : QueryOpening p) (m : Message E), + o ∈ col.openings ∧ o.level = i ∧ col.roots[i.val]? = some o.root ∧ + col.replies[CausalProbability.position (CausalProbability.Coordinate.query i)]? = + some (.query o.opened.rows m) ∧ + HashProgram.eval H (openProgram lanes i o.root o.proof + (CausalProbability.get (.query i) col.tape)) = some o.opened := by + unfold walk at ok + rw [HashProgram.eval_map] at ok + obtain ⟨final,walked,same⟩ := Option.map_eq_some_iff.mp ok + subst same + obtain ⟨_,seedAll,⟨_,rootsAll⟩,_,_⟩ := walkFrom_spec H decode grinding lanes _ _ final walked + refine ⟨?_,seedAll (fun s found => by cases found),?_⟩ + · rw [rootsAll] + exact array_prefix #[root] _ 0 root rfl + intro i + let schedule := WHIRHistory.schedule (ParameterBounds.config p) + let k := CausalProbability.position (CausalProbability.Coordinate.query i : Coord p) + have visibleQ : (CausalProbability.Coordinate.query i : Coord p) ∈ + CausalProbability.visibleCoordinates (ParameterBounds.config p) := + (CausalPrefix.visible_or_last _).resolve_right (by + rintro ⟨j,same,_⟩ + cases same) + have kLt : k < (CausalProbability.visibleCoordinates (ParameterBounds.config p)).length := + List.idxOf_lt_length_of_mem visibleQ + have hk : k < schedule.length := by + change k < (WHIRHistory.schedule (ParameterBounds.config p)).length + unfold WHIRHistory.schedule + rw [List.length_append] + omega + have atK : schedule[k] = CausalProbability.Coordinate.query i := by + have found := WHIRHistory.schedule_get_position (CausalProbability.Coordinate.query i : Coord p) + rw [List.getElem?_eq_getElem hk] at found + exact Option.some.inj found + have split : schedule = schedule.take k ++ CausalProbability.Coordinate.query i :: schedule.drop (k+1) := by + rw [← atK,← List.drop_eq_getElem_cons hk,List.take_append_drop] + have prefixVisible : ∀ q ∈ schedule.take k, + q ∈ CausalProbability.visibleCoordinates (ParameterBounds.config p) := by + intro q member + change q ∈ (WHIRHistory.schedule (ParameterBounds.config p)).take k at member + unfold WHIRHistory.schedule at member + rw [List.take_append_of_le_length (Nat.le_of_lt kLt)] at member + exact List.mem_of_mem_take member + have nodup := WHIRHistory.schedule_nodup (ParameterBounds.config p) + change schedule.Nodup at nodup + rw [split] at nodup + have fresh : CausalProbability.Coordinate.query i ∉ schedule.drop (k+1) := + (List.nodup_cons.mp (List.Nodup.of_append_right nodup)).1 + change HashProgram.eval H (walkFrom decode grinding lanes schedule _) = some final at walked + rw [split,walkFrom_append] at walked + obtain ⟨mid1,first,second⟩ := Option.bind_eq_some_iff.mp walked + simp only [walkFrom,HashProgram.eval_bind] at second + cases hs : HashProgram.eval H (stepWalk decode grinding lanes mid1 (CausalProbability.Coordinate.query i)) with + | none => simp [hs,HashProgram.eval] at second + | some mid2 => + simp only [hs] at second + obtain ⟨_,_,_,_,⟨e1,replies1,size1⟩⟩ := walkFrom_spec H decode grinding lanes _ _ mid1 first + obtain ⟨_,_,⟨r2,roots2⟩,_,_,query⟩ := stepWalk_spec H decode grinding lanes mid1 mid2 _ hs + obtain ⟨o,m,openings2,replies2,level,rootAt,opened⟩ := query i rfl + obtain ⟨tape3,_,⟨r3,roots3⟩,⟨o3,openings3⟩,⟨e3,replies3,_⟩⟩ := + walkFrom_spec H decode grinding lanes _ mid2 final second + have size : mid1.2.replies.size = k := by + rw [replies1,Array.size_append,size1 prefixVisible,List.length_take] + simp only [Collected.start,List.size_toArray,List.length_nil,Nat.zero_add] + omega + refine ⟨o,m,?_,level,?_,?_,?_⟩ + · rw [openings3,openings2] + simp + · rw [roots3,roots2] + exact array_prefix _ _ _ _ (array_prefix _ _ _ _ rootAt) + · rw [replies3,replies2] + apply array_prefix + rw [show CausalProbability.position (CausalProbability.Coordinate.query i : Coord p) = + mid1.2.replies.size from size.symm] + exact Array.getElem?_push_size + · rw [tape3 _ fresh] + exact opened + +end Walk + +/-! ## Captured roots, their logs and their oracles -/ + +/-- Reference of the walk root of level `i`: Root0 at level 0, the announced level root otherwise. -/ +def rootReference (p : ParameterBounds.Profile) (shape : SpongefishSessionAdapter.Shape) (i : Nat) + (root : Digest32) : Reference := + if i = 0 then SpongefishCurrentPhysicalRootCapture.reference shape root + else ⟨root,SpongefishCurrentRootPolicy.levelShape p i⟩ + +theorem openingReference_eq (shape : SpongefishSessionAdapter.Shape) (o : QueryOpening p) : + SpongefishCurrentGoodEvent.openingReference shape o = rootReference p shape o.level.val o.root := rfl + +/-- First-mention captures of the walk roots, recorded by level in `frozens`. -/ +def Captured (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (shape : SpongefishSessionAdapter.Shape) (headerFrames boundary B : Nat) (iv : Digest32) + (view : View (FullResult p)) (col : Collected p) (frozens : Nat → Frozen) : Prop := + ∀ i root, i < (ParameterBounds.config p).folds.size → col.roots[i]? = some root → + SpongefishCurrentRootPolicy.publicCapture (B := B) p grinding shape headerFrames boundary iv + (rootReference p shape i root) view = some (frozens i) + +/-- The base oracle: the frozen Root0 image. -/ +def rootOracle (frozen0 : Frozen) : BaseOracle := frozen0.raw + +/-- The ghost next oracle of level `i`: the decoded frozen capture of the level root. -/ +def nextOracle (frozens : Nat → Frozen) (i : Nat) : Oracle := + (PCSBCSFrozenOracleRows.frozenOracle i (frozens i)).getD #[] + +theorem ordinaryLog_origin {B : Nat} (events : List (SpongefishCurrentPhysicalRootCapture.Event B)) + (n : Node) (a : Digest32) (member : (n,a) ∈ SpongefishCurrentPhysicalRootCapture.ordinaryLog events) : + (⟨.inl n,a⟩ : SpongefishCurrentPhysicalRootCapture.Event B) ∈ events := by + have general : ∀ (events : List (SpongefishCurrentPhysicalRootCapture.Event B)) + (prior : DuplexPublicSimulator.PublicLog), + (n,a) ∈ events.foldl SpongefishCurrentPhysicalRootCapture.ordinaryStep prior → + (n,a) ∈ prior ∨ (⟨.inl n,a⟩ : SpongefishCurrentPhysicalRootCapture.Event B) ∈ events := by + intro events + induction events with + | nil => exact fun _ member => .inl member + | cons event rest ih => + intro prior member + rcases ih _ member with old | later + · obtain ⟨key,answer⟩ := event + cases key with + | inl input => + simp only [SpongefishCurrentPhysicalRootCapture.ordinaryStep,List.mem_cons] at old + rcases old with head | older + · obtain ⟨rfl,rfl⟩ := Prod.mk.inj head + exact .inr List.mem_cons_self + · exact .inl older + | inr key => exact .inl old + · exact .inr (List.mem_cons_of_mem _ later) + exact (general events [] member).resolve_left (by simp) + +theorem mixedTrace_origin (B : Nat) (iv : Digest32) : + ∀ (log : DuplexPublicSimulator.PublicLog) (obs : List Observation) (n : Node) (a : Digest32), + (⟨.inl n,a⟩ : SpongefishCurrentPhysicalRootCapture.Event B) ∈ + PCSBCSNativePublicCapture.mixedTrace B iv log obs → + ∃ purpose, (⟨.primitive purpose n,a⟩ : Observation) ∈ obs + | _, [], _, _, member => by cases member + | log, o :: rest, n, a, member => by + simp only [PCSBCSNativePublicCapture.mixedTrace,List.mem_append] at member + rcases member with here | later + · obtain ⟨query,answer⟩ := o + cases query with + | primitive purpose input => + simp only [PCSBCSNativePublicCapture.observationDraw] at here + split at here + · cases here + · split at here + · simp at here + · simp only [List.mem_singleton,Sigma.mk.injEq,Sum.inl.injEq,heq_eq_eq] at here + obtain ⟨rfl,rfl⟩ := here + exact ⟨purpose,List.mem_cons_self⟩ + | construction c valid => + simp only [PCSBCSNativePublicCapture.observationDraw] at here + split at here <;> simp at here + · obtain ⟨purpose,found⟩ := mixedTrace_origin B iv _ rest n a later + exact ⟨purpose,List.mem_cons_of_mem _ found⟩ + +/-- A public first-mention capture is the literal freeze of its ordinary prefix log, and every record of that log is a primitive observation of the view. -/ +theorem publicCapture_spec {B : Nat} {R : Type} (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (shape : SpongefishSessionAdapter.Shape) (headerFrames boundary : Nat) (iv : Digest32) (ref : Reference) + (view : View R) (frozen : Frozen) + (found : SpongefishCurrentRootPolicy.publicCapture (B := B) p grinding shape headerFrames boundary iv ref view = + some frozen) : + frozen = freeze frozen.queryPrefix ref.root ref.shape ∧ + ∀ n a, (n,a) ∈ frozen.queryPrefix → ∃ purpose, (⟨.primitive purpose n,a⟩ : Observation) ∈ view.observations := by + unfold SpongefishCurrentRootPolicy.publicCapture SpongefishCurrentRootPolicy.capture + SpongefishCurrentRootPolicy.firstPrefix at found + obtain ⟨before,first,same⟩ := Option.map_eq_some_iff.mp found + subst same + refine ⟨rfl,?_⟩ + intro n a member + exact mixedTrace_origin B iv [] view.observations n a + (PCSBCSNativePublicCapture.firstPrefix_subset _ _ _ before first _ (ordinaryLog_origin before n a member)) + +/-- Geometry of the root references: Root0 has the level-0 `openQuery` geometry with the shape's lanes, level roots the full later geometry. -/ +theorem rootReference_geometry (shape : SpongefishSessionAdapter.Shape) + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p shape) (i : Nat) (root : Digest32) : + (rootReference p shape i root).root = root ∧ + (rootReference p shape i root).shape = + ⟨(ParameterBounds.length (ParameterBounds.config p) i).log2,WHIRPhysicalVerifier.leafWords p i, + if i = 0 then shape.lanes else WHIRPhysicalVerifier.leafWords p i⟩ := by + unfold rootReference + by_cases zero : i = 0 + · subst zero + simp only [↓reduceIte] + obtain ⟨height,leaf,occupied⟩ := SpongefishCurrentRootPolicy.root0_geometry p shape supported + refine ⟨rfl,?_⟩ + change SpongefishCurrentPhysicalRootCapture.physicalShape shape = _ + rw [← height,Nat.log2_two_pow,← leaf,← occupied] + · simp [zero,SpongefishCurrentRootPolicy.levelShape] + +theorem lanes_fit (shape : SpongefishSessionAdapter.Shape) + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p shape) : + shape.lanes ≤ 2^(ParameterBounds.config p).folds[0]! := by + have fits := (SpongefishCurrentPhysicalRootCapture.occupied_guard shape supported.valid).2.1 + obtain ⟨_,leaf,occupied⟩ := SpongefishCurrentPhysicalRootCapture.physical_shape shape + rw [leaf,occupied,supported.batch] at fits + exact fits + +/-- Row binding at one captured root: with an authentic frozen log and a quiet opening, the rows opened by the walk's hash program are the decoded frozen oracle at the query indices. -/ +theorem captured_rows (C : PrimitiveOracle) (i : Fin (ParameterBounds.config p).folds.size) (lanes : Nat) + (fits : lanes ≤ 2^(ParameterBounds.config p).folds[0]!) (ref : Reference) (frozen : Frozen) + (literal : frozen = freeze frozen.queryPrefix ref.root ref.shape) + (geometry : ref.shape = ⟨(ParameterBounds.length (ParameterBounds.config p) i.val).log2, + WHIRPhysicalVerifier.leafWords p i.val, + if i.val = 0 then lanes else WHIRPhysicalVerifier.leafWords p i.val⟩) + (auth : PublicMerkleLog.AuthenticLog C frozen.queryPrefix) + (root : Digest32) (rootEq : ref.root = root) (proof : MerkleTransport.PrunedMerklePaths) + (x : CausalProbability.Sample (.query i)) (opened : WHIRPhysicalVerifier.Opened) + (evaluated : HashProgram.eval (PublicMerkleLog.hash C) (openProgram lanes i root proof x) = some opened) + (quiet : ¬ PublicMerkleBinding.OpenPrimitiveBad C frozen.queryPrefix root opened.paths) : + ∃ oracle, PCSBCSFrozenOracleRows.frozenOracle i.val frozen = some oracle ∧ + opened.rows = WHIRPhysicalVerifier.atQueries oracle (WHIRPhysicalVerifier.queryIndices p i x) := by + have accepted : (runReal C DuplexRefinement.zeroDigest + (WHIRPhysicalVerifier.openQuery p i lanes proof root x)).view.result = some opened := by + rw [← openProgram_lower,HashProgram.lower_real] + exact evaluated + rcases PCSBCSCapturedNativePhaseQuery.openQuery_selectPhase C DuplexRefinement.zeroDigest frozen.queryPrefix + auth p i lanes fits proof root x opened accepted with ⟨selected,selection,rows,_,_⟩ | bad + · rw [← rootEq,← geometry,← literal] at selection + obtain ⟨_,oracle,decoded,size,each⟩ := PCSBCSSourceFrozenAccessor.selectPhase_order _ _ _ _ selection + refine ⟨oracle,decoded,?_⟩ + rw [← rows] + apply Array.ext + · simp [WHIRPhysicalVerifier.atQueries,size] + · intro j hj hk + have entry := each ⟨j,by simpa [size] using hj⟩ + simp only [getElem!_pos selected.rows j hj] at entry + simp [WHIRPhysicalVerifier.atQueries,entry] + · exact (quiet bad).elim + +theorem extensionRow_size (w : Array K) (r : Array E) (h : PCSBCSFrozenOracleRows.extensionRow w = some r) : + r.size = w.size / 3 := by + unfold PCSBCSFrozenOracleRows.extensionRow at h + split at h + · cases h + simp + · cases h + +/-- A frozen level capture decodes to a rectangular later oracle. -/ +theorem next_valid (log : DuplexPublicSimulator.PublicLog) (root : Digest32) (j : Nat) (nonzero : j ≠ 0) : + oracleValid ((PCSBCSFrozenOracleRows.frozenOracle j + (freeze log root (SpongefishCurrentRootPolicy.levelShape p j))).getD #[]) + (ParameterBounds.length (ParameterBounds.config p) j) (2^(ParameterBounds.config p).folds[j]!) = true := by + have words : (SpongefishCurrentRootPolicy.levelShape p j).occupied = 3 * 2^(ParameterBounds.config p).folds[j]! := by + simp [SpongefishCurrentRootPolicy.levelShape,WHIRPhysicalVerifier.leafWords,nonzero] + have fits : (SpongefishCurrentRootPolicy.levelShape p j).occupied ≤ + (SpongefishCurrentRootPolicy.levelShape p j).leafWords := le_refl _ + obtain ⟨oracle,decoded,size⟩ := PCSBCSSourceFrozenAccessorStructural.frozenOracle_freeze log root _ fits j + (Or.inr (by rw [words]; omega)) + obtain ⟨cells,rawSize,rows⟩ := PCSBCSSourceFrozenAccessorStructural.freeze_shape_exact log root _ fits + obtain ⟨_,codec⟩ := PCSBCSCapturedNativeReplyBridge.frozenOracle_row j _ oracle decoded + rw [decoded,Option.getD_some] + simp only [oracleValid,Bool.and_eq_true,beq_iff_eq,Array.all_eq_true] + constructor + · rw [size,cells,(SpongefishCurrentRootPolicy.levelShape_geometry p j).1] + · intro k hk + have rawK : k < (freeze log root (SpongefishCurrentRootPolicy.levelShape p j)).raw.size := by + rw [rawSize,← size] + exact hk + have row := codec ⟨k,rawK⟩ + simp only [PCSBCSCapturedNativeReplyBridge.rowCodec,nonzero,↓reduceIte] at row + have width := rows _ (Array.getElem_mem_toList rawK) + have rowSize := extensionRow_size _ _ row + simp only [Fin.getElem_fin] at rowSize + rw [width,words,getElem!_pos oracle k hk] at rowSize + rw [rowSize] + simp + +/-- The frozen Root0 image is a rectangular base oracle of the initial geometry. -/ +theorem root_valid (shape : SpongefishSessionAdapter.Shape) + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p shape) + (log : DuplexPublicSimulator.PublicLog) (root : Digest32) : + oracleValid (liftRoot (freeze log root (SpongefishCurrentPhysicalRootCapture.physicalShape shape)).raw) + (2^((ParameterBounds.config p).logN-(ParameterBounds.config p).folds[0]!+ + (ParameterBounds.config p).rates[0]!)) shape.lanes = true := by + have fits := (SpongefishCurrentPhysicalRootCapture.occupied_guard shape supported.valid).2.1 + obtain ⟨cells,rawSize,rows⟩ := PCSBCSSourceFrozenAccessorStructural.freeze_shape_exact log root _ fits + obtain ⟨height,_,occupied⟩ := SpongefishCurrentPhysicalRootCapture.physical_shape shape + simp only [oracleValid,Bool.and_eq_true,beq_iff_eq,Array.all_eq_true,liftRoot] + constructor + · rw [Array.size_map,rawSize,cells,height,supported.dimension,supported.batch,supported.rate] + · intro k hk + rw [Array.size_map] at hk + simp only [Array.getElem_map,Array.size_map] + rw [rows _ (Array.getElem_mem_toList hk),occupied] + +/-! ## Literal public trace of an indexed strategy -/ + +/-- The public snapshot only reads strictly prior visible replies, so the replayed replies of an indexed strategy give the same snapshot as the indexed reply array. -/ +theorem snapshot_indexed (input : Public) (answers : Array Reply) (ring : RingPCSGame.Prefix) + (t : Tape input.config) (q : CausalProbability.Coordinate input.config) : + PCSRoundByRoundTranscriptState.snapshot ring t + (PCSRoundByRoundTranscriptState.replies input (CausalStrategy.indexedStrategy answers) t) q = + PCSRoundByRoundTranscriptState.snapshot ring t answers q := by + unfold PCSRoundByRoundTranscriptState.snapshot PCSRoundByRoundTranscriptState.priorAnswers + congr 2 + funext n + have bound : n.val < (visibleBatches input.config t.1 (challenges input.config t)).length := by + rw [← CausalProbability.visibleCoordinates_map,List.length_map] + exact Nat.lt_of_lt_of_le n.isLt List.idxOf_le_length + unfold PCSRoundByRoundTranscriptState.replies + rw [List.getElem!_toArray,CausalStrategy.indexed_response answers input [] _ n.val bound] + simp + +/-- The current original reconstruction binds the record to the caller layout's shape and the original's lanes, anchor point and value to the record. -/ +theorem candidate_binding {Q : Nat} (layout : WHIRCallerClaims.CallerLayout) (q : Coordinate) + (r : SpongefishSessionAdapter.Record) (instanceBytes : List Byte) (observations : List Observation) + (input : PCSBCSCallerBinding.CallerInput p) + (original : SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q r instanceBytes observations = + some input) : + r.shape = AnchoredSourceCaller.shape layout ∧ input.lanes = r.shape.lanes ∧ + input.anchorPoint = r.point.toArray ∧ input.anchorValue = r.value := by + unfold SpongefishCurrentSourceCallerOriginal.candidate at original + obtain ⟨result,_,finished⟩ := Option.bind_eq_some_iff.mp original + exact SpongefishCurrentOpeningExperiment.finish_binding layout q r _ input finished + +/-! ## Ideal rows, oracle shapes and the terminal state -/ + +section IdealRows +variable {Q : Nat} {Packet : Type} {Block : Packet → Type} + (part : RawOracleCoupling.Partition (PublicCompressionCouplingMixed.Key Q) Packet Block) + (iv : Digest32) (tag instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (before payloadCalls messages : List Call) (decode : Decoder) + (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (counted : Counts Q (fullProgram (p := p) iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram)) + (table : (key : part.Key) → part.Answer (D := Digest32) key) + (headerFrames boundary : Nat) + +/-- Row binding of the ideal walk: on every partition table, if every walk root has a first-mention capture and every query opening is quiet against its capture, the reply at position `position (.query i)` carries the rows of the decoded frozen oracle of level `i` (the frozen Root0 image at level 0) at the native query indices of the tape. -/ +theorem ideal_rows (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (result : (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).result = (some (.ok data),some col)) + (quiet : SpongefishCurrentGoodEvent.Quiet grinding (AnchoredSourceCaller.shape layout) headerFrames boundary + Q iv (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table)) + (frozens : Nat → Frozen) + (found : Captured grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q iv + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table) col frozens) : + SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies (rootOracle (frozens 0)) + (nextOracle frozens) := by + obtain ⟨root0,_,evaluated,_⟩ := ideal_walk part iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram counted table data col result + obtain ⟨_,_,each⟩ := walk_spec _ decode grinding _ root0 _ col evaluated + intro i + obtain ⟨o,m,member,level,rootAt,replyAt,opened⟩ := each i + have capture := found i.val o.root i.isLt rootAt + obtain ⟨literal,origin⟩ := publicCapture_spec grinding _ headerFrames boundary iv _ _ _ capture + obtain ⟨rootEq,geometry⟩ := rootReference_geometry _ supported i.val o.root + have auth : PublicMerkleLog.AuthenticLog (PCSBCSPublicPrimitiveOpening.publicSeed + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table)) (frozens i.val).queryPrefix := by + intro n a recorded + obtain ⟨purpose,observed⟩ := origin n a recorded + exact source_seed part iv _ counted table purpose n a observed + have clean := quiet col (by rw [result]) o member (frozens i.val) (by + rw [openingReference_eq,level] + exact capture) + obtain ⟨oracle,decoded,rows⟩ := captured_rows _ i _ (lanes_fit _ supported) _ (frozens i.val) literal + geometry auth o.root rootEq o.proof _ o.opened opened clean + have reply : col.replies[CausalProbability.position (CausalProbability.Coordinate.query i)]! = + .query o.opened.rows m := by + simp only [getElem!_def,replyAt] + rw [reply] + change o.opened.rows = _ + rw [rows] + congr 1 + unfold SpongefishCurrentOpeningExperiment.levelOracle + by_cases zero : i.val = 0 + · simp only [zero,↓reduceIte] + rw [zero] at decoded + simp only [PCSBCSFrozenOracleRows.frozenOracle,↓reduceIte,Option.some.injEq] at decoded + rw [← decoded] + rfl + · simp only [zero,↓reduceIte] + unfold nextOracle + rw [decoded] + rfl + +/-- The ghost next oracles decoded from the level captures have their public rectangular shapes. -/ +theorem ideal_nextShapes (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (result : (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).result = (some (.ok data),some col)) + (frozens : Nat → Frozen) + (found : Captured grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q iv + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table) col frozens) : + SpongefishCurrentOpeningExperiment.NextShapes (ParameterBounds.config p) (nextOracle frozens) := by + obtain ⟨root0,_,evaluated,_⟩ := ideal_walk part iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram counted table data col result + obtain ⟨_,_,each⟩ := walk_spec _ decode grinding _ root0 _ col evaluated + intro j positive bound + obtain ⟨o,_,_,_,rootAt,_,_⟩ := each ⟨j,bound⟩ + obtain ⟨literal,_⟩ := publicCapture_spec grinding _ headerFrames boundary iv _ _ _ (found j o.root bound rootAt) + have nonzero : j ≠ 0 := by omega + unfold nextOracle + rw [literal] + simp only [rootReference,nonzero,↓reduceIte] + exact next_valid _ _ j nonzero + +/-- The frozen Root0 image has the public initial shape. -/ +theorem ideal_rootShape (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (result : (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).result = (some (.ok data),some col)) + (frozens : Nat → Frozen) + (found : Captured grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q iv + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table) col frozens) : + oracleValid (liftRoot (rootOracle (frozens 0))) + (2^((ParameterBounds.config p).logN-(ParameterBounds.config p).folds[0]!+ + (ParameterBounds.config p).rates[0]!)) (AnchoredSourceCaller.shape layout).lanes = true := by + obtain ⟨root0,_,evaluated,_⟩ := ideal_walk part iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram counted table data col result + obtain ⟨rootAt,_,_⟩ := walk_spec _ decode grinding _ root0 _ col evaluated + obtain ⟨literal,_⟩ := publicCapture_spec grinding _ headerFrames boundary iv _ _ _ (found 0 root0 (ParameterBounds.production_config_valid p).2.1 rootAt) + unfold rootOracle + rw [literal] + simp only [rootReference,↓reduceIte,SpongefishCurrentPhysicalRootCapture.reference] + exact root_valid _ supported _ _ + +/-- Terminal state of the ideal good event: the walk's native equations on the reconstructed original, row binding against the first-mention captures and extraction failure on the frozen Root0 image make the literal final public state true, for the frozen Root0 image as base oracle, the tape and the native replies with restored ghost next oracles. -/ +theorem ideal_terminal (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (result : (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).result = (some (.ok data),some col)) + (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (original : SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout + (SpongefishCurrentGoodEvent.postBinding boundary data) r instanceBytes + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).observations = some input) + (verdict : SpongefishCurrentGoodEvent.Verdict r input col) + (fails : SpongefishCurrentGoodEvent.ExtractionFails grinding (AnchoredSourceCaller.shape layout) + headerFrames boundary Q iv input (idealView part iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram counted table)) + (quiet : SpongefishCurrentGoodEvent.Quiet grinding (AnchoredSourceCaller.shape layout) headerFrames boundary + Q iv (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table)) + (frozens : Nat → Frozen) + (found : Captured grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q iv + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table) col frozens) + (seed : RingPCSGame.Prefix × E) (seeded : col.seed = some seed) : + PCSBCSRestorationHazard.literalState p input (rootOracle (frozens 0)) seed.1 col.tape + (SpongefishCurrentOpeningExperiment.restoredReplies col (nextOracle frozens)) + (PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config p)) = true := by + obtain ⟨shapeEq,lanes,anchorPoint,anchorValue⟩ := candidate_binding layout _ r instanceBytes _ input original + obtain ⟨seed',proof,seeded',parsed,equations⟩ := verdict + rw [seeded] at seeded' + cases seeded' + obtain ⟨root0,_,evaluated,_⟩ := ideal_walk part iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram counted table data col result + obtain ⟨rootAt,seedTape,_⟩ := walk_spec _ decode grinding _ root0 _ col evaluated + have rows := ideal_rows part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table headerFrames boundary supported data col result quiet frozens found + have nextShapes := ideal_nextShapes part iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram counted table headerFrames boundary data col result frozens found + have rootShape := ideal_rootShape part iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram counted table headerFrames boundary supported data col result frozens found + rw [← shapeEq] at rootShape + have accepted := SpongefishCurrentOpeningExperiment.experiment_accepts r input col seed proof + (seedTape seed seeded) parsed equations lanes anchorPoint anchorValue + (by rw [shapeEq]; exact supported.dimension) (by rw [shapeEq]; exact supported.batch) + (rootOracle (frozens 0)) (nextOracle frozens) rootShape nextShapes rows + have failure : ¬ ∃ w, PCSRoundByRoundKnowledge.extract p input.lanes input.family input.points + input.anchorPoint input.anchorValue (rootOracle (frozens 0)) = some w ∧ + PCSRewindSource.ExplainsOriginal (ParameterBounds.config p) input.lanes (rootOracle (frozens 0)) + input.family input.points input.anchorPoint input.anchorValue w := by + rintro ⟨w,extracted,explains⟩ + apply fails + refine ⟨root0,frozens 0,w,?_,?_,extracted,explains⟩ + · unfold SpongefishCurrentGoodEvent.publicRoot0 + rw [result] + exact rootAt + · have capture := found 0 root0 (ParameterBounds.production_config_valid p).2.1 rootAt + simp only [rootReference,↓reduceIte] at capture + exact capture + have final := PCSRoundByRoundTranscriptState.literal_accepted_extraction_failure_final p input.lanes + input.family input.points input.anchorPoint input.anchorValue input.prepared (rootOracle (frozens 0)) + (fun _ => CausalStrategy.indexedStrategy + (SpongefishCurrentOpeningExperiment.restoredReplies col (nextOracle frozens))) + input.familyCap input.claimCap seed.1 col.tape accepted failure + have same : PCSRoundByRoundTranscriptState.snapshot (c := ParameterBounds.config p) seed.1 col.tape + (PCSRoundByRoundTranscriptState.replies (ExecutionShapes.Input p input.lanes (rootOracle (frozens 0)) + (OriginalClaimsChecker.input input.prepared (rootOracle (frozens 0)) seed.1).claims) + (CausalStrategy.indexedStrategy + (SpongefishCurrentOpeningExperiment.restoredReplies col (nextOracle frozens))) col.tape) + (PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config p)) = + PCSRoundByRoundTranscriptState.snapshot seed.1 col.tape + (SpongefishCurrentOpeningExperiment.restoredReplies col (nextOracle frozens)) + (PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config p)) := + snapshot_indexed (ExecutionShapes.Input p input.lanes (rootOracle (frozens 0)) + (OriginalClaimsChecker.input input.prepared (rootOracle (frozens 0)) seed.1).claims) + (SpongefishCurrentOpeningExperiment.restoredReplies col (nextOracle frozens)) seed.1 col.tape + (PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config p)) + unfold PCSBCSRestorationHazard.literalState + rw [← same] + exact final + +/-- Every hashed input of every returned query opening has its real primitive plan, for the view's public seed, among the view's observations and in the view's public primitive log. -/ +theorem ideal_opening_plans (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (result : (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).result = (some (.ok data),some col)) : + ∀ o ∈ col.openings, ∀ path ∈ o.opened.paths, + ∀ bytes ∈ path.opening.inputs (MerkleTransport.hashing (PublicMerkleLog.hash + (PCSBCSPublicPrimitiveOpening.publicSeed (idealView part iv tag instanceBytes layout before payloadCalls + messages decode grinding prefixProgram counted table)))), + ∀ e ∈ PublicMerkleLog.plan (PCSBCSPublicPrimitiveOpening.publicSeed (idealView part iv tag instanceBytes + layout before payloadCalls messages decode grinding prefixProgram counted table)) bytes, + (⟨.primitive .verification e.1,e.2⟩ : Observation) ∈ + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).observations ∧ + (e.1,e.2) ∈ DuplexPublicSimulator.finalLog [] + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).observations := by + obtain ⟨root0,_,evaluated,planned⟩ := ideal_walk part iv tag instanceBytes layout before payloadCalls messages + decode grinding prefixProgram counted table data col result + intro o member path present bytes input e queried + have call := (walk_openings _ decode grinding _ root0 _ col evaluated o member).2 path present bytes input + have observed := planned bytes call e queried + exact ⟨observed,PCSBCSObservedPrimitiveExtension.primitive_in_finalLog [] _ .verification e.1 e.2 observed⟩ + +/-- The terminal state read off the public good event: the good event fixes the returned walk, the reconstructed original and the batching seed, and for every family of first-mention captures of the walk roots the literal final public state is true. -/ +theorem good_terminal (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (k : Nat) + (good : SpongefishCurrentGoodEvent.GoodFull Q iv instanceBytes layout grinding headerFrames boundary k + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table)) : + ∃ (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) + (input : PCSBCSCallerBinding.CallerInput p) (seed : RingPCSGame.Prefix × E), + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table).result = (some (.ok data),some col) ∧ col.seed = some seed ∧ + ∀ frozens : Nat → Frozen, + Captured grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q iv + (idealView part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table) col frozens → + PCSBCSRestorationHazard.literalState p input (rootOracle (frozens 0)) seed.1 col.tape + (SpongefishCurrentOpeningExperiment.restoredReplies col (nextOracle frozens)) + (PCSRoundByRoundTranscriptState.lastCoordinate (ParameterBounds.config p)) = true := by + obtain ⟨data,col,r,input,result,_,original,verdict,fails,_,quiet⟩ := good + have seeds := verdict + obtain ⟨seed,_,seeded,_⟩ := seeds + exact ⟨data,col,input,seed,result,seeded,fun frozens found => + ideal_terminal part iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram counted table headerFrames boundary supported data col result r input original verdict + fails quiet frozens found seed seeded⟩ + +end IdealRows + +#print axioms source_seed +#print axioms consistent_eval +#print axioms full_walk +#print axioms ideal_walk +#print axioms stepWalk_spec +#print axioms walkFrom_spec +#print axioms walk_spec +#print axioms publicCapture_spec +#print axioms rootReference_geometry +#print axioms captured_rows +#print axioms next_valid +#print axioms root_valid +#print axioms snapshot_indexed +#print axioms candidate_binding +#print axioms ideal_rows +#print axioms ideal_nextShapes +#print axioms ideal_rootShape +#print axioms ideal_terminal +#print axioms ideal_opening_plans +#print axioms good_terminal + +end Whir.SpongefishCurrentIdealRows diff --git a/verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean b/verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean index fefa0a68f..f44be100c 100644 --- a/verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean +++ b/verification/whir/Whir/SpongefishCurrentKnowledgeEndpoint.lean @@ -485,7 +485,7 @@ noncomputable local instance (Q : Nat) (iv : Digest32) (grinding : Fin (cfg).fol | .inr _ => inferInstance open Classical SpongefishCurrentOpeningProgram in -/-- Item 3: the current #607 basic full-prefix knowledge bound for one binding message shape. The real event is native acceptance of the whole current caller path and opening whose prepared original fails public straight-line extraction on the frozen Root0 image. The bound has the three explicit summands of `finalBound`; the only remaining obligation is `refines`, a state path of the current round node model on every ideal table where the public good event fires. -/ +/-- Item 3: the current #607 basic full-prefix knowledge bound for one binding message shape. The real event is: the caller tape replays and the record binding verifies on the real primitive, the PCS opening is natively accepted, and the prepared original fails public straight-line extraction on the frozen Root0 image. The bound has the three explicit summands of `finalBound`; the only remaining obligation is `refines`, a state path of the current round node model on every ideal table where the public good event fires. -/ theorem full_knowledge_bound {Coins : Type} [Fintype Coins] [Nonempty Coins] (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls messages : List Call) (k : Nat) diff --git a/verification/whir/Whir/SpongefishCurrentKnowledgeFinal.lean b/verification/whir/Whir/SpongefishCurrentKnowledgeFinal.lean new file mode 100644 index 000000000..91f39d094 --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentKnowledgeFinal.lean @@ -0,0 +1,187 @@ +import Whir.SpongefishCurrentRefines +import Whir.SpongefishCurrentHeaderGlue +import Whir.SpongefishCurrentKnowledgeEndpoint + +/-! Current #607 basic full-prefix knowledge bound with `Refines` discharged. The `Refines` obligation of `SpongefishCurrentKnowledgeEndpoint.full_knowledge_all` is discharged for every binding message shape by the per-coin caller-data builder of `SpongefishCurrentRefines.builder` with the history reply parser, so the endpoint holds in the ideal-compression model with only static public premises: a nonempty instance, the caller prelude and payload call shapes, and `Supported p (AnchoredSourceCaller.shape layout)` (valid shape whose dimension, batch and rate match the profile). The instance, tag, session IV, caller layout and hint decoder are fixed before the attacker runs. The real event, for SOME received record, is: the caller tape replays and the record binding verifies on the real primitive, the PCS opening is natively accepted (query proof of work, Merkle authentication, anchored equations), and the public straight-line extractor fails on the frozen Root0 image. Caller-side proof of work and caller equations are not required, which only enlarges the event. Completeness of the opening model (acceptance of an honest prover) is not proved here. -/ +namespace Whir.SpongefishCurrentKnowledgeFinal +open Concrete FiatShamirGame DuplexModeGame SpongefishPCSRoundFrames +open SpongefishCurrentOpeningAcceptance SpongefishCurrentOpeningProgram SpongefishCurrentKnowledgeEndpoint +set_option autoImplicit false + +variable {p : ParameterBounds.Profile} {layout : WHIRCallerClaims.CallerLayout} +local notation "cfg" => ParameterBounds.config p + +/-- The caller-data builder of binding message shape `k` for one attacker coin. -/ +noncomputable def build (iv : Digest32) (tag instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (before payloadCalls : List Call) (decode : Decoder) + (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) (k : Nat) : + SpongefishCurrentRoundPackets.Builder p + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) grinding A) iv + grinding (fullBoundary instanceBytes layout before payloadCalls k) := + SpongefishCurrentRefines.builder _ iv grinding (fullBoundary instanceBytes layout before payloadCalls k) + (SpongefishCurrentHeaderGlue.headerFrames instanceBytes layout before) k instanceBytes layout + (SpongefishCurrentHistoryReplies.historyReplies grinding + (fullBoundary instanceBytes layout before payloadCalls k)) + (SpongefishCurrentBCSKnowledge.source (SpongefishCurrentRoundPackets.partition p _ iv grinding + (fullBoundary instanceBytes layout before payloadCalls k)) iv + (fullProgram iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) decode grinding + prefixProgram) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) decode grinding + prefixProgram A attacker)) + +/-- `Refines` holds for every binding message shape and attacker coin. -/ +theorem refines_shape + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (iv : Digest32) (tag instanceBytes : List Byte) (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : Counts A prefixProgram) (k : Nat) : + SpongefishCurrentBCSKnowledge.Refines + (SpongefishCurrentRoundPackets.partition p + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) grinding A) iv + grinding (fullBoundary instanceBytes layout before payloadCalls k)) + (SpongefishCurrentRoundPackets.model p _ iv grinding + (fullBoundary instanceBytes layout before payloadCalls k) + (build iv tag instanceBytes layout before payloadCalls decode grinding prefixProgram A attacker k)) iv + (fullProgram iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) decode grinding + prefixProgram) + (fullProgram_counted iv tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) decode grinding + prefixProgram A attacker) + (SpongefishCurrentGoodEvent.goodFull (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k) grinding A) iv + instanceBytes layout grinding (SpongefishCurrentHeaderGlue.headerFrames instanceBytes layout before) + (fullBoundary instanceBytes layout before payloadCalls k) k) := by + have opening := binding_ready instanceBytes + (before ++ SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls) + (AnchoredSourceCaller.shape layout) k + exact SpongefishCurrentRefines.refines_full _ iv grinding _ _ k instanceBytes layout supported tag before + payloadCalls _ decode prefixProgram _ opening + (SpongefishCurrentHeaderGlue.headerFrames_le instanceBytes layout before payloadCalls _ _ opening) + (fun T data col result => SpongefishCurrentHeaderGlue.openingEvents_full _ iv tag instanceBytes layout + before payloadCalls _ decode grinding prefixProgram _ T data col result) + (fun T data col result r input accepted root0 rootEq => SpongefishCurrentHeaderGlue.header_full _ iv tag + instanceBytes layout before payloadCalls _ decode grinding prefixProgram beforeEq _ T data col result _ _ + r input _ accepted root0 rootEq) + +open Classical in +/-- The current #607 knowledge bound with `Refines` discharged: the real probability that, for some received record, the caller tape replays with a verified record binding, the PCS opening is natively accepted, and the public straight-line extractor fails on the frozen Root0 image, is at most the sum over the four binding message shapes of `finalBound Q_k = Q_k*((17/32)^56+2^-78) + min(1,(2Q_k^2-Q_k)/2^256) + (Q_k^3+3Q_k^2-2Q_k)/2^256`, where `Q_k` is the aggregate budget of shape `k`: attacker work plus the charged verifier replay and Merkle work. -/ +theorem current_knowledge {Coins : Type} [Fintype Coins] [Nonempty Coins] + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : Decoder) (grinding : Fin (cfg).folds.size → Fin 64) + (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode grinding + (prefixProgram coins.2) (fun k => SpongefishCurrentGoodEvent.ExtractionFails grinding + (AnchoredSourceCaller.shape layout) (SpongefishCurrentHeaderGlue.headerFrames instanceBytes layout before) + (fullBoundary instanceBytes layout before payloadCalls k.val) + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) grinding A) iv) + then (1 : ℚ) else 0) ≤ + ∑ k : Fin 4, SpongefishCurrentBCSKnowledge.finalBound (fullBudget tag instanceBytes layout before + payloadCalls (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + grinding A : ℚ) := + full_knowledge_all iv tag instanceBytes nonempty layout before payloadCalls beforeEq payloadEq decode grinding + prefixProgram A attacker (SpongefishCurrentHeaderGlue.headerFrames instanceBytes layout before) + (fun k coin => build iv tag instanceBytes layout before payloadCalls decode grinding (prefixProgram coin) A + (attacker coin) k.val) + (fun k coin => refines_shape supported iv tag instanceBytes before payloadCalls beforeEq decode grinding + (prefixProgram coin) A (attacker coin) k.val) + +/-- Four per-shape budgets at most `B <= 2^64` give at most `B / 2^49` in total. -/ +theorem four_shapes (budgets : Fin 4 → Nat) (B : Nat) (cap : B ≤ 2^64) (budget : ∀ k, budgets k ≤ B) : + ∑ k : Fin 4, SpongefishCurrentBCSKnowledge.finalBound (budgets k : ℚ) ≤ (B : ℚ) / 2^49 := by + have each (k : Fin 4) : SpongefishCurrentBCSKnowledge.finalBound (budgets k : ℚ) ≤ (B : ℚ) / 2^51 := by + have within : (budgets k : ℚ) ≤ B := by exact_mod_cast budget k + have capped : (B : ℚ) ≤ 2^64 := by exact_mod_cast cap + refine (SpongefishCurrentBCSKnowledge.finalBound_le _ (by positivity) (within.trans capped)).trans ?_ + exact div_le_div_of_nonneg_right within (by positivity) + refine (Finset.sum_le_sum fun k _ => each k).trans (le_of_eq ?_) + rw [Finset.sum_const,Finset.card_univ,Fintype.card_fin,nsmul_eq_mul] + ring + +open Classical in +/-- Concrete level at the deployed 17-bit query grinding: if every binding message shape has aggregate budget at most `B <= 2^64`, the probability of native acceptance with public extraction failure is at most `B / 2^49` (four shapes, each at most `B / 2^51`). -/ +theorem current_knowledge_level {Coins : Type} [Fintype Coins] [Nonempty Coins] + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : Decoder) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (B : Nat) (cap : B ≤ 2^64) + (budget : ∀ k : Fin 4, fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A ≤ B) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode + (SpongefishCurrentBCSKnowledge.deployedGrinding p) (prefixProgram coins.2) + (fun k => SpongefishCurrentGoodEvent.ExtractionFails (SpongefishCurrentBCSKnowledge.deployedGrinding p) + (AnchoredSourceCaller.shape layout) (SpongefishCurrentHeaderGlue.headerFrames instanceBytes layout before) + (fullBoundary instanceBytes layout before payloadCalls k.val) + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A) iv) + then (1 : ℚ) else 0) ≤ (B : ℚ) / 2^49 := by + exact (current_knowledge supported iv tag instanceBytes nonempty before payloadCalls beforeEq payloadEq decode + (SpongefishCurrentBCSKnowledge.deployedGrinding p) prefixProgram A attacker).trans + (four_shapes _ B cap budget) + +open Classical in +/-- Security level in bits at the deployed grinding: with every per-shape budget (attacker work plus the charged verifier replay and Merkle work, a worst-case charge not evaluated here for deployed layouts) at most `2^(49-λ)`, the probability of the accepted-with-extraction-failure event is at most `2^-λ`. For example per-shape budgets of `2^29` units give `2^-20` and `2^39` units give `2^-10`. -/ +theorem current_knowledge_bits {Coins : Type} [Fintype Coins] [Nonempty Coins] + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (iv : Digest32) (tag instanceBytes : List Byte) (nonempty : instanceBytes ≠ []) + (before payloadCalls : List Call) + (beforeEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.preludeShape layout) = some before) + (payloadEq : SpongefishCurrentSourceCallerOriginal.shapeCalls + (SpongefishCurrentSourceCallerOriginal.payloadShape layout) = some payloadCalls) + (decode : Decoder) (prefixProgram : Coins → Program SpongefishCurrentInitializedMode.Input) (A : Nat) + (attacker : ∀ coin, Counts A (prefixProgram coin)) (bits : Nat) (small : bits ≤ 49) + (budget : ∀ k : Fin 4, fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A ≤ 2^(49-bits)) : + average (fun coins : PrimitiveOracle × Coins => + if NativeAcceptedAnyFull coins.1 iv tag instanceBytes layout before payloadCalls decode + (SpongefishCurrentBCSKnowledge.deployedGrinding p) (prefixProgram coins.2) + (fun k => SpongefishCurrentGoodEvent.ExtractionFails (SpongefishCurrentBCSKnowledge.deployedGrinding p) + (AnchoredSourceCaller.shape layout) (SpongefishCurrentHeaderGlue.headerFrames instanceBytes layout before) + (fullBoundary instanceBytes layout before payloadCalls k.val) + (fullBudget tag instanceBytes layout before payloadCalls + (SpongefishCurrentBCSKnowledge.bindingCalls (AnchoredSourceCaller.shape layout) k.val) + (SpongefishCurrentBCSKnowledge.deployedGrinding p) A) iv) + then (1 : ℚ) else 0) ≤ 1 / 2^bits := by + have cap : 2^(49-bits) ≤ 2^64 := Nat.pow_le_pow_right (by norm_num) (by omega) + refine (current_knowledge_level supported iv tag instanceBytes nonempty before payloadCalls beforeEq payloadEq + decode prefixProgram A attacker _ cap budget).trans (le_of_eq ?_) + have split : (2 : ℚ)^49 = 2^(49-bits) * 2^bits := by + rw [← pow_add, Nat.sub_add_cancel small] + push_cast + rw [split] + field_simp + +#print axioms refines_shape +#print axioms current_knowledge +#print axioms current_knowledge_level +#print axioms current_knowledge_bits + +end Whir.SpongefishCurrentKnowledgeFinal diff --git a/verification/whir/Whir/SpongefishCurrentRefines.lean b/verification/whir/Whir/SpongefishCurrentRefines.lean new file mode 100644 index 000000000..6ec92070c --- /dev/null +++ b/verification/whir/Whir/SpongefishCurrentRefines.lean @@ -0,0 +1,1159 @@ +import Whir.SpongefishCurrentIdealRows +import Whir.SpongefishCurrentHistoryReplies +import Whir.SpongefishCurrentPartitionCapture +import Whir.PCSBCSLiteralStatePath +import Whir.PCSBCSCapturedSourceStatePath +import Whir.PCSBCSRestorationHazard +import Whir.WHIRQueryOracleRecurrence + +/-! Refinement of the current #607 round node model (`SpongefishCurrentBCSKnowledge.Refines` for `SpongefishCurrentGoodEvent.goodFull`). + +The builder reads only the table with the selected packet erased. It recovers the received record from the post-binding construction key, the caller original by caller replay with the admissible in-budget getter of the joined table, the Root0 and level-root images by first-mention partition capture of the references mentioned by the packet history (header frame and level-ending reply frames), the tape of every earlier draw from the raw keys of the history prefixes, and the replies by a reply parser of the history completed with the captured oracles. On every opening packet of a good table it returns the literal caller data of the returned walk (`builder_exact`): the post-binding coordinate is short, so the erased packet is never read by the caller replay; every mentioned root is captured before the packet answer; earlier draws are other packets; and the parser is exact before the packet coordinate. The packets of all coordinates, in schedule order, are recorded, so the literal before/after identities give the state path (`statePath`). + +`refines_of_facts` is generic in the program and the reply parser. `refines_full` instantiates it with the full source program and `SpongefishCurrentHistoryReplies.historyReplies`, using the opening packet histories, walk tape, seed, roots and parser exactness of `SpongefishCurrentHistoryReplies` and the row binding and terminal state of `SpongefishCurrentIdealRows`; its remaining hypotheses are static or header glue. -/ +namespace Whir.SpongefishCurrentRefines +open Concrete Protocol CausalGame FiatShamirGame DuplexModeGame DuplexFraming +open TypedOracleCompiler PCSBCSChallengeOracle PCSBCSCallerBinding +open SpongefishCurrentOpeningAcceptance SpongefishCurrentRoundPackets +open CausalProbability (position get levelCoordinates visibleCoordinates) +set_option autoImplicit false + +variable {p : ParameterBounds.Profile} +local notation "cfg" => ParameterBounds.config p + +/-! ## Static schedule facts -/ + +/-- Every deployed coordinate draws a positive number of bytes. -/ +theorem widths_deployed : ∀ p : ParameterBounds.Profile, + ((WHIRHistory.schedule (ParameterBounds.config p)).all fun q => + decide (PCSBCSRounds.rawWidth q ≠ 0)) = true := by + decide +kernel + +theorem width_ne (q : Coord p) : PCSBCSRounds.rawWidth q ≠ 0 := by + have all := widths_deployed p + rw [List.all_eq_true] at all + simpa using all q (WHIRHistory.coordinate_mem_schedule q) + +/-- The proof-of-work draws of a coordinate. -/ +def powPart (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) : List (Option (Coord p)) := + match q with + | .query i => if (grinding i).val = 0 then [] else [none] + | _ => [] + +/-- The opening draws of one coordinate. -/ +def drawStep (grinding : Fin (cfg).folds.size → Fin 64) (q : Coord p) : List (Option (Coord p)) := + powPart grinding q ++ (if PCSBCSRounds.rawWidth q = 0 then [] else [some q]) + +theorem openingDraws_eq (grinding : Fin (cfg).folds.size → Fin 64) : + openingDraws grinding = (WHIRHistory.schedule cfg).flatMap (drawStep grinding) := rfl + +theorem step_some (grinding : Fin (cfg).folds.size → Fin 64) (q y : Coord p) (n : Nat) + (found : (drawStep grinding q)[n]? = some (some y)) : + y = q ∧ n = (powPart grinding q).length := by + have none_ : ∀ x ∈ powPart grinding q, x = none := by + intro x member + unfold powPart at member + split at member + · split at member <;> simp_all + · simp at member + unfold drawStep at found + by_cases small : n < (powPart grinding q).length + · rw [List.getElem?_append_left small] at found + exact absurd (none_ _ (List.mem_of_getElem? found)) (by simp) + · rw [List.getElem?_append_right (by omega)] at found + split at found + · simp at found + · obtain ⟨inside,same⟩ := List.getElem?_eq_some_iff.mp found + simp only [List.length_singleton] at inside + simp only [List.getElem_singleton,Option.some.injEq] at same + exact ⟨same.symm,by omega⟩ + +theorem flatMap_some {α : Type} (f : α → List (Option α)) (g : α → Nat) + (hf : ∀ x y n, (f x)[n]? = some (some y) → y = x ∧ n = g x) : + ∀ (xs : List α) (j : Nat) (y : α), (xs.flatMap f)[j]? = some (some y) → + ∃ m, xs[m]? = some y ∧ j = ((xs.take m).flatMap f).length + g y ∧ g y < (f y).length + | [], j, y, found => by simp at found + | x :: xs, j, y, found => by + rw [List.flatMap_cons] at found + by_cases small : j < (f x).length + · rw [List.getElem?_append_left small] at found + obtain ⟨rfl,rfl⟩ := hf x y j found + exact ⟨0,rfl,by simp,small⟩ + · rw [List.getElem?_append_right (by omega)] at found + obtain ⟨m,at_,index,inside⟩ := flatMap_some f g hf xs _ y found + refine ⟨m+1,by simpa using at_,?_,inside⟩ + simp only [List.take_succ_cons,List.flatMap_cons,List.length_append] + omega + +/-- The index of a PCS draw is fixed by the schedule position of its coordinate. -/ +theorem draw_index (grinding : Fin (cfg).folds.size → Fin 64) (j : Nat) (q : Coord p) + (found : (openingDraws grinding)[j]? = some (some q)) : + j = (((WHIRHistory.schedule cfg).take (position q)).flatMap (drawStep grinding)).length + + (powPart grinding q).length ∧ + (powPart grinding q).length < (drawStep grinding q).length := by + obtain ⟨m,at_,index,inside⟩ := flatMap_some (drawStep grinding) (fun q => (powPart grinding q).length) + (step_some grinding) _ j q found + have place : m = position q := by + obtain ⟨lt,eq⟩ := List.getElem?_eq_some_iff.mp at_ + rw [← WHIRHistory.schedule_idxOf,← eq] + exact ((WHIRHistory.schedule_nodup cfg).idxOf_getElem m lt).symm + subst place + exact ⟨index,inside⟩ + +theorem flatMap_take_mono {α β : Type} (f : α → List β) (xs : List α) (a b : Nat) (le : a ≤ b) : + ((xs.take a).flatMap f).length ≤ ((xs.take b).flatMap f).length := by + conv_rhs => rw [← List.take_append_drop a (xs.take b)] + rw [List.take_take,Nat.min_eq_left le,List.flatMap_append,List.length_append] + omega + +theorem flatMap_take_succ {α β : Type} (f : α → List β) (xs : List α) (m : Nat) (x : α) + (at_ : xs[m]? = some x) : + ((xs.take (m+1)).flatMap f).length = ((xs.take m).flatMap f).length + (f x).length := by + rw [List.take_add_one,at_] + simp [List.flatMap_append] + +/-- Draw order is schedule order. -/ +theorem draw_lt (grinding : Fin (cfg).folds.size → Fin 64) (j j' : Nat) (r q : Coord p) + (hr : (openingDraws grinding)[j']? = some (some r)) + (hq : (openingDraws grinding)[j]? = some (some q)) (earlier : position r < position q) : j' < j := by + obtain ⟨ir,inr⟩ := draw_index grinding j' r hr + obtain ⟨iq,_⟩ := draw_index grinding j q hq + have step := flatMap_take_succ (drawStep grinding) _ _ r (WHIRHistory.schedule_get_position r) + have mono := flatMap_take_mono (drawStep grinding) (WHIRHistory.schedule cfg) (position r + 1) + (position q) earlier + omega + +/-- The draw of a coordinate, in the static draw list. -/ +def drawIndex (grinding : Fin (cfg).folds.size → Fin 64) (c : Coord p) : Nat := + (openingDraws grinding).idxOf (some c) + +theorem drawIndex_eq (grinding : Fin (cfg).folds.size → Fin 64) (j : Nat) (c : Coord p) + (found : (openingDraws grinding)[j]? = some (some c)) : drawIndex grinding c = j := by + have at_ : (openingDraws grinding)[drawIndex grinding c]? = some (some c) := + List.getElem?_idxOf (List.mem_of_getElem? found) + obtain ⟨a,_⟩ := draw_index grinding _ c at_ + obtain ⟨b,_⟩ := draw_index grinding j c found + omega + +theorem drawIndex_spec (grinding : Fin (cfg).folds.size → Fin 64) (c : Coord p) : + (openingDraws grinding)[drawIndex grinding c]? = some (some c) := by + obtain ⟨j,found⟩ := SpongefishCurrentOpeningPackets.openingDraws_complete grinding c + (WHIRHistory.coordinate_mem_schedule c) (width_ne c) + rw [drawIndex_eq grinding j c found] + exact found + +/-! ## Level order -/ + +def levelOf : Coord p → Option Nat + | .fold i _ => some i.val + | .ood i _ => some i.val + | .query i => some i.val + | _ => none + +theorem levelOf_mem (k : Nat) (q : Coord p) (h : q ∈ levelCoordinates cfg k) : levelOf q = some k := by + unfold levelCoordinates at h + split_ifs at h with hk + · simp only [List.mem_append,List.mem_ofFn,List.mem_singleton] at h + rcases h with (⟨j,rfl⟩ | ⟨j,rfl⟩) | rfl <;> rfl + · simp at h + +/-- Every coordinate of an earlier level precedes every coordinate of a later level. -/ +theorem level_before (a b : Nat) (lt : a < b) (x y : Coord p) (hx : x ∈ levelCoordinates cfg a) + (hy : y ∈ levelCoordinates cfg b) : position x < position y := by + have hb : b < (cfg).folds.size := by + unfold levelCoordinates at hy + split_ifs at hy with h + · exact h + · simp at hy + have range : List.range (cfg).folds.size = List.range (a+1) ++ + (List.range ((cfg).folds.size-(a+1))).map (fun n => a+1+n) := by + calc + List.range (cfg).folds.size = List.range ((a+1)+((cfg).folds.size-(a+1))) := + congrArg List.range (by omega) + _ = _ := by rw [List.range_add] + have shape : visibleCoordinates cfg = + ([(.initial : Coord p)] ++ (List.range (a+1)).flatMap (levelCoordinates cfg)) ++ + (((List.range ((cfg).folds.size-(a+1))).map (fun n => a+1+n)).flatMap (levelCoordinates cfg) ++ + List.ofFn fun j : Fin ((cfg).logN - (cfg).folds.toList.sum - 1) => + CausalProbability.Coordinate.tail ⟨j.val,by omega⟩) := by + unfold visibleCoordinates + rw [range,List.flatMap_append] + simp only [List.append_assoc] + have inA : x ∈ [(.initial : Coord p)] ++ (List.range (a+1)).flatMap (levelCoordinates cfg) := + List.mem_append_right _ (List.mem_flatMap.mpr ⟨a,List.mem_range.mpr (by omega),hx⟩) + have outA : y ∉ [(.initial : Coord p)] ++ (List.range (a+1)).flatMap (levelCoordinates cfg) := by + have level := levelOf_mem b y hy + intro member + rcases List.mem_append.mp member with initial | later + · rw [List.mem_singleton.mp initial] at level + cases level + · obtain ⟨m,hm,inside⟩ := List.mem_flatMap.mp later + have := levelOf_mem m y inside + rw [level] at this + cases this + have := List.mem_range.mp hm + omega + unfold position + rw [shape,List.idxOf_append_of_mem inA,List.idxOf_append_of_notMem outA] + have := List.idxOf_lt_length_of_mem inA + omega + +theorem fold_lt_query (i : Fin (cfg).folds.size) (k : Fin (cfg).folds[i.val]!) (t : Tape cfg) : + position (.fold i k : Coord p) < position (.query i : Coord p) := by + rw [CausalPositions.position_fold i k t,CausalPositions.position_query i t] + have := k.isLt + omega + +/-- The last fold of the level before `i`. -/ +def lastFold : Nat → Option (Coord p) + | 0 => none + | i+1 => + if h : i < (cfg).folds.size then + some (.fold ⟨i,h⟩ ⟨(cfg).folds[i]! - 1,by + have : 0 < (cfg).folds[i]! := WHIRQueryOracleRecurrence.production_folds_positive p ⟨i,h⟩ + change (cfg).folds[i]! - 1 < (cfg).folds[i]! + omega⟩) + else none + +theorem lastFold_eq (i : Fin (cfg).folds.size) (k : Fin (cfg).folds[i.val]!) + (last : isLastFold i k = true) : lastFold (p := p) (i.val+1) = some (.fold i k) := by + have kEq : k.val = (cfg).folds[i.val]! - 1 := by + simp only [isLastFold,decide_eq_true_eq] at last + omega + obtain ⟨kv,klt⟩ := k + simp only at kEq + subst kEq + simp only [lastFold,i.isLt,↓reduceDIte] + +/-! ## The builder -/ + +section Builder +variable (Q : Nat) (iv : Digest32) (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (boundary : Nat) + +/-- Tables of the current round partition. -/ +abbrev Table := (key : Key p Q iv grinding boundary) → Answer p Q iv grinding boundary key + +/-- The output blocks of the coordinate `r` drawn at the first `n` frames of `H`, looked up by raw key through the joined table. -/ +noncomputable def prefixBlocks (T : Table Q iv grinding boundary) (H : FramedHistory) (n : Nat) + (r : Coord p) : Fin (blocks (PCSBCSRounds.rawWidth r)) → Digest32 := fun b => + if work : pathCost ⟨{H with frames := H.frames.take n},.output b.val⟩ ≤ Q then + (partition p Q iv grinding boundary).join T + (.inr (constructionKey Q iv ⟨{H with frames := H.frames.take n},.output b.val⟩ work)) + else 0 + +/-- The grouped sample of `r` read at its draw prefix of `H`. -/ +noncomputable def sampleAt (T : Table Q iv grinding boundary) (H : FramedHistory) (r : Coord p) : + PCSBCSRounds.Raw r := + grouped r (prefixBlocks Q iv grinding boundary T H (boundary + drawIndex grinding r + 1) r) + +/-- The tape of every coordinate strictly before `q`, read from the prefixes of `H`. -/ +noncomputable def tapeOf (T : Table Q iv grinding boundary) (H : FramedHistory) (q : Coord p) : Tape cfg := + (CausalProbability.coordinates cfg).symm fun r => + if position r < position q then StackWHIRReplay.projectSample r (sampleAt Q iv grinding boundary T H r) + else 0 + +/-- The ring prefix of the initial draw, read from the prefix of `H`. -/ +noncomputable def ringOf (T : Table Q iv grinding boundary) (H : FramedHistory) : RingPCSGame.Prefix := + (sampleAt Q iv grinding boundary T H .initial).1 + +/-- The reference of the level-`i` root mentioned by `H`: Root0 from the header frame, a later level root from the reply frame of the last fold of the level before. -/ +def rootRef (shape : SpongefishSessionAdapter.Shape) (headerFrames : Nat) (H : FramedHistory) (i : Nat) : + Option PCSBCSSourceRootReferences.Reference := + if i = 0 then SpongefishCurrentRootPolicy.anchorReference shape headerFrames H + else (lastFold (p := p) i).bind fun c => + SpongefishCurrentRootPolicy.levelAt p grinding boundary H (drawIndex grinding c) + +/-- First-mention capture of the level-`i` root mentioned by `H`. -/ +noncomputable def frozenAt {R : Type} {n : Nat} + (source : Sampling (Key p Q iv grinding boundary) (Answer p Q iv grinding boundary) R n) + (shape : SpongefishSessionAdapter.Shape) (headerFrames : Nat) (T : Table Q iv grinding boundary) + (H : FramedHistory) (i : Nat) : Option PCSBCSMerkleRootCache.Frozen := + (rootRef grinding boundary shape headerFrames H i).bind fun ref => + SpongefishCurrentPartitionCapture.pcapture (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) ref source T + +open Classical in +/-- In-budget construction answers of a raw table, at admissible coordinates only. -/ +noncomputable def admissibleGetter (table : PublicCompressionCouplingMixed.Key Q → Digest32) + (c : Coordinate) : Option Digest32 := + if DuplexEncoding.Admissible c then SpongefishCurrentCallerOriginalTable.tableGetter Q iv table c else none + +/-- The post-binding coordinate of a packet history. -/ +def bindingCoordinate (H : FramedHistory) : Coordinate := + ⟨{H with frames := H.frames.take (boundary+1)},.output 0⟩ + +/-- The selected record of a coordinate's construction key. -/ +def recordAt (k : Nat) (shape : AnchoredHeaderCodec.Shape) (q : Coordinate) : + Option SpongefishSessionAdapter.Record := + if work : pathCost q ≤ Q then + SpongefishCurrentCallerOriginalTable.recordOf shape iv k (constructionKey Q iv q work) + else none + +/-- The current round builder: from the table with the selected packet erased, the caller original at the post-binding coordinate, the first-mention Root0 and level captures, the tape of earlier draws and the replies parsed from the packet history. -/ +noncomputable def builder (headerFrames k : Nat) (instanceBytes : List Byte) + (layout : WHIRCallerClaims.CallerLayout) (parse : FramedHistory → Tape cfg → (Nat → Oracle) → Array Reply) + {R : Type} {n : Nat} + (source : Sampling (Key p Q iv grinding boundary) (Answer p Q iv grinding boundary) R n) : + Builder p Q iv grinding boundary := fun packet other => + let T' := SpongefishCurrentPartitionCapture.otherTable (partition p Q iv grinding boundary) packet other + let H := packet.history + let q0 := bindingCoordinate boundary H + (recordAt Q iv k (AnchoredSourceCaller.shape layout) q0).bind fun r => + (SpongefishCurrentCallerOriginalTable.tableCandidate p layout q0 r instanceBytes + (admissibleGetter Q iv ((partition p Q iv grinding boundary).join T'))).bind fun input => + (frozenAt Q iv grinding boundary source (AnchoredSourceCaller.shape layout) headerFrames T' H 0).map fun f0 => + let next := fun i => ((frozenAt Q iv grinding boundary source (AnchoredSourceCaller.shape layout) + headerFrames T' H i).bind (PCSBCSFrozenOracleRows.frozenOracle i)).getD #[] + let t := tapeOf Q iv grinding boundary T' H packet.coord + PCSBCSRestorationHazard.literalCallerData p input f0.raw (ringOf Q iv grinding boundary T' H) t + (parse H t (SpongefishCurrentOpeningExperiment.levelOracle f0.raw next)) packet.coord + +end Builder + +/-! ## Erased tables, raw keys and root mentions -/ + +section Tables +variable (Q : Nat) (iv : Digest32) (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (boundary : Nat) + +theorem get_coordinates (f : ∀ r : Coord p, CausalProbability.Sample r) (r : Coord p) : + get r ((CausalProbability.coordinates cfg).symm f) = f r := + congrFun ((CausalProbability.coordinates cfg).apply_symm_apply f) r + +theorem otherTable_of_ne (packet : Packet p Q grinding boundary) (T : Table Q iv grinding boundary) + (key : Key p Q iv grinding boundary) (ne : key ≠ .inl packet) : + SpongefishCurrentPartitionCapture.otherTable (partition p Q iv grinding boundary) packet + (PCSStateRestoration.Latent.erase (.inl packet) T) key = T key := by + classical + unfold SpongefishCurrentPartitionCapture.otherTable + rw [PCSStateRestoration.Latent.fill_erase] + exact Function.update_of_ne ne _ _ + +theorem join_other (packet : Packet p Q grinding boundary) (T : Table Q iv grinding boundary) + (raw : PublicCompressionCouplingMixed.Key Q) + (other : ∀ c, (partition p Q iv grinding boundary).recognize raw = some c → c.1 ≠ packet) : + (partition p Q iv grinding boundary).join (SpongefishCurrentPartitionCapture.otherTable + (partition p Q iv grinding boundary) packet (PCSStateRestoration.Latent.erase (.inl packet) T)) raw = + (partition p Q iv grinding boundary).join T raw := by + unfold RawOracleCoupling.Partition.join + split + · rename_i c hc + exact congrFun (otherTable_of_ne Q iv grinding boundary packet T (.inl c.1) + (fun e => other c hc (Sum.inl.inj e))) c.2 + · rename_i hc + exact otherTable_of_ne Q iv grinding boundary packet T _ (by simp) + +theorem recognize_key (raw : RawKey Q) (c : Sigma (PacketBlock (p := p) (Q := Q) (grinding := grinding) + (boundary := boundary))) + (found : (partition p Q iv grinding boundary).recognize (.inr raw) = some c) : + raw = packetKey iv c.1 c.2 := by + have encoded := (partition p Q iv grinding boundary).encode_recognize _ c found + change Sum.inr (packetKey iv c.1 c.2) = _ at encoded + exact (Sum.inr.inj encoded).symm + +/-- A construction key of an admissible coordinate with at most `boundary` frames is garbage. -/ +theorem small_garbage (c : Coordinate) (valid : DuplexEncoding.Admissible c) (work : pathCost c ≤ Q) + (small : c.history.frames.length ≤ boundary) + (blk : Sigma (PacketBlock (p := p) (Q := Q) (grinding := grinding) (boundary := boundary))) : + (partition p Q iv grinding boundary).recognize (.inr (constructionKey Q iv c work)) ≠ some blk := by + intro found + have key := recognize_key Q iv grinding boundary _ blk found + have same := constructionKey_injective Q iv valid (blk.1.admissible blk.2) work (blk.1.bounded blk.2) key + have frames := congrArg (fun c : Coordinate => c.history.frames.length) same + have large := SpongefishCurrentCallerOriginalTable.packet_frames blk.1 + simp only at frames + omega + +theorem addresses_block (shape : SpongefishSessionAdapter.Shape) (headerFrames : Nat) + (P : Packet p Q grinding boundary) (b : PacketBlock P) : + SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv + ((partition p Q iv grinding boundary).encode ⟨P,b⟩) = + SpongefishCurrentRootPolicy.references p grinding shape headerFrames boundary P.history := by + change SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv + (.inr (constructionKey Q iv ⟨P.history,.output b.val⟩ (P.bounded b))) = _ + simp only [SpongefishCurrentRootPolicy.addresses, + WHIRHeaderRoots.decodeRaw_construction iv _ (P.admissible b) (P.bounded b)] + rfl + +theorem mentioned (shape : SpongefishSessionAdapter.Shape) (headerFrames : Nat) + (P : Packet p Q grinding boundary) (ref : PCSBCSSourceRootReferences.Reference) + (member : ref ∈ SpongefishCurrentRootPolicy.references p grinding shape headerFrames boundary P.history) : + ref ∈ SpongefishCurrentPartitionCapture.paddr (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) (.inl P) := + (SpongefishCurrentPartitionCapture.mem_paddr_packet _ _ P ref).mpr + ⟨firstBlock P,by rw [addresses_block]; exact member⟩ + +theorem uniform (shape : SpongefishSessionAdapter.Shape) (headerFrames : Nat) : + SpongefishCurrentPartitionCapture.Uniform (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) := by + intro P b c ref member + rw [addresses_block] at member ⊢ + exact member + +/-- On the source of a counted program, the partition capture is the public capture of the view. -/ +theorem pcapture_public (shape : SpongefishSessionAdapter.Shape) (headerFrames : Nat) {R : Type} + (program : Program R) (counted : Counts Q program) (T : Table Q iv grinding boundary) + (ref : PCSBCSSourceRootReferences.Reference) : + SpongefishCurrentPartitionCapture.pcapture (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) ref + (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted) T = + SpongefishCurrentRootPolicy.publicCapture (B := Q) p grinding shape headerFrames boundary iv ref + (Sampling.eval T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv + program counted)) := + SpongefishCurrentPartitionCapture.pcapture_view _ _ (uniform Q iv grinding boundary shape headerFrames) + (SpongefishCurrentPartitionCapture.round_plain p Q iv grinding boundary) iv ref program Q (le_refl Q) + counted T + +/-- The caller original of the erased table: the public candidate of the view transfers to the admissible getter of the joined table, and the erased packet is never read. -/ +theorem input_exact {R : Type} (program : Program R) (counted : Counts Q program) + (T : Table Q iv grinding boundary) (packet : Packet p Q grinding boundary) + (layout : WHIRCallerClaims.CallerLayout) (q0 : Coordinate) (r : SpongefishSessionAdapter.Record) + (instanceBytes : List Byte) (input : PCSBCSCallerBinding.CallerInput p) + (atBoundary : q0.history.frames.length ≤ boundary + 1) + (accepted : SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout q0 r instanceBytes + (Sampling.eval T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program + counted)).observations = some input) : + SpongefishCurrentCallerOriginalTable.tableCandidate p layout q0 r instanceBytes + (admissibleGetter Q iv ((partition p Q iv grinding boundary).join + (SpongefishCurrentPartitionCapture.otherTable (partition p Q iv grinding boundary) packet + (PCSStateRestoration.Latent.erase (.inl packet) T)))) = some input := by + classical + have first : SpongefishCurrentCallerOriginalTable.tableCandidate p layout q0 r instanceBytes + (admissibleGetter Q iv ((partition p Q iv grinding boundary).join T)) = some input := by + apply SpongefishCurrentCallerOriginalTable.candidate_tableCandidate p layout q0 r instanceBytes _ _ input + accepted + intro o member c valid query work + unfold SpongefishCurrentBCSKnowledge.source at member + rw [Atomic.eval_program] at member + have observed := SpongefishCurrentCallerOriginalTable.table_observed Q _ iv [] program Q (le_refl Q) + counted o member c valid query work + simp only [admissibleGetter,valid,↓reduceIte] + exact observed + rw [SpongefishCurrentCallerOriginalTable.tableCandidate_boundary p layout q0 r instanceBytes _ + (admissibleGetter Q iv ((partition p Q iv grinding boundary).join T)) boundary atBoundary ?_] + · exact first + intro c small + unfold admissibleGetter + split + · rename_i valid + unfold SpongefishCurrentCallerOriginalTable.tableGetter + split + · rename_i work + rw [join_other Q iv grinding boundary packet T _ + (fun blk found _ => small_garbage Q iv grinding boundary c valid work small blk found)] + · rfl + · rfl + +end Tables + +theorem fold_mem (i : Fin (cfg).folds.size) (k : Fin (cfg).folds[i.val]!) : + (.fold i k : Coord p) ∈ levelCoordinates cfg i.val := by + unfold levelCoordinates + rw [dite_eq_left i.isLt] + exact List.mem_append_left _ (List.mem_append_left _ (List.mem_ofFn.mpr ⟨k,rfl⟩)) + +theorem query_mem (i : Fin (cfg).folds.size) : (.query i : Coord p) ∈ levelCoordinates cfg i.val := by + simp [levelCoordinates,i.isLt] + +/-- The literal caller data reads the ring only after the initial draw, the tape only strictly before `q` and the replies only before the position of `q`. -/ +theorem literalCallerData_congr (original : PCSBCSCallerBinding.CallerInput p) (root : BaseOracle) + (ring ring' : RingPCSGame.Prefix) (t t' : Tape cfg) (a a' : Array Reply) (q : Coord p) + (rings : q ≠ .initial → ring = ring') + (tapes : ∀ r : Coord p, position r < position q → get r t = get r t') + (answers : PCSRoundByRoundTranscriptState.priorAnswers a (position q) = + PCSRoundByRoundTranscriptState.priorAnswers a' (position q)) : + PCSBCSRestorationHazard.literalCallerData p original root ring t a q = + PCSBCSRestorationHazard.literalCallerData p original root ring' t' a' q := by + unfold PCSBCSRestorationHazard.literalCallerData PCSBCSRestorationHazard.incomingData + PCSBCSRestorationHazard.incomingTrace + have ringPart : (if q = .initial then none else some ring) = (if q = .initial then none else some ring') := by + split_ifs with h + · rfl + · rw [rings h] + have tapePart : (fun r : Coord p => if position r < position q then some (get r t) else none) = + (fun r : Coord p => if position r < position q then some (get r t') else none) := by + funext r + split_ifs with h + · rw [tapes r h] + · rfl + rw [ringPart,tapePart,answers] + +/-! ## Good-table facts and exactness -/ + +/-- Levels whose oracle is read by the replies strictly before `q`: the level announced by a root-carrying last fold before `q`, and the level of a query reply before `q`. -/ +def LevelUsed (q : Coord p) (i : Nat) : Prop := + (∃ (i' : Fin (cfg).folds.size) (k : Fin (cfg).folds[i'.val]!), isLastFold i' k = true ∧ + i'.val + 1 < (cfg).folds.size ∧ i = i'.val + 1 ∧ position (.fold i' k : Coord p) < position q) ∨ + (∃ i' : Fin (cfg).folds.size, 0 < i'.val ∧ i = i'.val ∧ position (.query i' : Coord p) < position q) + +/-- Drawn byte runs of the opening draws, in draw order. -/ +def drawnBytes (grinding : Fin (cfg).folds.size → Fin 64) (data : SpongefishCurrentMixedModeCompiler.Data) : + List (List Byte) := + SpongefishCurrentOpeningPackets.verifierBytes (SpongefishCurrentOpeningPackets.openingEvents grinding data.events) + +section Exact +variable (Q : Nat) (iv : Digest32) (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (boundary headerFrames k : Nat) (instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (parse : FramedHistory → Tape (ParameterBounds.config p) → (Nat → Oracle) → Array Reply) + (program : Program (SpongefishCurrentOpeningProgram.FullResult p)) (counted : Counts Q program) + +/-- Everything the good event and the sibling modules supply on one table: the good-event caller record and original, the opening packet histories with their nesting and recorded packets, the tape and seed of the returned walk at every draw, the header and level roots of the walk read from the histories, and exactness of the reply parser before every packet coordinate. -/ +structure Facts (T : Table Q iv grinding boundary) (data : SpongefishCurrentMixedModeCompiler.Data) + (col : Collected p) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (seed : RingPCSGame.Prefix × E) (histories : List FramedHistory) : Prop where + record : ∃ work : pathCost (SpongefishCurrentGoodEvent.postBinding boundary data) ≤ Q, + SpongefishCurrentCallerOriginalTable.recordOf (AnchoredSourceCaller.shape layout) iv k + (constructionKey Q iv (SpongefishCurrentGoodEvent.postBinding boundary data) work) = some r + original : SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout + (SpongefishCurrentGoodEvent.postBinding boundary data) r instanceBytes + (Sampling.eval T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program + counted)).observations = some input + seeded : col.seed = some seed + postHistory : ∀ h : FramedHistory, histories[0]? = some h → + SpongefishCurrentGoodEvent.postBinding boundary data = ⟨h,.output 0⟩ + frames : ∀ (j : Nat) (h : FramedHistory), histories[j]? = some h → h.frames.length = boundary + j + 1 + nested : ∀ (i j : Nat) (hi hj : FramedHistory), i ≤ j → histories[i]? = some hi → + histories[j]? = some hj → hi = {hj with frames := hj.frames.take (boundary + i + 1)} + packets : ∀ (j : Nat) (q : Coord p), (openingDraws grinding)[j]? = some (some q) → + ∃ (packet : Packet p Q grinding boundary) (bytes : List Byte), + packet.coord = q ∧ histories[j]? = some packet.history ∧ + (drawnBytes grinding data)[j]? = some bytes ∧ + decodeSample packet.coord bytes = grouped packet.coord (T (.inl packet)) ∧ + (⟨.inl packet,T (.inl packet)⟩ : Sigma (Answer p Q iv grinding boundary)) ∈ + (Sampling.execute T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv + program counted)).2 + tapeAt : ∀ (j : Nat) (q : Coord p) (bytes : List Byte), (openingDraws grinding)[j]? = some (some q) → + (drawnBytes grinding data)[j]? = some bytes → + get q col.tape = StackWHIRReplay.projectSample q (decodeSample q bytes) + seedAt : ∀ (j : Nat) (bytes : List Byte), (openingDraws grinding)[j]? = some (some .initial) → + (drawnBytes grinding data)[j]? = some bytes → col.seed = some (decodeSample (.initial : Coord p) bytes) + anchor : ∃ (root0 : Digest32) (h0 : FramedHistory), col.roots[0]? = some root0 ∧ histories[0]? = some h0 ∧ + headerFrames ≤ boundary + 1 ∧ + SpongefishCurrentAnchorHeader.fromHistory (AnchoredSourceCaller.shape layout) + {h0 with frames := h0.frames.take headerFrames} = some root0 + levelRoots : ∀ (i' : Fin (cfg).folds.size) (k : Fin (cfg).folds[i'.val]!) (j' : Nat), + isLastFold i' k = true → i'.val + 1 < (cfg).folds.size → + (openingDraws grinding)[j']? = some (some (.fold i' k)) → + ∃ (root : Digest32) (h : FramedHistory) (previous : Nat) (bytes : List Byte), + col.roots[i'.val + 1]? = some root ∧ histories[j' + 1]? = some h ∧ + h.frames[boundary + j' + 1]? = some (.absorb previous bytes) ∧ + SpongefishCurrentRootPolicy.levelRoot bytes = some root + parsed : ∀ (root : BaseOracle) (next : Nat → Oracle), + SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies root next → + ∀ (j : Nat) (q : Coord p) (h : FramedHistory), (openingDraws grinding)[j]? = some (some q) → + histories[j]? = some h → ∀ t : Tape cfg, (∀ r : Coord p, position r < position q → get r t = get r col.tape) → + ∀ next' : Nat → Oracle, (∀ i, LevelUsed q i → next' i = next i) → + PCSRoundByRoundTranscriptState.priorAnswers + (parse h t (SpongefishCurrentOpeningExperiment.levelOracle root next')) (position q) = + PCSRoundByRoundTranscriptState.priorAnswers + (SpongefishCurrentOpeningExperiment.restoredReplies col next) (position q) + +/-- The view of the source on a table. -/ +noncomputable abbrev viewOf (T : Table Q iv grinding boundary) : View (SpongefishCurrentOpeningProgram.FullResult p) := + Sampling.eval T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted) + +/-- Exactness of the builder on every opening packet of a good table. -/ +theorem builder_exact (T : Table Q iv grinding boundary) (data : SpongefishCurrentMixedModeCompiler.Data) + (col : Collected p) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (seed : RingPCSGame.Prefix × E) (histories : List FramedHistory) + (facts : Facts Q iv grinding boundary headerFrames k instanceBytes layout parse program counted T data col r + input seed histories) + (frozens : Nat → PCSBCSMerkleRootCache.Frozen) + (captured : SpongefishCurrentIdealRows.Captured grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary Q iv (viewOf Q iv grinding boundary program counted T) col frozens) + (rows : SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies + (SpongefishCurrentIdealRows.rootOracle (frozens 0)) (SpongefishCurrentIdealRows.nextOracle frozens)) + (j : Nat) (packet : Packet p Q grinding boundary) + (draw : (openingDraws grinding)[j]? = some (some packet.coord)) + (history : histories[j]? = some packet.history) : + builder Q iv grinding boundary headerFrames k instanceBytes layout parse + (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted) + packet (PCSStateRestoration.Latent.erase (.inl packet) T) = + some (PCSBCSRestorationHazard.literalCallerData p input (SpongefishCurrentIdealRows.rootOracle (frozens 0)) + seed.1 col.tape (SpongefishCurrentOpeningExperiment.restoredReplies col + (SpongefishCurrentIdealRows.nextOracle frozens)) packet.coord) := by + set H := packet.history with HDef + set source := SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted + with sourceDef + set T' := SpongefishCurrentPartitionCapture.otherTable (partition p Q iv grinding boundary) packet + (PCSStateRestoration.Latent.erase (.inl packet) T) with T'Def + set shape := AnchoredSourceCaller.shape layout with shapeDef + have lenH : H.frames.length = boundary + j + 1 := facts.frames j H history + have inside : j < histories.length := (List.getElem?_eq_some_iff.mp history).1 + -- the post-binding coordinate and the caller original + obtain ⟨h0,h0At⟩ : ∃ h0, histories[0]? = some h0 := ⟨_,List.getElem?_eq_getElem (by omega)⟩ + have h0Eq := facts.nested 0 j h0 H (Nat.zero_le _) h0At history + have q0Eq : bindingCoordinate boundary H = SpongefishCurrentGoodEvent.postBinding boundary data := by + rw [facts.postHistory h0 h0At,h0Eq] + rfl + have recordEq : recordAt Q iv k shape (bindingCoordinate boundary H) = some r := by + obtain ⟨work,selected⟩ := facts.record + unfold recordAt + rw [q0Eq,dite_eq_left work] + exact selected + have inputEq := input_exact Q iv grinding boundary program counted T packet layout + (bindingCoordinate boundary H) r instanceBytes input + (by simp only [bindingCoordinate,List.length_take]; omega) (by rw [q0Eq]; exact facts.original) + -- captures of the view + have public_ : ∀ ref, SpongefishCurrentPartitionCapture.pcapture (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) ref source T' = + SpongefishCurrentPartitionCapture.pcapture (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) ref source T → + SpongefishCurrentPartitionCapture.pcapture (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) ref source T' = + SpongefishCurrentRootPolicy.publicCapture (B := Q) p grinding shape headerFrames boundary iv ref + (viewOf Q iv grinding boundary program counted T) := by + intro ref same + rw [same] + exact pcapture_public Q iv grinding boundary shape headerFrames program counted T ref + -- Root0 + have rootEq : frozenAt Q iv grinding boundary source shape headerFrames T' H 0 = some (frozens 0) := by + obtain ⟨root0,h0',rootAt,h0'At,headerLe,header⟩ := facts.anchor + rw [h0At] at h0'At + cases h0'At + have headerH : SpongefishCurrentAnchorHeader.fromHistory shape + {H with frames := H.frames.take headerFrames} = some root0 := by + rw [← header,h0Eq] + simp only [List.take_take] + rw [Nat.min_eq_left (by omega)] + have anchorH : SpongefishCurrentRootPolicy.anchorReference shape headerFrames H = + some (SpongefishCurrentPhysicalRootCapture.reference shape root0) := by + unfold SpongefishCurrentRootPolicy.anchorReference + rw [ite_eq_left (by omega),headerH] + rfl + have member := mentioned Q iv grinding boundary shape headerFrames packet _ + (SpongefishCurrentRootPolicy.anchor_mem p grinding shape headerFrames boundary H root0 (by omega) headerH) + have erased := SpongefishCurrentPartitionCapture.pcapture_erased (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) packet _ member source T + unfold frozenAt rootRef + rw [ite_eq_left rfl,anchorH,Option.bind_some,public_ _ erased] + exact captured 0 root0 (ParameterBounds.production_config_valid p).2.1 rootAt + -- level roots + have levelEq : ∀ (i' : Fin (cfg).folds.size) (kk : Fin (cfg).folds[i'.val]!), isLastFold i' kk = true → + i'.val + 1 < (cfg).folds.size → position (.fold i' kk : Coord p) < position packet.coord → + frozenAt Q iv grinding boundary source shape headerFrames T' H (i'.val+1) = some (frozens (i'.val+1)) := by + intro i' kk last later earlier + have drawC := drawIndex_spec grinding (.fold i' kk) + have lt := draw_lt grinding j _ _ _ drawC draw earlier + obtain ⟨root,h,previous,bytes,rootAt,hAt,frameAt,parsedRoot⟩ := + facts.levelRoots i' kk _ last later drawC + have hEq := facts.nested _ j h H (by omega) hAt history + have frameH : H.frames[boundary + drawIndex grinding (.fold i' kk) + 1]? = some (.absorb previous bytes) := by + rw [hEq] at frameAt + simp only [List.getElem?_take] at frameAt + split at frameAt + · exact frameAt + · omega + have levelAtEq : SpongefishCurrentRootPolicy.levelAt p grinding boundary H (drawIndex grinding (.fold i' kk)) = + some ⟨root,SpongefishCurrentRootPolicy.levelShape p (i'.val+1)⟩ := by + simp only [SpongefishCurrentRootPolicy.levelAt,drawC,last,later,and_self,↓reduceIte,frameH,parsedRoot, + Option.map_some] + have member := mentioned Q iv grinding boundary shape headerFrames packet _ + (SpongefishCurrentRootPolicy.level_mem p grinding shape headerFrames boundary H _ i' kk drawC last later + previous bytes frameH root parsedRoot) + have erased := SpongefishCurrentPartitionCapture.pcapture_erased (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv) packet _ member source T + unfold frozenAt rootRef + rw [ite_eq_right (by omega),lastFold_eq i' kk last,Option.bind_some,levelAtEq,Option.bind_some,public_ _ erased] + have found := captured (i'.val+1) root later rootAt + unfold SpongefishCurrentIdealRows.rootReference at found + rw [ite_eq_right (by omega)] at found + exact found + have nextEq : ∀ i, LevelUsed packet.coord i → + ((frozenAt Q iv grinding boundary source shape headerFrames T' H i).bind + (PCSBCSFrozenOracleRows.frozenOracle i)).getD #[] = SpongefishCurrentIdealRows.nextOracle frozens i := by + intro i used + rcases used with ⟨i',kk,last,later,rfl,earlier⟩ | ⟨i',positive,rfl,earlier⟩ + · rw [levelEq i' kk last later earlier,Option.bind_some] + rfl + · let i0 : Fin (cfg).folds.size := ⟨i'.val - 1,by omega⟩ + have folds0 : 0 < (cfg).folds[i0.val]! := WHIRQueryOracleRecurrence.production_folds_positive p i0 + let k0 : Fin (cfg).folds[i0.val]! := ⟨(cfg).folds[i0.val]! - 1,by omega⟩ + have last0 : isLastFold i0 k0 = true := by + simp only [isLastFold,decide_eq_true_eq,k0] + omega + have before := level_before (p := p) i0.val i'.val (by simp only [i0]; omega) (.fold i0 k0) (.query i') + (fold_mem i0 k0) (query_mem i') + have shift : i0.val + 1 = i'.val := by simp only [i0]; omega + have agreed := levelEq i0 k0 last0 (by omega) (by omega) + rw [shift] at agreed + rw [agreed,Option.bind_some] + rfl + -- tape and ring + have sample : ∀ r : Coord p, position r < position packet.coord → ∃ bytes, + (drawnBytes grinding data)[drawIndex grinding r]? = some bytes ∧ + sampleAt Q iv grinding boundary T' H r = decodeSample r bytes := by + intro r earlier + have drawR := drawIndex_spec grinding r + have lt := draw_lt grinding j _ r packet.coord drawR draw earlier + obtain ⟨P,bytes,coordEq,histP,bytesAt,decoded,_⟩ := facts.packets _ r drawR + subst coordEq + refine ⟨bytes,bytesAt,?_⟩ + have nestP := facts.nested _ j P.history H lt.le histP history + have ne : P ≠ packet := by + intro same + have lengths := facts.frames _ _ histP + have equal := congrArg (fun x : Packet p Q grinding boundary => x.history.frames.length) same + simp only [← HDef] at equal + omega + unfold sampleAt + rw [decoded] + refine congrArg (grouped P.coord) (funext fun b => ?_) + unfold prefixBlocks + rw [← nestP,dite_eq_left (P.bounded b)] + change (partition p Q iv grinding boundary).join T' ((partition p Q iv grinding boundary).encode ⟨P,b⟩) = _ + rw [SpongefishCurrentOpeningPackets.join_encode] + exact congrFun (otherTable_of_ne Q iv grinding boundary packet T (.inl P) (by simpa using ne)) b + have tapes : ∀ r : Coord p, position r < position packet.coord → + get r (tapeOf Q iv grinding boundary T' H packet.coord) = get r col.tape := by + intro r earlier + rw [tapeOf,get_coordinates,ite_eq_left earlier] + obtain ⟨bytes,at_,eq⟩ := sample r earlier + rw [eq,facts.tapeAt _ r bytes (drawIndex_spec grinding r) at_] + have rings : packet.coord ≠ .initial → ringOf Q iv grinding boundary T' H = seed.1 := by + intro different + have earlier : position (.initial : Coord p) < position packet.coord := by + rw [CausalPositions.position_initial] + exact PCSBCSRestorationHazard.noninitial_positive _ different + obtain ⟨bytes,at_,eq⟩ := sample .initial earlier + have seedEq := facts.seedAt _ bytes (drawIndex_spec grinding .initial) at_ + rw [facts.seeded] at seedEq + unfold ringOf + rw [eq,Option.some.inj seedEq] + -- replies + have answers := facts.parsed _ _ rows j packet.coord H draw history + (tapeOf Q iv grinding boundary T' H packet.coord) tapes _ nextEq + -- assembly + unfold builder + dsimp only + rw [← HDef,← T'Def,← shapeDef,recordEq,Option.bind_some,inputEq,Option.bind_some,rootEq,Option.map_some] + refine congrArg some ?_ + exact literalCallerData_congr _ _ _ _ _ _ _ _ _ rings tapes answers + +end Exact + +/-! ## Captures of the walk roots and the state path -/ + +theorem literalRaw_decode (col : Collected p) (seed : RingPCSGame.Prefix × E) (q : Coord p) (bytes : List Byte) + (seeded : col.seed = some seed) + (tape : get q col.tape = StackWHIRReplay.projectSample q (decodeSample q bytes)) + (seedq : q = .initial → col.seed = some (decodeSample (.initial : Coord p) bytes)) : + PCSBCSRestorationHazard.literalRaw seed.1 col.tape q = decodeSample q bytes := by + cases q with + | initial => + have same := seedq rfl + rw [seeded] at same + cases same + simp only [PCSBCSRestorationHazard.literalRaw] + rw [tape] + rfl + | fold i j => exact tape + | ood i j => exact tape + | query i => exact tape + | tail j => exact tape + +theorem ne_initial_of_position (q : Coord p) (moved : position q ≠ 0) : q ≠ .initial := by + intro same + rw [same,CausalPositions.position_initial] at moved + exact moved rfl + +section Path +variable (Q : Nat) (iv : Digest32) (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (boundary headerFrames k : Nat) (instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + (parse : FramedHistory → Tape (ParameterBounds.config p) → (Nat → Oracle) → Array Reply) + (program : Program (SpongefishCurrentOpeningProgram.FullResult p)) (counted : Counts Q program) + +/-- Every walk root below the number of levels is first-mentioned by the packet of the last coordinate, so it has a first-mention capture in the view. -/ +theorem captures_exist (T : Table Q iv grinding boundary) (data : SpongefishCurrentMixedModeCompiler.Data) + (col : Collected p) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (seed : RingPCSGame.Prefix × E) (histories : List FramedHistory) + (facts : Facts Q iv grinding boundary headerFrames k instanceBytes layout parse program counted T data col r + input seed histories) : + ∃ frozens, SpongefishCurrentIdealRows.Captured grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary Q iv (viewOf Q iv grinding boundary program counted T) col frozens := by + classical + let shape := AnchoredSourceCaller.shape layout + let source := SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted + let last := PCSRoundByRoundTranscriptState.lastCoordinate cfg + obtain ⟨PL,bytesL,coordL,histL,_,_,recordedL⟩ := facts.packets _ last (drawIndex_spec grinding last) + have lenL := facts.frames _ _ histL + have visited : (.inl PL : Key p Q iv grinding boundary) ∈ + (Sampling.execute T source).2.map Sigma.fst := List.mem_map.mpr ⟨_,recordedL,rfl⟩ + have exists_ : ∀ ref, ref ∈ SpongefishCurrentRootPolicy.references p grinding shape headerFrames boundary + PL.history → ∃ f, SpongefishCurrentRootPolicy.publicCapture (B := Q) p grinding shape headerFrames + boundary iv ref (viewOf Q iv grinding boundary program counted T) = some f := by + intro ref member + obtain ⟨before,found⟩ := PCSBCSFirstRootDisclosure.first_mention_exists + (SpongefishCurrentPartitionCapture.paddr (partition p Q iv grinding boundary) + (SpongefishCurrentRootPolicy.addresses p grinding shape headerFrames boundary iv)) _ ref + (mentioned Q iv grinding boundary shape headerFrames PL ref member) source T visited + rw [← pcapture_public Q iv grinding boundary shape headerFrames program counted T ref] + exact ⟨_,by unfold SpongefishCurrentPartitionCapture.pcapture; rw [found]; rfl⟩ + have each : ∀ i root, i < (cfg).folds.size → col.roots[i]? = some root → + ∃ f, SpongefishCurrentRootPolicy.publicCapture (B := Q) p grinding shape headerFrames boundary iv + (SpongefishCurrentIdealRows.rootReference p shape i root) (viewOf Q iv grinding boundary program counted T) = + some f := by + intro i root small rootAt + cases i with + | zero => + obtain ⟨root0,h0,root0At,h0At,headerLe,header⟩ := facts.anchor + rw [rootAt] at root0At + cases root0At + have h0Eq := facts.nested 0 _ h0 PL.history (Nat.zero_le _) h0At histL + have headerH : SpongefishCurrentAnchorHeader.fromHistory shape + {PL.history with frames := PL.history.frames.take headerFrames} = some root := by + rw [← header,h0Eq] + simp only [List.take_take] + rw [Nat.min_eq_left (by omega)] + exact exists_ _ (SpongefishCurrentRootPolicy.anchor_mem p grinding shape headerFrames boundary + PL.history root (by omega) headerH) + | succ i0 => + let i' : Fin (cfg).folds.size := ⟨i0,by omega⟩ + have folds0 : 0 < (cfg).folds[i'.val]! := WHIRQueryOracleRecurrence.production_folds_positive p i' + let kk : Fin (cfg).folds[i'.val]! := ⟨(cfg).folds[i'.val]! - 1,by omega⟩ + have lastK : isLastFold i' kk = true := by + simp only [isLastFold,decide_eq_true_eq,kk] + omega + have drawC := drawIndex_spec grinding (.fold i' kk) + have earlier : position (.fold i' kk : Coord p) < position last := + lt_of_lt_of_le (fold_lt_query i' kk col.tape) + (PCSRoundByRoundTranscriptState.lastCoordinate_max cfg _) + have lt := draw_lt grinding _ _ _ last drawC (drawIndex_spec grinding last) earlier + obtain ⟨root',h,previous,bytes,root'At,hAt,frameAt,parsedRoot⟩ := + facts.levelRoots i' kk _ lastK small drawC + rw [rootAt] at root'At + cases root'At + have hEq := facts.nested _ _ h PL.history (by omega) hAt histL + have frameH : PL.history.frames[boundary + drawIndex grinding (.fold i' kk) + 1]? = + some (.absorb previous bytes) := by + rw [hEq] at frameAt + simp only [List.getElem?_take] at frameAt + split at frameAt + · exact frameAt + · omega + have member := SpongefishCurrentRootPolicy.level_mem p grinding shape headerFrames boundary PL.history _ i' kk + drawC lastK small previous bytes frameH root parsedRoot + obtain ⟨f,found⟩ := exists_ _ member + refine ⟨f,?_⟩ + unfold SpongefishCurrentIdealRows.rootReference + rw [ite_eq_right (by omega)] + exact found + have nonempty : Nonempty PCSBCSMerkleRootCache.Frozen := by + obtain ⟨root0,_,root0At,_⟩ := facts.anchor + obtain ⟨f,_⟩ := each 0 root0 (ParameterBounds.production_config_valid p).2.1 root0At + exact ⟨f⟩ + refine ⟨fun i => Classical.epsilon fun f => ∀ root, col.roots[i]? = some root → + SpongefishCurrentRootPolicy.publicCapture (B := Q) p grinding shape headerFrames boundary iv + (SpongefishCurrentIdealRows.rootReference p shape i root) (viewOf Q iv grinding boundary program counted T) = + some f,?_⟩ + intro i root small rootAt + obtain ⟨f,found⟩ := each i root small rootAt + have spec := Classical.epsilon_spec (p := fun f => ∀ root, col.roots[i]? = some root → + SpongefishCurrentRootPolicy.publicCapture (B := Q) p grinding shape headerFrames boundary iv + (SpongefishCurrentIdealRows.rootReference p shape i root) (viewOf Q iv grinding boundary program counted T) = + some f) ⟨f,fun root' at' => by rw [rootAt] at at'; cases at'; exact found⟩ + exact spec root rootAt + +/-- The literal state path on a good table: the packets of all coordinates in schedule order are recorded, each reconstructed node is the literal caller data, neighbouring states are linked by the literal before/after identities, the initial state is undoomed and the terminal state is the literal final state. -/ +theorem statePath (T : Table Q iv grinding boundary) (data : SpongefishCurrentMixedModeCompiler.Data) + (col : Collected p) (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p) + (seed : RingPCSGame.Prefix × E) (histories : List FramedHistory) + (facts : Facts Q iv grinding boundary headerFrames k instanceBytes layout parse program counted T data col r + input seed histories) + (frozens : Nat → PCSBCSMerkleRootCache.Frozen) + (captured : SpongefishCurrentIdealRows.Captured grinding (AnchoredSourceCaller.shape layout) headerFrames + boundary Q iv (viewOf Q iv grinding boundary program counted T) col frozens) + (rows : SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies + (SpongefishCurrentIdealRows.rootOracle (frozens 0)) (SpongefishCurrentIdealRows.nextOracle frozens)) + (terminal : PCSBCSRestorationHazard.literalState p input (SpongefishCurrentIdealRows.rootOracle (frozens 0)) + seed.1 col.tape (SpongefishCurrentOpeningExperiment.restoredReplies col + (SpongefishCurrentIdealRows.nextOracle frozens)) (PCSRoundByRoundTranscriptState.lastCoordinate cfg) = true) : + PCSStateRestoration.Latent.StatePath + (model p Q iv grinding boundary (builder Q iv grinding boundary headerFrames k instanceBytes layout parse + (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted))) + T (Sampling.execute T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv + program counted)).2 false true := by + classical + let build := builder Q iv grinding boundary headerFrames k instanceBytes layout parse + (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted) + let root := SpongefishCurrentIdealRows.rootOracle (frozens 0) + let replies := SpongefishCurrentOpeningExperiment.restoredReplies col (SpongefishCurrentIdealRows.nextOracle frozens) + have choose : ∀ q : Coord p, ∃ P : Packet p Q grinding boundary, P.coord = q ∧ + (openingDraws grinding)[drawIndex grinding q]? = some (some P.coord) ∧ + histories[drawIndex grinding q]? = some P.history ∧ + (⟨.inl P,T (.inl P)⟩ : Sigma (Answer p Q iv grinding boundary)) ∈ + (Sampling.execute T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv + program counted)).2 ∧ + grouped P.coord (T (.inl P)) = PCSBCSRestorationHazard.literalRaw seed.1 col.tape P.coord := by + intro q + have drawQ := drawIndex_spec grinding q + obtain ⟨P,bytes,coordEq,hist,bytesAt,decoded,recorded⟩ := facts.packets _ q drawQ + subst coordEq + refine ⟨P,rfl,drawQ,hist,recorded,?_⟩ + rw [← decoded] + exact (literalRaw_decode col seed P.coord bytes facts.seeded (facts.tapeAt _ _ bytes drawQ bytesAt) + (fun initial => facts.seedAt _ bytes (initial ▸ drawQ) bytesAt)).symm + let pk : Coord p → Packet p Q grinding boundary := fun q => Classical.choose (choose q) + have pkSpec := fun q => Classical.choose_spec (choose q) + have assembled : ∀ q, build (pk q) (PCSStateRestoration.Latent.erase (.inl (pk q)) T) = + some (PCSBCSRestorationHazard.literalCallerData p input root seed.1 col.tape replies q) := by + intro q + obtain ⟨coordEq,drawQ,hist,_,_⟩ := pkSpec q + have exact := builder_exact Q iv grinding boundary headerFrames k instanceBytes layout parse program counted + T data col r input seed histories facts frozens captured rows _ (pk q) drawQ hist + rw [coordEq] at exact + exact exact + have afterEq : ∀ q, PCSStateRestoration.Latent.after (model p Q iv grinding boundary build) (.inl (pk q)) T = + PCSBCSRestorationHazard.literalState p input root seed.1 col.tape replies q := by + intro q + obtain ⟨coordEq,_,_,_,raw⟩ := pkSpec q + change (match build (pk q) (PCSStateRestoration.Latent.erase (.inl (pk q)) T) with + | some caller => (callerCertificate p).after caller (pk q).coord (grouped (pk q).coord (T (.inl (pk q)))) + | none => false) = _ + rw [assembled q,raw,coordEq] + exact PCSBCSRestorationHazard.literal_after p input root seed.1 col.tape replies q + have beforeEq : ∀ q (different : q ≠ .initial), + PCSStateRestoration.Latent.before (model p Q iv grinding boundary build) (.inl (pk q)) T = + PCSBCSRestorationHazard.literalState p input root seed.1 col.tape replies + (PCSRoundByRoundTranscriptState.predecessor q (PCSBCSRestorationHazard.noninitial_positive q different)) := by + intro q different + obtain ⟨coordEq,_,_,_,_⟩ := pkSpec q + have recovered : PCSStateRestoration.Latent.publicNode (model p Q iv grinding boundary build) (.inl (pk q)) T = + some (PCSBCSRestorationHazard.literalCallerData p input root seed.1 col.tape replies q) := assembled q + unfold PCSStateRestoration.Latent.before + rw [recovered] + change (callerCertificate p).before (PCSBCSRestorationHazard.literalCallerData p input root seed.1 col.tape + replies q) (pk q).coord = _ + rw [coordEq] + exact PCSBCSRestorationHazard.literal_before p input root seed.1 col.tape replies q different + have initialEq : PCSStateRestoration.Latent.before (model p Q iv grinding boundary build) + (.inl (pk .initial)) T = false := by + obtain ⟨coordEq,_,_,_,_⟩ := pkSpec .initial + have recovered : PCSStateRestoration.Latent.publicNode (model p Q iv grinding boundary build) + (.inl (pk .initial)) T = + some (PCSBCSRestorationHazard.literalCallerData p input root seed.1 col.tape replies .initial) := + assembled .initial + unfold PCSStateRestoration.Latent.before + rw [recovered] + change (callerCertificate p).before (PCSBCSRestorationHazard.literalCallerData p input root seed.1 col.tape + replies .initial) (pk .initial).coord = false + rw [coordEq] + rfl + apply PCSBCSLiteralStatePath.of_round_links _ T _ + ((WHIRHistory.schedule cfg).map fun q => (.inl (pk q) : Key p Q iv grinding boundary)) false true + · intro key member + obtain ⟨q,_,rfl⟩ := List.mem_map.mp member + exact (pkSpec q).2.2.2.1 + · intro i hi + have bound : i + 1 < (WHIRHistory.schedule cfg).length := by simpa only [List.length_map] using hi + simp only [List.getElem_map] + have positionI : position ((WHIRHistory.schedule cfg)[i]'(by omega)) = i := + WHIRHistory.position_schedule_get cfg ⟨i,by unfold WHIRHistory.depth; omega⟩ + have positionJ : position ((WHIRHistory.schedule cfg)[i+1]'bound) = i + 1 := + WHIRHistory.position_schedule_get cfg ⟨i+1,by unfold WHIRHistory.depth; omega⟩ + have different := ne_initial_of_position _ (by rw [positionJ]; omega) + have predEq : PCSRoundByRoundTranscriptState.predecessor ((WHIRHistory.schedule cfg)[i+1]'(by omega)) + (PCSBCSRestorationHazard.noninitial_positive _ different) = (WHIRHistory.schedule cfg)[i]'(by omega) := by + apply CausalPrefix.position_injective + rw [PCSRoundByRoundTranscriptState.predecessor_position,positionI,positionJ] + rfl + rw [afterEq,beforeEq _ different,predEq] + · intro key head + have first : (WHIRHistory.schedule cfg).head? = some .initial := by + have at0 := WHIRHistory.schedule_get_position (.initial : Coord p) + rw [CausalPositions.position_initial] at at0 + simpa only [List.head?_eq_getElem?] using at0 + simp only [List.head?_map,first,Option.map_some,Option.some.injEq] at head + rw [← head] + exact initialEq + · intro key final + rw [List.getLast?_map] at final + obtain ⟨q,atLast,rfl⟩ := Option.map_eq_some_iff.mp final + have isLast : q = PCSRoundByRoundTranscriptState.lastCoordinate cfg := by + apply CausalPrefix.position_injective + rw [PCSBCSCapturedSourceStatePath.lastCoordinate_position] + rw [List.getLast?_eq_getElem?] at atLast + obtain ⟨inside,stored⟩ := List.getElem?_eq_some_iff.mp atLast + rw [← stored] + exact WHIRHistory.position_schedule_get cfg ⟨WHIRHistory.depth cfg - 1,inside⟩ + rw [afterEq,isLast] + exact terminal + · intro empty + have member := WHIRHistory.coordinate_mem_schedule (.initial : Coord p) + rw [List.map_eq_nil_iff.mp empty] at member + cases member + +end Path + +/-! ## Refinement -/ + +section Refines +variable (Q : Nat) (iv : Digest32) (grinding : Fin (ParameterBounds.config p).folds.size → Fin 64) + (boundary headerFrames k : Nat) (instanceBytes : List Byte) (layout : WHIRCallerClaims.CallerLayout) + +/-- `Refines` for the public good event, for any counted program and reply parser, from the good-table facts and, for every family of root captures, row authentication and the literal terminal state. -/ +theorem refines_of_facts + (parse : FramedHistory → Tape (ParameterBounds.config p) → (Nat → Oracle) → Array Reply) + (program : Program (SpongefishCurrentOpeningProgram.FullResult p)) (counted : Counts Q program) + (facts : ∀ T : Table Q iv grinding boundary, + SpongefishCurrentGoodEvent.GoodFull Q iv instanceBytes layout grinding headerFrames boundary k + (viewOf Q iv grinding boundary program counted T) → + ∃ (data : SpongefishCurrentMixedModeCompiler.Data) (col : Collected p) (r : SpongefishSessionAdapter.Record) + (input : PCSBCSCallerBinding.CallerInput p) (seed : RingPCSGame.Prefix × E) (histories : List FramedHistory), + Facts Q iv grinding boundary headerFrames k instanceBytes layout parse program counted T data col r input + seed histories ∧ + ∀ frozens : Nat → PCSBCSMerkleRootCache.Frozen, + SpongefishCurrentIdealRows.Captured grinding (AnchoredSourceCaller.shape layout) headerFrames boundary Q + iv (viewOf Q iv grinding boundary program counted T) col frozens → + SpongefishCurrentOpeningExperiment.RowsAuthenticated col.tape col.replies + (SpongefishCurrentIdealRows.rootOracle (frozens 0)) (SpongefishCurrentIdealRows.nextOracle frozens) ∧ + PCSBCSRestorationHazard.literalState p input (SpongefishCurrentIdealRows.rootOracle (frozens 0)) seed.1 + col.tape (SpongefishCurrentOpeningExperiment.restoredReplies col + (SpongefishCurrentIdealRows.nextOracle frozens)) (PCSRoundByRoundTranscriptState.lastCoordinate cfg) = + true) : + SpongefishCurrentBCSKnowledge.Refines (partition p Q iv grinding boundary) + (model p Q iv grinding boundary (builder Q iv grinding boundary headerFrames k instanceBytes layout parse + (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv program counted))) + iv program counted (SpongefishCurrentGoodEvent.goodFull Q iv instanceBytes layout grinding headerFrames + boundary k) := by + intro T good + simp only [SpongefishCurrentGoodEvent.goodFull,decide_eq_true_eq] at good + obtain ⟨data,col,r,input,seed,histories,facts,extra⟩ := facts T good + obtain ⟨frozens,captured⟩ := captures_exist Q iv grinding boundary headerFrames k instanceBytes layout parse + program counted T data col r input seed histories facts + obtain ⟨rows,terminal⟩ := extra frozens captured + exact statePath Q iv grinding boundary headerFrames k instanceBytes layout parse program counted T data col r + input seed histories facts frozens captured rows terminal + +/-- The opening phase returns the source result unchanged as its first component. -/ +theorem phase_first {Q' : Nat} {Seed State : Type} (sim : Simulator Q' Seed State) (ro : RawKey Q' → Digest32) + (iv : Digest32) (state : State) (decode : SpongefishCurrentOpeningProgram.Decoder) (lanes index offset : Nat) + (res : SpongefishCurrentSourceJoinProbability.SourceResult) (rest : Nat) (cap : rest ≤ Q') + (counted : Counts rest (SpongefishCurrentOpeningProgram.openingPhase (p := p) decode grinding lanes index + offset res)) : + (runIdeal sim ro iv state (SpongefishCurrentOpeningProgram.openingPhase (p := p) decode grinding lanes index + offset res) rest cap counted).view.result.1 = res := by + revert counted + rcases res with _ | (e | data) + · intro counted + rfl + · intro counted + rfl + · dsimp only [SpongefishCurrentOpeningProgram.openingPhase] + split + · intro counted + rfl + · intro counted + obtain ⟨_,_,_,_,same⟩ := SpongefishCurrentOpeningPackets.ideal_bind sim ro iv _ _ state rest cap counted + rw [same] + rfl + +open SpongefishCurrentOpeningProgram in +/-- `Refines` of the current round node model for the full source program, with the history reply parser. The remaining hypotheses are static (`supported`, the opening frame shape `opening` and `headerLe`) and the two header glue facts: on every successful view the opening events of the walk are the opening-call events, and, for the public caller candidate of the good event, the commitment header frame of the post-binding history carries the walk's header root. -/ +theorem refines_full + (supported : SpongefishCurrentAnchorAttackerPrefix.Supported p (AnchoredSourceCaller.shape layout)) + (tag : List Byte) (before payloadCalls messages : List SpongefishPCSRoundFrames.Call) (decode : Decoder) + (prefixProgram : Program SpongefishCurrentInitializedMode.Input) + (counted : Counts Q (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding + prefixProgram)) + (opening : SpongefishCurrentOpeningPackets.openingShape instanceBytes (before ++ + SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ payloadCalls ++ + messages) = (boundary,true)) + (headerLe : headerFrames ≤ boundary + 1) + (events : ∀ (T : Table Q iv grinding boundary) (data : SpongefishCurrentMixedModeCompiler.Data) + (col : Collected p), + (viewOf Q iv grinding boundary (fullProgram iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram) counted T).result = (some (.ok data),some col) → + openingEvents (openingOffset layout before payloadCalls messages) data = + SpongefishCurrentOpeningPackets.openingEvents grinding data.events) + (header : ∀ (T : Table Q iv grinding boundary) (data : SpongefishCurrentMixedModeCompiler.Data) + (col : Collected p), + (viewOf Q iv grinding boundary (fullProgram iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram) counted T).result = (some (.ok data),some col) → + ∀ (r : SpongefishSessionAdapter.Record) (input : PCSBCSCallerBinding.CallerInput p), + SpongefishCurrentSourceCallerOriginal.candidate (Q := Q) p layout + (SpongefishCurrentGoodEvent.postBinding boundary data) r instanceBytes + (viewOf Q iv grinding boundary (fullProgram iv tag instanceBytes layout before payloadCalls messages decode + grinding prefixProgram) counted T).observations = some input → + ∀ root0, headerRoot (rootIndex before) data.events = some root0 → + SpongefishCurrentAnchorHeader.fromHistory (AnchoredSourceCaller.shape layout) + {(SpongefishCurrentGoodEvent.postBinding boundary data).history with + frames := (SpongefishCurrentGoodEvent.postBinding boundary data).history.frames.take headerFrames} = + some root0) : + SpongefishCurrentBCSKnowledge.Refines (partition p Q iv grinding boundary) + (model p Q iv grinding boundary (builder Q iv grinding boundary headerFrames k instanceBytes layout + (SpongefishCurrentHistoryReplies.historyReplies grinding boundary) + (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv + (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram) + counted))) + iv (fullProgram iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram) counted + (SpongefishCurrentGoodEvent.goodFull Q iv instanceBytes layout grinding headerFrames boundary k) := by + apply refines_of_facts + intro T good + have goodCopy := good + obtain ⟨data,col,r,input,result,record,original,verdict,fails,_,quiet⟩ := goodCopy + have verdictCopy := verdict + obtain ⟨seed,_,seeded,_,_⟩ := verdictCopy + -- the initialized part succeeded + have success : (Sampling.eval T (SpongefishCurrentBCSKnowledge.source (partition p Q iv grinding boundary) iv + (SpongefishCurrentInitializedMode.afterPrefix iv tag instanceBytes prefixProgram + ((before ++ SpongefishCurrentAcceptedJoin.headerCalls (AnchoredSourceCaller.shape layout).logN ++ + payloadCalls ++ messages) ++ openingCalls grinding)) + (WHIRModeFinal.bind_prefix_counted _ _ Q counted))).result = some (.ok data) := by + obtain ⟨state,rest,cap,counted',same⟩ := SpongefishCurrentOpeningPackets.source_bind + (partition p Q iv grinding boundary) iv + (SpongefishCurrentSourceJoinProbability.program iv tag instanceBytes layout before payloadCalls messages + grinding prefixProgram) + (openingPhase decode grinding (AnchoredSourceCaller.shape layout).lanes (rootIndex before) + (openingOffset layout before payloadCalls messages)) counted T + have first := congrArg (fun v => v.result.1) same + simp only [phase_first] at first + have firstResult := congrArg Prod.fst result + exact first.symm.trans firstResult + obtain ⟨histories,length,frames,nested,_,_,packets,calls,_,framesAt,content,postHistory⟩ := + SpongefishCurrentHistoryReplies.opening_frames Q iv grinding boundary tag instanceBytes _ prefixProgram _ + counted opening T data success + obtain ⟨root0,headerAt,walked,_⟩ := SpongefishCurrentIdealRows.ideal_walk (partition p Q iv grinding boundary) + iv tag instanceBytes layout before payloadCalls messages decode grinding prefixProgram counted T data col result + rw [events T data col result] at walked + have rootAt := SpongefishCurrentHistoryReplies.root_start _ decode grinding _ root0 _ col calls walked + refine ⟨data,col,r,input,seed,histories,⟨record,original,seeded,postHistory,frames,nested,packets, + fun j q bytes found drawn => SpongefishCurrentHistoryReplies.tape_draw _ decode grinding _ root0 _ col calls + walked j q bytes found drawn, + fun j bytes found drawn => SpongefishCurrentHistoryReplies.seed_draw _ decode grinding _ root0 _ col calls + walked j bytes found drawn,?_, + fun i' kk j' last more found => SpongefishCurrentHistoryReplies.level_roots_of_frames _ decode grinding _ root0 _ + col calls walked boundary histories length content i' kk j' last more found, + fun root next rows j q h found hAt t agree next' levels => + SpongefishCurrentHistoryReplies.replies_exact_local _ decode grinding _ root0 _ col calls walked j q found + boundary h (framesAt j h hAt).1 root next rows t agree next' levels⟩, + fun frozens captured => ⟨SpongefishCurrentIdealRows.ideal_rows (partition p Q iv grinding boundary) iv tag + instanceBytes layout before payloadCalls messages decode grinding prefixProgram counted T headerFrames + boundary supported data col result quiet frozens captured, + SpongefishCurrentIdealRows.ideal_terminal (partition p Q iv grinding boundary) iv tag instanceBytes layout + before payloadCalls messages decode grinding prefixProgram counted T headerFrames boundary supported data + col result r input original verdict fails quiet frozens captured seed seeded⟩⟩ + obtain ⟨h0,h0At⟩ : ∃ h0, histories[0]? = some h0 := by + obtain ⟨j,found⟩ := SpongefishCurrentOpeningPackets.openingDraws_complete grinding (.initial : Coord p) + (WHIRHistory.coordinate_mem_schedule _) (width_ne _) + have inside := (List.getElem?_eq_some_iff.mp found).1 + exact ⟨_,List.getElem?_eq_getElem (by omega)⟩ + refine ⟨root0,h0,rootAt,h0At,headerLe,?_⟩ + have fromHeader := header T data col result r input original root0 headerAt + rw [postHistory h0 h0At] at fromHeader + exact fromHeader + +end Refines + +#print axioms widths_deployed +#print axioms draw_lt +#print axioms level_before +#print axioms input_exact +#print axioms builder_exact +#print axioms captures_exist +#print axioms statePath +#print axioms refines_of_facts +#print axioms refines_full + +end Whir.SpongefishCurrentRefines